From f89e687efa9bee93d92f7ed357be0f657c7126a9 Mon Sep 17 00:00:00 2001 From: Josh Berdine Date: Fri, 20 Oct 2017 09:16:57 -0700 Subject: [PATCH] [ocamlformat] Use ocamlformat from github Summary: Install ocamlformat from github as part of `make devsetup`, and use it for formatting OCaml (and jbuild) code. Reviewed By: jvillard Differential Revision: D6092464 fbshipit-source-id: 4ba0845 --- .ocamlformat | 1 + CONTRIBUTING.md | 2 +- Makefile | 14 +- infer/src/IR/Annot.ml | 2 + infer/src/IR/Attributes.ml | 28 +- infer/src/IR/Binop.ml | 135 +- infer/src/IR/BuiltinDecl.ml | 3 + infer/src/IR/CallFlags.ml | 2 + infer/src/IR/Cfg.ml | 173 +- infer/src/IR/Cg.ml | 83 +- infer/src/IR/Const.ml | 59 +- infer/src/IR/DecompiledExp.ml | 115 +- infer/src/IR/Errlog.ml | 110 +- infer/src/IR/Exceptions.ml | 291 +-- infer/src/IR/Exceptions.mli | 6 +- infer/src/IR/Exp.ml | 189 +- infer/src/IR/HilExp.ml | 172 +- infer/src/IR/HilInstr.ml | 99 +- infer/src/IR/Ident.ml | 42 +- infer/src/IR/IntLit.ml | 36 +- infer/src/IR/Io_infer.ml | 55 +- infer/src/IR/LintIssues.ml | 28 +- infer/src/IR/Localise.ml | 383 ++-- infer/src/IR/Location.ml | 3 + infer/src/IR/Mangled.ml | 1 + infer/src/IR/Mleak_buckets.ml | 22 +- infer/src/IR/Objc_models.ml | 34 +- infer/src/IR/PredSymb.ml | 186 +- infer/src/IR/ProcAttributes.ml | 2 + infer/src/IR/Procdesc.ml | 142 +- infer/src/IR/Pvar.ml | 115 +- infer/src/IR/QualifiedCppName.ml | 19 +- infer/src/IR/Sil.ml | 1278 ++++++------ infer/src/IR/Subtype.ml | 156 +- infer/src/IR/Tenv.ml | 53 +- infer/src/IR/Typ.ml | 914 +++++---- infer/src/absint/AbstractDomain.ml | 119 +- infer/src/absint/AbstractInterpreter.ml | 44 +- infer/src/absint/Checkers.ml | 42 +- infer/src/absint/FormalMap.ml | 3 + infer/src/absint/LowerHil.ml | 19 +- infer/src/absint/NodePrinter.ml | 10 +- infer/src/absint/PatternMatch.ml | 326 +-- infer/src/absint/ProcCfg.ml | 31 +- infer/src/absint/Scheduler.ml | 5 + infer/src/absint/Summary.ml | 9 +- infer/src/absint/Var.ml | 9 +- infer/src/atd/jbuild.in | 3 +- infer/src/backend/Attribute.ml | 264 +-- infer/src/backend/BuiltinDefn.ml | 641 +++--- infer/src/backend/Differential.ml | 14 +- infer/src/backend/DifferentialFilters.ml | 96 +- infer/src/backend/InferAnalyze.ml | 67 +- infer/src/backend/InferPrint.ml | 489 +++-- infer/src/backend/OndemandCapture.ml | 11 +- infer/src/backend/PerfStats.ml | 10 +- infer/src/backend/PropUtil.ml | 97 +- infer/src/backend/StatsAggregator.ml | 66 +- infer/src/backend/Tasks.ml | 11 +- infer/src/backend/abs.ml | 666 ++++--- infer/src/backend/absarray.ml | 289 +-- infer/src/backend/buckets.ml | 93 +- infer/src/backend/builtin.ml | 13 +- infer/src/backend/callbacks.ml | 44 +- infer/src/backend/callbacks.mli | 3 +- infer/src/backend/cluster.ml | 4 + infer/src/backend/clusterMakefile.ml | 10 +- infer/src/backend/crashcontext.ml | 54 +- infer/src/backend/dom.ml | 1251 ++++++------ infer/src/backend/dotty.ml | 915 +++++---- infer/src/backend/errdesc.ml | 1050 +++++----- infer/src/backend/exe_env.ml | 108 +- infer/src/backend/infer.ml | 84 +- infer/src/backend/inferconfig.ml | 180 +- infer/src/backend/interproc.ml | 412 ++-- infer/src/backend/match.ml | 679 ++++--- infer/src/backend/mergeCapture.ml | 32 +- infer/src/backend/ondemand.ml | 78 +- infer/src/backend/paths.ml | 284 +-- infer/src/backend/preanal.ml | 122 +- infer/src/backend/printer.ml | 250 +-- infer/src/backend/prop.ml | 1770 +++++++++-------- infer/src/backend/propgraph.ml | 243 +-- infer/src/backend/propset.ml | 5 + infer/src/backend/prover.ml | 1622 ++++++++------- infer/src/backend/rearrange.ml | 837 ++++---- infer/src/backend/reporting.ml | 14 +- infer/src/backend/specs.ml | 294 +-- infer/src/backend/state.ml | 104 +- infer/src/backend/symExec.ml | 1000 +++++----- infer/src/backend/tabulation.ml | 703 ++++--- infer/src/backend/timeout.ml | 64 +- infer/src/base/CommandDoc.ml | 12 + infer/src/base/CommandLineOption.ml | 336 ++-- infer/src/base/Config.ml | 484 +++-- infer/src/base/DB.ml | 89 +- infer/src/base/Die.ml | 34 +- infer/src/base/Die.mli | 5 +- infer/src/base/Epilogues.ml | 19 +- infer/src/base/Escape.ml | 135 +- infer/src/base/IssueType.ml | 21 + infer/src/base/Latex.ml | 36 +- infer/src/base/Logging.ml | 132 +- infer/src/base/MarkupFormatter.ml | 11 +- infer/src/base/MergeResults.ml | 22 +- infer/src/base/Multilinks.ml | 16 +- infer/src/base/Pp.ml | 42 +- infer/src/base/PrettyPrintable.ml | 15 +- infer/src/base/Process.ml | 23 +- infer/src/base/ProcessPool.ml | 22 +- infer/src/base/ProcessPool.mli | 2 +- infer/src/base/ResultsDir.ml | 26 +- infer/src/base/ResultsDir.mli | 2 +- infer/src/base/Serialization.ml | 31 +- infer/src/base/SourceFile.ml | 104 +- infer/src/base/SqliteUtils.ml | 56 +- infer/src/base/SqliteUtils.mli | 5 +- infer/src/base/StatisticsToolbox.ml | 3 + infer/src/base/SymOp.ml | 64 +- infer/src/base/SymOp.mli | 2 +- infer/src/base/Utils.ml | 143 +- infer/src/base/ZipLib.ml | 86 +- infer/src/bufferoverrun/absLoc.ml | 23 +- infer/src/bufferoverrun/arrayBlk.ml | 30 +- .../src/bufferoverrun/bufferOverrunChecker.ml | 440 ++-- .../src/bufferoverrun/bufferOverrunDomain.ml | 160 +- .../bufferOverrunProofObligations.ml | 170 +- .../bufferoverrun/bufferOverrunSemantics.ml | 570 +++--- infer/src/bufferoverrun/bufferOverrunTrace.ml | 31 +- infer/src/bufferoverrun/itv.ml | 910 +++++---- infer/src/checkers/BoundedCallTree.ml | 94 +- infer/src/checkers/IdAccessPathMapDomain.ml | 27 +- infer/src/checkers/NullabilityCheck.ml | 56 +- infer/src/checkers/NullabilityPreanalysis.ml | 50 +- infer/src/checkers/NullabilitySuggest.ml | 133 +- infer/src/checkers/SimpleChecker.ml | 6 +- infer/src/checkers/Sink.ml | 9 +- infer/src/checkers/SinkTrace.ml | 19 +- infer/src/checkers/Siof.ml | 124 +- infer/src/checkers/SiofTrace.ml | 4 + infer/src/checkers/Source.ml | 12 +- infer/src/checkers/Stacktrace.ml | 22 +- infer/src/checkers/Trace.ml | 107 +- infer/src/checkers/accessPath.ml | 208 +- infer/src/checkers/accessPathDomains.ml | 13 +- infer/src/checkers/accessTree.ml | 181 +- infer/src/checkers/addressTaken.ml | 38 +- infer/src/checkers/annotationReachability.ml | 217 +- infer/src/checkers/annotations.ml | 27 +- infer/src/checkers/constantPropagation.ml | 87 +- infer/src/checkers/dataflow.ml | 33 +- .../checkers/fragmentRetainsViewChecker.ml | 27 +- infer/src/checkers/idenv.ml | 23 +- infer/src/checkers/immutableChecker.ml | 20 +- infer/src/checkers/liveness.ml | 47 +- infer/src/checkers/printfArgs.ml | 135 +- infer/src/checkers/registerCheckers.ml | 24 +- infer/src/checkers/repeatedCallsChecker.ml | 87 +- infer/src/checkers/uninit.ml | 79 +- infer/src/checkers/uninitDomain.ml | 5 + infer/src/clang/ALVar.ml | 52 +- infer/src/clang/CLintersContext.ml | 3 + infer/src/clang/CProcname.ml | 149 +- infer/src/clang/CTLExceptions.ml | 12 +- infer/src/clang/CTLExceptions.mli | 10 +- infer/src/clang/CTLParserHelper.ml | 18 +- infer/src/clang/CType.ml | 71 +- infer/src/clang/CType_decl.ml | 259 +-- infer/src/clang/Capture.ml | 76 +- infer/src/clang/CiOSVersionNumbers.ml | 24 +- infer/src/clang/ClangCommand.ml | 52 +- infer/src/clang/ClangPointers.ml | 43 +- infer/src/clang/ClangWrapper.ml | 51 +- infer/src/clang/ComponentKit.ml | 237 ++- infer/src/clang/ast_expressions.ml | 169 +- infer/src/clang/cArithmetic_trans.ml | 338 ++-- infer/src/clang/cAst_utils.ml | 336 ++-- infer/src/clang/cContext.ml | 87 +- infer/src/clang/cEnum_decl.ml | 37 +- infer/src/clang/cField_decl.ml | 81 +- infer/src/clang/cFrontend.ml | 15 +- infer/src/clang/cFrontend_checkers.ml | 129 +- infer/src/clang/cFrontend_checkers_main.ml | 249 +-- infer/src/clang/cFrontend_config.ml | 3 + infer/src/clang/cFrontend_decl.ml | 217 +- infer/src/clang/cFrontend_errors.ml | 390 ++-- infer/src/clang/cGeneral_utils.ml | 126 +- infer/src/clang/cIssue.ml | 10 +- infer/src/clang/cLocation.ml | 24 +- infer/src/clang/cMethod_signature.ml | 4 + infer/src/clang/cMethod_trans.ml | 475 +++-- infer/src/clang/cPredicates.ml | 778 ++++---- infer/src/clang/cTL.ml | 978 ++++----- infer/src/clang/cTrans.ml | 1576 ++++++++------- infer/src/clang/cTrans_models.ml | 83 +- infer/src/clang/cTrans_utils.ml | 409 ++-- infer/src/clang/cType_to_sil_type.ml | 284 +-- infer/src/clang/cVar_decl.ml | 85 +- infer/src/clang/clang_ast_extend.ml | 133 +- infer/src/clang/ctl_parser_types.ml | 508 ++--- infer/src/clang/objcCategory_decl.ml | 57 +- infer/src/clang/objcInterface_decl.ml | 71 +- infer/src/clang/objcProperty_decl.ml | 2 + infer/src/clang/objcProtocol_decl.ml | 10 +- infer/src/clang/tableaux.ml | 199 +- infer/src/clang_stubs/CTLParserHelper.ml | 4 +- infer/src/concurrency/RacerD.ml | 1104 +++++----- infer/src/concurrency/RacerDConfig.ml | 9 +- infer/src/concurrency/RacerDDomain.ml | 255 ++- infer/src/eradicate/AnnotatedSignature.ml | 69 +- infer/src/eradicate/eradicate.ml | 138 +- infer/src/eradicate/eradicateChecks.ml | 163 +- infer/src/eradicate/modelTables.ml | 34 +- infer/src/eradicate/modelTables.mli | 2 +- infer/src/eradicate/models.ml | 40 +- infer/src/eradicate/typeAnnotation.ml | 32 +- infer/src/eradicate/typeCheck.ml | 716 +++---- infer/src/eradicate/typeErr.ml | 356 ++-- infer/src/eradicate/typeOrigin.ml | 80 +- infer/src/eradicate/typeState.ml | 26 +- infer/src/harness/androidFramework.ml | 32 +- infer/src/harness/harness.ml | 31 +- infer/src/harness/inhabit.ml | 83 +- infer/src/integration/Buck.ml | 57 +- .../integration/CaptureCompilationDatabase.ml | 83 +- infer/src/integration/Clang.ml | 51 +- infer/src/integration/ClangQuotes.ml | 14 +- infer/src/integration/CompilationDatabase.ml | 30 +- infer/src/integration/Diff.ml | 35 +- infer/src/integration/Driver.ml | 463 +++-- infer/src/integration/Javac.ml | 62 +- infer/src/integration/Maven.ml | 82 +- infer/src/integration/ReportDiff.ml | 12 +- infer/src/istd/IList.ml | 59 +- infer/src/istd/IStd.ml | 29 +- infer/src/istd/jbuild.in | 9 +- infer/src/java/jAnnotation.ml | 28 +- infer/src/java/jClasspath.ml | 83 +- infer/src/java/jContext.ml | 14 +- infer/src/java/jFrontend.ml | 138 +- infer/src/java/jMain.ml | 71 +- infer/src/java/jTrans.ml | 547 ++--- infer/src/java/jTransExn.ml | 43 +- infer/src/java/jTransType.ml | 382 ++-- infer/src/jbuild.common.in | 31 +- infer/src/jbuild.in | 24 +- infer/src/labs/ResourceLeaks.ml | 57 +- infer/src/quandary/ClangTaintAnalysis.ml | 61 +- infer/src/quandary/ClangTrace.ml | 225 ++- infer/src/quandary/JavaTaintAnalysis.ml | 86 +- infer/src/quandary/JavaTrace.ml | 336 ++-- infer/src/quandary/QuandaryConfig.ml | 36 +- infer/src/quandary/QuandarySummary.ml | 9 +- infer/src/quandary/TaintAnalysis.ml | 448 +++-- infer/src/scripts/checkCopyright.ml | 103 +- infer/src/unit/BoundedCallTreeTests.ml | 20 +- infer/src/unit/DifferentialFiltersTests.ml | 40 +- infer/src/unit/DifferentialTests.ml | 16 +- infer/src/unit/DifferentialTestsUtils.ml | 8 +- infer/src/unit/TaintTests.ml | 5 +- infer/src/unit/TraceTests.ml | 24 +- infer/src/unit/abstractInterpreterTests.ml | 30 +- infer/src/unit/accessPathTestUtils.ml | 1 + infer/src/unit/accessPathTests.ml | 18 +- infer/src/unit/accessTreeTests.ml | 60 +- infer/src/unit/addressTakenTests.ml | 1 + infer/src/unit/analyzerTester.ml | 66 +- infer/src/unit/clang/CFrontend_errorsTests.ml | 1 + .../src/unit/clang/CiOSVersionNumbersTests.ml | 1 + infer/src/unit/clang/ClangTests.ml | 1 + infer/src/unit/clang/QualifiedCppNameTests.ml | 1 + infer/src/unit/inferunit.ml | 14 +- infer/src/unit/livenessTests.ml | 1 + infer/src/unit/procCfgTests.ml | 65 +- infer/src/unit/schedulerTests.ml | 12 +- infer/src/unit/stacktraceTests.ml | 1 + scripts/ocamlformat.sh | 2 +- 277 files changed, 23836 insertions(+), 19196 deletions(-) diff --git a/.ocamlformat b/.ocamlformat index 1c7efde5c..af7f0bccd 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1,2 +1,3 @@ margin 100 sparse true +version v0.1 diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md index 44e5961a1..78b82767a 100644 --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -145,7 +145,7 @@ module MF = MarkupFormatter - Use the `_hum` suffix to flag functions that output human-readable strings. -- Format code with ocamlformat. +- Format code with [ocamlformat](https://github.com/ocaml-ppx/ocamlformat). ### C/C++/Objective-C diff --git a/Makefile b/Makefile index b13ed77a7..8bb65985e 100644 --- a/Makefile +++ b/Makefile @@ -138,17 +138,23 @@ fb-setup: $(QUIET)$(call silent_on_success,Facebook setup,\ $(MAKE) -C facebook setup) -OCAMLFORMAT_EXE=facebook/dependencies/ocamlformat/src/_build/opt/ocamlformat.exe +OCAMLFORMAT_EXE?=ocamlformat .PHONY: fmt fmt: - parallel $(OCAMLFORMAT_EXE) --no-warn-error -i ::: $$(git diff --name-only $$(git merge-base origin/master HEAD) | grep "\.mli\?$$") + parallel $(OCAMLFORMAT_EXE) -i ::: $$(git diff --name-only $$(git merge-base origin/master HEAD) | grep "\.mli\?$$") + +JBUILD_ML:=$(shell find * -name 'jbuild*.in' | grep -v workspace) + +.PHONY: fmt_jbuild +fmt_jbuild: + parallel $(OCAMLFORMAT_EXE) -i ::: $(JBUILD_ML) SRC_ML:=$(shell find * \( -name _build -or -name facebook-clang-plugins -or -path facebook/dependencies \) -not -prune -or -type f -and -name '*'.ml -or -name '*'.mli 2>/dev/null) .PHONY: fmt_all fmt_all: - parallel $(OCAMLFORMAT_EXE) --no-warn-error -i ::: $(SRC_ML) + parallel $(OCAMLFORMAT_EXE) -i ::: $(SRC_ML) $(JBUILD_ML) # pre-building these avoids race conditions when building, eg src_build and test_build in parallel .PHONY: src_build_common @@ -584,6 +590,8 @@ devsetup: Makefile.autoconf $(QUIET)[ $(OPAM) != "no" ] || (echo 'No `opam` found, aborting setup.' >&2; exit 1) $(QUIET)$(call silent_on_success,installing $(OPAM_DEV_DEPS),\ OPAMSWITCH=$(OPAMSWITCH); $(OPAM) install --yes --no-checksum user-setup $(OPAM_DEV_DEPS)) + $(QUIET)$(call silent_on_success,installing ocamlformat,\ + OPAMSWITCH=$(OPAMSWITCH); $(OPAM) pin add --yes ocamlformat https://github.com/ocaml-ppx/ocamlformat.git#$$(grep version .ocamlformat | cut -d ' ' -f 2)) $(QUIET)echo '$(TERM_INFO)*** Running `opam config setup -a`$(TERM_RESET)' >&2 $(QUIET)OPAMSWITCH=$(OPAMSWITCH); $(OPAM) config --yes setup -a $(QUIET)echo '$(TERM_INFO)*** Running `opam user-setup`$(TERM_RESET)' >&2 diff --git a/infer/src/IR/Annot.ml b/infer/src/IR/Annot.ml index 7b3d8f9e3..95bd4a6cb 100644 --- a/infer/src/IR/Annot.ml +++ b/infer/src/IR/Annot.ml @@ -53,10 +53,12 @@ module Item = struct let pp fmt (a, _) = pp fmt a in F.fprintf fmt "<%a>" (Pp.seq pp) ann + let to_string ann = let pp fmt = pp fmt ann in F.asprintf "%t" pp + (** Empty item annotation. *) let empty = [] diff --git a/infer/src/IR/Attributes.ml b/infer/src/IR/Attributes.ml index 89899a853..4a38a0fec 100644 --- a/infer/src/IR/Attributes.ml +++ b/infer/src/IR/Attributes.ml @@ -16,11 +16,13 @@ let int64_of_attributes_kind = let int64_two = Int64.of_int 2 in function ProcUndefined -> Int64.zero | ProcObjCAccessor -> Int64.one | ProcDefined -> int64_two + let proc_kind_of_attr (proc_attributes: ProcAttributes.t) = if proc_attributes.is_defined then ProcDefined else if Option.is_some proc_attributes.objc_accessor then ProcObjCAccessor else ProcUndefined + module type Data = sig val of_pname : Typ.Procname.t -> Sqlite3.Data.t @@ -38,6 +40,7 @@ module Data : Data = struct let default () = Sqlite3.Data.TEXT (Typ.Procname.to_filename pname) in Base.Hashtbl.find_or_add pname_to_key pname ~default + let of_source_file file = Sqlite3.Data.TEXT (SourceFile.to_string file) let to_proc_attr = function[@warning "-8"] Sqlite3.Data.BLOB b -> Marshal.from_string b 0 @@ -76,6 +79,7 @@ FROM ( WHERE attr_kind < :akind OR (attr_kind = :akind AND source_file < :sfile) )|} + let replace pname_blob akind loc_file attr_blob = let replace_stmt = get_replace_statement () in Sqlite3.bind replace_stmt 1 (* :pname *) pname_blob @@ -88,6 +92,7 @@ let replace pname_blob akind loc_file attr_blob = |> SqliteUtils.check_sqlite_error ~log:"replace bind proc attributes" ; SqliteUtils.sqlite_unit_step ~finalize:false ~log:"Attributes.replace" replace_stmt + let get_find_more_defined_statement = ResultsDir.register_statement {| @@ -97,6 +102,7 @@ WHERE proc_name = :pname AND attr_kind > :akind |} + let should_try_to_update pname_blob akind = let find_stmt = get_find_more_defined_statement () in Sqlite3.bind find_stmt 1 (* :pname *) pname_blob @@ -106,14 +112,17 @@ let should_try_to_update pname_blob akind = SqliteUtils.sqlite_result_step ~finalize:false ~log:"Attributes.replace" find_stmt |> (* there is no entry with a strictly larger "definedness" for that proc name *) Option.is_none + let get_select_statement = ResultsDir.register_statement "SELECT proc_attributes FROM attributes WHERE proc_name = :k" + let get_select_defined_statement = ResultsDir.register_statement "SELECT proc_attributes FROM attributes WHERE proc_name = :k AND attr_kind = %Ld" (int64_of_attributes_kind ProcDefined) + let find ~defined pname_blob = let select_stmt = if defined then get_select_defined_statement () else get_select_statement () in Sqlite3.bind select_stmt 1 pname_blob @@ -121,6 +130,7 @@ let find ~defined pname_blob = SqliteUtils.sqlite_result_step ~finalize:false ~log:"Attributes.find" select_stmt |> Option.map ~f:Data.to_proc_attr + let load pname = Data.of_pname pname |> find ~defined:false let store (attr: ProcAttributes.t) = @@ -129,26 +139,28 @@ let store (attr: ProcAttributes.t) = if should_try_to_update key pkind then replace key pkind (Data.of_source_file attr.loc.Location.file) (Data.of_proc_attr attr) + let load_defined pname = Data.of_pname pname |> find ~defined:true let find_file_capturing_procedure pname = match load pname with - | None - -> None - | Some proc_attributes - -> let source_file = proc_attributes.ProcAttributes.source_file_captured in + | None -> + None + | Some proc_attributes -> + let source_file = proc_attributes.ProcAttributes.source_file_captured in let source_dir = DB.source_dir_from_source_file source_file in let origin = (* Procedure coming from include files if it has different location than the file where it was captured. *) match SourceFile.compare source_file proc_attributes.ProcAttributes.loc.file <> 0 with - | true - -> `Include - | false - -> `Source + | true -> + `Include + | false -> + `Source in let cfg_fname = DB.source_dir_get_internal_file source_dir ".cfg" in let cfg_fname_exists = PVariant.( = ) `Yes (Sys.file_exists (DB.filename_to_string cfg_fname)) in if cfg_fname_exists then Some (source_file, origin) else None + diff --git a/infer/src/IR/Binop.ml b/infer/src/IR/Binop.ml index cf66e4972..620ef7b40 100644 --- a/infer/src/IR/Binop.ml +++ b/infer/src/IR/Binop.ml @@ -52,83 +52,86 @@ let invertible = function PlusA | PlusPI | MinusA | MinusPI -> true | _ -> false If the [binop] operation is not invertible, the function raises Assert_failure. *) let invert bop = match bop with - | PlusA - -> MinusA - | PlusPI - -> MinusPI - | MinusA - -> PlusA - | MinusPI - -> PlusPI - | _ - -> assert false + | PlusA -> + MinusA + | PlusPI -> + MinusPI + | MinusA -> + PlusA + | MinusPI -> + PlusPI + | _ -> + assert false + (** This function returns true if 0 is the right unit of [binop]. The return value false means "don't know". *) let is_zero_runit = function PlusA | PlusPI | MinusA | MinusPI | MinusPP -> true | _ -> false let text = function - | PlusA - -> "+" - | PlusPI - -> "+" - | MinusA | MinusPP - -> "-" - | MinusPI - -> "-" - | Mult - -> "*" - | Div - -> "/" - | Mod - -> "%" - | Shiftlt - -> "<<" - | Shiftrt - -> ">>" - | Lt - -> "<" - | Gt - -> ">" - | Le - -> "<=" - | Ge - -> ">=" - | Eq - -> "==" - | Ne - -> "!=" - | BAnd - -> "&" - | BXor - -> "^" - | BOr - -> "|" - | LAnd - -> "&&" - | LOr - -> "||" + | PlusA -> + "+" + | PlusPI -> + "+" + | MinusA | MinusPP -> + "-" + | MinusPI -> + "-" + | Mult -> + "*" + | Div -> + "/" + | Mod -> + "%" + | Shiftlt -> + "<<" + | Shiftrt -> + ">>" + | Lt -> + "<" + | Gt -> + ">" + | Le -> + "<=" + | Ge -> + ">=" + | Eq -> + "==" + | Ne -> + "!=" + | BAnd -> + "&" + | BXor -> + "^" + | BOr -> + "|" + | LAnd -> + "&&" + | LOr -> + "||" + (** Pretty print a binary operator. *) let str pe binop = match pe.Pp.kind with | HTML -> ( match binop with - | Ge - -> " >= " - | Le - -> " <= " - | Gt - -> " > " - | Lt - -> " < " - | Shiftlt - -> " << " - | Shiftrt - -> " >> " - | _ - -> text binop ) + | Ge -> + " >= " + | Le -> + " <= " + | Gt -> + " > " + | Lt -> + " < " + | Shiftlt -> + " << " + | Shiftrt -> + " >> " + | _ -> + text binop ) | LATEX -> ( match binop with Ge -> " \\geq " | Le -> " \\leq " | _ -> text binop ) - | _ - -> text binop + | _ -> + text binop + diff --git a/infer/src/IR/BuiltinDecl.ml b/infer/src/IR/BuiltinDecl.ml index ba7b40c3d..88450f2dc 100644 --- a/infer/src/IR/BuiltinDecl.ml +++ b/infer/src/IR/BuiltinDecl.ml @@ -19,6 +19,7 @@ let create_procname name = let pname = Typ.Procname.from_string_c_fun name in register pname ; pname + let create_objc_class_method class_name method_name = let method_kind = Typ.Procname.ObjCClassMethod in let tname = Typ.Name.Objc.from_string class_name in @@ -28,6 +29,7 @@ let create_objc_class_method class_name method_name = in register pname ; pname + let is_declared pname = Typ.Procname.Set.mem pname !builtin_decls let __array_access = create_procname "__array_access" @@ -83,6 +85,7 @@ let __objc_cast = create_procname "__objc_cast" let __objc_dictionary_literal = create_objc_class_method "NSDictionary" "dictionaryWithObjects:forKeys:count:" + let __objc_release = create_procname "__objc_release" let __objc_release_autorelease_pool = create_procname "__objc_release_autorelease_pool" diff --git a/infer/src/IR/CallFlags.ml b/infer/src/IR/CallFlags.ml index d6fc3dc61..cd2a8dbf0 100644 --- a/infer/src/IR/CallFlags.ml +++ b/infer/src/IR/CallFlags.ml @@ -27,9 +27,11 @@ let pp f cf = if cf.cf_virtual then F.fprintf f " virtual" ; if cf.cf_noreturn then F.fprintf f " noreturn" + let default = { cf_virtual= false ; cf_interface= false ; cf_noreturn= false ; cf_is_objc_block= false ; cf_targets= [] } + diff --git a/infer/src/IR/Cfg.ml b/infer/src/IR/Cfg.ml index 4dd7e9de6..b6aefecf5 100644 --- a/infer/src/IR/Cfg.ml +++ b/infer/src/IR/Cfg.ml @@ -28,10 +28,13 @@ let find_proc_desc_from_name cfg pname = try Some (Typ.Procname.Hash.find cfg.proc_desc_table pname) with Not_found -> None + (** Create a new procdesc *) let create_proc_desc cfg (proc_attributes: ProcAttributes.t) = let pdesc = Procdesc.from_proc_attributes ~called_from_cfg:true proc_attributes in - add_proc_desc cfg proc_attributes.proc_name pdesc ; pdesc + add_proc_desc cfg proc_attributes.proc_name pdesc ; + pdesc + (** Iterate over all the nodes in the cfg *) let iter_all_nodes ?(sorted= false) f cfg = @@ -49,12 +52,14 @@ let iter_all_nodes ?(sorted= false) f cfg = |> List.sort ~cmp:[%compare : Procdesc.t * Procdesc.Node.t] |> List.iter ~f:(fun (d, n) -> f d n) + (** Get all the procdescs (defined and declared) *) let get_all_procs cfg = let procs = ref [] in let f _ pdesc = procs := pdesc :: !procs in iter_proc_desc cfg f ; !procs + (** Get the procedures whose body is defined in this cfg *) let get_defined_procs cfg = List.filter ~f:Procdesc.is_defined (get_all_procs cfg) @@ -67,12 +72,12 @@ let check_cfg_connectedness cfg = let succs = Procdesc.Node.get_succs n in let preds = Procdesc.Node.get_preds n in match Procdesc.Node.get_kind n with - | Procdesc.Node.Start_node _ - -> Int.equal (List.length succs) 0 || List.length preds > 0 - | Procdesc.Node.Exit_node _ - -> List.length succs > 0 || Int.equal (List.length preds) 0 - | Procdesc.Node.Stmt_node _ | Procdesc.Node.Prune_node _ | Procdesc.Node.Skip_node _ - -> Int.equal (List.length succs) 0 || Int.equal (List.length preds) 0 + | Procdesc.Node.Start_node _ -> + Int.equal (List.length succs) 0 || List.length preds > 0 + | Procdesc.Node.Exit_node _ -> + List.length succs > 0 || Int.equal (List.length preds) 0 + | Procdesc.Node.Stmt_node _ | Procdesc.Node.Prune_node _ | Procdesc.Node.Skip_node _ -> + Int.equal (List.length succs) 0 || Int.equal (List.length preds) 0 | Procdesc.Node.Join_node -> (* Join node has the exception that it may be without predecessors and pointing to an exit node *) @@ -89,14 +94,17 @@ let check_cfg_connectedness cfg = let pdescs = get_all_procs cfg in List.iter ~f:do_pdesc pdescs + (** Serializer for control flow graphs *) let cfg_serializer : cfg Serialization.serializer = Serialization.create_serializer Serialization.Key.cfg + (** Load a cfg from a file *) let load_cfg_from_file (filename: DB.filename) : cfg option = Serialization.read_from_file cfg_serializer filename + (** Save the .attr files for the procedures in the cfg. *) let save_attributes source_file cfg = let save_proc pdesc = @@ -110,6 +118,7 @@ let save_attributes source_file cfg = in List.iter ~f:save_proc (get_all_procs cfg) + (** Inline a synthetic (access or bridge) method. *) let inline_synthetic_method ret_id etl pdesc loc_call : Sil.instr option = let modified = ref None in @@ -124,70 +133,72 @@ let inline_synthetic_method ret_id etl pdesc loc_call : Sil.instr option = match (instr, ret_id, etl) with | ( Sil.Load (_, Exp.Lfield (Exp.Var _, fn, ft), bt, _) , Some (ret_id, _) - , [(* getter for fields *) (e1, _)] ) - -> let instr' = Sil.Load (ret_id, Exp.Lfield (e1, fn, ft), bt, loc_call) in + , [(* getter for fields *) (e1, _)] ) -> + let instr' = Sil.Load (ret_id, Exp.Lfield (e1, fn, ft), bt, loc_call) in found instr instr' | Sil.Load (_, Exp.Lfield (Exp.Lvar pvar, fn, ft), bt, _), Some (ret_id, _), [] - when Pvar.is_global pvar - -> (* getter for static fields *) + when Pvar.is_global pvar -> + (* getter for static fields *) let instr' = Sil.Load (ret_id, Exp.Lfield (Exp.Lvar pvar, fn, ft), bt, loc_call) in found instr instr' - | Sil.Store (Exp.Lfield (_, fn, ft), bt, _, _), _, [(* setter for fields *) (e1, _); (e2, _)] - -> let instr' = Sil.Store (Exp.Lfield (e1, fn, ft), bt, e2, loc_call) in + | Sil.Store (Exp.Lfield (_, fn, ft), bt, _, _), _, [(* setter for fields *) (e1, _); (e2, _)] -> + let instr' = Sil.Store (Exp.Lfield (e1, fn, ft), bt, e2, loc_call) in found instr instr' | Sil.Store (Exp.Lfield (Exp.Lvar pvar, fn, ft), bt, _, _), _, [(e1, _)] - when Pvar.is_global pvar - -> (* setter for static fields *) + when Pvar.is_global pvar -> + (* setter for static fields *) let instr' = Sil.Store (Exp.Lfield (Exp.Lvar pvar, fn, ft), bt, e1, loc_call) in found instr instr' | Sil.Call (ret_id', Exp.Const Const.Cfun pn, etl', _, cf), _, _ when Bool.equal (is_none ret_id) (is_none ret_id') - && Int.equal (List.length etl') (List.length etl) - -> let instr' = Sil.Call (ret_id, Exp.Const (Const.Cfun pn), etl, loc_call, cf) in + && Int.equal (List.length etl') (List.length etl) -> + let instr' = Sil.Call (ret_id, Exp.Const (Const.Cfun pn), etl, loc_call, cf) in found instr instr' | Sil.Call (ret_id', Exp.Const Const.Cfun pn, etl', _, cf), _, _ when Bool.equal (is_none ret_id) (is_none ret_id') - && Int.equal (List.length etl' + 1) (List.length etl) - -> let etl1 = + && Int.equal (List.length etl' + 1) (List.length etl) -> + let etl1 = match List.rev etl with (* remove last element *) - | _ :: l - -> List.rev l - | [] - -> assert false + | _ :: l -> + List.rev l + | [] -> + assert false in let instr' = Sil.Call (ret_id, Exp.Const (Const.Cfun pn), etl1, loc_call, cf) in found instr instr' - | _ - -> () + | _ -> + () in - Procdesc.iter_instrs do_instr pdesc ; !modified + Procdesc.iter_instrs do_instr pdesc ; + !modified + (** Find synthetic (access or bridge) Java methods in the procedure and inline them in the cfg. *) let proc_inline_synthetic_methods cfg pdesc : unit = let instr_inline_synthetic_method = function | Sil.Call (ret_id, Exp.Const Const.Cfun pn, etl, loc, _) -> ( match find_proc_desc_from_name cfg pn with - | Some pd - -> let is_access = Typ.Procname.java_is_access_method pn in + | Some pd -> + let is_access = Typ.Procname.java_is_access_method pn in let attributes = Procdesc.get_attributes pd in let is_synthetic = attributes.is_synthetic_method in let is_bridge = attributes.is_bridge_method in if is_access || is_bridge || is_synthetic then inline_synthetic_method ret_id etl pd loc else None - | None - -> None ) - | _ - -> None + | None -> + None ) + | _ -> + None in let node_inline_synthetic_methods node = let modified = ref false in let do_instr instr = match instr_inline_synthetic_method instr with - | None - -> instr - | Some instr' - -> modified := true ; + | None -> + instr + | Some instr' -> + modified := true ; instr' in let instrs = Procdesc.Node.get_instrs node in @@ -196,11 +207,13 @@ let proc_inline_synthetic_methods cfg pdesc : unit = in Procdesc.iter_nodes node_inline_synthetic_methods pdesc + (** Inline the java synthetic methods in the cfg *) let inline_java_synthetic_methods cfg = let f pname pdesc = if Typ.Procname.is_java pname then proc_inline_synthetic_methods cfg pdesc in iter_proc_desc cfg f + (** compute the list of procedures added or changed in [cfg_new] over [cfg_old] *) let mark_unchanged_pdescs cfg_new cfg_old = let pdescs_eq (pd1: Procdesc.t) (pd2: Procdesc.t) = @@ -263,19 +276,22 @@ let mark_unchanged_pdescs cfg_new cfg_old = in Typ.Procname.Hash.iter mark_pdesc_if_unchanged new_procs + (** Save a cfg into a file *) let store_cfg_to_file ~source_file (filename: DB.filename) (cfg: cfg) = inline_java_synthetic_methods cfg ; ( if Config.incremental_procs then match load_cfg_from_file filename with - | Some old_cfg - -> mark_unchanged_pdescs cfg old_cfg - | None - -> () ) ; + | Some old_cfg -> + mark_unchanged_pdescs cfg old_cfg + | None -> + () ) ; (* NOTE: it's important to write attribute files to disk before writing .cfg file to disk. OndemandCapture module relies on it - it uses existance of .cfg file as a barrier to make sure that all attributes were written to disk (but not necessarily flushed) *) - save_attributes source_file cfg ; Serialization.write_to_file cfg_serializer filename ~data:cfg + save_attributes source_file cfg ; + Serialization.write_to_file cfg_serializer filename ~data:cfg + (** clone a procedure description and apply the type substitutions where the parameters are used *) @@ -289,10 +305,10 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions = Typ.mk (Tptr (Typ.mk (Tstruct typename), Typ.Pk_pointer)) in let convert_exp = function - | Exp.Lvar origin_pvar - -> Exp.Lvar (convert_pvar origin_pvar) - | exp - -> exp + | Exp.Lvar origin_pvar -> + Exp.Lvar (convert_pvar origin_pvar) + | exp -> + exp in let subst_map = ref Ident.IdentMap.empty in let redirect_typename origin_id = @@ -304,23 +320,23 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions = ( id , (Exp.Lvar origin_pvar as origin_exp) , {Typ.desc= Tptr ({desc= Tstruct origin_typename}, Pk_pointer)} - , loc ) - -> let specialized_typname = + , loc ) -> + let specialized_typname = try Mangled.Map.find (Pvar.get_name origin_pvar) substitutions with Not_found -> origin_typename in subst_map := Ident.IdentMap.add id specialized_typname !subst_map ; Sil.Load (id, convert_exp origin_exp, mk_ptr_typ specialized_typname, loc) :: instrs - | Sil.Load (id, (Exp.Var origin_id as origin_exp), ({Typ.desc= Tstruct _} as origin_typ), loc) - -> let updated_typ : Typ.t = + | Sil.Load (id, (Exp.Var origin_id as origin_exp), ({Typ.desc= Tstruct _} as origin_typ), loc) -> + let updated_typ : Typ.t = try Typ.mk ~default:origin_typ (Tstruct (Ident.IdentMap.find origin_id !subst_map)) with Not_found -> origin_typ in Sil.Load (id, convert_exp origin_exp, updated_typ, loc) :: instrs - | Sil.Load (id, origin_exp, origin_typ, loc) - -> Sil.Load (id, convert_exp origin_exp, origin_typ, loc) :: instrs - | Sil.Store (assignee_exp, origin_typ, origin_exp, loc) - -> let set_instr = + | Sil.Load (id, origin_exp, origin_typ, loc) -> + Sil.Load (id, convert_exp origin_exp, origin_typ, loc) :: instrs + | Sil.Store (assignee_exp, origin_typ, origin_exp, loc) -> + let set_instr = Sil.Store (convert_exp assignee_exp, origin_typ, convert_exp origin_exp, loc) in set_instr :: instrs @@ -330,8 +346,8 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions = , (Exp.Var id, _) :: origin_args , loc , call_flags ) - when call_flags.CallFlags.cf_virtual && redirect_typename id <> None - -> let redirected_typename = Option.value_exn (redirect_typename id) in + when call_flags.CallFlags.cf_virtual && redirect_typename id <> None -> + let redirected_typename = Option.value_exn (redirect_typename id) in let redirected_typ = mk_ptr_typ redirected_typename in let redirected_pname = Typ.Procname.replace_class (Typ.Procname.Java callee_pname_java) redirected_typename @@ -344,30 +360,30 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions = Sil.Call (return_ids, Exp.Const (Const.Cfun redirected_pname), args, loc, call_flags) in call_instr :: instrs - | Sil.Call (return_ids, origin_call_exp, origin_args, loc, call_flags) - -> let converted_args = List.map ~f:(fun (exp, typ) -> (convert_exp exp, typ)) origin_args in + | Sil.Call (return_ids, origin_call_exp, origin_args, loc, call_flags) -> + let converted_args = List.map ~f:(fun (exp, typ) -> (convert_exp exp, typ)) origin_args in let call_instr = Sil.Call (return_ids, convert_exp origin_call_exp, converted_args, loc, call_flags) in call_instr :: instrs - | Sil.Prune (origin_exp, loc, is_true_branch, if_kind) - -> Sil.Prune (convert_exp origin_exp, loc, is_true_branch, if_kind) :: instrs - | Sil.Declare_locals (typed_vars, loc) - -> let new_typed_vars = + | Sil.Prune (origin_exp, loc, is_true_branch, if_kind) -> + Sil.Prune (convert_exp origin_exp, loc, is_true_branch, if_kind) :: instrs + | Sil.Declare_locals (typed_vars, loc) -> + let new_typed_vars = List.map ~f:(fun (pvar, typ) -> (convert_pvar pvar, typ)) typed_vars in Sil.Declare_locals (new_typed_vars, loc) :: instrs - | Sil.Nullify _ | Abstract _ | Sil.Remove_temps _ - -> (* these are generated instructions that will be replaced by the preanalysis *) + | Sil.Nullify _ | Abstract _ | Sil.Remove_temps _ -> + (* these are generated instructions that will be replaced by the preanalysis *) instrs in let convert_node_kind = function - | Procdesc.Node.Start_node _ - -> Procdesc.Node.Start_node resolved_pname - | Procdesc.Node.Exit_node _ - -> Procdesc.Node.Exit_node resolved_pname - | node_kind - -> node_kind + | Procdesc.Node.Start_node _ -> + Procdesc.Node.Start_node resolved_pname + | Procdesc.Node.Exit_node _ -> + Procdesc.Node.Exit_node resolved_pname + | node_kind -> + node_kind in let node_map = ref Procdesc.NodeMap.empty in let rec convert_node node = @@ -377,10 +393,10 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions = Procdesc.create_node resolved_pdesc loc kind instrs and loop callee_nodes = match callee_nodes with - | [] - -> [] - | node :: other_node - -> let converted_node = + | [] -> + [] + | node :: other_node -> + let converted_node = try Procdesc.NodeMap.find node !node_map with Not_found -> let new_node = convert_node node @@ -399,6 +415,7 @@ let specialize_types_proc callee_pdesc resolved_pdesc substitutions = ignore (loop [callee_start_node]) ; resolved_pdesc + (** Creates a copy of a procedure description and a list of type substitutions of the form (name, typ) where name is a parameter. The resulting proc desc is isomorphic but all the type of the parameters are replaced in the instructions according to the list. @@ -409,11 +426,11 @@ let specialize_types callee_pdesc resolved_pname args = List.fold2_exn ~f:(fun (params, subts) (param_name, param_typ) (_, arg_typ) -> match arg_typ.Typ.desc with - | Tptr ({desc= Tstruct typename}, Pk_pointer) - -> (* Replace the type of the parameter by the type of the argument *) + | Tptr ({desc= Tstruct typename}, Pk_pointer) -> + (* Replace the type of the parameter by the type of the argument *) ((param_name, arg_typ) :: params, Mangled.Map.add param_name typename subts) - | _ - -> ((param_name, param_typ) :: params, subts)) + | _ -> + ((param_name, param_typ) :: params, subts)) ~init:([], Mangled.Map.empty) callee_attributes.formals args in let resolved_attributes = @@ -430,7 +447,9 @@ let specialize_types callee_pdesc resolved_pname args = in specialize_types_proc callee_pdesc resolved_pdesc substitutions + let pp_proc_signatures fmt cfg = F.fprintf fmt "METHOD SIGNATURES@\n@." ; let sorted_procs = List.sort ~cmp:Procdesc.compare (get_all_procs cfg) in List.iter ~f:(fun pdesc -> F.fprintf fmt "%a@." Procdesc.pp_signature pdesc) sorted_procs + diff --git a/infer/src/IR/Cg.ml b/infer/src/IR/Cg.ml index 1212b2bf6..517e74679 100644 --- a/infer/src/IR/Cg.ml +++ b/infer/src/IR/Cg.ml @@ -56,12 +56,14 @@ let add_node g n ~defined = in Typ.Procname.Hash.add g.node_map n info + let remove_node_defined g n = try let info = Typ.Procname.Hash.find g.node_map n in info.defined <- false with Not_found -> () + let add_defined_node g n = add_node g n ~defined:true (** Compute the ancestors of the node, if not already computed *) @@ -76,14 +78,15 @@ let compute_ancestors g node = seen := Typ.Procname.Set.add current !seen ; let info = Typ.Procname.Hash.find g current in match info.ancestors with - | Some ancestors - -> result := Typ.Procname.Set.union !result ancestors - | None - -> result := Typ.Procname.Set.union !result info.parents ; + | Some ancestors -> + result := Typ.Procname.Set.union !result ancestors + | None -> + result := Typ.Procname.Set.union !result info.parents ; todo := Typ.Procname.Set.union !todo info.parents ) done ; !result + (** Compute the heirs of the node, if not already computed *) let compute_heirs g node = let todo = ref (Typ.Procname.Set.singleton node) in @@ -96,40 +99,43 @@ let compute_heirs g node = seen := Typ.Procname.Set.add current !seen ; let info = Typ.Procname.Hash.find g current in match info.heirs with - | Some heirs - -> result := Typ.Procname.Set.union !result heirs - | None - -> result := Typ.Procname.Set.union !result info.children ; + | Some heirs -> + result := Typ.Procname.Set.union !result heirs + | None -> + result := Typ.Procname.Set.union !result info.children ; todo := Typ.Procname.Set.union !todo info.children ) done ; !result + (** Compute the ancestors of the node, if not pre-computed already *) let get_ancestors (g: t) node = let info = Typ.Procname.Hash.find g.node_map node in match info.ancestors with - | None - -> let ancestors = compute_ancestors g.node_map node in + | None -> + let ancestors = compute_ancestors g.node_map node in info.ancestors <- Some ancestors ; let size = Typ.Procname.Set.cardinal ancestors in if size > 1000 then L.(debug Analysis Medium) "%a has %d ancestors@." Typ.Procname.pp node size ; ancestors - | Some ancestors - -> ancestors + | Some ancestors -> + ancestors + (** Compute the heirs of the node, if not pre-computed already *) let get_heirs (g: t) node = let info = Typ.Procname.Hash.find g.node_map node in match info.heirs with - | None - -> let heirs = compute_heirs g.node_map node in + | None -> + let heirs = compute_heirs g.node_map node in info.heirs <- Some heirs ; let size = Typ.Procname.Set.cardinal heirs in if size > 1000 then L.(debug Analysis Medium) "%a has %d heirs@." Typ.Procname.pp node size ; heirs - | Some heirs - -> heirs + | Some heirs -> + heirs + let node_defined (g: t) n = try @@ -137,6 +143,7 @@ let node_defined (g: t) n = info.defined with Not_found -> false + let add_edge g nfrom nto = add_node g nfrom ~defined:false ; add_node g nto ~defined:false ; @@ -145,6 +152,7 @@ let add_edge g nfrom nto = info_from.children <- Typ.Procname.Set.add nto info_from.children ; info_to.parents <- Typ.Procname.Set.add nfrom info_to.parents + (** iterate over the elements of a node_map in node order *) let node_map_iter f g = let table = ref [] in @@ -152,30 +160,35 @@ let node_map_iter f g = let cmp ((n1: Typ.Procname.t), _) ((n2: Typ.Procname.t), _) = Typ.Procname.compare n1 n2 in List.iter ~f:(fun (n, info) -> f n info) (List.sort ~cmp !table) + let get_nodes (g: t) = let nodes = ref Typ.Procname.Set.empty in let f node _ = nodes := Typ.Procname.Set.add node !nodes in node_map_iter f g ; !nodes + let compute_calls g node = { in_calls= Typ.Procname.Set.cardinal (get_ancestors g node) ; out_calls= Typ.Procname.Set.cardinal (get_heirs g node) } + (** Compute the calls of the node, if not pre-computed already *) let get_calls (g: t) node = let info = Typ.Procname.Hash.find g.node_map node in match info.in_out_calls with - | None - -> let calls = compute_calls g node in + | None -> + let calls = compute_calls g node in info.in_out_calls <- Some calls ; calls - | Some calls - -> calls + | Some calls -> + calls + let get_all_nodes (g: t) = let nodes = Typ.Procname.Set.elements (get_nodes g) in List.map ~f:(fun node -> (node, get_calls g node)) nodes + let get_nodes_and_calls (g: t) = List.filter ~f:(fun (n, _) -> node_defined g n) (get_all_nodes g) let node_get_num_ancestors g n = (n, Typ.Procname.Set.cardinal (get_ancestors g n)) @@ -189,6 +202,7 @@ let get_edges (g: t) : ((node * int) * (node * int)) list = in node_map_iter f g ; !edges + (** Return all the children of [n], whether defined or not *) let get_all_children (g: t) n = (Typ.Procname.Hash.find g.node_map n).children @@ -208,6 +222,7 @@ let get_nonrecursive_dependents (g: t) n = let res = Typ.Procname.Set.filter (node_defined g) res0 in res + (** Return the ancestors of [n] which are also heirs of [n] *) let compute_recursive_dependents (g: t) n = let reached_from_n pn = Typ.Procname.Set.mem n (get_ancestors g pn) in @@ -215,21 +230,24 @@ let compute_recursive_dependents (g: t) n = let res = Typ.Procname.Set.filter (node_defined g) res0 in res + (** Compute the ancestors of [n] which are also heirs of [n], if not pre-computed already *) let get_recursive_dependents (g: t) n = let info = Typ.Procname.Hash.find g.node_map n in match info.recursive_dependents with - | None - -> let recursive_dependents = compute_recursive_dependents g n in + | None -> + let recursive_dependents = compute_recursive_dependents g n in info.recursive_dependents <- Some recursive_dependents ; recursive_dependents - | Some recursive_dependents - -> recursive_dependents + | Some recursive_dependents -> + recursive_dependents + (** Return the nodes dependent on [n] *) let get_dependents (g: t) n = Typ.Procname.Set.union (get_nonrecursive_dependents g n) (get_recursive_dependents g n) + (** Return all the nodes with their defined children *) let get_nodes_and_defined_children (g: t) = let nodes = ref Typ.Procname.Set.empty in @@ -237,6 +255,7 @@ let get_nodes_and_defined_children (g: t) = let nodes_list = Typ.Procname.Set.elements !nodes in List.map ~f:(fun n -> (n, get_defined_children g n)) nodes_list + (** nodes with defined flag, and edges *) type nodes_and_edges = (node * bool) list * (node * node) list @@ -251,12 +270,14 @@ let get_nodes_and_edges (g: t) : nodes_and_edges = in node_map_iter f g ; (!nodes, !edges) + (** Return the list of nodes which are defined *) let get_defined_nodes (g: t) = let nodes, _ = get_nodes_and_edges g in let get_node (node, _) = node in List.map ~f:get_node (List.filter ~f:(fun (_, defined) -> defined) nodes) + (** Return the path of the source file *) let get_source (g: t) = g.source @@ -267,26 +288,30 @@ let extend cg_old cg_new = List.iter ~f:(fun (node, defined) -> add_node cg_old node ~defined) nodes ; List.iter ~f:(fun (nfrom, nto) -> add_edge cg_old nfrom nto) edges + (** Begin support for serialization *) let callgraph_serializer : (SourceFile.t * nodes_and_edges) Serialization.serializer = Serialization.create_serializer Serialization.Key.cg + (** Load a call graph from a file *) let load_from_file (filename: DB.filename) : t option = match Serialization.read_from_file callgraph_serializer filename with - | None - -> None - | Some (source, (nodes, edges)) - -> let g = create source in + | None -> + None + | Some (source, (nodes, edges)) -> + let g = create source in List.iter ~f:(fun (node, defined) -> if defined then add_defined_node g node) nodes ; List.iter ~f:(fun (nfrom, nto) -> add_edge g nfrom nto) edges ; Some g + (** Save a call graph into a file *) let store_to_file (filename: DB.filename) (call_graph: t) = Serialization.write_to_file callgraph_serializer filename ~data:(call_graph.source, get_nodes_and_edges call_graph) + let pp_graph_dotty (g: t) fmt = let nodes_with_calls = get_all_nodes g in let get_shape (n, _) = if node_defined g n then "box" else "diamond" in @@ -303,6 +328,7 @@ let pp_graph_dotty (g: t) fmt = List.iter ~f:(fun (s, d) -> F.fprintf fmt "%a -> %a@\n" pp_node s pp_node d) (get_edges g) ; F.fprintf fmt "}@." + (** Print the call graph as a dotty file. *) let save_call_graph_dotty source (g: t) = let fname_dot = @@ -311,3 +337,4 @@ let save_call_graph_dotty source (g: t) = let outc = Out_channel.create (DB.filename_to_string fname_dot) in let fmt = F.formatter_of_out_channel outc in pp_graph_dotty g fmt ; Out_channel.close outc + diff --git a/infer/src/IR/Const.ml b/infer/src/IR/Const.ml index 45f685acd..b14d9f6eb 100644 --- a/infer/src/IR/Const.ml +++ b/infer/src/IR/Const.ml @@ -26,34 +26,36 @@ let equal = [%compare.equal : t] let kind_equal c1 c2 = let const_kind_number = function - | Cint _ - -> 1 - | Cfun _ - -> 2 - | Cstr _ - -> 3 - | Cfloat _ - -> 4 - | Cclass _ - -> 5 + | Cint _ -> + 1 + | Cfun _ -> + 2 + | Cstr _ -> + 3 + | Cfloat _ -> + 4 + | Cclass _ -> + 5 in Int.equal (const_kind_number c1) (const_kind_number c2) + let pp pe f = function - | Cint i - -> IntLit.pp f i + | Cint i -> + IntLit.pp f i | Cfun fn -> ( match pe.Pp.kind with - | HTML - -> F.fprintf f "_fun_%s" (Escape.escape_xml (Typ.Procname.to_string fn)) - | _ - -> F.fprintf f "_fun_%s" (Typ.Procname.to_string fn) ) - | Cstr s - -> F.fprintf f "\"%s\"" (String.escaped s) - | Cfloat v - -> F.fprintf f "%f" v - | Cclass c - -> F.fprintf f "%a" Ident.pp_name c + | HTML -> + F.fprintf f "_fun_%s" (Escape.escape_xml (Typ.Procname.to_string fn)) + | _ -> + F.fprintf f "_fun_%s" (Typ.Procname.to_string fn) ) + | Cstr s -> + F.fprintf f "\"%s\"" (String.escaped s) + | Cfloat v -> + F.fprintf f "%f" v + | Cclass c -> + F.fprintf f "%a" Ident.pp_name c + let to_string c = F.asprintf "%a" (pp Pp.text) c @@ -62,9 +64,10 @@ let iszero_int_float = function Cint i -> IntLit.iszero i | Cfloat 0.0 -> true | let isone_int_float = function Cint i -> IntLit.isone i | Cfloat 1.0 -> true | _ -> false let isminusone_int_float = function - | Cint i - -> IntLit.isminusone i - | Cfloat -1.0 - -> true - | _ - -> false + | Cint i -> + IntLit.isminusone i + | Cfloat -1.0 -> + true + | _ -> + false + diff --git a/infer/src/IR/DecompiledExp.ml b/infer/src/IR/DecompiledExp.ml index caa130408..ec67977c5 100644 --- a/infer/src/IR/DecompiledExp.ml +++ b/infer/src/IR/DecompiledExp.ml @@ -40,80 +40,81 @@ let eradicate_java () = Config.eradicate && java () (** convert a dexp to a string *) let rec to_string = function - | Darray (de1, de2) - -> to_string de1 ^ "[" ^ to_string de2 ^ "]" - | Dbinop (op, de1, de2) - -> "(" ^ to_string de1 ^ Binop.str Pp.text op ^ to_string de2 ^ ")" - | Dconst Cfun pn - -> Typ.Procname.to_simplified_string pn - | Dconst c - -> Const.to_string c - | Dderef de - -> "*" ^ to_string de - | Dfcall (fun_dexp, args, _, {cf_virtual= isvirtual}) - -> let pp_arg fmt de = F.fprintf fmt "%s" (to_string de) in + | Darray (de1, de2) -> + to_string de1 ^ "[" ^ to_string de2 ^ "]" + | Dbinop (op, de1, de2) -> + "(" ^ to_string de1 ^ Binop.str Pp.text op ^ to_string de2 ^ ")" + | Dconst Cfun pn -> + Typ.Procname.to_simplified_string pn + | Dconst c -> + Const.to_string c + | Dderef de -> + "*" ^ to_string de + | Dfcall (fun_dexp, args, _, {cf_virtual= isvirtual}) -> + let pp_arg fmt de = F.fprintf fmt "%s" (to_string de) in let pp_args fmt des = if eradicate_java () then ( if des <> [] then F.fprintf fmt "..." ) else Pp.comma_seq pp_arg fmt des in let pp_fun fmt = function - | Dconst Cfun pname - -> let s = + | Dconst Cfun pname -> + let s = match pname with - | Typ.Procname.Java pname_java - -> Typ.Procname.java_get_method pname_java - | _ - -> Typ.Procname.to_string pname + | Typ.Procname.Java pname_java -> + Typ.Procname.java_get_method pname_java + | _ -> + Typ.Procname.to_string pname in F.fprintf fmt "%s" s - | de - -> F.fprintf fmt "%s" (to_string de) + | de -> + F.fprintf fmt "%s" (to_string de) in let receiver, args' = match args with - | (Dpvar pv) :: args' when isvirtual && Pvar.is_this pv - -> (None, args') - | a :: args' when isvirtual - -> (Some a, args') - | _ - -> (None, args) + | (Dpvar pv) :: args' when isvirtual && Pvar.is_this pv -> + (None, args') + | a :: args' when isvirtual -> + (Some a, args') + | _ -> + (None, args) in let pp fmt = let pp_receiver fmt = function None -> () | Some arg -> F.fprintf fmt "%a." pp_arg arg in F.fprintf fmt "%a%a(%a)" pp_receiver receiver pp_fun fun_dexp pp_args args' in F.asprintf "%t" pp - | Darrow (Dpvar pv, f) when Pvar.is_this pv - -> (* this->fieldname *) + | Darrow (Dpvar pv, f) when Pvar.is_this pv -> + (* this->fieldname *) Typ.Fieldname.to_simplified_string f - | Darrow (de, f) - -> if Typ.Fieldname.is_hidden f then to_string de + | Darrow (de, f) -> + if Typ.Fieldname.is_hidden f then to_string de else if java () then to_string de ^ "." ^ Typ.Fieldname.to_flat_string f else to_string de ^ "->" ^ Typ.Fieldname.to_string f - | Ddot (Dpvar _, fe) when eradicate_java () - -> (* static field access *) + | Ddot (Dpvar _, fe) when eradicate_java () -> + (* static field access *) Typ.Fieldname.to_simplified_string fe - | Ddot (de, f) - -> if Typ.Fieldname.is_hidden f then "&" ^ to_string de + | Ddot (de, f) -> + if Typ.Fieldname.is_hidden f then "&" ^ to_string de else if java () then to_string de ^ "." ^ Typ.Fieldname.to_flat_string f else to_string de ^ "." ^ Typ.Fieldname.to_string f - | Dpvar pv - -> Mangled.to_string (Pvar.get_name pv) - | Dpvaraddr pv - -> let s = + | Dpvar pv -> + Mangled.to_string (Pvar.get_name pv) + | Dpvaraddr pv -> + let s = if eradicate_java () then Pvar.get_simplified_name pv else Mangled.to_string (Pvar.get_name pv) in let ampersand = if eradicate_java () then "" else "&" in ampersand ^ s - | Dunop (op, de) - -> Unop.str op ^ to_string de - | Dsizeof (typ, _, _) - -> F.asprintf "%a" (Typ.pp_full Pp.text) typ - | Dunknown - -> "unknown" - | Dretcall (de, _, _, _) - -> "returned by " ^ to_string de + | Dunop (op, de) -> + Unop.str op ^ to_string de + | Dsizeof (typ, _, _) -> + F.asprintf "%a" (Typ.pp_full Pp.text) typ + | Dunknown -> + "unknown" + | Dretcall (de, _, _, _) -> + "returned by " ^ to_string de + (** Pretty print a dexp. *) let pp fmt de = F.fprintf fmt "%s" (to_string de) @@ -126,14 +127,16 @@ let pp_vpath pe fmt vpath = Io_infer.Html.pp_end_color () else F.fprintf fmt "%a" pp vpath + let rec has_tmp_var = function - | Dpvar pvar | Dpvaraddr pvar - -> Pvar.is_frontend_tmp pvar - | Dderef dexp | Ddot (dexp, _) | Darrow (dexp, _) | Dunop (_, dexp) | Dsizeof (_, Some dexp, _) - -> has_tmp_var dexp - | Darray (dexp1, dexp2) | Dbinop (_, dexp1, dexp2) - -> has_tmp_var dexp1 || has_tmp_var dexp2 - | Dretcall (dexp, dexp_list, _, _) | Dfcall (dexp, dexp_list, _, _) - -> has_tmp_var dexp || List.exists ~f:has_tmp_var dexp_list - | Dconst _ | Dunknown | Dsizeof (_, None, _) - -> false + | Dpvar pvar | Dpvaraddr pvar -> + Pvar.is_frontend_tmp pvar + | Dderef dexp | Ddot (dexp, _) | Darrow (dexp, _) | Dunop (_, dexp) | Dsizeof (_, Some dexp, _) -> + has_tmp_var dexp + | Darray (dexp1, dexp2) | Dbinop (_, dexp1, dexp2) -> + has_tmp_var dexp1 || has_tmp_var dexp2 + | Dretcall (dexp, dexp_list, _, _) | Dfcall (dexp, dexp_list, _, _) -> + has_tmp_var dexp || List.exists ~f:has_tmp_var dexp_list + | Dconst _ | Dunknown | Dsizeof (_, None, _) -> + false + diff --git a/infer/src/IR/Errlog.ml b/infer/src/IR/Errlog.ml index 006502a89..ef5fa4dd4 100644 --- a/infer/src/IR/Errlog.ml +++ b/infer/src/IR/Errlog.ml @@ -32,36 +32,39 @@ let pp_loc_trace fmt l = PrettyPrintable.pp_collection ~pp_item:pp_loc_trace_ele let contains_exception loc_trace_elem = let pred nt = match nt with - | Exception _ - -> true - | Condition _ | Procedure_start _ | Procedure_end _ - -> false + | Exception _ -> + true + | Condition _ | Procedure_start _ | Procedure_end _ -> + false in List.exists ~f:pred loc_trace_elem.lt_node_tags + let make_trace_element lt_level lt_loc lt_description lt_node_tags = {lt_level; lt_loc; lt_description; lt_node_tags} + (** Trace of locations *) type loc_trace = loc_trace_elem list let compute_local_exception_line loc_trace = let compute_local_exception_line state step = match state with - | `Stop _ - -> state - | `Continue (last_known_step_at_level_zero_opt, line_opt) - -> let last_known_step_at_level_zero_opt' = + | `Stop _ -> + state + | `Continue (last_known_step_at_level_zero_opt, line_opt) -> + let last_known_step_at_level_zero_opt' = if Int.equal step.lt_level 0 then Some step else last_known_step_at_level_zero_opt in match last_known_step_at_level_zero_opt' with - | Some step_zero when contains_exception step - -> `Stop (last_known_step_at_level_zero_opt', Some step_zero.lt_loc.line) - | _ - -> `Continue (last_known_step_at_level_zero_opt', line_opt) + | Some step_zero when contains_exception step -> + `Stop (last_known_step_at_level_zero_opt', Some step_zero.lt_loc.line) + | _ -> + `Continue (last_known_step_at_level_zero_opt', line_opt) in snd (List_.fold_until ~init:(`Continue (None, None)) ~f:compute_local_exception_line loc_trace) + type node_id_key = {node_id: int; node_key: int} type err_key = @@ -103,11 +106,13 @@ module ErrLogHash = struct Hashtbl.hash (key.err_kind, key.in_footprint, key.err_name, Localise.error_desc_hash key.err_desc) + let equal key1 key2 = [%compare.equal : Exceptions.err_kind * bool * IssueType.t] (key1.err_kind, key1.in_footprint, key1.err_name) (key2.err_kind, key2.in_footprint, key2.err_name) && Localise.error_desc_equal key1.err_desc key2.err_desc + end include Hashtbl.Make (Key) @@ -122,6 +127,7 @@ let compare x y = let bindings x = ErrLogHash.fold (fun k d l -> (k, d) :: l) x [] in [%compare : (ErrLogHash.Key.t * ErrDataSet.t) list] (bindings x) (bindings y) + (** Empty error log *) let empty () = ErrLogHash.create 13 @@ -134,11 +140,13 @@ let iter (f: iter_fun) (err_log: t) = (fun err_key set -> ErrDataSet.iter (fun err_data -> f err_key err_data) set) err_log + let fold (f: err_key -> err_data -> 'a -> 'a) t acc = ErrLogHash.fold (fun err_key set acc -> ErrDataSet.fold (fun err_data acc -> f err_key err_data acc) set acc) t acc + (** Return the number of elements in the error log which satisfy [filter] *) let size filter (err_log: t) = let count = ref 0 in @@ -148,6 +156,7 @@ let size filter (err_log: t) = err_log ; !count + (** Print errors from error log *) let pp_errors fmt (errlog: t) = let f key _ = @@ -156,6 +165,7 @@ let pp_errors fmt (errlog: t) = in ErrLogHash.iter f errlog + (** Print warnings from error log *) let pp_warnings fmt (errlog: t) = let f key _ = @@ -164,6 +174,7 @@ let pp_warnings fmt (errlog: t) = in ErrLogHash.iter f errlog + (** Print an error log in html format *) let pp_html source path_to_root fmt (errlog: t) = let pp_eds fmt err_datas = @@ -191,15 +202,17 @@ let pp_html source path_to_root fmt (errlog: t) = F.fprintf fmt "%aINFOS DURING RE-EXECUTION@\n" Io_infer.Html.pp_hline () ; ErrLogHash.iter (pp_err_log false Exceptions.Kinfo) errlog + (* I use string in case we want to display a different name to the user*) let severity_to_str severity = match severity with - | Exceptions.High - -> "HIGH" - | Exceptions.Medium - -> "MEDIUM" - | Exceptions.Low - -> "LOW" + | Exceptions.High -> + "HIGH" + | Exceptions.Medium -> + "MEDIUM" + | Exceptions.Low -> + "LOW" + (** Add an error description to the error log unless there is one already at the same node + session; return true if added *) @@ -210,12 +223,16 @@ let add_issue tbl err_key (err_datas: ErrDataSet.t) : bool = else ( ErrLogHash.replace tbl err_key (ErrDataSet.union err_datas current_eds) ; true ) - with Not_found -> ErrLogHash.add tbl err_key err_datas ; true + with Not_found -> + ErrLogHash.add tbl err_key err_datas ; + true + (** Update an old error log with a new one *) let update errlog_old errlog_new = ErrLogHash.iter (fun err_key l -> ignore (add_issue errlog_old err_key l)) errlog_new + let log_issue err_kind err_log loc (node_id, node_key) session ltr ?linters_def_file ?doc_url exn = let error = Exceptions.recognize_exception exn in let err_kind = match error.kind with Some err_kind -> err_kind | _ -> err_kind in @@ -226,10 +243,10 @@ let log_issue err_kind err_log loc (node_id, node_key) session ltr ?linters_def_ in let hide_memory_error = match Localise.error_desc_get_bucket error.description with - | Some bucket when String.equal bucket Mleak_buckets.ml_bucket_unknown_origin - -> not Mleak_buckets.should_raise_leak_unknown_origin - | _ - -> false + | Some bucket when String.equal bucket Mleak_buckets.ml_bucket_unknown_origin -> + not Mleak_buckets.should_raise_leak_unknown_origin + | _ -> + false in let log_it = Exceptions.equal_visibility error.visibility Exceptions.Exn_user @@ -263,7 +280,8 @@ let log_issue err_kind err_log loc (node_id, node_key) session ltr ?linters_def_ let print_now () = L.(debug Analysis Medium) "@\n%a@\n@?" - (Exceptions.pp_err ~node_key loc err_kind error.name error.description error.ml_loc) () ; + (Exceptions.pp_err ~node_key loc err_kind error.name error.description error.ml_loc) + () ; if err_kind <> Exceptions.Kerror then let warn_str = let pp fmt = @@ -274,17 +292,18 @@ let log_issue err_kind err_log loc (node_id, node_key) session ltr ?linters_def_ in let d = match err_kind with - | Exceptions.Kerror - -> L.d_error - | Exceptions.Kwarning - -> L.d_warning - | Exceptions.Kinfo | Exceptions.Kadvice | Exceptions.Klike - -> L.d_info + | Exceptions.Kerror -> + L.d_error + | Exceptions.Kwarning -> + L.d_warning + | Exceptions.Kinfo | Exceptions.Kadvice | Exceptions.Klike -> + L.d_info in d warn_str ; L.d_ln () in if should_print_now then print_now () + type err_log = t (** Global per-file error table *) @@ -316,6 +335,7 @@ module Err_table = struct let pp ~key:err_string ~data:count = F.fprintf fmt " %s:%d" err_string count in String.Map.iteri ~f:pp !err_name_map + module LocMap = Caml.Map.Make (struct type t = ErrDataSet.elt @@ -333,20 +353,20 @@ module Err_table = struct let add_err nslm key = let map = match (key.in_footprint, key.err_kind) with - | true, Exceptions.Kerror - -> map_err_fp - | false, Exceptions.Kerror - -> map_err_re - | true, Exceptions.Kwarning - -> map_warn_fp - | false, Exceptions.Kwarning - -> map_warn_re - | _, Exceptions.Kinfo - -> map_info - | _, Exceptions.Kadvice - -> map_advice - | _, Exceptions.Klike - -> map_likes + | true, Exceptions.Kerror -> + map_err_fp + | false, Exceptions.Kerror -> + map_err_re + | true, Exceptions.Kwarning -> + map_warn_fp + | false, Exceptions.Kwarning -> + map_warn_re + | _, Exceptions.Kinfo -> + map_info + | _, Exceptions.Kadvice -> + map_advice + | _, Exceptions.Klike -> + map_likes in try let err_list = LocMap.find nslm !map in @@ -378,6 +398,7 @@ module Err_table = struct LocMap.iter (fun nslm err_names -> F.fprintf fmt "%a" (pp Exceptions.Kwarning nslm) err_names) !map_warn_re + end type err_table = Err_table.t @@ -393,6 +414,7 @@ let err_table_size_footprint ekind = let filter ekind' in_footprint = Exceptions.equal_err_kind ekind ekind' && in_footprint in Err_table.table_size filter + (** Print stats for the global per-file error table *) let pp_err_table_stats ekind = Err_table.pp_stats_footprint ekind diff --git a/infer/src/IR/Exceptions.ml b/infer/src/IR/Exceptions.ml index 192c0be42..6ff9d6cd9 100644 --- a/infer/src/IR/Exceptions.ml +++ b/infer/src/IR/Exceptions.ml @@ -24,6 +24,7 @@ let equal_visibility = [%compare.equal : visibility] let string_of_visibility vis = match vis with Exn_user -> "user" | Exn_developer -> "developer" | Exn_system -> "system" + (** severity of bugs *) type severity = | High (** high severity bug *) @@ -160,24 +161,24 @@ type t = let recognize_exception exn = match exn with (* all the static names of errors must be defined in Config.IssueType *) - | Abduction_case_not_implemented ml_loc - -> { name= IssueType.abduction_case_not_implemented + | Abduction_case_not_implemented ml_loc -> + { name= IssueType.abduction_case_not_implemented ; description= Localise.no_desc ; ml_loc= Some ml_loc ; visibility= Exn_developer ; severity= Low ; kind= None ; category= Nocat } - | Context_leak (desc, _) - -> { name= IssueType.context_leak + | Context_leak (desc, _) -> + { name= IssueType.context_leak ; description= desc ; ml_loc= None ; visibility= Exn_user ; severity= High ; kind= None ; category= Nocat } - | Analysis_stops (desc, ml_loc_opt) - -> let visibility = if Config.analysis_stops then Exn_user else Exn_developer in + | Analysis_stops (desc, ml_loc_opt) -> + let visibility = if Config.analysis_stops then Exn_user else Exn_developer in { name= IssueType.analysis_stops ; description= desc ; ml_loc= ml_loc_opt @@ -185,40 +186,40 @@ let recognize_exception exn = ; severity= Medium ; kind= None ; category= Nocat } - | Array_of_pointsto ml_loc - -> { name= IssueType.array_of_pointsto + | Array_of_pointsto ml_loc -> + { name= IssueType.array_of_pointsto ; description= Localise.no_desc ; ml_loc= Some ml_loc ; visibility= Exn_developer ; severity= Low ; kind= None ; category= Nocat } - | Array_out_of_bounds_l1 (desc, ml_loc) - -> { name= IssueType.array_out_of_bounds_l1 + | Array_out_of_bounds_l1 (desc, ml_loc) -> + { name= IssueType.array_out_of_bounds_l1 ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= Some Kerror ; category= Checker } - | Array_out_of_bounds_l2 (desc, ml_loc) - -> { name= IssueType.array_out_of_bounds_l2 + | Array_out_of_bounds_l2 (desc, ml_loc) -> + { name= IssueType.array_out_of_bounds_l2 ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= Medium ; kind= None ; category= Nocat } - | Array_out_of_bounds_l3 (desc, ml_loc) - -> { name= IssueType.array_out_of_bounds_l3 + | Array_out_of_bounds_l3 (desc, ml_loc) -> + { name= IssueType.array_out_of_bounds_l3 ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_developer ; severity= Medium ; kind= None ; category= Nocat } - | Assert_failure (f, l, c) - -> let ml_loc = (f, l, c, c) in + | Assert_failure (f, l, c) -> + let ml_loc = (f, l, c, c) in { name= IssueType.assert_failure ; description= Localise.no_desc ; ml_loc= Some ml_loc @@ -226,48 +227,48 @@ let recognize_exception exn = ; severity= High ; kind= None ; category= Nocat } - | Bad_footprint ml_loc - -> { name= IssueType.bad_footprint + | Bad_footprint ml_loc -> + { name= IssueType.bad_footprint ; description= Localise.no_desc ; ml_loc= Some ml_loc ; visibility= Exn_developer ; severity= Low ; kind= None ; category= Nocat } - | Cannot_star ml_loc - -> { name= IssueType.cannot_star + | Cannot_star ml_loc -> + { name= IssueType.cannot_star ; description= Localise.no_desc ; ml_loc= Some ml_loc ; visibility= Exn_developer ; severity= Low ; kind= None ; category= Nocat } - | Class_cast_exception (desc, ml_loc) - -> { name= IssueType.class_cast_exception + | Class_cast_exception (desc, ml_loc) -> + { name= IssueType.class_cast_exception ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= None ; category= Prover } - | Codequery desc - -> { name= IssueType.codequery + | Codequery desc -> + { name= IssueType.codequery ; description= desc ; ml_loc= None ; visibility= Exn_user ; severity= High ; kind= None ; category= Prover } - | Comparing_floats_for_equality (desc, ml_loc) - -> { name= IssueType.comparing_floats_for_equality + | Comparing_floats_for_equality (desc, ml_loc) -> + { name= IssueType.comparing_floats_for_equality ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= Medium ; kind= None ; category= Nocat } - | Condition_always_true_false (desc, b, ml_loc) - -> let name = if b then IssueType.condition_always_true else IssueType.condition_always_false in + | Condition_always_true_false (desc, b, ml_loc) -> + let name = if b then IssueType.condition_always_true else IssueType.condition_always_false in { name ; description= desc ; ml_loc= Some ml_loc @@ -275,21 +276,21 @@ let recognize_exception exn = ; severity= Medium ; kind= None ; category= Nocat } - | Custom_error (error_msg, desc) - -> { name= IssueType.from_string error_msg + | Custom_error (error_msg, desc) -> + { name= IssueType.from_string error_msg ; description= desc ; ml_loc= None ; visibility= Exn_user ; severity= High ; kind= None ; category= Checker } - | Dangling_pointer_dereference (dko, desc, ml_loc) - -> let visibility = + | Dangling_pointer_dereference (dko, desc, ml_loc) -> + let visibility = match dko with - | Some _ - -> Exn_user (* only show to the user if the category was identified *) - | None - -> Exn_developer + | Some _ -> + Exn_user (* only show to the user if the category was identified *) + | None -> + Exn_developer in { name= IssueType.dangling_pointer_dereference ; description= desc @@ -298,128 +299,128 @@ let recognize_exception exn = ; severity= High ; kind= None ; category= Prover } - | Deallocate_stack_variable desc - -> { name= IssueType.deallocate_stack_variable + | Deallocate_stack_variable desc -> + { name= IssueType.deallocate_stack_variable ; description= desc ; ml_loc= None ; visibility= Exn_user ; severity= High ; kind= None ; category= Prover } - | Deallocate_static_memory desc - -> { name= IssueType.deallocate_static_memory + | Deallocate_static_memory desc -> + { name= IssueType.deallocate_static_memory ; description= desc ; ml_loc= None ; visibility= Exn_user ; severity= High ; kind= None ; category= Prover } - | Deallocation_mismatch (desc, ml_loc) - -> { name= IssueType.deallocation_mismatch + | Deallocation_mismatch (desc, ml_loc) -> + { name= IssueType.deallocation_mismatch ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= None ; category= Prover } - | Divide_by_zero (desc, ml_loc) - -> { name= IssueType.divide_by_zero + | Divide_by_zero (desc, ml_loc) -> + { name= IssueType.divide_by_zero ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= Some Kerror ; category= Checker } - | Double_lock (desc, ml_loc) - -> { name= IssueType.double_lock + | Double_lock (desc, ml_loc) -> + { name= IssueType.double_lock ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= Some Kerror ; category= Prover } - | Eradicate (kind_s, desc) - -> { name= IssueType.from_string kind_s + | Eradicate (kind_s, desc) -> + { name= IssueType.from_string kind_s ; description= desc ; ml_loc= None ; visibility= Exn_user ; severity= High ; kind= None ; category= Prover } - | Empty_vector_access (desc, ml_loc) - -> { name= IssueType.empty_vector_access + | Empty_vector_access (desc, ml_loc) -> + { name= IssueType.empty_vector_access ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= Some Kerror ; category= Prover } - | Field_not_null_checked (desc, ml_loc) - -> { name= IssueType.field_not_null_checked + | Field_not_null_checked (desc, ml_loc) -> + { name= IssueType.field_not_null_checked ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= Medium ; kind= Some Kwarning ; category= Nocat } - | Frontend_warning ((name, hum), desc, ml_loc) - -> { name= IssueType.from_string name ?hum + | Frontend_warning ((name, hum), desc, ml_loc) -> + { name= IssueType.from_string name ?hum ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= Medium ; kind= None ; category= Linters } - | Checkers (kind_s, desc) - -> { name= IssueType.from_string kind_s + | Checkers (kind_s, desc) -> + { name= IssueType.from_string kind_s ; description= desc ; ml_loc= None ; visibility= Exn_user ; severity= High ; kind= None ; category= Prover } - | Null_dereference (desc, ml_loc) - -> { name= IssueType.null_dereference + | Null_dereference (desc, ml_loc) -> + { name= IssueType.null_dereference ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= None ; category= Prover } - | Null_test_after_dereference (desc, ml_loc) - -> { name= IssueType.null_test_after_dereference + | Null_test_after_dereference (desc, ml_loc) -> + { name= IssueType.null_test_after_dereference ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= None ; category= Nocat } - | Pointer_size_mismatch (desc, ml_loc) - -> { name= IssueType.pointer_size_mismatch + | Pointer_size_mismatch (desc, ml_loc) -> + { name= IssueType.pointer_size_mismatch ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= Some Kerror ; category= Checker } - | Inherently_dangerous_function desc - -> { name= IssueType.inherently_dangerous_function + | Inherently_dangerous_function desc -> + { name= IssueType.inherently_dangerous_function ; description= desc ; ml_loc= None ; visibility= Exn_developer ; severity= Medium ; kind= None ; category= Nocat } - | Internal_error desc - -> { name= IssueType.internal_error + | Internal_error desc -> + { name= IssueType.internal_error ; description= desc ; ml_loc= None ; visibility= Exn_developer ; severity= High ; kind= None ; category= Nocat } - | Java_runtime_exception (exn_name, _, desc) - -> let exn_str = Typ.Name.name exn_name in + | Java_runtime_exception (exn_name, _, desc) -> + let exn_str = Typ.Name.name exn_name in { name= IssueType.from_string exn_str ; description= desc ; ml_loc= None @@ -427,8 +428,8 @@ let recognize_exception exn = ; severity= High ; kind= None ; category= Prover } - | Leak (fp_part, _, (exn_vis, error_desc), done_array_abstraction, resource, ml_loc) - -> if done_array_abstraction then + | Leak (fp_part, _, (exn_vis, error_desc), done_array_abstraction, resource, ml_loc) -> + if done_array_abstraction then { name= IssueType.leak_after_array_abstraction ; description= error_desc ; ml_loc= Some ml_loc @@ -447,14 +448,14 @@ let recognize_exception exn = else let name = match resource with - | PredSymb.Rmemory _ - -> IssueType.memory_leak - | PredSymb.Rfile - -> IssueType.resource_leak - | PredSymb.Rlock - -> IssueType.resource_leak - | PredSymb.Rignore - -> IssueType.memory_leak + | PredSymb.Rmemory _ -> + IssueType.memory_leak + | PredSymb.Rfile -> + IssueType.resource_leak + | PredSymb.Rlock -> + IssueType.resource_leak + | PredSymb.Rignore -> + IssueType.memory_leak in { name ; description= error_desc @@ -463,8 +464,8 @@ let recognize_exception exn = ; severity= High ; kind= None ; category= Prover } - | Missing_fld (fld, ml_loc) - -> let desc = Localise.verbatim_desc (Typ.Fieldname.to_full_string fld) in + | Missing_fld (fld, ml_loc) -> + let desc = Localise.verbatim_desc (Typ.Fieldname.to_full_string fld) in { name= IssueType.missing_fld ; description= desc ; ml_loc= Some ml_loc @@ -472,32 +473,32 @@ let recognize_exception exn = ; severity= Medium ; kind= None ; category= Nocat } - | Premature_nil_termination (desc, ml_loc) - -> { name= IssueType.premature_nil_termination + | Premature_nil_termination (desc, ml_loc) -> + { name= IssueType.premature_nil_termination ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= None ; category= Prover } - | Parameter_not_null_checked (desc, ml_loc) - -> { name= IssueType.parameter_not_null_checked + | Parameter_not_null_checked (desc, ml_loc) -> + { name= IssueType.parameter_not_null_checked ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= Medium ; kind= Some Kwarning ; category= Nocat } - | Precondition_not_found (desc, ml_loc) - -> { name= IssueType.precondition_not_found + | Precondition_not_found (desc, ml_loc) -> + { name= IssueType.precondition_not_found ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_developer ; severity= Low ; kind= None ; category= Nocat } - | Precondition_not_met (desc, ml_loc) - -> { name= IssueType.precondition_not_met + | Precondition_not_met (desc, ml_loc) -> + { name= IssueType.precondition_not_met ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_developer @@ -505,72 +506,72 @@ let recognize_exception exn = ; kind= Some Kwarning ; category= Nocat } (* always a warning *) - | Retain_cycle (_, desc, ml_loc) - -> { name= IssueType.retain_cycle + | Retain_cycle (_, desc, ml_loc) -> + { name= IssueType.retain_cycle ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= None ; category= Prover } - | Registered_observer_being_deallocated (desc, ml_loc) - -> { name= IssueType.registered_observer_being_deallocated + | Registered_observer_being_deallocated (desc, ml_loc) -> + { name= IssueType.registered_observer_being_deallocated ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= Some Kerror ; category= Nocat } - | Return_expression_required (desc, ml_loc) - -> { name= IssueType.return_expression_required + | Return_expression_required (desc, ml_loc) -> + { name= IssueType.return_expression_required ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= Medium ; kind= None ; category= Nocat } - | Stack_variable_address_escape (desc, ml_loc) - -> { name= IssueType.stack_variable_address_escape + | Stack_variable_address_escape (desc, ml_loc) -> + { name= IssueType.stack_variable_address_escape ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= Some Kerror ; category= Nocat } - | Return_statement_missing (desc, ml_loc) - -> { name= IssueType.return_statement_missing + | Return_statement_missing (desc, ml_loc) -> + { name= IssueType.return_statement_missing ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= Medium ; kind= None ; category= Nocat } - | Return_value_ignored (desc, ml_loc) - -> { name= IssueType.return_value_ignored + | Return_value_ignored (desc, ml_loc) -> + { name= IssueType.return_value_ignored ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= Medium ; kind= None ; category= Nocat } - | SymOp.Analysis_failure_exe _ - -> { name= IssueType.failure_exe + | SymOp.Analysis_failure_exe _ -> + { name= IssueType.failure_exe ; description= Localise.no_desc ; ml_loc= None ; visibility= Exn_system ; severity= Low ; kind= None ; category= Nocat } - | Skip_function desc - -> { name= IssueType.skip_function + | Skip_function desc -> + { name= IssueType.skip_function ; description= desc ; ml_loc= None ; visibility= Exn_developer ; severity= Low ; kind= None ; category= Nocat } - | Skip_pointer_dereference (desc, ml_loc) - -> { name= IssueType.skip_pointer_dereference + | Skip_pointer_dereference (desc, ml_loc) -> + { name= IssueType.skip_pointer_dereference ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user @@ -578,72 +579,72 @@ let recognize_exception exn = ; kind= Some Kinfo ; category= Nocat } (* always an info *) - | Symexec_memory_error ml_loc - -> { name= IssueType.symexec_memory_error + | Symexec_memory_error ml_loc -> + { name= IssueType.symexec_memory_error ; description= Localise.no_desc ; ml_loc= Some ml_loc ; visibility= Exn_developer ; severity= Low ; kind= None ; category= Nocat } - | Uninitialized_value (desc, ml_loc) - -> { name= IssueType.uninitialized_value + | Uninitialized_value (desc, ml_loc) -> + { name= IssueType.uninitialized_value ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= Medium ; kind= None ; category= Nocat } - | Unary_minus_applied_to_unsigned_expression (desc, ml_loc) - -> { name= IssueType.unary_minus_applied_to_unsigned_expression + | Unary_minus_applied_to_unsigned_expression (desc, ml_loc) -> + { name= IssueType.unary_minus_applied_to_unsigned_expression ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= Medium ; kind= None ; category= Nocat } - | Unknown_proc - -> { name= IssueType.unknown_proc + | Unknown_proc -> + { name= IssueType.unknown_proc ; description= Localise.no_desc ; ml_loc= None ; visibility= Exn_developer ; severity= Low ; kind= None ; category= Nocat } - | Unreachable_code_after (desc, ml_loc) - -> { name= IssueType.unreachable_code_after + | Unreachable_code_after (desc, ml_loc) -> + { name= IssueType.unreachable_code_after ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= Medium ; kind= None ; category= Nocat } - | Unsafe_guarded_by_access (desc, ml_loc) - -> { name= IssueType.unsafe_guarded_by_access + | Unsafe_guarded_by_access (desc, ml_loc) -> + { name= IssueType.unsafe_guarded_by_access ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= None ; category= Prover } - | Use_after_free (desc, ml_loc) - -> { name= IssueType.use_after_free + | Use_after_free (desc, ml_loc) -> + { name= IssueType.use_after_free ; description= desc ; ml_loc= Some ml_loc ; visibility= Exn_user ; severity= High ; kind= None ; category= Prover } - | Wrong_argument_number ml_loc - -> { name= IssueType.wrong_argument_number + | Wrong_argument_number ml_loc -> + { name= IssueType.wrong_argument_number ; description= Localise.no_desc ; ml_loc= Some ml_loc ; visibility= Exn_developer ; severity= Low ; kind= None ; category= Nocat } - | exn - -> { name= IssueType.failure_exe + | exn -> + { name= IssueType.failure_exe ; description= Localise.verbatim_desc (F.asprintf "%a: %s" Exn.pp exn (Caml.Printexc.get_backtrace ())) ; ml_loc= None @@ -652,6 +653,7 @@ let recognize_exception exn = ; kind= None ; category= Nocat } + (** print a description of the exception to the html output *) let print_exception_html s exn = let error = recognize_exception exn in @@ -661,29 +663,32 @@ let print_exception_html s exn = let desc_str = F.asprintf "%a" Localise.pp_error_desc error.description in L.d_strln_color Red (s ^ error.name.IssueType.unique_id ^ " " ^ desc_str ^ ml_loc_string) + (** string describing an error kind *) let err_kind_string = function - | Kwarning - -> "WARNING" - | Kerror - -> "ERROR" - | Kinfo - -> "INFO" - | Kadvice - -> "ADVICE" - | Klike - -> "LIKE" + | Kwarning -> + "WARNING" + | Kerror -> + "ERROR" + | Kinfo -> + "INFO" + | Kadvice -> + "ADVICE" + | Klike -> + "LIKE" + (** string describing an error class *) let err_class_string = function - | Checker - -> "CHECKER" - | Prover - -> "PROVER" - | Nocat - -> "" - | Linters - -> "Linters" + | Checker -> + "CHECKER" + | Prover -> + "PROVER" + | Nocat -> + "" + | Linters -> + "Linters" + (** whether to print the bug key together with the error message *) let print_key = false @@ -695,7 +700,9 @@ let pp_err ~node_key loc ekind ex_name desc ml_loc_opt fmt () = F.fprintf fmt "%a:%d: %s: %a %a%a%a@\n" SourceFile.pp loc.Location.file loc.Location.line kind IssueType.pp ex_name Localise.pp_error_desc desc pp_key node_key L.pp_ml_loc_opt ml_loc_opt + (** Return true if the exception is not serious and should be handled in timeout mode *) let handle_exception exn = let error = recognize_exception exn in equal_visibility error.visibility Exn_user || equal_visibility error.visibility Exn_developer + diff --git a/infer/src/IR/Exceptions.mli b/infer/src/IR/Exceptions.mli index c2d382cf8..0f37b70e3 100644 --- a/infer/src/IR/Exceptions.mli +++ b/infer/src/IR/Exceptions.mli @@ -67,8 +67,7 @@ exception Context_leak of Localise.error_desc * Logging.ml_loc exception Custom_error of string * Localise.error_desc -exception - Dangling_pointer_dereference of +exception Dangling_pointer_dereference of PredSymb.dangling_kind option * Localise.error_desc * Logging.ml_loc exception Deallocate_stack_variable of Localise.error_desc @@ -97,8 +96,7 @@ exception Internal_error of Localise.error_desc exception Java_runtime_exception of Typ.Name.t * string * Localise.error_desc -exception - Leak of +exception Leak of bool * Sil.hpred * (visibility * Localise.error_desc) * bool * PredSymb.resource * Logging.ml_loc exception Missing_fld of Typ.Fieldname.t * Logging.ml_loc diff --git a/infer/src/IR/Exp.ml b/infer/src/IR/Exp.ml index b707ccd89..78dc13d08 100644 --- a/infer/src/IR/Exp.ml +++ b/infer/src/IR/Exp.ml @@ -77,6 +77,7 @@ end) let rec is_array_index_of exp1 exp2 = match exp1 with Lindex (exp, _) -> is_array_index_of exp exp2 | _ -> equal exp1 exp2 + let is_null_literal = function Const Cint n -> IntLit.isnull n | _ -> false let is_this = function Lvar pvar -> Pvar.is_this pvar | _ -> false @@ -88,65 +89,71 @@ let is_zero = function Const Cint n -> IntLit.iszero n | _ -> false (** Turn an expression representing a type into the type it represents If not a sizeof, return the default type if given, otherwise raise an exception *) let texp_to_typ default_opt = function - | Sizeof {typ} - -> typ - | _ - -> Typ.unsome "texp_to_typ" default_opt + | Sizeof {typ} -> + typ + | _ -> + Typ.unsome "texp_to_typ" default_opt + (** Return the root of [lexp]. *) let rec root_of_lexp lexp = match (lexp : t) with - | Var _ - -> lexp - | Const _ - -> lexp - | Cast (_, e) - -> root_of_lexp e - | UnOp _ | BinOp _ | Exn _ | Closure _ - -> lexp - | Lvar _ - -> lexp - | Lfield (e, _, _) - -> root_of_lexp e - | Lindex (e, _) - -> root_of_lexp e - | Sizeof _ - -> lexp + | Var _ -> + lexp + | Const _ -> + lexp + | Cast (_, e) -> + root_of_lexp e + | UnOp _ | BinOp _ | Exn _ | Closure _ -> + lexp + | Lvar _ -> + lexp + | Lfield (e, _, _) -> + root_of_lexp e + | Lindex (e, _) -> + root_of_lexp e + | Sizeof _ -> + lexp + (** Checks whether an expression denotes a location by pointer arithmetic. Currently, catches array - indexing expressions such as a[i] only. *) let rec pointer_arith = function - | Lfield (e, _, _) - -> pointer_arith e - | Lindex _ - -> true - | _ - -> false + | Lfield (e, _, _) -> + pointer_arith e + | Lindex _ -> + true + | _ -> + false + let get_undefined footprint = Var (Ident.create_fresh (if footprint then Ident.kfootprint else Ident.kprimed)) + (** returns true if the expression represents a stack-directed address *) let rec is_stack_addr e = match (e : t) with - | Lvar pv - -> not (Pvar.is_global pv) - | UnOp (_, e', _) | Cast (_, e') | Lfield (e', _, _) | Lindex (e', _) - -> is_stack_addr e' - | _ - -> false + | Lvar pv -> + not (Pvar.is_global pv) + | UnOp (_, e', _) | Cast (_, e') | Lfield (e', _, _) | Lindex (e', _) -> + is_stack_addr e' + | _ -> + false + (** returns true if the express operates on address of local variable *) let rec has_local_addr e = match (e : t) with - | Lvar pv - -> Pvar.is_local pv - | UnOp (_, e', _) | Cast (_, e') | Lfield (e', _, _) - -> has_local_addr e' - | BinOp (_, e0, e1) | Lindex (e0, e1) - -> has_local_addr e0 || has_local_addr e1 - | _ - -> false + | Lvar pv -> + Pvar.is_local pv + | UnOp (_, e', _) | Cast (_, e') | Lfield (e', _, _) -> + has_local_addr e' + | BinOp (_, e0, e1) | Lindex (e0, e1) -> + has_local_addr e0 || has_local_addr e1 + | _ -> + false + (** Create integer constant *) let int i = Const (Cint i) @@ -185,69 +192,70 @@ let lt e1 e2 = BinOp (Lt, e1, e2) let get_vars exp = let rec get_vars_ exp vars = match exp with - | Lvar pvar - -> (fst vars, pvar :: snd vars) - | Var id - -> (id :: fst vars, snd vars) - | Cast (_, e) | UnOp (_, e, _) | Lfield (e, _, _) | Exn e | Sizeof {dynamic_length= Some e} - -> get_vars_ e vars - | BinOp (_, e1, e2) | Lindex (e1, e2) - -> get_vars_ e1 vars |> get_vars_ e2 - | Closure {captured_vars} - -> List.fold + | Lvar pvar -> + (fst vars, pvar :: snd vars) + | Var id -> + (id :: fst vars, snd vars) + | Cast (_, e) | UnOp (_, e, _) | Lfield (e, _, _) | Exn e | Sizeof {dynamic_length= Some e} -> + get_vars_ e vars + | BinOp (_, e1, e2) | Lindex (e1, e2) -> + get_vars_ e1 vars |> get_vars_ e2 + | Closure {captured_vars} -> + List.fold ~f:(fun vars_acc (captured_exp, _, _) -> get_vars_ captured_exp vars_acc) ~init:vars captured_vars - | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _) - -> vars - | Sizeof _ - -> vars + | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _) -> + vars + | Sizeof _ -> + vars in get_vars_ exp ([], []) + (** Pretty print an expression. *) let rec pp_ pe pp_t f e = let pp_exp = pp_ pe pp_t in let print_binop_stm_output e1 op e2 = match (op : Binop.t) with - | Eq | Ne | PlusA | Mult - -> F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe op) pp_exp e1 - | Lt - -> F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Gt) pp_exp e1 - | Gt - -> F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Lt) pp_exp e1 - | Le - -> F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Ge) pp_exp e1 - | Ge - -> F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Le) pp_exp e1 - | _ - -> F.fprintf f "(%a %s %a)" pp_exp e1 (Binop.str pe op) pp_exp e2 + | Eq | Ne | PlusA | Mult -> + F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe op) pp_exp e1 + | Lt -> + F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Gt) pp_exp e1 + | Gt -> + F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Lt) pp_exp e1 + | Le -> + F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Ge) pp_exp e1 + | Ge -> + F.fprintf f "(%a %s %a)" pp_exp e2 (Binop.str pe Le) pp_exp e1 + | _ -> + F.fprintf f "(%a %s %a)" pp_exp e1 (Binop.str pe op) pp_exp e2 in match (e : t) with - | Var id - -> Ident.pp pe f id - | Const c - -> F.fprintf f "%a" (Const.pp pe) c - | Cast (typ, e) - -> F.fprintf f "(%a)%a" pp_t typ pp_exp e - | UnOp (op, e, _) - -> F.fprintf f "%s%a" (Unop.str op) pp_exp e - | BinOp (op, Const c, e2) when Config.smt_output - -> print_binop_stm_output (Const c) op e2 - | BinOp (op, e1, e2) - -> F.fprintf f "(%a %s %a)" pp_exp e1 (Binop.str pe op) pp_exp e2 - | Exn e - -> F.fprintf f "EXN %a" pp_exp e - | Closure {name; captured_vars} - -> let id_exps = List.map ~f:(fun (id_exp, _, _) -> id_exp) captured_vars in + | Var id -> + Ident.pp pe f id + | Const c -> + F.fprintf f "%a" (Const.pp pe) c + | Cast (typ, e) -> + F.fprintf f "(%a)%a" pp_t typ pp_exp e + | UnOp (op, e, _) -> + F.fprintf f "%s%a" (Unop.str op) pp_exp e + | BinOp (op, Const c, e2) when Config.smt_output -> + print_binop_stm_output (Const c) op e2 + | BinOp (op, e1, e2) -> + F.fprintf f "(%a %s %a)" pp_exp e1 (Binop.str pe op) pp_exp e2 + | Exn e -> + F.fprintf f "EXN %a" pp_exp e + | Closure {name; captured_vars} -> + let id_exps = List.map ~f:(fun (id_exp, _, _) -> id_exp) captured_vars in F.fprintf f "(%a)" (Pp.comma_seq pp_exp) (Const (Cfun name) :: id_exps) - | Lvar pv - -> Pvar.pp pe f pv - | Lfield (e, fld, _) - -> F.fprintf f "%a.%a" pp_exp e Typ.Fieldname.pp fld - | Lindex (e1, e2) - -> F.fprintf f "%a[%a]" pp_exp e1 pp_exp e2 - | Sizeof {typ; nbytes; dynamic_length; subtype} - -> let pp_len f l = Option.iter ~f:(F.fprintf f "[%a]" pp_exp) l in + | Lvar pv -> + Pvar.pp pe f pv + | Lfield (e, fld, _) -> + F.fprintf f "%a.%a" pp_exp e Typ.Fieldname.pp fld + | Lindex (e1, e2) -> + F.fprintf f "%a[%a]" pp_exp e1 pp_exp e2 + | Sizeof {typ; nbytes; dynamic_length; subtype} -> + let pp_len f l = Option.iter ~f:(F.fprintf f "[%a]" pp_exp) l in let pp_size f size = Option.iter ~f:(Int.pp f) size in let pp_if b pp label f v = if b then F.fprintf f ";%s=%a" label pp v in let pp_if_some pp_opt label f opt = pp_if (Option.is_some opt) pp_opt label f opt in @@ -257,6 +265,7 @@ let rec pp_ pe pp_t f e = (pp_if (not (String.equal "" subt_s)) Subtype.pp "sub_t") subtype + let pp_printenv pe pp_typ f e = pp_ pe (pp_typ pe) f e let pp f e = pp_printenv Pp.text Typ.pp f e diff --git a/infer/src/IR/HilExp.ml b/infer/src/IR/HilExp.ml index fa559c9af..f49dff663 100644 --- a/infer/src/IR/HilExp.ml +++ b/infer/src/IR/HilExp.ml @@ -23,78 +23,81 @@ type t = [@@deriving compare] let rec pp fmt = function - | AccessPath access_path - -> AccessPath.pp fmt access_path - | UnaryOperator (op, e, _) - -> F.fprintf fmt "%s%a" (Unop.str op) pp e - | BinaryOperator (op, e1, e2) - -> F.fprintf fmt "%a %s %a" pp e1 (Binop.str Pp.text op) pp e2 - | Exception e - -> F.fprintf fmt "exception %a" pp e - | Closure (pname, _) - -> F.fprintf fmt "closure(%a)" Typ.Procname.pp pname - | Constant c - -> Const.pp Pp.text fmt c - | Cast (typ, e) - -> F.fprintf fmt "(%a) %a" (Typ.pp_full Pp.text) typ pp e - | Sizeof (typ, length) - -> let pp_length fmt = Option.iter ~f:(F.fprintf fmt "[%a]" pp) in + | AccessPath access_path -> + AccessPath.pp fmt access_path + | UnaryOperator (op, e, _) -> + F.fprintf fmt "%s%a" (Unop.str op) pp e + | BinaryOperator (op, e1, e2) -> + F.fprintf fmt "%a %s %a" pp e1 (Binop.str Pp.text op) pp e2 + | Exception e -> + F.fprintf fmt "exception %a" pp e + | Closure (pname, _) -> + F.fprintf fmt "closure(%a)" Typ.Procname.pp pname + | Constant c -> + Const.pp Pp.text fmt c + | Cast (typ, e) -> + F.fprintf fmt "(%a) %a" (Typ.pp_full Pp.text) typ pp e + | Sizeof (typ, length) -> + let pp_length fmt = Option.iter ~f:(F.fprintf fmt "[%a]" pp) in F.fprintf fmt "sizeof(%a%a)" (Typ.pp_full Pp.text) typ pp_length length + let rec get_typ tenv = function - | AccessPath access_path - -> AccessPath.get_typ access_path tenv - | UnaryOperator (_, _, typ_opt) - -> typ_opt - | BinaryOperator ((Lt | Gt | Le | Ge | Eq | Ne | LAnd | LOr), _, _) - -> Some (Typ.mk (Typ.Tint Typ.IBool)) + | AccessPath access_path -> + AccessPath.get_typ access_path tenv + | UnaryOperator (_, _, typ_opt) -> + typ_opt + | BinaryOperator ((Lt | Gt | Le | Ge | Eq | Ne | LAnd | LOr), _, _) -> + Some (Typ.mk (Typ.Tint Typ.IBool)) | BinaryOperator (_, e1, e2) -> ( match (* TODO: doing this properly will require taking account of language-specific coercion semantics. Only return a type when the operands have the same type for now *) (get_typ tenv e1, get_typ tenv e2) with - | Some typ1, Some typ2 when Typ.equal typ1 typ2 - -> Some typ1 - | _ - -> None ) - | Exception t - -> get_typ tenv t - | Closure _ | Constant Cfun _ - -> (* We don't have a way to represent function types *) + | Some typ1, Some typ2 when Typ.equal typ1 typ2 -> + Some typ1 + | _ -> + None ) + | Exception t -> + get_typ tenv t + | Closure _ | Constant Cfun _ -> + (* We don't have a way to represent function types *) None - | Constant Cint _ - -> (* TODO: handle signedness *) + | Constant Cint _ -> + (* TODO: handle signedness *) Some (Typ.mk (Typ.Tint Typ.IInt)) - | Constant Cfloat _ - -> Some (Typ.mk (Typ.Tfloat Typ.FFloat)) - | Constant Cclass _ - -> (* TODO: this only happens in Java. We probably need to change it to `Cclass of Typ.Name.t` + | Constant Cfloat _ -> + Some (Typ.mk (Typ.Tfloat Typ.FFloat)) + | Constant Cclass _ -> + (* TODO: this only happens in Java. We probably need to change it to `Cclass of Typ.Name.t` to give a useful result here *) None - | Constant Cstr _ - -> (* TODO: this will need to behave differently depending on whether we're in C++ or Java *) + | Constant Cstr _ -> + (* TODO: this will need to behave differently depending on whether we're in C++ or Java *) None - | Cast (typ, _) - -> Some typ - | Sizeof _ - -> (* sizeof returns a size_t, which is an unsigned int *) + | Cast (typ, _) -> + Some typ + | Sizeof _ -> + (* sizeof returns a size_t, which is an unsigned int *) Some (Typ.mk (Typ.Tint Typ.IUInt)) + let get_access_paths exp0 = let rec get_access_paths_ exp acc = match exp with - | AccessPath ap - -> ap :: acc - | Cast (_, e) | UnaryOperator (_, e, _) | Exception e | Sizeof (_, Some e) - -> get_access_paths_ e acc - | BinaryOperator (_, e1, e2) - -> get_access_paths_ e1 acc |> get_access_paths_ e2 - | Closure _ | Constant _ | Sizeof _ - -> acc + | AccessPath ap -> + ap :: acc + | Cast (_, e) | UnaryOperator (_, e, _) | Exception e | Sizeof (_, Some e) -> + get_access_paths_ e acc + | BinaryOperator (_, e1, e2) -> + get_access_paths_ e1 acc |> get_access_paths_ e2 + | Closure _ | Constant _ | Sizeof _ -> + acc in get_access_paths_ exp0 [] + (* convert an SIL expression into an HIL expression. the [f_resolve_id] function should map an SSA temporary variable to the access path it represents. evaluating the HIL expression should produce the same result as evaluating the SIL expression and replacing the temporary variables @@ -102,29 +105,29 @@ let get_access_paths exp0 = let of_sil ~include_array_indexes ~f_resolve_id exp typ = let rec of_sil_ (exp: Exp.t) typ = match exp with - | Var id - -> let ap = + | Var id -> + let ap = match f_resolve_id (Var.of_id id) with - | Some access_path - -> access_path - | None - -> AccessPath.of_id id typ + | Some access_path -> + access_path + | None -> + AccessPath.of_id id typ in AccessPath ap - | UnOp (op, e, typ_opt) - -> UnaryOperator (op, of_sil_ e typ, typ_opt) - | BinOp (op, e0, e1) - -> BinaryOperator (op, of_sil_ e0 typ, of_sil_ e1 typ) - | Exn e - -> Exception (of_sil_ e typ) - | Const c - -> Constant c - | Cast (cast_typ, e) - -> Cast (cast_typ, of_sil_ e typ) - | Sizeof {typ; dynamic_length} - -> Sizeof (typ, Option.map ~f:(fun e -> of_sil_ e typ) dynamic_length) - | Closure closure - -> let environment = + | UnOp (op, e, typ_opt) -> + UnaryOperator (op, of_sil_ e typ, typ_opt) + | BinOp (op, e0, e1) -> + BinaryOperator (op, of_sil_ e0 typ, of_sil_ e1 typ) + | Exn e -> + Exception (of_sil_ e typ) + | Const c -> + Constant c + | Cast (cast_typ, e) -> + Cast (cast_typ, of_sil_ e typ) + | Sizeof {typ; dynamic_length} -> + Sizeof (typ, Option.map ~f:(fun e -> of_sil_ e typ) dynamic_length) + | Closure closure -> + let environment = List.map ~f:(fun (value, pvar, typ) -> (AccessPath.base_of_pvar pvar typ, of_sil_ value typ)) closure.captured_vars @@ -132,38 +135,39 @@ let of_sil ~include_array_indexes ~f_resolve_id exp typ = Closure (closure.name, environment) | Lfield (root_exp, fld, root_exp_typ) -> ( match AccessPath.of_lhs_exp ~include_array_indexes exp typ ~f_resolve_id with - | Some access_path - -> AccessPath access_path - | None - -> (* unsupported field expression: represent with a dummy variable *) + | Some access_path -> + AccessPath access_path + | None -> + (* unsupported field expression: represent with a dummy variable *) of_sil_ (Exp.Lfield ( Var (Ident.create_normal (Ident.string_to_name (Exp.to_string root_exp)) 0) , fld , root_exp_typ )) typ ) - | Lindex (Const Cstr s, index_exp) - -> (* indexed string literal (e.g., "foo"[1]). represent this by introducing a dummy variable + | Lindex (Const Cstr s, index_exp) -> + (* indexed string literal (e.g., "foo"[1]). represent this by introducing a dummy variable for the string literal. if you actually need to see the value of the string literal in the analysis, you should probably be using SIL. this is unsound if the code modifies the literal, e.g. using `const_cast` *) of_sil_ (Exp.Lindex (Var (Ident.create_normal (Ident.string_to_name s) 0), index_exp)) typ | Lindex (root_exp, index_exp) -> ( match AccessPath.of_lhs_exp ~include_array_indexes exp typ ~f_resolve_id with - | Some access_path - -> AccessPath access_path - | None - -> (* unsupported index expression: represent with a dummy variable *) + | Some access_path -> + AccessPath access_path + | None -> + (* unsupported index expression: represent with a dummy variable *) of_sil_ (Exp.Lindex ( Var (Ident.create_normal (Ident.string_to_name (Exp.to_string root_exp)) 0) , index_exp )) typ ) | Lvar _ -> match AccessPath.of_lhs_exp ~include_array_indexes exp typ ~f_resolve_id with - | Some access_path - -> AccessPath access_path - | None - -> L.(die InternalError) "Couldn't convert var expression %a to access path" Exp.pp exp + | Some access_path -> + AccessPath access_path + | None -> + L.(die InternalError) "Couldn't convert var expression %a to access path" Exp.pp exp in of_sil_ exp typ + let is_null_literal = function Constant Cint n -> IntLit.isnull n | _ -> false diff --git a/infer/src/IR/HilInstr.ml b/infer/src/IR/HilInstr.ml index 21c101dc7..bcf9f52ad 100644 --- a/infer/src/IR/HilInstr.ml +++ b/infer/src/IR/HilInstr.ml @@ -14,10 +14,11 @@ module L = Logging type call = Direct of Typ.Procname.t | Indirect of AccessPath.t [@@deriving compare] let pp_call fmt = function - | Direct pname - -> Typ.Procname.pp fmt pname - | Indirect access_path - -> F.fprintf fmt "*%a" AccessPath.pp access_path + | Direct pname -> + Typ.Procname.pp fmt pname + | Indirect access_path -> + F.fprintf fmt "*%a" AccessPath.pp access_path + type t = | Assign of AccessPath.t * HilExp.t * Location.t @@ -26,15 +27,16 @@ type t = [@@deriving compare] let pp fmt = function - | Assign (access_path, exp, loc) - -> F.fprintf fmt "%a := %a [%a]" AccessPath.pp access_path HilExp.pp exp Location.pp loc - | Assume (exp, _, _, loc) - -> F.fprintf fmt "assume %a [%a]" HilExp.pp exp Location.pp loc - | Call (ret_opt, call, actuals, _, loc) - -> let pp_ret fmt = Option.iter ~f:(F.fprintf fmt "%a := " AccessPath.pp_base) in + | Assign (access_path, exp, loc) -> + F.fprintf fmt "%a := %a [%a]" AccessPath.pp access_path HilExp.pp exp Location.pp loc + | Assume (exp, _, _, loc) -> + F.fprintf fmt "assume %a [%a]" HilExp.pp exp Location.pp loc + | Call (ret_opt, call, actuals, _, loc) -> + let pp_ret fmt = Option.iter ~f:(F.fprintf fmt "%a := " AccessPath.pp_base) in let pp_actuals fmt = PrettyPrintable.pp_collection ~pp_item:HilExp.pp fmt in F.fprintf fmt "%a%a(%a) [%a]" pp_ret ret_opt pp_call call pp_actuals actuals Location.pp loc + type translation = Instr of t | Bind of Var.t * AccessPath.t | Unbind of Var.t list | Ignore (* convert an SIL instruction into an HIL instruction. the [f_resolve_id] function should map an SSA @@ -46,29 +48,29 @@ let of_sil ~include_array_indexes ~f_resolve_id (instr: Sil.instr) = let analyze_id_assignment lhs_id rhs_exp rhs_typ loc = let rhs_hil_exp = exp_of_sil rhs_exp rhs_typ in match HilExp.get_access_paths rhs_hil_exp with - | [rhs_access_path] - -> Bind (lhs_id, rhs_access_path) - | _ - -> Instr (Assign (((lhs_id, rhs_typ), []), rhs_hil_exp, loc)) + | [rhs_access_path] -> + Bind (lhs_id, rhs_access_path) + | _ -> + Instr (Assign (((lhs_id, rhs_typ), []), rhs_hil_exp, loc)) in match instr with - | Load (lhs_id, rhs_exp, rhs_typ, loc) - -> analyze_id_assignment (Var.of_id lhs_id) rhs_exp rhs_typ loc - | Store (Lvar lhs_pvar, lhs_typ, rhs_exp, loc) when Pvar.is_ssa_frontend_tmp lhs_pvar - -> analyze_id_assignment (Var.of_pvar lhs_pvar) rhs_exp lhs_typ loc + | Load (lhs_id, rhs_exp, rhs_typ, loc) -> + analyze_id_assignment (Var.of_id lhs_id) rhs_exp rhs_typ loc + | Store (Lvar lhs_pvar, lhs_typ, rhs_exp, loc) when Pvar.is_ssa_frontend_tmp lhs_pvar -> + analyze_id_assignment (Var.of_pvar lhs_pvar) rhs_exp lhs_typ loc | Call ( Some (ret_id, _) , Const Cfun callee_pname , (target_exp, _) :: (Sizeof {typ= cast_typ}, _) :: _ , loc , _ ) - when Typ.Procname.equal callee_pname BuiltinDecl.__cast - -> analyze_id_assignment (Var.of_id ret_id) target_exp cast_typ loc - | Store (lhs_exp, typ, rhs_exp, loc) - -> let lhs_access_path = + when Typ.Procname.equal callee_pname BuiltinDecl.__cast -> + analyze_id_assignment (Var.of_id ret_id) target_exp cast_typ loc + | Store (lhs_exp, typ, rhs_exp, loc) -> + let lhs_access_path = match exp_of_sil lhs_exp typ with - | AccessPath ap - -> ap + | AccessPath ap -> + ap | BinaryOperator (_, exp0, exp1) -> ( match (* pointer arithmetic. somewhere in one of the expressions, there should be at least @@ -77,42 +79,43 @@ let of_sil ~include_array_indexes ~f_resolve_id (instr: Sil.instr) = SIL instead *) HilExp.get_access_paths exp0 with - | ap :: _ - -> ap + | ap :: _ -> + ap | [] -> match HilExp.get_access_paths exp1 with - | ap :: _ - -> ap - | [] - -> L.(die InternalError) + | ap :: _ -> + ap + | [] -> + L.(die InternalError) "Invalid pointer arithmetic expression %a used as LHS" Exp.pp lhs_exp ) - | _ - -> L.(die InternalError) "Non-assignable LHS expression %a" Exp.pp lhs_exp + | _ -> + L.(die InternalError) "Non-assignable LHS expression %a" Exp.pp lhs_exp in Instr (Assign (lhs_access_path, exp_of_sil rhs_exp typ, loc)) - | Call (ret_opt, call_exp, formals, loc, call_flags) - -> let hil_ret = Option.map ~f:(fun (ret_id, ret_typ) -> (Var.of_id ret_id, ret_typ)) ret_opt in + | Call (ret_opt, call_exp, formals, loc, call_flags) -> + let hil_ret = Option.map ~f:(fun (ret_id, ret_typ) -> (Var.of_id ret_id, ret_typ)) ret_opt in let hil_call = match exp_of_sil call_exp (Typ.mk Tvoid) with - | Constant Cfun procname | Closure (procname, _) - -> Direct procname - | AccessPath access_path - -> Indirect access_path - | call_exp - -> L.(die InternalError) "Unexpected call expression %a" HilExp.pp call_exp + | Constant Cfun procname | Closure (procname, _) -> + Direct procname + | AccessPath access_path -> + Indirect access_path + | call_exp -> + L.(die InternalError) "Unexpected call expression %a" HilExp.pp call_exp in let formals = List.map ~f:(fun (exp, typ) -> exp_of_sil exp typ) formals in Instr (Call (hil_ret, hil_call, formals, call_flags, loc)) - | Prune (exp, loc, true_branch, if_kind) - -> let hil_exp = exp_of_sil exp (Typ.mk (Tint IBool)) in + | Prune (exp, loc, true_branch, if_kind) -> + let hil_exp = exp_of_sil exp (Typ.mk (Tint IBool)) in let branch = if true_branch then `Then else `Else in Instr (Assume (hil_exp, branch, if_kind, loc)) - | Nullify (pvar, _) - -> Unbind [Var.of_pvar pvar] - | Remove_temps (ids, _) - -> Unbind (List.map ~f:Var.of_id ids) + | Nullify (pvar, _) -> + Unbind [Var.of_pvar pvar] + | Remove_temps (ids, _) -> + Unbind (List.map ~f:Var.of_id ids) (* ignoring for now; will translate as builtin function call if needed *) | Abstract _ - | Declare_locals _ - -> (* these don't seem useful for most analyses. can translate them later if we want to *) + | Declare_locals _ -> + (* these don't seem useful for most analyses. can translate them later if we want to *) Ignore + diff --git a/infer/src/IR/Ident.ml b/infer/src/IR/Ident.ml index 2a70134d8..3d70711ed 100644 --- a/infer/src/IR/Ident.ml +++ b/infer/src/IR/Ident.ml @@ -29,16 +29,17 @@ module Name = struct let from_string s = FromString s let to_string = function - | Primed - -> primed - | Normal - -> normal - | Footprint - -> footprint - | Spec - -> spec - | FromString s - -> s + | Primed -> + primed + | Normal -> + normal + | Footprint -> + footprint + | Spec -> + spec + | FromString s -> + s + end type name = Name.t [@@deriving compare] @@ -75,6 +76,7 @@ type t = {kind: kind; name: Name.t; stamp: int} [@@deriving compare] let equal i1 i2 = Int.equal i1.stamp i2.stamp && equal_kind i1.kind i2.kind && equal_name i1.name i2.name + (** {2 Set for identifiers} *) module IdentSet = Caml.Set.Make (struct type nonrec t = t @@ -149,6 +151,7 @@ module NameGenerator = struct in {kind; name; stamp} + (** Make sure that fresh ids after whis one will be with different stamps *) let update_name_hash name stamp = try @@ -156,6 +159,7 @@ module NameGenerator = struct let new_stamp = max curr_stamp stamp in NameHash.replace !name_map name new_stamp with Not_found -> NameHash.add !name_map name stamp + end (** Name used for the return variable *) @@ -167,9 +171,12 @@ let standard_name kind = else if equal_kind kind KFootprint then Name.Footprint else Name.Primed + (** Every identifier with a given stamp should unltimately be created using this function *) let create_with_stamp kind name stamp = - NameGenerator.update_name_hash name stamp ; {kind; name; stamp} + NameGenerator.update_name_hash name stamp ; + {kind; name; stamp} + (** Create an identifier with default name for the given kind *) let create kind stamp = create_with_stamp kind (standard_name kind) stamp @@ -210,15 +217,18 @@ let make_unprimed id = else if has_kind id KNone then {id with kind= KNone} else {id with kind= KNormal} + (** Update the name generator so that the given id's are not generated again *) let update_name_generator ids = let upd id = ignore (create_with_stamp id.kind id.name id.stamp) in List.iter ~f:upd ids + (** Generate a normal identifier whose name encodes a path given as a string. *) let create_path pathstring = create_normal (string_to_name ("%path%" ^ pathstring)) path_ident_stamp + (** {2 Pretty Printing} *) (** Convert an identifier to a string. *) @@ -230,6 +240,7 @@ let to_string id = let suffix = "$" ^ string_of_int id.stamp in prefix ^ base_name ^ suffix + (** Pretty print a name. *) let pp_name f name = F.fprintf f "%s" (name_to_string name) @@ -239,10 +250,10 @@ let pp_name_latex style f (name: name) = Latex.pp_string style f (name_to_string (** Pretty print an identifier. *) let pp pe f id = match pe.Pp.kind with - | TEXT | HTML - -> F.fprintf f "%s" (to_string id) - | LATEX - -> let base_name = name_to_string id.name in + | TEXT | HTML -> + F.fprintf f "%s" (to_string id) + | LATEX -> + let base_name = name_to_string id.name in let style = if has_kind id KFootprint then Latex.Boldface else if has_kind id KNormal then Latex.Roman @@ -250,6 +261,7 @@ let pp pe f id = in F.fprintf f "%a_{%s}" (Latex.pp_string style) base_name (string_of_int id.stamp) + (** pretty printer for lists of identifiers *) let pp_list pe = Pp.comma_seq (pp pe) diff --git a/infer/src/IR/IntLit.ml b/infer/src/IR/IntLit.ml index 81942037b..9b3c7b24e 100644 --- a/infer/src/IR/IntLit.ml +++ b/infer/src/IR/IntLit.ml @@ -21,24 +21,28 @@ exception OversizedShift let area u i = match (i < 0L, u) with - | true, false - -> (* only representable as signed *) 1 - | false, _ - -> (* in the intersection between signed and unsigned *) 2 - | true, true - -> (* only representable as unsigned *) 3 + | true, false -> + (* only representable as signed *) 1 + | false, _ -> + (* in the intersection between signed and unsigned *) 2 + | true, true -> + (* only representable as unsigned *) 3 + let to_signed (unsigned, i, ptr) = if Int.equal (area unsigned i) 3 then None else (* not representable as signed *) Some (false, i, ptr) + let compare (unsigned1, i1, _) (unsigned2, i2, _) = let n = Bool.compare unsigned1 unsigned2 in if n <> 0 then n else Int64.compare i1 i2 + let compare_value (unsigned1, i1, _) (unsigned2, i2, _) = [%compare : int * Int64.t] (area unsigned1 i1, i1) (area unsigned2 i2, i2) + let eq i1 i2 = Int.equal (compare_value i1 i2) 0 let neq i1 i2 = compare_value i1 i2 <> 0 @@ -86,6 +90,7 @@ let neg (unsigned, i, ptr) = (unsigned, Int64.neg i, ptr) let lift binop (unsigned1, i1, ptr1) (unsigned2, i2, ptr2) = (unsigned1 || unsigned2, binop i1 i2, ptr1 || ptr2) + let lift1 unop (unsigned, i, ptr) = (unsigned, unop i, ptr) let add i1 i2 = lift Int64.( + ) i1 i2 @@ -108,25 +113,28 @@ let sub i1 i2 = add i1 (neg i2) let shift_left (unsigned1, i1, ptr1) (_, i2, _) = match Int64.to_int i2 with - | None - -> L.(die InternalError) "Shifting failed with operand %a" Int64.pp i2 - | Some i2 - -> if i2 < 0 || i2 >= 64 then raise OversizedShift ; + | None -> + L.(die InternalError) "Shifting failed with operand %a" Int64.pp i2 + | Some i2 -> + if i2 < 0 || i2 >= 64 then raise OversizedShift ; let res = Int64.shift_left i1 i2 in (unsigned1, res, ptr1) + let shift_right (unsigned1, i1, ptr1) (_, i2, _) = match Int64.to_int i2 with - | None - -> L.(die InternalError) "Shifting failed with operand %a" Int64.pp i2 - | Some i2 - -> if i2 < 0 || i2 >= 64 then raise OversizedShift ; + | None -> + L.(die InternalError) "Shifting failed with operand %a" Int64.pp i2 + | Some i2 -> + if i2 < 0 || i2 >= 64 then raise OversizedShift ; let res = Int64.shift_right i1 i2 in (unsigned1, res, ptr1) + let pp f (unsigned, n, ptr) = if ptr && Int64.equal n 0L then F.fprintf f "null" else if unsigned then F.fprintf f "%Lu" n else F.fprintf f "%Ld" n + let to_string i = F.asprintf "%a" pp i diff --git a/infer/src/IR/Io_infer.ml b/infer/src/IR/Io_infer.ml index b025a5ac4..f5787f912 100644 --- a/infer/src/IR/Io_infer.ml +++ b/infer/src/IR/Io_infer.ml @@ -20,10 +20,10 @@ module Html = struct let create pk path = let fname, dir_path = match List.rev path with - | fname :: path_rev - -> (fname, List.rev ((fname ^ ".html") :: path_rev)) - | [] - -> raise (Failure "Html.create") + | fname :: path_rev -> + (fname, List.rev ((fname ^ ".html") :: path_rev)) + | [] -> + raise (Failure "Html.create") in let fd = DB.Results_dir.create_file pk dir_path in let outc = Unix.out_channel_of_descr fd in @@ -84,22 +84,25 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e in F.fprintf fmt "%s" s ; (fd, fmt) + (** Get the full html filename from a path *) let get_full_fname source path = let dir_path = match List.rev path with - | fname :: path_rev - -> List.rev ((fname ^ ".html") :: path_rev) - | [] - -> raise (Failure "Html.open_out") + | fname :: path_rev -> + List.rev ((fname ^ ".html") :: path_rev) + | [] -> + raise (Failure "Html.open_out") in DB.Results_dir.path_to_filename (DB.Results_dir.Abs_source_dir source) dir_path + (** Open an Html file to append data *) let open_out source path = let full_fname = get_full_fname source path in let fd = - Unix.openfile (DB.filename_to_string full_fname) + Unix.openfile + (DB.filename_to_string full_fname) ~mode:Unix.([O_WRONLY; O_APPEND]) ~perm:0o777 in @@ -107,14 +110,19 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e let fmt = F.formatter_of_out_channel outc in (fd, fmt) + (** Return true if the html file was modified since the beginning of the analysis *) let modified_during_analysis source path = let fname = get_full_fname source path in if DB.file_exists fname then DB.file_modified_time fname >= Config.initial_analysis_time else false + (** Close an Html file *) - let close (fd, fmt) = F.fprintf fmt "@\n@." ; Unix.close fd + let close (fd, fmt) = + F.fprintf fmt "@\n@." ; + Unix.close fd + (** Print a horizontal line *) let pp_hline fmt () = F.fprintf fmt "
@\n" @@ -136,6 +144,7 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e let pr_str = "" ^ text ^ "" in F.fprintf fmt " %s" pr_str + (** File name for the node, given the procedure name and node id *) let node_filename pname id = Typ.Procname.to_filename pname ^ "_node" ^ string_of_int id @@ -161,10 +170,12 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e in pp_link ~path:(path_to_root @ ["nodes"; node_fname]) fmt node_text + (** Print an html link to the given proc *) let pp_proc_link path_to_root proc_name fmt text = pp_link ~path:(path_to_root @ [Typ.Procname.to_filename proc_name]) fmt text + (** Print an html link to the given line number of the current source file *) let pp_line_link ?(with_name= false) ?(text= None) source path_to_root fmt linenum = let fname = DB.source_file_encoding source in @@ -177,6 +188,7 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e fmt (match text with Some s -> s | None -> linenum_str) + (** Print an html link given node id and session *) let pp_session_link ?(with_name= false) ?proc_name source path_to_root fmt (node_id, session, linenum) = @@ -191,6 +203,7 @@ td.rowname { text-align:right; font-weight:bold; color:#444444; padding-right:2e ~pos:(Some pos) ~path:path_to_node fmt (node_name ^ "#" ^ pos) ; F.fprintf fmt "(%a)" (pp_line_link source path_to_root) linenum + end (* =============== END of module Html =============== *) @@ -294,22 +307,23 @@ module Xml = struct (** print an xml node *) let rec pp_node newline indent fmt = function - | Tree {name; attributes; forest} - -> let indent' = if String.equal newline "" then "" else indent ^ " " in + | Tree {name; attributes; forest} -> + let indent' = if String.equal newline "" then "" else indent ^ " " in let space = if List.is_empty attributes then "" else " " in let pp_inside fmt () = match forest with - | [] - -> () - | [(String s)] - -> pp fmt "%s" s - | _ - -> pp fmt "%s%a%s" newline (pp_forest newline indent') forest indent + | [] -> + () + | [(String s)] -> + pp fmt "%s" s + | _ -> + pp fmt "%s%a%s" newline (pp_forest newline indent') forest indent in pp fmt "%s<%s%s%a>%a%s" indent name space pp_attributes attributes pp_inside () name newline - | String s - -> F.fprintf fmt "%s%s%s" indent s newline + | String s -> + F.fprintf fmt "%s%s%s" indent s newline + and pp_forest newline indent fmt forest = List.iter ~f:(pp_node newline indent fmt) forest @@ -327,6 +341,7 @@ module Xml = struct if on_several_lines then pp_prelude fmt ; pp_node newline "" fmt node ; if on_several_lines then pp fmt "@." + end (* =============== END of module Xml =============== *) diff --git a/infer/src/IR/LintIssues.ml b/infer/src/IR/LintIssues.ml index 644a470da..b30d2d862 100644 --- a/infer/src/IR/LintIssues.ml +++ b/infer/src/IR/LintIssues.ml @@ -22,13 +22,16 @@ let get_err_log procname = errLogMap := Typ.Procname.Map.add procname errlog !errLogMap ; errlog + let lint_issues_serializer : Errlog.t Typ.Procname.Map.t Serialization.serializer = Serialization.create_serializer Serialization.Key.lint_issues + (** Save issues to a file *) let store_issues filename errLogMap = Serialization.write_to_file lint_issues_serializer filename ~data:errLogMap + (** Load issues from the given file *) let load_issues issues_file = Serialization.read_from_file lint_issues_serializer issues_file @@ -42,21 +45,22 @@ let load_issues_to_errlog_map dir = let load_issues_to_map issues_file = let file = DB.filename_from_string (Filename.concat issues_dir issues_file) in match load_issues file with - | Some map - -> errLogMap + | Some map -> + errLogMap := Typ.Procname.Map.merge (fun _ issues1 issues2 -> match (issues1, issues2) with - | Some issues1, Some issues2 - -> Errlog.update issues1 issues2 ; Some issues1 - | Some issues1, None - -> Some issues1 - | None, Some issues2 - -> Some issues2 - | None, None - -> None) + | Some issues1, Some issues2 -> + Errlog.update issues1 issues2 ; Some issues1 + | Some issues1, None -> + Some issues1 + | None, Some issues2 -> + Some issues2 + | None, None -> + None) !errLogMap map - | None - -> () + | None -> + () in match children_opt with Some children -> Array.iter ~f:load_issues_to_map children | None -> () + diff --git a/infer/src/IR/Localise.ml b/infer/src/IR/Localise.ml index ba0c61289..4fe520e5c 100644 --- a/infer/src/IR/Localise.ml +++ b/infer/src/IR/Localise.ml @@ -100,11 +100,13 @@ module Tags = struct let get tags tag = List.Assoc.find ~equal:String.equal tags tag let tag_value_records_of_tags tags = - List.map ~f:(fun (tag, value) -> {Jsonbug_t.tag= tag; value}) tags + List.map ~f:(fun (tag, value) -> {Jsonbug_t.tag; value}) tags + let tags_of_tag_value_records (tag_value_records: Jsonbug_t.tag_value_record list) = List.map ~f:(fun {Jsonbug_t.tag; value} -> (tag, value)) tag_value_records + let lines_of_tags (tags: t) = let line_tags = String.Set.of_list @@ -114,6 +116,7 @@ module Tags = struct ~f:(fun (tag, value) -> if String.Set.mem line_tags tag then Some (int_of_string value) else None) tags + end type error_desc = @@ -131,15 +134,18 @@ let custom_desc s tags = {no_desc with descriptions= [s]; tags} let custom_desc_with_advice description advice tags = {no_desc with descriptions= [description]; advice= Some advice; tags} + (** pretty print an error description *) let pp_error_desc fmt err_desc = let pp_item fmt s = F.fprintf fmt "%s" s in Pp.seq pp_item fmt err_desc.descriptions + (** pretty print an error advice *) let pp_error_advice fmt err_desc = match err_desc.advice with Some advice -> F.fprintf fmt "%s" advice | None -> () + (** get tags of error description *) let error_desc_get_tags err_desc = err_desc.tags @@ -165,6 +171,7 @@ let error_desc_extract_tag_value err_desc tag_to_extract = let find_value tag v = match v with t, _ when String.equal t tag -> true | _ -> false in match List.find ~f:(find_value tag_to_extract) err_desc.tags with Some (_, s) -> s | None -> "" + let error_desc_to_tag_value_pairs err_desc = err_desc.tags (** returns the content of the value tag of the error_desc *) @@ -174,6 +181,7 @@ let error_desc_get_tag_value error_desc = error_desc_extract_tag_value error_des let error_desc_get_tag_call_procedure error_desc = error_desc_extract_tag_value error_desc Tags.call_procedure + (** get the bucket value of an error_desc, if any *) let error_desc_get_bucket err_desc = Tags.get err_desc.tags Tags.bucket @@ -186,6 +194,7 @@ let error_desc_set_bucket err_desc bucket = in {err_desc with descriptions; tags} + (** get the value tag, if any *) let get_value_line_tag tags = try @@ -194,10 +203,12 @@ let get_value_line_tag tags = Some [value; line] with Not_found -> None + (** extract from desc a value on which to apply polymorphic hash and equality *) let desc_get_comparable err_desc = match get_value_line_tag err_desc.tags with Some sl' -> sl' | None -> err_desc.descriptions + (** hash function for error_desc *) let error_desc_hash desc = Hashtbl.hash (desc_get_comparable desc) @@ -205,6 +216,7 @@ let error_desc_hash desc = Hashtbl.hash (desc_get_comparable desc) let error_desc_equal desc1 desc2 = [%compare.equal : string list] (desc_get_comparable desc1) (desc_get_comparable desc2) + let _line_tag tags tag loc = let line_str = string_of_int loc.Location.line in Tags.update tags tag line_str ; @@ -214,6 +226,7 @@ let _line_tag tags tag loc = s ^ ", column " ^ col_str else s + let at_line_tag tags tag loc = "at " ^ _line_tag tags tag loc let _line tags loc = _line_tag tags Tags.line loc @@ -225,39 +238,45 @@ let call_to tags proc_name = Tags.update tags Tags.call_procedure proc_name_str ; "call to " ^ MF.monospaced_to_string proc_name_str + let call_to_at_line tags proc_name loc = call_to tags proc_name ^ " " ^ at_line_tag tags Tags.call_line loc + let by_call_to tags proc_name = "by " ^ call_to tags proc_name let by_call_to_ra tags ra = "by " ^ call_to_at_line tags ra.PredSymb.ra_pname ra.PredSymb.ra_loc let add_by_call_to_opt problem_str tags proc_name_opt = match proc_name_opt with - | Some proc_name - -> problem_str ^ " " ^ by_call_to tags proc_name - | None - -> problem_str + | Some proc_name -> + problem_str ^ " " ^ by_call_to tags proc_name + | None -> + problem_str + let rec format_typ typ = match typ.Typ.desc with - | Typ.Tptr (t, _) when Config.curr_language_is Config.Java - -> format_typ t - | Typ.Tstruct name - -> Typ.Name.name name - | _ - -> Typ.to_string typ + | Typ.Tptr (t, _) when Config.curr_language_is Config.Java -> + format_typ t + | Typ.Tstruct name -> + Typ.Name.name name + | _ -> + Typ.to_string typ + let format_field f = if Config.curr_language_is Config.Java then Typ.Fieldname.java_get_field f else Typ.Fieldname.to_string f + let format_method pname = match pname with - | Typ.Procname.Java pname_java - -> Typ.Procname.java_get_method pname_java - | _ - -> Typ.Procname.to_string pname + | Typ.Procname.Java pname_java -> + Typ.Procname.java_get_method pname_java + | _ -> + Typ.Procname.to_string pname + let mem_dyn_allocated = "memory dynamically allocated" @@ -280,15 +299,18 @@ let _deref_str_null proc_name_opt _problem_str tags = let problem_str = add_by_call_to_opt _problem_str tags proc_name_opt in {tags; value_pre= Some (pointer_or_object ()); value_post= None; problem_str} + (** dereference strings for null dereference *) let deref_str_null proc_name_opt = let problem_str = "could be null and is dereferenced" in _deref_str_null proc_name_opt problem_str (Tags.create ()) + let access_str_empty proc_name_opt = let problem_str = "could be empty and is accessed" in _deref_str_null proc_name_opt problem_str (Tags.create ()) + (** dereference strings for null dereference due to Nullable annotation *) let deref_str_nullable proc_name_opt nullable_obj_str = let tags = Tags.create () in @@ -297,6 +319,7 @@ let deref_str_nullable proc_name_opt nullable_obj_str = let problem_str = "" in _deref_str_null proc_name_opt problem_str tags + (** dereference strings for null dereference due to weak captured variable in block *) let deref_str_weak_variable_in_block proc_name_opt nullable_obj_str = let tags = Tags.create () in @@ -304,6 +327,7 @@ let deref_str_weak_variable_in_block proc_name_opt nullable_obj_str = let problem_str = "" in _deref_str_null proc_name_opt problem_str tags + (** dereference strings for nonterminal nil arguments in c/objc variadic methods *) let deref_str_nil_argument_in_variadic_method pn total_args arg_number = let tags = Tags.create () in @@ -313,11 +337,13 @@ let deref_str_nil_argument_in_variadic_method pn total_args arg_number = let problem_str = Printf.sprintf "could be %s which results in a call to %s with %d arguments instead of %d (%s indicates that the last argument of this variadic %s has been reached)" - nil_null (Typ.Procname.to_simplified_string pn) arg_number (total_args - 1) nil_null - function_method + nil_null + (Typ.Procname.to_simplified_string pn) + arg_number (total_args - 1) nil_null function_method in _deref_str_null None problem_str tags + (** dereference strings for an undefined value coming from the given procedure *) let deref_str_undef (proc_name, loc) = let tags = Tags.create () in @@ -330,20 +356,21 @@ let deref_str_undef (proc_name, loc) = "could be assigned by a call to skip function " ^ proc_name_str ^ at_line_tag tags Tags.call_line loc ^ " and is dereferenced or freed" } + (** dereference strings for a freed pointer dereference *) let deref_str_freed ra = let tags = Tags.create () in let freed_or_closed_by_call = let freed_or_closed = match ra.PredSymb.ra_res with - | PredSymb.Rmemory _ - -> "freed" - | PredSymb.Rfile - -> "closed" - | PredSymb.Rignore - -> "freed" - | PredSymb.Rlock - -> "locked" + | PredSymb.Rmemory _ -> + "freed" + | PredSymb.Rfile -> + "closed" + | PredSymb.Rignore -> + "freed" + | PredSymb.Rlock -> + "locked" in freed_or_closed ^ " " ^ by_call_to_ra tags ra in @@ -352,24 +379,26 @@ let deref_str_freed ra = ; value_post= None ; problem_str= "was " ^ freed_or_closed_by_call ^ " and is dereferenced or freed" } + (** dereference strings for a dangling pointer dereference *) let deref_str_dangling dangling_kind_opt = let dangling_kind_prefix = match dangling_kind_opt with - | Some PredSymb.DAuninit - -> "uninitialized " - | Some PredSymb.DAaddr_stack_var - -> "deallocated stack " - | Some PredSymb.DAminusone - -> "-1 " - | None - -> "" + | Some PredSymb.DAuninit -> + "uninitialized " + | Some PredSymb.DAaddr_stack_var -> + "deallocated stack " + | Some PredSymb.DAminusone -> + "-1 " + | None -> + "" in { tags= Tags.create () ; value_pre= Some (dangling_kind_prefix ^ pointer_or_object ()) ; value_post= None ; problem_str= "could be dangling and is dereferenced or freed" } + (** dereference strings for a pointer size mismatch *) let deref_str_pointer_size_mismatch typ_from_instr typ_of_object = let str_from_typ typ = @@ -382,52 +411,58 @@ let deref_str_pointer_size_mismatch typ_from_instr typ_of_object = ; problem_str= "could be used to access an object of smaller type " ^ str_from_typ typ_of_object } + (** dereference strings for an array out of bound access *) let deref_str_array_bound size_opt index_opt = let tags = Tags.create () in let size_str_opt = match size_opt with - | Some n - -> let n_str = IntLit.to_string n in - Tags.update tags Tags.array_size n_str ; Some ("of size " ^ n_str) - | None - -> None + | Some n -> + let n_str = IntLit.to_string n in + Tags.update tags Tags.array_size n_str ; + Some ("of size " ^ n_str) + | None -> + None in let index_str = match index_opt with - | Some n - -> let n_str = IntLit.to_string n in - Tags.update tags Tags.array_index n_str ; "index " ^ n_str - | None - -> "an index" + | Some n -> + let n_str = IntLit.to_string n in + Tags.update tags Tags.array_index n_str ; + "index " ^ n_str + | None -> + "an index" in { tags ; value_pre= Some "array" ; value_post= size_str_opt ; problem_str= "could be accessed with " ^ index_str ^ " out of bounds" } + (** dereference strings for an uninitialized access whose lhs has the given attribute *) let deref_str_uninitialized alloc_att_opt = let tags = Tags.create () in let creation_str = match alloc_att_opt with - | Some Sil.Apred (Aresource ({ra_kind= Racquire} as ra), _) - -> "after allocation " ^ by_call_to_ra tags ra - | _ - -> "after declaration" + | Some Sil.Apred (Aresource ({ra_kind= Racquire} as ra), _) -> + "after allocation " ^ by_call_to_ra tags ra + | _ -> + "after declaration" in { tags ; value_pre= Some "value" ; value_post= None ; problem_str= "was not initialized " ^ creation_str ^ " and is used" } + (** Java unchecked exceptions errors *) let java_unchecked_exn_desc proc_name exn_name pre_str : error_desc = { no_desc with descriptions= [ MF.monospaced_to_string (Typ.Procname.to_string proc_name) - ; ("can throw " ^ MF.monospaced_to_string (Typ.Name.name exn_name)) - ; ("whenever " ^ pre_str) ] } + ; "can throw " ^ MF.monospaced_to_string (Typ.Name.name exn_name) + ; "whenever " ^ pre_str ] } + let desc_context_leak pname context_typ fieldname leak_path : error_desc = let fld_str = Typ.Fieldname.to_string fieldname in @@ -435,10 +470,10 @@ let desc_context_leak pname context_typ fieldname leak_path : error_desc = let leak_path_entry_to_str acc entry = let entry_str = match entry with - | Some fld, _ - -> Typ.Fieldname.to_string fld - | None, typ - -> Typ.to_string typ + | Some fld, _ -> + Typ.Fieldname.to_string fld + | None, typ -> + Typ.to_string typ in (* intentionally omit space; [typ_to_string] adds an extra space *) acc ^ entry_str ^ " |->\n" @@ -454,16 +489,18 @@ let desc_context_leak pname context_typ fieldname leak_path : error_desc = let preamble = let pname_str = match pname with - | Typ.Procname.Java pname_java - -> MF.monospaced_to_string - (Printf.sprintf "%s.%s" (Typ.Procname.java_get_class_name pname_java) + | Typ.Procname.Java pname_java -> + MF.monospaced_to_string + (Printf.sprintf "%s.%s" + (Typ.Procname.java_get_class_name pname_java) (Typ.Procname.java_get_method pname_java)) - | _ - -> "" + | _ -> + "" in "Context " ^ context_str ^ " may leak during method " ^ pname_str ^ ":\n" in - {no_desc with descriptions= [(preamble ^ MF.code_to_string (leak_root ^ path_str))]} + {no_desc with descriptions= [preamble ^ MF.code_to_string (leak_root ^ path_str)]} + let desc_double_lock pname_opt object_str loc = let mutex_str = Format.sprintf "Mutex %s" object_str in @@ -474,6 +511,7 @@ let desc_double_lock pname_opt object_str loc = let descriptions = [mutex_str; msg; at_line tags loc] in {no_desc with descriptions; tags= !tags} + let desc_unsafe_guarded_by_access accessed_fld guarded_by_str loc = let line_info = at_line (Tags.create ()) loc in let accessed_fld_str = Typ.Fieldname.to_string accessed_fld in @@ -489,6 +527,7 @@ let desc_unsafe_guarded_by_access accessed_fld guarded_by_str loc = in {no_desc with descriptions= [msg]} + let desc_fragment_retains_view fragment_typ fieldname fld_typ pname : error_desc = (* TODO: try advice *) let problem = @@ -503,9 +542,11 @@ let desc_fragment_retains_view fragment_typ fieldname fld_typ pname : error_desc in {no_desc with descriptions= [problem; consequences; advice]} + let desc_custom_error loc : error_desc = {no_desc with descriptions= ["detected"; at_line (Tags.create ()) loc]} + (** type of access *) type access = | Last_assigned of int * bool @@ -517,12 +558,13 @@ type access = let nullable_annotation_name proc_name = match Config.nullable_annotation with - | Some name - -> name - | None when Typ.Procname.is_java proc_name - -> "@Nullable" - | None (* default Clang annotation name *) - -> "_Nullable" + | Some name -> + name + | None when Typ.Procname.is_java proc_name -> + "@Nullable" + | None (* default Clang annotation name *) -> + "_Nullable" + let dereference_string proc_name deref_str value_str access_opt loc = let tags = deref_str.tags in @@ -537,40 +579,43 @@ let dereference_string proc_name deref_str value_str access_opt loc = in let access_desc = match access_opt with - | None - -> [] - | Some Last_accessed (n, _) - -> let line_str = string_of_int n in - Tags.update tags Tags.accessed_line line_str ; [("last accessed on line " ^ line_str)] - | Some Last_assigned (n, _) - -> let line_str = string_of_int n in - Tags.update tags Tags.assigned_line line_str ; [("last assigned on line " ^ line_str)] - | Some Returned_from_call _ - -> [] - | Some Initialized_automatically - -> ["initialized automatically"] + | None -> + [] + | Some Last_accessed (n, _) -> + let line_str = string_of_int n in + Tags.update tags Tags.accessed_line line_str ; + ["last accessed on line " ^ line_str] + | Some Last_assigned (n, _) -> + let line_str = string_of_int n in + Tags.update tags Tags.assigned_line line_str ; + ["last assigned on line " ^ line_str] + | Some Returned_from_call _ -> + [] + | Some Initialized_automatically -> + ["initialized automatically"] in let problem_desc = let problem_str = let annotation_name = nullable_annotation_name proc_name in match (Tags.get !tags Tags.nullable_src, Tags.get !tags Tags.weak_captured_var_src) with - | Some nullable_src, _ - -> if String.equal nullable_src value_str then "is annotated with " ^ annotation_name + | Some nullable_src, _ -> + if String.equal nullable_src value_str then "is annotated with " ^ annotation_name ^ " and is dereferenced without a null check" else "is indirectly marked " ^ annotation_name ^ " (source: " ^ MF.monospaced_to_string nullable_src ^ ") and is dereferenced without a null check" - | None, Some weak_var_str - -> if String.equal weak_var_str value_str then + | None, Some weak_var_str -> + if String.equal weak_var_str value_str then "is a weak pointer captured in the block and is dereferenced without a null check" else "is equal to the variable " ^ MF.monospaced_to_string weak_var_str ^ ", a weak pointer captured in the block, and is dereferenced without a null check" - | None, None - -> deref_str.problem_str + | None, None -> + deref_str.problem_str in - [(problem_str ^ " " ^ at_line tags loc)] + [problem_str ^ " " ^ at_line tags loc] in {no_desc with descriptions= value_desc :: access_desc @ problem_desc; tags= !tags} + let parameter_field_not_null_checked_desc (desc: error_desc) exp = let parameter_not_nullable_desc var = let var_s = Pvar.to_string var in @@ -585,12 +630,12 @@ let parameter_field_not_null_checked_desc (desc: error_desc) exp = let field_not_nullable_desc exp = let rec exp_to_string exp = match exp with - | Exp.Lfield (exp', field, _) - -> exp_to_string exp' ^ " -> " ^ Typ.Fieldname.to_string field - | Exp.Lvar pvar - -> Mangled.to_string (Pvar.get_name pvar) - | _ - -> "" + | Exp.Lfield (exp', field, _) -> + exp_to_string exp' ^ " -> " ^ Typ.Fieldname.to_string field + | Exp.Lvar pvar -> + Mangled.to_string (Pvar.get_name pvar) + | _ -> + "" in let var_s = exp_to_string exp in let field_not_null_desc = @@ -602,16 +647,18 @@ let parameter_field_not_null_checked_desc (desc: error_desc) exp = ; tags= (Tags.field_not_null_checked, var_s) :: desc.tags } in match exp with - | Exp.Lvar var - -> parameter_not_nullable_desc var - | Exp.Lfield _ - -> field_not_nullable_desc exp - | _ - -> desc + | Exp.Lvar var -> + parameter_not_nullable_desc var + | Exp.Lfield _ -> + field_not_nullable_desc exp + | _ -> + desc + let has_tag (desc: error_desc) tag = List.exists ~f:(fun (tag', _) -> String.equal tag tag') desc.tags + let is_parameter_not_null_checked_desc desc = has_tag desc Tags.parameter_not_null_checked let is_field_not_null_checked_desc desc = has_tag desc Tags.field_not_null_checked @@ -619,6 +666,7 @@ let is_field_not_null_checked_desc desc = has_tag desc Tags.field_not_null_check let is_parameter_field_not_null_checked_desc desc = is_parameter_not_null_checked_desc desc || is_field_not_null_checked_desc desc + let is_double_lock_desc desc = has_tag desc Tags.double_lock let desc_allocation_mismatch alloc dealloc = @@ -645,9 +693,11 @@ let desc_allocation_mismatch alloc dealloc = in {no_desc with descriptions= [description]; tags= !tags} + let desc_comparing_floats_for_equality loc = let tags = Tags.create () in - {no_desc with descriptions= [("Comparing floats for equality " ^ at_line tags loc)]; tags= !tags} + {no_desc with descriptions= ["Comparing floats for equality " ^ at_line tags loc]; tags= !tags} + let desc_condition_always_true_false i cond_str_opt loc = let tags = Tags.create () in @@ -661,11 +711,13 @@ let desc_condition_always_true_false i cond_str_opt loc = in {no_desc with descriptions= [description]; tags= !tags} + let desc_unreachable_code_after loc = let tags = Tags.create () in let description = "Unreachable code after statement " ^ at_line tags loc in {no_desc with descriptions= [description]} + let desc_deallocate_stack_variable var_str proc_name loc = let tags = Tags.create () in Tags.update tags Tags.value var_str ; @@ -675,6 +727,7 @@ let desc_deallocate_stack_variable var_str proc_name loc = in {no_desc with descriptions= [description]; tags= !tags} + let desc_deallocate_static_memory const_str proc_name loc = let tags = Tags.create () in Tags.update tags Tags.value const_str ; @@ -684,24 +737,25 @@ let desc_deallocate_static_memory const_str proc_name loc = in {no_desc with descriptions= [description]; tags= !tags} + let desc_class_cast_exception pname_opt typ_str1 typ_str2 exp_str_opt loc = let tags = Tags.create () in Tags.update tags Tags.type1 typ_str1 ; Tags.update tags Tags.type2 typ_str2 ; let in_expression = match exp_str_opt with - | Some exp_str - -> Tags.update tags Tags.value exp_str ; + | Some exp_str -> + Tags.update tags Tags.value exp_str ; " in expression " ^ MF.monospaced_to_string exp_str ^ " " - | None - -> " " + | None -> + " " in let at_line' () = match pname_opt with - | Some proc_name - -> "in " ^ call_to_at_line tags proc_name loc - | None - -> at_line tags loc + | Some proc_name -> + "in " ^ call_to_at_line tags proc_name loc + | None -> + at_line tags loc in let description = Format.asprintf "%a cannot be cast to %a %s %s" MF.pp_monospaced typ_str1 MF.pp_monospaced @@ -709,6 +763,7 @@ let desc_class_cast_exception pname_opt typ_str1 typ_str2 exp_str_opt loc = in {no_desc with descriptions= [description]; tags= !tags} + let desc_divide_by_zero expr_str loc = let tags = Tags.create () in Tags.update tags Tags.value expr_str ; @@ -717,6 +772,7 @@ let desc_divide_by_zero expr_str loc = in {no_desc with descriptions= [description]; tags= !tags} + let desc_empty_vector_access pname_opt object_str loc = let vector_str = Format.asprintf "Vector %a" MF.pp_monospaced object_str in let desc = access_str_empty pname_opt in @@ -725,6 +781,7 @@ let desc_empty_vector_access pname_opt object_str loc = let descriptions = [vector_str; desc.problem_str; at_line tags loc] in {no_desc with descriptions; tags= !tags} + let is_empty_vector_access_desc desc = has_tag desc Tags.empty_vector_access let desc_frontend_warning desc sugg_opt loc = @@ -736,6 +793,7 @@ let desc_frontend_warning desc sugg_opt loc = let description = Format.sprintf "%s %s. %s" desc (at_line tags loc) sugg in {no_desc with descriptions= [description]; tags= !tags} + let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc bucket_opt = let tags = Tags.create () in let () = @@ -744,28 +802,28 @@ let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc let xxx_allocated_to = let value_str, _to, _on = match value_str_opt with - | None - -> ("", "", "") - | Some s - -> Tags.update tags Tags.value s ; (MF.monospaced_to_string s, " to ", " on ") + | None -> + ("", "", "") + | Some s -> + Tags.update tags Tags.value s ; (MF.monospaced_to_string s, " to ", " on ") in let typ_str = match hpred_type_opt with - | Some Exp.Sizeof {typ= {desc= Tstruct name}} when Typ.Name.is_class name - -> " of type " ^ MF.monospaced_to_string (Typ.Name.name name) ^ " " - | _ - -> " " + | Some Exp.Sizeof {typ= {desc= Tstruct name}} when Typ.Name.is_class name -> + " of type " ^ MF.monospaced_to_string (Typ.Name.name name) ^ " " + | _ -> + " " in let desc_str = match resource_opt with - | Some PredSymb.Rmemory _ - -> mem_dyn_allocated ^ _to ^ value_str - | Some PredSymb.Rfile - -> "resource" ^ typ_str ^ "acquired" ^ _to ^ value_str - | Some PredSymb.Rlock - -> lock_acquired ^ _on ^ value_str - | Some PredSymb.Rignore | None - -> if is_none value_str_opt then "memory" else value_str + | Some PredSymb.Rmemory _ -> + mem_dyn_allocated ^ _to ^ value_str + | Some PredSymb.Rfile -> + "resource" ^ typ_str ^ "acquired" ^ _to ^ value_str + | Some PredSymb.Rlock -> + lock_acquired ^ _on ^ value_str + | Some PredSymb.Rignore | None -> + if is_none value_str_opt then "memory" else value_str in if String.equal desc_str "" then [] else [desc_str] in @@ -775,14 +833,14 @@ let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc let is_not_rxxx_after = let rxxx = match resource_opt with - | Some PredSymb.Rmemory _ - -> reachable - | Some PredSymb.Rfile | Some PredSymb.Rlock - -> released - | Some PredSymb.Rignore | None - -> reachable + | Some PredSymb.Rmemory _ -> + reachable + | Some PredSymb.Rfile | Some PredSymb.Rlock -> + released + | Some PredSymb.Rignore | None -> + reachable in - [("is not " ^ rxxx ^ " after " ^ _line tags loc)] + ["is not " ^ rxxx ^ " after " ^ _line tags loc] in let bucket_str = match bucket_opt with Some bucket when Config.show_buckets -> bucket | _ -> "" @@ -790,6 +848,7 @@ let desc_leak hpred_type_opt value_str_opt resource_opt resource_action_opt loc { no_desc with descriptions= bucket_str :: xxx_allocated_to @ by_call_to @ is_not_rxxx_after; tags= !tags } + let desc_buffer_overrun desc = verbatim_desc desc (** kind of precondition not met *) @@ -799,15 +858,15 @@ let desc_precondition_not_met kind proc_name loc = let tags = Tags.create () in let kind_str = match kind with - | None - -> [] - | Some Pnm_bounds - -> ["possible array out of bounds"] - | Some Pnm_dangling - -> ["possible dangling pointer dereference"] + | None -> + [] + | Some Pnm_bounds -> + ["possible array out of bounds"] + | Some Pnm_dangling -> + ["possible dangling pointer dereference"] in - { no_desc with - descriptions= kind_str @ [("in " ^ call_to_at_line tags proc_name loc)]; tags= !tags } + {no_desc with descriptions= kind_str @ ["in " ^ call_to_at_line tags proc_name loc]; tags= !tags} + let desc_null_test_after_dereference expr_str line loc = let tags = Tags.create () in @@ -819,6 +878,7 @@ let desc_null_test_after_dereference expr_str line loc = in {no_desc with descriptions= [description]; tags= !tags} + let desc_return_expression_required typ_str loc = let tags = Tags.create () in Tags.update tags Tags.value typ_str ; @@ -828,6 +888,7 @@ let desc_return_expression_required typ_str loc = in {no_desc with descriptions= [description]; tags= !tags} + let desc_retain_cycle cycle loc cycle_dotty = Logging.d_strln "Proposition with retain cycle:" ; let ct = ref 1 in @@ -838,20 +899,20 @@ let desc_retain_cycle cycle loc cycle_dotty = in let do_edge ((se, _), f, _) = match se with - | Sil.Eexp (Exp.Lvar pvar, _) when Pvar.equal pvar Sil.block_pvar - -> str_cycle + | Sil.Eexp (Exp.Lvar pvar, _) when Pvar.equal pvar Sil.block_pvar -> + str_cycle := !str_cycle ^ " (" ^ string_of_int !ct ^ ") a block capturing " ^ MF.monospaced_to_string (Typ.Fieldname.to_string f) ^ "; " ; ct := !ct + 1 - | Sil.Eexp ((Exp.Lvar pvar as e), _) - -> let e_str = Exp.to_string e in + | Sil.Eexp ((Exp.Lvar pvar as e), _) -> + let e_str = Exp.to_string e in let e_str = if Pvar.is_seed pvar then remove_old e_str else e_str in str_cycle := !str_cycle ^ " (" ^ string_of_int !ct ^ ") object " ^ e_str ^ " retaining " ^ MF.monospaced_to_string (e_str ^ "." ^ Typ.Fieldname.to_string f) ^ ", " ; ct := !ct + 1 - | Sil.Eexp (Exp.Sizeof {typ}, _) - -> let step = + | Sil.Eexp (Exp.Sizeof {typ}, _) -> + let step = " (" ^ string_of_int !ct ^ ") an object of " ^ MF.monospaced_to_string (Typ.to_string typ) ^ " retaining another object via instance variable " @@ -859,8 +920,8 @@ let desc_retain_cycle cycle loc cycle_dotty = in str_cycle := !str_cycle ^ step ; ct := !ct + 1 - | _ - -> () + | _ -> + () in List.iter ~f:do_edge cycle ; let desc = @@ -869,36 +930,41 @@ let desc_retain_cycle cycle loc cycle_dotty = in {no_desc with descriptions= [desc]; tags= !tags; dotty= cycle_dotty} + let registered_observer_being_deallocated_str obj_str = "Object " ^ obj_str ^ " is registered in a notification center but not being removed before deallocation" + let desc_registered_observer_being_deallocated pvar loc = let tags = Tags.create () in let obj_str = MF.monospaced_to_string (Pvar.to_string pvar) in { no_desc with descriptions= - [ ( registered_observer_being_deallocated_str obj_str ^ at_line tags loc + [ registered_observer_being_deallocated_str obj_str ^ at_line tags loc ^ ". Being still registered as observer of the notification " - ^ "center, the deallocated object " ^ obj_str ^ " may be notified in the future." ) ] + ^ "center, the deallocated object " ^ obj_str ^ " may be notified in the future." ] ; tags= !tags } + let desc_return_statement_missing loc = let tags = Tags.create () in - {no_desc with descriptions= [("Return statement missing " ^ at_line tags loc)]; tags= !tags} + {no_desc with descriptions= ["Return statement missing " ^ at_line tags loc]; tags= !tags} + let desc_return_value_ignored proc_name loc = let tags = Tags.create () in - {no_desc with descriptions= [("after " ^ call_to_at_line tags proc_name loc)]; tags= !tags} + {no_desc with descriptions= ["after " ^ call_to_at_line tags proc_name loc]; tags= !tags} + let desc_unary_minus_applied_to_unsigned_expression expr_str_opt typ_str loc = let tags = Tags.create () in let expression = match expr_str_opt with - | Some s - -> Tags.update tags Tags.value s ; "expression " ^ s - | None - -> "an expression" + | Some s -> + Tags.update tags Tags.value s ; "expression " ^ s + | None -> + "an expression" in let description = Format.asprintf "A unary minus is applied to %a of type %s %s" MF.pp_monospaced expression @@ -906,29 +972,32 @@ let desc_unary_minus_applied_to_unsigned_expression expr_str_opt typ_str loc = in {no_desc with descriptions= [description]; tags= !tags} + let desc_skip_function proc_name = let tags = Tags.create () in let proc_name_str = Typ.Procname.to_string proc_name in Tags.update tags Tags.value proc_name_str ; {no_desc with descriptions= [proc_name_str]; tags= !tags} + let desc_inherently_dangerous_function proc_name = let proc_name_str = Typ.Procname.to_string proc_name in let tags = Tags.create () in Tags.update tags Tags.value proc_name_str ; {no_desc with descriptions= [MF.monospaced_to_string proc_name_str]; tags= !tags} + let desc_stack_variable_address_escape pvar addr_dexp_str loc = let expr_str = Pvar.to_string pvar in let tags = Tags.create () in Tags.update tags Tags.value expr_str ; let escape_to_str = match addr_dexp_str with - | Some s - -> Tags.update tags Tags.escape_to s ; + | Some s -> + Tags.update tags Tags.escape_to s ; "to " ^ s ^ " " - | None - -> "" + | None -> + "" in let variable_str = if Pvar.is_frontend_tmp pvar then "temporary" @@ -939,6 +1008,7 @@ let desc_stack_variable_address_escape pvar addr_dexp_str loc = in {no_desc with descriptions= [description]; tags= !tags} + let desc_uninitialized_dangling_pointer_deref deref expr_str loc = let tags = Tags.create () in Tags.update tags Tags.value expr_str ; @@ -948,3 +1018,4 @@ let desc_uninitialized_dangling_pointer_deref deref expr_str loc = (at_line tags loc) in {no_desc with descriptions= [description]; tags= !tags} + diff --git a/infer/src/IR/Location.ml b/infer/src/IR/Location.ml index 586373b5c..05d084ede 100644 --- a/infer/src/IR/Location.ml +++ b/infer/src/IR/Location.ml @@ -31,12 +31,15 @@ let pp f (loc: t) = F.fprintf f "line %d" loc.line ; if loc.col <> -1 then F.fprintf f ", column %d" loc.col + let to_string loc = let s = string_of_int loc.line in if loc.col <> -1 then Printf.sprintf "%s:%d" s loc.col else s + (** Pretty print a file-position of a location *) let pp_file_pos f (loc: t) = let fname = SourceFile.to_string loc.file in let pos = to_string loc in F.fprintf f "%s:%s" fname pos + diff --git a/infer/src/IR/Mangled.ml b/infer/src/IR/Mangled.ml index 95a141184..e73972efb 100644 --- a/infer/src/IR/Mangled.ml +++ b/infer/src/IR/Mangled.ml @@ -30,6 +30,7 @@ let to_string (pn: t) = pn.plain let to_string_full (pn: t) = match pn.mangled with Some mangled -> pn.plain ^ "{" ^ mangled ^ "}" | None -> pn.plain + (** Get mangled string if given *) let get_mangled pn = match pn.mangled with Some s -> s | None -> pn.plain diff --git a/infer/src/IR/Mleak_buckets.ml b/infer/src/IR/Mleak_buckets.ml index 8865e89fa..19757f450 100644 --- a/infer/src/IR/Mleak_buckets.ml +++ b/infer/src/IR/Mleak_buckets.ml @@ -17,16 +17,17 @@ let objc_arc_flag = "objc_arc" let bucket_to_message bucket = match bucket with - | `MLeak_cf - -> "[CF]" - | `MLeak_arc - -> "[ARC]" - | `MLeak_no_arc - -> "[NO ARC]" - | `MLeak_cpp - -> "[CPP]" - | `MLeak_unknown - -> "[UNKNOWN ORIGIN]" + | `MLeak_cf -> + "[CF]" + | `MLeak_arc -> + "[ARC]" + | `MLeak_no_arc -> + "[NO ARC]" + | `MLeak_cpp -> + "[CPP]" + | `MLeak_unknown -> + "[UNKNOWN ORIGIN]" + let contains_all = List.mem ~equal:PVariant.( = ) Config.ml_buckets `MLeak_all @@ -65,6 +66,7 @@ let should_raise_objc_leak typ = else if should_raise_leak_no_arc () then Some (bucket_to_message `MLeak_no_arc) else None + (* let bucket_to_string bucket = match bucket with diff --git a/infer/src/IR/Objc_models.ml b/infer/src/IR/Objc_models.ml index 8cf2463c1..2cd0c1886 100644 --- a/infer/src/IR/Objc_models.ml +++ b/infer/src/IR/Objc_models.ml @@ -56,6 +56,7 @@ module Core_foundation_model = struct ; "__CFURLEnumerator" ; "__CFUUID" ] + let cf_network = [ "_CFHTTPAuthentication" ; "__CFHTTPMessage" @@ -65,6 +66,7 @@ module Core_foundation_model = struct ; "__CFNetServiceMonitor" ; "__CFNetServiceBrowser" ] + let core_media = [ "OpaqueCMBlockBuffer" ; "opaqueCMBufferQueue" @@ -76,6 +78,7 @@ module Core_foundation_model = struct ; "OpaqueCMClock" ; "OpaqueCMTimebase" ] + let core_text = [ "__CTFont" ; "__CTFontCollection" @@ -91,9 +94,11 @@ module Core_foundation_model = struct ; "__CTTextTab" ; "__CTTypesetter" ] + let core_video = ["__CVBuffer"; "__CVMetalTextureCache"; "__CVOpenGLESTextureCache"; "__CVPixelBufferPool"] + let image_io = ["CGImageDestination"; "CGImageMetadata"; "CGImageMetadataTag"; "CGImageSource"] let security = @@ -107,6 +112,7 @@ module Core_foundation_model = struct ; "__SecTrust" ; "__SecRequirement" ] + let system_configuration = [ "__SCDynamicStore" ; "__SCNetworkInterface" @@ -118,6 +124,7 @@ module Core_foundation_model = struct ; "__SCNetworkReachability" ; "__SCPreferences" ] + let core_graphics_types = [ "CGAffineTransform" ; "CGBase" @@ -149,10 +156,12 @@ module Core_foundation_model = struct ; "CGPDFString" ; "CGShading" ] + let core_foundation_types = core_foundation @ cf_network @ core_media @ core_text @ core_video @ image_io @ security @ system_configuration + let copy = "Copy" let create = "Create" @@ -171,24 +180,27 @@ module Core_foundation_model = struct let core_lib_to_type_list lib = match lib with - | Core_foundation - -> core_foundation_types - | Core_graphics - -> core_graphics_types + | Core_foundation -> + core_foundation_types + | Core_graphics -> + core_graphics_types + let is_objc_memory_model_controlled o = List.mem ~equal:String.equal core_foundation_types o || List.mem ~equal:String.equal core_graphics_types o + let rec is_core_lib lib typ = match typ.Typ.desc with - | Typ.Tptr (styp, _) - -> is_core_lib lib styp - | Typ.Tstruct name - -> let core_lib_types = core_lib_to_type_list lib in + | Typ.Tptr (styp, _) -> + is_core_lib lib styp + | Typ.Tstruct name -> + let core_lib_types = core_lib_to_type_list lib in List.mem ~equal:String.equal core_lib_types (Typ.Name.name name) - | _ - -> false + | _ -> + false + let is_core_foundation_type typ = is_core_lib Core_foundation typ @@ -200,6 +212,7 @@ module Core_foundation_model = struct is_core_lib_type typ && (String.is_substring ~substring:create funct || String.is_substring ~substring:copy funct) + let function_arg_is_cftype typ = String.is_substring ~substring:cf_type typ let is_core_lib_retain typ funct = function_arg_is_cftype typ && String.equal funct cf_retain @@ -212,6 +225,7 @@ module Core_foundation_model = struct in List.exists ~f core_graphics_types + (* let function_arg_is_core_pgraphics typ = let res = (String.is_substring ~substring:cf_type typ) in diff --git a/infer/src/IR/PredSymb.ml b/infer/src/IR/PredSymb.ml index ee43a53fe..5056e0f64 100644 --- a/infer/src/IR/PredSymb.ml +++ b/infer/src/IR/PredSymb.ml @@ -26,10 +26,11 @@ let equal_access = [%compare.equal : access] (** Return the value of the FA_sentinel attribute in [attr_list] if it is found *) let get_sentinel_func_attribute_value attr_list = match attr_list with - | (FA_sentinel (sentinel, null_pos)) :: _ - -> Some (sentinel, null_pos) - | [] - -> None + | (FA_sentinel (sentinel, null_pos)) :: _ -> + Some (sentinel, null_pos) + | [] -> + None + type mem_kind = | Mmalloc (** memory allocated with malloc *) @@ -72,6 +73,7 @@ type res_action = let compare_res_action {ra_kind= k1; ra_res= r1} {ra_kind= k2; ra_res= r2} = [%compare : res_act_kind * resource] (k1, r1) (k2, r2) + (* type aliases for components of t values that compare should ignore *) type _annot_item = Annot.Item.t @@ -115,25 +117,27 @@ let equal = [%compare.equal : t] (** name of the allocation function for the given memory kind *) let mem_alloc_pname = function - | Mmalloc - -> Typ.Procname.from_string_c_fun "malloc" - | Mnew - -> Typ.Procname.from_string_c_fun "new" - | Mnew_array - -> Typ.Procname.from_string_c_fun "new[]" - | Mobjc - -> Typ.Procname.from_string_c_fun "alloc" + | Mmalloc -> + Typ.Procname.from_string_c_fun "malloc" + | Mnew -> + Typ.Procname.from_string_c_fun "new" + | Mnew_array -> + Typ.Procname.from_string_c_fun "new[]" + | Mobjc -> + Typ.Procname.from_string_c_fun "alloc" + (** name of the deallocation function for the given memory kind *) let mem_dealloc_pname = function - | Mmalloc - -> Typ.Procname.from_string_c_fun "free" - | Mnew - -> Typ.Procname.from_string_c_fun "delete" - | Mnew_array - -> Typ.Procname.from_string_c_fun "delete[]" - | Mobjc - -> Typ.Procname.from_string_c_fun "dealloc" + | Mmalloc -> + Typ.Procname.from_string_c_fun "free" + | Mnew -> + Typ.Procname.from_string_c_fun "delete" + | Mnew_array -> + Typ.Procname.from_string_c_fun "delete[]" + | Mobjc -> + Typ.Procname.from_string_c_fun "dealloc" + (** Categories of attributes *) type category = @@ -152,24 +156,25 @@ let equal_category = [%compare.equal : category] let to_category att = match att with - | Aresource _ | Adangling _ - -> ACresource - | Alocked | Aunlocked - -> AClock - | Aautorelease - -> ACautorelease - | Adiv0 _ - -> ACdiv0 - | Aobjc_null - -> ACobjc_null - | Aretval _ - -> ACretval - | Aundef _ - -> ACundef - | Aobserver | Aunsubscribed_observer - -> ACobserver - | Awont_leak - -> ACwontleak + | Aresource _ | Adangling _ -> + ACresource + | Alocked | Aunlocked -> + AClock + | Aautorelease -> + ACautorelease + | Adiv0 _ -> + ACdiv0 + | Aobjc_null -> + ACobjc_null + | Aretval _ -> + ACretval + | Aundef _ -> + ACundef + | Aobserver | Aunsubscribed_observer -> + ACobserver + | Awont_leak -> + ACwontleak + let is_undef = function Aundef _ -> true | _ -> false @@ -177,71 +182,72 @@ let is_wont_leak = function Awont_leak -> true | _ -> false (** convert the attribute to a string *) let to_string pe = function - | Aresource ra - -> let mk_name = function - | Mmalloc - -> "ma" - | Mnew - -> "ne" - | Mnew_array - -> "na" - | Mobjc - -> "oc" + | Aresource ra -> + let mk_name = function + | Mmalloc -> + "ma" + | Mnew -> + "ne" + | Mnew_array -> + "na" + | Mobjc -> + "oc" in let name = match (ra.ra_kind, ra.ra_res) with - | Racquire, Rmemory mk - -> "MEM" ^ mk_name mk - | Racquire, Rfile - -> "FILE" - | Rrelease, Rmemory mk - -> "FREED" ^ mk_name mk - | Rrelease, Rfile - -> "CLOSED" - | _, Rignore - -> "IGNORE" - | Racquire, Rlock - -> "LOCKED" - | Rrelease, Rlock - -> "UNLOCKED" + | Racquire, Rmemory mk -> + "MEM" ^ mk_name mk + | Racquire, Rfile -> + "FILE" + | Rrelease, Rmemory mk -> + "FREED" ^ mk_name mk + | Rrelease, Rfile -> + "CLOSED" + | _, Rignore -> + "IGNORE" + | Racquire, Rlock -> + "LOCKED" + | Rrelease, Rlock -> + "UNLOCKED" in let str_vpath = if Config.trace_error then F.asprintf "%a" (DecompiledExp.pp_vpath pe) ra.ra_vpath else "" in name ^ Binop.str pe Lt ^ Typ.Procname.to_string ra.ra_pname ^ ":" ^ string_of_int ra.ra_loc.Location.line ^ Binop.str pe Gt ^ str_vpath - | Aautorelease - -> "AUTORELEASE" - | Adangling dk - -> let dks = + | Aautorelease -> + "AUTORELEASE" + | Adangling dk -> + let dks = match dk with - | DAuninit - -> "UNINIT" - | DAaddr_stack_var - -> "ADDR_STACK" - | DAminusone - -> "MINUS1" + | DAuninit -> + "UNINIT" + | DAaddr_stack_var -> + "ADDR_STACK" + | DAminusone -> + "MINUS1" in "DANGL" ^ Binop.str pe Lt ^ dks ^ Binop.str pe Gt - | Aundef (pn, _, loc, _) - -> "UND" ^ Binop.str pe Lt ^ Typ.Procname.to_string pn ^ Binop.str pe Gt ^ ":" + | Aundef (pn, _, loc, _) -> + "UND" ^ Binop.str pe Lt ^ Typ.Procname.to_string pn ^ Binop.str pe Gt ^ ":" ^ string_of_int loc.Location.line - | Alocked - -> "LOCKED" - | Aunlocked - -> "UNLOCKED" - | Adiv0 (_, _) - -> "DIV0" - | Aobjc_null - -> "OBJC_NULL" - | Aretval (pn, _) - -> "RET" ^ Binop.str pe Lt ^ Typ.Procname.to_string pn ^ Binop.str pe Gt - | Aobserver - -> "OBSERVER" - | Aunsubscribed_observer - -> "UNSUBSCRIBED_OBSERVER" - | Awont_leak - -> "WONT_LEAK" + | Alocked -> + "LOCKED" + | Aunlocked -> + "UNLOCKED" + | Adiv0 (_, _) -> + "DIV0" + | Aobjc_null -> + "OBJC_NULL" + | Aretval (pn, _) -> + "RET" ^ Binop.str pe Lt ^ Typ.Procname.to_string pn ^ Binop.str pe Gt + | Aobserver -> + "OBSERVER" + | Aunsubscribed_observer -> + "UNSUBSCRIBED_OBSERVER" + | Awont_leak -> + "WONT_LEAK" + (** dump an attribute *) let d_attribute (a: t) = L.add_print_action (L.PTattribute, Obj.repr a) diff --git a/infer/src/IR/ProcAttributes.ml b/infer/src/IR/ProcAttributes.ml index 9dfa5da4d..cb20ce092 100644 --- a/infer/src/IR/ProcAttributes.ml +++ b/infer/src/IR/ProcAttributes.ml @@ -21,6 +21,7 @@ let compare_proc_flags x y = let bindings x = Hashtbl.fold (fun k d l -> (k, d) :: l) x [] in [%compare : (string * string) list] (bindings x) (bindings y) + let proc_flags_empty () : proc_flags = Hashtbl.create 1 let proc_flag_ignore_return = "ignore_return" @@ -99,3 +100,4 @@ let default proc_name language = ; proc_name ; ret_type= Typ.mk Typ.Tvoid ; source_file_captured= SourceFile.invalid __FILE__ } + diff --git a/infer/src/IR/Procdesc.ml b/infer/src/IR/Procdesc.ml index 783e02e91..9b3acd846 100644 --- a/infer/src/IR/Procdesc.ml +++ b/infer/src/IR/Procdesc.ml @@ -59,6 +59,7 @@ module Node = struct ; preds= [] ; exn= [] } + let compare node1 node2 = Int.compare node1.id node2.id let hash node = Hashtbl.hash node.id @@ -98,6 +99,7 @@ module Node = struct in NodeSet.elements (slice_nodes node.succs) + let get_sliced_preds node f = let visited = ref NodeSet.empty in let rec slice_nodes nodes : NodeSet.t = @@ -112,16 +114,18 @@ module Node = struct in NodeSet.elements (slice_nodes node.preds) + let get_exn node = node.exn (** Get the name of the procedure the node belongs to *) let get_proc_name node = match node.pname_opt with - | None - -> L.internal_error "get_proc_name: at node %d@\n" node.id ; + | None -> + L.internal_error "get_proc_name: at node %d@\n" node.id ; assert false - | Some pname - -> pname + | Some pname -> + pname + (** Get the predecessors of the node *) let get_preds node = node.preds @@ -137,6 +141,7 @@ module Node = struct in nodes start_node + (** Get the node kind *) let get_kind node = node.kind @@ -149,11 +154,12 @@ module Node = struct match instr with | Sil.Call (_, exp, _, _, _) -> ( match exp with Exp.Const Const.Cfun procname -> procname :: callees | _ -> callees ) - | _ - -> callees + | _ -> + callees in List.fold ~f:collect ~init:[] (get_instrs node) + (** Get the location of the node *) let get_loc n = n.loc @@ -161,6 +167,7 @@ module Node = struct let get_last_loc n = match List.rev (get_instrs n) with instr :: _ -> Sil.instr_get_loc instr | [] -> n.loc + let pp_id f id = F.fprintf f "%d" id let pp f node = pp_id f (get_id node) @@ -189,6 +196,7 @@ module Node = struct let instr = Sil.Declare_locals (ptl, loc) in prepend_instrs node [instr] + (** Print extended instructions for the node, highlighting the given subinstruction if present *) let pp_instrs pe0 ~sub_instrs instro fmt node = @@ -201,44 +209,47 @@ module Node = struct else let () = match get_kind node with - | Stmt_node s - -> F.fprintf fmt "statements (%s)" s - | Prune_node (_, _, descr) - -> F.fprintf fmt "assume %s" descr - | Exit_node _ - -> F.fprintf fmt "exit" - | Skip_node s - -> F.fprintf fmt "skip (%s)" s - | Start_node _ - -> F.fprintf fmt "start" - | Join_node - -> F.fprintf fmt "join" + | Stmt_node s -> + F.fprintf fmt "statements (%s)" s + | Prune_node (_, _, descr) -> + F.fprintf fmt "assume %s" descr + | Exit_node _ -> + F.fprintf fmt "exit" + | Skip_node s -> + F.fprintf fmt "skip (%s)" s + | Start_node _ -> + F.fprintf fmt "start" + | Join_node -> + F.fprintf fmt "join" in F.fprintf fmt " %a " Location.pp (get_loc node) + (** Dump extended instructions for the node *) let d_instrs ~(sub_instrs: bool) (curr_instr: Sil.instr option) (node: t) = L.add_print_action (L.PTnode_instrs, Obj.repr (sub_instrs, curr_instr, node)) + (** Return a description of the cfg node *) let get_description pe node = let str = match get_kind node with - | Stmt_node _ - -> "Instructions" - | Prune_node (_, _, descr) - -> "Conditional" ^ " " ^ descr - | Exit_node _ - -> "Exit" - | Skip_node _ - -> "Skip" - | Start_node _ - -> "Start" - | Join_node - -> "Join" + | Stmt_node _ -> + "Instructions" + | Prune_node (_, _, descr) -> + "Conditional" ^ " " ^ descr + | Exit_node _ -> + "Exit" + | Skip_node _ -> + "Skip" + | Start_node _ -> + "Start" + | Join_node -> + "Join" in let pp fmt = F.fprintf fmt "%s@\n%a@?" str (pp_instrs pe None ~sub_instrs:true) node in F.asprintf "%t" pp + end (* =============== END of module Node =============== *) @@ -273,6 +284,7 @@ let from_proc_attributes ~called_from_cfg attributes = let exit_node = Node.dummy pname_opt in {attributes; nodes= []; nodes_num= 0; start_node; exit_node; loop_heads= None} + (** Compute the distance of each node to the exit node, if not computed already *) let compute_distance_to_exit_node pdesc = let exit_node = pdesc.exit_node in @@ -280,10 +292,10 @@ let compute_distance_to_exit_node pdesc = let next_nodes = ref [] in let do_node (node: Node.t) = match node.dist_exit with - | Some _ - -> () - | None - -> node.dist_exit <- Some dist ; + | Some _ -> + () + | None -> + node.dist_exit <- Some dist ; next_nodes := node.preds @ !next_nodes in List.iter ~f:do_node nodes ; @@ -291,6 +303,7 @@ let compute_distance_to_exit_node pdesc = in mark_distance 0 [exit_node] + (** check or indicate if we have performed preanalysis on the CFG *) let did_preanalysis pdesc = pdesc.attributes.did_preanalysis @@ -334,6 +347,7 @@ let get_start_node pdesc = pdesc.start_node let get_sliced_slope pdesc f = Node.get_generated_slope (get_start_node pdesc) (fun n -> Node.get_sliced_succs n f) + (** List of nodes in the procedure up to the first branching *) let get_slope pdesc = Node.get_generated_slope (get_start_node pdesc) Node.get_succs @@ -354,6 +368,7 @@ let fold_calls f acc pdesc = in List.fold ~f:do_node ~init:acc (get_nodes pdesc) + (** iterate over the calls from the procedure: (callee,location) pairs *) let iter_calls f pdesc = fold_calls (fun _ call -> f call) () pdesc @@ -361,6 +376,7 @@ let iter_instrs f pdesc = let do_node node = List.iter ~f:(fun i -> f node i) (Node.get_instrs node) in iter_nodes do_node pdesc + let fold_nodes f acc pdesc = List.fold ~f ~init:acc (List.rev (get_nodes pdesc)) let fold_instrs f acc pdesc = @@ -369,23 +385,26 @@ let fold_instrs f acc pdesc = in fold_nodes fold_node acc pdesc + let iter_slope f pdesc = let visited = ref NodeSet.empty in let rec do_node node = visited := NodeSet.add node !visited ; f node ; match Node.get_succs node with - | [n] - -> if not (NodeSet.mem n !visited) then do_node n - | _ - -> () + | [n] -> + if not (NodeSet.mem n !visited) then do_node n + | _ -> + () in do_node (get_start_node pdesc) + let iter_slope_calls f pdesc = let do_node node = List.iter ~f:(fun callee_pname -> f callee_pname) (Node.get_callees node) in iter_slope do_node pdesc + (** iterate between two nodes or until we reach a branching structure *) let iter_slope_range f src_node dst_node = let visited = ref NodeSet.empty in @@ -393,13 +412,14 @@ let iter_slope_range f src_node dst_node = visited := NodeSet.add node !visited ; f node ; match Node.get_succs node with - | [n] - -> if not (NodeSet.mem n !visited) && not (Node.equal node dst_node) then do_node n - | _ - -> () + | [n] -> + if not (NodeSet.mem n !visited) && not (Node.equal node dst_node) then do_node n + | _ -> + () in do_node src_node + (** Set the exit node of the proc desc *) let set_exit_node pdesc node = pdesc.exit_node <- node @@ -413,12 +433,14 @@ let set_start_node pdesc node = pdesc.start_node <- node let append_locals pdesc new_locals = (pdesc.attributes).locals <- pdesc.attributes.locals @ new_locals + (** Set the successor nodes and exception nodes, and build predecessor links *) let set_succs_exn_base (node: Node.t) succs exn = node.succs <- succs ; node.exn <- exn ; List.iter ~f:(fun (n: Node.t) -> n.preds <- node :: n.preds) succs + (** Create a new cfg node *) let create_node pdesc loc kind instrs = pdesc.nodes_num <- pdesc.nodes_num + 1 ; @@ -437,18 +459,20 @@ let create_node pdesc loc kind instrs = pdesc.nodes <- node :: pdesc.nodes ; node + (** Set the successor and exception nodes. If this is a join node right before the exit node, add an extra node in the middle, otherwise nullify and abstract instructions cannot be added after a conditional. *) let node_set_succs_exn pdesc (node: Node.t) succs exn = match (node.kind, succs) with - | Join_node, [({Node.kind= Exit_node _} as exit_node)] - -> let kind = Node.Stmt_node "between_join_and_exit" in + | Join_node, [({Node.kind= Exit_node _} as exit_node)] -> + let kind = Node.Stmt_node "between_join_and_exit" in let node' = create_node pdesc node.loc kind node.instrs in set_succs_exn_base node [node'] exn ; set_succs_exn_base node' [exit_node] exn - | _ - -> set_succs_exn_base node succs exn + | _ -> + set_succs_exn_base node succs exn + (** Get loop heads for widening. It collects all target nodes of back-edges in a depth-first @@ -457,10 +481,10 @@ let node_set_succs_exn pdesc (node: Node.t) succs exn = let get_loop_heads pdesc = let rec set_loop_head_rec visited heads wl = match wl with - | [] - -> heads - | (n, ancester) :: wl' - -> if NodeSet.mem n visited then + | [] -> + heads + | (n, ancester) :: wl' -> + if NodeSet.mem n visited then if NodeSet.mem n ancester then set_loop_head_rec visited (NodeSet.add n heads) wl' else set_loop_head_rec visited heads wl' else @@ -474,10 +498,12 @@ let get_loop_heads pdesc = pdesc.loop_heads <- Some lh ; lh + let is_loop_head pdesc (node: Node.t) = let lh = match pdesc.loop_heads with Some lh -> lh | None -> get_loop_heads pdesc in NodeSet.mem node lh + let pp_variable_list fmt etl = if List.is_empty etl then Format.fprintf fmt "None" else @@ -485,14 +511,16 @@ let pp_variable_list fmt etl = ~f:(fun (id, ty) -> Format.fprintf fmt " %a:%a" Mangled.pp id (Typ.pp_full Pp.text) ty) etl + let pp_objc_accessor fmt accessor = match accessor with - | Some ProcAttributes.Objc_getter field - -> Format.fprintf fmt "Getter of %a, " (Typ.Struct.pp_field Pp.text) field - | Some ProcAttributes.Objc_setter field - -> Format.fprintf fmt "Setter of %a, " (Typ.Struct.pp_field Pp.text) field - | None - -> () + | Some ProcAttributes.Objc_getter field -> + Format.fprintf fmt "Getter of %a, " (Typ.Struct.pp_field Pp.text) field + | Some ProcAttributes.Objc_setter field -> + Format.fprintf fmt "Setter of %a, " (Typ.Struct.pp_field Pp.text) field + | None -> + () + let pp_signature fmt pdesc = let attributes = get_attributes pdesc in @@ -511,6 +539,8 @@ let pp_signature fmt pdesc = Format.fprintf fmt ", Annotation: %a" (Annot.Method.pp pname_string) method_annotation ; Format.fprintf fmt "]@\n" + let is_specialized pdesc = let attributes = get_attributes pdesc in attributes.ProcAttributes.is_specialized + diff --git a/infer/src/IR/Pvar.ml b/infer/src/IR/Pvar.ml index f87d9cd0d..c5c6b6fc1 100644 --- a/infer/src/IR/Pvar.ml +++ b/infer/src/IR/Pvar.ml @@ -44,67 +44,73 @@ let compare_modulo_this x y = else if String.equal "this" (Mangled.to_string x.pv_name) then 0 else compare_pvar_kind x.pv_kind y.pv_kind + let equal = [%compare.equal : t] let pp_translation_unit fmt = function - | TUFile fname - -> SourceFile.pp fmt fname - | TUExtern - -> Format.fprintf fmt "EXTERN" + | TUFile fname -> + SourceFile.pp fmt fname + | TUExtern -> + Format.fprintf fmt "EXTERN" + let _pp f pv = let name = pv.pv_name in match pv.pv_kind with - | Local_var n - -> if !Config.pp_simple then F.fprintf f "%a" Mangled.pp name + | Local_var n -> + if !Config.pp_simple then F.fprintf f "%a" Mangled.pp name else F.fprintf f "%a$%a" Typ.Procname.pp n Mangled.pp name - | Callee_var n - -> if !Config.pp_simple then F.fprintf f "%a|callee" Mangled.pp name + | Callee_var n -> + if !Config.pp_simple then F.fprintf f "%a|callee" Mangled.pp name else F.fprintf f "%a$%a|callee" Typ.Procname.pp n Mangled.pp name - | Abduced_retvar (n, l) - -> if !Config.pp_simple then F.fprintf f "%a|abducedRetvar" Mangled.pp name + | Abduced_retvar (n, l) -> + if !Config.pp_simple then F.fprintf f "%a|abducedRetvar" Mangled.pp name else F.fprintf f "%a$[%a]%a|abducedRetvar" Typ.Procname.pp n Location.pp l Mangled.pp name - | Abduced_ref_param (n, index, l) - -> if !Config.pp_simple then F.fprintf f "%a|abducedRefParam%d" Mangled.pp name index + | Abduced_ref_param (n, index, l) -> + if !Config.pp_simple then F.fprintf f "%a|abducedRefParam%d" Mangled.pp name index else F.fprintf f "%a$[%a]%a|abducedRefParam" Typ.Procname.pp n Location.pp l Mangled.pp name - | Global_var (translation_unit, is_const, is_pod, _) - -> F.fprintf f "#GB<%a%s%s>$%a" pp_translation_unit translation_unit + | Global_var (translation_unit, is_const, is_pod, _) -> + F.fprintf f "#GB<%a%s%s>$%a" pp_translation_unit translation_unit (if is_const then "|const" else "") (if not is_pod then "|!pod" else "") Mangled.pp name - | Seed_var - -> F.fprintf f "old_%a" Mangled.pp name + | Seed_var -> + F.fprintf f "old_%a" Mangled.pp name + (** Pretty print a program variable in latex. *) let pp_latex f pv = let name = pv.pv_name in match pv.pv_kind with - | Local_var _ - -> Latex.pp_string Latex.Roman f (Mangled.to_string name) - | Callee_var _ - -> F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) + | Local_var _ -> + Latex.pp_string Latex.Roman f (Mangled.to_string name) + | Callee_var _ -> + F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) (Latex.pp_string Latex.Roman) "callee" - | Abduced_retvar _ - -> F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) + | Abduced_retvar _ -> + F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) (Latex.pp_string Latex.Roman) "abducedRetvar" - | Abduced_ref_param _ - -> F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) + | Abduced_ref_param _ -> + F.fprintf f "%a_{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) (Latex.pp_string Latex.Roman) "abducedRefParam" - | Global_var _ - -> Latex.pp_string Latex.Boldface f (Mangled.to_string name) - | Seed_var - -> F.fprintf f "%a^{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) + | Global_var _ -> + Latex.pp_string Latex.Boldface f (Mangled.to_string name) + | Seed_var -> + F.fprintf f "%a^{%a}" (Latex.pp_string Latex.Roman) (Mangled.to_string name) (Latex.pp_string Latex.Roman) "old" + (** Pretty print a pvar which denotes a value, not an address *) let pp_value pe f pv = match pe.Pp.kind with TEXT -> _pp f pv | HTML -> _pp f pv | LATEX -> pp_latex f pv + (** Pretty print a program variable. *) let pp pe f pv = let ampersand = match pe.Pp.kind with TEXT -> "&" | HTML -> "&" | LATEX -> "\\&" in F.fprintf f "%s%a" ampersand (pp_value pe) pv + (** Dump a program variable. *) let d (pvar: t) = L.add_print_action (L.PTpvar, Obj.repr pvar) @@ -123,13 +129,15 @@ let get_simplified_name pv = match String.rsplit2 s ~on:'.' with | Some (s1, s2) -> ( match String.rsplit2 s1 ~on:'.' with Some (_, s4) -> s4 ^ "." ^ s2 | _ -> s ) - | _ - -> s + | _ -> + s + (** Check if the pvar is an abucted return var or param passed by ref *) let is_abduced pv = match pv.pv_kind with Abduced_retvar _ | Abduced_ref_param _ -> true | _ -> false + (** Turn a pvar into a seed pvar (which stored the initial value) *) let to_seed pv = {pv with pv_kind= Seed_var} @@ -173,10 +181,11 @@ let is_frontend_tmp pvar = is_sil_tmp name || match pvar.pv_kind with - | Local_var pname - -> Typ.Procname.is_java pname && is_bytecode_tmp name - | _ - -> false + | Local_var pname -> + Typ.Procname.is_java pname && is_bytecode_tmp name + | _ -> + false + (* in Sawja, variables like $T0_18 are temporaries, but not SSA vars. *) let is_ssa_frontend_tmp pvar = @@ -185,25 +194,28 @@ let is_ssa_frontend_tmp pvar = let name = to_string pvar in not (String.contains name '_' && String.contains name '$') + (** Turn an ordinary program variable into a callee program variable *) let to_callee pname pvar = match pvar.pv_kind with - | Local_var _ - -> {pvar with pv_kind= Callee_var pname} - | Global_var _ - -> pvar - | Callee_var _ | Abduced_retvar _ | Abduced_ref_param _ | Seed_var - -> L.d_str "Cannot convert pvar to callee: " ; + | Local_var _ -> + {pvar with pv_kind= Callee_var pname} + | Global_var _ -> + pvar + | Callee_var _ | Abduced_retvar _ | Abduced_ref_param _ | Seed_var -> + L.d_str "Cannot convert pvar to callee: " ; d pvar ; L.d_ln () ; assert false + let name_hash (name: Mangled.t) = Hashtbl.hash name (** [mk name proc_name] creates a program var with the given function name *) let mk (name: Mangled.t) (proc_name: Typ.Procname.t) : t = {pv_hash= name_hash name; pv_name= name; pv_kind= Local_var proc_name} + let get_ret_pvar pname = mk Ident.name_return pname (** [mk_callee name proc_name] creates a program var @@ -211,6 +223,7 @@ let get_ret_pvar pname = mk Ident.name_return pname let mk_callee (name: Mangled.t) (proc_name: Typ.Procname.t) : t = {pv_hash= name_hash name; pv_name= name; pv_kind= Callee_var proc_name} + (** create a global variable with the given name *) let mk_global ?(is_constexpr= false) ?(is_pod= true) ?(is_static_local= false) (name: Mangled.t) translation_unit : t = @@ -218,27 +231,32 @@ let mk_global ?(is_constexpr= false) ?(is_pod= true) ?(is_static_local= false) ( ; pv_name= name ; pv_kind= Global_var (translation_unit, is_constexpr, is_pod, is_static_local) } + (** create a fresh temporary variable local to procedure [pname]. for use in the frontends only! *) let mk_tmp name pname = let id = Ident.create_fresh Ident.knormal in let pvar_mangled = Mangled.from_string (tmp_prefix ^ name ^ Ident.to_string id) in mk pvar_mangled pname + (** create an abduced return variable for a call to [proc_name] at [loc] *) let mk_abduced_ret (proc_name: Typ.Procname.t) (loc: Location.t) : t = let name = Mangled.from_string ("$RET_" ^ Typ.Procname.to_unique_id proc_name) in {pv_hash= name_hash name; pv_name= name; pv_kind= Abduced_retvar (proc_name, loc)} + let mk_abduced_ref_param (proc_name: Typ.Procname.t) (index: int) (loc: Location.t) : t = let name = Mangled.from_string ("$REF_PARAM_VAL_" ^ Typ.Procname.to_unique_id proc_name) in {pv_hash= name_hash name; pv_name= name; pv_kind= Abduced_ref_param (proc_name, index, loc)} + let get_translation_unit pvar = match pvar.pv_kind with - | Global_var (tu, _, _, _) - -> tu - | _ - -> L.(die InternalError) "Expected a global variable" + | Global_var (tu, _, _, _) -> + tu + | _ -> + L.(die InternalError) "Expected a global variable" + let is_compile_constant pvar = match pvar.pv_kind with Global_var (_, b, _, _) -> b | _ -> false @@ -246,9 +264,10 @@ let is_pod pvar = match pvar.pv_kind with Global_var (_, _, b, _) -> b | _ -> tr let get_initializer_pname {pv_name; pv_kind} = match pv_kind with - | Global_var _ - -> Some + | Global_var _ -> + Some (Typ.Procname.from_string_c_fun (Config.clang_initializer_prefix ^ Mangled.to_string_full pv_name)) - | _ - -> None + | _ -> + None + diff --git a/infer/src/IR/QualifiedCppName.ml b/infer/src/IR/QualifiedCppName.ml index 5180dc459..bd91f57ad 100644 --- a/infer/src/IR/QualifiedCppName.ml +++ b/infer/src/IR/QualifiedCppName.ml @@ -25,16 +25,18 @@ let strip_template_args quals = let no_template_name s = List.hd_exn (String.split ~on:'<' s) in List.map ~f:no_template_name quals + let append_template_args_to_last quals ~args = match quals with - | [last; _] when String.contains last '<' - -> L.(die InternalError) + | [last; _] when String.contains last '<' -> + L.(die InternalError) "expected qualified name without template args, but got %s, the last qualifier of %s" last (String.concat ~sep:", " quals) - | last :: rest - -> (last ^ args) :: rest - | [] - -> L.(die InternalError) "expected non-empty qualified name" + | last :: rest -> + (last ^ args) :: rest + | [] -> + L.(die InternalError) "expected non-empty qualified name" + let to_list = List.rev @@ -68,6 +70,7 @@ module Match = struct let regexp_string_of_qualifiers quals = Str.quote (to_separated_string ~sep:matching_separator quals) ^ "$" + let qualifiers_list_matcher quals_list = ( if List.is_empty quals_list then "a^" else @@ -75,6 +78,7 @@ module Match = struct List.map ~f:regexp_string_of_qualifiers quals_list |> String.concat ~sep:"\\|" ) |> Str.regexp + let qualifiers_of_fuzzy_qual_name qual_name = (* Fail if we detect templates in the fuzzy name. Template instantiations are not taken into account when fuzzy matching, and templates may produce wrong results when parsing qualified @@ -86,12 +90,15 @@ module Match = struct L.(die InternalError) "Unexpected template in fuzzy qualified name %s." qual_name ) ; of_qual_string qual_name + let of_fuzzy_qual_names fuzzy_qual_names = List.map fuzzy_qual_names ~f:qualifiers_of_fuzzy_qual_name |> qualifiers_list_matcher + let match_qualifiers matcher quals = (* qual_name may have qualifiers with template parameters - drop them to whitelist all instantiations *) let normalized_qualifiers = strip_template_args quals in Str.string_match matcher (to_separated_string ~sep:matching_separator normalized_qualifiers) 0 + end diff --git a/infer/src/IR/Sil.ml b/infer/src/IR/Sil.ml index 9ebe4e6b0..a075890f4 100644 --- a/infer/src/IR/Sil.ml +++ b/infer/src/IR/Sil.ml @@ -61,10 +61,11 @@ let skip_instr = Remove_temps ([], Location.dummy) (** Check if an instruction is auxiliary, or if it comes from source instructions. *) let instr_is_auxiliary = function - | Load _ | Store _ | Prune _ | Call _ - -> false - | Nullify _ | Abstract _ | Remove_temps _ | Declare_locals _ - -> true + | Load _ | Store _ | Prune _ | Call _ -> + false + | Nullify _ | Abstract _ | Remove_temps _ | Declare_locals _ -> + true + (** offset for an lvalue *) type offset = Off_fld of Typ.Fieldname.t * Typ.t | Off_index of Exp.t @@ -83,10 +84,11 @@ let equal_atom = [%compare.equal : atom] let atom_has_local_addr a = match a with - | Aeq (e0, e1) | Aneq (e0, e1) - -> Exp.has_local_addr e0 || Exp.has_local_addr e1 - | Apred _ | Anpred _ - -> false + | Aeq (e0, e1) | Aneq (e0, e1) -> + Exp.has_local_addr e0 || Exp.has_local_addr e1 + | Apred _ | Anpred _ -> + false + (** kind of lseg or dllseg predicates *) type lseg_kind = @@ -139,6 +141,7 @@ type strexp = inst strexp0 let compare_strexp ?(inst= false) se1 se2 = compare_strexp0 (match inst with true -> compare_inst | false -> fun _ _ -> 0) se1 se2 + let equal_strexp ?(inst= false) se1 se2 = Int.equal (compare_strexp ~inst se1 se2) 0 (** an atomic heap predicate *) @@ -183,6 +186,7 @@ type hpred = inst hpred0 let compare_hpred ?(inst= false) hpred1 hpred2 = compare_hpred0 (match inst with true -> compare_inst | false -> fun _ _ -> 0) hpred1 hpred2 + let equal_hpred ?(inst= false) hpred1 hpred2 = Int.equal (compare_hpred ~inst hpred1 hpred2) 0 type hpara = inst hpara0 @@ -199,32 +203,34 @@ let equal_hpara_dll = [%compare.equal : hpara_dll] (** Return the lhs expression of a hpred *) let hpred_get_lhs h = - match h - with Hpointsto (e, _, _) | Hlseg (_, _, e, _, _) | Hdllseg (_, _, e, _, _, _, _) -> e + match h with Hpointsto (e, _, _) | Hlseg (_, _, e, _, _) | Hdllseg (_, _, e, _, _, _, _) -> e + (** {2 Comparision and Inspection Functions} *) let has_objc_ref_counter tenv hpred = match hpred with | Hpointsto (_, _, Sizeof {typ= {desc= Tstruct name}}) -> ( match Tenv.lookup tenv name with - | Some {fields} - -> List.exists ~f:Typ.Struct.is_objc_ref_counter_field fields - | _ - -> false ) - | _ - -> false + | Some {fields} -> + List.exists ~f:Typ.Struct.is_objc_ref_counter_field fields + | _ -> + false ) + | _ -> + false + (** Returns the zero value of a type, for int, float and ptr types, None othwewise *) let zero_value_of_numerical_type_option typ = match typ.Typ.desc with - | Typ.Tint _ - -> Some (Exp.Const (Cint IntLit.zero)) - | Typ.Tfloat _ - -> Some (Exp.Const (Cfloat 0.0)) - | Typ.Tptr _ - -> Some (Exp.Const (Cint IntLit.null)) - | _ - -> None + | Typ.Tint _ -> + Some (Exp.Const (Cint IntLit.zero)) + | Typ.Tfloat _ -> + Some (Exp.Const (Cfloat 0.0)) + | Typ.Tptr _ -> + Some (Exp.Const (Cint IntLit.null)) + | _ -> + None + (** Returns the zero value of a type, for int, float and ptr types, fail otherwise *) let zero_value_of_numerical_type typ = Option.value_exn (zero_value_of_numerical_type_option typ) @@ -238,6 +244,7 @@ let is_static_local_name pname pvar = let var_name = Mangled.to_string (Pvar.get_name pvar) in match Str.split_delim (Str.regexp_string pname) var_name with [_; _] -> true | _ -> false + (** {2 Sets of expressions} *) let elist_to_eset es = List.fold ~f:(fun set e -> Exp.Set.add e set) ~init:Exp.Set.empty es @@ -265,43 +272,47 @@ let color_pre_wrapper pe f x = else (pe, false) else (pe, false) + (** Close color annotation if changed *) let color_post_wrapper changed pe f = if changed then if Pp.equal_print_kind pe.Pp.kind Pp.HTML then Io_infer.Html.pp_end_color f () else Latex.pp_color f pe.Pp.color + (** Print a sequence with difference mode if enabled. *) let pp_seq_diff pp pe0 f = if not Config.print_using_diff then Pp.comma_seq pp f else let rec doit = function - | [] - -> () - | [x] - -> let _, changed = color_pre_wrapper pe0 f x in + | [] -> + () + | [x] -> + let _, changed = color_pre_wrapper pe0 f x in F.fprintf f "%a" pp x ; color_post_wrapper changed pe0 f - | x :: l - -> let _, changed = color_pre_wrapper pe0 f x in + | x :: l -> + let _, changed = color_pre_wrapper pe0 f x in F.fprintf f "%a" pp x ; color_post_wrapper changed pe0 f ; F.fprintf f ", " ; doit l in doit + (** Pretty print an expression. *) let pp_exp_printenv pe0 f e0 = let pe, changed = color_pre_wrapper pe0 f e0 in let e = match pe.Pp.obj_sub with - | Some sub - -> (* apply object substitution to expression *) Obj.obj (sub (Obj.repr e0)) - | None - -> e0 + | Some sub -> + (* apply object substitution to expression *) Obj.obj (sub (Obj.repr e0)) + | None -> + e0 in if not (Exp.equal e0 e) then match e with Exp.Lvar pvar -> Pvar.pp_value pe f pvar | _ -> assert false else Exp.pp_printenv pe Typ.pp f e ; color_post_wrapper changed pe0 f + (** dump an expression. *) let d_exp (e: Exp.t) = L.add_print_action (L.PTexp, Obj.repr e) @@ -312,33 +323,36 @@ let pp_exp_list pe f expl = Pp.seq (pp_exp_printenv pe) f expl let d_exp_list (el: Exp.t list) = L.add_print_action (L.PTexp_list, Obj.repr el) let pp_texp pe f = function - | Exp.Sizeof {typ; nbytes; dynamic_length; subtype} - -> let pp_len f l = Option.iter ~f:(F.fprintf f "[%a]" (pp_exp_printenv pe)) l in + | Exp.Sizeof {typ; nbytes; dynamic_length; subtype} -> + let pp_len f l = Option.iter ~f:(F.fprintf f "[%a]" (pp_exp_printenv pe)) l in let pp_size f size = Option.iter ~f:(Int.pp f) size in F.fprintf f "%a%a%a%a" (Typ.pp pe) typ pp_size nbytes pp_len dynamic_length Subtype.pp subtype - | e - -> pp_exp_printenv pe f e + | e -> + pp_exp_printenv pe f e + (** Pretty print a type with all the details. *) let pp_texp_full pe f = function - | Exp.Sizeof {typ; nbytes; dynamic_length; subtype} - -> let pp_len f l = Option.iter ~f:(F.fprintf f "[%a]" (pp_exp_printenv pe)) l in + | Exp.Sizeof {typ; nbytes; dynamic_length; subtype} -> + let pp_len f l = Option.iter ~f:(F.fprintf f "[%a]" (pp_exp_printenv pe)) l in let pp_size f size = Option.iter ~f:(Int.pp f) size in F.fprintf f "%a%a%a%a" (Typ.pp_full pe) typ pp_size nbytes pp_len dynamic_length Subtype.pp subtype - | e - -> Exp.pp_printenv pe Typ.pp_full f e + | e -> + Exp.pp_printenv pe Typ.pp_full f e + (** Dump a type expression with all the details. *) let d_texp_full (te: Exp.t) = L.add_print_action (L.PTtexp_full, Obj.repr te) (** Pretty print an offset *) let pp_offset pe f = function - | Off_fld (fld, _) - -> F.fprintf f "%a" Typ.Fieldname.pp fld - | Off_index exp - -> F.fprintf f "%a" (pp_exp_printenv pe) exp + | Off_fld (fld, _) -> + F.fprintf f "%a" Typ.Fieldname.pp fld + | Off_index exp -> + F.fprintf f "%a" (pp_exp_printenv pe) exp + (** Convert an offset to a string *) let offset_to_string e = F.asprintf "%a" (pp_offset Pp.text) e @@ -348,12 +362,13 @@ let d_offset (off: offset) = L.add_print_action (L.PToff, Obj.repr off) (** Pretty print a list of offsets *) let rec pp_offset_list pe f = function - | [] - -> () - | [off1; off2] - -> F.fprintf f "%a.%a" (pp_offset pe) off1 (pp_offset pe) off2 - | off :: off_list - -> F.fprintf f "%a.%a" (pp_offset pe) off (pp_offset_list pe) off_list + | [] -> + () + | [off1; off2] -> + F.fprintf f "%a.%a" (pp_offset pe) off1 (pp_offset pe) off2 + | off :: off_list -> + F.fprintf f "%a.%a" (pp_offset pe) off (pp_offset_list pe) off_list + (** Dump a list of offsets *) let d_offset_list (offl: offset list) = L.add_print_action (L.PToff_list, Obj.repr offl) @@ -369,56 +384,59 @@ let instr_get_loc = function | Nullify (_, loc) | Abstract loc | Remove_temps (_, loc) - | Declare_locals (_, loc) - -> loc + | Declare_locals (_, loc) -> + loc + (** get the expressions occurring in the instruction *) let instr_get_exps = function - | Load (id, e, _, _) - -> [Exp.Var id; e] - | Store (e1, _, e2, _) - -> [e1; e2] - | Prune (cond, _, _, _) - -> [cond] - | Call (ret_id, e, _, _, _) - -> e :: Option.value_map ~f:(fun (id, _) -> [Exp.Var id]) ~default:[] ret_id - | Nullify (pvar, _) - -> [Exp.Lvar pvar] - | Abstract _ - -> [] - | Remove_temps (temps, _) - -> List.map ~f:(fun id -> Exp.Var id) temps - | Declare_locals _ - -> [] + | Load (id, e, _, _) -> + [Exp.Var id; e] + | Store (e1, _, e2, _) -> + [e1; e2] + | Prune (cond, _, _, _) -> + [cond] + | Call (ret_id, e, _, _, _) -> + e :: Option.value_map ~f:(fun (id, _) -> [Exp.Var id]) ~default:[] ret_id + | Nullify (pvar, _) -> + [Exp.Lvar pvar] + | Abstract _ -> + [] + | Remove_temps (temps, _) -> + List.map ~f:(fun id -> Exp.Var id) temps + | Declare_locals _ -> + [] + (** Pretty print an instruction. *) let pp_instr pe0 f instr = let pe, changed = color_pre_wrapper pe0 f instr in ( match instr with - | Load (id, e, t, loc) - -> F.fprintf f "%a=*%a:%a [%a]" (Ident.pp pe) id (pp_exp_printenv pe) e (Typ.pp pe) t + | Load (id, e, t, loc) -> + F.fprintf f "%a=*%a:%a [%a]" (Ident.pp pe) id (pp_exp_printenv pe) e (Typ.pp pe) t Location.pp loc - | Store (e1, t, e2, loc) - -> F.fprintf f "*%a:%a=%a [%a]" (pp_exp_printenv pe) e1 (Typ.pp pe) t (pp_exp_printenv pe) e2 + | Store (e1, t, e2, loc) -> + F.fprintf f "*%a:%a=%a [%a]" (pp_exp_printenv pe) e1 (Typ.pp pe) t (pp_exp_printenv pe) e2 Location.pp loc - | Prune (cond, loc, true_branch, _) - -> F.fprintf f "PRUNE(%a, %b); [%a]" (pp_exp_printenv pe) cond true_branch Location.pp loc - | Call (ret_id, e, arg_ts, loc, cf) - -> (match ret_id with None -> () | Some (id, _) -> F.fprintf f "%a=" (Ident.pp pe) id) ; + | Prune (cond, loc, true_branch, _) -> + F.fprintf f "PRUNE(%a, %b); [%a]" (pp_exp_printenv pe) cond true_branch Location.pp loc + | Call (ret_id, e, arg_ts, loc, cf) -> + (match ret_id with None -> () | Some (id, _) -> F.fprintf f "%a=" (Ident.pp pe) id) ; F.fprintf f "%a(%a)%a [%a]" (pp_exp_printenv pe) e (Pp.comma_seq (pp_exp_typ pe)) arg_ts CallFlags.pp cf Location.pp loc - | Nullify (pvar, loc) - -> F.fprintf f "NULLIFY(%a); [%a]" (Pvar.pp pe) pvar Location.pp loc - | Abstract loc - -> F.fprintf f "APPLY_ABSTRACTION; [%a]" Location.pp loc - | Remove_temps (temps, loc) - -> F.fprintf f "REMOVE_TEMPS(%a); [%a]" (Ident.pp_list pe) temps Location.pp loc - | Declare_locals (ptl, loc) - -> let pp_typ fmt (pvar, _) = Pvar.pp pe fmt pvar in + | Nullify (pvar, loc) -> + F.fprintf f "NULLIFY(%a); [%a]" (Pvar.pp pe) pvar Location.pp loc + | Abstract loc -> + F.fprintf f "APPLY_ABSTRACTION; [%a]" Location.pp loc + | Remove_temps (temps, loc) -> + F.fprintf f "REMOVE_TEMPS(%a); [%a]" (Ident.pp_list pe) temps Location.pp loc + | Declare_locals (ptl, loc) -> + let pp_typ fmt (pvar, _) = Pvar.pp pe fmt pvar in F.fprintf f "DECLARE_LOCALS(%a); [%a]" (Pp.comma_seq pp_typ) ptl Location.pp loc ) ; color_post_wrapper changed pe0 f + (** Check if a pvar is a local pointing to a block in objc *) let is_block_pvar pvar = Typ.has_block_prefix (Mangled.to_string (Pvar.get_name pvar)) @@ -431,6 +449,7 @@ let d_instr (i: instr) = L.add_print_action (L.PTinstr, Obj.repr i) let pp_instr_list pe fmt instrs = List.iter instrs ~f:(fun instr -> F.fprintf fmt "%a;@\n" (pp_instr pe) instr) + (** Dump a list of instructions. *) let d_instr_list (il: instr list) = L.add_print_action (L.PTinstr_list, Obj.repr il) @@ -439,28 +458,29 @@ let pp_atom pe0 f a = ( match a with | Aeq (BinOp (op, e1, e2), Const Cint i) when IntLit.isone i -> ( match pe.Pp.kind with - | TEXT | HTML - -> F.fprintf f "%a" (pp_exp_printenv pe) (Exp.BinOp (op, e1, e2)) - | LATEX - -> F.fprintf f "%a" (pp_exp_printenv pe) (Exp.BinOp (op, e1, e2)) ) + | TEXT | HTML -> + F.fprintf f "%a" (pp_exp_printenv pe) (Exp.BinOp (op, e1, e2)) + | LATEX -> + F.fprintf f "%a" (pp_exp_printenv pe) (Exp.BinOp (op, e1, e2)) ) | Aeq (e1, e2) -> ( match pe.Pp.kind with - | TEXT | HTML - -> F.fprintf f "%a = %a" (pp_exp_printenv pe) e1 (pp_exp_printenv pe) e2 - | LATEX - -> F.fprintf f "%a{=}%a" (pp_exp_printenv pe) e1 (pp_exp_printenv pe) e2 ) + | TEXT | HTML -> + F.fprintf f "%a = %a" (pp_exp_printenv pe) e1 (pp_exp_printenv pe) e2 + | LATEX -> + F.fprintf f "%a{=}%a" (pp_exp_printenv pe) e1 (pp_exp_printenv pe) e2 ) | Aneq (e1, e2) -> ( match pe.Pp.kind with - | TEXT | HTML - -> F.fprintf f "%a != %a" (pp_exp_printenv pe) e1 (pp_exp_printenv pe) e2 - | LATEX - -> F.fprintf f "%a{\\neq}%a" (pp_exp_printenv pe) e1 (pp_exp_printenv pe) e2 ) - | Apred (a, es) - -> F.fprintf f "%s(%a)" (PredSymb.to_string pe a) (Pp.comma_seq (pp_exp_printenv pe)) es - | Anpred (a, es) - -> F.fprintf f "!%s(%a)" (PredSymb.to_string pe a) (Pp.comma_seq (pp_exp_printenv pe)) es ) ; + | TEXT | HTML -> + F.fprintf f "%a != %a" (pp_exp_printenv pe) e1 (pp_exp_printenv pe) e2 + | LATEX -> + F.fprintf f "%a{\\neq}%a" (pp_exp_printenv pe) e1 (pp_exp_printenv pe) e2 ) + | Apred (a, es) -> + F.fprintf f "%s(%a)" (PredSymb.to_string pe a) (Pp.comma_seq (pp_exp_printenv pe)) es + | Anpred (a, es) -> + F.fprintf f "!%s(%a)" (PredSymb.to_string pe a) (Pp.comma_seq (pp_exp_printenv pe)) es ) ; color_post_wrapper changed pe0 f + (** dump an atom *) let d_atom (a: atom) = L.add_print_action (L.PTatom, Obj.repr a) @@ -468,12 +488,13 @@ let pp_lseg_kind f = function Lseg_NE -> F.fprintf f "ne" | Lseg_PE -> () (** Print a *-separated sequence. *) let rec pp_star_seq pp f = function - | [] - -> () - | [x] - -> F.fprintf f "%a" pp x - | x :: l - -> F.fprintf f "%a * %a" pp x (pp_star_seq pp) l + | [] -> + () + | [x] -> + F.fprintf f "%a" pp x + | x :: l -> + F.fprintf f "%a * %a" pp x (pp_star_seq pp) l + (** Module Predicates records the occurrences of predicates as parameters of (doubly -)linked lists and Epara. Provides unique numbering @@ -551,6 +572,7 @@ end = struct env.num <- env.num + 1 ; env.todo <- env.todo @ [hpara] ) + (** Process one hpara_dll, updating the map from hparas to numbers, and the todo list *) let process_hpara_dll env hpara_dll = if not (HparaDllHash.mem env.hash_dll hpara_dll) then ( @@ -558,30 +580,34 @@ end = struct env.num <- env.num + 1 ; env.todo_dll <- env.todo_dll @ [hpara_dll] ) + (** Process a sexp, updating env *) let rec process_sexp env = function - | Eexp _ - -> () - | Earray (_, esel, _) - -> List.iter ~f:(fun (_, se) -> process_sexp env se) esel - | Estruct (fsel, _) - -> List.iter ~f:(fun (_, se) -> process_sexp env se) fsel + | Eexp _ -> + () + | Earray (_, esel, _) -> + List.iter ~f:(fun (_, se) -> process_sexp env se) esel + | Estruct (fsel, _) -> + List.iter ~f:(fun (_, se) -> process_sexp env se) fsel + (** Process one hpred, updating env *) let rec process_hpred env = function - | Hpointsto (_, se, _) - -> process_sexp env se - | Hlseg (_, hpara, _, _, _) - -> List.iter ~f:(process_hpred env) hpara.body ; + | Hpointsto (_, se, _) -> + process_sexp env se + | Hlseg (_, hpara, _, _, _) -> + List.iter ~f:(process_hpred env) hpara.body ; process_hpara env hpara - | Hdllseg (_, hpara_dll, _, _, _, _, _) - -> List.iter ~f:(process_hpred env) hpara_dll.body_dll ; + | Hdllseg (_, hpara_dll, _, _, _, _, _) -> + List.iter ~f:(process_hpred env) hpara_dll.body_dll ; process_hpara_dll env hpara_dll + (** create an empty predicate environment *) let empty_env () = {num= 0; hash= HparaHash.create 3; todo= []; hash_dll= HparaDllHash.create 3; todo_dll= []} + (** iterator for predicates which are marked as todo in env, unless they have been visited already. This can in turn extend the todo list for the nested predicates, @@ -590,24 +616,26 @@ end = struct let iter (env: env) f f_dll = while env.todo <> [] || env.todo_dll <> [] do match env.todo with - | hpara :: todo' - -> env.todo <- todo' ; + | hpara :: todo' -> + env.todo <- todo' ; let n, emitted = HparaHash.find env.hash hpara in if not emitted then f n hpara | [] -> match env.todo_dll with - | hpara_dll :: todo_dll' - -> env.todo_dll <- todo_dll' ; + | hpara_dll :: todo_dll' -> + env.todo_dll <- todo_dll' ; let n, emitted = HparaDllHash.find env.hash_dll hpara_dll in if not emitted then f_dll n hpara_dll - | [] - -> () + | [] -> + () done + end let pp_texp_simple pe = match pe.Pp.opt with SIM_DEFAULT -> pp_texp pe | SIM_WITH_TYP -> pp_texp_full pe + let inst_abstraction = Iabstraction let inst_actual_precondition = Iactual_precondition @@ -635,60 +663,62 @@ let inst_update loc pos = Iupdate (None, false, loc.Location.line, pos) (** update the location of the instrumentation *) let inst_new_loc loc inst = match inst with - | Iabstraction - -> inst - | Iactual_precondition - -> inst - | Ialloc - -> inst - | Iformal _ - -> inst - | Iinitial - -> inst - | Ilookup - -> inst - | Inone - -> inst - | Inullify - -> inst - | Irearrange (zf, ncf, _, pos) - -> Irearrange (zf, ncf, loc.Location.line, pos) - | Itaint - -> inst - | Iupdate (zf, ncf, _, pos) - -> Iupdate (zf, ncf, loc.Location.line, pos) - | Ireturn_from_call _ - -> Ireturn_from_call loc.Location.line + | Iabstraction -> + inst + | Iactual_precondition -> + inst + | Ialloc -> + inst + | Iformal _ -> + inst + | Iinitial -> + inst + | Ilookup -> + inst + | Inone -> + inst + | Inullify -> + inst + | Irearrange (zf, ncf, _, pos) -> + Irearrange (zf, ncf, loc.Location.line, pos) + | Itaint -> + inst + | Iupdate (zf, ncf, _, pos) -> + Iupdate (zf, ncf, loc.Location.line, pos) + | Ireturn_from_call _ -> + Ireturn_from_call loc.Location.line + (** return a string representing the inst *) let inst_to_string inst = let zero_flag_to_string = function Some true -> "(z)" | _ -> "" in let null_case_flag_to_string ncf = if ncf then "(ncf)" else "" in match inst with - | Iabstraction - -> "abstraction" - | Iactual_precondition - -> "actual_precondition" - | Ialloc - -> "alloc" - | Iformal (zf, ncf) - -> "formal" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf - | Iinitial - -> "initial" - | Ilookup - -> "lookup" - | Inone - -> "none" - | Inullify - -> "nullify" - | Irearrange (zf, ncf, n, _) - -> "rearrange:" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf ^ string_of_int n - | Itaint - -> "taint" - | Iupdate (zf, ncf, n, _) - -> "update:" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf ^ string_of_int n - | Ireturn_from_call n - -> "return_from_call: " ^ string_of_int n + | Iabstraction -> + "abstraction" + | Iactual_precondition -> + "actual_precondition" + | Ialloc -> + "alloc" + | Iformal (zf, ncf) -> + "formal" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf + | Iinitial -> + "initial" + | Ilookup -> + "lookup" + | Inone -> + "none" + | Inullify -> + "nullify" + | Irearrange (zf, ncf, n, _) -> + "rearrange:" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf ^ string_of_int n + | Itaint -> + "taint" + | Iupdate (zf, ncf, n, _) -> + "update:" ^ zero_flag_to_string zf ^ null_case_flag_to_string ncf ^ string_of_int n + | Ireturn_from_call n -> + "return_from_call: " ^ string_of_int n + exception JoinFail @@ -701,57 +731,60 @@ let inst_partial_join inst1 inst2 = if equal_inst inst1 inst2 then inst1 else match (inst1, inst2) with - | _, Inone | Inone, _ - -> inst_none - | _, Ialloc | Ialloc, _ - -> fail () - | _, Iinitial | Iinitial, _ - -> fail () - | _, Iupdate _ | Iupdate _, _ - -> fail () - | _ - -> inst_none + | _, Inone | Inone, _ -> + inst_none + | _, Ialloc | Ialloc, _ -> + fail () + | _, Iinitial | Iinitial, _ -> + fail () + | _, Iupdate _ | Iupdate _, _ -> + fail () + | _ -> + inst_none + (** meet of instrumentations *) let inst_partial_meet inst1 inst2 = if equal_inst inst1 inst2 then inst1 else inst_none (** Return the zero flag of the inst *) let inst_zero_flag = function - | Iabstraction - -> None - | Iactual_precondition - -> None - | Ialloc - -> None - | Iformal (zf, _) - -> zf - | Iinitial - -> None - | Ilookup - -> None - | Inone - -> None - | Inullify - -> None - | Irearrange (zf, _, _, _) - -> zf - | Itaint - -> None - | Iupdate (zf, _, _, _) - -> zf - | Ireturn_from_call _ - -> None + | Iabstraction -> + None + | Iactual_precondition -> + None + | Ialloc -> + None + | Iformal (zf, _) -> + zf + | Iinitial -> + None + | Ilookup -> + None + | Inone -> + None + | Inullify -> + None + | Irearrange (zf, _, _, _) -> + zf + | Itaint -> + None + | Iupdate (zf, _, _, _) -> + zf + | Ireturn_from_call _ -> + None + (** Set the null case flag of the inst. *) let inst_set_null_case_flag = function - | Iformal (zf, false) - -> Iformal (zf, true) - | Irearrange (zf, false, n, pos) - -> Irearrange (zf, true, n, pos) - | Iupdate (zf, false, n, pos) - -> Iupdate (zf, true, n, pos) - | inst - -> inst + | Iformal (zf, false) -> + Iformal (zf, true) + | Irearrange (zf, false, n, pos) -> + Irearrange (zf, true, n, pos) + | Iupdate (zf, false, n, pos) -> + Iupdate (zf, true, n, pos) + | inst -> + inst + (** Get the null case flag of the inst. *) let inst_get_null_case_flag = function Iupdate (_, ncf, _, _) -> Some ncf | _ -> None @@ -760,43 +793,44 @@ let inst_get_null_case_flag = function Iupdate (_, ncf, _, _) -> Some ncf | _ -> let update_inst inst_old inst_new = let combine_zero_flags z1 z2 = match (z1, z2) with - | Some b1, Some b2 - -> Some (b1 || b2) - | Some b, None - -> Some b - | None, Some b - -> Some b - | None, None - -> None + | Some b1, Some b2 -> + Some (b1 || b2) + | Some b, None -> + Some b + | None, Some b -> + Some b + | None, None -> + None in match inst_new with - | Iabstraction - -> inst_new - | Iactual_precondition - -> inst_new - | Ialloc - -> inst_new - | Iformal (zf, ncf) - -> let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in + | Iabstraction -> + inst_new + | Iactual_precondition -> + inst_new + | Ialloc -> + inst_new + | Iformal (zf, ncf) -> + let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in Iformal (zf', ncf) - | Iinitial - -> inst_new - | Ilookup - -> inst_new - | Inone - -> inst_new - | Inullify - -> inst_new - | Irearrange (zf, ncf, n, pos) - -> let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in + | Iinitial -> + inst_new + | Ilookup -> + inst_new + | Inone -> + inst_new + | Inullify -> + inst_new + | Irearrange (zf, ncf, n, pos) -> + let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in Irearrange (zf', ncf, n, pos) - | Itaint - -> inst_new - | Iupdate (zf, ncf, n, pos) - -> let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in + | Itaint -> + inst_new + | Iupdate (zf, ncf, n, pos) -> + let zf' = combine_zero_flags (inst_zero_flag inst_old) zf in Iupdate (zf', ncf, n, pos) - | Ireturn_from_call _ - -> inst_new + | Ireturn_from_call _ -> + inst_new + (** describe an instrumentation with a string *) let pp_inst pe f inst = @@ -805,82 +839,85 @@ let pp_inst pe f inst = F.fprintf f " %a%s%a" Io_infer.Html.pp_start_color Pp.Orange str Io_infer.Html.pp_end_color () else F.fprintf f "%s%s%s" (Binop.str pe Lt) str (Binop.str pe Gt) + let pp_inst_if_trace pe f inst = if Config.trace_error then pp_inst pe f inst (** pretty print a strexp with an optional predicate env *) let rec pp_sexp_env pe0 envo f se = let pe, changed = color_pre_wrapper pe0 f se in ( match se with - | Eexp (e, inst) - -> F.fprintf f "%a%a" (pp_exp_printenv pe) e (pp_inst_if_trace pe) inst + | Eexp (e, inst) -> + F.fprintf f "%a%a" (pp_exp_printenv pe) e (pp_inst_if_trace pe) inst | Estruct (fel, inst) -> ( match pe.Pp.kind with - | TEXT | HTML - -> let pp_diff f (n, se) = F.fprintf f "%a:%a" Typ.Fieldname.pp n (pp_sexp_env pe envo) se in + | TEXT | HTML -> + let pp_diff f (n, se) = F.fprintf f "%a:%a" Typ.Fieldname.pp n (pp_sexp_env pe envo) se in F.fprintf f "{%a}%a" (pp_seq_diff pp_diff pe) fel (pp_inst_if_trace pe) inst - | LATEX - -> let pp_diff f (n, se) = + | LATEX -> + let pp_diff f (n, se) = F.fprintf f "%a:%a" (Typ.Fieldname.pp_latex Latex.Boldface) n (pp_sexp_env pe envo) se in F.fprintf f "\\{%a\\}%a" (pp_seq_diff pp_diff pe) fel (pp_inst_if_trace pe) inst ) - | Earray (len, nel, inst) - -> let pp_diff f (i, se) = + | Earray (len, nel, inst) -> + let pp_diff f (i, se) = F.fprintf f "%a:%a" (pp_exp_printenv pe) i (pp_sexp_env pe envo) se in F.fprintf f "[%a|%a]%a" (pp_exp_printenv pe) len (pp_seq_diff pp_diff pe) nel (pp_inst_if_trace pe) inst ) ; color_post_wrapper changed pe0 f + (** Pretty print an hpred with an optional predicate env *) let rec pp_hpred_env pe0 envo f hpred = let pe, changed = color_pre_wrapper pe0 f hpred in ( match hpred with | Hpointsto (e, se, te) - -> ( + -> ( let pe' = match (e, se) with - | Lvar pvar, Eexp (Var _, _) when not (Pvar.is_global pvar) - -> Pp.{pe with obj_sub= None} (* dont use obj sub on the var defining it *) - | _ - -> pe + | Lvar pvar, Eexp (Var _, _) when not (Pvar.is_global pvar) -> + Pp.{pe with obj_sub= None} (* dont use obj sub on the var defining it *) + | _ -> + pe in match pe'.Pp.kind with - | TEXT | HTML - -> F.fprintf f "%a|->%a:%a" (pp_exp_printenv pe') e (pp_sexp_env pe' envo) se + | TEXT | HTML -> + F.fprintf f "%a|->%a:%a" (pp_exp_printenv pe') e (pp_sexp_env pe' envo) se (pp_texp_simple pe') te - | LATEX - -> F.fprintf f "%a\\mapsto %a" (pp_exp_printenv pe') e (pp_sexp_env pe' envo) se ) + | LATEX -> + F.fprintf f "%a\\mapsto %a" (pp_exp_printenv pe') e (pp_sexp_env pe' envo) se ) | Hlseg (k, hpara, e1, e2, elist) -> ( match pe.Pp.kind with - | TEXT | HTML - -> F.fprintf f "lseg%a(%a,%a,[%a],%a)" pp_lseg_kind k (pp_exp_printenv pe) e1 + | TEXT | HTML -> + F.fprintf f "lseg%a(%a,%a,[%a],%a)" pp_lseg_kind k (pp_exp_printenv pe) e1 (pp_exp_printenv pe) e2 (Pp.comma_seq (pp_exp_printenv pe)) elist (pp_hpara_env pe envo) hpara - | LATEX - -> F.fprintf f "\\textsf{lseg}_{%a}(%a,%a,[%a],%a)" pp_lseg_kind k (pp_exp_printenv pe) e1 + | LATEX -> + F.fprintf f "\\textsf{lseg}_{%a}(%a,%a,[%a],%a)" pp_lseg_kind k (pp_exp_printenv pe) e1 (pp_exp_printenv pe) e2 (Pp.comma_seq (pp_exp_printenv pe)) elist (pp_hpara_env pe envo) hpara ) | Hdllseg (k, hpara_dll, iF, oB, oF, iB, elist) -> match pe.Pp.kind with - | TEXT | HTML - -> F.fprintf f "dllseg%a(%a,%a,%a,%a,[%a],%a)" pp_lseg_kind k (pp_exp_printenv pe) iF + | TEXT | HTML -> + F.fprintf f "dllseg%a(%a,%a,%a,%a,[%a],%a)" pp_lseg_kind k (pp_exp_printenv pe) iF (pp_exp_printenv pe) oB (pp_exp_printenv pe) oF (pp_exp_printenv pe) iB (Pp.comma_seq (pp_exp_printenv pe)) elist (pp_hpara_dll_env pe envo) hpara_dll - | LATEX - -> F.fprintf f "\\textsf{dllseg}_{%a}(%a,%a,%a,%a,[%a],%a)" pp_lseg_kind k + | LATEX -> + F.fprintf f "\\textsf{dllseg}_{%a}(%a,%a,%a,%a,[%a],%a)" pp_lseg_kind k (pp_exp_printenv pe) iF (pp_exp_printenv pe) oB (pp_exp_printenv pe) oF (pp_exp_printenv pe) iB (Pp.comma_seq (pp_exp_printenv pe)) elist (pp_hpara_dll_env pe envo) hpara_dll ) ; color_post_wrapper changed pe0 f + and pp_hpara_env pe envo f hpara = match envo with - | None - -> let r, n, svars, evars, b = (hpara.root, hpara.next, hpara.svars, hpara.evars, hpara.body) in + | None -> + let r, n, svars, evars, b = (hpara.root, hpara.next, hpara.svars, hpara.evars, hpara.body) in F.fprintf f "lam [%a,%a,%a]. exists [%a]. %a" (Ident.pp pe) r (Ident.pp pe) n (Pp.seq (Ident.pp pe)) svars @@ -888,13 +925,14 @@ and pp_hpara_env pe envo f hpara = evars (pp_star_seq (pp_hpred_env pe envo)) b - | Some env - -> F.fprintf f "P%d" (Predicates.get_hpara_id env hpara) + | Some env -> + F.fprintf f "P%d" (Predicates.get_hpara_id env hpara) + and pp_hpara_dll_env pe envo f hpara_dll = match envo with - | None - -> let iF, oB, oF, svars, evars, b = + | None -> + let iF, oB, oF, svars, evars, b = ( hpara_dll.cell , hpara_dll.blink , hpara_dll.flink @@ -910,8 +948,9 @@ and pp_hpara_dll_env pe envo f hpara_dll = evars (pp_star_seq (pp_hpred_env pe envo)) b - | Some env - -> F.fprintf f "P%d" (Predicates.get_hpara_dll_id env hpara_dll) + | Some env -> + F.fprintf f "P%d" (Predicates.get_hpara_dll_id env hpara_dll) + (** pretty print a strexp *) let pp_sexp pe f = pp_sexp_env pe None f @@ -932,24 +971,27 @@ let d_sexp (se: strexp) = L.add_print_action (L.PTsexp, Obj.repr se) let pp_sexp_list pe f sel = F.fprintf f "%a" (Pp.seq (fun f se -> F.fprintf f "%a" (pp_sexp pe) se)) sel + (** dump a list of expressions. *) let d_sexp_list (sel: strexp list) = L.add_print_action (L.PTsexp_list, Obj.repr sel) let rec pp_hpara_list pe f = function - | [] - -> () - | [para] - -> F.fprintf f "PRED: %a" (pp_hpara pe) para - | para :: paras - -> F.fprintf f "PRED: %a@\n@\n%a" (pp_hpara pe) para (pp_hpara_list pe) paras + | [] -> + () + | [para] -> + F.fprintf f "PRED: %a" (pp_hpara pe) para + | para :: paras -> + F.fprintf f "PRED: %a@\n@\n%a" (pp_hpara pe) para (pp_hpara_list pe) paras + let rec pp_hpara_dll_list pe f = function - | [] - -> () - | [para] - -> F.fprintf f "PRED: %a" (pp_hpara_dll pe) para - | para :: paras - -> F.fprintf f "PRED: %a@\n@\n%a" (pp_hpara_dll pe) para (pp_hpara_dll_list pe) paras + | [] -> + () + | [para] -> + F.fprintf f "PRED: %a" (pp_hpara_dll pe) para + | para :: paras -> + F.fprintf f "PRED: %a@\n@\n%a" (pp_hpara_dll pe) para (pp_hpara_dll_list pe) paras + (** dump a hpred. *) let d_hpred (hpred: hpred) = L.add_print_action (L.PThpred, Obj.repr hpred) @@ -962,154 +1004,168 @@ let rec strexp_expmap (f: Exp.t * inst option -> Exp.t * inst option) = match f (e, Some inst) with e', None -> (e', inst) | e', Some inst' -> (e', inst') in function - | Eexp (e, inst) - -> let e', inst' = fei (e, inst) in + | Eexp (e, inst) -> + let e', inst' = fei (e, inst) in Eexp (e', inst') - | Estruct (fld_se_list, inst) - -> let f_fld_se (fld, se) = (fld, strexp_expmap f se) in + | Estruct (fld_se_list, inst) -> + let f_fld_se (fld, se) = (fld, strexp_expmap f se) in Estruct (List.map ~f:f_fld_se fld_se_list, inst) - | Earray (len, idx_se_list, inst) - -> let len' = fe len in + | Earray (len, idx_se_list, inst) -> + let len' = fe len in let f_idx_se (idx, se) = let idx' = fe idx in (idx', strexp_expmap f se) in Earray (len', List.map ~f:f_idx_se idx_se_list, inst) + let hpred_expmap (f: Exp.t * inst option -> Exp.t * inst option) = let fe e = fst (f (e, None)) in function - | Hpointsto (e, se, te) - -> let e' = fe e in + | Hpointsto (e, se, te) -> + let e' = fe e in let se' = strexp_expmap f se in let te' = fe te in Hpointsto (e', se', te') - | Hlseg (k, hpara, root, next, shared) - -> let root' = fe root in + | Hlseg (k, hpara, root, next, shared) -> + let root' = fe root in let next' = fe next in let shared' = List.map ~f:fe shared in Hlseg (k, hpara, root', next', shared') - | Hdllseg (k, hpara, iF, oB, oF, iB, shared) - -> let iF' = fe iF in + | Hdllseg (k, hpara, iF, oB, oF, iB, shared) -> + let iF' = fe iF in let oB' = fe oB in let oF' = fe oF in let iB' = fe iB in let shared' = List.map ~f:fe shared in Hdllseg (k, hpara, iF', oB', oF', iB', shared') + let rec strexp_instmap (f: inst -> inst) strexp = match strexp with - | Eexp (e, inst) - -> Eexp (e, f inst) - | Estruct (fld_se_list, inst) - -> let f_fld_se (fld, se) = (fld, strexp_instmap f se) in + | Eexp (e, inst) -> + Eexp (e, f inst) + | Estruct (fld_se_list, inst) -> + let f_fld_se (fld, se) = (fld, strexp_instmap f se) in Estruct (List.map ~f:f_fld_se fld_se_list, f inst) - | Earray (len, idx_se_list, inst) - -> let f_idx_se (idx, se) = (idx, strexp_instmap f se) in + | Earray (len, idx_se_list, inst) -> + let f_idx_se (idx, se) = (idx, strexp_instmap f se) in Earray (len, List.map ~f:f_idx_se idx_se_list, f inst) + let rec hpara_instmap (f: inst -> inst) hpara = {hpara with body= List.map ~f:(hpred_instmap f) hpara.body} + and hpara_dll_instmap (f: inst -> inst) hpara_dll = {hpara_dll with body_dll= List.map ~f:(hpred_instmap f) hpara_dll.body_dll} + and hpred_instmap (fn: inst -> inst) (hpred: hpred) : hpred = match hpred with - | Hpointsto (e, se, te) - -> let se' = strexp_instmap fn se in + | Hpointsto (e, se, te) -> + let se' = strexp_instmap fn se in Hpointsto (e, se', te) - | Hlseg (k, hpara, e, f, el) - -> Hlseg (k, hpara_instmap fn hpara, e, f, el) - | Hdllseg (k, hpar_dll, e, f, g, h, el) - -> Hdllseg (k, hpara_dll_instmap fn hpar_dll, e, f, g, h, el) + | Hlseg (k, hpara, e, f, el) -> + Hlseg (k, hpara_instmap fn hpara, e, f, el) + | Hdllseg (k, hpar_dll, e, f, g, h, el) -> + Hdllseg (k, hpara_dll_instmap fn hpar_dll, e, f, g, h, el) + let hpred_list_expmap (f: Exp.t * inst option -> Exp.t * inst option) (hlist: hpred list) = List.map ~f:(hpred_expmap f) hlist + let atom_expmap (f: Exp.t -> Exp.t) = function - | Aeq (e1, e2) - -> Aeq (f e1, f e2) - | Aneq (e1, e2) - -> Aneq (f e1, f e2) - | Apred (a, es) - -> Apred (a, List.map ~f es) - | Anpred (a, es) - -> Anpred (a, List.map ~f es) + | Aeq (e1, e2) -> + Aeq (f e1, f e2) + | Aneq (e1, e2) -> + Aneq (f e1, f e2) + | Apred (a, es) -> + Apred (a, List.map ~f es) + | Anpred (a, es) -> + Anpred (a, List.map ~f es) + let atom_list_expmap (f: Exp.t -> Exp.t) (alist: atom list) = List.map ~f:(atom_expmap f) alist (** {2 Function for computing lexps in sigma} *) let hpred_get_lexp acc = function - | Hpointsto (e, _, _) - -> e :: acc - | Hlseg (_, _, e, _, _) - -> e :: acc - | Hdllseg (_, _, e1, _, _, e2, _) - -> e1 :: e2 :: acc + | Hpointsto (e, _, _) -> + e :: acc + | Hlseg (_, _, e, _, _) -> + e :: acc + | Hdllseg (_, _, e1, _, _, e2, _) -> + e1 :: e2 :: acc + let hpred_list_get_lexps (filter: Exp.t -> bool) (hlist: hpred list) : Exp.t list = let lexps = List.fold ~f:hpred_get_lexp ~init:[] hlist in List.filter ~f:filter lexps + (** {2 Functions for computing program variables} *) let rec exp_fpv e = match (e : Exp.t) with - | Var _ - -> [] - | Exn e - -> exp_fpv e - | Closure {captured_vars} - -> List.map ~f:(fun (_, pvar, _) -> pvar) captured_vars - | Const _ - -> [] - | Cast (_, e) | UnOp (_, e, _) - -> exp_fpv e - | BinOp (_, e1, e2) - -> exp_fpv e1 @ exp_fpv e2 - | Lvar name - -> [name] - | Lfield (e, _, _) - -> exp_fpv e - | Lindex (e1, e2) - -> exp_fpv e1 @ exp_fpv e2 + | Var _ -> + [] + | Exn e -> + exp_fpv e + | Closure {captured_vars} -> + List.map ~f:(fun (_, pvar, _) -> pvar) captured_vars + | Const _ -> + [] + | Cast (_, e) | UnOp (_, e, _) -> + exp_fpv e + | BinOp (_, e1, e2) -> + exp_fpv e1 @ exp_fpv e2 + | Lvar name -> + [name] + | Lfield (e, _, _) -> + exp_fpv e + | Lindex (e1, e2) -> + exp_fpv e1 @ exp_fpv e2 (* TODO: Sizeof length expressions may contain variables, do not ignore them. *) - | Sizeof _ - -> [] + | Sizeof _ -> + [] + let exp_list_fpv el = List.concat_map ~f:exp_fpv el let atom_fpv = function - | Aeq (e1, e2) - -> exp_fpv e1 @ exp_fpv e2 - | Aneq (e1, e2) - -> exp_fpv e1 @ exp_fpv e2 - | Apred (_, es) | Anpred (_, es) - -> List.fold ~f:(fun fpv e -> List.rev_append (exp_fpv e) fpv) ~init:[] es + | Aeq (e1, e2) -> + exp_fpv e1 @ exp_fpv e2 + | Aneq (e1, e2) -> + exp_fpv e1 @ exp_fpv e2 + | Apred (_, es) | Anpred (_, es) -> + List.fold ~f:(fun fpv e -> List.rev_append (exp_fpv e) fpv) ~init:[] es + let rec strexp_fpv = function - | Eexp (e, _) - -> exp_fpv e - | Estruct (fld_se_list, _) - -> let f (_, se) = strexp_fpv se in + | Eexp (e, _) -> + exp_fpv e + | Estruct (fld_se_list, _) -> + let f (_, se) = strexp_fpv se in List.concat_map ~f fld_se_list - | Earray (len, idx_se_list, _) - -> let fpv_in_len = exp_fpv len in + | Earray (len, idx_se_list, _) -> + let fpv_in_len = exp_fpv len in let f (idx, se) = exp_fpv idx @ strexp_fpv se in fpv_in_len @ List.concat_map ~f idx_se_list + let rec hpred_fpv = function - | Hpointsto (base, se, te) - -> exp_fpv base @ strexp_fpv se @ exp_fpv te - | Hlseg (_, para, e1, e2, elist) - -> let fpvars_in_elist = exp_list_fpv elist in + | Hpointsto (base, se, te) -> + exp_fpv base @ strexp_fpv se @ exp_fpv te + | Hlseg (_, para, e1, e2, elist) -> + let fpvars_in_elist = exp_list_fpv elist in hpara_fpv para @ exp_fpv (* This set has to be empty. *) e1 @ exp_fpv e2 @ fpvars_in_elist - | Hdllseg (_, para, e1, e2, e3, e4, elist) - -> let fpvars_in_elist = exp_list_fpv elist in + | Hdllseg (_, para, e1, e2, e3, e4, elist) -> + let fpvars_in_elist = exp_list_fpv elist in hpara_dll_fpv para (* This set has to be empty. *) @ exp_fpv e1 @ exp_fpv e2 @ exp_fpv e3 @ exp_fpv e4 @ fpvars_in_elist + (** hpara should not contain any program variables. This is because it might cause problems when we do interprocedural analysis. In interprocedural analysis, we should consider the issue @@ -1118,6 +1174,7 @@ and hpara_fpv para = let fpvars_in_body = List.concat_map ~f:hpred_fpv para.body in match fpvars_in_body with [] -> [] | _ -> assert false + (** hpara_dll should not contain any program variables. This is because it might cause problems when we do interprocedural analysis. In interprocedural analysis, we should consider the issue @@ -1126,6 +1183,7 @@ and hpara_dll_fpv para = let fpvars_in_body = List.concat_map ~f:hpred_fpv para.body_dll in match fpvars_in_body with [] -> [] | _ -> assert false + (** {2 Functions for computing free non-program variables} *) (** Type of free variables. These include primed, normal and footprint variables. @@ -1151,6 +1209,7 @@ let fav_duplicates = ref false let ( ++ ) fav id = if !fav_duplicates || not (List.exists ~f:(Ident.equal id) !fav) then fav := id :: !fav + (** extend [fav] with ident list [idl] *) let ( +++ ) fav idl = List.iter ~f:(fun id -> fav ++ id) idl @@ -1163,6 +1222,7 @@ let fav_from_list l = let _ = List.iter ~f:(fun id -> fav ++ id) l in fav + (** Convert a [fav] to a list of identifiers while preserving the order that the identifiers were added to [fav]. *) let fav_to_list fav = List.rev !fav @@ -1179,6 +1239,7 @@ let fav_imperative_to_functional f x = let _ = f fav x in fav + (** [fav_filter_ident fav f] only keeps [id] if [f id] is true. *) let fav_filter_ident fav filter = fav := List.filter ~f:filter !fav @@ -1188,16 +1249,17 @@ let fav_copy_filter_ident fav filter = ref (List.filter ~f:filter !fav) (** checks whether every element in l1 appears l2 **) let rec ident_sorted_list_subset l1 l2 = match (l1, l2) with - | [], _ - -> true - | _ :: _, [] - -> false - | id1 :: l1, id2 :: l2 - -> let n = Ident.compare id1 id2 in + | [], _ -> + true + | _ :: _, [] -> + false + | id1 :: l1, id2 :: l2 -> + let n = Ident.compare id1 id2 in if Int.equal n 0 then ident_sorted_list_subset l1 (id2 :: l2) else if n > 0 then ident_sorted_list_subset (id1 :: l1) l2 else false + (** [fav_subset_ident fav1 fav2] returns true if every ident in [fav1] is in [fav2].*) let fav_subset_ident fav1 fav2 = ident_sorted_list_subset (fav_to_list fav1) (fav_to_list fav2) @@ -1206,27 +1268,28 @@ let fav_mem fav id = List.exists ~f:(Ident.equal id) !fav let rec exp_fav_add fav e = match (e : Exp.t) with - | Var id - -> fav ++ id - | Exn e - -> exp_fav_add fav e - | Closure {captured_vars} - -> List.iter ~f:(fun (e, _, _) -> exp_fav_add fav e) captured_vars - | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _) - -> () - | Cast (_, e) | UnOp (_, e, _) - -> exp_fav_add fav e - | BinOp (_, e1, e2) - -> exp_fav_add fav e1 ; exp_fav_add fav e2 - | Lvar _ - -> () - | Lfield (e, _, _) (* do nothing since we only count non-program variables *) - -> exp_fav_add fav e - | Lindex (e1, e2) - -> exp_fav_add fav e1 ; exp_fav_add fav e2 + | Var id -> + fav ++ id + | Exn e -> + exp_fav_add fav e + | Closure {captured_vars} -> + List.iter ~f:(fun (e, _, _) -> exp_fav_add fav e) captured_vars + | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _) -> + () + | Cast (_, e) | UnOp (_, e, _) -> + exp_fav_add fav e + | BinOp (_, e1, e2) -> + exp_fav_add fav e1 ; exp_fav_add fav e2 + | Lvar _ -> + () + | Lfield (e, _, _) (* do nothing since we only count non-program variables *) -> + exp_fav_add fav e + | Lindex (e1, e2) -> + exp_fav_add fav e1 ; exp_fav_add fav e2 (* TODO: Sizeof length expressions may contain variables, do not ignore them. *) - | Sizeof _ - -> () + | Sizeof _ -> + () + let exp_fav = fav_imperative_to_functional exp_fav_add @@ -1236,11 +1299,13 @@ let ident_in_exp id e = let fav = fav_new () in exp_fav_add fav e ; fav_mem fav id + let atom_fav_add fav = function - | Aeq (e1, e2) | Aneq (e1, e2) - -> exp_fav_add fav e1 ; exp_fav_add fav e2 - | Apred (_, es) | Anpred (_, es) - -> List.iter ~f:(fun e -> exp_fav_add fav e) es + | Aeq (e1, e2) | Aneq (e1, e2) -> + exp_fav_add fav e1 ; exp_fav_add fav e2 + | Apred (_, es) | Anpred (_, es) -> + List.iter ~f:(fun e -> exp_fav_add fav e) es + let atom_fav = fav_imperative_to_functional atom_fav_add @@ -1248,28 +1313,30 @@ let atom_fav = fav_imperative_to_functional atom_fav_add let atom_av_add = atom_fav_add let rec strexp_fav_add fav = function - | Eexp (e, _) - -> exp_fav_add fav e - | Estruct (fld_se_list, _) - -> List.iter ~f:(fun (_, se) -> strexp_fav_add fav se) fld_se_list - | Earray (len, idx_se_list, _) - -> exp_fav_add fav len ; + | Eexp (e, _) -> + exp_fav_add fav e + | Estruct (fld_se_list, _) -> + List.iter ~f:(fun (_, se) -> strexp_fav_add fav se) fld_se_list + | Earray (len, idx_se_list, _) -> + exp_fav_add fav len ; List.iter ~f:(fun (e, se) -> exp_fav_add fav e ; strexp_fav_add fav se) idx_se_list + let hpred_fav_add fav = function - | Hpointsto (base, sexp, te) - -> exp_fav_add fav base ; strexp_fav_add fav sexp ; exp_fav_add fav te - | Hlseg (_, _, e1, e2, elist) - -> exp_fav_add fav e1 ; + | Hpointsto (base, sexp, te) -> + exp_fav_add fav base ; strexp_fav_add fav sexp ; exp_fav_add fav te + | Hlseg (_, _, e1, e2, elist) -> + exp_fav_add fav e1 ; exp_fav_add fav e2 ; List.iter ~f:(exp_fav_add fav) elist - | Hdllseg (_, _, e1, e2, e3, e4, elist) - -> exp_fav_add fav e1 ; + | Hdllseg (_, _, e1, e2, e3, e4, elist) -> + exp_fav_add fav e1 ; exp_fav_add fav e2 ; exp_fav_add fav e3 ; exp_fav_add fav e4 ; List.iter ~f:(exp_fav_add fav) elist + let hpred_fav = fav_imperative_to_functional hpred_fav_add (** This function should be used before adding a new @@ -1289,8 +1356,11 @@ let array_clean_new_index footprint_part new_idx = Exp.Var id ) else new_idx + (** {2 Functions for computing all free or bound non-program variables} *) -let exp_av_add = exp_fav_add (** Expressions do not bind variables *) + +(** Expressions do not bind variables *) +let exp_av_add = exp_fav_add (** Structured expressions do not bind variables *) let strexp_av_add = strexp_fav_add @@ -1302,6 +1372,7 @@ let rec hpara_av_add fav para = fav +++ para.svars ; fav +++ para.evars + and hpara_dll_av_add fav para = List.iter ~f:(hpred_av_add fav) para.body_dll ; fav ++ para.cell ; @@ -1310,22 +1381,24 @@ and hpara_dll_av_add fav para = fav +++ para.svars_dll ; fav +++ para.evars_dll + and hpred_av_add fav = function - | Hpointsto (base, se, te) - -> exp_av_add fav base ; strexp_av_add fav se ; exp_av_add fav te - | Hlseg (_, para, e1, e2, elist) - -> hpara_av_add fav para ; + | Hpointsto (base, se, te) -> + exp_av_add fav base ; strexp_av_add fav se ; exp_av_add fav te + | Hlseg (_, para, e1, e2, elist) -> + hpara_av_add fav para ; exp_av_add fav e1 ; exp_av_add fav e2 ; List.iter ~f:(exp_av_add fav) elist - | Hdllseg (_, para, e1, e2, e3, e4, elist) - -> hpara_dll_av_add fav para ; + | Hdllseg (_, para, e1, e2, e3, e4, elist) -> + hpara_dll_av_add fav para ; exp_av_add fav e1 ; exp_av_add fav e2 ; exp_av_add fav e3 ; exp_av_add fav e4 ; List.iter ~f:(exp_av_add fav) elist + let hpara_shallow_av_add fav para = List.iter ~f:(hpred_fav_add fav) para.body ; fav ++ para.root ; @@ -1333,6 +1406,7 @@ let hpara_shallow_av_add fav para = fav +++ para.svars ; fav +++ para.evars + let hpara_dll_shallow_av_add fav para = List.iter ~f:(hpred_fav_add fav) para.body_dll ; fav ++ para.cell ; @@ -1341,6 +1415,7 @@ let hpara_dll_shallow_av_add fav para = fav +++ para.svars_dll ; fav +++ para.evars_dll + (** Variables in hpara, excluding bound vars in the body *) let hpara_shallow_av = fav_imperative_to_functional hpara_shallow_av_add @@ -1373,6 +1448,7 @@ let exp_subst_of_list sub = assert (sub_no_duplicated_ids sub') ; sub' + let subst_of_list sub = `Exp (exp_subst_of_list sub) (** like exp_subst_of_list, but allow duplicate ids and only keep the first occurrence *) @@ -1387,12 +1463,13 @@ let exp_sub_empty = exp_subst_of_list [] let sub_empty = `Exp exp_sub_empty let is_sub_empty = function - | `Exp [] - -> true - | `Exp _ - -> false - | `Typ sub - -> Typ.is_type_subst_empty sub + | `Exp [] -> + true + | `Exp _ -> + false + | `Typ sub -> + Typ.is_type_subst_empty sub + (** Join two substitutions into one. For all id in dom(sub1) cap dom(sub2), sub1(id) = sub2(id). *) @@ -1401,6 +1478,7 @@ let sub_join sub1 sub2 = assert (sub_no_duplicated_ids sub) ; sub + (** Compute the common id-exp part of two inputs [subst1] and [subst2]. The first component of the output is this common part. The second and third components are the remainder of [subst1] @@ -1408,19 +1486,20 @@ let sub_join sub1 sub2 = let sub_symmetric_difference sub1_in sub2_in = let rec diff sub_common sub1_only sub2_only sub1 sub2 = match (sub1, sub2) with - | [], _ | _, [] - -> let sub1_only' = List.rev_append sub1_only sub1 in + | [], _ | _, [] -> + let sub1_only' = List.rev_append sub1_only sub1 in let sub2_only' = List.rev_append sub2_only sub2 in let sub_common = List.rev sub_common in (sub_common, sub1_only', sub2_only') - | id_e1 :: sub1', id_e2 :: sub2' - -> let n = compare_ident_exp id_e1 id_e2 in + | id_e1 :: sub1', id_e2 :: sub2' -> + let n = compare_ident_exp id_e1 id_e2 in if Int.equal n 0 then diff (id_e1 :: sub_common) sub1_only sub2_only sub1' sub2' else if n < 0 then diff sub_common (id_e1 :: sub1_only) sub2_only sub1' sub2 else diff sub_common sub1_only (id_e2 :: sub2_only) sub1 sub2' in diff [] [] [] sub1_in sub2_in + (** [sub_find filter sub] returns the expression associated to the first identifier that satisfies [filter]. Raise [Not_found] if there isn't one. *) let sub_find filter (sub: exp_subst) = snd (List.find_exn ~f:(fun (i, _) -> filter i) sub) @@ -1442,6 +1521,7 @@ let sub_range_partition filter (sub: exp_subst) = List.partition_tf ~f:(fun (_, let sub_domain_partition filter (sub: exp_subst) = List.partition_tf ~f:(fun (i, _) -> filter i) sub + (** Return the list of identifiers in the domain of the substitution. *) let sub_domain sub = List.map ~f:fst sub @@ -1462,11 +1542,13 @@ let extend_sub sub id exp : exp_subst option = let compare (id1, _) (id2, _) = Ident.compare id1 id2 in if mem_sub id sub then None else Some (List.merge ~cmp:compare sub [(id, exp)]) + (** Free auxilary variables in the domain and range of the substitution. *) let sub_fav_add fav (sub: exp_subst) = List.iter ~f:(fun (id, e) -> fav ++ id ; exp_fav_add fav e) sub + (** Substitutions do not contain binders *) let sub_av_add = sub_fav_add @@ -1478,78 +1560,80 @@ let rec exp_sub_ids (f: subst_fun) exp = match f with | `Exp f_exp -> ( match f_exp id with - | Exp.Var id' when Ident.equal id id' - -> exp (* it will preserve physical equality when needed *) - | exp' - -> exp' ) - | _ - -> exp ) - | Lvar _ - -> exp - | Exn e - -> let e' = exp_sub_ids f e in + | Exp.Var id' when Ident.equal id id' -> + exp (* it will preserve physical equality when needed *) + | exp' -> + exp' ) + | _ -> + exp ) + | Lvar _ -> + exp + | Exn e -> + let e' = exp_sub_ids f e in if phys_equal e' e then exp else Exp.Exn e' - | Closure c - -> let captured_vars = + | Closure c -> + let captured_vars = IList.map_changed - (fun (e, pvar, typ as captured) -> + (fun ((e, pvar, typ) as captured) -> let e' = exp_sub_ids f e in let typ' = f_typ typ in if phys_equal e' e && phys_equal typ typ' then captured else (e', pvar, typ')) c.captured_vars in if phys_equal captured_vars c.captured_vars then exp else Exp.Closure {c with captured_vars} - | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _) - -> exp - | Cast (t, e) - -> let e' = exp_sub_ids f e in + | Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _) -> + exp + | Cast (t, e) -> + let e' = exp_sub_ids f e in let t' = f_typ t in if phys_equal e' e && phys_equal t' t then exp else Exp.Cast (t', e') - | UnOp (op, e, typ_opt) - -> let e' = exp_sub_ids f e in + | UnOp (op, e, typ_opt) -> + let e' = exp_sub_ids f e in let typ_opt' = match typ_opt with - | Some t - -> let t' = f_typ t in + | Some t -> + let t' = f_typ t in if phys_equal t t' then typ_opt else Some t' - | None - -> typ_opt + | None -> + typ_opt in if phys_equal e' e && phys_equal typ_opt typ_opt' then exp else Exp.UnOp (op, e', typ_opt') - | BinOp (op, e1, e2) - -> let e1' = exp_sub_ids f e1 in + | BinOp (op, e1, e2) -> + let e1' = exp_sub_ids f e1 in let e2' = exp_sub_ids f e2 in if phys_equal e1' e1 && phys_equal e2' e2 then exp else Exp.BinOp (op, e1', e2') - | Lfield (e, fld, typ) - -> let e' = exp_sub_ids f e in + | Lfield (e, fld, typ) -> + let e' = exp_sub_ids f e in let typ' = f_typ typ in let fld' = Typ.Fieldname.class_name_replace ~f:f_tname fld in if phys_equal e' e && phys_equal typ typ' && phys_equal fld fld' then exp else Exp.Lfield (e', fld', typ') - | Lindex (e1, e2) - -> let e1' = exp_sub_ids f e1 in + | Lindex (e1, e2) -> + let e1' = exp_sub_ids f e1 in let e2' = exp_sub_ids f e2 in if phys_equal e1' e1 && phys_equal e2' e2 then exp else Exp.Lindex (e1', e2') - | Sizeof ({typ; dynamic_length= Some l; subtype} as sizeof_data) - -> let l' = exp_sub_ids f l in + | Sizeof ({typ; dynamic_length= Some l; subtype} as sizeof_data) -> + let l' = exp_sub_ids f l in let typ' = f_typ typ in let subtype' = Subtype.sub_type f_tname subtype in if phys_equal l' l && phys_equal typ typ' && phys_equal subtype subtype' then exp else Exp.Sizeof {sizeof_data with typ= typ'; dynamic_length= Some l'; subtype= subtype'} - | Sizeof ({typ; dynamic_length= None; subtype} as sizeof_data) - -> let typ' = f_typ typ in + | Sizeof ({typ; dynamic_length= None; subtype} as sizeof_data) -> + let typ' = f_typ typ in let subtype' = Subtype.sub_type f_tname subtype in if phys_equal typ typ' then exp else Exp.Sizeof {sizeof_data with typ= typ'; subtype= subtype'} + let apply_sub subst : subst_fun = match subst with - | `Exp l - -> `Exp + | `Exp l -> + `Exp (fun id -> match List.Assoc.find l ~equal:Ident.equal id with Some x -> x | None -> Exp.Var id) - | `Typ typ_subst - -> `Typ (Typ.sub_type typ_subst, Typ.sub_tname typ_subst) + | `Typ typ_subst -> + `Typ (Typ.sub_type typ_subst, Typ.sub_tname typ_subst) + let exp_sub (subst: subst) e = exp_sub_ids (apply_sub subst) e @@ -1560,35 +1644,35 @@ let instr_sub_ids ~sub_id_binders f instr = in let sub_typ x = match f with `Exp _ -> x | `Typ (f, _) -> f x in match instr with - | Load (id, rhs_exp, typ, loc) - -> let id' = if sub_id_binders then sub_id id else id in + | Load (id, rhs_exp, typ, loc) -> + let id' = if sub_id_binders then sub_id id else id in let rhs_exp' = exp_sub_ids f rhs_exp in let typ' = sub_typ typ in if phys_equal id' id && phys_equal rhs_exp' rhs_exp && phys_equal typ typ' then instr else Load (id', rhs_exp', typ', loc) - | Store (lhs_exp, typ, rhs_exp, loc) - -> let lhs_exp' = exp_sub_ids f lhs_exp in + | Store (lhs_exp, typ, rhs_exp, loc) -> + let lhs_exp' = exp_sub_ids f lhs_exp in let typ' = sub_typ typ in let rhs_exp' = exp_sub_ids f rhs_exp in if phys_equal lhs_exp' lhs_exp && phys_equal typ typ' && phys_equal rhs_exp' rhs_exp then instr else Store (lhs_exp', typ', rhs_exp', loc) - | Call (ret_id, fun_exp, actuals, call_flags, loc) - -> let ret_id' = + | Call (ret_id, fun_exp, actuals, call_flags, loc) -> + let ret_id' = if sub_id_binders then match ret_id with - | Some (id, typ) - -> let id' = sub_id id in + | Some (id, typ) -> + let id' = sub_id id in let typ' = sub_typ typ in if Ident.equal id id' && phys_equal typ typ' then ret_id else Some (id', typ') - | None - -> None + | None -> + None else ret_id in let fun_exp' = exp_sub_ids f fun_exp in let actuals' = IList.map_changed - (fun (actual, typ as actual_pair) -> + (fun ((actual, typ) as actual_pair) -> let actual' = exp_sub_ids f actual in let typ' = sub_typ typ in if phys_equal actual' actual && phys_equal typ typ' then actual_pair @@ -1598,23 +1682,24 @@ let instr_sub_ids ~sub_id_binders f instr = if phys_equal ret_id' ret_id && phys_equal fun_exp' fun_exp && phys_equal actuals' actuals then instr else Call (ret_id', fun_exp', actuals', call_flags, loc) - | Prune (exp, loc, true_branch, if_kind) - -> let exp' = exp_sub_ids f exp in + | Prune (exp, loc, true_branch, if_kind) -> + let exp' = exp_sub_ids f exp in if phys_equal exp' exp then instr else Prune (exp', loc, true_branch, if_kind) - | Remove_temps (ids, loc) - -> let ids' = IList.map_changed sub_id ids in + | Remove_temps (ids, loc) -> + let ids' = IList.map_changed sub_id ids in if phys_equal ids' ids then instr else Remove_temps (ids', loc) - | Declare_locals (locals, loc) - -> let locals' = + | Declare_locals (locals, loc) -> + let locals' = IList.map_changed - (fun (name, typ as local_var) -> + (fun ((name, typ) as local_var) -> let typ' = sub_typ typ in if phys_equal typ typ' then local_var else (name, typ')) locals in if phys_equal locals locals' then instr else Declare_locals (locals', loc) - | Nullify _ | Abstract _ - -> instr + | Nullify _ | Abstract _ -> + instr + (** apply [subst] to all id's in [instr], including binder id's *) let instr_sub (subst: subst) instr = instr_sub_ids ~sub_id_binders:true (apply_sub subst) instr @@ -1632,42 +1717,44 @@ let rec exp_compare_structural e1 e2 exp_map = (0, Exp.Map.add e1 e2 exp_map) in match ((e1 : Exp.t), (e2 : Exp.t)) with - | Var _, Var _ - -> compare_exps_with_map e1 e2 exp_map - | UnOp (o1, e1, to1), UnOp (o2, e2, to2) - -> let n = Unop.compare o1 o2 in + | Var _, Var _ -> + compare_exps_with_map e1 e2 exp_map + | UnOp (o1, e1, to1), UnOp (o2, e2, to2) -> + let n = Unop.compare o1 o2 in if n <> 0 then (n, exp_map) else let n, exp_map = exp_compare_structural e1 e2 exp_map in ((if n <> 0 then n else [%compare : Typ.t option] to1 to2), exp_map) - | BinOp (o1, e1, f1), BinOp (o2, e2, f2) - -> let n = Binop.compare o1 o2 in + | BinOp (o1, e1, f1), BinOp (o2, e2, f2) -> + let n = Binop.compare o1 o2 in if n <> 0 then (n, exp_map) else let n, exp_map = exp_compare_structural e1 e2 exp_map in if n <> 0 then (n, exp_map) else exp_compare_structural f1 f2 exp_map - | Cast (t1, e1), Cast (t2, e2) - -> let n, exp_map = exp_compare_structural e1 e2 exp_map in + | Cast (t1, e1), Cast (t2, e2) -> + let n, exp_map = exp_compare_structural e1 e2 exp_map in ((if n <> 0 then n else Typ.compare t1 t2), exp_map) - | Lvar _, Lvar _ - -> compare_exps_with_map e1 e2 exp_map - | Lfield (e1, f1, t1), Lfield (e2, f2, t2) - -> let n, exp_map = exp_compare_structural e1 e2 exp_map in + | Lvar _, Lvar _ -> + compare_exps_with_map e1 e2 exp_map + | Lfield (e1, f1, t1), Lfield (e2, f2, t2) -> + let n, exp_map = exp_compare_structural e1 e2 exp_map in ( ( if n <> 0 then n else let n = Typ.Fieldname.compare f1 f2 in if n <> 0 then n else Typ.compare t1 t2 ) , exp_map ) - | Lindex (e1, f1), Lindex (e2, f2) - -> let n, exp_map = exp_compare_structural e1 e2 exp_map in + | Lindex (e1, f1), Lindex (e2, f2) -> + let n, exp_map = exp_compare_structural e1 e2 exp_map in if n <> 0 then (n, exp_map) else exp_compare_structural f1 f2 exp_map - | _ - -> (Exp.compare e1 e2, exp_map) + | _ -> + (Exp.compare e1 e2, exp_map) + let exp_typ_compare_structural (e1, t1) (e2, t2) exp_map = let n, exp_map = exp_compare_structural e1 e2 exp_map in ((if n <> 0 then n else Typ.compare t1 t2), exp_map) + (** compare instructions from different procedures without considering loc's, ident's, and pvar's. the [exp_map] param gives a mapping of names used in the procedure of [instr1] to identifiers used in the procedure of [instr2] *) @@ -1678,14 +1765,14 @@ let compare_structural_instr instr1 instr2 exp_map = if n <> 0 then (n, exp_map) else (Typ.compare typ1 typ2, exp_map) in match (id_typ1, id_typ2) with - | Some it1, Some it2 - -> id_typ_compare_structural it1 it2 - | None, None - -> (0, exp_map) - | None, _ - -> (-1, exp_map) - | _, None - -> (1, exp_map) + | Some it1, Some it2 -> + id_typ_compare_structural it1 it2 + | None, None -> + (0, exp_map) + | None, _ -> + (-1, exp_map) + | _, None -> + (1, exp_map) in let id_list_compare_structural ids1 ids2 exp_map = let n = Int.compare (List.length ids1) (List.length ids2) in @@ -1697,27 +1784,27 @@ let compare_structural_instr instr1 instr2 exp_map = ~init:(0, exp_map) ids1 ids2 in match (instr1, instr2) with - | Load (id1, e1, t1, _), Load (id2, e2, t2, _) - -> let n, exp_map = exp_compare_structural (Var id1) (Var id2) exp_map in + | Load (id1, e1, t1, _), Load (id2, e2, t2, _) -> + let n, exp_map = exp_compare_structural (Var id1) (Var id2) exp_map in if n <> 0 then (n, exp_map) else let n, exp_map = exp_compare_structural e1 e2 exp_map in ((if n <> 0 then n else Typ.compare t1 t2), exp_map) - | Store (e11, t1, e21, _), Store (e12, t2, e22, _) - -> let n, exp_map = exp_compare_structural e11 e12 exp_map in + | Store (e11, t1, e21, _), Store (e12, t2, e22, _) -> + let n, exp_map = exp_compare_structural e11 e12 exp_map in if n <> 0 then (n, exp_map) else let n = Typ.compare t1 t2 in if n <> 0 then (n, exp_map) else exp_compare_structural e21 e22 exp_map - | Prune (cond1, _, true_branch1, ik1), Prune (cond2, _, true_branch2, ik2) - -> let n, exp_map = exp_compare_structural cond1 cond2 exp_map in + | Prune (cond1, _, true_branch1, ik1), Prune (cond2, _, true_branch2, ik2) -> + let n, exp_map = exp_compare_structural cond1 cond2 exp_map in ( ( if n <> 0 then n else let n = Bool.compare true_branch1 true_branch2 in if n <> 0 then n else compare_if_kind ik1 ik2 ) , exp_map ) - | Call (ret_id1, e1, arg_ts1, _, cf1), Call (ret_id2, e2, arg_ts2, _, cf2) - -> let args_compare_structural args1 args2 exp_map = + | Call (ret_id1, e1, arg_ts1, _, cf1), Call (ret_id2, e2, arg_ts2, _, cf2) -> + let args_compare_structural args1 args2 exp_map = let n = Int.compare (List.length args1) (List.length args2) in if n <> 0 then (n, exp_map) else @@ -1734,14 +1821,14 @@ let compare_structural_instr instr1 instr2 exp_map = else let n, exp_map = args_compare_structural arg_ts1 arg_ts2 exp_map in ((if n <> 0 then n else CallFlags.compare cf1 cf2), exp_map) - | Nullify (pvar1, _), Nullify (pvar2, _) - -> exp_compare_structural (Lvar pvar1) (Lvar pvar2) exp_map - | Abstract _, Abstract _ - -> (0, exp_map) - | Remove_temps (temps1, _), Remove_temps (temps2, _) - -> id_list_compare_structural temps1 temps2 exp_map - | Declare_locals (ptl1, _), Declare_locals (ptl2, _) - -> let n = Int.compare (List.length ptl1) (List.length ptl2) in + | Nullify (pvar1, _), Nullify (pvar2, _) -> + exp_compare_structural (Lvar pvar1) (Lvar pvar2) exp_map + | Abstract _, Abstract _ -> + (0, exp_map) + | Remove_temps (temps1, _), Remove_temps (temps2, _) -> + id_list_compare_structural temps1 temps2 exp_map + | Declare_locals (ptl1, _), Declare_locals (ptl2, _) -> + let n = Int.compare (List.length ptl1) (List.length ptl2) in if n <> 0 then (n, exp_map) else List.fold2_exn @@ -1751,8 +1838,9 @@ let compare_structural_instr instr1 instr2 exp_map = let n, exp_map = exp_compare_structural (Lvar pv1) (Lvar pv2) exp_map in if n <> 0 then (n, exp_map) else (Typ.compare t1 t2, exp_map)) ~init:(0, exp_map) ptl1 ptl2 - | _ - -> (compare_instr instr1 instr2, exp_map) + | _ -> + (compare_instr instr1 instr2, exp_map) + let atom_sub subst = atom_expmap (exp_sub subst) @@ -1760,70 +1848,74 @@ let hpred_sub subst = let f (e, inst_opt) = (exp_sub subst e, inst_opt) in hpred_expmap f + (** {2 Functions for replacing occurrences of expressions.} *) let rec exp_replace_exp epairs e = (* First we check if there is an exact match *) match List.find ~f:(fun (e1, _) -> Exp.equal e e1) epairs with - | Some (_, e2) - -> e2 + | Some (_, e2) -> + e2 | None -> (* If e is a compound expression, we need to check for its subexpressions as well *) match e with - | Exp.UnOp (op, e0, ty) - -> let e0' = exp_replace_exp epairs e0 in + | Exp.UnOp (op, e0, ty) -> + let e0' = exp_replace_exp epairs e0 in if phys_equal e0 e0' then e else Exp.UnOp (op, e0', ty) - | Exp.BinOp (op, lhs, rhs) - -> let lhs' = exp_replace_exp epairs lhs in + | Exp.BinOp (op, lhs, rhs) -> + let lhs' = exp_replace_exp epairs lhs in let rhs' = exp_replace_exp epairs rhs in if phys_equal lhs lhs' && phys_equal rhs rhs' then e else Exp.BinOp (op, lhs', rhs') - | Exp.Cast (ty, e0) - -> let e0' = exp_replace_exp epairs e0 in + | Exp.Cast (ty, e0) -> + let e0' = exp_replace_exp epairs e0 in if phys_equal e0 e0' then e else Exp.Cast (ty, e0') - | Exp.Lfield (e0, fname, ty) - -> let e0' = exp_replace_exp epairs e0 in + | Exp.Lfield (e0, fname, ty) -> + let e0' = exp_replace_exp epairs e0 in if phys_equal e0 e0' then e else Exp.Lfield (e0', fname, ty) - | Exp.Lindex (base, index) - -> let base' = exp_replace_exp epairs base in + | Exp.Lindex (base, index) -> + let base' = exp_replace_exp epairs base in let index' = exp_replace_exp epairs index in if phys_equal base base' && phys_equal index index' then e else Exp.Lindex (base', index') - | _ - -> e + | _ -> + e + let atom_replace_exp epairs atom = atom_expmap (fun e -> exp_replace_exp epairs e) atom let rec strexp_replace_exp epairs = function - | Eexp (e, inst) - -> Eexp (exp_replace_exp epairs e, inst) - | Estruct (fsel, inst) - -> let f (fld, se) = (fld, strexp_replace_exp epairs se) in + | Eexp (e, inst) -> + Eexp (exp_replace_exp epairs e, inst) + | Estruct (fsel, inst) -> + let f (fld, se) = (fld, strexp_replace_exp epairs se) in Estruct (List.map ~f fsel, inst) - | Earray (len, isel, inst) - -> let len' = exp_replace_exp epairs len in + | Earray (len, isel, inst) -> + let len' = exp_replace_exp epairs len in let f (idx, se) = let idx' = exp_replace_exp epairs idx in (idx', strexp_replace_exp epairs se) in Earray (len', List.map ~f isel, inst) + let hpred_replace_exp epairs = function - | Hpointsto (root, se, te) - -> let root_repl = exp_replace_exp epairs root in + | Hpointsto (root, se, te) -> + let root_repl = exp_replace_exp epairs root in let strexp_repl = strexp_replace_exp epairs se in let te_repl = exp_replace_exp epairs te in Hpointsto (root_repl, strexp_repl, te_repl) - | Hlseg (k, para, root, next, shared) - -> let root_repl = exp_replace_exp epairs root in + | Hlseg (k, para, root, next, shared) -> + let root_repl = exp_replace_exp epairs root in let next_repl = exp_replace_exp epairs next in let shared_repl = List.map ~f:(exp_replace_exp epairs) shared in Hlseg (k, para, root_repl, next_repl, shared_repl) - | Hdllseg (k, para, e1, e2, e3, e4, shared) - -> let e1' = exp_replace_exp epairs e1 in + | Hdllseg (k, para, e1, e2, e3, e4, shared) -> + let e1' = exp_replace_exp epairs e1 in let e2' = exp_replace_exp epairs e2 in let e3' = exp_replace_exp epairs e3 in let e4' = exp_replace_exp epairs e4 in let shared_repl = List.map ~f:(exp_replace_exp epairs) shared in Hdllseg (k, para, e1', e2', e3', e4', shared_repl) + (** {2 Compaction} *) module HpredInstHash = Hashtbl.Make (struct type t = hpred @@ -1843,33 +1935,38 @@ let exp_compact sh e = try Exp.Hash.find sh.exph e with Not_found -> Exp.Hash.add sh.exph e e ; e + let rec sexp_compact sh se = match se with - | Eexp (e, inst) - -> Eexp (exp_compact sh e, inst) - | Estruct (fsel, inst) - -> Estruct (List.map ~f:(fun (f, se) -> (f, sexp_compact sh se)) fsel, inst) - | Earray _ - -> se + | Eexp (e, inst) -> + Eexp (exp_compact sh e, inst) + | Estruct (fsel, inst) -> + Estruct (List.map ~f:(fun (f, se) -> (f, sexp_compact sh se)) fsel, inst) + | Earray _ -> + se + (** Return a compact representation of the hpred *) let _hpred_compact sh hpred = match hpred with - | Hpointsto (e1, se, e2) - -> let e1' = exp_compact sh e1 in + | Hpointsto (e1, se, e2) -> + let e1' = exp_compact sh e1 in let e2' = exp_compact sh e2 in let se' = sexp_compact sh se in Hpointsto (e1', se', e2') - | Hlseg _ - -> hpred - | Hdllseg _ - -> hpred + | Hlseg _ -> + hpred + | Hdllseg _ -> + hpred + let hpred_compact sh hpred = try HpredInstHash.find sh.hpredh hpred with Not_found -> let hpred' = _hpred_compact sh hpred in - HpredInstHash.add sh.hpredh hpred' hpred' ; hpred' + HpredInstHash.add sh.hpredh hpred' hpred' ; + hpred' + (** {2 Functions for constructing or destructing entities in this module} *) @@ -1884,45 +1981,47 @@ let exp_get_offsets exp = | Exn _ | Closure _ | Lvar _ - | Sizeof {dynamic_length= None} - -> offlist_past - | Sizeof {dynamic_length= Some l} - -> f offlist_past l - | Cast (_, sub_exp) - -> f offlist_past sub_exp - | Lfield (sub_exp, fldname, typ) - -> f (Off_fld (fldname, typ) :: offlist_past) sub_exp - | Lindex (sub_exp, e) - -> f (Off_index e :: offlist_past) sub_exp + | Sizeof {dynamic_length= None} -> + offlist_past + | Sizeof {dynamic_length= Some l} -> + f offlist_past l + | Cast (_, sub_exp) -> + f offlist_past sub_exp + | Lfield (sub_exp, fldname, typ) -> + f (Off_fld (fldname, typ) :: offlist_past) sub_exp + | Lindex (sub_exp, e) -> + f (Off_index e :: offlist_past) sub_exp in f [] exp + let exp_add_offsets exp offsets = let rec f acc = function - | [] - -> acc - | (Off_fld (fld, typ)) :: offs' - -> f (Exp.Lfield (acc, fld, typ)) offs' - | (Off_index e) :: offs' - -> f (Exp.Lindex (acc, e)) offs' + | [] -> + acc + | (Off_fld (fld, typ)) :: offs' -> + f (Exp.Lfield (acc, fld, typ)) offs' + | (Off_index e) :: offs' -> + f (Exp.Lindex (acc, e)) offs' in f exp offsets + (** Convert all the lseg's in sigma to nonempty lsegs. *) let sigma_to_sigma_ne sigma : (atom list * hpred list) list = if Config.nelseg then let f eqs_sigma_list hpred = match hpred with - | Hpointsto _ | Hlseg (Lseg_NE, _, _, _, _) | Hdllseg (Lseg_NE, _, _, _, _, _, _) - -> let g (eqs, sigma) = (eqs, hpred :: sigma) in + | Hpointsto _ | Hlseg (Lseg_NE, _, _, _, _) | Hdllseg (Lseg_NE, _, _, _, _, _, _) -> + let g (eqs, sigma) = (eqs, hpred :: sigma) in List.map ~f:g eqs_sigma_list - | Hlseg (Lseg_PE, para, e1, e2, el) - -> let g (eqs, sigma) = + | Hlseg (Lseg_PE, para, e1, e2, el) -> + let g (eqs, sigma) = [(Aeq (e1, e2) :: eqs, sigma); (eqs, Hlseg (Lseg_NE, para, e1, e2, el) :: sigma)] in List.concat_map ~f:g eqs_sigma_list - | Hdllseg (Lseg_PE, para_dll, e1, e2, e3, e4, el) - -> let g (eqs, sigma) = + | Hdllseg (Lseg_PE, para_dll, e1, e2, e3, e4, el) -> + let g (eqs, sigma) = [ (Aeq (e1, e3) :: Aeq (e2, e4) :: eqs, sigma) ; (eqs, Hdllseg (Lseg_NE, para_dll, e1, e2, e3, e4, el) :: sigma) ] in @@ -1931,6 +2030,7 @@ let sigma_to_sigma_ne sigma : (atom list * hpred list) list = List.fold ~f ~init:[([], [])] sigma else [([], sigma)] + (** [hpara_instantiate para e1 e2 elist] instantiates [para] with [e1], [e2] and [elist]. If [para = lambda (x, y, xs). exists zs. b], then the result of the instantiation is [b\[e1 / x, e2 / y, elist / xs, _zs'/ zs\]] @@ -1956,6 +2056,7 @@ let hpara_instantiate para e1 e2 elist = in (ids_evars, List.map ~f:(hpred_sub subst) para.body) + (** [hpara_dll_instantiate para cell blink flink elist] instantiates [para] with [cell], [blink], [flink], and [elist]. If [para = lambda (x, y, z, xs). exists zs. b], then the result of the instantiation is @@ -1984,4 +2085,5 @@ let hpara_dll_instantiate (para: hpara_dll) cell blink flink elist = in (ids_evars, List.map ~f:(hpred_sub subst) para.body_dll) + let custom_error = Pvar.mk_global (Mangled.from_string "INFER_CUSTOM_ERROR") Pvar.TUExtern diff --git a/infer/src/IR/Subtype.ml b/infer/src/IR/Subtype.ml index 0ad625525..327d11dbf 100644 --- a/infer/src/IR/Subtype.ml +++ b/infer/src/IR/Subtype.ml @@ -18,6 +18,7 @@ let list_to_string list = if Int.equal (List.length list) 0 then "( sub )" else "- {" ^ String.concat ~sep:", " (List.map ~f:Typ.Name.name list) ^ "}" + type t' = | Exact (** denotes the current type only *) | Subtypes of Typ.Name.t list @@ -39,27 +40,30 @@ let equal_result = [%compare.equal : result] let sub_type tname_subst st_pair = let st, kind = st_pair in match st with - | Subtypes tnames - -> let tnames' = IList.map_changed tname_subst tnames in + | Subtypes tnames -> + let tnames' = IList.map_changed tname_subst tnames in if phys_equal tnames tnames' then st_pair else (Subtypes tnames', kind) - | Exact - -> st_pair + | Exact -> + st_pair + let max_result res1 res2 = if compare_result res1 res2 <= 0 then res2 else res1 let is_interface tenv (class_name: Typ.Name.t) = match (class_name, Tenv.lookup tenv class_name) with - | JavaClass _, Some {fields= []; methods= []} - -> true - | _ - -> false + | JavaClass _, Some {fields= []; methods= []} -> + true + | _ -> + false + let is_root_class class_name = match class_name with - | Typ.JavaClass _ - -> Typ.Name.equal class_name Typ.Name.Java.java_lang_object - | _ - -> false + | Typ.JavaClass _ -> + Typ.Name.equal class_name Typ.Name.Java.java_lang_object + | _ -> + false + (** check if c1 is a subclass of c2 *) let check_subclass_tenv tenv c1 c2 : result = @@ -69,23 +73,24 @@ let check_subclass_tenv tenv c1 c2 : result = if equal_result best_result Yes then Yes else match classnames with - | [] - -> best_result - | cn :: cns - -> loop (max_result best_result (check cn)) cns + | [] -> + best_result + | cn :: cns -> + loop (max_result best_result (check cn)) cns and check cn : result = if Typ.Name.equal cn c2 then Yes else match Tenv.lookup tenv cn with - | None when is_root_class cn - -> No - | None - -> Unknown - | Some {supers} - -> loop No supers + | None when is_root_class cn -> + No + | None -> + Unknown + | Some {supers} -> + loop No supers in if is_root_class c2 then Yes else check c1 + module SubtypesMap = Caml.Map.Make (struct (* pair of subtypes *) type t = Typ.Name.t * Typ.Name.t [@@deriving compare] @@ -101,6 +106,7 @@ let check_subtype = is_subt : result ) + let is_known_subtype tenv c1 c2 : bool = equal_result (check_subtype tenv c1 c2) Yes let is_known_not_subtype tenv c1 c2 : bool = equal_result (check_subtype tenv c1 c2) No @@ -110,10 +116,11 @@ let flag_to_string flag = match flag with CAST -> "(cast)" | INSTOF -> "(instof) let pp f (t, flag) = if Config.print_types then match t with - | Exact - -> F.fprintf f "%s" (flag_to_string flag) - | Subtypes list - -> F.fprintf f "%s" (list_to_string list ^ flag_to_string flag) + | Exact -> + F.fprintf f "%s" (flag_to_string flag) + | Subtypes list -> + F.fprintf f "%s" (list_to_string list ^ flag_to_string flag) + let exact = (Exact, NORMAL) @@ -133,56 +140,63 @@ let list_intersect equal l1 l2 = let in_l2 a = List.mem ~equal l2 a in List.filter ~f:in_l2 l1 + let join_flag flag1 flag2 = match (flag1, flag2) with CAST, _ -> CAST | _, CAST -> CAST | _, _ -> NORMAL + let join (s1, flag1) (s2, flag2) = let s = match (s1, s2) with - | Exact, _ - -> s2 - | _, Exact - -> s1 - | Subtypes l1, Subtypes l2 - -> Subtypes (list_intersect Typ.Name.equal l1 l2) + | Exact, _ -> + s2 + | _, Exact -> + s1 + | Subtypes l1, Subtypes l2 -> + Subtypes (list_intersect Typ.Name.equal l1 l2) in let flag = join_flag flag1 flag2 in (s, flag) + let update_flag c1 c2 flag flag' = match flag with INSTOF -> if Typ.Name.equal c1 c2 then flag else flag' | _ -> flag' + let change_flag st_opt c1 c2 flag' = match st_opt with | Some st -> ( match st with - | Exact, flag - -> let new_flag = update_flag c1 c2 flag flag' in + | Exact, flag -> + let new_flag = update_flag c1 c2 flag flag' in Some (Exact, new_flag) - | Subtypes t, flag - -> let new_flag = update_flag c1 c2 flag flag' in + | Subtypes t, flag -> + let new_flag = update_flag c1 c2 flag flag' in Some (Subtypes t, new_flag) ) - | None - -> None + | None -> + None + let normalize_subtypes t_opt c1 c2 flag1 flag2 = let new_flag = update_flag c1 c2 flag1 flag2 in match t_opt with | Some t -> ( match t with - | Exact - -> Some (t, new_flag) - | Subtypes l - -> Some (Subtypes (List.sort ~cmp:Typ.Name.compare l), new_flag) ) - | None - -> None + | Exact -> + Some (t, new_flag) + | Subtypes l -> + Some (Subtypes (List.sort ~cmp:Typ.Name.compare l), new_flag) ) + | None -> + None + let subtypes_to_string t = match fst t with - | Exact - -> "ex" ^ flag_to_string (snd t) - | Subtypes l - -> list_to_string l ^ flag_to_string (snd t) + | Exact -> + "ex" ^ flag_to_string (snd t) + | Subtypes l -> + list_to_string l ^ flag_to_string (snd t) + (* c is a subtype when it does not appear in the list l of no-subtypes *) let no_subtype_in_list tenv c l = not (List.exists ~f:(is_known_subtype tenv c) l) @@ -204,21 +218,23 @@ let check_redundancies tenv c l = in List.fold ~f:aux ~init:([], true) l + let rec updates_head f c l = match l with - | [] - -> [] - | ci :: rest - -> if is_strict_subtype f ci c then ci :: updates_head f c rest else updates_head f c rest + | [] -> + [] + | ci :: rest -> + if is_strict_subtype f ci c then ci :: updates_head f c rest else updates_head f c rest + (* adds the classes of l2 to l1 and checks that no redundancies or inconsistencies will occur A - { X1,..., Xn } is inconsistent if A <: Xi for some i *) let rec add_not_subtype tenv c1 l1 l2 = match l2 with - | [] - -> l1 - | c :: rest - -> if is_known_subtype tenv c1 c then add_not_subtype tenv c1 l1 rest + | [] -> + l1 + | c :: rest -> + if is_known_subtype tenv c1 c then add_not_subtype tenv c1 l1 rest else (* checks for inconsistencies *) let l1', should_add = check_redundancies tenv c l1 in @@ -226,23 +242,24 @@ let rec add_not_subtype tenv c1 l1 l2 = let rest' = add_not_subtype tenv c1 l1' rest in if should_add then c :: rest' else rest' + let get_subtypes tenv (c1, ((st1, flag1): t)) (c2, ((st2, flag2): t)) = let is_sub = is_known_subtype tenv c1 c2 in let pos_st, neg_st = match (st1, st2) with - | Exact, Exact - -> if is_sub then (Some st1, None) else (None, Some st1) - | Exact, Subtypes l2 - -> if is_sub && no_subtype_in_list tenv c1 l2 then (Some st1, None) else (None, Some st1) - | Subtypes l1, Exact - -> if is_sub then (Some st1, None) + | Exact, Exact -> + if is_sub then (Some st1, None) else (None, Some st1) + | Exact, Subtypes l2 -> + if is_sub && no_subtype_in_list tenv c1 l2 then (Some st1, None) else (None, Some st1) + | Subtypes l1, Exact -> + if is_sub then (Some st1, None) else let l1' = updates_head tenv c2 l1 in if no_subtype_in_list tenv c2 l1 then (Some (Subtypes l1'), Some (Subtypes (add_not_subtype tenv c1 l1 [c2]))) else (None, Some st1) - | Subtypes l1, Subtypes l2 - -> if is_interface tenv c2 || is_sub then + | Subtypes l1, Subtypes l2 -> + if is_interface tenv c2 || is_sub then if no_subtype_in_list tenv c1 l2 then let l2' = updates_head tenv c1 l2 in (Some (Subtypes (add_not_subtype tenv c1 l1 l2')), None) @@ -257,19 +274,21 @@ let get_subtypes tenv (c1, ((st1, flag1): t)) (c2, ((st2, flag2): t)) = in (normalize_subtypes pos_st c1 c2 flag1 flag2, normalize_subtypes neg_st c1 c2 flag1 flag2) + let case_analysis_basic tenv (c1, st) (c2, (_, flag2)) = let pos_st, neg_st = if is_known_subtype tenv c1 c2 then (Some st, None) else if is_known_subtype tenv c2 c1 then match st with - | Exact, _ - -> if Typ.Name.equal c1 c2 then (Some st, None) else (None, Some st) - | Subtypes _, _ - -> if Typ.Name.equal c1 c2 then (Some st, None) else (Some st, Some st) + | Exact, _ -> + if Typ.Name.equal c1 c2 then (Some st, None) else (None, Some st) + | Subtypes _, _ -> + if Typ.Name.equal c1 c2 then (Some st, None) else (Some st, Some st) else (None, Some st) in (change_flag pos_st c1 c2 flag2, change_flag neg_st c1 c2 flag2) + (** [case_analysis (c1, st1) (c2, st2) f] performs case analysis on [c1 <: c2] according to [st1] and [st2] where f c1 c2 is true if c1 is a subtype of c2. @@ -280,3 +299,4 @@ let case_analysis_basic tenv (c1, st) (c2, (_, flag2)) = let case_analysis tenv (c1, st1) (c2, st2) = if Config.subtype_multirange then get_subtypes tenv (c1, st1) (c2, st2) else case_analysis_basic tenv (c1, st1) (c2, st2) + diff --git a/infer/src/IR/Tenv.ml b/infer/src/IR/Tenv.ml index 1085dabef..8f465cf58 100644 --- a/infer/src/IR/Tenv.ml +++ b/infer/src/IR/Tenv.ml @@ -34,6 +34,7 @@ let pp fmt (tenv: t) = Format.fprintf fmt "@[<6>TYPE: %a@." (Typ.Struct.pp Pp.text name) typ) tenv + (** Create a new type environment. *) let create () = TypenameHash.create 1000 @@ -42,7 +43,9 @@ let mk_struct tenv ?default ?fields ?statics ?methods ?supers ?annots name = let struct_typ = Typ.Struct.internal_mk_struct ?default ?fields ?statics ?methods ?supers ?annots () in - TypenameHash.replace tenv name struct_typ ; struct_typ + TypenameHash.replace tenv name struct_typ ; + struct_typ + (** Check if typename is found in tenv *) let mem tenv name = TypenameHash.mem tenv name @@ -59,8 +62,9 @@ let lookup tenv name : Typ.Struct.t option = | CppClass (m, NoTemplate) -> ( try Some (TypenameHash.find tenv (CStruct m)) with Not_found -> None ) - | _ - -> None + | _ -> + None + (** Add a (name,type) pair to the global type environment. *) let add tenv name struct_typ = TypenameHash.replace tenv name struct_typ @@ -77,15 +81,17 @@ let sort_fields_tenv tenv = in iter sort_fields_struct tenv + (** Add a field to a given struct in the global type environment. *) let add_field tenv class_tn_name field = match lookup tenv class_tn_name with - | Some ({fields} as struct_typ) - -> if not (List.mem ~equal:equal_fields fields field) then + | Some ({fields} as struct_typ) -> + if not (List.mem ~equal:equal_fields fields field) then let new_fields = List.merge [field] fields ~cmp:compare_fields in ignore (mk_struct tenv ~default:struct_typ ~fields:new_fields ~statics:[] class_tn_name) - | _ - -> () + | _ -> + () + (** Get method that is being overriden by java_pname (if any) **) let get_overriden_method tenv pname_java = @@ -103,21 +109,23 @@ let get_overriden_method tenv pname_java = Some (struct_typ_get_method_by_name struct_typ (Typ.Procname.java_get_method pname_java)) with Not_found -> get_overriden_method_in_supers pname_java (supers_tail @ struct_typ.supers) ) - | None - -> get_overriden_method_in_supers pname_java supers_tail ) - | [] - -> None + | None -> + get_overriden_method_in_supers pname_java supers_tail ) + | [] -> + None in match lookup tenv (Typ.Procname.java_get_class_type_name pname_java) with - | Some {supers} - -> get_overriden_method_in_supers pname_java supers - | _ - -> None + | Some {supers} -> + get_overriden_method_in_supers pname_java supers + | _ -> + None + (** Serializer for type environments *) let tenv_serializer : t Serialization.serializer = Serialization.create_serializer Serialization.Key.tenv + let global_tenv : t option ref = ref None (** Load a type environment from a file *) @@ -128,6 +136,7 @@ let load_from_file (filename: DB.filename) : t option = !global_tenv ) else Serialization.read_from_file tenv_serializer filename + (** Save a type environment into a file *) let store_to_file (filename: DB.filename) (tenv: t) = (* update in-memory global tenv for later uses by this process, e.g. in single-core mode the @@ -140,13 +149,15 @@ let store_to_file (filename: DB.filename) (tenv: t) = let fmt = Format.formatter_of_out_channel out_channel in Format.fprintf fmt "%a" pp tenv ; Out_channel.close out_channel + exception Found of Typ.Name.t let language_is tenv lang = match TypenameHash.iter (fun n -> raise (Found n)) tenv with - | () - -> false - | exception Found JavaClass _ - -> Config.equal_language lang Java - | exception Found _ - -> Config.equal_language lang Clang + | () -> + false + | exception Found JavaClass _ -> + Config.equal_language lang Java + | exception Found _ -> + Config.equal_language lang Clang + diff --git a/infer/src/IR/Typ.ml b/infer/src/IR/Typ.ml index 8ae3d56c9..438fdff2d 100644 --- a/infer/src/IR/Typ.ml +++ b/infer/src/IR/Typ.ml @@ -34,42 +34,44 @@ type ikind = [@@deriving compare] let ikind_to_string = function - | IChar - -> "char" - | ISChar - -> "signed char" - | IUChar - -> "unsigned char" - | IBool - -> "_Bool" - | IInt - -> "int" - | IUInt - -> "unsigned int" - | IShort - -> "short" - | IUShort - -> "unsigned short" - | ILong - -> "long" - | IULong - -> "unsigned long" - | ILongLong - -> "long long" - | IULongLong - -> "unsigned long long" - | I128 - -> "__int128_t" - | IU128 - -> "__uint128_t" + | IChar -> + "char" + | ISChar -> + "signed char" + | IUChar -> + "unsigned char" + | IBool -> + "_Bool" + | IInt -> + "int" + | IUInt -> + "unsigned int" + | IShort -> + "short" + | IUShort -> + "unsigned short" + | ILong -> + "long" + | IULong -> + "unsigned long" + | ILongLong -> + "long long" + | IULongLong -> + "unsigned long long" + | I128 -> + "__int128_t" + | IU128 -> + "__uint128_t" + let ikind_is_char = function IChar | ISChar | IUChar -> true | _ -> false let ikind_is_unsigned = function - | IUChar | IUInt | IUShort | IULong | IULongLong - -> true - | _ - -> false + | IUChar | IUInt | IUShort | IULong | IULongLong -> + true + | _ -> + false + let int_of_int64_kind i ik = IntLit.of_int64_unsigned i (ikind_is_unsigned ik) @@ -81,12 +83,13 @@ type fkind = [@@deriving compare] let fkind_to_string = function - | FFloat - -> "float" - | FDouble - -> "double" - | FLongDouble - -> "long double" + | FFloat -> + "float" + | FDouble -> + "double" + | FLongDouble -> + "long double" + (** kind of pointer *) type ptr_kind = @@ -100,16 +103,17 @@ type ptr_kind = let equal_ptr_kind = [%compare.equal : ptr_kind] let ptr_kind_string = function - | Pk_reference - -> "&" - | Pk_pointer - -> "*" - | Pk_objc_weak - -> "__weak *" - | Pk_objc_unsafe_unretained - -> "__unsafe_unretained *" - | Pk_objc_autoreleasing - -> "__autoreleasing *" + | Pk_reference -> + "&" + | Pk_pointer -> + "*" + | Pk_objc_weak -> + "__weak *" + | Pk_objc_unsafe_unretained -> + "__unsafe_unretained *" + | Pk_objc_autoreleasing -> + "__autoreleasing *" + module T = struct type type_quals = {is_const: bool; is_restrict: bool; is_volatile: bool} [@@deriving compare] @@ -170,6 +174,7 @@ let mk_type_quals ?default ?is_const ?is_restrict ?is_volatile () = in mk_aux ?default ?is_const ?is_restrict ?is_volatile () + let is_const {is_const} = is_const let is_restrict {is_restrict} = is_restrict @@ -181,11 +186,13 @@ let mk ?default ?quals desc : t = let mk_aux ?(default= default_) ?(quals= default.quals) desc = {desc; quals} in mk_aux ?default ?quals desc + let merge_quals quals1 quals2 = { is_const= quals1.is_const || quals2.is_const ; is_restrict= quals1.is_restrict || quals2.is_restrict ; is_volatile= quals1.is_volatile || quals2.is_volatile } + let escape pe = if Pp.equal_print_kind pe.Pp.kind Pp.HTML then Escape.escape_xml else ident (** Pretty print a type with all the details, using the C syntax. *) @@ -197,56 +204,59 @@ let rec pp_full pe f typ = in let pp_desc f {desc} = match desc with - | Tstruct tname - -> F.fprintf f "%a" (pp_name_c_syntax pe) tname - | TVar name - -> F.fprintf f "%s" name - | Tint ik - -> F.fprintf f "%s" (ikind_to_string ik) - | Tfloat fk - -> F.fprintf f "%s" (fkind_to_string fk) - | Tvoid - -> F.fprintf f "void" - | Tfun false - -> F.fprintf f "_fn_" - | Tfun true - -> F.fprintf f "_fn_noreturn_" - | Tptr (({desc= Tarray _ | Tfun _} as typ), pk) - -> F.fprintf f "%a(%s)" (pp_full pe) typ (ptr_kind_string pk |> escape pe) - | Tptr (typ, pk) - -> F.fprintf f "%a%s" (pp_full pe) typ (ptr_kind_string pk |> escape pe) - | Tarray (typ, static_len, static_stride) - -> let pp_int_opt fmt = function Some x -> IntLit.pp fmt x | None -> F.fprintf fmt "_" in + | Tstruct tname -> + F.fprintf f "%a" (pp_name_c_syntax pe) tname + | TVar name -> + F.fprintf f "%s" name + | Tint ik -> + F.fprintf f "%s" (ikind_to_string ik) + | Tfloat fk -> + F.fprintf f "%s" (fkind_to_string fk) + | Tvoid -> + F.fprintf f "void" + | Tfun false -> + F.fprintf f "_fn_" + | Tfun true -> + F.fprintf f "_fn_noreturn_" + | Tptr (({desc= Tarray _ | Tfun _} as typ), pk) -> + F.fprintf f "%a(%s)" (pp_full pe) typ (ptr_kind_string pk |> escape pe) + | Tptr (typ, pk) -> + F.fprintf f "%a%s" (pp_full pe) typ (ptr_kind_string pk |> escape pe) + | Tarray (typ, static_len, static_stride) -> + let pp_int_opt fmt = function Some x -> IntLit.pp fmt x | None -> F.fprintf fmt "_" in F.fprintf f "%a[%a*%a]" (pp_full pe) typ pp_int_opt static_len pp_int_opt static_stride in F.fprintf f "%a%a" pp_desc typ pp_quals typ + and pp_name_c_syntax pe f = function - | CStruct name | CUnion name | ObjcClass name | ObjcProtocol name - -> F.fprintf f "%a" QualifiedCppName.pp name - | CppClass (name, template_spec) - -> F.fprintf f "%a%a" QualifiedCppName.pp name (pp_template_spec_info pe) template_spec - | JavaClass name - -> F.fprintf f "%a" Mangled.pp name + | CStruct name | CUnion name | ObjcClass name | ObjcProtocol name -> + F.fprintf f "%a" QualifiedCppName.pp name + | CppClass (name, template_spec) -> + F.fprintf f "%a%a" QualifiedCppName.pp name (pp_template_spec_info pe) template_spec + | JavaClass name -> + F.fprintf f "%a" Mangled.pp name + and pp_template_spec_info pe f = function - | NoTemplate - -> () - | Template {args} - -> let pp_arg_opt f = function - | TType typ - -> pp_full pe f typ - | TInt i - -> Int64.pp f i - | TNull - -> Pp.string f "null" - | TNullPtr - -> Pp.string f "NullPtr" - | TOpaque - -> Pp.string f "Opaque" + | NoTemplate -> + () + | Template {args} -> + let pp_arg_opt f = function + | TType typ -> + pp_full pe f typ + | TInt i -> + Int64.pp f i + | TNull -> + Pp.string f "null" + | TNullPtr -> + Pp.string f "NullPtr" + | TOpaque -> + Pp.string f "Opaque" in F.fprintf f "%s%a%s" (escape pe "<") (Pp.comma_seq pp_arg_opt) args (escape pe ">") + (** Pretty print a type. Do nothing by default. *) let pp pe f te = if Config.print_types then pp_full pe f te else () @@ -254,6 +264,7 @@ let to_string typ = let pp fmt = pp_full Pp.text fmt typ in F.asprintf "%t" pp + type type_subst_t = (string * t) list [@@deriving compare] let is_type_subst_empty = List.is_empty @@ -263,39 +274,41 @@ let rec sub_type subst generic_typ : t = match generic_typ.desc with | TVar tname -> ( match List.Assoc.find subst ~equal:String.equal tname with - | Some t - -> (* Type qualifiers may come from original type or be part of substitution. Merge them *) + | Some t -> + (* Type qualifiers may come from original type or be part of substitution. Merge them *) mk ~quals:(merge_quals t.quals generic_typ.quals) t.desc - | None - -> generic_typ ) - | Tarray (typ, arg1, arg2) - -> let typ' = sub_type subst typ in + | None -> + generic_typ ) + | Tarray (typ, arg1, arg2) -> + let typ' = sub_type subst typ in if phys_equal typ typ' then generic_typ else mk ~default:generic_typ (Tarray (typ', arg1, arg2)) - | Tptr (typ, arg) - -> let typ' = sub_type subst typ in + | Tptr (typ, arg) -> + let typ' = sub_type subst typ in if phys_equal typ typ' then generic_typ else mk ~default:generic_typ (Tptr (typ', arg)) - | Tstruct tname - -> let tname' = sub_tname subst tname in + | Tstruct tname -> + let tname' = sub_tname subst tname in if phys_equal tname tname' then generic_typ else mk ~default:generic_typ (Tstruct tname') - | _ - -> generic_typ + | _ -> + generic_typ + and sub_tname subst tname = match tname with - | CppClass (name, Template {mangled; args}) - -> let sub_typ_opt typ_opt = + | CppClass (name, Template {mangled; args}) -> + let sub_typ_opt typ_opt = match typ_opt with - | TType typ - -> let typ' = sub_type subst typ in + | TType typ -> + let typ' = sub_type subst typ in if phys_equal typ typ' then typ_opt else TType typ' - | TInt _ | TNull | TNullPtr | TOpaque - -> typ_opt + | TInt _ | TNull | TNullPtr | TOpaque -> + typ_opt in let args' = IList.map_changed sub_typ_opt args in if phys_equal args args' then tname else CppClass (name, Template {mangled; args= args'}) - | _ - -> tname + | _ -> + tname + module Name = struct type t = name [@@deriving compare] @@ -303,42 +316,46 @@ module Name = struct let equal = [%compare.equal : t] let qual_name = function - | CStruct name | CUnion name | ObjcClass name | ObjcProtocol name - -> name - | CppClass (name, templ_args) - -> let template_suffix = F.asprintf "%a" (pp_template_spec_info Pp.text) templ_args in + | CStruct name | CUnion name | ObjcClass name | ObjcProtocol name -> + name + | CppClass (name, templ_args) -> + let template_suffix = F.asprintf "%a" (pp_template_spec_info Pp.text) templ_args in QualifiedCppName.append_template_args_to_last name ~args:template_suffix - | JavaClass _ - -> QualifiedCppName.empty + | JavaClass _ -> + QualifiedCppName.empty + let unqualified_name = function - | CStruct name | CUnion name | ObjcClass name | ObjcProtocol name - -> name - | CppClass (name, _) - -> name - | JavaClass _ - -> QualifiedCppName.empty + | CStruct name | CUnion name | ObjcClass name | ObjcProtocol name -> + name + | CppClass (name, _) -> + name + | JavaClass _ -> + QualifiedCppName.empty + let name n = match n with - | CStruct _ | CUnion _ | CppClass _ | ObjcClass _ | ObjcProtocol _ - -> qual_name n |> QualifiedCppName.to_qual_string - | JavaClass name - -> Mangled.to_string name + | CStruct _ | CUnion _ | CppClass _ | ObjcClass _ | ObjcProtocol _ -> + qual_name n |> QualifiedCppName.to_qual_string + | JavaClass name -> + Mangled.to_string name + let pp fmt tname = let prefix = function - | CStruct _ - -> "struct" - | CUnion _ - -> "union" - | CppClass _ | JavaClass _ | ObjcClass _ - -> "class" - | ObjcProtocol _ - -> "protocol" + | CStruct _ -> + "struct" + | CUnion _ -> + "union" + | CppClass _ | JavaClass _ | ObjcClass _ -> + "class" + | ObjcProtocol _ -> + "protocol" in F.fprintf fmt "%s %a" (prefix tname) (pp_name_c_syntax Pp.text) tname + let to_string = F.asprintf "%a" pp let is_class = function CppClass _ | JavaClass _ | ObjcClass _ -> true | _ -> false @@ -350,10 +367,11 @@ module Name = struct | CppClass _, CppClass _ | JavaClass _, JavaClass _ | ObjcClass _, ObjcClass _ - | ObjcProtocol _, ObjcProtocol _ - -> true - | _ - -> false + | ObjcProtocol _, ObjcProtocol _ -> + true + | _ -> + false + module C = struct let from_qual_name qual_name = CStruct qual_name @@ -370,6 +388,7 @@ module Name = struct if String.equal package_name "" then from_string class_name else from_string (package_name ^ "." ^ class_name) + let is_class = function JavaClass _ -> true | _ -> false let java_lang_object = from_string "java.lang.Object" @@ -416,12 +435,13 @@ let d_list (tl: t list) = L.add_print_action (L.PTtyp_list, Obj.repr tl) let name typ = match typ.desc with Tstruct name -> Some name | _ -> None let unsome s = function - | Some default_typ - -> default_typ - | None - -> L.internal_error "No default typ in %s@." s ; + | Some default_typ -> + default_typ + | None -> + L.internal_error "No default typ in %s@." s ; assert false + (** turn a *T into a T. fails if [typ] is not a pointer type *) let strip_ptr typ = match typ.desc with Tptr (t, _) -> t | _ -> assert false @@ -430,9 +450,11 @@ let strip_ptr typ = match typ.desc with Tptr (t, _) -> t | _ -> assert false let array_elem default_opt typ = match typ.desc with Tarray (t_el, _, _) -> t_el | _ -> unsome "array_elem" default_opt + let is_class_of_kind check_fun typ = match typ.desc with Tstruct tname -> check_fun tname | _ -> false + let is_objc_class = is_class_of_kind Name.Objc.is_class let is_cpp_class = is_class_of_kind Name.Cpp.is_class @@ -442,43 +464,46 @@ let is_java_class = is_class_of_kind Name.Java.is_class let rec is_array_of_cpp_class typ = match typ.desc with Tarray (typ, _, _) -> is_array_of_cpp_class typ | _ -> is_cpp_class typ + let is_pointer_to_cpp_class typ = match typ.desc with Tptr (t, _) -> is_cpp_class t | _ -> false let has_block_prefix s = match Str.split_delim (Str.regexp_string Config.anonymous_block_prefix) s with - | _ :: _ :: _ - -> true - | _ - -> false + | _ :: _ :: _ -> + true + | _ -> + false + (** Check if type is a type for a block in objc *) let is_block_type typ = has_block_prefix (to_string typ) (** Java types by name *) let rec java_from_string : string -> t = function - | "" | "void" - -> mk Tvoid - | "int" - -> mk (Tint IInt) - | "byte" - -> mk (Tint IShort) - | "short" - -> mk (Tint IShort) - | "boolean" - -> mk (Tint IBool) - | "char" - -> mk (Tint IChar) - | "long" - -> mk (Tint ILong) - | "float" - -> mk (Tfloat FFloat) - | "double" - -> mk (Tfloat FDouble) - | typ_str when String.contains typ_str '[' - -> let stripped_typ = String.sub typ_str ~pos:0 ~len:(String.length typ_str - 2) in + | "" | "void" -> + mk Tvoid + | "int" -> + mk (Tint IInt) + | "byte" -> + mk (Tint IShort) + | "short" -> + mk (Tint IShort) + | "boolean" -> + mk (Tint IBool) + | "char" -> + mk (Tint IChar) + | "long" -> + mk (Tint ILong) + | "float" -> + mk (Tfloat FFloat) + | "double" -> + mk (Tfloat FDouble) + | typ_str when String.contains typ_str '[' -> + let stripped_typ = String.sub typ_str ~pos:0 ~len:(String.length typ_str - 2) in mk (Tptr (mk (Tarray (java_from_string stripped_typ, None, None)), Pk_pointer)) - | typ_str - -> mk (Tstruct (Name.Java.from_string typ_str)) + | typ_str -> + mk (Tstruct (Name.Java.from_string typ_str)) + type typ = t @@ -557,6 +582,7 @@ module Procname = struct let objc_method_kind_of_bool is_instance = if is_instance then ObjCInstanceMethod else ObjCClassMethod + let empty_block = Block "" let is_verbose v = match v with Verbose -> true | _ -> false @@ -564,42 +590,47 @@ module Procname = struct (** A type is a pair (package, type_name) that is translated in a string package.type_name *) let java_type_to_string_verbosity p verbosity = match p with - | None, typ - -> typ - | Some p, cls - -> if is_verbose verbosity then p ^ "." ^ cls else cls + | None, typ -> + typ + | Some p, cls -> + if is_verbose verbosity then p ^ "." ^ cls else cls + let java_type_to_string p = java_type_to_string_verbosity p Verbose (** Given a list of types, it creates a unique string of types separated by commas *) let rec java_param_list_to_string inputList verbosity = match inputList with - | [] - -> "" - | [head] - -> java_type_to_string_verbosity head verbosity - | head :: rest - -> java_type_to_string_verbosity head verbosity ^ "," + | [] -> + "" + | [head] -> + java_type_to_string_verbosity head verbosity + | head :: rest -> + java_type_to_string_verbosity head verbosity ^ "," ^ java_param_list_to_string rest verbosity + (** It is the same as java_type_to_string, but Java return types are optional because of constructors without type *) let java_return_type_to_string j verbosity = match j.return_type with None -> "" | Some typ -> java_type_to_string_verbosity typ verbosity + (** Given a package.class_name string, it looks for the latest dot and split the string in two (package, class_name) *) let split_classname package_classname = match String.rsplit2 package_classname ~on:'.' with - | Some (x, y) - -> (Some x, y) - | None - -> (None, package_classname) + | Some (x, y) -> + (Some x, y) + | None -> + (None, package_classname) + let split_typename typename = split_classname (Name.name typename) let c name mangled template_args ~is_generic_model = {name; mangled= Some mangled; template_args; is_generic_model} + let from_string_c_fun (name: string) = C { name= QualifiedCppName.of_qual_string name @@ -607,13 +638,16 @@ module Procname = struct ; template_args= NoTemplate ; is_generic_model= false } + let java class_name return_type method_name parameters kind = {class_name; return_type; method_name; parameters; kind} + (** Create an objc procedure name from a class_name and method_name. *) let objc_cpp class_name method_name kind template_args ~is_generic_model = {class_name; method_name; kind; template_args; is_generic_model} + (** Create an objc procedure name from a class_name and method_name. *) let mangled_objc_block name = Block name @@ -627,19 +661,21 @@ module Procname = struct In case of Java, replace package and class name. *) let replace_class t (new_class: Name.t) = match t with - | Java j - -> Java {j with class_name= new_class} - | ObjC_Cpp osig - -> ObjC_Cpp {osig with class_name= new_class} - | C _ | Block _ | Linters_dummy_method - -> t + | Java j -> + Java {j with class_name= new_class} + | ObjC_Cpp osig -> + ObjC_Cpp {osig with class_name= new_class} + | C _ | Block _ | Linters_dummy_method -> + t + let objc_cpp_replace_method_name t (new_method_name: string) = match t with - | ObjC_Cpp osig - -> ObjC_Cpp {osig with method_name= new_method_name} - | C _ | Block _ | Linters_dummy_method | Java _ - -> t + | ObjC_Cpp osig -> + ObjC_Cpp {osig with method_name= new_method_name} + | C _ | Block _ | Linters_dummy_method | Java _ -> + t + (** Get the class name of a Objective-C/C++ procedure name. *) let objc_cpp_get_class_name objc_cpp = Name.name objc_cpp.class_name @@ -672,29 +708,31 @@ module Procname = struct (** Return the method/function of a procname. *) let get_method = function - | ObjC_Cpp name - -> name.method_name - | C {name} - -> QualifiedCppName.to_qual_string name - | Block name - -> name - | Java j - -> j.method_name - | Linters_dummy_method - -> "Linters_dummy_method" + | ObjC_Cpp name -> + name.method_name + | C {name} -> + QualifiedCppName.to_qual_string name + | Block name -> + name + | Java j -> + j.method_name + | Linters_dummy_method -> + "Linters_dummy_method" + (** Return the language of the procedure. *) let get_language = function - | ObjC_Cpp _ - -> Config.Clang - | C _ - -> Config.Clang - | Block _ - -> Config.Clang - | Linters_dummy_method - -> Config.Clang - | Java _ - -> Config.Java + | ObjC_Cpp _ -> + Config.Clang + | C _ -> + Config.Clang + | Block _ -> + Config.Clang + | Linters_dummy_method -> + Config.Clang + | Java _ -> + Config.Java + (** Return the return type of a java procname. *) let java_get_return_type (j: java) = java_return_type_to_string j Verbose @@ -706,26 +744,29 @@ module Procname = struct let java_get_parameters_as_strings j = List.map ~f:(fun param -> java_type_to_string param) j.parameters + (** Return true if the java procedure is static *) let java_is_static = function Java j -> equal_method_kind j.kind Static | _ -> false let java_is_lambda = function - | Java j - -> String.is_prefix ~prefix:"lambda$" j.method_name - | _ - -> false + | Java j -> + String.is_prefix ~prefix:"lambda$" j.method_name + | _ -> + false + let java_is_generated = function - | Java j - -> String.is_prefix ~prefix:"$" j.method_name - | _ - -> false + | Java j -> + String.is_prefix ~prefix:"$" j.method_name + | _ -> + false + (** Prints a string of a java procname with the given level of verbosity *) let java_to_string ?(withclass= false) (j: java) verbosity = match verbosity with - | Verbose | Non_verbose - -> (* if verbose, then package.class.method(params): rtype, + | Verbose | Non_verbose -> + (* if verbose, then package.class.method(params): rtype, else rtype package.class.method(params) verbose is used for example to create unique filenames, non_verbose to create reports *) let return_type = java_return_type_to_string j verbosity in @@ -737,8 +778,8 @@ module Procname = struct let output = class_name ^ "." ^ j.method_name ^ "(" ^ params ^ ")" in if equal_detail_level verbosity Verbose then output ^ separator ^ return_type else return_type ^ separator ^ output - | Simple - -> (* methodname(...) or without ... if there are no parameters *) + | Simple -> + (* methodname(...) or without ... if there are no parameters *) let cls_prefix = if withclass then java_type_to_string_verbosity (split_typename j.class_name) verbosity ^ "." @@ -751,27 +792,30 @@ module Procname = struct in method_name ^ "(" ^ params ^ ")" + (** Check if the class name is for an anonymous inner class. *) let is_anonymous_inner_class_name class_name = let class_name_no_package = snd (split_typename class_name) in match String.rsplit2 class_name_no_package ~on:'$' with - | Some (_, s) - -> let is_int = + | Some (_, s) -> + let is_int = try ignore (int_of_string (String.strip s)) ; true with Failure _ -> false in is_int - | None - -> false + | None -> + false + (** Check if the procedure belongs to an anonymous inner class. *) let java_is_anonymous_inner_class = function - | Java j - -> is_anonymous_inner_class_name j.class_name - | _ - -> false + | Java j -> + is_anonymous_inner_class_name j.class_name + | _ -> + false + (** Check if the last parameter is a hidden inner class, and remove it if present. This is used in private constructors, where a proxy constructor is generated @@ -779,187 +823,205 @@ module Procname = struct let java_remove_hidden_inner_class_parameter = function | Java js -> ( match List.rev js.parameters with - | (_, s) :: par' - -> if is_anonymous_inner_class_name (Name.Java.from_string s) then + | (_, s) :: par' -> + if is_anonymous_inner_class_name (Name.Java.from_string s) then Some (Java {js with parameters= List.rev par'}) else None - | [] - -> None ) - | _ - -> None + | [] -> + None ) + | _ -> + None + (** Check if the procedure name is an anonymous inner class constructor. *) let java_is_anonymous_inner_class_constructor = function - | Java js - -> is_anonymous_inner_class_name js.class_name - | _ - -> false + | Java js -> + is_anonymous_inner_class_name js.class_name + | _ -> + false + (** Check if the procedure name is an acess method (e.g. access$100 used to access private members from a nested class. *) let java_is_access_method = function | Java js -> ( match String.rsplit2 js.method_name ~on:'$' with - | Some ("access", s) - -> let is_int = + | Some ("access", s) -> + let is_int = try ignore (int_of_string s) ; true with Failure _ -> false in is_int - | _ - -> false ) - | _ - -> false + | _ -> + false ) + | _ -> + false + (** Check if the procedure name is of an auto-generated method containing '$'. *) let java_is_autogen_method = function - | Java js - -> String.contains js.method_name '$' - | _ - -> false + | Java js -> + String.contains js.method_name '$' + | _ -> + false + (** Check if the proc name has the type of a java vararg. Note: currently only checks that the last argument has type Object[]. *) let java_is_vararg = function | Java js -> ( match List.rev js.parameters with (_, "java.lang.Object[]") :: _ -> true | _ -> false ) - | _ - -> false + | _ -> + false + let is_objc_constructor method_name = String.equal method_name "new" || String.is_prefix ~prefix:"init" method_name + let is_objc_kind = function - | ObjCClassMethod | ObjCInstanceMethod | ObjCInternalMethod - -> true - | _ - -> false + | ObjCClassMethod | ObjCInstanceMethod | ObjCInternalMethod -> + true + | _ -> + false + (** [is_constructor pname] returns true if [pname] is a constructor *) let is_constructor = function - | Java js - -> String.equal js.method_name "" - | ObjC_Cpp {kind= CPPConstructor _} - -> true - | ObjC_Cpp {kind; method_name} when is_objc_kind kind - -> is_objc_constructor method_name - | _ - -> false + | Java js -> + String.equal js.method_name "" + | ObjC_Cpp {kind= CPPConstructor _} -> + true + | ObjC_Cpp {kind; method_name} when is_objc_kind kind -> + is_objc_constructor method_name + | _ -> + false + let is_objc_dealloc method_name = String.equal method_name "dealloc" (** [is_dealloc pname] returns true if [pname] is the dealloc method in Objective-C *) let is_destructor = function - | ObjC_Cpp {kind= CPPDestructor _} - -> true - | ObjC_Cpp name - -> is_objc_dealloc name.method_name - | _ - -> false + | ObjC_Cpp {kind= CPPDestructor _} -> + true + | ObjC_Cpp name -> + is_objc_dealloc name.method_name + | _ -> + false + let java_is_close = function Java js -> String.equal js.method_name "close" | _ -> false (** [is_class_initializer pname] returns true if [pname] is a class initializer *) let is_class_initializer = function - | Java js - -> String.equal js.method_name "" - | _ - -> false + | Java js -> + String.equal js.method_name "" + | _ -> + false + (** [is_infer_undefined pn] returns true if [pn] is a special Infer undefined proc *) let is_infer_undefined pn = match pn with - | Java j - -> let regexp = Str.regexp "com.facebook.infer.builtins.InferUndefined" in + | Java j -> + let regexp = Str.regexp "com.facebook.infer.builtins.InferUndefined" in Str.string_match regexp (java_get_class_name j) 0 - | _ - -> (* TODO: add cases for obj-c, c, c++ *) + | _ -> + (* TODO: add cases for obj-c, c, c++ *) false + let get_global_name_of_initializer = function | C {name} when String.is_prefix ~prefix:Config.clang_initializer_prefix - (QualifiedCppName.to_qual_string name) - -> let name_str = QualifiedCppName.to_qual_string name in + (QualifiedCppName.to_qual_string name) -> + let name_str = QualifiedCppName.to_qual_string name in let prefix_len = String.length Config.clang_initializer_prefix in Some (String.sub name_str ~pos:prefix_len ~len:(String.length name_str - prefix_len)) - | _ - -> None + | _ -> + None + (** to_string for C_function type *) let to_readable_string (c1, c2) verbose = let plain = QualifiedCppName.to_qual_string c1 in if verbose then match c2 with None -> plain | Some s -> plain ^ "{" ^ s ^ "}" else plain + let c_method_kind_verbose_str kind = match kind with - | CPPMethod m | CPPDestructor m - -> "(" ^ (match m with None -> "" | Some s -> s) ^ ")" - | CPPConstructor (m, is_constexpr) - -> "{" ^ (match m with None -> "" | Some s -> s) ^ (if is_constexpr then "|constexpr" else "") + | CPPMethod m | CPPDestructor m -> + "(" ^ (match m with None -> "" | Some s -> s) ^ ")" + | CPPConstructor (m, is_constexpr) -> + "{" ^ (match m with None -> "" | Some s -> s) ^ (if is_constexpr then "|constexpr" else "") ^ "}" - | ObjCClassMethod - -> "class" - | ObjCInstanceMethod - -> "instance" - | ObjCInternalMethod - -> "internal" + | ObjCClassMethod -> + "class" + | ObjCInstanceMethod -> + "instance" + | ObjCInternalMethod -> + "internal" + let c_method_to_string osig detail_level = match detail_level with - | Simple - -> osig.method_name - | Non_verbose - -> Name.name osig.class_name ^ "_" ^ osig.method_name - | Verbose - -> let m_str = c_method_kind_verbose_str osig.kind in + | Simple -> + osig.method_name + | Non_verbose -> + Name.name osig.class_name ^ "_" ^ osig.method_name + | Verbose -> + let m_str = c_method_kind_verbose_str osig.kind in Name.name osig.class_name ^ "_" ^ osig.method_name ^ m_str + (** Very verbose representation of an existing Procname.t *) let to_unique_id pn = match pn with - | Java j - -> java_to_string j Verbose - | C {name; mangled} - -> to_readable_string (name, mangled) true - | ObjC_Cpp osig - -> c_method_to_string osig Verbose - | Block name - -> name - | Linters_dummy_method - -> "Linters_dummy_method" + | Java j -> + java_to_string j Verbose + | C {name; mangled} -> + to_readable_string (name, mangled) true + | ObjC_Cpp osig -> + c_method_to_string osig Verbose + | Block name -> + name + | Linters_dummy_method -> + "Linters_dummy_method" + (** Convert a proc name to a string for the user to see *) let to_string p = match p with - | Java j - -> java_to_string j Non_verbose - | C {name; mangled} - -> to_readable_string (name, mangled) false - | ObjC_Cpp osig - -> c_method_to_string osig Non_verbose - | Block name - -> name - | Linters_dummy_method - -> to_unique_id p + | Java j -> + java_to_string j Non_verbose + | C {name; mangled} -> + to_readable_string (name, mangled) false + | ObjC_Cpp osig -> + c_method_to_string osig Non_verbose + | Block name -> + name + | Linters_dummy_method -> + to_unique_id p + let sexp_of_t p = Sexp.Atom (to_string p) (** Convenient representation of a procname for external tools (e.g. eclipse plugin) *) let to_simplified_string ?(withclass= false) p = match p with - | Java j - -> java_to_string ~withclass j Simple - | C {name; mangled} - -> to_readable_string (name, mangled) false ^ "()" - | ObjC_Cpp osig - -> c_method_to_string osig Simple - | Block _ - -> "block" - | Linters_dummy_method - -> to_unique_id p + | Java j -> + java_to_string ~withclass j Simple + | C {name; mangled} -> + to_readable_string (name, mangled) false ^ "()" + | ObjC_Cpp osig -> + c_method_to_string osig Simple + | Block _ -> + "block" + | Linters_dummy_method -> + to_unique_id p + (** Pretty print a proc name *) let pp f pn = F.fprintf f "%s" (to_string pn) @@ -1000,13 +1062,14 @@ module Procname = struct let get_qualifiers pname = match pname with - | C {name} - -> name - | ObjC_Cpp objc_cpp - -> objc_cpp_get_class_qualifiers objc_cpp + | C {name} -> + name + | ObjC_Cpp objc_cpp -> + objc_cpp_get_class_qualifiers objc_cpp |> QualifiedCppName.append_qualifier ~qual:objc_cpp.method_name - | _ - -> QualifiedCppName.empty + | _ -> + QualifiedCppName.empty + (** Convert a proc name to a filename *) let to_concrete_filename ?crc_only pname = @@ -1016,15 +1079,16 @@ module Procname = struct in let proc_id = match pname with - | C {mangled} - -> get_qual_name_str pname :: Option.to_list mangled |> String.concat ~sep:"#" - | ObjC_Cpp objc_cpp - -> get_qual_name_str pname ^ "#" ^ c_method_kind_verbose_str objc_cpp.kind - | _ - -> to_unique_id pname + | C {mangled} -> + get_qual_name_str pname :: Option.to_list mangled |> String.concat ~sep:"#" + | ObjC_Cpp objc_cpp -> + get_qual_name_str pname ^ "#" ^ c_method_kind_verbose_str objc_cpp.kind + | _ -> + to_unique_id pname in Escape.escape_filename @@ DB.append_crc_cutoff ?crc_only proc_id + let to_generic_filename ?crc_only pname = let proc_id = get_qualifiers pname |> QualifiedCppName.strip_template_args |> QualifiedCppName.to_rev_list @@ -1032,12 +1096,14 @@ module Procname = struct in Escape.escape_filename @@ DB.append_crc_cutoff ?crc_only proc_id + let to_filename ?crc_only pname = match pname with - | (C {is_generic_model} | ObjC_Cpp {is_generic_model}) when Bool.equal is_generic_model true - -> to_generic_filename ?crc_only pname - | _ - -> to_concrete_filename ?crc_only pname + | (C {is_generic_model} | ObjC_Cpp {is_generic_model}) when Bool.equal is_generic_model true -> + to_generic_filename ?crc_only pname + | _ -> + to_concrete_filename ?crc_only pname + (** given two template arguments, try to generate mapping from generic ones to concrete ones. *) let get_template_args_mapping generic_procname concrete_procname = @@ -1054,25 +1120,25 @@ module Procname = struct ctyp -> match (gtyp, ctyp) with - | TType {desc= TVar name}, TType concrete - -> (name, concrete) :: result - | _ - -> result )) + | TType {desc= TVar name}, TType concrete -> + (name, concrete) :: result + | _ -> + result )) with Invalid_argument _ -> `Invalid (* fold2_exn throws on length mismatch, we need to handle it *) ) - | NoTemplate, NoTemplate - -> `NoTemplate - | _ - -> `Invalid + | NoTemplate, NoTemplate -> + `NoTemplate + | _ -> + `Invalid in let combine_mappings mapping1 mapping2 = match (mapping1, mapping2) with - | `Valid m1, `Valid m2 - -> `Valid (List.append m1 m2) - | `NoTemplate, a | a, `NoTemplate - -> a - (* no template is no-op state, simply return the other state *) | _ - -> `Invalid + | `Valid m1, `Valid m2 -> + `Valid (List.append m1 m2) + | `NoTemplate, a | a, `NoTemplate -> + a + (* no template is no-op state, simply return the other state *) | _ -> + `Invalid (* otherwise there is no valid mapping *) in let extract_mapping = function `Invalid | `NoTemplate -> None | `Valid m -> Some m in @@ -1081,17 +1147,18 @@ module Procname = struct (* TODO we should look at procedure names *) in match (generic_procname, concrete_procname) with - | C {template_args= args1}, C {template_args= args2} (* template function *) - -> mapping_for_template_args (empty_qual, args1) (empty_qual, args2) |> extract_mapping + | C {template_args= args1}, C {template_args= args2} (* template function *) -> + mapping_for_template_args (empty_qual, args1) (empty_qual, args2) |> extract_mapping | ( ObjC_Cpp {template_args= args1; class_name= CppClass (name1, class_args1)} , ObjC_Cpp {template_args= args2; class_name= CppClass (name2, class_args2)} - (* template methods/template classes/both *) ) - -> combine_mappings + (* template methods/template classes/both *) ) -> + combine_mappings (mapping_for_template_args (name1, class_args1) (name2, class_args2)) (mapping_for_template_args (empty_qual, args1) (empty_qual, args2)) |> extract_mapping - | _ - -> None + | _ -> + None + end (** Return the return type of [pname_java]. *) @@ -1099,6 +1166,7 @@ let java_proc_return_typ pname_java : t = let typ = java_from_string (Procname.java_get_return_type pname_java) in match typ.desc with Tstruct _ -> mk (Tptr (typ, Pk_pointer)) | _ -> typ + module Fieldname = struct type clang_field_info = {class_name: Name.t; field_name: string} [@@deriving compare] @@ -1124,12 +1192,13 @@ module Fieldname = struct (** Convert a fieldname to a string. *) let to_string = function - | Hidden - -> hidden_str - | Java fname - -> fname - | Clang {field_name} - -> field_name + | Hidden -> + hidden_str + | Java fname -> + fname + | Clang {field_name} -> + field_name + (** Convert a fieldname to a simplified string with at most one-level path. *) let to_simplified_string fn = @@ -1137,37 +1206,42 @@ module Fieldname = struct match String.rsplit2 s ~on:'.' with | Some (s1, s2) -> ( match String.rsplit2 s1 ~on:'.' with Some (_, s4) -> s4 ^ "." ^ s2 | _ -> s ) - | _ - -> s + | _ -> + s + let to_full_string fname = match fname with - | Clang {class_name; field_name} - -> Name.to_string class_name ^ "::" ^ field_name - | _ - -> to_string fname + | Clang {class_name; field_name} -> + Name.to_string class_name ^ "::" ^ field_name + | _ -> + to_string fname + (** Convert a fieldname to a flat string without path. *) let to_flat_string fn = let s = to_string fn in match String.rsplit2 s ~on:'.' with Some (_, s2) -> s2 | _ -> s + let pp f = function - | Hidden - -> Format.fprintf f "%s" hidden_str - | Java field_name | Clang {field_name} - -> Format.fprintf f "%s" field_name + | Hidden -> + Format.fprintf f "%s" hidden_str + | Java field_name | Clang {field_name} -> + Format.fprintf f "%s" field_name + let pp_latex style f fn = Latex.pp_string style f (to_string fn) let class_name_replace fname ~f = match fname with - | Clang {class_name; field_name} - -> let class_name' = f class_name in + | Clang {class_name; field_name} -> + let class_name' = f class_name in if phys_equal class_name class_name' then fname else Clang {class_name= class_name'; field_name} - | _ - -> fname + | _ -> + fname + (** Returns the class part of the fieldname *) let java_get_class fn = @@ -1175,12 +1249,14 @@ module Fieldname = struct let ri = String.rindex_exn fn '.' in String.slice fn 0 ri + (** Returns the last component of the fieldname *) let java_get_field fn = let fn = to_string fn in let ri = 1 + String.rindex_exn fn '.' in String.slice fn ri 0 + (** Check if the field is the synthetic this$n of a nested class, used to access the n-th outher instance. *) let java_is_outer_instance fn = let fn = to_string fn in @@ -1192,11 +1268,13 @@ module Fieldname = struct (last_char >= '0' && last_char <= '9') && String.is_suffix fn ~suffix:(this ^ String.of_char last_char) + let clang_get_qual_class = function - | Clang {class_name} - -> Some (Name.qual_name class_name) - | _ - -> None + | Clang {class_name} -> + Some (Name.qual_name class_name) + | _ -> + None + (** hidded fieldname constant *) let hidden = Hidden @@ -1213,10 +1291,11 @@ module Fieldname = struct let is_captured_parameter field_name = match field_name with - | Java _ - -> String.is_prefix ~prefix:"val$" (to_flat_string field_name) - | Hidden | Clang _ - -> false + | Java _ -> + String.is_prefix ~prefix:"val$" (to_flat_string field_name) + | Hidden | Clang _ -> + false + end end @@ -1238,6 +1317,7 @@ module Struct = struct let pp_field pe f (field_name, typ, ann) = F.fprintf f "@\n\t\t%a %a %a" (pp_full pe) typ Fieldname.pp field_name Annot.Item.pp ann + let pp pe name f {fields; supers; methods; annots} = if Config.debug_mode then (* change false to true to print the details of struct *) @@ -1252,6 +1332,7 @@ module Struct = struct methods Annot.Item.pp annots else F.fprintf f "%a" Name.pp name + let internal_mk_struct ?default ?fields ?statics ?methods ?supers ?annots () = let default_ = {fields= []; statics= []; methods= []; supers= []; annots= Annot.Item.empty} in let mk_struct_ ?(default= default_) ?(fields= default.fields) ?(statics= default.statics) @@ -1260,50 +1341,54 @@ module Struct = struct in mk_struct_ ?default ?fields ?statics ?methods ?supers ?annots () + (** the element typ of the final extensible array in the given typ, if any *) let rec get_extensible_array_element_typ ~lookup (typ: T.t) = match typ.desc with - | Tarray (typ, _, _) - -> Some typ + | Tarray (typ, _, _) -> + Some typ | Tstruct name -> ( match lookup name with | Some {fields} -> ( match List.last fields with - | Some (_, fld_typ, _) - -> get_extensible_array_element_typ ~lookup fld_typ - | None - -> None ) - | None - -> None ) - | _ - -> None + | Some (_, fld_typ, _) -> + get_extensible_array_element_typ ~lookup fld_typ + | None -> + None ) + | None -> + None ) + | _ -> + None + (** If a struct type with field f, return the type of f. If not, return the default *) let fld_typ ~lookup ~default fn (typ: T.t) = match typ.desc with | Tstruct name -> ( match lookup name with - | Some {fields} - -> List.find ~f:(fun (f, _, _) -> Fieldname.equal f fn) fields + | Some {fields} -> + List.find ~f:(fun (f, _, _) -> Fieldname.equal f fn) fields |> Option.value_map ~f:snd3 ~default - | None - -> default ) - | _ - -> default + | None -> + default ) + | _ -> + default + let get_field_type_and_annotation ~lookup fn (typ: T.t) = match typ.desc with | Tstruct name | Tptr ({desc= Tstruct name}, _) -> ( match lookup name with - | Some {fields; statics} - -> List.find_map + | Some {fields; statics} -> + List.find_map ~f:(fun (f, t, a) -> match Fieldname.equal f fn with true -> Some (t, a) | false -> None) (fields @ statics) - | None - -> None ) - | _ - -> None + | None -> + None ) + | _ -> + None + let objc_ref_counter_annot = [({Annot.class_name= "ref_counter"; parameters= []}, false)] @@ -1312,4 +1397,5 @@ module Struct = struct let is_objc_ref_counter_field (fld, _, a) = Fieldname.is_hidden fld && Annot.Item.equal a objc_ref_counter_annot + end diff --git a/infer/src/absint/AbstractDomain.ml b/infer/src/absint/AbstractDomain.ml index b384d4e98..ad83a4928 100644 --- a/infer/src/absint/AbstractDomain.ml +++ b/infer/src/absint/AbstractDomain.ml @@ -57,34 +57,37 @@ module BottomLifted (Domain : S) = struct if phys_equal lhs rhs then true else match (lhs, rhs) with - | Bottom, _ - -> true - | _, Bottom - -> false - | NonBottom lhs, NonBottom rhs - -> Domain.( <= ) ~lhs ~rhs + | Bottom, _ -> + true + | _, Bottom -> + false + | NonBottom lhs, NonBottom rhs -> + Domain.( <= ) ~lhs ~rhs + let join astate1 astate2 = if phys_equal astate1 astate2 then astate1 else match (astate1, astate2) with - | Bottom, _ - -> astate2 - | _, Bottom - -> astate1 - | NonBottom a1, NonBottom a2 - -> NonBottom (Domain.join a1 a2) + | Bottom, _ -> + astate2 + | _, Bottom -> + astate1 + | NonBottom a1, NonBottom a2 -> + NonBottom (Domain.join a1 a2) + let widen ~prev ~next ~num_iters = if phys_equal prev next then prev else match (prev, next) with - | Bottom, _ - -> next - | _, Bottom - -> prev - | NonBottom prev, NonBottom next - -> NonBottom (Domain.widen ~prev ~next ~num_iters) + | Bottom, _ -> + next + | _, Bottom -> + prev + | NonBottom prev, NonBottom next -> + NonBottom (Domain.widen ~prev ~next ~num_iters) + let pp fmt = function Bottom -> F.fprintf fmt "_|_" | NonBottom astate -> Domain.pp fmt astate end @@ -98,30 +101,33 @@ module TopLifted (Domain : S) = struct if phys_equal lhs rhs then true else match (lhs, rhs) with - | _, Top - -> true - | Top, _ - -> false - | NonTop lhs, NonTop rhs - -> Domain.( <= ) ~lhs ~rhs + | _, Top -> + true + | Top, _ -> + false + | NonTop lhs, NonTop rhs -> + Domain.( <= ) ~lhs ~rhs + let join astate1 astate2 = if phys_equal astate1 astate2 then astate1 else match (astate1, astate2) with - | Top, _ | _, Top - -> Top - | NonTop a1, NonTop a2 - -> NonTop (Domain.join a1 a2) + | Top, _ | _, Top -> + Top + | NonTop a1, NonTop a2 -> + NonTop (Domain.join a1 a2) + let widen ~prev ~next ~num_iters = if phys_equal prev next then prev else match (prev, next) with - | Top, _ | _, Top - -> Top - | NonTop prev, NonTop next - -> NonTop (Domain.widen ~prev ~next ~num_iters) + | Top, _ | _, Top -> + Top + | NonTop prev, NonTop next -> + NonTop (Domain.widen ~prev ~next ~num_iters) + let pp fmt = function Top -> F.fprintf fmt "T" | NonTop astate -> Domain.pp fmt astate end @@ -134,16 +140,19 @@ module Pair (Domain1 : S) (Domain2 : S) = struct else Domain1.( <= ) ~lhs:(fst lhs) ~rhs:(fst rhs) && Domain2.( <= ) ~lhs:(snd lhs) ~rhs:(snd rhs) + let join astate1 astate2 = if phys_equal astate1 astate2 then astate1 else (Domain1.join (fst astate1) (fst astate2), Domain2.join (snd astate1) (snd astate2)) + let widen ~prev ~next ~num_iters = if phys_equal prev next then prev else ( Domain1.widen ~prev:(fst prev) ~next:(fst next) ~num_iters , Domain2.widen ~prev:(snd prev) ~next:(snd next) ~num_iters ) + let pp fmt (astate1, astate2) = F.fprintf fmt "(%a, %a)" Domain1.pp astate1 Domain2.pp astate2 end @@ -187,34 +196,37 @@ module Map (Key : PrettyPrintable.PrintableOrderedType) (ValueDomain : S) = stru with Not_found -> false) lhs + let join astate1 astate2 = if phys_equal astate1 astate2 then astate1 else M.merge (fun _ v1_opt v2_opt -> match (v1_opt, v2_opt) with - | Some v1, Some v2 - -> Some (ValueDomain.join v1 v2) - | Some v, _ | _, Some v - -> Some v - | None, None - -> None) + | Some v1, Some v2 -> + Some (ValueDomain.join v1 v2) + | Some v, _ | _, Some v -> + Some v + | None, None -> + None) astate1 astate2 + let widen ~prev ~next ~num_iters = if phys_equal prev next then prev else M.merge (fun _ v1_opt v2_opt -> match (v1_opt, v2_opt) with - | Some v1, Some v2 - -> Some (ValueDomain.widen ~prev:v1 ~next:v2 ~num_iters) - | Some v, _ | _, Some v - -> Some v - | None, None - -> None) + | Some v1, Some v2 -> + Some (ValueDomain.widen ~prev:v1 ~next:v2 ~num_iters) + | Some v, _ | _, Some v -> + Some v + | None, None -> + None) prev next + let pp fmt astate = M.pp ~pp_value:ValueDomain.pp fmt astate end @@ -230,30 +242,33 @@ module InvertedMap (Key : PrettyPrintable.PrintableOrderedType) (ValueDomain : S try M.for_all (fun k rhs_v -> ValueDomain.( <= ) ~lhs:(M.find k lhs) ~rhs:rhs_v) rhs with Not_found -> false + let join astate1 astate2 = if phys_equal astate1 astate2 then astate1 else M.merge (fun _ v1_opt v2_opt -> match (v1_opt, v2_opt) with - | Some v1, Some v2 - -> Some (ValueDomain.join v1 v2) - | _ - -> None) + | Some v1, Some v2 -> + Some (ValueDomain.join v1 v2) + | _ -> + None) astate1 astate2 + let widen ~prev ~next ~num_iters = if phys_equal prev next then prev else M.merge (fun _ v1_opt v2_opt -> match (v1_opt, v2_opt) with - | Some v1, Some v2 - -> Some (ValueDomain.widen ~prev:v1 ~next:v2 ~num_iters) - | _ - -> None) + | Some v1, Some v2 -> + Some (ValueDomain.widen ~prev:v1 ~next:v2 ~num_iters) + | _ -> + None) prev next + let pp fmt astate = M.pp ~pp_value:ValueDomain.pp fmt astate end diff --git a/infer/src/absint/AbstractInterpreter.ml b/infer/src/absint/AbstractInterpreter.ml index 3a92a535e..14328f1b1 100644 --- a/infer/src/absint/AbstractInterpreter.ml +++ b/infer/src/absint/AbstractInterpreter.ml @@ -53,24 +53,27 @@ struct try Some (InvariantMap.find node_id inv_map) with Not_found -> None + (** extract the postcondition of node [n] from [inv_map] *) let extract_post node_id inv_map = match extract_state node_id inv_map with Some state -> Some state.post | None -> None + (** extract the precondition of node [n] from [inv_map] *) let extract_pre node_id inv_map = match extract_state node_id inv_map with Some state -> Some state.pre | None -> None + let exec_node node astate_pre work_queue inv_map ({ProcData.pdesc} as proc_data) ~debug = let node_id = CFG.id node in let update_inv_map pre visit_count = let compute_post (pre, inv_map) (instr, id_opt) = let post = TransferFunctions.exec_instr pre proc_data node instr in match id_opt with - | Some id - -> (post, InvariantMap.add id {pre; post; visit_count} inv_map) - | None - -> (post, inv_map) + | Some id -> + (post, InvariantMap.add id {pre; post; visit_count} inv_map) + | None -> + (post, inv_map) in (* hack to ensure that we call `exec_instr` on a node even if it has no instructions *) let instr_ids = match CFG.instr_ids node with [] -> [(Sil.skip_instr, None)] | l -> l in @@ -108,6 +111,7 @@ struct let visit_count = 1 in update_inv_map astate_pre visit_count + let rec exec_worklist cfg work_queue inv_map proc_data ~debug = let compute_pre node inv_map = (* if the [pred] -> [node] transition was normal, use post([pred]) *) @@ -119,25 +123,26 @@ struct List.fold ~f:extract_pre_f ~init:normal_posts (CFG.exceptional_preds cfg node) in match List.filter_opt all_posts with - | post :: posts - -> Some (List.fold ~f:Domain.join ~init:post posts) - | [] - -> None + | post :: posts -> + Some (List.fold ~f:Domain.join ~init:post posts) + | [] -> + None in match Scheduler.pop work_queue with - | Some (_, [], work_queue') - -> exec_worklist cfg work_queue' inv_map proc_data ~debug - | Some (node, _, work_queue') - -> let inv_map_post, work_queue_post = + | Some (_, [], work_queue') -> + exec_worklist cfg work_queue' inv_map proc_data ~debug + | Some (node, _, work_queue') -> + let inv_map_post, work_queue_post = match compute_pre node inv_map with - | Some astate_pre - -> exec_node node astate_pre work_queue' inv_map proc_data ~debug - | None - -> (inv_map, work_queue') + | Some astate_pre -> + exec_node node astate_pre work_queue' inv_map proc_data ~debug + | None -> + (inv_map, work_queue') in exec_worklist cfg work_queue_post inv_map_post proc_data ~debug - | None - -> inv_map + | None -> + inv_map + (* compute and return an invariant map for [cfg] *) let exec_cfg cfg proc_data ~initial ~debug = @@ -147,15 +152,18 @@ struct in exec_worklist cfg work_queue' inv_map' proc_data ~debug + (* compute and return an invariant map for [pdesc] *) let exec_pdesc ({ProcData.pdesc} as proc_data) = exec_cfg (CFG.from_pdesc pdesc) proc_data ~debug:Config.write_html + (* compute and return the postcondition of [pdesc] *) let compute_post ?(debug= Config.write_html) ({ProcData.pdesc} as proc_data) ~initial = let cfg = CFG.from_pdesc pdesc in let inv_map = exec_cfg cfg proc_data ~initial ~debug in extract_post (CFG.id (CFG.exit_node cfg)) inv_map + end module MakeWithScheduler (C : ProcCfg.S) (S : Scheduler.Make) (T : TransferFunctions.MakeSIL) = diff --git a/infer/src/absint/Checkers.ml b/infer/src/absint/Checkers.ml index 3677a36e5..25c84a468 100644 --- a/infer/src/absint/Checkers.ml +++ b/infer/src/absint/Checkers.ml @@ -21,13 +21,14 @@ module PP = struct let pp_loc_range linereader nbefore nafter fmt loc = let printline n = match Printer.LineReader.from_loc linereader {loc with Location.line= n} with - | Some s - -> F.fprintf fmt "%s%s@\n" (if Int.equal n loc.Location.line then "-->" else " ") s - | _ - -> () + | Some s -> + F.fprintf fmt "%s%s@\n" (if Int.equal n loc.Location.line then "-->" else " ") s + | _ -> + () in F.fprintf fmt "%a:%d@\n" SourceFile.pp loc.Location.file loc.Location.line ; for n = loc.Location.line - nbefore to loc.Location.line + nafter do printline n done + end (* PP *) @@ -73,33 +74,33 @@ module ST = struct match (field_name, PatternMatch.get_this_type proc_attributes) with | Some field_name, Some t -> ( match Typ.Struct.get_field_type_and_annotation ~lookup field_name t with - | Some (_, ia) - -> Annotations.ia_has_annotation_with ia annotation_matches - | None - -> false ) - | _ - -> false + | Some (_, ia) -> + Annotations.ia_has_annotation_with ia annotation_matches + | None -> + false ) + | _ -> + false in let is_class_suppressed = match PatternMatch.get_this_type proc_attributes with | Some t -> ( match PatternMatch.type_get_annotation tenv t with - | Some ia - -> Annotations.ia_has_annotation_with ia annotation_matches - | None - -> false ) - | None - -> false + | Some ia -> + Annotations.ia_has_annotation_with ia annotation_matches + | None -> + false ) + | None -> + false in is_method_suppressed || is_field_suppressed || is_class_suppressed in let trace = let origin_elements = match origin_loc with - | Some oloc - -> [Errlog.make_trace_element 0 oloc "origin" []] - | None - -> [] + | Some oloc -> + [Errlog.make_trace_element 0 oloc "origin" []] + | None -> + [] in origin_elements @ [Errlog.make_trace_element 0 loc description []] in @@ -108,4 +109,5 @@ module ST = struct (Typ.Procname.to_string proc_name) ; L.progress "%s@." description ; Reporting.log_error_deprecated proc_name ~loc ~ltr:trace exn ) + end diff --git a/infer/src/absint/FormalMap.ml b/infer/src/absint/FormalMap.ml index 354d8cb67..53b840173 100644 --- a/infer/src/absint/FormalMap.ml +++ b/infer/src/absint/FormalMap.ml @@ -27,6 +27,7 @@ let make pdesc = ~f:(fun formal_map (base, index) -> AccessPath.BaseMap.add base index formal_map) ~init:AccessPath.BaseMap.empty formals_with_nums + let empty = AccessPath.BaseMap.empty let is_formal = AccessPath.BaseMap.mem @@ -35,10 +36,12 @@ let get_formal_index base t = try Some (AccessPath.BaseMap.find base t) with Not_found -> None + let get_formal_base index t = List.find ~f:(fun (_, i) -> Int.equal i index) (AccessPath.BaseMap.bindings t) |> Option.map ~f:fst + let get_formals_indexes = AccessPath.BaseMap.bindings let pp = AccessPath.BaseMap.pp ~pp_value:Int.pp diff --git a/infer/src/absint/LowerHil.ml b/infer/src/absint/LowerHil.ml index 39659844e..5ed4b4cb2 100644 --- a/infer/src/absint/LowerHil.ml +++ b/infer/src/absint/LowerHil.ml @@ -29,7 +29,7 @@ struct type extras = TransferFunctions.extras - let exec_instr (actual_state, id_map as astate) extras node instr = + let exec_instr ((actual_state, id_map) as astate) extras node instr = let f_resolve_id id = try Some (IdAccessPathMapDomain.find id id_map) with Not_found -> None @@ -37,16 +37,16 @@ struct match HilInstr.of_sil ~include_array_indexes:HilConfig.include_array_indexes ~f_resolve_id instr with - | Bind (id, access_path) - -> let id_map' = IdAccessPathMapDomain.add id access_path id_map in + | Bind (id, access_path) -> + let id_map' = IdAccessPathMapDomain.add id access_path id_map in if phys_equal id_map id_map' then astate else (actual_state, id_map') - | Unbind ids - -> let id_map' = + | Unbind ids -> + let id_map' = List.fold ~f:(fun acc id -> IdAccessPathMapDomain.remove id acc) ~init:id_map ids in if phys_equal id_map id_map' then astate else (actual_state, id_map') - | Instr hil_instr - -> let actual_state' = TransferFunctions.exec_instr actual_state extras node hil_instr in + | Instr hil_instr -> + let actual_state' = TransferFunctions.exec_instr actual_state extras node hil_instr in ( if Config.write_html then let underyling_node = CFG.underlying_node node in NodePrinter.start_session underyling_node ; @@ -55,8 +55,9 @@ struct (fst astate) HilInstr.pp hil_instr TransferFunctions.Domain.pp actual_state') ; NodePrinter.finish_session underyling_node ) ; if phys_equal actual_state actual_state' then astate else (actual_state', id_map) - | Ignore - -> astate + | Ignore -> + astate + end module MakeDefault (MakeTransferFunctions : TransferFunctions.MakeHIL) (CFG : ProcCfg.S) = diff --git a/infer/src/absint/NodePrinter.ml b/infer/src/absint/NodePrinter.ml index 1050301cc..dc66ebad7 100644 --- a/infer/src/absint/NodePrinter.ml +++ b/infer/src/absint/NodePrinter.ml @@ -18,16 +18,18 @@ let new_session node = let pname = Procdesc.Node.get_proc_name node in let node_id = (Procdesc.Node.get_id node :> int) in match Specs.get_summary pname with - | None - -> 0 - | Some summary - -> (summary.stats).nodes_visited_fp <- IntSet.add node_id summary.stats.nodes_visited_fp ; + | None -> + 0 + | Some summary -> + (summary.stats).nodes_visited_fp <- IntSet.add node_id summary.stats.nodes_visited_fp ; incr summary.Specs.sessions ; !(summary.Specs.sessions) + let start_session node = if Config.write_html then let session = new_session node in Printer.node_start_session node session + let finish_session node = if Config.write_html then Printer.node_finish_session node diff --git a/infer/src/absint/PatternMatch.ml b/infer/src/absint/PatternMatch.ml index 4c62b8f66..ff4cd584e 100644 --- a/infer/src/absint/PatternMatch.ml +++ b/infer/src/absint/PatternMatch.ml @@ -16,10 +16,11 @@ module F = Format let type_is_object typ = match typ.Typ.desc with - | Tptr ({desc= Tstruct name}, _) - -> Typ.Name.equal name Typ.Name.Java.java_lang_object - | _ - -> false + | Tptr ({desc= Tstruct name}, _) -> + Typ.Name.equal name Typ.Name.Java.java_lang_object + | _ -> + false + let java_proc_name_with_class_method pn_java class_with_path method_name = try @@ -27,70 +28,81 @@ let java_proc_name_with_class_method pn_java class_with_path method_name = && String.equal (Typ.Procname.java_get_method pn_java) method_name with _ -> false + (** Holds iff the predicate holds on a supertype of the named type, including the type itself *) let rec supertype_exists tenv pred name = match Tenv.lookup tenv name with - | Some ({supers} as struct_typ) - -> pred name struct_typ || List.exists ~f:(fun name -> supertype_exists tenv pred name) supers - | None - -> false + | Some ({supers} as struct_typ) -> + pred name struct_typ || List.exists ~f:(fun name -> supertype_exists tenv pred name) supers + | None -> + false + let rec supertype_find_map_opt tenv f name = match f name with | None -> ( match Tenv.lookup tenv name with - | Some {supers} - -> List.find_map ~f:(supertype_find_map_opt tenv f) supers - | None - -> None ) - | result - -> result + | Some {supers} -> + List.find_map ~f:(supertype_find_map_opt tenv f) supers + | None -> + None ) + | result -> + result + let is_immediate_subtype tenv this_type_name super_type_name = match Tenv.lookup tenv this_type_name with - | Some {supers} - -> List.exists ~f:(Typ.Name.equal super_type_name) supers - | None - -> false + | Some {supers} -> + List.exists ~f:(Typ.Name.equal super_type_name) supers + | None -> + false + (** return true if [typ0] <: [typ1] *) let is_subtype tenv name0 name1 = Typ.Name.equal name0 name1 || supertype_exists tenv (fun name _ -> Typ.Name.equal name name1) name0 + let is_subtype_of_str tenv cn1 classname_str = let typename = Typ.Name.Java.from_string classname_str in is_subtype tenv cn1 typename + (** The type the method is invoked on *) let get_this_type proc_attributes = match proc_attributes.ProcAttributes.formals with (_, t) :: _ -> Some t | _ -> None + let type_get_direct_supertypes tenv (typ: Typ.t) = match typ.desc with | Tptr ({desc= Tstruct name}, _) | Tstruct name -> ( match Tenv.lookup tenv name with Some {supers} -> supers | None -> [] ) - | _ - -> [] + | _ -> + [] + let type_get_class_name {Typ.desc} = match desc with Typ.Tptr (typ, _) -> Typ.name typ | _ -> None + let type_get_annotation tenv (typ: Typ.t) : Annot.Item.t option = match typ.desc with | Tptr ({desc= Tstruct name}, _) | Tstruct name -> ( match Tenv.lookup tenv name with Some {annots} -> Some annots | None -> None ) - | _ - -> None + | _ -> + None + let rec get_type_name {Typ.desc} = match desc with - | Typ.Tstruct name - -> Typ.Name.name name - | Typ.Tptr (t, _) - -> get_type_name t - | _ - -> "_" + | Typ.Tstruct name -> + Typ.Name.name name + | Typ.Tptr (t, _) -> + get_type_name t + | _ -> + "_" + let get_field_type_name tenv (typ: Typ.t) (fieldname: Typ.Fieldname.t) : string option = match typ.desc with @@ -98,74 +110,76 @@ let get_field_type_name tenv (typ: Typ.t) (fieldname: Typ.Fieldname.t) : string match Tenv.lookup tenv name with | Some {fields} -> ( match List.find ~f:(function fn, _, _ -> Typ.Fieldname.equal fn fieldname) fields with - | Some (_, ft, _) - -> Some (get_type_name ft) - | None - -> None ) - | None - -> None ) - | _ - -> None + | Some (_, ft, _) -> + Some (get_type_name ft) + | None -> + None ) + | None -> + None ) + | _ -> + None + let java_get_const_type_name (const: Const.t) : string = match const with - | Const.Cstr _ - -> "java.lang.String" - | Const.Cint _ - -> "java.lang.Integer" - | Const.Cfloat _ - -> "java.lang.Double" - | _ - -> "_" + | Const.Cstr _ -> + "java.lang.String" + | Const.Cint _ -> + "java.lang.Integer" + | Const.Cfloat _ -> + "java.lang.Double" + | _ -> + "_" + let get_vararg_type_names tenv (call_node: Procdesc.Node.t) (ivar: Pvar.t) : string list = (* Is this the node creating ivar? *) let rec initializes_array instrs = match instrs with | (Sil.Call (Some (t1, _), Exp.Const Const.Cfun pn, _, _, _)) - :: (Sil.Store (Exp.Lvar iv, _, Exp.Var t2, _)) :: is - -> Pvar.equal ivar iv && Ident.equal t1 t2 + :: (Sil.Store (Exp.Lvar iv, _, Exp.Var t2, _)) :: is -> + Pvar.equal ivar iv && Ident.equal t1 t2 && Typ.Procname.equal pn (Typ.Procname.from_string_c_fun "__new_array") || initializes_array is - | _ :: is - -> initializes_array is - | _ - -> false + | _ :: is -> + initializes_array is + | _ -> + false in (* Get the type name added to ivar or None *) let added_type_name node = let rec nvar_type_name nvar instrs = match instrs with - | (Sil.Load (nv, Exp.Lfield (_, id, t), _, _)) :: _ when Ident.equal nv nvar - -> get_field_type_name tenv t id - | (Sil.Load (nv, _, t, _)) :: _ when Ident.equal nv nvar - -> Some (get_type_name t) - | _ :: is - -> nvar_type_name nvar is - | _ - -> None + | (Sil.Load (nv, Exp.Lfield (_, id, t), _, _)) :: _ when Ident.equal nv nvar -> + get_field_type_name tenv t id + | (Sil.Load (nv, _, t, _)) :: _ when Ident.equal nv nvar -> + Some (get_type_name t) + | _ :: is -> + nvar_type_name nvar is + | _ -> + None in let rec added_nvar array_nvar instrs = match instrs with | (Sil.Store (Exp.Lindex (Exp.Var iv, _), _, Exp.Var nvar, _)) :: _ - when Ident.equal iv array_nvar - -> nvar_type_name nvar (Procdesc.Node.get_instrs node) + when Ident.equal iv array_nvar -> + nvar_type_name nvar (Procdesc.Node.get_instrs node) | (Sil.Store (Exp.Lindex (Exp.Var iv, _), _, Exp.Const c, _)) :: _ - when Ident.equal iv array_nvar - -> Some (java_get_const_type_name c) - | _ :: is - -> added_nvar array_nvar is - | _ - -> None + when Ident.equal iv array_nvar -> + Some (java_get_const_type_name c) + | _ :: is -> + added_nvar array_nvar is + | _ -> + None in let rec array_nvar instrs = match instrs with - | (Sil.Load (nv, Exp.Lvar iv, _, _)) :: _ when Pvar.equal iv ivar - -> added_nvar nv instrs - | _ :: is - -> array_nvar is - | _ - -> None + | (Sil.Load (nv, Exp.Lvar iv, _, _)) :: _ when Pvar.equal iv ivar -> + added_nvar nv instrs + | _ :: is -> + array_nvar is + | _ -> + None in array_nvar (Procdesc.Node.get_instrs node) in @@ -176,59 +190,67 @@ let get_vararg_type_names tenv (call_node: Procdesc.Node.t) (ivar: Pvar.t) : str match Procdesc.Node.get_preds node with | [n] -> ( match added_type_name node with Some name -> name :: type_names n | None -> type_names n ) - | _ - -> raise Not_found + | _ -> + raise Not_found in List.rev (type_names call_node) + let has_formal_proc_argument_type_names proc_desc argument_type_names = let formals = Procdesc.get_formals proc_desc in let equal_formal_arg (_, typ) arg_type_name = String.equal (get_type_name typ) arg_type_name in Int.equal (List.length formals) (List.length argument_type_names) && List.for_all2_exn ~f:equal_formal_arg formals argument_type_names + let has_formal_method_argument_type_names cfg pname_java argument_type_names = has_formal_proc_argument_type_names cfg (Typ.Procname.java_get_class_name pname_java :: argument_type_names) + let is_getter pname_java = Str.string_match (Str.regexp "get*") (Typ.Procname.java_get_method pname_java) 0 + let is_setter pname_java = Str.string_match (Str.regexp "set*") (Typ.Procname.java_get_method pname_java) 0 + (** Returns the signature of a field access (class name, field name, field type name) *) let get_java_field_access_signature = function - | Sil.Load (_, Exp.Lfield (_, fn, ft), bt, _) - -> Some (get_type_name bt, Typ.Fieldname.java_get_field fn, get_type_name ft) - | _ - -> None + | Sil.Load (_, Exp.Lfield (_, fn, ft), bt, _) -> + Some (get_type_name bt, Typ.Fieldname.java_get_field fn, get_type_name ft) + | _ -> + None + (** Returns the formal signature (class name, method name, argument type names and return type name) *) let get_java_method_call_formal_signature = function | Sil.Call (_, Exp.Const Const.Cfun pn, (_, tt) :: args, _, _) -> ( match pn with - | Typ.Procname.Java pn_java - -> let arg_names = List.map ~f:(function _, t -> get_type_name t) args in + | Typ.Procname.Java pn_java -> + let arg_names = List.map ~f:(function _, t -> get_type_name t) args in let rt_name = Typ.Procname.java_get_return_type pn_java in let m_name = Typ.Procname.java_get_method pn_java in Some (get_type_name tt, m_name, arg_names, rt_name) - | _ - -> None ) - | _ - -> None + | _ -> + None ) + | _ -> + None + let type_is_class typ = match typ.Typ.desc with - | Tptr ({desc= Tstruct _}, _) - -> true - | Tptr ({desc= Tarray _}, _) - -> true - | Tstruct _ - -> true - | _ - -> false + | Tptr ({desc= Tstruct _}, _) -> + true + | Tptr ({desc= Tarray _}, _) -> + true + | Tstruct _ -> + true + | _ -> + false + let initializer_classes = List.map ~f:Typ.Name.Java.from_string @@ -239,6 +261,7 @@ let initializer_classes = ; "android.support.v4.app.Fragment" ; "junit.framework.TestCase" ] + let initializer_methods = ["onActivityCreated"; "onAttach"; "onCreate"; "onCreateView"; "setUp"] (** Check if the type has in its supertypes from the initializer_classes list. *) @@ -247,59 +270,62 @@ let type_has_initializer (tenv: Tenv.t) (t: Typ.t) : bool = List.mem ~equal:Typ.Name.equal initializer_classes typename in match t.desc with - | Typ.Tstruct name | Tptr ({desc= Tstruct name}, _) - -> supertype_exists tenv is_initializer_class name - | _ - -> false + | Typ.Tstruct name | Tptr ({desc= Tstruct name}, _) -> + supertype_exists tenv is_initializer_class name + | _ -> + false + (** Check if the method is one of the known initializer methods. *) let method_is_initializer (tenv: Tenv.t) (proc_attributes: ProcAttributes.t) : bool = match get_this_type proc_attributes with - | Some this_type - -> if type_has_initializer tenv this_type then + | Some this_type -> + if type_has_initializer tenv this_type then match proc_attributes.ProcAttributes.proc_name with - | Typ.Procname.Java pname_java - -> let mname = Typ.Procname.java_get_method pname_java in + | Typ.Procname.Java pname_java -> + let mname = Typ.Procname.java_get_method pname_java in List.exists ~f:(String.equal mname) initializer_methods - | _ - -> false + | _ -> + false else false - | None - -> false + | None -> + false + (** Get the vararg values by looking for array assignments to the pvar. *) let java_get_vararg_values node pvar idenv = let values = ref [] in let do_instr = function | Sil.Store (Exp.Lindex (array_exp, _), _, content_exp, _) - when Exp.equal (Exp.Lvar pvar) (Idenv.expand_expr idenv array_exp) - -> (* Each vararg argument is an assigment to a pvar denoting an array of objects. *) + when Exp.equal (Exp.Lvar pvar) (Idenv.expand_expr idenv array_exp) -> + (* Each vararg argument is an assigment to a pvar denoting an array of objects. *) values := content_exp :: !values - | _ - -> () + | _ -> + () in let do_node n = List.iter ~f:do_instr (Procdesc.Node.get_instrs n) in let () = match Errdesc.find_program_variable_assignment node pvar with - | Some (node', _) - -> Procdesc.iter_slope_range do_node node' node - | None - -> () + | Some (node', _) -> + Procdesc.iter_slope_range do_node node' node + | None -> + () in !values + let proc_calls resolve_attributes pdesc filter : (Typ.Procname.t * ProcAttributes.t) list = let res = ref [] in let do_instruction _ instr = match instr with | Sil.Call (_, Exp.Const Const.Cfun callee_pn, _, _, _) -> ( match resolve_attributes callee_pn with - | Some callee_attributes - -> if filter callee_pn callee_attributes then res := (callee_pn, callee_attributes) :: !res - | None - -> () ) - | _ - -> () + | Some callee_attributes -> + if filter callee_pn callee_attributes then res := (callee_pn, callee_attributes) :: !res + | None -> + () ) + | _ -> + () in let do_node node = let instrs = Procdesc.Node.get_instrs node in @@ -309,47 +335,50 @@ let proc_calls resolve_attributes pdesc filter : (Typ.Procname.t * ProcAttribute List.iter ~f:do_node nodes ; List.rev !res + let override_exists f tenv proc_name = let rec super_type_exists tenv super_class_name = let super_proc_name = Typ.Procname.replace_class proc_name super_class_name in match Tenv.lookup tenv super_class_name with - | Some {methods; supers} - -> let is_override pname = + | Some {methods; supers} -> + let is_override pname = Typ.Procname.equal pname super_proc_name && not (Typ.Procname.is_constructor pname) in List.exists ~f:(fun pname -> is_override pname && f pname) methods || List.exists ~f:(super_type_exists tenv) supers - | _ - -> false + | _ -> + false in f proc_name || match proc_name with - | Typ.Procname.Java proc_name_java - -> let type_name = + | Typ.Procname.Java proc_name_java -> + let type_name = Typ.Name.Java.from_string (Typ.Procname.java_get_class_name proc_name_java) in List.exists ~f:(super_type_exists tenv) (type_get_direct_supertypes tenv (Typ.mk (Tstruct type_name))) - | _ - -> false + | _ -> + false + (* Only java supported at the moment *) let override_iter f tenv proc_name = ignore (override_exists (fun pname -> f pname ; false) tenv proc_name) + (** return the set of instance fields that are assigned to a null literal in [procdesc] *) let get_fields_nullified procdesc = (* walk through the instructions and look for instance fields that are assigned to null *) let collect_nullified_flds (nullified_flds, this_ids) _ = function | Sil.Store (Exp.Lfield (Exp.Var lhs, fld, _), _, rhs, _) - when Exp.is_null_literal rhs && Ident.IdentSet.mem lhs this_ids - -> (Typ.Fieldname.Set.add fld nullified_flds, this_ids) - | Sil.Load (id, rhs, _, _) when Exp.is_this rhs - -> (nullified_flds, Ident.IdentSet.add id this_ids) - | _ - -> (nullified_flds, this_ids) + when Exp.is_null_literal rhs && Ident.IdentSet.mem lhs this_ids -> + (Typ.Fieldname.Set.add fld nullified_flds, this_ids) + | Sil.Load (id, rhs, _, _) when Exp.is_this rhs -> + (nullified_flds, Ident.IdentSet.add id this_ids) + | _ -> + (nullified_flds, this_ids) in let nullified_flds, _ = Procdesc.fold_instrs collect_nullified_flds (Typ.Fieldname.Set.empty, Ident.IdentSet.empty) @@ -357,10 +386,12 @@ let get_fields_nullified procdesc = in nullified_flds + (** Checks if the exception is an unchecked exception *) let is_runtime_exception tenv typename = is_subtype_of_str tenv typename "java.lang.RuntimeException" + (** Checks if the class name is a Java exception *) let is_exception tenv typename = is_subtype_of_str tenv typename "java.lang.Exception" @@ -370,31 +401,34 @@ let is_throwable tenv typename = is_subtype_of_str tenv typename "java.lang.Thro (** tests whether any class attributes (e.g., @ThreadSafe) pass check of first argument, including for supertypes*) let check_class_attributes check tenv = function - | Typ.Procname.Java java_pname - -> let check_class_annots _ {Typ.Struct.annots} = check annots in + | Typ.Procname.Java java_pname -> + let check_class_annots _ {Typ.Struct.annots} = check annots in supertype_exists tenv check_class_annots (Typ.Procname.java_get_class_type_name java_pname) - | _ - -> false + | _ -> + false + (** tests whether any class attributes (e.g., @ThreadSafe) pass check of first argument, for the current class only*) let check_current_class_attributes check tenv = function | Typ.Procname.Java java_pname -> ( match Tenv.lookup tenv (Typ.Procname.java_get_class_type_name java_pname) with - | Some struct_typ - -> check struct_typ.annots - | _ - -> false ) - | _ - -> false + | Some struct_typ -> + check struct_typ.annots + | _ -> + false ) + | _ -> + false + (** find superclasss with attributes (e.g., @ThreadSafe), including current class*) let rec find_superclasses_with_attributes check tenv tname = match Tenv.lookup tenv tname with - | Some struct_typ - -> let result_from_supers = + | Some struct_typ -> + let result_from_supers = List.concat (List.map ~f:(find_superclasses_with_attributes check tenv) struct_typ.supers) in if check struct_typ.annots then tname :: result_from_supers else result_from_supers - | _ - -> [] + | _ -> + [] + diff --git a/infer/src/absint/ProcCfg.ml b/infer/src/absint/ProcCfg.ml index 5515ab2b5..bf1b34080 100644 --- a/infer/src/absint/ProcCfg.ml +++ b/infer/src/absint/ProcCfg.ml @@ -77,12 +77,14 @@ module InstrNode = struct let n = Procdesc.Node.compare_id id1 id2 in if n <> 0 then n else compare_index index1 index2 + let pp_id fmt (id, index) = match index with - | Node_index - -> Procdesc.Node.pp_id fmt id - | Instr_index i - -> F.fprintf fmt "(%a: %d)" Procdesc.Node.pp_id id i + | Node_index -> + Procdesc.Node.pp_id fmt id + | Instr_index i -> + F.fprintf fmt "(%a: %d)" Procdesc.Node.pp_id id i + end module type S = sig @@ -202,6 +204,7 @@ module Exceptional = struct in (pdesc, exceptional_preds) + let instrs = Procdesc.Node.get_instrs let instr_ids n = List.map ~f:(fun i -> (i, None)) (instrs n) @@ -216,26 +219,29 @@ module Exceptional = struct try Procdesc.IdMap.find (Procdesc.Node.get_id n) exn_pred_map with Not_found -> [] + (** get all normal and exceptional successors of [n]. *) let succs t n = let normal_succs = normal_succs t n in match exceptional_succs t n with - | [] - -> normal_succs - | exceptional_succs - -> normal_succs @ exceptional_succs |> List.sort ~cmp:Procdesc.Node.compare + | [] -> + normal_succs + | exceptional_succs -> + normal_succs @ exceptional_succs |> List.sort ~cmp:Procdesc.Node.compare |> List.remove_consecutive_duplicates ~equal:Procdesc.Node.equal + (** get all normal and exceptional predecessors of [n]. *) let preds t n = let normal_preds = normal_preds t n in match exceptional_preds t n with - | [] - -> normal_preds - | exceptional_preds - -> normal_preds @ exceptional_preds |> List.sort ~cmp:Procdesc.Node.compare + | [] -> + normal_preds + | exceptional_preds -> + normal_preds @ exceptional_preds |> List.sort ~cmp:Procdesc.Node.compare |> List.remove_consecutive_duplicates ~equal:Procdesc.Node.equal + let proc_desc (pdesc, _) = pdesc let start_node (pdesc, _) = Procdesc.get_start_node pdesc @@ -285,6 +291,7 @@ struct let id = (Procdesc.Node.get_id t, Instr_index i) in (instr, Some id)) (instrs t) + end module NodeIdMap (CFG : S) = Caml.Map.Make (struct diff --git a/infer/src/absint/Scheduler.ml b/infer/src/absint/Scheduler.ml index 12b3dc7fc..4cb7dd36a 100644 --- a/infer/src/absint/Scheduler.ml +++ b/infer/src/absint/Scheduler.ml @@ -58,16 +58,19 @@ module ReversePostorder (CFG : ProcCfg.S) = struct let compute_priority cfg node visited_preds = List.length (CFG.preds cfg node) - IdSet.cardinal visited_preds + let make cfg node = let visited_preds = IdSet.empty in let priority = compute_priority cfg node visited_preds in {node; visited_preds; priority} + (* add [node_id] to the visited preds for [t] *) let add_visited_pred cfg t node_id = let visited_preds' = IdSet.add node_id t.visited_preds in let priority' = compute_priority cfg t.node visited_preds' in {t with visited_preds= visited_preds'; priority= priority'} + end type t = {worklist: WorkUnit.t M.t; cfg: CFG.t} @@ -88,6 +91,7 @@ module ReversePostorder (CFG : ProcCfg.S) = struct let new_worklist = List.fold ~f:schedule_succ ~init:t.worklist (CFG.succs t.cfg node) in {t with worklist= new_worklist} + (* remove and return the node with the highest priority (note that smaller integers have higher priority), the ids of its visited predecessors, and new schedule *) (* TODO: could do this slightly more efficiently by keeping a list of priority zero nodes for @@ -109,5 +113,6 @@ module ReversePostorder (CFG : ProcCfg.S) = struct Some (node, WorkUnit.visited_preds max_priority_work, t') with Not_found -> None + let empty cfg = {worklist= M.empty; cfg} end diff --git a/infer/src/absint/Summary.ml b/infer/src/absint/Summary.ml index 9f72757fd..e4db3ea61 100644 --- a/infer/src/absint/Summary.ml +++ b/infer/src/absint/Summary.ml @@ -32,8 +32,9 @@ module Make (P : Payload) : S with type payload = P.payload = struct let read_summary caller_pdesc callee_pname = match Ondemand.analyze_proc_name caller_pdesc callee_pname with - | None - -> None - | Some summary - -> P.read_payload summary + | None -> + None + | Some summary -> + P.read_payload summary + end diff --git a/infer/src/absint/Var.ml b/infer/src/absint/Var.ml index 7ffc680b1..59bc41d66 100644 --- a/infer/src/absint/Var.ml +++ b/infer/src/absint/Var.ml @@ -30,10 +30,11 @@ let is_return = function ProgramVar pvar -> Pvar.is_return pvar | LogicalVar _ - let is_footprint = function ProgramVar _ -> false | LogicalVar id -> Ident.is_footprint id let pp fmt = function - | ProgramVar pv - -> Pvar.pp Pp.text fmt pv - | LogicalVar id - -> Ident.pp Pp.text fmt id + | ProgramVar pv -> + Pvar.pp Pp.text fmt pv + | LogicalVar id -> + Ident.pp Pp.text fmt id + module Map = PrettyPrintable.MakePPMap (struct type nonrec t = t diff --git a/infer/src/atd/jbuild.in b/infer/src/atd/jbuild.in index 1aa5e2314..7b7a7c3e9 100644 --- a/infer/src/atd/jbuild.in +++ b/infer/src/atd/jbuild.in @@ -12,5 +12,6 @@ let cflags = common_cflags @ ["-w"; "-27-32-34-35-39"] (libraries (atdgen)) )) |} - (String.concat " " cflags) (String.concat " " common_optflags) + (String.concat " " cflags) + (String.concat " " common_optflags) |> Jbuild_plugin.V1.send diff --git a/infer/src/backend/Attribute.ml b/infer/src/backend/Attribute.ml index fe0d932fc..ee6007431 100644 --- a/infer/src/backend/Attribute.ml +++ b/infer/src/backend/Attribute.ml @@ -23,38 +23,42 @@ let add tenv ?(footprint= false) ?(polarity= true) prop attr args = Prop.prop_atom_and tenv ~footprint prop (if polarity then Sil.Apred (attr, args) else Sil.Anpred (attr, args)) + let attributes_in_same_category attr1 attr2 = let cat1 = PredSymb.to_category attr1 in let cat2 = PredSymb.to_category attr2 in PredSymb.equal_category cat1 cat2 + (** Replace an attribute associated to the expression *) let add_or_replace_check_changed tenv check_attribute_change prop atom = match atom with - | Sil.Apred (att0, (_ :: _ as exps0)) | Anpred (att0, (_ :: _ as exps0)) - -> let pairs = List.map ~f:(fun e -> (e, Prop.exp_normalize_prop tenv prop e)) exps0 in + | Sil.Apred (att0, (_ :: _ as exps0)) | Anpred (att0, (_ :: _ as exps0)) -> + let pairs = List.map ~f:(fun e -> (e, Prop.exp_normalize_prop tenv prop e)) exps0 in let _, nexp = List.hd_exn pairs in (* len exps0 > 0 by match *) let atom_map = function | Sil.Apred (att, exp :: _) | Anpred (att, exp :: _) - when Exp.equal nexp exp && attributes_in_same_category att att0 - -> check_attribute_change att att0 ; atom - | atom' - -> atom' + when Exp.equal nexp exp && attributes_in_same_category att att0 -> + check_attribute_change att att0 ; atom + | atom' -> + atom' in let pi = prop.Prop.pi in let pi' = IList.map_changed atom_map pi in if phys_equal pi pi' then Prop.prop_atom_and tenv prop atom else Prop.normalize tenv (Prop.set prop ~pi:pi') - | _ - -> prop + | _ -> + prop + let add_or_replace tenv prop atom = (* wrapper for the most common case: do nothing *) let check_attr_changed _ _ = () in add_or_replace_check_changed tenv check_attr_changed prop atom + (** Get all the attributes of the prop *) let get_all (prop: 'a Prop.t) = let res = ref [] in @@ -62,34 +66,38 @@ let get_all (prop: 'a Prop.t) = List.iter ~f:do_atom prop.pi ; List.rev !res + (** Get all the attributes of the prop *) let get_for_symb prop att = List.filter ~f:(function Sil.Apred (att', _) | Anpred (att', _) -> PredSymb.equal att' att | _ -> false) prop.Prop.pi + (** Get the attribute associated to the expression, if any *) let get_for_exp tenv (prop: 'a Prop.t) exp = let nexp = Prop.exp_normalize_prop tenv prop exp in let atom_get_attr attributes atom = match atom with - | (Sil.Apred (_, es) | Anpred (_, es)) when List.mem ~equal:Exp.equal es nexp - -> atom :: attributes - | _ - -> attributes + | (Sil.Apred (_, es) | Anpred (_, es)) when List.mem ~equal:Exp.equal es nexp -> + atom :: attributes + | _ -> + attributes in List.fold ~f:atom_get_attr ~init:[] prop.pi + let get tenv prop exp category = let atts = get_for_exp tenv prop exp in List.find ~f:(function - | Sil.Apred (att, _) | Anpred (att, _) - -> PredSymb.equal_category (PredSymb.to_category att) category - | _ - -> false) + | Sil.Apred (att, _) | Anpred (att, _) -> + PredSymb.equal_category (PredSymb.to_category att) category + | _ -> + false) atts + let get_undef tenv prop exp = get tenv prop exp ACundef let get_resource tenv prop exp = get tenv prop exp ACresource @@ -112,11 +120,13 @@ let has_dangling_uninit tenv prop exp = ~f:(function Sil.Apred (a, _) -> PredSymb.equal a (Adangling DAuninit) | _ -> false) la + let filter_atoms tenv ~f prop = let pi0 = prop.Prop.pi in let pi1 = IList.filter_changed f pi0 in if phys_equal pi1 pi0 then prop else Prop.normalize tenv (Prop.set prop ~pi:pi1) + let remove tenv prop atom = if is_pred atom then let natom = Prop.atom_normalize_prop tenv prop atom in @@ -124,74 +134,80 @@ let remove tenv prop atom = filter_atoms tenv ~f prop else prop + (** Remove an attribute from all the atoms in the heap *) let remove_for_attr tenv prop att0 = let f = function - | Sil.Apred (att, _) | Anpred (att, _) - -> not (PredSymb.equal att0 att) - | _ - -> true + | Sil.Apred (att, _) | Anpred (att, _) -> + not (PredSymb.equal att0 att) + | _ -> + true in filter_atoms tenv ~f prop + let remove_resource tenv ra_kind ra_res = let f = function - | Sil.Apred (Aresource res_action, _) - -> PredSymb.compare_res_act_kind res_action.ra_kind ra_kind <> 0 + | Sil.Apred (Aresource res_action, _) -> + PredSymb.compare_res_act_kind res_action.ra_kind ra_kind <> 0 || PredSymb.compare_resource res_action.ra_res ra_res <> 0 - | _ - -> true + | _ -> + true in filter_atoms tenv ~f + (** Apply f to every resource attribute in the prop *) let map_resource tenv prop f = let attribute_map e = function - | PredSymb.Aresource ra - -> PredSymb.Aresource (f e ra) - | att - -> att + | PredSymb.Aresource ra -> + PredSymb.Aresource (f e ra) + | att -> + att in let atom_map = function - | Sil.Apred (att, ([e] as es)) - -> Sil.Apred (attribute_map e att, es) - | Sil.Anpred (att, ([e] as es)) - -> Sil.Anpred (attribute_map e att, es) - | atom - -> atom + | Sil.Apred (att, ([e] as es)) -> + Sil.Apred (attribute_map e att, es) + | Sil.Anpred (att, ([e] as es)) -> + Sil.Anpred (attribute_map e att, es) + | atom -> + atom in let pi0 = prop.Prop.pi in let pi1 = IList.map_changed atom_map pi0 in if phys_equal pi1 pi0 then prop else Prop.normalize tenv (Prop.set prop ~pi:pi1) + (* Replace an attribute OBJC_NULL($n1) with OBJC_NULL(var) when var = $n1, and also sets $n1 = 0 *) let replace_objc_null tenv prop lhs_exp rhs_exp = match (get_objc_null tenv prop rhs_exp, rhs_exp) with - | Some atom, Exp.Var _ - -> let prop = remove tenv prop atom in + | Some atom, Exp.Var _ -> + let prop = remove tenv prop atom in let prop = Prop.conjoin_eq tenv rhs_exp Exp.zero prop in let natom = Sil.atom_replace_exp [(rhs_exp, lhs_exp)] atom in add_or_replace tenv prop natom - | _ - -> prop + | _ -> + prop + let rec nullify_exp_with_objc_null tenv prop exp = match exp with - | Exp.BinOp (_, exp1, exp2) - -> let prop' = nullify_exp_with_objc_null tenv prop exp1 in + | Exp.BinOp (_, exp1, exp2) -> + let prop' = nullify_exp_with_objc_null tenv prop exp1 in nullify_exp_with_objc_null tenv prop' exp2 - | Exp.UnOp (_, exp, _) - -> nullify_exp_with_objc_null tenv prop exp + | Exp.UnOp (_, exp, _) -> + nullify_exp_with_objc_null tenv prop exp | Exp.Var _ -> ( match get_objc_null tenv prop exp with - | Some atom - -> let prop' = remove tenv prop atom in + | Some atom -> + let prop' = remove tenv prop atom in Prop.conjoin_eq tenv exp Exp.zero prop' - | _ - -> prop ) - | _ - -> prop + | _ -> + prop ) + | _ -> + prop + (** mark Exp.Var's or Exp.Lvar's as undefined The annotations of the return type of the method get propagated to the return id, @@ -201,23 +217,24 @@ let mark_vars_as_undefined tenv prop ~ret_exp_opt ~undefined_actuals_by_ref call loc path_pos = let mark_var_as_undefined ~annot exp prop = match exp with - | Exp.Var _ | Lvar _ - -> let att_undef = PredSymb.Aundef (callee_pname, annot, loc, path_pos) in + | Exp.Var _ | Lvar _ -> + let att_undef = PredSymb.Aundef (callee_pname, annot, loc, path_pos) in add_or_replace tenv prop (Apred (att_undef, [exp])) - | _ - -> prop + | _ -> + prop in let prop_with_ret_attr = match ret_exp_opt with - | Some ret_exp - -> mark_var_as_undefined ~annot:ret_annots ret_exp prop - | None - -> prop + | Some ret_exp -> + mark_var_as_undefined ~annot:ret_annots ret_exp prop + | None -> + prop in List.fold ~f:(fun prop id -> mark_var_as_undefined ~annot:[] id prop) ~init:prop_with_ret_attr undefined_actuals_by_ref + (** type for arithmetic problems *) type arith_problem = (* division by zero *) @@ -232,68 +249,69 @@ let find_arithmetic_problem tenv proc_node_session prop exp = let res = ref prop in let check_zero e = match Prop.exp_normalize_prop tenv prop e with - | Exp.Const c when Const.iszero_int_float c - -> true - | _ - -> res := add_or_replace tenv !res (Apred (Adiv0 proc_node_session, [e])) ; + | Exp.Const c when Const.iszero_int_float c -> + true + | _ -> + res := add_or_replace tenv !res (Apred (Adiv0 proc_node_session, [e])) ; false in let rec walk = function - | Exp.Var _ - -> () + | Exp.Var _ -> + () | Exp.UnOp ( Unop.Neg , e , Some ( {Typ.desc= Tint (Typ.IUChar | Typ.IUInt | Typ.IUShort | Typ.IULong | Typ.IULongLong)} - as typ ) ) - -> uminus_unsigned := (e, typ) :: !uminus_unsigned - | Exp.UnOp (_, e, _) - -> walk e - | Exp.BinOp (op, e1, e2) - -> if Binop.equal op Binop.Div || Binop.equal op Binop.Mod then exps_divided + as typ ) ) -> + uminus_unsigned := (e, typ) :: !uminus_unsigned + | Exp.UnOp (_, e, _) -> + walk e + | Exp.BinOp (op, e1, e2) -> + if Binop.equal op Binop.Div || Binop.equal op Binop.Mod then exps_divided := e2 :: !exps_divided ; walk e1 ; walk e2 - | Exp.Exn _ - -> () - | Exp.Closure _ - -> () - | Exp.Const _ - -> () - | Exp.Cast (_, e) - -> walk e - | Exp.Lvar _ - -> () - | Exp.Lfield (e, _, _) - -> walk e - | Exp.Lindex (e1, e2) - -> walk e1 ; walk e2 - | Exp.Sizeof {dynamic_length= None} - -> () - | Exp.Sizeof {dynamic_length= Some len} - -> walk len + | Exp.Exn _ -> + () + | Exp.Closure _ -> + () + | Exp.Const _ -> + () + | Exp.Cast (_, e) -> + walk e + | Exp.Lvar _ -> + () + | Exp.Lfield (e, _, _) -> + walk e + | Exp.Lindex (e1, e2) -> + walk e1 ; walk e2 + | Exp.Sizeof {dynamic_length= None} -> + () + | Exp.Sizeof {dynamic_length= Some len} -> + walk len in walk exp ; let problem_opt = match (List.find ~f:check_zero !exps_divided, !uminus_unsigned) with - | Some e, _ - -> Some (Div0 e) - | None, (e, t) :: _ - -> Some (UminusUnsigned (e, t)) - | None, [] - -> None + | Some e, _ -> + Some (Div0 e) + | None, (e, t) :: _ -> + Some (UminusUnsigned (e, t)) + | None, [] -> + None in (problem_opt, !res) + (** Deallocate the stack variables in [pvars], and replace them by normal variables. Return the list of stack variables whose address was still present after deallocation. *) let deallocate_stack_vars tenv (p: 'a Prop.t) pvars = let filter = function - | Sil.Hpointsto (Exp.Lvar v, _, _) - -> List.exists ~f:(Pvar.equal v) pvars - | _ - -> false + | Sil.Hpointsto (Exp.Lvar v, _, _) -> + List.exists ~f:(Pvar.equal v) pvars + | _ -> + false in let sigma_stack, sigma_other = List.partition_tf ~f:filter p.sigma in let fresh_address_vars = ref [] in @@ -303,12 +321,12 @@ let deallocate_stack_vars tenv (p: 'a Prop.t) pvars = let exp_replace = List.map ~f:(function - | Sil.Hpointsto (Exp.Lvar v, _, _) - -> let freshv = Ident.create_fresh Ident.kprimed in + | Sil.Hpointsto (Exp.Lvar v, _, _) -> + let freshv = Ident.create_fresh Ident.kprimed in fresh_address_vars := (v, freshv) :: !fresh_address_vars ; (Exp.Lvar v, Exp.Var freshv) - | _ - -> assert false) + | _ -> + assert false) sigma_stack in let pi1 = List.map ~f:(fun (id, e) -> Sil.Aeq (Exp.Var id, e)) (Sil.sub_to_list p.sub) in @@ -342,6 +360,7 @@ let deallocate_stack_vars tenv (p: 'a Prop.t) pvars = let p''' = if changed then Prop.normalize tenv (Prop.set p'' ~pi:filtered_pi) else p'' in (!stack_vars_address_in_post, List.fold ~f:(Prop.prop_atom_and tenv) ~init:p''' pi) + (** Input of this method is an exp in a prop. Output is a formal variable or path from a formal variable that is equal to the expression, or the OBJC_NULL attribute of the expression. *) @@ -353,40 +372,41 @@ let find_equal_formal_path tenv e prop = else let seen_hpreds = hpred :: seen_hpreds in match res with - | Some _ - -> res + | Some _ -> + res | None -> match hpred with | Sil.Hpointsto (Exp.Lvar pvar1, Sil.Eexp (exp2, Sil.Iformal (_, _)), _) - when Exp.equal exp2 e && (Pvar.is_local pvar1 || Pvar.is_seed pvar1) - -> Some (Exp.Lvar pvar1) - | Sil.Hpointsto (exp1, Sil.Estruct (fields, _), _) - -> List.fold_right + when Exp.equal exp2 e && (Pvar.is_local pvar1 || Pvar.is_seed pvar1) -> + Some (Exp.Lvar pvar1) + | Sil.Hpointsto (exp1, Sil.Estruct (fields, _), _) -> + List.fold_right ~f:(fun (field, strexp) res -> match res with - | Some _ - -> res + | Some _ -> + res | None -> match strexp with | Sil.Eexp (exp2, _) when Exp.equal exp2 e -> ( match find_in_sigma exp1 seen_hpreds with - | Some vfs - -> Some (Exp.Lfield (vfs, field, Typ.mk Tvoid)) - | None - -> None ) - | _ - -> None) + | Some vfs -> + Some (Exp.Lfield (vfs, field, Typ.mk Tvoid)) + | None -> + None ) + | _ -> + None) fields ~init:None - | _ - -> None) + | _ -> + None) prop.Prop.sigma ~init:None in match find_in_sigma e [] with - | Some vfs - -> Some vfs + | Some vfs -> + Some vfs | None -> match get_objc_null tenv prop e with - | Some Apred (Aobjc_null, [_; vfs]) - -> Some vfs - | _ - -> None + | Some Apred (Aobjc_null, [_; vfs]) -> + Some vfs + | _ -> + None + diff --git a/infer/src/backend/BuiltinDefn.ml b/infer/src/backend/BuiltinDefn.ml index 8801e9604..dc00e0090 100644 --- a/infer/src/backend/BuiltinDefn.ml +++ b/infer/src/backend/BuiltinDefn.ml @@ -23,11 +23,12 @@ let execute___no_op prop path : Builtin.ret_typ = [(prop, path)] let execute___builtin_va_arg {Builtin.pdesc; tenv; prop_; path; ret_id; args; loc} : Builtin.ret_typ = match (args, ret_id) with - | [_; _; (lexp3, typ3)], _ - -> let instr' = Sil.Store (lexp3, typ3, Exp.zero, loc) in + | [_; _; (lexp3, typ3)], _ -> + let instr' = Sil.Store (lexp3, typ3, Exp.zero, loc) in SymExec.instrs ~mask_errors:true tenv pdesc [instr'] [(prop_, path)] - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + let mk_empty_array len = Sil.Earray (len, [], Sil.inst_none) @@ -37,22 +38,25 @@ let mk_empty_array len = Sil.Earray (len, [], Sil.inst_none) let mk_empty_array_rearranged len = Sil.Earray (len, [], Sil.inst_rearrange true (State.get_loc ()) (State.get_path_pos ())) + let extract_array_type typ = if Config.curr_language_is Config.Java then match typ.Typ.desc with Typ.Tptr (({Typ.desc= Tarray _} as arr), _) -> Some arr | _ -> None else match typ.Typ.desc with - | Typ.Tarray _ - -> Some typ - | Typ.Tptr (elt, _) - -> Some (Typ.mk ~default:typ (Tarray (elt, None, None))) - | _ - -> None + | Typ.Tarray _ -> + Some typ + | Typ.Tptr (elt, _) -> + Some (Typ.mk ~default:typ (Tarray (elt, None, None))) + | _ -> + None + (** Return a result from a procedure call. *) let return_result tenv e prop ret_id = match ret_id with Some (ret_id, _) -> Prop.conjoin_eq tenv e (Exp.Var ret_id) prop | _ -> prop + (* Add an array of typ pointed to by lexp to prop_ if it doesn't already exist *) (* Return the new prop and the array length *) (* Return None if it fails to add the array *) @@ -65,12 +69,12 @@ let add_array_to_prop tenv pdesc prop_ lexp typ = prop.Prop.sigma in match hpred_opt with - | Some Sil.Hpointsto (_, Sil.Earray (len, _, _), _) - -> Some (len, prop) - | Some _ - -> None (* e points to something but not an array *) - | None - -> extract_array_type typ + | Some Sil.Hpointsto (_, Sil.Earray (len, _, _), _) -> + Some (len, prop) + | Some _ -> + None (* e points to something but not an array *) + | None -> + extract_array_type typ |> Option.map ~f:(fun arr_typ -> let len = Exp.Var (Ident.create_fresh Ident.kfootprint) in let s = mk_empty_array_rearranged len in @@ -86,37 +90,40 @@ let add_array_to_prop tenv pdesc prop_ lexp typ = let prop'' = Prop.normalize tenv prop'' in (len, prop'') ) + (* Add an array in prop if it is not allocated.*) let execute___require_allocated_array {Builtin.tenv; pdesc; prop_; path; args} : Builtin.ret_typ = match args with | [(lexp, typ)] -> ( match add_array_to_prop tenv pdesc prop_ lexp typ with - | None - -> [] - | Some (_, prop) - -> [(prop, path)] ) - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | None -> + [] + | Some (_, prop) -> + [(prop, path)] ) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + let execute___get_array_length {Builtin.tenv; pdesc; prop_; path; ret_id; args} : Builtin.ret_typ = match args with | [(lexp, typ)] -> ( match add_array_to_prop tenv pdesc prop_ lexp typ with - | None - -> [] - | Some (len, prop) - -> [(return_result tenv len prop ret_id, path)] ) - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | None -> + [] + | Some (len, prop) -> + [(return_result tenv len prop ret_id, path)] ) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + let execute___set_array_length {Builtin.tenv; pdesc; prop_; path; ret_id; args} : Builtin.ret_typ = match (args, ret_id) with | [(lexp, typ); (len, _)], None -> ( match add_array_to_prop tenv pdesc prop_ lexp typ with - | None - -> [] - | Some (_, prop_a) - -> (* Invariant: prop_a has an array pointed to by lexp *) + | None -> + [] + | Some (_, prop_a) -> + (* Invariant: prop_a has an array pointed to by lexp *) let pname = Procdesc.get_proc_name pdesc in let n_lexp, prop__ = check_arith_norm_exp tenv pname lexp prop_a in let n_len, prop = check_arith_norm_exp tenv pname len prop__ in @@ -126,15 +133,16 @@ let execute___set_array_length {Builtin.tenv; pdesc; prop_; path; ret_id; args} prop.Prop.sigma in match hpred with - | [(Sil.Hpointsto (e, Sil.Earray (_, esel, inst), t))] - -> let hpred' = Sil.Hpointsto (e, Sil.Earray (n_len, esel, inst), t) in + | [(Sil.Hpointsto (e, Sil.Earray (_, esel, inst), t))] -> + let hpred' = Sil.Hpointsto (e, Sil.Earray (n_len, esel, inst), t) in let prop' = Prop.set prop ~sigma:(hpred' :: sigma') in [(Prop.normalize tenv prop', path)] - | _ - -> [] + | _ -> + [] (* by construction of prop_a this case is impossible *) ) - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + let execute___print_value {Builtin.tenv; pdesc; prop_; path; args} : Builtin.ret_typ = L.(debug Analysis Medium) "__print_value: " ; @@ -143,7 +151,10 @@ let execute___print_value {Builtin.tenv; pdesc; prop_; path; args} : Builtin.ret let n_lexp, _ = check_arith_norm_exp tenv pname lexp prop_ in L.(debug Analysis Medium) "%a " Exp.pp n_lexp in - List.iter ~f:do_arg args ; L.(debug Analysis Medium) "@." ; [(prop_, path)] + List.iter ~f:do_arg args ; + L.(debug Analysis Medium) "@." ; + [(prop_, path)] + let is_undefined_opt tenv prop n_lexp = Option.is_some (Attribute.get_undef tenv prop n_lexp) @@ -156,33 +167,33 @@ let create_type tenv n_lexp typ prop = ~f:(function Sil.Hpointsto (e, _, _) -> Exp.equal e n_lexp | _ -> false) prop.Prop.sigma with - | Some _ - -> prop - | None - -> let mhpred = + | Some _ -> + prop + | None -> + let mhpred = match typ.Typ.desc with - | Typ.Tptr (typ', _) - -> let sexp = Sil.Estruct ([], Sil.inst_none) in + | Typ.Tptr (typ', _) -> + let sexp = Sil.Estruct ([], Sil.inst_none) in let texp = Exp.Sizeof {typ= typ'; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes} in let hpred = Prop.mk_ptsto tenv n_lexp sexp texp in Some hpred - | Typ.Tarray _ - -> let len = Exp.Var (Ident.create_fresh Ident.kfootprint) in + | Typ.Tarray _ -> + let len = Exp.Var (Ident.create_fresh Ident.kfootprint) in let sexp = mk_empty_array len in let texp = Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes} in let hpred = Prop.mk_ptsto tenv n_lexp sexp texp in Some hpred - | _ - -> None + | _ -> + None in match mhpred with - | Some hpred - -> let sigma = prop.Prop.sigma in + | Some hpred -> + let sigma = prop.Prop.sigma in let sigma_fp = prop.Prop.sigma_fp in let prop' = Prop.set prop ~sigma:(hpred :: sigma) in let prop'' = @@ -192,8 +203,8 @@ let create_type tenv n_lexp typ prop = in let prop'' = Prop.normalize tenv prop'' in prop'' - | None - -> prop + | None -> + prop in let sil_is_null = Exp.BinOp (Binop.Eq, n_lexp, Exp.zero) in let sil_is_nonnull = Exp.UnOp (Unop.LNot, sil_is_null, None) in @@ -203,10 +214,11 @@ let create_type tenv n_lexp typ prop = else if List.length non_null_case > 0 && is_undefined_opt tenv prop n_lexp then non_null_case else null_case @ non_null_case + let execute___get_type_of {Builtin.pdesc; tenv; prop_; path; ret_id; args} : Builtin.ret_typ = match args with - | [(lexp, typ)] - -> let pname = Procdesc.get_proc_name pdesc in + | [(lexp, typ)] -> + let pname = Procdesc.get_proc_name pdesc in let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in let props = create_type tenv n_lexp typ prop in let aux prop = @@ -217,14 +229,15 @@ let execute___get_type_of {Builtin.pdesc; tenv; prop_; path; ret_id; args} : Bui prop.Prop.sigma in match hpred_opt with - | Some texp - -> (return_result tenv texp prop ret_id, path) - | None - -> (return_result tenv Exp.zero prop ret_id, path) + | Some texp -> + (return_result tenv texp prop ret_id, path) + | None -> + (return_result tenv Exp.zero prop ret_id, path) in List.map ~f:aux props - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + (** replace the type of the ptsto rooted at [root_e] with [texp] in [prop] *) let replace_ptsto_texp tenv prop root_e texp = @@ -235,10 +248,10 @@ let replace_ptsto_texp tenv prop root_e texp = sigma in match sigma1 with - | [(Sil.Hpointsto (e, se, _))] - -> Sil.Hpointsto (e, se, texp) :: sigma2 - | _ - -> sigma + | [(Sil.Hpointsto (e, se, _))] -> + Sil.Hpointsto (e, se, texp) :: sigma2 + | _ -> + sigma in let sigma = prop.Prop.sigma in let sigma_fp = prop.Prop.sigma_fp in @@ -246,11 +259,12 @@ let replace_ptsto_texp tenv prop root_e texp = let prop'' = Prop.set prop' ~sigma_fp:(process_sigma sigma_fp) in Prop.normalize tenv prop'' + let execute___instanceof_cast ~instof {Builtin.pdesc; tenv; prop_; path; ret_id; args} : Builtin.ret_typ = match args with - | [(val1_, typ1); (texp2_, _)] - -> let pname = Procdesc.get_proc_name pdesc in + | [(val1_, typ1); (texp2_, _)] -> + let pname = Procdesc.get_proc_name pdesc in let val1, prop__ = check_arith_norm_exp tenv pname val1_ prop_ in let texp2, prop = check_arith_norm_exp tenv pname texp2_ prop__ in let is_cast_to_reference = @@ -271,16 +285,16 @@ let execute___instanceof_cast ~instof {Builtin.pdesc; tenv; prop_; path; ret_id; prop.Prop.sigma |> Option.map ~f:(function | Sil.Hpointsto (_, _, texp1) - -> ( + -> ( let pos_type_opt, neg_type_opt = Prover.Subtyping_check.subtype_case_analysis tenv texp1 texp2 in let mk_res type_opt res_e = match type_opt with - | None - -> [] - | Some texp1' - -> let prop' = + | None -> + [] + | Some texp1' -> + let prop' = if Exp.equal texp1 texp1' then prop else replace_ptsto_texp tenv prop val1 texp1' in @@ -299,45 +313,48 @@ let execute___instanceof_cast ~instof {Builtin.pdesc; tenv; prop_; path; ret_id; pos_res @ neg_res else if !Config.footprint then match pos_type_opt with - | None - -> deal_with_failed_cast val1 texp1 texp2 - | Some _ - -> mk_res pos_type_opt val1 + | None -> + deal_with_failed_cast val1 texp1 texp2 + | Some _ -> + mk_res pos_type_opt val1 else (* !Config.footprint is false *) match neg_type_opt with - | Some _ - -> if is_undefined_opt tenv prop val1 then mk_res pos_type_opt val1 + | Some _ -> + if is_undefined_opt tenv prop val1 then mk_res pos_type_opt val1 else deal_with_failed_cast val1 texp1 texp2 - | None - -> mk_res pos_type_opt val1 ) - | _ - -> [] ) + | None -> + mk_res pos_type_opt val1 ) + | _ -> + [] ) in match res_opt with - | Some res - -> res - | None - -> [(return_result tenv val1 prop ret_id, path)] + | Some res -> + res + | None -> + [(return_result tenv val1 prop ret_id, path)] in let props = create_type tenv val1 typ1 prop in List.concat_map ~f:exe_one_prop props - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + let execute___instanceof builtin_args : Builtin.ret_typ = execute___instanceof_cast ~instof:true builtin_args + let execute___cast builtin_args : Builtin.ret_typ = execute___instanceof_cast ~instof:false builtin_args + let set_resource_attribute tenv prop path n_lexp loc ra_res = let prop' = match Attribute.get_resource tenv prop n_lexp with - | Some Apred (Aresource ra, _) - -> Attribute.add_or_replace tenv prop (Apred (Aresource {ra with ra_res}, [n_lexp])) - | _ - -> let pname = PredSymb.mem_alloc_pname PredSymb.Mnew in + | Some Apred (Aresource ra, _) -> + Attribute.add_or_replace tenv prop (Apred (Aresource {ra with ra_res}, [n_lexp])) + | _ -> + let pname = PredSymb.mem_alloc_pname PredSymb.Mnew in let ra = {PredSymb.ra_kind= Racquire; ra_res; ra_pname= pname; ra_loc= loc; ra_vpath= None} in @@ -345,138 +362,145 @@ let set_resource_attribute tenv prop path n_lexp loc ra_res = in [(prop', path)] + (** Set the attibute of the value as file *) let execute___set_file_attribute {Builtin.tenv; pdesc; prop_; path; ret_id; args; loc} : Builtin.ret_typ = match (args, ret_id) with - | [(lexp, _)], _ - -> let pname = Procdesc.get_proc_name pdesc in + | [(lexp, _)], _ -> + let pname = Procdesc.get_proc_name pdesc in let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in set_resource_attribute tenv prop path n_lexp loc PredSymb.Rfile - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + (** Set the attibute of the value as lock *) let execute___set_lock_attribute {Builtin.tenv; pdesc; prop_; path; ret_id; args; loc} : Builtin.ret_typ = match (args, ret_id) with - | [(lexp, _)], _ - -> let pname = Procdesc.get_proc_name pdesc in + | [(lexp, _)], _ -> + let pname = Procdesc.get_proc_name pdesc in let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in set_resource_attribute tenv prop path n_lexp loc PredSymb.Rlock - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + (** Set the resource attribute of the first real argument of method as ignore, the first argument is assumed to be "this" *) let execute___method_set_ignore_attribute {Builtin.tenv; pdesc; prop_; path; ret_id; args; loc} : Builtin.ret_typ = match (args, ret_id) with - | [_; (lexp, _)], _ - -> let pname = Procdesc.get_proc_name pdesc in + | [_; (lexp, _)], _ -> + let pname = Procdesc.get_proc_name pdesc in let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in set_resource_attribute tenv prop path n_lexp loc PredSymb.Rignore - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + (** Set the attibute of the value as memory *) let execute___set_mem_attribute {Builtin.tenv; pdesc; prop_; path; ret_id; args; loc} : Builtin.ret_typ = match (args, ret_id) with - | [(lexp, _)], _ - -> let pname = Procdesc.get_proc_name pdesc in + | [(lexp, _)], _ -> + let pname = Procdesc.get_proc_name pdesc in let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in set_resource_attribute tenv prop path n_lexp loc (PredSymb.Rmemory PredSymb.Mnew) - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + (** take a pointer to a struct, and return the value of a hidden field in the struct *) let execute___get_hidden_field {Builtin.tenv; pdesc; prop_; path; ret_id; args} : Builtin.ret_typ = match args with - | [(lexp, _)] - -> let pname = Procdesc.get_proc_name pdesc in + | [(lexp, _)] -> + let pname = Procdesc.get_proc_name pdesc in let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in let ret_val = ref None in let return_val p = match !ret_val with Some e -> return_result tenv e p ret_id | None -> p in - let foot_var = (lazy (Exp.Var (Ident.create_fresh Ident.kfootprint))) in + let foot_var = lazy (Exp.Var (Ident.create_fresh Ident.kfootprint)) in let filter_fld_hidden (f, _) = Typ.Fieldname.is_hidden f in let has_fld_hidden fsel = List.exists ~f:filter_fld_hidden fsel in let do_hpred in_foot hpred = match hpred with | Sil.Hpointsto (e, Sil.Estruct (fsel, inst), texp) - when Exp.equal e n_lexp && not (has_fld_hidden fsel) - -> let foot_e = Lazy.force foot_var in + when Exp.equal e n_lexp && not (has_fld_hidden fsel) -> + let foot_e = Lazy.force foot_var in ret_val := Some foot_e ; let se = Sil.Eexp (foot_e, Sil.inst_none) in let fsel' = (Typ.Fieldname.hidden, se) :: fsel in Sil.Hpointsto (e, Sil.Estruct (fsel', inst), texp) | Sil.Hpointsto (e, Sil.Estruct (fsel, _), _) - when Exp.equal e n_lexp && not in_foot && has_fld_hidden fsel - -> let set_ret_val () = + when Exp.equal e n_lexp && not in_foot && has_fld_hidden fsel -> + let set_ret_val () = match List.find ~f:filter_fld_hidden fsel with - | Some (_, Sil.Eexp (e, _)) - -> ret_val := Some e - | _ - -> () + | Some (_, Sil.Eexp (e, _)) -> + ret_val := Some e + | _ -> + () in set_ret_val () ; hpred - | _ - -> hpred + | _ -> + hpred in let sigma' = List.map ~f:(do_hpred false) prop.Prop.sigma in let sigma_fp' = List.map ~f:(do_hpred true) prop.Prop.sigma_fp in let prop' = Prop.set prop ~sigma:sigma' ~sigma_fp:sigma_fp' in let prop'' = return_val (Prop.normalize tenv prop') in [(prop'', path)] - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + (** take a pointer to a struct and a value, and set a hidden field in the struct to the given value *) let execute___set_hidden_field {Builtin.tenv; pdesc; prop_; path; args} : Builtin.ret_typ = match args with - | [(lexp1, _); (lexp2, _)] - -> let pname = Procdesc.get_proc_name pdesc in + | [(lexp1, _); (lexp2, _)] -> + let pname = Procdesc.get_proc_name pdesc in let n_lexp1, prop__ = check_arith_norm_exp tenv pname lexp1 prop_ in let n_lexp2, prop = check_arith_norm_exp tenv pname lexp2 prop__ in - let foot_var = (lazy (Exp.Var (Ident.create_fresh Ident.kfootprint))) in + let foot_var = lazy (Exp.Var (Ident.create_fresh Ident.kfootprint)) in let filter_fld_hidden (f, _) = Typ.Fieldname.is_hidden f in let has_fld_hidden fsel = List.exists ~f:filter_fld_hidden fsel in let do_hpred in_foot hpred = match hpred with - | Sil.Hpointsto (e, Sil.Estruct (fsel, inst), texp) when Exp.equal e n_lexp1 && not in_foot - -> let se = Sil.Eexp (n_lexp2, Sil.inst_none) in + | Sil.Hpointsto (e, Sil.Estruct (fsel, inst), texp) when Exp.equal e n_lexp1 && not in_foot -> + let se = Sil.Eexp (n_lexp2, Sil.inst_none) in let fsel' = (Typ.Fieldname.hidden, se) :: List.filter ~f:(fun x -> not (filter_fld_hidden x)) fsel in Sil.Hpointsto (e, Sil.Estruct (fsel', inst), texp) | Sil.Hpointsto (e, Sil.Estruct (fsel, inst), texp) - when Exp.equal e n_lexp1 && in_foot && not (has_fld_hidden fsel) - -> let foot_e = Lazy.force foot_var in + when Exp.equal e n_lexp1 && in_foot && not (has_fld_hidden fsel) -> + let foot_e = Lazy.force foot_var in let se = Sil.Eexp (foot_e, Sil.inst_none) in let fsel' = (Typ.Fieldname.hidden, se) :: fsel in Sil.Hpointsto (e, Sil.Estruct (fsel', inst), texp) - | _ - -> hpred + | _ -> + hpred in let sigma' = List.map ~f:(do_hpred false) prop.Prop.sigma in let sigma_fp' = List.map ~f:(do_hpred true) prop.Prop.sigma_fp in let prop' = Prop.set prop ~sigma:sigma' ~sigma_fp:sigma_fp' in let prop'' = Prop.normalize tenv prop' in [(prop'', path)] - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + (* Update the objective-c hidden counter by applying the operation op and the operand delta.*) (* Eg. op=+/- delta is an integer *) let execute___objc_counter_update ~mask_errors op delta {Builtin.pdesc; tenv; prop_; path; args; loc} : Builtin.ret_typ = match args with - | [(lexp, ({Typ.desc= Tstruct _} as typ | {desc= Tptr (({desc= Tstruct _} as typ), _)}))] - -> (* Assumes that lexp is a temp n$1 that has the value of the object. *) + | [(lexp, (({Typ.desc= Tstruct _} as typ) | {desc= Tptr (({desc= Tstruct _} as typ), _)}))] -> + (* Assumes that lexp is a temp n$1 that has the value of the object. *) (* This is the case as a call f(o) it's translates as n$1=*&o; f(n$1) *) (* n$2 = *n$1.hidden *) let tmp = Ident.create_fresh Ident.knormal in @@ -490,66 +514,75 @@ let execute___objc_counter_update ~mask_errors op delta [counter_to_tmp; update_counter; Sil.Remove_temps ([tmp], loc)] in SymExec.instrs ~mask_errors tenv pdesc update_counter_instrs [(prop_, path)] - | [(_, typ)] - -> L.d_str ("Trying to update hidden field of non-struct value. Type: " ^ Typ.to_string typ) ; + | [(_, typ)] -> + L.d_str ("Trying to update hidden field of non-struct value. Type: " ^ Typ.to_string typ) ; assert false - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + (* Given a list of args checks if the first is the flag indicating whether is a call to retain/release for which we have to suppress NPE report or not. If the flag is present it is removed from the list of args. *) let get_suppress_npe_flag args = match args with - | (Exp.Const Const.Cint i, {Typ.desc= Tint Typ.IBool}) :: args' when IntLit.isone i - -> (false, args') (* this is a CFRelease/CFRetain *) - | _ - -> (true, args) + | (Exp.Const Const.Cint i, {Typ.desc= Tint Typ.IBool}) :: args' when IntLit.isone i -> + (false, args') (* this is a CFRelease/CFRetain *) + | _ -> + (true, args) + let execute___objc_retain_impl ({Builtin.tenv; prop_; args; ret_id} as builtin_args) : Builtin.ret_typ = let mask_errors, args' = get_suppress_npe_flag args in match args' with - | [(lexp, _)] - -> let prop = return_result tenv lexp prop_ ret_id in + | [(lexp, _)] -> + let prop = return_result tenv lexp prop_ ret_id in execute___objc_counter_update ~mask_errors Binop.PlusA IntLit.one {builtin_args with Builtin.prop_= prop; args= args'} - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + let execute___objc_retain builtin_args : Builtin.ret_typ = if Config.objc_memory_model_on then execute___objc_retain_impl builtin_args else execute___no_op builtin_args.Builtin.prop_ builtin_args.Builtin.path + let execute___objc_retain_cf builtin_args : Builtin.ret_typ = execute___objc_retain_impl builtin_args + let execute___objc_release_impl ({Builtin.args} as builtin_args) : Builtin.ret_typ = let mask_errors, args' = get_suppress_npe_flag args in execute___objc_counter_update ~mask_errors Binop.MinusA IntLit.one {builtin_args with Builtin.args= args'} + let execute___objc_release builtin_args : Builtin.ret_typ = if Config.objc_memory_model_on then execute___objc_release_impl builtin_args else execute___no_op builtin_args.Builtin.prop_ builtin_args.Builtin.path + let execute___objc_release_cf builtin_args : Builtin.ret_typ = execute___objc_release_impl builtin_args + (** Set the attibute of the value as objc autoreleased *) let execute___set_autorelease_attribute {Builtin.tenv; pdesc; prop_; path; ret_id; args} : Builtin.ret_typ = match (args, ret_id) with - | [(lexp, _)], _ - -> let pname = Procdesc.get_proc_name pdesc in + | [(lexp, _)], _ -> + let pname = Procdesc.get_proc_name pdesc in let prop = return_result tenv lexp prop_ ret_id in if Config.objc_memory_model_on then let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop in let prop' = Attribute.add_or_replace tenv prop (Apred (Aautorelease, [n_lexp])) in [(prop', path)] else execute___no_op prop path - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + (** Release all the objects in the pool *) let execute___release_autorelease_pool ({Builtin.tenv; prop_; path} as builtin_args) @@ -559,57 +592,63 @@ let execute___release_autorelease_pool ({Builtin.tenv; prop_; path} as builtin_a let prop_without_attribute = Attribute.remove_for_attr tenv prop_ Aautorelease in let call_release res atom = match (res, atom) with - | (prop', path') :: _, Sil.Apred (_, exp :: _) - -> List.find + | (prop', path') :: _, Sil.Apred (_, exp :: _) -> + List.find ~f:(function Sil.Hpointsto (e1, _, _) -> Exp.equal e1 exp | _ -> false) prop_.Prop.sigma |> Option.value_map ~f:(function - | Sil.Hpointsto (_, _, Exp.Sizeof {typ}) - -> let res1 = + | Sil.Hpointsto (_, _, Exp.Sizeof {typ}) -> + let res1 = execute___objc_release {builtin_args with Builtin.args= [(exp, typ)]; prop_= prop'; path= path'} in res1 - | _ - -> res) + | _ -> + res) ~default:res - | _ - -> res + | _ -> + res in List.fold ~f:call_release ~init:[(prop_without_attribute, path)] autoreleased_objects else execute___no_op prop_ path + let set_attr tenv pdesc prop path exp attr = let pname = Procdesc.get_proc_name pdesc in let n_lexp, prop = check_arith_norm_exp tenv pname exp prop in [(Attribute.add_or_replace tenv prop (Apred (attr, [n_lexp])), path)] + let delete_attr tenv pdesc prop path exp attr = let pname = Procdesc.get_proc_name pdesc in let n_lexp, prop = check_arith_norm_exp tenv pname exp prop in [(Attribute.remove tenv prop (Apred (attr, [n_lexp])), path)] + (** Set attibute att *) let execute___set_attr attr {Builtin.tenv; pdesc; prop_; path; args} : Builtin.ret_typ = match args with - | [(lexp, _)] - -> set_attr tenv pdesc prop_ path lexp attr - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | [(lexp, _)] -> + set_attr tenv pdesc prop_ path lexp attr + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + (** Delete the locked attibute of the value*) let execute___delete_locked_attribute {Builtin.tenv; prop_; pdesc; path; args} : Builtin.ret_typ = match args with - | [(lexp, _)] - -> delete_attr tenv pdesc prop_ path lexp PredSymb.Alocked - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | [(lexp, _)] -> + delete_attr tenv pdesc prop_ path lexp PredSymb.Alocked + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + (** Set the attibute of the value as locked*) let execute___set_locked_attribute builtin_args : Builtin.ret_typ = execute___set_attr PredSymb.Alocked builtin_args + (** Set the attibute of the value as resource/unlocked*) let execute___set_unlocked_attribute ({Builtin.pdesc; loc} as builtin_args) : Builtin.ret_typ = let pname = Procdesc.get_proc_name pdesc in @@ -623,14 +662,16 @@ let execute___set_unlocked_attribute ({Builtin.pdesc; loc} as builtin_args) : Bu in execute___set_attr (PredSymb.Aresource ra) builtin_args + (** Set the attibute of the value as wont leak*) let execute___set_wont_leak_attribute builtin_args : Builtin.ret_typ = execute___set_attr PredSymb.Awont_leak builtin_args + let execute___objc_cast {Builtin.tenv; pdesc; prop_; path; ret_id; args} : Builtin.ret_typ = match args with | [(val1_, _); (texp2_, _)] - -> ( + -> ( let pname = Procdesc.get_proc_name pdesc in let val1, prop__ = check_arith_norm_exp tenv pname val1_ prop_ in let texp2, prop = check_arith_norm_exp tenv pname texp2_ prop__ in @@ -640,30 +681,32 @@ let execute___objc_cast {Builtin.tenv; pdesc; prop_; path; ret_id; args} : Built prop.Prop.sigma |> Option.map ~f:(fun hpred -> match (hpred, texp2) with - | Sil.Hpointsto (val1, _, _), Exp.Sizeof _ - -> let prop' = replace_ptsto_texp tenv prop val1 texp2 in + | Sil.Hpointsto (val1, _, _), Exp.Sizeof _ -> + let prop' = replace_ptsto_texp tenv prop val1 texp2 in [(return_result tenv val1 prop' ret_id, path)] - | _ - -> [(return_result tenv val1 prop ret_id, path)] ) + | _ -> + [(return_result tenv val1 prop ret_id, path)] ) with - | Some res - -> res - | None - -> [(return_result tenv val1 prop ret_id, path)] ) - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | Some res -> + res + | None -> + [(return_result tenv val1 prop ret_id, path)] ) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + let execute_abort {Builtin.proc_name} : Builtin.ret_typ = raise (Exceptions.Precondition_not_found (Localise.verbatim_desc (Typ.Procname.to_string proc_name), __POS__)) + let execute_exit {Builtin.prop_; path} : Builtin.ret_typ = SymExec.diverge prop_ path let _execute_free tenv mk loc acc iter = match Prop.prop_iter_current tenv iter with - | Sil.Hpointsto (lexp, _, _), [] - -> let prop = Prop.prop_iter_remove_curr_then_to_prop tenv iter in + | Sil.Hpointsto (lexp, _, _), [] -> + let prop = Prop.prop_iter_remove_curr_then_to_prop tenv iter in let pname = PredSymb.mem_dealloc_pname mk in let ra = { PredSymb.ra_kind= PredSymb.Rrelease @@ -678,21 +721,22 @@ let _execute_free tenv mk loc acc iter = (Apred (Aresource ra, [lexp])) in p_res :: acc - | Sil.Hpointsto _, _ :: _ - -> assert false (* alignment error *) - | _ - -> assert false + | Sil.Hpointsto _, _ :: _ -> + assert false (* alignment error *) + | _ -> + assert false + (* should not happen *) let _execute_free_nonzero mk pdesc tenv instr prop lexp typ loc = try match Prover.is_root tenv prop lexp lexp with - | None - -> L.d_strln ".... Alignment Error: Freed a non root ...." ; + | None -> + L.d_strln ".... Alignment Error: Freed a non root ...." ; assert false - | Some _ - -> let prop_list = + | Some _ -> + let prop_list = List.fold ~f:(_execute_free tenv mk loc) ~init:[] (Rearrange.rearrange pdesc tenv lexp typ prop loc) in @@ -709,10 +753,11 @@ let _execute_free_nonzero mk pdesc tenv instr prop lexp typ loc = L.d_ln () ; raise (Exceptions.Array_of_pointsto __POS__) ) + let execute_free mk {Builtin.pdesc; instr; tenv; prop_; path; args; loc} : Builtin.ret_typ = match args with - | [(lexp, typ)] - -> let pname = Procdesc.get_proc_name pdesc in + | [(lexp, typ)] -> + let pname = Procdesc.get_proc_name pdesc in let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in let prop_nonzero = (* case n_lexp!=0 *) @@ -727,51 +772,53 @@ let execute_free mk {Builtin.pdesc; instr; tenv; prop_; path; args; loc} : Built @ (* model: if 0 then skip else _execute_free_nonzero *) List.concat_map ~f:(fun p -> - _execute_free_nonzero mk pdesc tenv instr p (Prop.exp_normalize_prop tenv p lexp) typ - loc) + _execute_free_nonzero mk pdesc tenv instr p + (Prop.exp_normalize_prop tenv p lexp) + typ loc) prop_nonzero in List.map ~f:(fun p -> (p, path)) plist - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + let execute_alloc mk can_return_null {Builtin.pdesc; tenv; prop_; path; ret_id; args; loc} : Builtin.ret_typ = let pname = Procdesc.get_proc_name pdesc in let rec evaluate_char_sizeof e = match e with - | Exp.Var _ - -> e - | Exp.UnOp (uop, e', typ) - -> Exp.UnOp (uop, evaluate_char_sizeof e', typ) - | Exp.BinOp (bop, e1', e2') - -> Exp.BinOp (bop, evaluate_char_sizeof e1', evaluate_char_sizeof e2') + | Exp.Var _ -> + e + | Exp.UnOp (uop, e', typ) -> + Exp.UnOp (uop, evaluate_char_sizeof e', typ) + | Exp.BinOp (bop, e1', e2') -> + Exp.BinOp (bop, evaluate_char_sizeof e1', evaluate_char_sizeof e2') | Exp.Exn _ | Exp.Closure _ | Exp.Const _ | Exp.Cast _ | Exp.Lvar _ | Exp.Lfield _ - | Exp.Lindex _ - -> e + | Exp.Lindex _ -> + e | Exp.Sizeof {typ= {Typ.desc= Tarray ({Typ.desc= Tint ik}, _, _)}; dynamic_length= Some len} - when Typ.ikind_is_char ik - -> evaluate_char_sizeof len + when Typ.ikind_is_char ik -> + evaluate_char_sizeof len | Exp.Sizeof {typ= {Typ.desc= Tarray ({Typ.desc= Tint ik}, Some len, _)}; dynamic_length= None} - when Typ.ikind_is_char ik - -> evaluate_char_sizeof (Exp.Const (Const.Cint len)) - | Exp.Sizeof _ - -> e + when Typ.ikind_is_char ik -> + evaluate_char_sizeof (Exp.Const (Const.Cint len)) + | Exp.Sizeof _ -> + e in let size_exp, procname = match args with - | [(size_exp, _)] - -> (* for malloc and __new *) + | [(size_exp, _)] -> + (* for malloc and __new *) (size_exp, PredSymb.mem_alloc_pname mk) - | [(size_exp, _); (Exp.Const Const.Cfun pname, _)] - -> (size_exp, pname) - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | [(size_exp, _); (Exp.Const Const.Cfun pname, _)] -> + (size_exp, pname) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) in let ret_id = match ret_id with Some (ret_id, _) -> ret_id | _ -> Ident.create_fresh Ident.kprimed @@ -809,14 +856,15 @@ let execute_alloc mk can_return_null {Builtin.pdesc; tenv; prop_; path; ret_id; [(prop_alloc, path); (prop_null, path)] else [(prop_alloc, path)] + let execute___cxx_typeid ({Builtin.pdesc; tenv; prop_; args; loc} as r) : Builtin.ret_typ = match args with | type_info_exp :: rest - -> ( + -> ( let res = execute_alloc PredSymb.Mnew false {r with args= [type_info_exp]} in match rest with - | [(field_exp, _); (lexp, typ_)] - -> let pname = Procdesc.get_proc_name pdesc in + | [(field_exp, _); (lexp, typ_)] -> + let pname = Procdesc.get_proc_name pdesc in let n_lexp, prop = check_arith_norm_exp tenv pname lexp prop_ in let typ = List.find @@ -831,85 +879,90 @@ let execute___cxx_typeid ({Builtin.pdesc; tenv; prop_; args; loc} as r) : Builti Sil.Store (field_exp, Typ.mk Tvoid, Exp.Const (Const.Cstr typ_string), loc) in SymExec.instrs ~mask_errors:true tenv pdesc [set_instr] res - | _ - -> res ) - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + res ) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + let execute_pthread_create ({Builtin.tenv; prop_; path; args} as builtin_args) : Builtin.ret_typ = match args with | [_; _; start_routine; arg] - -> ( + -> ( let routine_name = Prop.exp_normalize_prop tenv prop_ (fst start_routine) in let routine_arg = Prop.exp_normalize_prop tenv prop_ (fst arg) in match (routine_name, snd start_routine) with | Exp.Lvar pvar, _ - -> ( + -> ( let fun_name = Pvar.get_name pvar in let fun_string = Mangled.to_string fun_name in L.d_strln ("pthread_create: calling function " ^ fun_string) ; match Specs.get_summary (Typ.Procname.from_string_c_fun fun_string) with - | None - -> assert false - | Some callee_summary - -> SymExec.proc_call callee_summary {builtin_args with args= [(routine_arg, snd arg)]} ) - | _ - -> L.d_str "pthread_create: unknown function " ; + | None -> + assert false + | Some callee_summary -> + SymExec.proc_call callee_summary {builtin_args with args= [(routine_arg, snd arg)]} ) + | _ -> + L.d_str "pthread_create: unknown function " ; Sil.d_exp routine_name ; L.d_strln ", skipping call." ; [(prop_, path)] ) - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + let execute_skip {Builtin.prop_; path} : Builtin.ret_typ = [(prop_, path)] let execute_scan_function skip_n_arguments ({Builtin.args} as call_args) : Builtin.ret_typ = match args with - | _ when List.length args >= skip_n_arguments - -> let varargs = ref args in + | _ when List.length args >= skip_n_arguments -> + let varargs = ref args in varargs := List.drop !varargs skip_n_arguments ; SymExec.unknown_or_scan_call ~is_scan:true ~reason:"execute scan function" None Annot.Item.empty {call_args with args= !varargs} - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + let execute__unwrap_exception {Builtin.tenv; pdesc; prop_; path; ret_id; args} : Builtin.ret_typ = match args with | [(ret_exn, _)] - -> ( + -> ( let pname = Procdesc.get_proc_name pdesc in let n_ret_exn, prop = check_arith_norm_exp tenv pname ret_exn prop_ in match n_ret_exn with - | Exp.Exn exp - -> let prop_with_exn = return_result tenv exp prop ret_id in + | Exp.Exn exp -> + let prop_with_exn = return_result tenv exp prop ret_id in [(prop_with_exn, path)] - | _ - -> assert false ) - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + assert false ) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + let execute_return_first_argument {Builtin.tenv; pdesc; prop_; path; ret_id; args} : Builtin.ret_typ = match args with - | (arg1_, _) :: _ - -> let pname = Procdesc.get_proc_name pdesc in + | (arg1_, _) :: _ -> + let pname = Procdesc.get_proc_name pdesc in let arg1, prop = check_arith_norm_exp tenv pname arg1_ prop_ in let prop' = return_result tenv arg1 prop ret_id in [(prop', path)] - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + let execute___split_get_nth {Builtin.tenv; pdesc; prop_; path; ret_id; args} : Builtin.ret_typ = match args with | [(lexp1, _); (lexp2, _); (lexp3, _)] - -> ( + -> ( let pname = Procdesc.get_proc_name pdesc in let n_lexp1, prop__ = check_arith_norm_exp tenv pname lexp1 prop_ in let n_lexp2, prop___ = check_arith_norm_exp tenv pname lexp2 prop__ in let n_lexp3, prop = check_arith_norm_exp tenv pname lexp3 prop___ in match (n_lexp1, n_lexp2, n_lexp3) with | Exp.Const Const.Cstr str1, Exp.Const Const.Cstr str2, Exp.Const Const.Cint n_sil - -> ( + -> ( let n = IntLit.to_int n_sil in try let parts = Str.split (Str.regexp_string str2) str1 in @@ -917,21 +970,23 @@ let execute___split_get_nth {Builtin.tenv; pdesc; prop_; path; ret_id; args} : B let res = Exp.Const (Const.Cstr n_part) in [(return_result tenv res prop ret_id, path)] with Not_found -> assert false ) - | _ - -> [(prop, path)] ) - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + [(prop, path)] ) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + (* forces the expression passed as parameter to be assumed true at the point where this builtin is called, diverges if this causes an inconsistency *) let execute___infer_assume {Builtin.tenv; prop_; path; args} : Builtin.ret_typ = match args with - | [(lexp, _)] - -> let prop_assume = Prop.conjoin_eq tenv lexp (Exp.bool true) prop_ in + | [(lexp, _)] -> + let prop_assume = Prop.conjoin_eq tenv lexp (Exp.bool true) prop_ in if Prover.check_inconsistency tenv prop_assume then SymExec.diverge prop_assume path else [(prop_assume, path)] - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + (* creates a named error state *) let execute___infer_fail {Builtin.pdesc; tenv; prop_; path; args; loc} : Builtin.ret_typ = @@ -939,86 +994,94 @@ let execute___infer_fail {Builtin.pdesc; tenv; prop_; path; args; loc} : Builtin match args with | [(lexp_msg, _)] -> ( match Prop.exp_normalize_prop tenv prop_ lexp_msg with - | Exp.Const Const.Cstr str - -> str - | _ - -> assert false ) - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | Exp.Const Const.Cstr str -> + str + | _ -> + assert false ) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) in let set_instr = Sil.Store (Exp.Lvar Sil.custom_error, Typ.mk Tvoid, Exp.Const (Const.Cstr error_str), loc) in SymExec.instrs ~mask_errors:true tenv pdesc [set_instr] [(prop_, path)] + (* translate builtin assertion failure *) let execute___assert_fail {Builtin.pdesc; tenv; prop_; path; args; loc} : Builtin.ret_typ = let error_str = match List.length args with - | 4 - -> Config.default_failure_name - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | 4 -> + Config.default_failure_name + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) in let set_instr = Sil.Store (Exp.Lvar Sil.custom_error, Typ.mk Tvoid, Exp.Const (Const.Cstr error_str), loc) in SymExec.instrs ~mask_errors:true tenv pdesc [set_instr] [(prop_, path)] + let execute_objc_alloc_no_fail symb_state typ alloc_fun_opt {Builtin.pdesc; tenv; ret_id; loc} = let alloc_fun = Exp.Const (Const.Cfun BuiltinDecl.__objc_alloc_no_fail) in let ptr_typ = Typ.mk (Tptr (typ, Typ.Pk_pointer)) in let sizeof_typ = Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.exact} in let alloc_fun_exp = match alloc_fun_opt with - | Some pname - -> [(Exp.Const (Const.Cfun pname), Typ.mk Tvoid)] - | None - -> [] + | Some pname -> + [(Exp.Const (Const.Cfun pname), Typ.mk Tvoid)] + | None -> + [] in let alloc_instr = Sil.Call (ret_id, alloc_fun, [(sizeof_typ, ptr_typ)] @ alloc_fun_exp, loc, CallFlags.default) in SymExec.instrs tenv pdesc [alloc_instr] symb_state + (* NSArray models *) let execute_objc_NSArray_alloc_no_fail builtin_args symb_state pname = let ret_typ = match builtin_args.Builtin.ret_id with - | Some (_, typ) - -> typ - | None - -> Typ.mk (Tptr (Typ.mk Tvoid, Pk_pointer)) + | Some (_, typ) -> + typ + | None -> + Typ.mk (Tptr (Typ.mk Tvoid, Pk_pointer)) in execute_objc_alloc_no_fail symb_state ret_typ (Some pname) builtin_args + let execute_NSArray_arrayWithObjects_count builtin_args = let n_formals = 1 in let res = SymExec.check_variadic_sentinel ~fails_on_nil:true n_formals (0, 1) builtin_args in execute_objc_NSArray_alloc_no_fail builtin_args res BuiltinDecl.nsArray_arrayWithObjectsCount + let execute_NSArray_arrayWithObjects builtin_args = let n_formals = 1 in let res = SymExec.check_variadic_sentinel n_formals (0, 1) builtin_args in execute_objc_NSArray_alloc_no_fail builtin_args res BuiltinDecl.nsArray_arrayWithObjects + (* NSDictionary models *) let execute_objc_NSDictionary_alloc_no_fail symb_state pname builtin_args = let ret_typ = match builtin_args.Builtin.ret_id with - | Some (_, typ) - -> typ - | None - -> Typ.mk (Tptr (Typ.mk Tvoid, Pk_pointer)) + | Some (_, typ) -> + typ + | None -> + Typ.mk (Tptr (Typ.mk Tvoid, Pk_pointer)) in execute_objc_alloc_no_fail symb_state ret_typ (Some pname) builtin_args + let execute___objc_dictionary_literal builtin_args = let n_formals = 1 in let res' = SymExec.check_variadic_sentinel ~fails_on_nil:true n_formals (0, 1) builtin_args in let pname = BuiltinDecl.__objc_dictionary_literal in execute_objc_NSDictionary_alloc_no_fail res' pname builtin_args + (* only used in Quandary, so ok to skip *) let __array_access = Builtin.register BuiltinDecl.__array_access execute_skip @@ -1044,6 +1107,7 @@ let __delete_array = Builtin.register BuiltinDecl.__delete_array (execute_free P let __delete_locked_attribute = Builtin.register BuiltinDecl.__delete_locked_attribute execute___delete_locked_attribute + let __exit = Builtin.register BuiltinDecl.__exit execute_exit (* return the length of the array passed as a parameter *) @@ -1068,27 +1132,32 @@ let __instanceof = Builtin.register BuiltinDecl.__instanceof execute___instanceo let __method_set_ignore_attribute = Builtin.register BuiltinDecl.__method_set_ignore_attribute execute___method_set_ignore_attribute + let __new = Builtin.register BuiltinDecl.__new (execute_alloc PredSymb.Mnew false) let __new_array = Builtin.register BuiltinDecl.__new_array (execute_alloc PredSymb.Mnew_array false) + let __objc_alloc = Builtin.register BuiltinDecl.__objc_alloc (execute_alloc PredSymb.Mobjc true) (* like __objc_alloc, but does not return nil *) let __objc_alloc_no_fail = Builtin.register BuiltinDecl.__objc_alloc_no_fail (execute_alloc PredSymb.Mobjc false) + let __objc_cast = Builtin.register BuiltinDecl.__objc_cast execute___objc_cast let __objc_dictionary_literal = Builtin.register BuiltinDecl.__objc_dictionary_literal execute___objc_dictionary_literal + let __objc_release = Builtin.register BuiltinDecl.__objc_release execute___objc_release let __objc_release_autorelease_pool = Builtin.register BuiltinDecl.__objc_release_autorelease_pool execute___release_autorelease_pool + let __objc_release_cf = Builtin.register BuiltinDecl.__objc_release_cf execute___objc_release_cf let __objc_retain = Builtin.register BuiltinDecl.__objc_retain execute___objc_retain @@ -1106,39 +1175,49 @@ let __print_value = Builtin.register BuiltinDecl.__print_value execute___print_v let __require_allocated_array = Builtin.register BuiltinDecl.__require_allocated_array execute___require_allocated_array + let __set_array_length = Builtin.register BuiltinDecl.__set_array_length execute___set_array_length let __set_autorelease_attribute = Builtin.register BuiltinDecl.__set_autorelease_attribute execute___set_autorelease_attribute + let __set_file_attribute = Builtin.register BuiltinDecl.__set_file_attribute execute___set_file_attribute + (* set a hidden field in the struct to the given value *) let __set_hidden_field = Builtin.register BuiltinDecl.__set_hidden_field execute___set_hidden_field let __set_lock_attribute = Builtin.register BuiltinDecl.__set_lock_attribute execute___set_lock_attribute + let __set_locked_attribute = Builtin.register BuiltinDecl.__set_locked_attribute execute___set_locked_attribute + let __set_mem_attribute = Builtin.register BuiltinDecl.__set_mem_attribute execute___set_mem_attribute + let __set_observer_attribute = Builtin.register BuiltinDecl.__set_observer_attribute (execute___set_attr PredSymb.Aobserver) + let __set_unlocked_attribute = Builtin.register BuiltinDecl.__set_unlocked_attribute execute___set_unlocked_attribute + let __set_unsubscribed_observer_attribute = Builtin.register BuiltinDecl.__set_unsubscribed_observer_attribute (execute___set_attr PredSymb.Aunsubscribed_observer) + let __set_wont_leak_attribute = Builtin.register BuiltinDecl.__set_wont_leak_attribute execute___set_wont_leak_attribute + (* splits a string given a separator and returns the nth string *) let __split_get_nth = Builtin.register BuiltinDecl.__split_get_nth execute___split_get_nth @@ -1159,15 +1238,19 @@ let fwscanf = Builtin.register BuiltinDecl.fwscanf (execute_scan_function 2) let malloc = Builtin.register BuiltinDecl.malloc (execute_alloc PredSymb.Mmalloc (not Config.unsafe_malloc)) + let malloc_no_fail = Builtin.register BuiltinDecl.malloc_no_fail (execute_alloc PredSymb.Mmalloc false) + let nsArray_arrayWithObjects = Builtin.register BuiltinDecl.nsArray_arrayWithObjects execute_NSArray_arrayWithObjects + let nsArray_arrayWithObjectsCount = Builtin.register BuiltinDecl.nsArray_arrayWithObjectsCount execute_NSArray_arrayWithObjects_count + (* model throwing exception in objc/c++ as divergence *) let objc_cpp_throw = Builtin.register BuiltinDecl.objc_cpp_throw execute_exit diff --git a/infer/src/backend/Differential.ml b/infer/src/backend/Differential.ml index fcc22add4..7bdf5d859 100644 --- a/infer/src/backend/Differential.ml +++ b/infer/src/backend/Differential.ml @@ -20,21 +20,23 @@ let of_reports ~(current_report: Jsonbug_t.report) ~(previous_report: Jsonbug_t. in let fold_aux ~key:_ ~data (left, both, right) = match data with - | `Left left' - -> (List.rev_append left' left, both, right) - | `Both (both', _) - -> (left, List.rev_append both' both, right) - | `Right right' - -> (left, both, List.rev_append right' right) + | `Left left' -> + (List.rev_append left' left, both, right) + | `Both (both', _) -> + (left, List.rev_append both' both, right) + | `Right right' -> + (left, both, List.rev_append right' right) in let introduced, preexisting, fixed = Map.fold2 (to_map current_report) (to_map previous_report) ~f:fold_aux ~init:([], [], []) in {introduced; fixed; preexisting} + let to_files {introduced; fixed; preexisting} destdir = Out_channel.write_all (destdir ^/ "introduced.json") ~data:(Jsonbug_j.string_of_report introduced) ; Out_channel.write_all (destdir ^/ "fixed.json") ~data:(Jsonbug_j.string_of_report fixed) ; Out_channel.write_all (destdir ^/ "preexisting.json") ~data:(Jsonbug_j.string_of_report preexisting) + diff --git a/infer/src/backend/DifferentialFilters.ml b/infer/src/backend/DifferentialFilters.ml index 0b8e00de8..e786c961e 100644 --- a/infer/src/backend/DifferentialFilters.ml +++ b/infer/src/backend/DifferentialFilters.ml @@ -29,22 +29,22 @@ module FileRenamings = struct try match assoc with | `Assoc l - -> ( + -> ( let current_opt = List.Assoc.find ~equal:String.equal l "current" in let previous_opt = List.Assoc.find ~equal:String.equal l "previous" in match (current_opt, previous_opt) with - | Some `String current, Some `String previous - -> {current; previous} - | None, _ - -> raise (Yojson.Json_error "\"current\" field missing") - | Some _, None - -> raise (Yojson.Json_error "\"previous\" field missing") - | Some _, Some `String _ - -> raise (Yojson.Json_error "\"current\" field is not a string") - | Some _, Some _ - -> raise (Yojson.Json_error "\"previous\" field is not a string") ) - | _ - -> raise (Yojson.Json_error "not a record") + | Some `String current, Some `String previous -> + {current; previous} + | None, _ -> + raise (Yojson.Json_error "\"current\" field missing") + | Some _, None -> + raise (Yojson.Json_error "\"previous\" field missing") + | Some _, Some `String _ -> + raise (Yojson.Json_error "\"current\" field is not a string") + | Some _, Some _ -> + raise (Yojson.Json_error "\"previous\" field is not a string") ) + | _ -> + raise (Yojson.Json_error "not a record") with Yojson.Json_error err -> L.(die UserError) "Error parsing file renamings: %s@\nExpected JSON object of the following form: '%s', but instead got: '%s'" @@ -52,10 +52,11 @@ module FileRenamings = struct (Yojson.Basic.to_string assoc) in match j with - | `List json_renamings - -> List.map ~f:renaming_of_assoc json_renamings - | _ - -> L.(die UserError) "Expected JSON list but got '%s'" input + | `List json_renamings -> + List.map ~f:renaming_of_assoc json_renamings + | _ -> + L.(die UserError) "Expected JSON list but got '%s'" input + let from_json_file file : t = from_json (In_channel.read_all file) @@ -63,12 +64,14 @@ module FileRenamings = struct let r = List.find ~f:(fun r -> String.equal current r.current) t in Option.map ~f:(fun r -> r.previous) r + let pp fmt t = let pp_tuple fmt {current; previous} = Format.fprintf fmt "{\"current\": \"%s\", \"previous\": \"%s\"}" current previous in Format.fprintf fmt "[%a]" (Pp.comma_seq pp_tuple) t + module VISIBLE_FOR_TESTING_DO_NOT_USE_DIRECTLY = struct let from_renamings = from_renamings @@ -82,32 +85,33 @@ end intersection of [l1] and [l2] according to [cmd] and additionally satisfy [pred], and [lN'] is [lN] minus [dups]. [dups] contains only one witness for each removed issue, taken from [l1]. *) let relative_complements ~cmp ?(pred= fun _ -> true) l1 l2 = - let rec aux (out_l1, dups, out_l2 as out) in_l1 in_l2 = + let rec aux ((out_l1, dups, out_l2) as out) in_l1 in_l2 = let is_last_seen_dup v = match dups with ld :: _ -> Int.equal (cmp ld v) 0 | [] -> false in match (in_l1, in_l2) with - | i :: is, f :: fs when Int.equal (cmp i f) 0 - -> (* i = f *) + | i :: is, f :: fs when Int.equal (cmp i f) 0 -> + (* i = f *) if pred i then aux (out_l1, i :: dups, out_l2) is fs else aux (i :: out_l1, dups, f :: out_l2) is fs - | i :: is, f :: _ when cmp i f < 0 - -> (* i < f *) + | i :: is, f :: _ when cmp i f < 0 -> + (* i < f *) let out_l1' = if is_last_seen_dup i then out_l1 else i :: out_l1 in aux (out_l1', dups, out_l2) is in_l2 - | _ :: _, f :: fs - -> (* i > f *) + | _ :: _, f :: fs -> + (* i > f *) let out_l2' = if is_last_seen_dup f then out_l2 else f :: out_l2 in aux (out_l1, dups, out_l2') in_l1 fs - | i :: is, [] when is_last_seen_dup i - -> aux out is in_l2 - | [], f :: fs when is_last_seen_dup f - -> aux out in_l1 fs - | _, _ - -> (List.rev_append in_l1 out_l1, dups, List.rev_append in_l2 out_l2) + | i :: is, [] when is_last_seen_dup i -> + aux out is in_l2 + | [], f :: fs when is_last_seen_dup f -> + aux out in_l1 fs + | _, _ -> + (List.rev_append in_l1 out_l1, dups, List.rev_append in_l2 out_l2) in let l1_sorted = List.sort ~cmp l1 in let l2_sorted = List.sort ~cmp l2 in aux ([], [], []) l1_sorted l2_sorted + type issue_file_with_renaming = Jsonbug_t.jsonbug * string option let skip_duplicated_types_on_filenames renamings (diff: Differential.t) : Differential.t = @@ -118,7 +122,7 @@ let skip_duplicated_types_on_filenames renamings (diff: Differential.t) : Differ in String.compare f1 f2 in - let cmp (issue1, _ as issue_with_previous_file1) (issue2, _ as issue_with_previous_file2) = + let cmp ((issue1, _) as issue_with_previous_file1) ((issue2, _) as issue_with_previous_file2) = [%compare : int * string * issue_file_with_renaming] (issue1.Jsonbug_t.key, issue1.Jsonbug_t.bug_type, issue_with_previous_file1) (issue2.Jsonbug_t.key, issue2.Jsonbug_t.bug_type, issue_with_previous_file2) @@ -142,6 +146,7 @@ let skip_duplicated_types_on_filenames renamings (diff: Differential.t) : Differ in {introduced; fixed; preexisting} + let java_anon_class_pattern = Str.regexp "\\$[0-9]+" type procedure_id = string @@ -164,12 +169,14 @@ let compare_procedure_id pid1 pid2 = in String.compare pid1_norm_trimmed pid2_norm_trimmed + let value_of_qualifier_tag qts tag = match List.find ~f:(fun elem -> String.equal elem.Jsonbug_t.tag tag) qts with - | Some qt - -> Some qt.Jsonbug_t.value - | None - -> None + | Some qt -> + Some qt.Jsonbug_t.value + | None -> + None + type file_extension = string [@@deriving compare] @@ -206,10 +213,10 @@ let skip_anonymous_class_renamings (diff: Differential.t) : Differential.t = let pred (issue: Jsonbug_t.jsonbug) = let is_java_file () = match extension issue.file with - | Some ext - -> String.equal (String.lowercase ext) "java" - | None - -> false + | Some ext -> + String.equal (String.lowercase ext) "java" + | None -> + false in let has_anonymous_class_token () = try @@ -224,11 +231,12 @@ let skip_anonymous_class_renamings (diff: Differential.t) : Differential.t = in {introduced; fixed; preexisting= preexisting @ diff.preexisting} + (* Strip issues whose paths are not among those we're interested in *) let interesting_paths_filter (interesting_paths: SourceFile.t list option) = match interesting_paths with - | Some (paths: SourceFile.t list) - -> let interesting_paths_set = + | Some (paths: SourceFile.t list) -> + let interesting_paths_set = paths |> List.filter_map ~f:(fun p -> if not (SourceFile.is_invalid p) && SourceFile.is_under_project_root p then @@ -240,8 +248,9 @@ let interesting_paths_filter (interesting_paths: SourceFile.t list option) = List.filter ~f:(fun issue -> String.Set.mem interesting_paths_set issue.Jsonbug_t.file) report - | None - -> Fn.id + | None -> + Fn.id + let do_filter (diff: Differential.t) (renamings: FileRenamings.t) ~(skip_duplicated_types: bool) ~(interesting_paths: SourceFile.t list option) : Differential.t = @@ -260,6 +269,7 @@ let do_filter (diff: Differential.t) (renamings: FileRenamings.t) ~(skip_duplica ; fixed= apply_paths_filter_if_needed `Fixed diff'.fixed ; preexisting= apply_paths_filter_if_needed `Preexisting diff'.preexisting } + module VISIBLE_FOR_TESTING_DO_NOT_USE_DIRECTLY = struct let relative_complements = relative_complements diff --git a/infer/src/backend/InferAnalyze.ml b/infer/src/backend/InferAnalyze.ml index 4e8fc6b35..bcb9f3096 100644 --- a/infer/src/backend/InferAnalyze.ml +++ b/infer/src/backend/InferAnalyze.ml @@ -21,7 +21,8 @@ let analyze_exe_env_tasks cluster exe_env : Tasks.t = let biabduction_only = Config.equal_analyzer Config.analyzer Config.BiAbduction in if biabduction_only then (* run the biabduction analysis only *) - Tasks.create (Interproc.do_analysis_closures exe_env) + Tasks.create + (Interproc.do_analysis_closures exe_env) ~continuation: ( if Config.write_html || Config.developer_mode then Some @@ -37,6 +38,7 @@ let analyze_exe_env_tasks cluster exe_env : Tasks.t = Callbacks.iterate_callbacks call_graph exe_env ; if Config.write_html then Printer.write_all_html_files cluster) ] + (** Create tasks to analyze a cluster *) let analyze_cluster_tasks cluster_num (cluster: Cluster.t) : Tasks.t = let exe_env = Exe_env.from_cluster cluster in @@ -46,6 +48,7 @@ let analyze_cluster_tasks cluster_num (cluster: Cluster.t) : Tasks.t = "@\nProcessing cluster #%d with %d procedures@." (cluster_num + 1) num_procs ; analyze_exe_env_tasks cluster exe_env + let analyze_cluster cluster_num cluster = Tasks.run (analyze_cluster_tasks cluster_num cluster) let output_json_makefile_stats clusters = @@ -60,13 +63,15 @@ let output_json_makefile_stats clusters = let f = Out_channel.create (Filename.concat Config.results_dir Config.proc_stats_filename) in Yojson.Basic.pretty_to_channel f file_stats + let process_cluster_cmdline fname = match Cluster.load_from_file (DB.filename_from_string fname) with - | None - -> (if Config.keep_going then L.internal_error else L.die InternalError) + | None -> + (if Config.keep_going then L.internal_error else L.die InternalError) "Cannot find cluster file %s@." fname - | Some (nr, cluster) - -> analyze_cluster (nr - 1) cluster + | Some (nr, cluster) -> + analyze_cluster (nr - 1) cluster + let print_legend () = L.progress "Starting analysis...@\n" ; @@ -84,6 +89,7 @@ let print_legend () = Config.log_analysis_recursion_timeout ) ; L.progress "@\n@?" + let cluster_should_be_analyzed ~changed_files cluster = let fname = DB.source_dir_to_string cluster in (* whether [fname] is one of the [changed_files] *) @@ -105,33 +111,35 @@ let cluster_should_be_analyzed ~changed_files cluster = modified in match is_changed_file with - | Some b - -> b - | None when Config.reactive_mode - -> check_modified () - | None - -> true + | Some b -> + b + | None when Config.reactive_mode -> + check_modified () + | None -> + true + let register_active_checkers () = match Config.analyzer with - | Checkers | Crashcontext - -> RegisterCheckers.get_active_checkers () |> RegisterCheckers.register - | BiAbduction | CaptureOnly | CompileOnly | Linters - -> () + | Checkers | Crashcontext -> + RegisterCheckers.get_active_checkers () |> RegisterCheckers.register + | BiAbduction | CaptureOnly | CompileOnly | Linters -> + () + let main ~changed_files ~makefile = BuiltinDefn.init () ; ( match Config.modified_targets with - | Some file - -> MergeCapture.record_modified_targets_from_file file - | None - -> () ) ; + | Some file -> + MergeCapture.record_modified_targets_from_file file + | None -> + () ) ; register_active_checkers () ; match Config.cluster_cmdline with - | Some fname - -> process_cluster_cmdline fname - | None - -> if Config.allow_specs_cleanup then DB.Results_dir.clean_specs_dir () ; + | Some fname -> + process_cluster_cmdline fname + | None -> + if Config.allow_specs_cleanup then DB.Results_dir.clean_specs_dir () ; let all_clusters = DB.find_source_dirs () in let clusters_to_analyze = List.filter ~f:(cluster_should_be_analyzed ~changed_files) all_clusters @@ -144,10 +152,10 @@ let main ~changed_files ~makefile = (if Int.equal n_clusters_to_analyze 1 then "" else "s") Config.results_dir ; let is_java = - ( lazy - (List.exists - ~f:(fun cl -> DB.string_crc_has_extension ~ext:"java" (DB.source_dir_to_string cl)) - all_clusters) ) + lazy + (List.exists + ~f:(fun cl -> DB.string_crc_has_extension ~ext:"java" (DB.source_dir_to_string cl)) + all_clusters) in L.debug Analysis Quiet "Dynamic dispatch mode: %s@." Config.(string_of_dynamic_dispatch dynamic_dispatch) ; @@ -164,7 +172,8 @@ let main ~changed_files ~makefile = let aggregate_tasks = Tasks.aggregate ~size:Config.procedures_per_process tasks in Tasks.Runner.start runner ~tasks:aggregate_tasks in - List.iteri ~f:cluster_start_tasks clusters_to_analyze ; Tasks.Runner.complete runner ) + List.iteri ~f:cluster_start_tasks clusters_to_analyze ; + Tasks.Runner.complete runner ) else if makefile <> "" then ClusterMakefile.create_cluster_makefile clusters_to_analyze makefile else ( @@ -173,9 +182,11 @@ let main ~changed_files ~makefile = L.progress "@\nAnalysis finished in %as@." Pp.elapsed_time () ) ; output_json_makefile_stats clusters_to_analyze + let register_perf_stats_report () = let stats_dir = Filename.concat Config.results_dir Config.backend_stats_dir_name in let cluster = match Config.cluster_cmdline with Some cl -> "_" ^ cl | None -> "" in let stats_base = Config.perf_stats_prefix ^ Filename.basename cluster ^ ".json" in let stats_file = Filename.concat stats_dir stats_base in PerfStats.register_report_at_exit stats_file + diff --git a/infer/src/backend/InferPrint.ml b/infer/src/backend/InferPrint.ml index 0f25e4596..6f8bf998e 100644 --- a/infer/src/backend/InferPrint.ml +++ b/infer/src/backend/InferPrint.ml @@ -13,7 +13,10 @@ module Hashtbl = Caml.Hashtbl module L = Logging module F = Format -let print_usage_exit err_s = L.user_error "Load Error: %s@\n@." err_s ; Config.print_usage_exit () +let print_usage_exit err_s = + L.user_error "Load Error: %s@\n@." err_s ; + Config.print_usage_exit () + (** return the list of the .specs files in the results dir and libs, if they're defined *) let load_specfiles () = @@ -31,6 +34,7 @@ let load_specfiles () = let result_specs_dir = DB.filename_to_string DB.Results_dir.specs_dir in specs_files_in_dir result_specs_dir + (** Create and initialize latex file *) let begin_latex_file fmt = let author = "Infer " ^ Version.versionString in @@ -38,14 +42,17 @@ let begin_latex_file fmt = let table_of_contents = true in Latex.pp_begin fmt (author, title, table_of_contents) + let error_desc_to_csv_string error_desc = let pp fmt = F.fprintf fmt "%a" Localise.pp_error_desc error_desc in Escape.escape_csv (F.asprintf "%t" pp) + let error_advice_to_csv_string error_desc = let pp fmt = F.fprintf fmt "%a" Localise.pp_error_advice error_desc in Escape.escape_csv (F.asprintf "%t" pp) + let error_desc_to_plain_string error_desc = let pp fmt = F.fprintf fmt "%a" Localise.pp_error_desc error_desc in let s = F.asprintf "%t" pp in @@ -56,6 +63,7 @@ let error_desc_to_plain_string error_desc = in s + let error_desc_to_dotty_string error_desc = Localise.error_desc_get_dotty error_desc let error_desc_to_xml_tags error_desc = @@ -63,6 +71,7 @@ let error_desc_to_xml_tags error_desc = let subtree label contents = Io_infer.Xml.create_tree label [] [Io_infer.Xml.String contents] in List.map ~f:(fun (tag, value) -> subtree tag (Escape.escape_xml value)) tags + let get_bug_hash (kind: string) (type_str: string) (procedure_id: string) (filename: string) (node_key: int) (error_desc: Localise.error_desc) = let qualifier_tag_call_procedure = Localise.error_desc_get_tag_call_procedure error_desc in @@ -76,29 +85,30 @@ let get_bug_hash (kind: string) (type_str: string) (procedure_id: string) (filen , qualifier_tag_call_procedure , qualifier_tag_value ) + let exception_value = "exception" let loc_trace_to_jsonbug_record trace_list ekind = match ekind with - | Exceptions.Kinfo - -> [] - | _ - -> let tag_value_records_of_node_tag nt = + | Exceptions.Kinfo -> + [] + | _ -> + let tag_value_records_of_node_tag nt = match nt with - | Errlog.Condition cond - -> [ {Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= "condition"} + | Errlog.Condition cond -> + [ {Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= "condition"} ; {Jsonbug_j.tag= Io_infer.Xml.tag_branch; value= Printf.sprintf "%B" cond} ] - | Errlog.Exception exn_name - -> let res = [{Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= exception_value}] in + | Errlog.Exception exn_name -> + let res = [{Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= exception_value}] in let exn_str = Typ.Name.name exn_name in if String.is_empty exn_str then res else {Jsonbug_j.tag= Io_infer.Xml.tag_name; value= exn_str} :: res - | Errlog.Procedure_start pname - -> [ {Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= "procedure_start"} + | Errlog.Procedure_start pname -> + [ {Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= "procedure_start"} ; {Jsonbug_j.tag= Io_infer.Xml.tag_name; value= Typ.Procname.to_string pname} ; {Jsonbug_j.tag= Io_infer.Xml.tag_name_id; value= Typ.Procname.to_filename pname} ] - | Errlog.Procedure_end pname - -> [ {Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= "procedure_end"} + | Errlog.Procedure_end pname -> + [ {Jsonbug_j.tag= Io_infer.Xml.tag_kind; value= "procedure_end"} ; {Jsonbug_j.tag= Io_infer.Xml.tag_name; value= Typ.Procname.to_string pname} ; {Jsonbug_j.tag= Io_infer.Xml.tag_name_id; value= Typ.Procname.to_filename pname} ] in @@ -114,6 +124,7 @@ let loc_trace_to_jsonbug_record trace_list ekind = let record_list = List.rev (List.rev_map ~f:trace_item_to_record trace_list) in record_list + type summary_val = { vname: string ; vname_id: string @@ -175,6 +186,7 @@ let summary_values summary = ; vproof_coverage= Printf.sprintf "%2.2f" node_coverage ; vproof_trace= proof_trace } + module ProcsCsv = struct (** Print the header of the procedures csv file, with column names *) let pp_header fmt () = @@ -185,6 +197,7 @@ module ProcsCsv = struct Io_infer.Xml.tag_weight Io_infer.Xml.tag_proof_coverage Io_infer.Xml.tag_rank Io_infer.Xml.tag_in_calls Io_infer.Xml.tag_out_calls Io_infer.Xml.tag_proof_trace + (** Write proc summary stats in csv format *) let pp_summary fmt summary = let pp x = F.fprintf fmt x in @@ -201,6 +214,7 @@ module ProcsCsv = struct pp "%d," sv.vweight ; pp "%s," sv.vproof_coverage ; pp "%s@\n" sv.vproof_trace + end let should_report (issue_kind: Exceptions.err_kind) issue_type error_desc eclass = @@ -232,6 +246,7 @@ let should_report (issue_kind: Exceptions.err_kind) issue_type error_desc eclass issue_bucket_is_high else true + module IssuesCsv = struct let csv_issues_id = ref 0 @@ -243,15 +258,16 @@ module IssuesCsv = struct Io_infer.Xml.tag_key Io_infer.Xml.tag_qualifier_tags Io_infer.Xml.tag_hash "bug_id" "always_report" "advice" + let pp_issue fmt error_filter procname proc_loc_opt (key: Errlog.err_key) (err_data: Errlog.err_data) = let pp x = F.fprintf fmt x in let source_file = match proc_loc_opt with - | Some proc_loc - -> proc_loc.Location.file - | None - -> err_data.loc.Location.file + | Some proc_loc -> + proc_loc.Location.file + | None -> + err_data.loc.Location.file in if key.in_footprint && error_filter source_file key.err_desc key.err_name && should_report key.err_kind key.err_name key.err_desc err_data.err_class @@ -273,10 +289,10 @@ module IssuesCsv = struct let filename = SourceFile.to_string source_file in let always_report = match Localise.error_desc_extract_tag_value key.err_desc "always_report" with - | "" - -> "false" - | v - -> v + | "" -> + "false" + | v -> + v in let trace = Jsonbug_j.string_of_json_trace @@ -303,9 +319,11 @@ module IssuesCsv = struct pp "\"%s\"," always_report ; pp "\"%s\"@\n" err_advice_string + (** Write bug report in csv format *) let pp_issues_of_error_log fmt error_filter _ proc_loc_opt procname err_log = Errlog.iter (pp_issue fmt error_filter procname proc_loc_opt) err_log + end let potential_exception_message = "potential exception at line" @@ -317,6 +335,7 @@ module IssuesJson = struct is_first_item := true ; F.fprintf fmt "[@?" + let pp_json_close fmt () = F.fprintf fmt "]@\n@?" let pp_issue fmt error_filter procname proc_loc_opt (key: Errlog.err_key) @@ -324,10 +343,10 @@ module IssuesJson = struct let pp x = F.fprintf fmt x in let source_file, procedure_start_line = match proc_loc_opt with - | Some proc_loc - -> (proc_loc.Location.file, proc_loc.Location.line) - | None - -> (err_data.loc.Location.file, 0) + | Some proc_loc -> + (proc_loc.Location.file, proc_loc.Location.line) + | None -> + (err_data.loc.Location.file, 0) in if SourceFile.is_invalid source_file then L.(die InternalError) @@ -346,20 +365,20 @@ module IssuesJson = struct let file = SourceFile.to_string source_file in let json_ml_loc = match err_data.loc_in_ml_source with - | Some (file, lnum, cnum, enum) when Config.reports_include_ml_loc - -> Some Jsonbug_j.{file; lnum; cnum; enum} - | _ - -> None + | Some (file, lnum, cnum, enum) when Config.reports_include_ml_loc -> + Some Jsonbug_j.{file; lnum; cnum; enum} + | _ -> + None in let visibility = Exceptions.string_of_visibility err_data.visibility in let qualifier = let base_qualifier = error_desc_to_plain_string key.err_desc in if IssueType.(equal resource_leak) key.err_name then match Errlog.compute_local_exception_line err_data.loc_trace with - | None - -> base_qualifier - | Some line - -> let potential_exception_message = + | None -> + base_qualifier + | Some line -> + let potential_exception_message = Format.asprintf "%a: %s %d" MarkupFormatter.pp_bold "Note" potential_exception_message line in @@ -394,9 +413,11 @@ module IssuesJson = struct if not !is_first_item then pp "," else is_first_item := false ; pp "%s@?" (Jsonbug_j.string_of_jsonbug bug) + (** Write bug report in JSON format *) let pp_issues_of_error_log fmt error_filter _ proc_loc_opt procname err_log = Errlog.iter (pp_issue fmt error_filter procname proc_loc_opt) err_log + end let pp_custom_of_report fmt report fields = @@ -412,71 +433,75 @@ let pp_custom_of_report fmt report fields = in let pp_field index field = match field with - | `Issue_field_bug_class - -> Format.fprintf fmt "%s%s" (comma_separator index) issue.bug_class - | `Issue_field_kind - -> Format.fprintf fmt "%s%s" (comma_separator index) issue.kind - | `Issue_field_bug_type - -> Format.fprintf fmt "%s%s" (comma_separator index) issue.bug_type - | `Issue_field_qualifier - -> Format.fprintf fmt "%s%s" (comma_separator index) issue.qualifier - | `Issue_field_severity - -> Format.fprintf fmt "%s%s" (comma_separator index) issue.severity - | `Issue_field_visibility - -> Format.fprintf fmt "%s%s" (comma_separator index) issue.visibility - | `Issue_field_line - -> Format.fprintf fmt "%s%d" (comma_separator index) issue.line - | `Issue_field_column - -> Format.fprintf fmt "%s%d" (comma_separator index) issue.column - | `Issue_field_procedure - -> Format.fprintf fmt "%s%s" (comma_separator index) issue.procedure - | `Issue_field_procedure_id - -> Format.fprintf fmt "%s%s" (comma_separator index) issue.procedure_id - | `Issue_field_procedure_start_line - -> Format.fprintf fmt "%s%d" (comma_separator index) issue.procedure_start_line - | `Issue_field_file - -> Format.fprintf fmt "%s%s" (comma_separator index) issue.file - | `Issue_field_bug_trace - -> pp_trace fmt issue.bug_trace (comma_separator index) - | `Issue_field_key - -> Format.fprintf fmt "%s%d" (comma_separator index) issue.key - | `Issue_field_hash - -> Format.fprintf fmt "%s%d" (comma_separator index) issue.hash - | `Issue_field_line_offset - -> Format.fprintf fmt "%s%d" (comma_separator index) + | `Issue_field_bug_class -> + Format.fprintf fmt "%s%s" (comma_separator index) issue.bug_class + | `Issue_field_kind -> + Format.fprintf fmt "%s%s" (comma_separator index) issue.kind + | `Issue_field_bug_type -> + Format.fprintf fmt "%s%s" (comma_separator index) issue.bug_type + | `Issue_field_qualifier -> + Format.fprintf fmt "%s%s" (comma_separator index) issue.qualifier + | `Issue_field_severity -> + Format.fprintf fmt "%s%s" (comma_separator index) issue.severity + | `Issue_field_visibility -> + Format.fprintf fmt "%s%s" (comma_separator index) issue.visibility + | `Issue_field_line -> + Format.fprintf fmt "%s%d" (comma_separator index) issue.line + | `Issue_field_column -> + Format.fprintf fmt "%s%d" (comma_separator index) issue.column + | `Issue_field_procedure -> + Format.fprintf fmt "%s%s" (comma_separator index) issue.procedure + | `Issue_field_procedure_id -> + Format.fprintf fmt "%s%s" (comma_separator index) issue.procedure_id + | `Issue_field_procedure_start_line -> + Format.fprintf fmt "%s%d" (comma_separator index) issue.procedure_start_line + | `Issue_field_file -> + Format.fprintf fmt "%s%s" (comma_separator index) issue.file + | `Issue_field_bug_trace -> + pp_trace fmt issue.bug_trace (comma_separator index) + | `Issue_field_key -> + Format.fprintf fmt "%s%d" (comma_separator index) issue.key + | `Issue_field_hash -> + Format.fprintf fmt "%s%d" (comma_separator index) issue.hash + | `Issue_field_line_offset -> + Format.fprintf fmt "%s%d" (comma_separator index) (issue.line - issue.procedure_start_line) - | `Issue_field_procedure_id_without_crc - -> Format.fprintf fmt "%s%s" (comma_separator index) (DB.strip_crc issue.procedure_id) - | `Issue_field_qualifier_contains_potential_exception_note - -> Format.fprintf fmt "%B" + | `Issue_field_procedure_id_without_crc -> + Format.fprintf fmt "%s%s" (comma_separator index) (DB.strip_crc issue.procedure_id) + | `Issue_field_qualifier_contains_potential_exception_note -> + Format.fprintf fmt "%B" (String.is_substring issue.qualifier ~substring:potential_exception_message) in List.iteri ~f:pp_field fields ; Format.fprintf fmt "@." in List.iter ~f:(pp_custom_of_issue fmt) report + let tests_jsonbug_compare bug1 bug2 = let open Jsonbug_t in [%compare : string * string * int * string * int] (bug1.file, bug1.procedure, bug1.line - bug1.procedure_start_line, bug1.bug_type, bug1.hash) (bug2.file, bug2.procedure, bug2.line - bug2.procedure_start_line, bug2.bug_type, bug2.hash) + module IssuesTxt = struct let pp_issue fmt error_filter proc_loc_opt (key: Errlog.err_key) (err_data: Errlog.err_data) = let source_file = match proc_loc_opt with - | Some proc_loc - -> proc_loc.Location.file - | None - -> err_data.loc.Location.file + | Some proc_loc -> + proc_loc.Location.file + | None -> + err_data.loc.Location.file in if key.in_footprint && error_filter source_file key.err_desc key.err_name then Exceptions.pp_err ~node_key:err_data.node_id_key.node_key err_data.loc key.err_kind key.err_name key.err_desc None fmt () + (** Write bug report in text format *) let pp_issues_of_error_log fmt error_filter _ proc_loc_opt _ err_log = Errlog.iter (pp_issue fmt error_filter proc_loc_opt) err_log + end let pp_text_of_report fmt report = @@ -487,6 +512,7 @@ let pp_text_of_report fmt report = in List.iter ~f:pp_row report ; F.fprintf fmt "@?" + module CallsCsv = struct (** Write proc summary stats in csv format *) let pp_calls fmt summary = @@ -503,6 +529,7 @@ module CallsCsv = struct pp "%a@\n" Specs.CallStats.pp_trace trace in Specs.CallStats.iter do_call stats.Specs.call_stats + end module Stats = struct @@ -536,10 +563,12 @@ module Stats = struct ; nwarnings= 0 ; saved_errors= [] } + let process_loc loc stats = try Hashtbl.find stats.files loc.Location.file with Not_found -> Hashtbl.add stats.files loc.Location.file () + let loc_trace_to_string_list linereader indent_num ltr = let res = ref [] in let indent_string n = @@ -569,14 +598,15 @@ module Stats = struct List.iter ~f:loc_to_string ltr ; List.rev !res + let process_err_log error_filter linereader err_log stats = let found_errors = ref false in let process_row (key: Errlog.err_key) (err_data: Errlog.err_data) = let type_str = key.err_name.IssueType.unique_id in if key.in_footprint && error_filter key.err_desc key.err_name then match key.err_kind with - | Exceptions.Kerror - -> found_errors := true ; + | Exceptions.Kerror -> + found_errors := true ; stats.nerrors <- stats.nerrors + 1 ; let error_strs = let pp1 fmt = F.fprintf fmt "%d: %s" stats.nerrors type_str in @@ -589,17 +619,18 @@ module Stats = struct in let trace = loc_trace_to_string_list linereader 1 err_data.loc_trace in stats.saved_errors <- List.rev_append (error_strs @ trace @ [""]) stats.saved_errors - | Exceptions.Kwarning - -> stats.nwarnings <- stats.nwarnings + 1 - | Exceptions.Kinfo - -> stats.ninfos <- stats.ninfos + 1 - | Exceptions.Kadvice - -> stats.nadvice <- stats.nadvice + 1 - | Exceptions.Klike - -> stats.nlikes <- stats.nlikes + 1 + | Exceptions.Kwarning -> + stats.nwarnings <- stats.nwarnings + 1 + | Exceptions.Kinfo -> + stats.ninfos <- stats.ninfos + 1 + | Exceptions.Kadvice -> + stats.nadvice <- stats.nadvice + 1 + | Exceptions.Klike -> + stats.nlikes <- stats.nlikes + 1 in Errlog.iter process_row err_log ; !found_errors + let process_summary error_filter summary linereader stats = let specs = Specs.get_specs_from_payload summary in let found_errors = @@ -619,6 +650,7 @@ module Stats = struct if is_defective then stats.ndefective <- stats.ndefective + 1 ; process_loc summary.Specs.attributes.ProcAttributes.loc stats + let num_files stats = Hashtbl.length stats.files let pp fmt stats = @@ -635,6 +667,7 @@ module Stats = struct F.fprintf fmt "@\n -------------------@\n" ; F.fprintf fmt "@\nDetailed Errors@\n@\n" ; List.iter ~f:(fun s -> F.fprintf fmt "%s@\n" s) (List.rev stats.saved_errors) + end module Report = struct @@ -642,6 +675,7 @@ module Report = struct F.fprintf fmt "Infer Analysis Results -- generated %a@\n@\n" Pp.current_time () ; F.fprintf fmt "Summary Report@\n@\n" + let pp_stats fmt stats = Stats.pp fmt stats end @@ -651,6 +685,7 @@ module Summary = struct if CLOpt.equal_command Config.command CLOpt.Report && not Config.quiet then L.result "Procedure: %a@\n%a@." Typ.Procname.pp proc_name Specs.pp_summary_text summary + (** Write proc summary to latex file *) let write_summary_latex fmt summary = let proc_name = Specs.get_proc_name summary in @@ -658,6 +693,7 @@ module Summary = struct ("Analysis of function " ^ Latex.convert_string (Typ.Procname.to_string proc_name)) ; F.fprintf fmt "@[%a@]" (Specs.pp_summary_latex Black) summary + let pp_summary_xml summary fname = if Config.xml_specs then let base = DB.chop_extension (DB.filename_from_string fname) in @@ -672,6 +708,7 @@ module Summary = struct summary.Specs.attributes.ProcAttributes.loc outf.fmt ; Utils.close_outf outf ) + let print_summary_dot_svg summary fname = if Config.svg then let base = DB.chop_extension (DB.filename_from_string fname) in @@ -688,6 +725,7 @@ module Summary = struct (Sys.command ( "dot -Tsvg \"" ^ DB.filename_to_string dot_file ^ "\" >\"" ^ DB.filename_to_string svg_file ^ "\"" )) + end (** Categorize the preconditions of specs and print stats *) @@ -704,23 +742,27 @@ module PreconditionStats = struct let specs = Specs.get_specs_from_payload summary in let preconditions = List.map ~f:(fun spec -> Specs.Jprop.to_prop spec.Specs.pre) specs in match Prop.CategorizePreconditions.categorize preconditions with - | Prop.CategorizePreconditions.Empty - -> incr nr_empty ; L.result "Procedure: %a footprint:Empty@." Typ.Procname.pp proc_name - | Prop.CategorizePreconditions.OnlyAllocation - -> incr nr_onlyallocation ; + | Prop.CategorizePreconditions.Empty -> + incr nr_empty ; + L.result "Procedure: %a footprint:Empty@." Typ.Procname.pp proc_name + | Prop.CategorizePreconditions.OnlyAllocation -> + incr nr_onlyallocation ; L.result "Procedure: %a footprint:OnlyAllocation@." Typ.Procname.pp proc_name - | Prop.CategorizePreconditions.NoPres - -> incr nr_nopres ; L.result "Procedure: %a footprint:NoPres@." Typ.Procname.pp proc_name - | Prop.CategorizePreconditions.DataConstraints - -> incr nr_dataconstraints ; + | Prop.CategorizePreconditions.NoPres -> + incr nr_nopres ; + L.result "Procedure: %a footprint:NoPres@." Typ.Procname.pp proc_name + | Prop.CategorizePreconditions.DataConstraints -> + incr nr_dataconstraints ; L.result "Procedure: %a footprint:DataConstraints@." Typ.Procname.pp proc_name + let pp_stats () = L.result "@.Precondition stats@." ; L.result "Procedures with no preconditions: %d@." !nr_nopres ; L.result "Procedures with empty precondition: %d@." !nr_empty ; L.result "Procedures with only allocation conditions: %d@." !nr_onlyallocation ; L.result "Procedures with data constraints: %d@." !nr_dataconstraints + end (* Wrapper of an issue that compares all parts except the procname *) @@ -731,6 +773,7 @@ module Issue = struct let compare_err_data_ (err_data1: Errlog.err_data) (err_data2: Errlog.err_data) = Location.compare err_data1.loc err_data2.loc + type proc_name_ = Typ.Procname.t (* ignore proc name *) @@ -751,6 +794,7 @@ module Issue = struct if num_pruned_issues > 0 then L.user_warning "Note: pruned %d duplicate issues" num_pruned_issues ) ; issues' + end let error_filter filters proc_name file error_desc error_name = @@ -761,6 +805,7 @@ let error_filter filters proc_name file error_desc error_name = && (filters.Inferconfig.path_filter file || always_report ()) && filters.Inferconfig.error_filter error_name && filters.Inferconfig.proc_filter proc_name + type report_kind = Issues | Procs | Stats | Calls | Summary [@@deriving compare] type bug_format_kind = Json | Csv | Tests | Text | Latex [@@deriving compare] @@ -768,57 +813,63 @@ type bug_format_kind = Json | Csv | Tests | Text | Latex [@@deriving compare] let pp_issue_in_format (format_kind, (outf: Utils.outfile)) error_filter {Issue.proc_name; proc_location; err_key; err_data} = match format_kind with - | Csv - -> IssuesCsv.pp_issue outf.fmt error_filter proc_name (Some proc_location) err_key err_data - | Json - -> IssuesJson.pp_issue outf.fmt error_filter proc_name (Some proc_location) err_key err_data - | Latex - -> L.(die InternalError) "Printing issues in latex is not implemented" - | Tests - -> L.(die InternalError) "Print issues as tests is not implemented" - | Text - -> IssuesTxt.pp_issue outf.fmt error_filter (Some proc_location) err_key err_data + | Csv -> + IssuesCsv.pp_issue outf.fmt error_filter proc_name (Some proc_location) err_key err_data + | Json -> + IssuesJson.pp_issue outf.fmt error_filter proc_name (Some proc_location) err_key err_data + | Latex -> + L.(die InternalError) "Printing issues in latex is not implemented" + | Tests -> + L.(die InternalError) "Print issues as tests is not implemented" + | Text -> + IssuesTxt.pp_issue outf.fmt error_filter (Some proc_location) err_key err_data + let pp_issues_in_format (format_kind, (outf: Utils.outfile)) = match format_kind with - | Json - -> IssuesJson.pp_issues_of_error_log outf.fmt - | Csv - -> IssuesCsv.pp_issues_of_error_log outf.fmt - | Tests - -> L.(die InternalError) "Print issues as tests is not implemented" - | Text - -> IssuesTxt.pp_issues_of_error_log outf.fmt - | Latex - -> L.(die InternalError) "Printing issues in latex is not implemented" + | Json -> + IssuesJson.pp_issues_of_error_log outf.fmt + | Csv -> + IssuesCsv.pp_issues_of_error_log outf.fmt + | Tests -> + L.(die InternalError) "Print issues as tests is not implemented" + | Text -> + IssuesTxt.pp_issues_of_error_log outf.fmt + | Latex -> + L.(die InternalError) "Printing issues in latex is not implemented" + let pp_procs_in_format (format_kind, (outf: Utils.outfile)) = match format_kind with - | Csv - -> ProcsCsv.pp_summary outf.fmt - | Json | Latex | Tests | Text - -> L.(die InternalError) "Printing procs in json/latex/tests/text is not implemented" + | Csv -> + ProcsCsv.pp_summary outf.fmt + | Json | Latex | Tests | Text -> + L.(die InternalError) "Printing procs in json/latex/tests/text is not implemented" + let pp_calls_in_format (format_kind, (outf: Utils.outfile)) = match format_kind with - | Csv - -> CallsCsv.pp_calls outf.fmt - | Json | Tests | Text | Latex - -> L.(die InternalError) "Printing calls in json/tests/text/latex is not implemented" + | Csv -> + CallsCsv.pp_calls outf.fmt + | Json | Tests | Text | Latex -> + L.(die InternalError) "Printing calls in json/tests/text/latex is not implemented" + let pp_stats_in_format (format_kind, _) = match format_kind with - | Csv - -> Stats.process_summary - | Json | Tests | Text | Latex - -> L.(die InternalError) "Printing stats in json/tests/text/latex is not implemented" + | Csv -> + Stats.process_summary + | Json | Tests | Text | Latex -> + L.(die InternalError) "Printing stats in json/tests/text/latex is not implemented" + let pp_summary_in_format (format_kind, (outf: Utils.outfile)) = match format_kind with - | Latex - -> Summary.write_summary_latex outf.fmt - | Json | Csv | Tests | Text - -> L.(die InternalError) "Printing summary in json/csv/tests/text is not implemented" + | Latex -> + Summary.write_summary_latex outf.fmt + | Json | Csv | Tests | Text -> + L.(die InternalError) "Printing summary in json/csv/tests/text is not implemented" + let pp_issues_of_error_log error_filter linereader proc_loc_opt procname err_log bug_format_list = let pp_issues_in_format format = @@ -826,15 +877,16 @@ let pp_issues_of_error_log error_filter linereader proc_loc_opt procname err_log in List.iter ~f:pp_issues_in_format bug_format_list + let collect_issues summary issues_acc = let err_log = summary.Specs.attributes.ProcAttributes.err_log in let proc_name = Specs.get_proc_name summary in let proc_location = summary.Specs.attributes.ProcAttributes.loc in Errlog.fold - (fun err_key err_data acc -> - {Issue.proc_name= proc_name; proc_location; err_key; err_data} :: acc) + (fun err_key err_data acc -> {Issue.proc_name; proc_location; err_key; err_data} :: acc) err_log issues_acc + let pp_procs summary procs_format_list = let pp_procs_in_format format = let pp_procs = pp_procs_in_format format in @@ -842,6 +894,7 @@ let pp_procs summary procs_format_list = in List.iter ~f:pp_procs_in_format procs_format_list + let pp_calls summary calls_format_list = let pp_calls_in_format format = let pp_calls = pp_calls_in_format format in @@ -849,6 +902,7 @@ let pp_calls summary calls_format_list = in List.iter ~f:pp_calls_in_format calls_format_list + let pp_stats error_filter linereader summary stats stats_format_list = let pp_stats_in_format format = let pp_stats = pp_stats_in_format format in @@ -856,6 +910,7 @@ let pp_stats error_filter linereader summary stats stats_format_list = in List.iter ~f:pp_stats_in_format stats_format_list + let pp_summary summary fname summary_format_list = let pp_summary_in_format format = let pp_summary = pp_summary_in_format format in @@ -866,39 +921,42 @@ let pp_summary summary fname summary_format_list = Summary.pp_summary_xml summary fname ; Summary.print_summary_dot_svg summary fname + let pp_summary_by_report_kind formats_by_report_kind summary fname error_filter linereader stats file issues_acc = let pp_summary_by_report_kind (report_kind, format_list) = match (report_kind, format_list) with - | Procs, _ :: _ - -> pp_procs summary format_list - | Stats, _ :: _ - -> pp_stats (error_filter file) linereader summary stats format_list - | Calls, _ :: _ - -> pp_calls summary format_list - | Summary, _ - -> pp_summary summary fname format_list - | _ - -> () + | Procs, _ :: _ -> + pp_procs summary format_list + | Stats, _ :: _ -> + pp_stats (error_filter file) linereader summary stats format_list + | Calls, _ :: _ -> + pp_calls summary format_list + | Summary, _ -> + pp_summary summary fname format_list + | _ -> + () in - List.iter ~f:pp_summary_by_report_kind formats_by_report_kind ; collect_issues summary issues_acc + List.iter ~f:pp_summary_by_report_kind formats_by_report_kind ; + collect_issues summary issues_acc + let pp_json_report_by_report_kind formats_by_report_kind fname = match Utils.read_file fname with - | Ok report_lines - -> let pp_json_issues format_list report = + | Ok report_lines -> + let pp_json_issues format_list report = let pp_json_issue (format_kind, (outf: Utils.outfile)) = match format_kind with - | Tests - -> pp_custom_of_report outf.fmt report Config.issues_fields - | Text - -> pp_text_of_report outf.fmt report - | Json - -> L.(die InternalError) "Printing issues from json does not support json output" - | Csv - -> L.(die InternalError) "Printing issues from json does not support csv output" - | Latex - -> L.(die InternalError) "Printing issues from json does not support latex output" + | Tests -> + pp_custom_of_report outf.fmt report Config.issues_fields + | Text -> + pp_text_of_report outf.fmt report + | Json -> + L.(die InternalError) "Printing issues from json does not support json output" + | Csv -> + L.(die InternalError) "Printing issues from json does not support csv output" + | Latex -> + L.(die InternalError) "Printing issues from json does not support latex output" in List.iter ~f:pp_json_issue format_list in @@ -908,30 +966,33 @@ let pp_json_report_by_report_kind formats_by_report_kind fname = in let pp_report_by_report_kind (report_kind, format_list) = match (report_kind, format_list) with - | Issues, _ :: _ - -> pp_json_issues format_list sorted_report - | _ - -> () + | Issues, _ :: _ -> + pp_json_issues format_list sorted_report + | _ -> + () in List.iter ~f:pp_report_by_report_kind formats_by_report_kind - | Error error - -> L.(die UserError) "Error reading '%s': %s" fname error + | Error error -> + L.(die UserError) "Error reading '%s': %s" fname error + let pp_lint_issues_by_report_kind formats_by_report_kind error_filter linereader procname error_log = let pp_summary_by_report_kind (report_kind, format_list) = match (report_kind, format_list) with - | Issues, _ :: _ - -> pp_issues_of_error_log error_filter linereader None procname error_log format_list - | _ - -> () + | Issues, _ :: _ -> + pp_issues_of_error_log error_filter linereader None procname error_log format_list + | _ -> + () in List.iter ~f:pp_summary_by_report_kind formats_by_report_kind + (** Process lint issues of a procedure *) let pp_lint_issues filters formats_by_report_kind linereader procname error_log = let error_filter = error_filter filters procname in pp_lint_issues_by_report_kind formats_by_report_kind error_filter linereader procname error_log + (** Process a summary *) let process_summary filters formats_by_report_kind linereader stats fname summary issues_acc = let file = summary.Specs.attributes.ProcAttributes.loc.Location.file in @@ -947,6 +1008,7 @@ let process_summary filters formats_by_report_kind linereader stats fname summar Config.pp_simple := pp_simple_saved ; issues_acc' + module AnalysisResults = struct type t = (string * Specs.summary) list @@ -963,15 +1025,16 @@ module AnalysisResults = struct if List.is_empty Config.anon_args then load_specfiles () else List.rev Config.anon_args ) else load_specfiles () + (** Load .specs files in memory and return list of summaries *) let load_summaries_in_memory () : t = let summaries = ref [] in let load_file fname = match Specs.load_summary (DB.filename_from_string fname) with - | None - -> L.(die UserError) "Error: cannot open file %s@." fname - | Some summary - -> summaries := (fname, summary) :: !summaries + | None -> + L.(die UserError) "Error: cannot open file %s@." fname + | Some summary -> + summaries := (fname, summary) :: !summaries in let do_load () = spec_files_from_cmdline () |> List.iter ~f:load_file in Utils.without_gc ~f:do_load ; @@ -987,31 +1050,36 @@ module AnalysisResults = struct in List.sort ~cmp:summ_cmp !summaries + (** Create an iterator which loads spec files one at a time *) let iterator_of_spec_files () = let sorted_spec_files = List.sort ~cmp:String.compare (spec_files_from_cmdline ()) in let do_spec f fname = match Specs.load_summary (DB.filename_from_string fname) with - | None - -> L.(die UserError) "Error: cannot open file %s@." fname - | Some summary - -> f (fname, summary) + | None -> + L.(die UserError) "Error: cannot open file %s@." fname + | Some summary -> + f (fname, summary) in let iterate f = List.iter ~f:(do_spec f) sorted_spec_files in iterate + (** Serializer for analysis results *) let analysis_results_serializer : t Serialization.serializer = Serialization.create_serializer Serialization.Key.analysis_results + (** Load analysis_results from a file *) let load_analysis_results_from_file (filename: DB.filename) : t option = Serialization.read_from_file analysis_results_serializer filename + (** Save analysis_results into a file *) let store_analysis_results_to_file (filename: DB.filename) (analysis_results: t) = Serialization.write_to_file analysis_results_serializer filename ~data:analysis_results + (** Return an iterator over all the summaries. If options - load_results or - save_results are used, all the summaries are loaded in memory *) @@ -1020,18 +1088,19 @@ module AnalysisResults = struct match Config.load_analysis_results with | None -> ( match Config.save_analysis_results with - | None - -> iterator_of_spec_files () - | Some s - -> let r = load_summaries_in_memory () in + | None -> + iterator_of_spec_files () + | Some s -> + let r = load_summaries_in_memory () in store_analysis_results_to_file (DB.filename_from_string s) r ; iterator_of_summary_list r ) | Some fname -> match load_analysis_results_from_file (DB.filename_from_string fname) with - | Some r - -> iterator_of_summary_list r - | None - -> L.(die UserError) "Error: cannot open analysis results file %s@." fname + | Some r -> + iterator_of_summary_list r + | None -> + L.(die UserError) "Error: cannot open analysis results file %s@." fname + end let register_perf_stats_report () = @@ -1039,11 +1108,13 @@ let register_perf_stats_report () = let stats_file = Filename.concat stats_dir (Config.perf_stats_prefix ^ ".json") in PerfStats.register_report_at_exit stats_file + let mk_format format_kind fname = Option.value_map ~f:(fun out_file -> [(format_kind, out_file)]) ~default:[] (Utils.create_outfile fname) + let init_issues_format_list report_csv report_json = let csv_format = Option.value_map ~f:(mk_format Csv) ~default:[] report_csv in let json_format = Option.value_map ~f:(mk_format Json) ~default:[] report_json in @@ -1051,53 +1122,58 @@ let init_issues_format_list report_csv report_json = let txt_format = Option.value_map ~f:(mk_format Text) ~default:[] Config.issues_txt in csv_format @ json_format @ tests_format @ txt_format + let init_procs_format_list () = Option.value_map ~f:(mk_format Csv) ~default:[] Config.procs_csv let init_calls_format_list () = let csv_format = Option.value_map ~f:(mk_format Csv) ~default:[] Config.calls_csv in csv_format + let init_stats_format_list () = let csv_format = Option.value_map ~f:(mk_format Csv) ~default:[] Config.stats_report in csv_format + let init_summary_format_list () = let latex_format = Option.value_map ~f:(mk_format Latex) ~default:[] Config.latex in latex_format + let init_files format_list_by_kind = let init_files_of_report_kind (report_kind, format_list) = let init_files_of_format (format_kind, (outfile: Utils.outfile)) = match (format_kind, report_kind) with - | Csv, Issues - -> IssuesCsv.pp_header outfile.fmt () - | Csv, Procs - -> ProcsCsv.pp_header outfile.fmt () - | Csv, Stats - -> Report.pp_header outfile.fmt () - | Json, Issues - -> IssuesJson.pp_json_open outfile.fmt () - | Latex, Summary - -> begin_latex_file outfile.fmt - | (Csv | Json | Latex | Tests | Text), _ - -> () + | Csv, Issues -> + IssuesCsv.pp_header outfile.fmt () + | Csv, Procs -> + ProcsCsv.pp_header outfile.fmt () + | Csv, Stats -> + Report.pp_header outfile.fmt () + | Json, Issues -> + IssuesJson.pp_json_open outfile.fmt () + | Latex, Summary -> + begin_latex_file outfile.fmt + | (Csv | Json | Latex | Tests | Text), _ -> + () in List.iter ~f:init_files_of_format format_list in List.iter ~f:init_files_of_report_kind format_list_by_kind + let finalize_and_close_files format_list_by_kind stats pdflatex = let close_files_of_report_kind (report_kind, format_list) = let close_files_of_format (format_kind, (outfile: Utils.outfile)) = ( match (format_kind, report_kind) with - | Csv, Stats - -> F.fprintf outfile.fmt "%a@?" Report.pp_stats stats - | Json, Issues - -> IssuesJson.pp_json_close outfile.fmt () - | Latex, Summary - -> Latex.pp_end outfile.fmt () - | (Csv | Latex | Tests | Text | Json), _ - -> () ) ; + | Csv, Stats -> + F.fprintf outfile.fmt "%a@?" Report.pp_stats stats + | Json, Issues -> + IssuesJson.pp_json_close outfile.fmt () + | Latex, Summary -> + Latex.pp_end outfile.fmt () + | (Csv | Latex | Tests | Text | Json), _ -> + () ) ; Utils.close_outf outfile ; (* bug_format_kind report_kind *) if [%compare.equal : bug_format_kind * report_kind] @@ -1107,10 +1183,12 @@ let finalize_and_close_files format_list_by_kind stats pdflatex = let pdf_name = Filename.chop_extension outfile.fname ^ ".pdf" in ignore (Sys.command ("open " ^ pdf_name)) ) in - List.iter ~f:close_files_of_format format_list ; () + List.iter ~f:close_files_of_format format_list ; + () in List.iter ~f:close_files_of_report_kind format_list_by_kind + let pp_summary_and_issues formats_by_report_kind issue_formats = let pdflatex fname = ignore (Sys.command ("pdflatex " ^ fname)) in let stats = Stats.create () in @@ -1131,10 +1209,12 @@ let pp_summary_and_issues formats_by_report_kind issue_formats = (Issue.sort_filter_issues !all_issues) ; if Config.precondition_stats then PreconditionStats.pp_stats () ; LintIssues.load_issues_to_errlog_map Config.lint_issues_dir_name ; - Typ.Procname.Map.iter (pp_lint_issues filters formats_by_report_kind linereader) + Typ.Procname.Map.iter + (pp_lint_issues filters formats_by_report_kind linereader) !LintIssues.errLogMap ; finalize_and_close_files formats_by_report_kind stats pdflatex + let main ~report_csv ~report_json = let issue_formats = init_issues_format_list report_csv report_json in let formats_by_report_kind = @@ -1147,7 +1227,8 @@ let main ~report_csv ~report_json = if Config.developer_mode then register_perf_stats_report () ; init_files formats_by_report_kind ; match Config.from_json_report with - | Some fname - -> pp_json_report_by_report_kind formats_by_report_kind fname - | None - -> pp_summary_and_issues formats_by_report_kind issue_formats + | Some fname -> + pp_json_report_by_report_kind formats_by_report_kind fname + | None -> + pp_summary_and_issues formats_by_report_kind issue_formats + diff --git a/infer/src/backend/OndemandCapture.ml b/infer/src/backend/OndemandCapture.ml index b467da517..aa5a61ff1 100644 --- a/infer/src/backend/OndemandCapture.ml +++ b/infer/src/backend/OndemandCapture.ml @@ -9,7 +9,7 @@ open! IStd module L = Logging -let compilation_db = (lazy (CompilationDatabase.from_json_files !Config.clang_compilation_dbs)) +let compilation_db = lazy (CompilationDatabase.from_json_files !Config.clang_compilation_dbs) (** Given proc_attributes try to produce proc_attributes' where proc_attributes'.is_defined = true It may trigger capture of extra files to do so and when it does, it waits for @@ -45,12 +45,12 @@ let try_capture (attributes: ProcAttributes.t) : ProcAttributes.t option = SourceFile.pp definition_file Typ.Procname.pp attributes.proc_name in match definition_file_opt with - | None - -> L.(debug Capture Medium) + | None -> + L.(debug Capture Medium) "Couldn't find source file for %a (declared in %a)@\n" Typ.Procname.pp attributes.proc_name SourceFile.pp decl_file - | Some file - -> try_compile file ) ; + | Some file -> + try_compile file ) ; (* It's important to call load_defined_attributes again in all cases to make sure we try reading from disk again no matter which condition happened. If previous call to load_defined_attributes is None, it may mean couple of things: @@ -62,3 +62,4 @@ let try_capture (attributes: ProcAttributes.t) : ProcAttributes.t option = Caveat: it's possible that procedure will be captured in some other unrelated file later - infer may ignore it then. *) Attributes.load_defined attributes.proc_name + diff --git a/infer/src/backend/PerfStats.ml b/infer/src/backend/PerfStats.ml index 02d3199a6..9e305ab2b 100644 --- a/infer/src/backend/PerfStats.ml +++ b/infer/src/backend/PerfStats.ml @@ -47,6 +47,7 @@ let to_json ps = ; ("stack_kb", `Float ps.stack_kb) ; ("minor_heap_kb", `Float ps.minor_heap_kb) ] + let from_json json = let open! Yojson.Basic.Util in { rtime= json |> member "rtime" |> to_float @@ -65,6 +66,7 @@ let from_json json = ; stack_kb= json |> member "stack_kb" |> to_float ; minor_heap_kb= json |> member "minor_heap_kb" |> to_float } + let aggregate s = let mk_stats f = StatisticsToolbox.compute_statistics (List.map ~f s) in let aggr_rtime = mk_stats (fun stats -> stats.rtime) in @@ -99,6 +101,7 @@ let aggregate s = ; ("stack_kb", StatisticsToolbox.to_json aggr_stack_kb) ; ("minor_heap_kb", StatisticsToolbox.to_json aggr_minor_heap_kb) ] + let stats () = let words_to_kb n = n *. float_of_int (Sys.word_size / 8) /. 1024. in let words_to_mb n = words_to_kb n /. 1024. in @@ -123,6 +126,7 @@ let stats () = ; stack_kb= words_to_kb (float_of_int gc_stats.stack_size) ; minor_heap_kb= words_to_kb (float_of_int gc_ctrl.minor_heap_size) } + let report_at_exit file () = try let json_stats = to_json (stats ()) in @@ -133,11 +137,14 @@ let report_at_exit file () = Yojson.Basic.pretty_to_channel stats_oc json_stats ) with exc -> L.internal_error "Info: failed to write stats to %s@\n%s@\n%s@\n%s@." file - (Exn.to_string exc) (Yojson.Basic.pretty_to_string json_stats) (Printexc.get_backtrace ()) + (Exn.to_string exc) + (Yojson.Basic.pretty_to_string json_stats) + (Printexc.get_backtrace ()) with exc -> L.internal_error "Info: failed to compute stats for %s@\n%s@\n%s@." file (Exn.to_string exc) (Printexc.get_backtrace ()) + let register_report_at_exit = (* take care of not double-registering the same perf stat report *) let registered_files = String.Table.create ~size:4 () in @@ -146,3 +153,4 @@ let register_report_at_exit = String.Table.set registered_files ~key:file ~data:() ; if not Config.buck_cache_mode then Epilogues.register ~f:(report_at_exit file) ("stats reporting in " ^ file) ) + diff --git a/infer/src/backend/PropUtil.ml b/infer/src/backend/PropUtil.ml index daf0e39ae..b32deceb2 100644 --- a/infer/src/backend/PropUtil.ml +++ b/infer/src/backend/PropUtil.ml @@ -17,10 +17,10 @@ let get_name_of_objc_static_locals (curr_f: Procdesc.t) p = match e with | Exp.Lvar pvar when Pvar.is_global pvar && Sil.is_static_local_name pname pvar - (* is a local static if it's a global and it has a static local name *) - -> [pvar] - | _ - -> [] + (* is a local static if it's a global and it has a static local name *) -> + [pvar] + | _ -> + [] in let hpred_local_static hpred = match hpred with Sil.Hpointsto (e, _, _) -> [local_static e] | _ -> [] @@ -28,6 +28,7 @@ let get_name_of_objc_static_locals (curr_f: Procdesc.t) p = let vars_sigma = List.map ~f:hpred_local_static p.Prop.sigma in List.concat (List.concat vars_sigma) + (* returns a list of local variables that points to an objc block in a proposition *) let get_name_of_objc_block_locals p = let local_blocks e = @@ -39,44 +40,45 @@ let get_name_of_objc_block_locals p = let vars_sigma = List.map ~f:hpred_local_blocks p.Prop.sigma in List.concat (List.concat vars_sigma) + let remove_abduced_retvars tenv p = (* compute the hpreds and pure atoms reachable from the set of seed expressions in [exps] *) let compute_reachable p seed_exps = let sigma, pi = (p.Prop.sigma, p.Prop.pi) in let rec collect_exps exps = function - | Sil.Eexp (Exp.Exn e, _) - -> Exp.Set.add e exps - | Sil.Eexp (e, _) - -> Exp.Set.add e exps - | Sil.Estruct (flds, _) - -> List.fold ~f:(fun exps (_, strexp) -> collect_exps exps strexp) ~init:exps flds - | Sil.Earray (_, elems, _) - -> List.fold ~f:(fun exps (_, strexp) -> collect_exps exps strexp) ~init:exps elems + | Sil.Eexp (Exp.Exn e, _) -> + Exp.Set.add e exps + | Sil.Eexp (e, _) -> + Exp.Set.add e exps + | Sil.Estruct (flds, _) -> + List.fold ~f:(fun exps (_, strexp) -> collect_exps exps strexp) ~init:exps flds + | Sil.Earray (_, elems, _) -> + List.fold ~f:(fun exps (_, strexp) -> collect_exps exps strexp) ~init:exps elems in let rec compute_reachable_hpreds_rec sigma (reach, exps) = let add_hpred_if_reachable (reach, exps) = function - | Sil.Hpointsto (lhs, rhs, _) as hpred when Exp.Set.mem lhs exps - -> let reach' = Sil.HpredSet.add hpred reach in + | Sil.Hpointsto (lhs, rhs, _) as hpred when Exp.Set.mem lhs exps -> + let reach' = Sil.HpredSet.add hpred reach in let exps' = collect_exps exps rhs in (reach', exps') - | Sil.Hlseg (_, _, exp1, exp2, exp_l) as hpred - -> let reach' = Sil.HpredSet.add hpred reach in + | Sil.Hlseg (_, _, exp1, exp2, exp_l) as hpred -> + let reach' = Sil.HpredSet.add hpred reach in let exps' = List.fold ~f:(fun exps_acc exp -> Exp.Set.add exp exps_acc) ~init:exps (exp1 :: exp2 :: exp_l) in (reach', exps') - | Sil.Hdllseg (_, _, exp1, exp2, exp3, exp4, exp_l) as hpred - -> let reach' = Sil.HpredSet.add hpred reach in + | Sil.Hdllseg (_, _, exp1, exp2, exp3, exp4, exp_l) as hpred -> + let reach' = Sil.HpredSet.add hpred reach in let exps' = List.fold ~f:(fun exps_acc exp -> Exp.Set.add exp exps_acc) ~init:exps (exp1 :: exp2 :: exp3 :: exp4 :: exp_l) in (reach', exps') - | _ - -> (reach, exps) + | _ -> + (reach, exps) in let reach', exps' = List.fold ~f:add_hpred_if_reachable ~init:(reach, exps) sigma in if Int.equal (Sil.HpredSet.cardinal reach) (Sil.HpredSet.cardinal reach') then (reach, exps) @@ -88,21 +90,21 @@ let remove_abduced_retvars tenv p = (* filter away the pure atoms without reachable exps *) let reach_pi = let rec exp_contains = function - | exp when Exp.Set.mem exp reach_exps - -> true - | Exp.UnOp (_, e, _) | Exp.Cast (_, e) | Exp.Lfield (e, _, _) - -> exp_contains e - | Exp.BinOp (_, e0, e1) | Exp.Lindex (e0, e1) - -> exp_contains e0 || exp_contains e1 - | _ - -> false + | exp when Exp.Set.mem exp reach_exps -> + true + | Exp.UnOp (_, e, _) | Exp.Cast (_, e) | Exp.Lfield (e, _, _) -> + exp_contains e + | Exp.BinOp (_, e0, e1) | Exp.Lindex (e0, e1) -> + exp_contains e0 || exp_contains e1 + | _ -> + false in List.filter ~f:(function - | Sil.Aeq (lhs, rhs) | Sil.Aneq (lhs, rhs) - -> exp_contains lhs || exp_contains rhs - | Sil.Apred (_, es) | Sil.Anpred (_, es) - -> List.exists ~f:exp_contains es) + | Sil.Aeq (lhs, rhs) | Sil.Aneq (lhs, rhs) -> + exp_contains lhs || exp_contains rhs + | Sil.Apred (_, es) | Sil.Anpred (_, es) -> + List.exists ~f:exp_contains es) pi in (Sil.HpredSet.elements reach_hpreds, reach_pi) @@ -112,12 +114,12 @@ let remove_abduced_retvars tenv p = List.fold ~f:(fun pvars hpred -> match hpred with - | Sil.Hpointsto (Exp.Lvar pvar, _, _) - -> let abduceds, normal_pvars = pvars in + | Sil.Hpointsto (Exp.Lvar pvar, _, _) -> + let abduceds, normal_pvars = pvars in if Pvar.is_abduced pvar then (pvar :: abduceds, normal_pvars) else (abduceds, pvar :: normal_pvars) - | _ - -> pvars) + | _ -> + pvars) ~init:([], []) p.Prop.sigma in let _, p' = Attribute.deallocate_stack_vars tenv p abduceds in @@ -130,26 +132,29 @@ let remove_abduced_retvars tenv p = let sigma_reach, pi_reach = compute_reachable p' normal_pvar_set in Prop.normalize tenv (Prop.set p' ~pi:pi_reach ~sigma:sigma_reach) + let remove_locals tenv (curr_f: Procdesc.t) p = let names_of_locals = List.map ~f:(get_name_of_local curr_f) (Procdesc.get_locals curr_f) in let names_of_locals' = match !Config.curr_language with - | Config.Clang - -> (* in ObjC to deal with block we need to remove static locals *) + | Config.Clang -> + (* in ObjC to deal with block we need to remove static locals *) let names_of_static_locals = get_name_of_objc_static_locals curr_f p in let names_of_block_locals = get_name_of_objc_block_locals p in names_of_block_locals @ names_of_locals @ names_of_static_locals - | _ - -> names_of_locals + | _ -> + names_of_locals in let removed, p' = Attribute.deallocate_stack_vars tenv p names_of_locals' in (removed, remove_abduced_retvars tenv p') + let remove_formals tenv (curr_f: Procdesc.t) p = let pname = Procdesc.get_proc_name curr_f in let formal_vars = List.map ~f:(fun (n, _) -> Pvar.mk n pname) (Procdesc.get_formals curr_f) in Attribute.deallocate_stack_vars tenv p formal_vars + (** remove the return variable from the prop *) let remove_ret tenv (curr_f: Procdesc.t) (p: Prop.normal Prop.t) = let pname = Procdesc.get_proc_name curr_f in @@ -157,10 +162,12 @@ let remove_ret tenv (curr_f: Procdesc.t) (p: Prop.normal Prop.t) = let _, p' = Attribute.deallocate_stack_vars tenv p [Pvar.to_callee pname name_of_ret] in p' + (** remove locals and return variable from the prop *) let remove_locals_ret tenv (curr_f: Procdesc.t) p = snd (remove_locals tenv curr_f (remove_ret tenv curr_f p)) + (** Remove locals and formal parameters from the prop. Return the list of stack variables whose address was still present after deallocation. *) let remove_locals_formals tenv (curr_f: Procdesc.t) p = @@ -168,14 +175,16 @@ let remove_locals_formals tenv (curr_f: Procdesc.t) p = let pvars2, p2 = remove_formals tenv curr_f p1 in (pvars1 @ pvars2, p2) + (** remove seed vars from a prop *) let remove_seed_vars tenv (prop: 'a Prop.t) : Prop.normal Prop.t = let hpred_not_seed = function - | Sil.Hpointsto (Exp.Lvar pv, _, _) - -> not (Pvar.is_seed pv) - | _ - -> true + | Sil.Hpointsto (Exp.Lvar pv, _, _) -> + not (Pvar.is_seed pv) + | _ -> + true in let sigma = prop.sigma in let sigma' = List.filter ~f:hpred_not_seed sigma in Prop.normalize tenv (Prop.set prop ~sigma:sigma') + diff --git a/infer/src/backend/StatsAggregator.ml b/infer/src/backend/StatsAggregator.ml index 17de41ad5..0acb61627 100644 --- a/infer/src/backend/StatsAggregator.ml +++ b/infer/src/backend/StatsAggregator.ml @@ -19,6 +19,7 @@ let json_files_to_ignore_regex = ( ".*\\(" ^ Str.quote aggregated_stats_filename ^ "\\|" ^ Str.quote aggregated_stats_by_target_filename ^ "\\)$" ) + let dir_exists dir = Sys.is_directory dir = `Yes let find_json_files_in_dir dir = @@ -29,12 +30,13 @@ let find_json_files_in_dir dir = && Polymorphic_compare.( = ) s.st_kind Unix.S_REG in match dir_exists dir with - | true - -> let content = Array.to_list (Sys.readdir dir) in + | true -> + let content = Array.to_list (Sys.readdir dir) in let content_with_path = List.map ~f:(fun p -> Filename.concat dir p) content in List.filter ~f:is_valid_json_file content_with_path - | false - -> [] + | false -> + [] + type stats_paths = {frontend_paths: string list; backend_paths: string list; reporting_paths: string list} @@ -51,32 +53,34 @@ let find_stats_files_in_dir dir = in {frontend_paths; backend_paths; reporting_paths} + let load_data_from_infer_deps file = let error msg = Printf.sprintf ("Error reading '%s': " ^^ msg) file in let extract_target_and_path line = match String.split ~on:'\t' line with - | target :: _ :: path :: _ - -> if dir_exists path then Ok (target, path) + | target :: _ :: path :: _ -> + if dir_exists path then Ok (target, path) else Error (error "path '%s' is not a valid directory" path) - | _ - -> Error (error "malformed input") + | _ -> + Error (error "malformed input") in let parse_lines lines = List.map lines ~f:extract_target_and_path |> Result.all in Utils.read_file file |> Result.map_error ~f:(fun msg -> error "%s" msg) |> Result.bind ~f:parse_lines + let collect_all_stats_files () = let infer_out = Config.results_dir in let concatenate_paths p1 p2 = if Filename.is_relative p2 then Filename.concat p1 p2 else p2 in match Config.buck_out with - | Some p - -> if dir_exists p then + | Some p -> + if dir_exists p then let data = load_data_from_infer_deps (Filename.concat infer_out Config.buck_infer_deps_file_name) in match data with - | Ok r - -> let buck_out_parent = Filename.concat p Filename.parent_dir_name in + | Ok r -> + let buck_out_parent = Filename.concat p Filename.parent_dir_name in let targets_files = List.map ~f:(fun (t, p) -> @@ -84,11 +88,12 @@ let collect_all_stats_files () = r in Ok (Buck_out targets_files) - | Error _ as e - -> e + | Error _ as e -> + e else Error ("buck-out path '" ^ p ^ "' not found") - | None - -> Ok (Infer_out (find_stats_files_in_dir infer_out)) + | None -> + Ok (Infer_out (find_stats_files_in_dir infer_out)) + let aggregate_stats_files paths = let open_json_file file = Yojson.Basic.from_file file in @@ -98,6 +103,7 @@ let aggregate_stats_files paths = let all_perf_stats = load_stats paths in match all_perf_stats with [] -> None | _ -> Some (PerfStats.aggregate all_perf_stats) + type json_aggregated_stats = { frontend_json_data: Yojson.Basic.json option ; backend_json_data: Yojson.Basic.json option @@ -112,15 +118,16 @@ let aggregate_all_stats origin = let empty_stats_paths = {frontend_paths= []; backend_paths= []; reporting_paths= []} in let stats_paths = match origin with - | Buck_out tf - -> List.fold ~f:(fun acc (_, paths) -> accumulate_paths acc paths) ~init:empty_stats_paths tf - | Infer_out paths - -> paths + | Buck_out tf -> + List.fold ~f:(fun acc (_, paths) -> accumulate_paths acc paths) ~init:empty_stats_paths tf + | Infer_out paths -> + paths in { frontend_json_data= aggregate_stats_files stats_paths.frontend_paths ; backend_json_data= aggregate_stats_files stats_paths.backend_paths ; reporting_json_data= aggregate_stats_files stats_paths.reporting_paths } + let aggregate_stats_by_target tp = let to_json f aggr_stats = let collect_valid_stats acc t p = match p with Some v -> (t, v) :: acc | None -> acc in @@ -132,6 +139,7 @@ let aggregate_stats_by_target tp = let reporting_json_data = to_json (fun p -> aggregate_stats_files p.reporting_paths) tp in {frontend_json_data; backend_json_data; reporting_json_data} + let generate_files () = let infer_out = Config.results_dir in let stats_files = collect_all_stats_files () in @@ -148,8 +156,8 @@ let generate_files () = match json with Some j -> Utils.write_json_to_file destfile j | None -> () in ( match origin with - | Buck_out tp - -> let j = aggregate_stats_by_target tp in + | Buck_out tp -> + let j = aggregate_stats_by_target tp in write_to_json_file_opt (Filename.concat aggregated_frontend_stats_dir aggregated_stats_by_target_filename) j.frontend_json_data ; @@ -159,12 +167,16 @@ let generate_files () = write_to_json_file_opt (Filename.concat aggregated_reporting_stats_dir aggregated_stats_by_target_filename) j.reporting_json_data - | Infer_out _ - -> () ) ; + | Infer_out _ -> + () ) ; let j = aggregate_all_stats origin in - write_to_json_file_opt (Filename.concat aggregated_frontend_stats_dir aggregated_stats_filename) + write_to_json_file_opt + (Filename.concat aggregated_frontend_stats_dir aggregated_stats_filename) j.frontend_json_data ; - write_to_json_file_opt (Filename.concat aggregated_backend_stats_dir aggregated_stats_filename) + write_to_json_file_opt + (Filename.concat aggregated_backend_stats_dir aggregated_stats_filename) j.backend_json_data ; - write_to_json_file_opt (Filename.concat aggregated_reporting_stats_dir aggregated_stats_filename) + write_to_json_file_opt + (Filename.concat aggregated_reporting_stats_dir aggregated_stats_filename) j.reporting_json_data + diff --git a/infer/src/backend/Tasks.ml b/infer/src/backend/Tasks.ml index 3fb1396c8..4c4f9595b 100644 --- a/infer/src/backend/Tasks.ml +++ b/infer/src/backend/Tasks.ml @@ -23,6 +23,7 @@ let create ?(continuation= None) closures = in {closures; continuations} + let empty = {closures= []; continuations= Queue.create ()} (* Aggregate closures into groups of the given size *) @@ -35,11 +36,17 @@ let aggregate ~size t = {t with closures} else t + let run t = List.iter ~f:(fun f -> f ()) t.closures ; Queue.iter ~f:(fun closure -> closure ()) t.continuations -let fork_protect ~f x = L.reset_formatters () ; ResultsDir.new_database_connection () ; f x + +let fork_protect ~f x = + L.reset_formatters () ; + ResultsDir.new_database_connection () ; + f x + module Runner = struct type runner = {pool: ProcessPool.t; all_continuations: closure Queue.t} @@ -53,7 +60,9 @@ module Runner = struct ~f:(fun x -> ProcessPool.start_child ~f:(fun f -> fork_protect ~f ()) ~pool x) tasks.closures + let complete runner = ProcessPool.wait_all runner.pool ; Queue.iter ~f:(fun f -> f ()) runner.all_continuations + end diff --git a/infer/src/backend/abs.ml b/infer/src/backend/abs.ml index 595adc02c..8f4b05b8a 100644 --- a/infer/src/backend/abs.ml +++ b/infer/src/backend/abs.ml @@ -28,10 +28,10 @@ type rule = let sigma_rewrite tenv p r : Prop.normal Prop.t option = match Match.prop_match_with_impl tenv p r.r_condition r.r_vars r.r_root r.r_sigma with - | None - -> None - | Some (sub, p_leftover) - -> if not (r.r_condition p_leftover sub) then None + | None -> + None + | Some (sub, p_leftover) -> + if not (r.r_condition p_leftover sub) then None else let res_pi = r.r_new_pi p p_leftover sub in let res_sigma = Prop.sigma_sub (`Exp sub) r.r_new_sigma in @@ -39,6 +39,7 @@ let sigma_rewrite tenv p r : Prop.normal Prop.t option = let p_new = Prop.prop_sigma_star p_with_res_pi res_sigma in Some (Prop.normalize tenv p_new) + let sigma_fav_list sigma = Sil.fav_to_list (Prop.sigma_fav sigma) let sigma_fav_in_pvars = Sil.fav_imperative_to_functional Prop.sigma_fav_in_pvars_add @@ -63,6 +64,7 @@ let create_fresh_primeds_ls para = let exps_tuple = (exp_base, exp_next, exp_end, exps_shared) in (ids_tuple, exps_tuple) + let create_condition_ls ids_private id_base p_leftover (inst: Sil.exp_subst) = let insts_of_private_ids, insts_of_public_ids, inst_of_base = let f id' = List.exists ~f:(fun id'' -> Ident.equal id' id'') ids_private in @@ -95,24 +97,25 @@ let create_condition_ls ids_private id_base p_leftover (inst: Sil.exp_subst) = && not (IList.intersect Ident.compare fav_insts_of_private_ids fav_p_leftover) && not (IList.intersect Ident.compare fav_insts_of_private_ids fav_insts_of_public_ids) + let mk_rule_ptspts_ls tenv impl_ok1 impl_ok2 (para: Sil.hpara) = let ids_tuple, exps_tuple = create_fresh_primeds_ls para in let id_base, id_next, id_end, ids_shared = ids_tuple in let exp_base, exp_next, exp_end, exps_shared = exps_tuple in let ids_exist_fst, para_fst = Sil.hpara_instantiate para exp_base exp_next exps_shared in let para_fst_start, para_fst_rest = - let mark_impl_flag hpred = {Match.hpred= hpred; Match.flag= impl_ok1} in + let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok1} in match para_fst with - | [] - -> L.internal_error "@\n@\nERROR (Empty Para): %a@\n@." (Sil.pp_hpara Pp.text) para ; + | [] -> + L.internal_error "@\n@\nERROR (Empty Para): %a@\n@." (Sil.pp_hpara Pp.text) para ; assert false - | hpred :: hpreds - -> let hpat = mark_impl_flag hpred in + | hpred :: hpreds -> + let hpat = mark_impl_flag hpred in let hpats = List.map ~f:mark_impl_flag hpreds in (hpat, hpats) in let ids_exist_snd, para_snd = - let mark_impl_flag hpred = {Match.hpred= hpred; Match.flag= impl_ok2} in + let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok2} in let ids, para_body = Sil.hpara_instantiate para exp_next exp_end exps_shared in let para_body_hpats = List.map ~f:mark_impl_flag para_body in (ids, para_body_hpats) @@ -130,6 +133,7 @@ let mk_rule_ptspts_ls tenv impl_ok1 impl_ok2 (para: Sil.hpara) = ; r_new_pi= gen_pi_res ; r_condition= condition } + let mk_rule_ptsls_ls tenv k2 impl_ok1 impl_ok2 para = let ids_tuple, exps_tuple = create_fresh_primeds_ls para in let id_base, id_next, id_end, ids_shared = ids_tuple in @@ -137,11 +141,11 @@ let mk_rule_ptsls_ls tenv k2 impl_ok1 impl_ok2 para = let ids_exist, para_inst = Sil.hpara_instantiate para exp_base exp_next exps_shared in let para_inst_start, para_inst_rest = match para_inst with - | [] - -> L.internal_error "@\n@\nERROR (Empty Para): %a@\n@." (Sil.pp_hpara Pp.text) para ; + | [] -> + L.internal_error "@\n@\nERROR (Empty Para): %a@\n@." (Sil.pp_hpara Pp.text) para ; assert false - | hpred :: hpreds - -> let allow_impl hpred = {Match.hpred= hpred; Match.flag= impl_ok1} in + | hpred :: hpreds -> + let allow_impl hpred = {Match.hpred; Match.flag= impl_ok1} in (allow_impl hpred, List.map ~f:allow_impl hpreds) in let lseg_pat = @@ -160,6 +164,7 @@ let mk_rule_ptsls_ls tenv k2 impl_ok1 impl_ok2 para = ; r_new_sigma= [lseg_res] ; r_condition= condition } + let mk_rule_lspts_ls tenv k1 impl_ok1 impl_ok2 para = let ids_tuple, exps_tuple = create_fresh_primeds_ls para in let id_base, id_next, id_end, ids_shared = ids_tuple in @@ -169,7 +174,7 @@ let mk_rule_lspts_ls tenv k1 impl_ok1 impl_ok2 para = in let ids_exist, para_inst_pat = let ids, para_body = Sil.hpara_instantiate para exp_next exp_end exps_shared in - let allow_impl hpred = {Match.hpred= hpred; Match.flag= impl_ok2} in + let allow_impl hpred = {Match.hpred; Match.flag= impl_ok2} in let para_body_pat = List.map ~f:allow_impl para_body in (ids, para_body_pat) in @@ -186,12 +191,14 @@ let mk_rule_lspts_ls tenv k1 impl_ok1 impl_ok2 para = ; r_new_pi= gen_pi_res ; r_condition= condition } + let lseg_kind_add k1 k2 = match (k1, k2) with - | Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_NE - -> Sil.Lseg_NE - | Sil.Lseg_PE, Sil.Lseg_PE - -> Sil.Lseg_PE + | Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_NE -> + Sil.Lseg_NE + | Sil.Lseg_PE, Sil.Lseg_PE -> + Sil.Lseg_PE + let mk_rule_lsls_ls tenv k1 k2 impl_ok1 impl_ok2 para = let ids_tuple, exps_tuple = create_fresh_primeds_ls para in @@ -236,6 +243,7 @@ let mk_rule_lsls_ls tenv k1 k2 impl_ok1 impl_ok2 para = ; r_new_pi= gen_pi_res ; r_condition= condition } + let mk_rules_for_sll tenv (para: Sil.hpara) : rule list = if not Config.nelseg then let pts_pts = mk_rule_ptspts_ls tenv true true para in @@ -252,6 +260,7 @@ let mk_rules_for_sll tenv (para: Sil.hpara) : rule list = let nels_nels = mk_rule_lsls_ls tenv Sil.Lseg_NE Sil.Lseg_NE false false para in [pts_pts; pts_nels; nels_pts; nels_nels] + (****************** End of SLL abstraction rules ******************) (****************** Start of DLL abstraction rules ******************) let create_condition_dll = create_condition_ls @@ -273,18 +282,18 @@ let mk_rule_ptspts_dll tenv impl_ok1 impl_ok2 para = let exps_shared = List.map ~f:(fun id -> Exp.Var id) ids_shared in let ids_exist_fst, para_fst = Sil.hpara_dll_instantiate para exp_iF exp_oB exp_iF' exps_shared in let para_fst_start, para_fst_rest = - let mark_impl_flag hpred = {Match.hpred= hpred; Match.flag= impl_ok1} in + let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok1} in match para_fst with - | [] - -> L.internal_error "@\n@\nERROR (Empty DLL Para): %a@\n@." (Sil.pp_hpara_dll Pp.text) para ; + | [] -> + L.internal_error "@\n@\nERROR (Empty DLL Para): %a@\n@." (Sil.pp_hpara_dll Pp.text) para ; assert false - | hpred :: hpreds - -> let hpat = mark_impl_flag hpred in + | hpred :: hpreds -> + let hpat = mark_impl_flag hpred in let hpats = List.map ~f:mark_impl_flag hpreds in (hpat, hpats) in let ids_exist_snd, para_snd = - let mark_impl_flag hpred = {Match.hpred= hpred; Match.flag= impl_ok2} in + let mark_impl_flag hpred = {Match.hpred; Match.flag= impl_ok2} in let ids, para_body = Sil.hpara_dll_instantiate para exp_iF' exp_iF exp_oF exps_shared in let para_body_hpats = List.map ~f:mark_impl_flag para_body in (ids, para_body_hpats) @@ -309,6 +318,7 @@ let mk_rule_ptspts_dll tenv impl_ok1 impl_ok2 para = ; r_new_pi= gen_pi_res ; r_condition= condition } + let mk_rule_ptsdll_dll tenv k2 impl_ok1 impl_ok2 para = let id_iF = Ident.create_fresh Ident.kprimed in let id_iF' = Ident.create_fresh Ident.kprimed in @@ -329,10 +339,10 @@ let mk_rule_ptsdll_dll tenv k2 impl_ok1 impl_ok2 para = let ids_exist, para_inst = Sil.hpara_dll_instantiate para exp_iF exp_oB exp_iF' exps_shared in let para_inst_start, para_inst_rest = match para_inst with - | [] - -> assert false - | hpred :: hpreds - -> let allow_impl hpred = {Match.hpred= hpred; Match.flag= impl_ok1} in + | [] -> + assert false + | hpred :: hpreds -> + let allow_impl hpred = {Match.hpred; Match.flag= impl_ok1} in (allow_impl hpred, List.map ~f:allow_impl hpreds) in let dllseg_pat = @@ -352,6 +362,7 @@ let mk_rule_ptsdll_dll tenv k2 impl_ok1 impl_ok2 para = ; r_new_sigma= [dllseg_res] ; r_condition= condition } + let mk_rule_dllpts_dll tenv k1 impl_ok1 impl_ok2 para = let id_iF = Ident.create_fresh Ident.kprimed in let id_iF' = Ident.create_fresh Ident.kprimed in @@ -371,7 +382,7 @@ let mk_rule_dllpts_dll tenv k1 impl_ok1 impl_ok2 para = let exps_shared = List.map ~f:(fun id -> Exp.Var id) ids_shared in let ids_exist, para_inst = Sil.hpara_dll_instantiate para exp_iF' exp_oB' exp_oF exps_shared in let para_inst_pat = - let allow_impl hpred = {Match.hpred= hpred; Match.flag= impl_ok2} in + let allow_impl hpred = {Match.hpred; Match.flag= impl_ok2} in List.map ~f:allow_impl para_inst in let dllseg_pat = @@ -391,6 +402,7 @@ let mk_rule_dllpts_dll tenv k1 impl_ok1 impl_ok2 para = ; r_new_sigma= [dllseg_res] ; r_condition= condition } + let mk_rule_dlldll_dll tenv k1 k2 impl_ok1 impl_ok2 para = let id_iF = Ident.create_fresh Ident.kprimed in let id_iF' = Ident.create_fresh Ident.kprimed in @@ -432,6 +444,7 @@ let mk_rule_dlldll_dll tenv k1 k2 impl_ok1 impl_ok2 para = ; r_new_pi= gen_pi_res ; r_condition= condition } + let mk_rules_for_dll tenv (para: Sil.hpara_dll) : rule list = if not Config.nelseg then let pts_pts = mk_rule_ptspts_dll tenv true true para in @@ -448,41 +461,43 @@ let mk_rules_for_dll tenv (para: Sil.hpara_dll) : rule list = let dlldll_dll = mk_rule_dlldll_dll tenv Sil.Lseg_NE Sil.Lseg_NE false false para in [ptspts_dll; ptsdll_dll; dllpts_dll; dlldll_dll] + (****************** End of DLL abstraction rules ******************) (****************** Start of Predicate Discovery ******************) let typ_get_recursive_flds tenv typ_exp = let filter typ (_, (t: Typ.t), _) = match t.desc with - | Tstruct _ | Tint _ | Tfloat _ | Tvoid | Tfun _ | TVar _ - -> false - | Tptr (({desc= Tstruct _} as typ'), _) - -> Typ.equal typ' typ - | Tptr _ | Tarray _ - -> false + | Tstruct _ | Tint _ | Tfloat _ | Tvoid | Tfun _ | TVar _ -> + false + | Tptr (({desc= Tstruct _} as typ'), _) -> + Typ.equal typ' typ + | Tptr _ | Tarray _ -> + false in match typ_exp with | Exp.Sizeof {typ} -> ( match typ.desc with | Tstruct name -> ( match Tenv.lookup tenv name with - | Some {fields} - -> List.map ~f:fst3 (List.filter ~f:(filter typ) fields) - | None - -> L.(debug Analysis Quiet) + | Some {fields} -> + List.map ~f:fst3 (List.filter ~f:(filter typ) fields) + | None -> + L.(debug Analysis Quiet) "@\ntyp_get_recursive_flds: unexpected %a unknown struct type: %a@." Exp.pp typ_exp Typ.Name.pp name ; [] (* ToDo: assert false *) ) - | Tint _ | Tvoid | Tfun _ | Tptr _ | Tfloat _ | Tarray _ | TVar _ - -> [] ) - | Exp.Var _ - -> [] (* type of |-> not known yet *) - | Exp.Const _ - -> [] - | _ - -> L.internal_error "@\ntyp_get_recursive_flds: unexpected type expr: %a@." Exp.pp typ_exp ; + | Tint _ | Tvoid | Tfun _ | Tptr _ | Tfloat _ | Tarray _ | TVar _ -> + [] ) + | Exp.Var _ -> + [] (* type of |-> not known yet *) + | Exp.Const _ -> + [] + | _ -> + L.internal_error "@\ntyp_get_recursive_flds: unexpected type expr: %a@." Exp.pp typ_exp ; assert false + let discover_para_roots tenv p root1 next1 root2 next2 : Sil.hpara option = let eq_arg1 = Exp.equal root1 next1 in let eq_arg2 = Exp.equal root2 next2 in @@ -493,12 +508,13 @@ let discover_para_roots tenv p root1 next1 root2 next2 : Sil.hpara option = let todos = [(root1, root2)] in let sigma = p.Prop.sigma in match Match.find_partial_iso tenv (Prover.check_equal tenv p) corres todos sigma with - | None - -> None - | Some (new_corres, new_sigma1, _, _) - -> let hpara, _ = Match.hpara_create tenv new_corres new_sigma1 root1 next1 in + | None -> + None + | Some (new_corres, new_sigma1, _, _) -> + let hpara, _ = Match.hpara_create tenv new_corres new_sigma1 root1 next1 in Some hpara + let discover_para_dll_roots tenv p root1 blink1 flink1 root2 blink2 flink2 : Sil.hpara_dll option = let eq_arg1 = Exp.equal root1 blink1 in let eq_arg1' = Exp.equal root1 flink1 in @@ -511,41 +527,42 @@ let discover_para_dll_roots tenv p root1 blink1 flink1 root2 blink2 flink2 : Sil let todos = [(root1, root2)] in let sigma = p.Prop.sigma in match Match.find_partial_iso tenv (Prover.check_equal tenv p) corres todos sigma with - | None - -> None - | Some (new_corres, new_sigma1, _, _) - -> let hpara_dll, _ = Match.hpara_dll_create tenv new_corres new_sigma1 root1 blink1 flink1 in + | None -> + None + | Some (new_corres, new_sigma1, _, _) -> + let hpara_dll, _ = Match.hpara_dll_create tenv new_corres new_sigma1 root1 blink1 flink1 in Some hpara_dll + let discover_para_candidates tenv p = let edges = ref [] in let add_edge edg = edges := edg :: !edges in let get_edges_strexp rec_flds root se = let is_rec_fld fld = List.exists ~f:(Typ.Fieldname.equal fld) rec_flds in match se with - | Sil.Eexp _ | Sil.Earray _ - -> () - | Sil.Estruct (fsel, _) - -> let fsel' = List.filter ~f:(fun (fld, _) -> is_rec_fld fld) fsel in + | Sil.Eexp _ | Sil.Earray _ -> + () + | Sil.Estruct (fsel, _) -> + let fsel' = List.filter ~f:(fun (fld, _) -> is_rec_fld fld) fsel in let process (_, nextse) = match nextse with Sil.Eexp (next, _) -> add_edge (root, next) | _ -> assert false in List.iter ~f:process fsel' in let rec get_edges_sigma = function - | [] - -> () - | (Sil.Hlseg _) :: sigma_rest | (Sil.Hdllseg _) :: sigma_rest - -> get_edges_sigma sigma_rest - | (Sil.Hpointsto (root, se, te)) :: sigma_rest - -> let rec_flds = typ_get_recursive_flds tenv te in + | [] -> + () + | (Sil.Hlseg _) :: sigma_rest | (Sil.Hdllseg _) :: sigma_rest -> + get_edges_sigma sigma_rest + | (Sil.Hpointsto (root, se, te)) :: sigma_rest -> + let rec_flds = typ_get_recursive_flds tenv te in get_edges_strexp rec_flds root se ; get_edges_sigma sigma_rest in let rec find_all_consecutive_edges found edges_seen = function - | [] - -> List.rev found - | (e1, e2) :: edges_notseen - -> let edges_others = List.rev_append edges_seen edges_notseen in + | [] -> + List.rev found + | (e1, e2) :: edges_notseen -> + let edges_others = List.rev_append edges_seen edges_notseen in let edges_matched = List.filter ~f:(fun (e1', _) -> Exp.equal e2 e1') edges_others in let new_found = let f found_acc (_, e3) = (e1, e2, e3) :: found_acc in @@ -558,43 +575,44 @@ let discover_para_candidates tenv p = get_edges_sigma sigma ; find_all_consecutive_edges [] [] !edges + let discover_para_dll_candidates tenv p = let edges = ref [] in let add_edge edg = edges := edg :: !edges in let get_edges_strexp rec_flds root se = let is_rec_fld fld = List.exists ~f:(Typ.Fieldname.equal fld) rec_flds in match se with - | Sil.Eexp _ | Sil.Earray _ - -> () - | Sil.Estruct (fsel, _) - -> let fsel' = List.rev_filter ~f:(fun (fld, _) -> is_rec_fld fld) fsel in + | Sil.Eexp _ | Sil.Earray _ -> + () + | Sil.Estruct (fsel, _) -> + let fsel' = List.rev_filter ~f:(fun (fld, _) -> is_rec_fld fld) fsel in let convert_to_exp acc (_, se) = match se with Sil.Eexp (e, _) -> e :: acc | _ -> assert false in let links = List.fold ~f:convert_to_exp ~init:[] fsel' in let rec iter_pairs = function - | [] - -> () - | x :: l - -> List.iter ~f:(fun y -> add_edge (root, x, y)) l ; + | [] -> + () + | x :: l -> + List.iter ~f:(fun y -> add_edge (root, x, y)) l ; iter_pairs l in iter_pairs links in let rec get_edges_sigma = function - | [] - -> () - | (Sil.Hlseg _) :: sigma_rest | (Sil.Hdllseg _) :: sigma_rest - -> get_edges_sigma sigma_rest - | (Sil.Hpointsto (root, se, te)) :: sigma_rest - -> let rec_flds = typ_get_recursive_flds tenv te in + | [] -> + () + | (Sil.Hlseg _) :: sigma_rest | (Sil.Hdllseg _) :: sigma_rest -> + get_edges_sigma sigma_rest + | (Sil.Hpointsto (root, se, te)) :: sigma_rest -> + let rec_flds = typ_get_recursive_flds tenv te in get_edges_strexp rec_flds root se ; get_edges_sigma sigma_rest in let rec find_all_consecutive_edges found edges_seen = function - | [] - -> List.rev found - | (iF, blink, flink) :: edges_notseen - -> let edges_others = List.rev_append edges_seen edges_notseen in + | [] -> + List.rev found + | (iF, blink, flink) :: edges_notseen -> + let edges_others = List.rev_append edges_seen edges_notseen in let edges_matched = List.filter ~f:(fun (e1', _, _) -> Exp.equal flink e1') edges_others in let new_found = let f found_acc (_, _, flink2) = (iF, blink, flink, flink2) :: found_acc in @@ -607,6 +625,7 @@ let discover_para_dll_candidates tenv p = get_edges_sigma sigma ; find_all_consecutive_edges [] [] !edges + let discover_para tenv p = let candidates = discover_para_candidates tenv p in let already_defined para paras = @@ -614,13 +633,14 @@ let discover_para tenv p = in let f paras (root, next, out) = match discover_para_roots tenv p root next next out with - | None - -> paras - | Some para - -> if already_defined para paras then paras else para :: paras + | None -> + paras + | Some para -> + if already_defined para paras then paras else para :: paras in List.fold ~f ~init:[] candidates + let discover_para_dll tenv p = (* L.out "@[.... Called discover_dll para ...@."; @@ -632,13 +652,14 @@ let discover_para_dll tenv p = in let f paras (iF, oB, iF', oF) = match discover_para_dll_roots tenv p iF oB iF' iF' iF oF with - | None - -> paras - | Some para - -> if already_defined para paras then paras else para :: paras + | None -> + paras + | Some para -> + if already_defined para paras then paras else para :: paras in List.fold ~f ~init:[] candidates + (****************** End of Predicate Discovery ******************) (****************** Start of the ADT abs_rules ******************) @@ -663,6 +684,7 @@ let reset_current_rules () = Global.current_rules := [] let eqs_sub subst eqs = List.map ~f:(fun (e1, e2) -> (Sil.exp_sub (`Exp subst) e1, Sil.exp_sub (`Exp subst) e2)) eqs + let eqs_solve ids_in eqs_in = let rec solve (sub: Sil.exp_subst) (eqs: (Exp.t * Exp.t) list) : Sil.exp_subst option = let do_default id e eqs_rest = @@ -670,31 +692,31 @@ let eqs_solve ids_in eqs_in = else let sub' = match Sil.extend_sub sub id e with - | None - -> L.internal_error "@\n@\nERROR : Buggy Implementation.@\n@." ; + | None -> + L.internal_error "@\n@\nERROR : Buggy Implementation.@\n@." ; assert false - | Some sub' - -> sub' + | Some sub' -> + sub' in let eqs_rest' = eqs_sub sub' eqs_rest in solve sub' eqs_rest' in match eqs with - | [] - -> Some sub - | (e1, e2) :: eqs_rest when Exp.equal e1 e2 - -> solve sub eqs_rest - | (Exp.Var id1, (Exp.Const _ as e2)) :: eqs_rest - -> do_default id1 e2 eqs_rest - | ((Exp.Const _ as e1), (Exp.Var _ as e2)) :: eqs_rest - -> solve sub ((e2, e1) :: eqs_rest) - | ((Exp.Var id1 as e1), (Exp.Var id2 as e2)) :: eqs_rest - -> let n = Ident.compare id1 id2 in + | [] -> + Some sub + | (e1, e2) :: eqs_rest when Exp.equal e1 e2 -> + solve sub eqs_rest + | (Exp.Var id1, (Exp.Const _ as e2)) :: eqs_rest -> + do_default id1 e2 eqs_rest + | ((Exp.Const _ as e1), (Exp.Var _ as e2)) :: eqs_rest -> + solve sub ((e2, e1) :: eqs_rest) + | ((Exp.Var id1 as e1), (Exp.Var id2 as e2)) :: eqs_rest -> + let n = Ident.compare id1 id2 in if Int.equal n 0 then solve sub eqs_rest else if n > 0 then solve sub ((e2, e1) :: eqs_rest) else do_default id1 e2 eqs_rest - | _ :: _ - -> None + | _ :: _ -> + None in let compute_ids sub = let sub_list = Sil.sub_to_list sub in @@ -704,22 +726,23 @@ let eqs_solve ids_in eqs_in = in match solve Sil.exp_sub_empty eqs_in with None -> None | Some sub -> Some (compute_ids sub, sub) + let sigma_special_cases_eqs sigma = let rec f ids_acc eqs_acc sigma_acc = function - | [] - -> [(List.rev ids_acc, List.rev eqs_acc, List.rev sigma_acc)] - | (Sil.Hpointsto _ as hpred) :: sigma_rest - -> f ids_acc eqs_acc (hpred :: sigma_acc) sigma_rest - | (Sil.Hlseg (_, para, e1, e2, es) as hpred) :: sigma_rest - -> let empty_case = f ids_acc ((e1, e2) :: eqs_acc) sigma_acc sigma_rest in + | [] -> + [(List.rev ids_acc, List.rev eqs_acc, List.rev sigma_acc)] + | (Sil.Hpointsto _ as hpred) :: sigma_rest -> + f ids_acc eqs_acc (hpred :: sigma_acc) sigma_rest + | (Sil.Hlseg (_, para, e1, e2, es) as hpred) :: sigma_rest -> + let empty_case = f ids_acc ((e1, e2) :: eqs_acc) sigma_acc sigma_rest in let pointsto_case = let eids, para_inst = Sil.hpara_instantiate para e1 e2 es in f (eids @ ids_acc) eqs_acc sigma_acc (para_inst @ sigma_rest) in let general_case = f ids_acc eqs_acc (hpred :: sigma_acc) sigma_rest in empty_case @ pointsto_case @ general_case - | (Sil.Hdllseg (_, para, e1, e2, e3, e4, es) as hpred) :: sigma_rest - -> let empty_case = f ids_acc ((e1, e3) :: (e2, e4) :: eqs_acc) sigma_acc sigma_rest in + | (Sil.Hdllseg (_, para, e1, e2, e3, e4, es) as hpred) :: sigma_rest -> + let empty_case = f ids_acc ((e1, e3) :: (e2, e4) :: eqs_acc) sigma_acc sigma_rest in let pointsto_case = let eids, para_inst = Sil.hpara_dll_instantiate para e1 e2 e3 es in f (eids @ ids_acc) eqs_acc sigma_acc (para_inst @ sigma_rest) @@ -729,39 +752,43 @@ let sigma_special_cases_eqs sigma = in f [] [] [] sigma + let sigma_special_cases ids sigma : (Ident.t list * Sil.hpred list) list = let special_cases_eqs = sigma_special_cases_eqs sigma in let special_cases_rev = let f acc (eids_cur, eqs_cur, sigma_cur) = let ids_all = ids @ eids_cur in match eqs_solve ids_all eqs_cur with - | None - -> acc - | Some (ids_res, sub) - -> (ids_res, List.map ~f:(Sil.hpred_sub (`Exp sub)) sigma_cur) :: acc + | None -> + acc + | Some (ids_res, sub) -> + (ids_res, List.map ~f:(Sil.hpred_sub (`Exp sub)) sigma_cur) :: acc in List.fold ~f ~init:[] special_cases_eqs in List.rev special_cases_rev + let hpara_special_cases hpara : Sil.hpara list = let update_para (evars', body') = {hpara with Sil.evars= evars'; Sil.body= body'} in let special_cases = sigma_special_cases hpara.Sil.evars hpara.Sil.body in List.map ~f:update_para special_cases + let hpara_special_cases_dll hpara : Sil.hpara_dll list = let update_para (evars', body') = {hpara with Sil.evars_dll= evars'; Sil.body_dll= body'} in let special_cases = sigma_special_cases hpara.Sil.evars_dll hpara.Sil.body_dll in List.map ~f:update_para special_cases + let abs_rules_apply_rsets tenv (rsets: rule_set list) (p_in: Prop.normal Prop.t) : Prop.normal Prop.t = let apply_rule (changed, p) r = match sigma_rewrite tenv p r with - | None - -> (changed, p) - | Some p' - -> (* + | None -> + (changed, p) + | Some p' -> + (* L.out "@[.... abstraction (rewritten in abs_rules) ....@."; L.out "@[<4> PROP:%a@\n@." pp_prop p'; *) @@ -774,6 +801,7 @@ let abs_rules_apply_rsets tenv (rsets: rule_set list) (p_in: Prop.normal Prop.t) in List.fold ~f:apply_rule_set ~init:p_in rsets + let abs_rules_apply_lists tenv (p_in: Prop.normal Prop.t) : Prop.normal Prop.t = let new_rsets = ref [] in let old_rsets = get_current_rules () in @@ -823,9 +851,11 @@ let abs_rules_apply_lists tenv (p_in: Prop.normal Prop.t) : Prop.normal Prop.t = let new_rules = old_rsets @ !new_rsets in set_current_rules new_rules ; p2 + let abs_rules_apply tenv (p_in: Prop.normal Prop.t) : Prop.normal Prop.t = abs_rules_apply_lists tenv p_in + (****************** End of the ADT abs_rules ******************) (****************** Start of Main Abstraction Functions ******************) let abstract_pure_part tenv p ~(from_abstract_footprint: bool) = @@ -853,14 +883,14 @@ let abstract_pure_part tenv p ~(from_abstract_footprint: bool) = | Sil.Aeq (Exp.BinOp (Binop.Lt, _, _), Exp.Const Const.Cint i) | Sil.Aeq (Exp.Const Const.Cint i, Exp.BinOp (Binop.Le, _, _)) | Sil.Aeq (Exp.BinOp (Binop.Le, _, _), Exp.Const Const.Cint i) - when IntLit.isone i - -> a :: pi + when IntLit.isone i -> + a :: pi | Sil.Aeq (Exp.Var name, e) when not (Ident.is_primed name) -> ( match e with Exp.Var _ | Exp.Const _ -> a :: pi | _ -> pi ) - | Sil.Aneq (Var _, _) | Sil.Apred (_, (Var _) :: _) | Anpred (_, (Var _) :: _) - -> a :: pi - | Sil.Aeq _ | Aneq _ | Apred _ | Anpred _ - -> pi) + | Sil.Aneq (Var _, _) | Sil.Apred (_, (Var _) :: _) | Anpred (_, (Var _) :: _) -> + a :: pi + | Sil.Aeq _ | Aneq _ | Apred _ | Anpred _ -> + pi) ~init:[] pi_filtered in List.rev new_pure @@ -875,6 +905,7 @@ let abstract_pure_part tenv p ~(from_abstract_footprint: bool) = in Prop.normalize tenv eprop'' + (** Collect symbolic garbage from pi and sigma *) let abstract_gc tenv p = let pi = p.Prop.pi in @@ -884,8 +915,8 @@ let abstract_gc tenv p = let fav_atom = atom_fav atom in IList.intersect compare fav_p_without_pi fav_atom in *) let strong_filter = function - | Sil.Aeq (e1, e2) | Sil.Aneq (e1, e2) - -> let fav_e1 = Sil.exp_fav e1 in + | Sil.Aeq (e1, e2) | Sil.Aneq (e1, e2) -> + let fav_e1 = Sil.exp_fav e1 in let fav_e2 = Sil.exp_fav e2 in let intersect_e1 _ = IList.intersect Ident.compare (Sil.fav_to_list fav_e1) (Sil.fav_to_list fav_p_without_pi) @@ -896,18 +927,19 @@ let abstract_gc tenv p = let no_fav_e1 = Sil.fav_is_empty fav_e1 in let no_fav_e2 = Sil.fav_is_empty fav_e2 in (no_fav_e1 || intersect_e1 ()) && (no_fav_e2 || intersect_e2 ()) - | Sil.Apred _ | Anpred _ as a - -> let fav_a = Sil.atom_fav a in + | Sil.Apred _ | Anpred _ as a -> + let fav_a = Sil.atom_fav a in Sil.fav_is_empty fav_a || IList.intersect Ident.compare (Sil.fav_to_list fav_a) (Sil.fav_to_list fav_p_without_pi) in let new_pi = List.filter ~f:strong_filter pi in let prop = Prop.normalize tenv (Prop.set p ~pi:new_pi) in match Prop.prop_iter_create prop with - | None - -> prop - | Some iter - -> Prop.prop_iter_to_prop tenv (Prop.prop_iter_gc_fields iter) + | None -> + prop + | Some iter -> + Prop.prop_iter_to_prop tenv (Prop.prop_iter_gc_fields iter) + (** maps from identifiers *) module IdMap = Caml.Map.Make (Ident) @@ -920,12 +952,13 @@ end) let hpred_entries hpred = match hpred with - | Sil.Hpointsto (e, _, _) - -> [e] - | Sil.Hlseg (_, _, e, _, _) - -> [e] - | Sil.Hdllseg (_, _, e1, _, _, e2, _) - -> [e1; e2] + | Sil.Hpointsto (e, _, _) -> + [e] + | Sil.Hlseg (_, _, e, _, _) -> + [e] + | Sil.Hdllseg (_, _, e1, _, _, e2, _) -> + [e1; e2] + (** find the id's in sigma reachable from the given roots *) let sigma_reachable root_fav sigma = @@ -940,18 +973,18 @@ let sigma_reachable root_fav sigma = List.iter ~f:do_hpred sigma ; let edge_fires (e, _) = match e with - | Exp.Var id - -> if Ident.is_primed id || Ident.is_footprint id then Ident.IdentSet.mem id !reach_set + | Exp.Var id -> + if Ident.is_primed id || Ident.is_footprint id then Ident.IdentSet.mem id !reach_set else true - | _ - -> true + | _ -> + true in let rec apply_once edges_to_revisit edges_todo modified = match edges_todo with - | [] - -> (edges_to_revisit, modified) - | edge :: edges_todo' - -> if edge_fires edge then ( + | [] -> + (edges_to_revisit, modified) + | edge :: edges_todo' -> + if edge_fires edge then ( reach_set := Ident.IdentSet.union (snd edge) !reach_set ; apply_once edges_to_revisit edges_todo' true ) else apply_once (edge :: edges_to_revisit) edges_todo' modified @@ -966,29 +999,30 @@ let sigma_reachable root_fav sigma = L.d_ln (); *) !reach_set + let get_cycle root prop = let sigma = prop.Prop.sigma in let get_points_to e = match e with - | Sil.Eexp (e', _) - -> List.find + | Sil.Eexp (e', _) -> + List.find ~f:(fun hpred -> match hpred with Sil.Hpointsto (e'', _, _) -> Exp.equal e'' e' | _ -> false) sigma - | _ - -> None + | _ -> + None in let print_cycle cyc = L.d_str "Cycle= " ; List.iter ~f:(fun ((e, t), f, e') -> match (e, e') with - | Sil.Eexp (e, _), Sil.Eexp (e', _) - -> L.d_str + | Sil.Eexp (e, _), Sil.Eexp (e', _) -> + L.d_str ( "(" ^ Exp.to_string e ^ ": " ^ Typ.to_string t ^ ", " ^ Typ.Fieldname.to_string f ^ ", " ^ Exp.to_string e' ^ ")" ) - | _ - -> ()) + | _ -> + ()) cyc ; L.d_strln "" in @@ -997,21 +1031,21 @@ let get_cycle root prop = describing the path to e_root and bool is true if e_root is reached. *) let rec dfs e_root et_src path el visited = match el with - | [] - -> (path, false) - | (f, e) :: el' - -> if Sil.equal_strexp e e_root then ((et_src, f, e) :: path, true) + | [] -> + (path, false) + | (f, e) :: el' -> + if Sil.equal_strexp e e_root then ((et_src, f, e) :: path, true) else if List.mem ~equal:Sil.equal_strexp visited e then (path, false) else let visited' = fst et_src :: visited in let res = match get_points_to e with - | None - -> (path, false) - | Some Sil.Hpointsto (_, Sil.Estruct (fl, _), Exp.Sizeof {typ= te}) - -> dfs e_root (e, te) ((et_src, f, e) :: path) fl visited' - | _ - -> (path, false) + | None -> + (path, false) + | Some Sil.Hpointsto (_, Sil.Estruct (fl, _), Exp.Sizeof {typ= te}) -> + dfs e_root (e, te) ((et_src, f, e) :: path) fl visited' + | _ -> + (path, false) (* check for lists *) in if snd res then res else dfs e_root et_src path el' visited' @@ -1020,14 +1054,18 @@ let get_cycle root prop = Sil.d_hpred root ; L.d_strln "" ; match root with - | Sil.Hpointsto (e_root, Sil.Estruct (fl, _), Exp.Sizeof {typ= te}) - -> let se_root = Sil.Eexp (e_root, Sil.Inone) in + | Sil.Hpointsto (e_root, Sil.Estruct (fl, _), Exp.Sizeof {typ= te}) -> + let se_root = Sil.Eexp (e_root, Sil.Inone) in (* start dfs with empty path and expr pointing to root *) let pot_cycle, res = dfs se_root (se_root, te) [] fl [] in if res then ( print_cycle pot_cycle ; pot_cycle ) - else ( L.d_strln "NO cycle found from root" ; [] ) - | _ - -> L.d_strln "Root exp is not an allocated object. No cycle found" ; [] + else ( + L.d_strln "NO cycle found from root" ; + [] ) + | _ -> + L.d_strln "Root exp is not an allocated object. No cycle found" ; + [] + (** Check whether the hidden counter field of a struct representing an objective-c object is positive, and whether the leak is part of the specified buckets. In the positive case, it @@ -1036,36 +1074,38 @@ let should_raise_objc_leak hpred = match hpred with | Sil.Hpointsto (_, Sil.Estruct ((fn, Sil.Eexp (Exp.Const Const.Cint i, _)) :: _, _), Exp.Sizeof {typ}) - when Typ.Fieldname.is_hidden fn && IntLit.gt i IntLit.zero (* counter > 0 *) - -> Mleak_buckets.should_raise_objc_leak typ - | _ - -> None + when Typ.Fieldname.is_hidden fn && IntLit.gt i IntLit.zero (* counter > 0 *) -> + Mleak_buckets.should_raise_objc_leak typ + | _ -> + None + let get_retain_cycle_dotty _prop cycle = match _prop with - | None - -> None - | Some Some _prop - -> Dotty.dotty_prop_to_str _prop cycle - | _ - -> None + | None -> + None + | Some Some _prop -> + Dotty.dotty_prop_to_str _prop cycle + | _ -> + None + let get_var_retain_cycle prop_ = let sigma = prop_.Prop.sigma in let is_pvar v h = match h with - | Sil.Hpointsto (Exp.Lvar _, v', _) when Sil.equal_strexp v v' - -> true - | _ - -> false + | Sil.Hpointsto (Exp.Lvar _, v', _) when Sil.equal_strexp v v' -> + true + | _ -> + false in let is_hpred_block v h = match (h, v) with | Sil.Hpointsto (e, _, Exp.Sizeof {typ}), Sil.Eexp (e', _) - when Exp.equal e e' && Typ.is_block_type typ - -> true - | _, _ - -> false + when Exp.equal e e' && Typ.is_block_type typ -> + true + | _, _ -> + false in let find v = List.find ~f:(is_pvar v) sigma |> Option.map ~f:Sil.hpred_get_lhs in let find_block v = @@ -1074,14 +1114,14 @@ let get_var_retain_cycle prop_ = let sexp e = Sil.Eexp (e, Sil.Inone) in let find_or_block ((e, t), f, e') = match find e with - | Some pvar - -> [((sexp pvar, t), f, e')] + | Some pvar -> + [((sexp pvar, t), f, e')] | _ -> match find_block e with - | Some blk - -> [((sexp blk, t), f, e')] - | _ - -> let sizeof = {Exp.typ= t; nbytes= None; dynamic_length= None; subtype= Subtype.exact} in + | Some blk -> + [((sexp blk, t), f, e')] + | _ -> + let sizeof = {Exp.typ= t; nbytes= None; dynamic_length= None; subtype= Subtype.exact} in [((sexp (Exp.Sizeof sizeof), t), f, e')] in (* returns the pvars of the first cycle we find in sigma. @@ -1090,16 +1130,17 @@ let get_var_retain_cycle prop_ = the one we are looking for. *) let rec do_sigma sigma_todo = match sigma_todo with - | [] - -> [] - | hp :: sigma' - -> let cycle = get_cycle hp prop_ in + | [] -> + [] + | hp :: sigma' -> + let cycle = get_cycle hp prop_ in L.d_strln "Filtering pvar in cycle " ; let cycle' = List.concat_map ~f:find_or_block cycle in if List.is_empty cycle' then do_sigma sigma' else cycle' in do_sigma sigma + let remove_opt _prop = match _prop with Some Some p -> p | _ -> Prop.prop_emp (** Checks if cycle has fields (derived from a property or directly defined as ivar) with attributes @@ -1109,26 +1150,26 @@ let cycle_has_weak_or_unretained_or_assign_field tenv cycle = let get_item_annotation (t: Typ.t) fn = match t.desc with | Tstruct name - -> ( + -> ( let equal_fn (fn', _, _) = Typ.Fieldname.equal fn fn' in match Tenv.lookup tenv name with - | Some {fields; statics} - -> List.find ~f:equal_fn (fields @ statics) |> Option.value_map ~f:trd3 ~default:[] - | None - -> [] ) - | _ - -> [] + | Some {fields; statics} -> + List.find ~f:equal_fn (fields @ statics) |> Option.value_map ~f:trd3 ~default:[] + | None -> + [] ) + | _ -> + [] in let rec has_weak_or_unretained_or_assign params = match params with - | [] - -> false + | [] -> + false | att :: _ when String.equal Config.unsafe_unret att || String.equal Config.weak att - || String.equal Config.assign att - -> true - | _ :: params' - -> has_weak_or_unretained_or_assign params' + || String.equal Config.assign att -> + true + | _ :: params' -> + has_weak_or_unretained_or_assign params' in let do_annotation ((a: Annot.t), _) = ( String.equal a.class_name Config.property_attributes @@ -1137,36 +1178,38 @@ let cycle_has_weak_or_unretained_or_assign_field tenv cycle = in let rec do_cycle c = match c with - | [] - -> false - | ((_, t), fn, _) :: c' - -> let ia = get_item_annotation t fn in + | [] -> + false + | ((_, t), fn, _) :: c' -> + let ia = get_item_annotation t fn in if List.exists ~f:do_annotation ia then true else do_cycle c' in do_cycle cycle + let check_observer_is_unsubscribed_deallocation tenv prop e = let pvar_opt = match Attribute.get_resource tenv prop e with - | Some Apred (Aresource {ra_vpath= Some Dpvar pvar}, _) - -> Some pvar - | _ - -> None + | Some Apred (Aresource {ra_vpath= Some Dpvar pvar}, _) -> + Some pvar + | _ -> + None in let loc = State.get_loc () in match Attribute.get_observer tenv prop e with | Some Apred (Aobserver, _) -> ( match pvar_opt with - | Some pvar when Config.nsnotification_center_checker_backend - -> L.d_strln + | Some pvar when Config.nsnotification_center_checker_backend -> + L.d_strln ( " ERROR: Object " ^ Pvar.to_string pvar ^ " is being deallocated while still registered in a notification center" ) ; let desc = Localise.desc_registered_observer_being_deallocated pvar loc in raise (Exceptions.Registered_observer_being_deallocated (desc, __POS__)) - | _ - -> () ) - | _ - -> () + | _ -> + () ) + | _ -> + () + let check_junk ?original_prop pname tenv prop = let fav_sub_sigmafp = Sil.fav_new () in @@ -1181,11 +1224,11 @@ let check_junk ?original_prop pname tenv prop = in let should_remove_hpred entries = let predicate = function - | Exp.Var id - -> (Ident.is_primed id || Ident.is_footprint id) && not (Sil.fav_mem fav_root id) + | Exp.Var id -> + (Ident.is_primed id || Ident.is_footprint id) && not (Sil.fav_mem fav_root id) && not (id_considered_reachable id) - | _ - -> false + | _ -> + false in List.for_all ~f:predicate entries in @@ -1203,20 +1246,20 @@ let check_junk ?original_prop pname tenv prop = let hpred_is_loop = match hpred with (* true if hpred has a self loop, ie one field points to id *) - | Sil.Hpointsto (Exp.Var id, se, _) - -> let fav = Sil.fav_new () in + | Sil.Hpointsto (Exp.Var id, se, _) -> + let fav = Sil.fav_new () in Sil.strexp_fav_add fav se ; Sil.fav_mem fav id - | _ - -> false + | _ -> + false in hpred_is_loop || List.exists ~f:predicate entries in let rec remove_junk_recursive sigma_done sigma_todo = match sigma_todo with - | [] - -> List.rev sigma_done - | hpred :: sigma_todo' - -> let entries = hpred_entries hpred in + | [] -> + List.rev sigma_done + | hpred :: sigma_todo' -> + let entries = hpred_entries hpred in if should_remove_hpred entries then let part = if fp_part then "footprint" else "normal" in L.d_strln (".... Prop with garbage in " ^ part ^ " part ....") ; @@ -1233,23 +1276,23 @@ let check_junk ?original_prop pname tenv prop = let do_entry e = check_observer_is_unsubscribed_deallocation tenv prop e ; match Attribute.get_wontleak tenv prop e with - | Some Apred ((Awont_leak as a), _) - -> L.d_strln "WONT_LEAK" ; + | Some Apred ((Awont_leak as a), _) -> + L.d_strln "WONT_LEAK" ; res := Some a | _ -> match Attribute.get_resource tenv prop e with - | Some Apred ((Aresource {ra_kind= Racquire} as a), _) - -> L.d_str "ATTRIBUTE: " ; + | Some Apred ((Aresource {ra_kind= Racquire} as a), _) -> + L.d_str "ATTRIBUTE: " ; PredSymb.d_attribute a ; L.d_ln () ; res := Some a | _ -> match Attribute.get_undef tenv prop e with - | Some Apred ((Aundef _ as a), _) - -> L.d_strln "UNDEF" ; + | Some Apred ((Aundef _ as a), _) -> + L.d_strln "UNDEF" ; res := Some a - | _ - -> () + | _ -> + () in List.iter ~f:do_entry entries ; !res in @@ -1259,21 +1302,21 @@ let check_junk ?original_prop pname tenv prop = in let resource = match Errdesc.hpred_is_open_resource tenv prop hpred with - | Some res - -> res - | None - -> PredSymb.Rmemory PredSymb.Mmalloc + | Some res -> + res + | None -> + PredSymb.Rmemory PredSymb.Mmalloc in let ml_bucket_opt = match resource with - | PredSymb.Rmemory PredSymb.Mobjc - -> should_raise_objc_leak hpred + | PredSymb.Rmemory PredSymb.Mobjc -> + should_raise_objc_leak hpred | PredSymb.Rmemory PredSymb.Mnew | PredSymb.Rmemory PredSymb.Mnew_array - when Config.curr_language_is Config.Clang - -> Mleak_buckets.should_raise_cpp_leak - | _ - -> None + when Config.curr_language_is Config.Clang -> + Mleak_buckets.should_raise_cpp_leak + | _ -> + None in let exn_retain_cycle cycle = let cycle_dotty = get_retain_cycle_dotty original_prop cycle in @@ -1291,10 +1334,10 @@ let check_junk ?original_prop pname tenv prop = in let ignore_resource, exn = match (alloc_attribute, resource) with - | Some PredSymb.Awont_leak, Rmemory _ - -> (true, exn_leak) - | Some _, Rmemory Mobjc when hpred_in_cycle hpred - -> (* When there is a cycle in objc we ignore it + | Some PredSymb.Awont_leak, Rmemory _ -> + (true, exn_leak) + | Some _, Rmemory Mobjc when hpred_in_cycle hpred -> + (* When there is a cycle in objc we ignore it only if it's empty or it has weak or unsafe_unretained fields. Otherwise we report a retain cycle. *) let cycle = get_var_retain_cycle (remove_opt original_prop) in @@ -1306,36 +1349,36 @@ let check_junk ?original_prop pname tenv prop = | Some _, Rmemory Mobjc | Some _, Rmemory Mnew | Some _, Rmemory Mnew_array - when Config.curr_language_is Config.Clang - -> (is_none ml_bucket_opt, exn_leak) - | Some _, Rmemory _ - -> (Config.curr_language_is Config.Java, exn_leak) - | Some _, Rignore - -> (true, exn_leak) - | Some _, Rfile when Config.tracing - -> (true, exn_leak) - | Some _, Rfile - -> (false, exn_leak) - | Some _, Rlock - -> (false, exn_leak) - | _ when hpred_in_cycle hpred && Sil.has_objc_ref_counter tenv hpred - -> (* When it's a cycle and the object has a ref counter then + when Config.curr_language_is Config.Clang -> + (is_none ml_bucket_opt, exn_leak) + | Some _, Rmemory _ -> + (Config.curr_language_is Config.Java, exn_leak) + | Some _, Rignore -> + (true, exn_leak) + | Some _, Rfile when Config.tracing -> + (true, exn_leak) + | Some _, Rfile -> + (false, exn_leak) + | Some _, Rlock -> + (false, exn_leak) + | _ when hpred_in_cycle hpred && Sil.has_objc_ref_counter tenv hpred -> + (* When it's a cycle and the object has a ref counter then we have a retain cycle. Objc object may not have the Mobjc qualifier when added in footprint doing abduction *) let cycle = get_var_retain_cycle (remove_opt original_prop) in (Int.equal (List.length cycle) 0, exn_retain_cycle cycle) - | _ - -> (Config.curr_language_is Config.Java, exn_leak) + | _ -> + (Config.curr_language_is Config.Java, exn_leak) in let already_reported () = let attr_opt_equal ao1 ao2 = match (ao1, ao2) with - | None, None - -> true - | Some a1, Some a2 - -> PredSymb.equal a1 a2 - | Some _, None | None, Some _ - -> false + | None, None -> + true + | Some a1, Some a2 -> + PredSymb.equal a1 a2 + | Some _, None | None, Some _ -> + false in is_none alloc_attribute && !leaks_reported <> [] || (* None attribute only reported if it's the first one *) @@ -1369,18 +1412,21 @@ let check_junk ?original_prop pname tenv prop = then prop else Prop.normalize tenv (Prop.set prop ~sigma:sigma_new ~sigma_fp:sigma_fp_new) + (** Check whether the prop contains junk. If it does, and [Config.allowleak] is true, remove the junk, otherwise raise a Leak exception. *) let abstract_junk ?original_prop pname tenv prop = Absarray.array_abstraction_performed := false ; check_junk ~original_prop pname tenv prop + (** Remove redundant elements in an array, and check for junk afterwards *) let remove_redundant_array_elements pname tenv prop = Absarray.array_abstraction_performed := false ; let prop' = Absarray.remove_redundant_elements tenv prop in check_junk ~original_prop:(Some prop) pname tenv prop' + let abstract_prop pname tenv ~(rename_primed: bool) ~(from_abstract_footprint: bool) p = Absarray.array_abstraction_performed := false ; let pure_abs_p = abstract_pure_part tenv ~from_abstract_footprint:true p in @@ -1399,24 +1445,25 @@ let abstract_prop pname tenv ~(rename_primed: bool) ~(from_abstract_footprint: b in ren_abs_p + let get_local_stack cur_sigma init_sigma = let filter_stack = function - | Sil.Hpointsto (Exp.Lvar _, _, _) - -> true - | Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ - -> false + | Sil.Hpointsto (Exp.Lvar _, _, _) -> + true + | Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> + false in let get_stack_var = function - | Sil.Hpointsto (Exp.Lvar pvar, _, _) - -> pvar - | Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ - -> assert false + | Sil.Hpointsto (Exp.Lvar pvar, _, _) -> + pvar + | Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> + assert false in let filter_local_stack olds = function - | Sil.Hpointsto (Exp.Lvar pvar, _, _) - -> not (List.exists ~f:(Pvar.equal pvar) olds) - | Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ - -> false + | Sil.Hpointsto (Exp.Lvar pvar, _, _) -> + not (List.exists ~f:(Pvar.equal pvar) olds) + | Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> + false in let init_stack = List.filter ~f:filter_stack init_sigma in let init_stack_pvars = List.map ~f:get_stack_var init_stack in @@ -1424,6 +1471,7 @@ let get_local_stack cur_sigma init_sigma = let cur_local_stack_pvars = List.map ~f:get_stack_var cur_local_stack in (cur_local_stack, cur_local_stack_pvars) + (** Extract the footprint, add a local stack and return it as a prop *) let extract_footprint_for_abs (p: 'a Prop.t) : Prop.exposed Prop.t * Pvar.t list = let sigma = p.Prop.sigma in @@ -1434,15 +1482,17 @@ let extract_footprint_for_abs (p: 'a Prop.t) : Prop.exposed Prop.t * Pvar.t list let p1 = Prop.set p0 ~pi:pi_fp in (p1, local_stack_pvars) + let remove_local_stack sigma pvars = let filter_non_stack = function - | Sil.Hpointsto (Exp.Lvar pvar, _, _) - -> not (List.exists ~f:(Pvar.equal pvar) pvars) - | Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ - -> true + | Sil.Hpointsto (Exp.Lvar pvar, _, _) -> + not (List.exists ~f:(Pvar.equal pvar) pvars) + | Sil.Hpointsto _ | Sil.Hlseg _ | Sil.Hdllseg _ -> + true in List.filter ~f:filter_non_stack sigma + (** [prop_set_fooprint p p_foot] removes a local stack from [p_foot], and sets proposition [p_foot] as footprint of [p]. *) let set_footprint_for_abs (p: 'a Prop.t) (p_foot: 'a Prop.t) local_stack_pvars @@ -1453,6 +1503,7 @@ let set_footprint_for_abs (p: 'a Prop.t) (p_foot: 'a Prop.t) local_stack_pvars let sigma = remove_local_stack p_sigma_fp local_stack_pvars in Prop.set p ~pi_fp:pi ~sigma_fp:sigma + (** Abstract the footprint of prop *) let abstract_footprint pname (tenv: Tenv.t) (prop: Prop.normal Prop.t) : Prop.normal Prop.t = let p, added_local_vars = extract_footprint_for_abs prop in @@ -1463,12 +1514,14 @@ let abstract_footprint pname (tenv: Tenv.t) (prop: Prop.normal Prop.t) : Prop.no let prop' = set_footprint_for_abs prop p_abs added_local_vars in Prop.normalize tenv prop' + let _abstract pname pay tenv p = if pay then SymOp.pay () ; (* pay one symop *) let p' = if !Config.footprint then abstract_footprint pname tenv p else p in abstract_prop pname tenv ~rename_primed:true ~from_abstract_footprint:false p' + let abstract pname tenv p = _abstract pname true tenv p let abstract_no_symop pname tenv p = _abstract pname false tenv p @@ -1478,4 +1531,5 @@ let lifted_abstract pname tenv pset = let abstracted_pset = Propset.map_option tenv f pset in abstracted_pset + (***************** End of Main Abstraction Functions *****************) diff --git a/infer/src/backend/absarray.ml b/infer/src/backend/absarray.ml index c61c7289e..65dd42fd8 100644 --- a/infer/src/backend/absarray.ml +++ b/infer/src/backend/absarray.ml @@ -75,31 +75,32 @@ end = struct assert false in match (se, t.desc, syn_offs) with - | _, _, [] - -> (se, t) + | _, _, [] -> + (se, t) | Sil.Estruct (fsel, _), Tstruct name, (Field (fld, _)) :: syn_offs' -> ( match Tenv.lookup tenv name with - | Some {fields} - -> let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in + | Some {fields} -> + let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in let t' = snd3 (List.find_exn ~f:(fun (f', _, _) -> Typ.Fieldname.equal f' fld) fields) in get_strexp_at_syn_offsets tenv se' t' syn_offs' - | None - -> fail () ) - | Sil.Earray (_, esel, _), Typ.Tarray (t', _, _), (Index ind) :: syn_offs' - -> let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' ind) esel) in + | None -> + fail () ) + | Sil.Earray (_, esel, _), Typ.Tarray (t', _, _), (Index ind) :: syn_offs' -> + let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' ind) esel) in get_strexp_at_syn_offsets tenv se' t' syn_offs' - | _ - -> fail () + | _ -> + fail () + (** Replace a strexp at the given syntactic offset list *) let rec replace_strexp_at_syn_offsets tenv se (t: Typ.t) syn_offs update = match (se, t.desc, syn_offs) with - | _, _, [] - -> update se + | _, _, [] -> + update se | Sil.Estruct (fsel, inst), Tstruct name, (Field (fld, _)) :: syn_offs' -> ( match Tenv.lookup tenv name with - | Some {fields} - -> let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in + | Some {fields} -> + let se' = snd (List.find_exn ~f:(fun (f', _) -> Typ.Fieldname.equal f' fld) fsel) in let t' = (fun (_, y, _) -> y) (List.find_exn ~f:(fun (f', _, _) -> Typ.Fieldname.equal f' fld) fields) @@ -112,43 +113,46 @@ end = struct fsel in Sil.Estruct (fsel', inst) - | None - -> assert false ) - | Sil.Earray (len, esel, inst), Tarray (t', _, _), (Index idx) :: syn_offs' - -> let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' idx) esel) in + | None -> + assert false ) + | Sil.Earray (len, esel, inst), Tarray (t', _, _), (Index idx) :: syn_offs' -> + let se' = snd (List.find_exn ~f:(fun (i', _) -> Exp.equal i' idx) esel) in let se_mod = replace_strexp_at_syn_offsets tenv se' t' syn_offs' update in let esel' = List.map ~f:(fun ese -> if Exp.equal (fst ese) idx then (idx, se_mod) else ese) esel in Sil.Earray (len, esel', inst) - | _ - -> assert false + | _ -> + assert false + (** convert a path into an expression *) let path_to_exps (root, syn_offs_in) = let rec convert acc = function - | [] - -> acc - | (Field (f, t)) :: syn_offs' - -> let acc' = List.map ~f:(fun e -> Exp.Lfield (e, f, t)) acc in + | [] -> + acc + | (Field (f, t)) :: syn_offs' -> + let acc' = List.map ~f:(fun e -> Exp.Lfield (e, f, t)) acc in convert acc' syn_offs' - | (Index idx) :: syn_offs' - -> let acc' = List.map ~f:(fun e -> Exp.Lindex (e, idx)) acc in + | (Index idx) :: syn_offs' -> + let acc' = List.map ~f:(fun e -> Exp.Lindex (e, idx)) acc in convert acc' syn_offs' in convert [root] syn_offs_in + (** create a path from a root and a list of offsets *) let path_from_exp_offsets root offs = let offset_to_syn_offset = function - | Sil.Off_fld (fld, typ) - -> Field (fld, typ) - | Sil.Off_index idx - -> Index idx + | Sil.Off_fld (fld, typ) -> + Field (fld, typ) + | Sil.Off_index idx -> + Index idx in let syn_offs = List.map ~f:offset_to_syn_offset offs in (root, syn_offs) + (** path to the root, len, elements and type of a new_array *) type strexp_data = path * Sil.strexp * Typ.t @@ -161,6 +165,7 @@ end = struct let hpred = List.find_exn ~f:filter sigma in (sigma, hpred, syn_offs) + (** Find a sub strexp with the given property. Can raise [Not_found] *) let find tenv (sigma: sigma) (pred: strexp_data -> bool) : t list = let found = ref [] in @@ -172,86 +177,90 @@ end = struct match (se, typ.desc) with | Sil.Estruct (fsel, _), Tstruct name -> ( match Tenv.lookup tenv name with - | Some {fields} - -> find_offset_fsel sigma_other hpred root offs fsel fields typ - | None - -> () ) - | Sil.Earray (_, esel, _), Tarray (t, _, _) - -> find_offset_esel sigma_other hpred root offs esel t - | _ - -> () + | Some {fields} -> + find_offset_fsel sigma_other hpred root offs fsel fields typ + | None -> + () ) + | Sil.Earray (_, esel, _), Tarray (t, _, _) -> + find_offset_esel sigma_other hpred root offs esel t + | _ -> + () and find_offset_fsel sigma_other hpred root offs fsel ftal typ = match fsel with - | [] - -> () - | (f, se) :: fsel' - -> ( match List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f' f) ftal with - | Some (_, t, _) - -> find_offset_sexp sigma_other hpred root (Field (f, typ) :: offs) se t - | None - -> L.d_strln ("Can't find field " ^ Typ.Fieldname.to_string f ^ " in StrexpMatch.find") + | [] -> + () + | (f, se) :: fsel' -> + ( match List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f' f) ftal with + | Some (_, t, _) -> + find_offset_sexp sigma_other hpred root (Field (f, typ) :: offs) se t + | None -> + L.d_strln ("Can't find field " ^ Typ.Fieldname.to_string f ^ " in StrexpMatch.find") ) ; find_offset_fsel sigma_other hpred root offs fsel' ftal typ and find_offset_esel sigma_other hpred root offs esel t = match esel with - | [] - -> () - | (ind, se) :: esel' - -> find_offset_sexp sigma_other hpred root (Index ind :: offs) se t ; + | [] -> + () + | (ind, se) :: esel' -> + find_offset_sexp sigma_other hpred root (Index ind :: offs) se t ; find_offset_esel sigma_other hpred root offs esel' t in let rec iterate sigma_seen = function - | [] - -> () - | hpred :: sigma_rest - -> ( match hpred with - | Sil.Hpointsto (root, se, te) - -> let sigma_other = sigma_seen @ sigma_rest in + | [] -> + () + | hpred :: sigma_rest -> + ( match hpred with + | Sil.Hpointsto (root, se, te) -> + let sigma_other = sigma_seen @ sigma_rest in find_offset_sexp sigma_other hpred root [] se (Exp.texp_to_typ None te) - | _ - -> () ) ; + | _ -> + () ) ; iterate (hpred :: sigma_seen) sigma_rest in iterate [] sigma ; !found + (** Get the matched strexp *) let get_data tenv ((_, hpred, syn_offs): t) = match hpred with - | Sil.Hpointsto (root, se, te) - -> let t = Exp.texp_to_typ None te in + | Sil.Hpointsto (root, se, te) -> + let t = Exp.texp_to_typ None te in let se', t' = get_strexp_at_syn_offsets tenv se t syn_offs in let path' = (root, syn_offs) in (path', se', t') - | _ - -> assert false + | _ -> + assert false + (** Replace the current hpred *) let replace_hpred ((sigma, hpred, _): t) hpred' = List.map ~f:(fun hpred'' -> if phys_equal hpred'' hpred then hpred' else hpred'') sigma + (** Replace the strexp at the given offset in the given hpred *) let hpred_replace_strexp tenv footprint_part hpred syn_offs update = let update se' = let se_in = update se' in match (se', se_in) with - | Sil.Earray (len, esel, _), Sil.Earray (_, esel_in, inst2) - -> let orig_indices = List.map ~f:fst esel in + | Sil.Earray (len, esel, _), Sil.Earray (_, esel_in, inst2) -> + let orig_indices = List.map ~f:fst esel in let index_is_not_new idx = List.exists ~f:(Exp.equal idx) orig_indices in let process_index idx = if index_is_not_new idx then idx else Sil.array_clean_new_index footprint_part idx in let esel_in' = List.map ~f:(fun (idx, se) -> (process_index idx, se)) esel_in in Sil.Earray (len, esel_in', inst2) - | _, _ - -> se_in + | _, _ -> + se_in in match hpred with - | Sil.Hpointsto (root, se, te) - -> let t = Exp.texp_to_typ None te in + | Sil.Hpointsto (root, se, te) -> + let t = Exp.texp_to_typ None te in let se' = replace_strexp_at_syn_offsets tenv se t syn_offs update in Sil.Hpointsto (root, se', te) - | _ - -> assert false + | _ -> + assert false + (** Replace the strexp at a given position by a new strexp *) let replace_strexp tenv footprint_part ((sigma, hpred, syn_offs): t) se_in = @@ -259,23 +268,25 @@ end = struct let hpred' = hpred_replace_strexp tenv footprint_part hpred syn_offs update in replace_hpred (sigma, hpred, syn_offs) hpred' + (** Replace the index in the array at a given position with the new index *) let replace_index tenv footprint_part ((sigma, hpred, syn_offs): t) (index: Exp.t) (index': Exp.t) = let update se' = match se' with - | Sil.Earray (len, esel, inst) - -> let esel' = + | Sil.Earray (len, esel, inst) -> + let esel' = List.map ~f:(fun (e', se') -> if Exp.equal e' index then (index', se') else (e', se')) esel in Sil.Earray (len, esel', inst) - | _ - -> assert false + | _ -> + assert false in let hpred' = hpred_replace_strexp tenv footprint_part hpred syn_offs update in replace_hpred (sigma, hpred, syn_offs) hpred' + end (** This function renames expressions in [p]. The renaming is, roughly @@ -303,6 +314,7 @@ let prop_replace_path_index tenv (p: Prop.exposed Prop.t) (path: StrexpMatch.pat in Prop.prop_expmap expmap_fun p + (** This function uses [update] and transforms the two sigma parts of [p], the sigma of the current SH of [p] and that of the footprint of [p]. *) let prop_update_sigma_and_fp_sigma tenv (p: Prop.normal Prop.t) @@ -317,6 +329,7 @@ let prop_update_sigma_and_fp_sigma tenv (p: Prop.normal Prop.t) in (Prop.normalize tenv ep2, changed || changed2) + (** Remember whether array abstraction was performed (to be reset before calling Abs.abstract) *) let array_abstraction_performed = ref false @@ -326,7 +339,7 @@ let array_abstraction_performed = ref false let generic_strexp_abstract tenv (abstraction_name: string) (p_in: Prop.normal Prop.t) (can_abstract_: StrexpMatch.strexp_data -> bool) (do_abstract: - bool -> Prop.normal Prop.t -> StrexpMatch.strexp_data -> Prop.normal Prop.t * bool) + bool -> Prop.normal Prop.t -> StrexpMatch.strexp_data -> Prop.normal Prop.t * bool) : Prop.normal Prop.t = let can_abstract data = let r = can_abstract_ data in @@ -341,12 +354,12 @@ let generic_strexp_abstract tenv (abstraction_name: string) (p_in: Prop.normal P in let match_select_next (matchings_cur, matchings_fp) = match (matchings_cur, matchings_fp) with - | [], [] - -> raise Not_found - | matched :: cur', fp' - -> (matched, false, (cur', fp')) - | [], matched :: fp' - -> (matched, true, ([], fp')) + | [], [] -> + raise Not_found + | matched :: cur', fp' -> + (matched, false, (cur', fp')) + | [], matched :: fp' -> + (matched, true, ([], fp')) in let rec match_abstract p0 matchings_cur_fp = try @@ -374,6 +387,7 @@ let generic_strexp_abstract tenv (abstraction_name: string) (p_in: Prop.normal P let num_matches = List.length matchings_cur + List.length matchings_fp in find_then_abstract num_matches p_in + (** Return [true] if there's a pointer to the index *) let index_is_pointed_to tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (index: Exp.t) : bool = let indices = @@ -387,13 +401,14 @@ let index_is_pointed_to tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (i in let pointers = List.concat_map ~f:add_index_to_paths indices in let filter = function - | Sil.Hpointsto (_, Sil.Eexp (e, _), _) - -> List.exists ~f:(Exp.equal e) pointers - | _ - -> false + | Sil.Hpointsto (_, Sil.Eexp (e, _), _) -> + List.exists ~f:(Exp.equal e) pointers + | _ -> + false in List.exists ~f:filter p.Prop.sigma + (** Given [p] containing an array at [path], blur [index] in it *) let blur_array_index tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (index: Exp.t) : Prop.normal Prop.t = @@ -425,12 +440,14 @@ let blur_array_index tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (inde Prop.normalize tenv p4 with Not_found -> p + (** Given [p] containing an array at [root], blur [indices] in it *) let blur_array_indices tenv (p: Prop.normal Prop.t) (root: StrexpMatch.path) (indices: Exp.t list) : Prop.normal Prop.t * bool = let f prop index = blur_array_index tenv prop root index in (List.fold ~f ~init:p indices, List.length indices > 0) + (** Given [p] containing an array at [root], only keep [indices] in it *) let keep_only_indices tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (indices: Exp.t list) : Prop.normal Prop.t * bool = @@ -439,8 +456,8 @@ let keep_only_indices tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (ind let matched = StrexpMatch.find_path sigma path in let _, se, _ = StrexpMatch.get_data tenv matched in match se with - | Sil.Earray (len, esel, inst) - -> let esel', esel_leftover' = + | Sil.Earray (len, esel, inst) -> + let esel', esel_leftover' = List.partition_tf ~f:(fun (e, _) -> List.exists ~f:(Exp.equal e) indices) esel in if List.is_empty esel_leftover' then (sigma, false) @@ -448,39 +465,44 @@ let keep_only_indices tenv (p: Prop.normal Prop.t) (path: StrexpMatch.path) (ind let se' = Sil.Earray (len, esel', inst) in let sigma' = StrexpMatch.replace_strexp tenv footprint_part matched se' in (sigma', true) - | _ - -> (sigma, false) + | _ -> + (sigma, false) with Not_found -> (sigma, false) in prop_update_sigma_and_fp_sigma tenv p prune_sigma + (** If the type is array, check whether we should do abstraction *) let array_typ_can_abstract {Typ.desc} = match desc with - | Tarray ({desc= Tptr ({desc= Tfun _}, _)}, _, _) - -> false (* don't abstract arrays of pointers *) - | _ - -> true + | Tarray ({desc= Tptr ({desc= Tfun _}, _)}, _, _) -> + false (* don't abstract arrays of pointers *) + | _ -> + true + (** This function checks whether we can apply an abstraction to a strexp *) let strexp_can_abstract ((_, se, typ): StrexpMatch.strexp_data) : bool = let can_abstract_se = match se with - | Sil.Earray (_, esel, _) - -> let len = List.length esel in + | Sil.Earray (_, esel, _) -> + let len = List.length esel in len > 1 - | _ - -> false + | _ -> + false in can_abstract_se && array_typ_can_abstract typ + (** This function abstracts a strexp *) let strexp_do_abstract tenv footprint_part p ((path, se_in, _): StrexpMatch.strexp_data) : Prop.normal Prop.t * bool = if Config.trace_absarray && footprint_part then ( - L.d_str "strexp_do_abstract (footprint)" ; L.d_ln () ) ; + L.d_str "strexp_do_abstract (footprint)" ; + L.d_ln () ) ; if Config.trace_absarray && not footprint_part then ( - L.d_str "strexp_do_abstract (nonfootprint)" ; L.d_ln () ) ; + L.d_str "strexp_do_abstract (nonfootprint)" ; + L.d_ln () ) ; let prune_and_blur d_keys keep blur path keep_keys blur_keys = let p2, changed2 = if Config.trace_absarray then ( L.d_str "keep " ; d_keys keep_keys ; L.d_ln () ) ; @@ -531,12 +553,12 @@ let strexp_do_abstract tenv footprint_part p ((path, se_in, _): StrexpMatch.stre let is_pointed index = index_is_pointed_to tenv p path index in let should_keep (index, _) = match index with - | Exp.Const _ - -> is_pointed index - | Exp.Var id - -> Ident.is_normal id || is_pointed index - | _ - -> false + | Exp.Const _ -> + is_pointed index + | Exp.Var id -> + Ident.is_normal id || is_pointed index + | _ -> + false in let abstract = prune_and_blur_indices path in filter_abstract Sil.d_exp_list should_keep abstract esel [] @@ -546,15 +568,18 @@ let strexp_do_abstract tenv footprint_part p ((path, se_in, _): StrexpMatch.stre in if !Config.footprint then do_footprint () else do_reexecution () + let strexp_abstract tenv (p: Prop.normal Prop.t) : Prop.normal Prop.t = generic_strexp_abstract tenv "strexp_abstract" p strexp_can_abstract (strexp_do_abstract tenv) + let report_error prop = L.d_strln "Check after array abstraction: FAIL" ; Prop.d_prop prop ; L.d_ln () ; assert false + (** Check performed after the array abstraction to see whether it was successful. Raise assert false in case of failure *) let check_after_array_abstraction tenv prop = let lookup = Tenv.lookup tenv in @@ -565,10 +590,10 @@ let check_after_array_abstraction tenv prop = else not (Sil.fav_exists (Sil.exp_fav ind) Ident.is_primed) in let rec check_se root offs typ = function - | Sil.Eexp _ - -> () - | Sil.Earray (_, esel, _) - -> (* check that no more than 2 elements are in the array *) + | Sil.Eexp _ -> + () + | Sil.Earray (_, esel, _) -> + (* check that no more than 2 elements are in the array *) let typ_elem = Typ.array_elem (Some (Typ.mk Tvoid)) typ in if List.length esel > 2 && array_typ_can_abstract typ then if List.for_all ~f:(check_index root offs) esel then () else report_error prop @@ -576,28 +601,31 @@ let check_after_array_abstraction tenv prop = List.iter ~f:(fun (ind, se) -> check_se root (offs @ [Sil.Off_index ind]) typ_elem se) esel - | Sil.Estruct (fsel, _) - -> List.iter + | Sil.Estruct (fsel, _) -> + List.iter ~f:(fun (f, se) -> let typ_f = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f typ in check_se root (offs @ [Sil.Off_fld (f, typ)]) typ_f se) fsel in let check_hpred = function - | Sil.Hpointsto (root, se, texp) - -> let typ = Exp.texp_to_typ (Some (Typ.mk Tvoid)) texp in + | Sil.Hpointsto (root, se, texp) -> + let typ = Exp.texp_to_typ (Some (Typ.mk Tvoid)) texp in check_se root [] typ se - | Sil.Hlseg _ | Sil.Hdllseg _ - -> () + | Sil.Hlseg _ | Sil.Hdllseg _ -> + () in let check_sigma sigma = List.iter ~f:check_hpred sigma in (* check_footprint_pure prop; *) check_sigma prop.Prop.sigma ; check_sigma prop.Prop.sigma_fp + (** Apply array abstraction and check the result *) let abstract_array_check tenv p = let p_res = strexp_abstract tenv p in - check_after_array_abstraction tenv p_res ; p_res + check_after_array_abstraction tenv p_res ; + p_res + (** remove redundant elements in an array *) let remove_redundant_elements tenv prop = @@ -634,26 +662,26 @@ let remove_redundant_elements tenv prop = in match (e, se) with | Exp.Const Const.Cint i, Sil.Eexp (Exp.Var id, _) - when (not fp_part || IntLit.iszero i) && not (Ident.is_normal id) && occurs_at_most_once id - -> remove () (* unknown value can be removed in re-execution mode or if the index is zero *) - | Exp.Var id, Sil.Eexp _ when not (Ident.is_normal id) && occurs_at_most_once id - -> remove () (* index unknown can be removed *) - | _ - -> true + when (not fp_part || IntLit.iszero i) && not (Ident.is_normal id) && occurs_at_most_once id -> + remove () (* unknown value can be removed in re-execution mode or if the index is zero *) + | Exp.Var id, Sil.Eexp _ when not (Ident.is_normal id) && occurs_at_most_once id -> + remove () (* index unknown can be removed *) + | _ -> + true in let remove_redundant_se fp_part = function - | Sil.Earray (len, esel, inst) - -> let esel' = List.filter ~f:(filter_redundant_e_se fp_part) esel in + | Sil.Earray (len, esel, inst) -> + let esel' = List.filter ~f:(filter_redundant_e_se fp_part) esel in Sil.Earray (len, esel', inst) - | se - -> se + | se -> + se in let remove_redundant_hpred fp_part = function - | Sil.Hpointsto (e, se, te) - -> let se' = remove_redundant_se fp_part se in + | Sil.Hpointsto (e, se, te) -> + let se' = remove_redundant_se fp_part se in Sil.Hpointsto (e, se', te) - | hpred - -> hpred + | hpred -> + hpred in let remove_redundant_sigma fp_part sigma = List.map ~f:(remove_redundant_hpred fp_part) sigma in let sigma' = remove_redundant_sigma false prop.Prop.sigma in @@ -662,3 +690,4 @@ let remove_redundant_elements tenv prop = let prop' = Prop.set prop ~sigma:sigma' ~sigma_fp:sigma_fp' in Prop.normalize tenv prop' else prop + diff --git a/infer/src/backend/buckets.ml b/infer/src/backend/buckets.ml index 622fcf974..af32de598 100644 --- a/infer/src/backend/buckets.ml +++ b/infer/src/backend/buckets.ml @@ -24,22 +24,22 @@ let check_nested_loop path pos_opt = let loop_visits_log = ref [] in let in_nested_loop () = match !loop_visits_log with - | true :: true :: _ - -> if verbose then L.d_strln "in nested loop" ; + | true :: true :: _ -> + if verbose then L.d_strln "in nested loop" ; true (* last two loop visits were entering loops *) - | _ - -> false + | _ -> + false in let do_node_caller node = match Procdesc.Node.get_kind node with - | Procdesc.Node.Prune_node (b, (Sil.Ik_dowhile | Sil.Ik_for | Sil.Ik_while), _) - -> (* if verbose then *) + | Procdesc.Node.Prune_node (b, (Sil.Ik_dowhile | Sil.Ik_for | Sil.Ik_while), _) -> + (* if verbose then *) (* L.d_strln ((if b then "enter" else "exit") ^ " node " *) (* ^ (string_of_int (Procdesc.Node.get_id node))); *) loop_visits_log := b :: !loop_visits_log - | _ - -> () + | _ -> + () in let do_any_node _level _node = incr trace_length @@ -49,13 +49,15 @@ let check_nested_loop path pos_opt = in let f level p _ _ = match Paths.Path.curr_node p with - | Some node - -> do_any_node level node ; + | Some node -> + do_any_node level node ; if Int.equal level 0 then do_node_caller node - | None - -> () + | None -> + () in - Paths.Path.iter_shortest_sequence f pos_opt path ; in_nested_loop () + Paths.Path.iter_shortest_sequence f pos_opt path ; + in_nested_loop () + (** Check that we know where the value was last assigned, and that there is a local access instruction at that line. **) @@ -66,10 +68,10 @@ let check_access access_opt de_opt = let node_instrs = Procdesc.Node.get_instrs node in let formals = match State.get_prop_tenv_pdesc () with - | None - -> [] - | Some (_, _, pdesc) - -> Procdesc.get_formals pdesc + | None -> + [] + | Some (_, _, pdesc) -> + Procdesc.get_formals pdesc in let formal_names = List.map ~f:fst formals in let is_formal pvar = @@ -78,43 +80,44 @@ let check_access access_opt de_opt = in let formal_ids = ref [] in let process_formal_letref = function - | Sil.Load (id, Exp.Lvar pvar, _, _) - -> let is_java_this = Config.curr_language_is Config.Java && Pvar.is_this pvar in + | Sil.Load (id, Exp.Lvar pvar, _, _) -> + let is_java_this = Config.curr_language_is Config.Java && Pvar.is_this pvar in if not is_java_this && is_formal pvar then formal_ids := id :: !formal_ids - | _ - -> () + | _ -> + () in - List.iter ~f:process_formal_letref node_instrs ; !formal_ids + List.iter ~f:process_formal_letref node_instrs ; + !formal_ids in let formal_param_used_in_call = ref false in let has_call_or_sets_null node = let rec exp_is_null exp = match exp with - | Exp.Const Const.Cint n - -> IntLit.iszero n - | Exp.Cast (_, e) - -> exp_is_null e + | Exp.Const Const.Cint n -> + IntLit.iszero n + | Exp.Cast (_, e) -> + exp_is_null e | Exp.Var _ | Exp.Lvar _ -> ( match State.get_const_map () node exp with - | Some Const.Cint n - -> IntLit.iszero n - | _ - -> false ) - | _ - -> false + | Some Const.Cint n -> + IntLit.iszero n + | _ -> + false ) + | _ -> + false in let filter = function - | Sil.Call (_, _, etl, _, _) - -> let formal_ids = find_formal_ids node in + | Sil.Call (_, _, etl, _, _) -> + let formal_ids = find_formal_ids node in let arg_is_formal_param (e, _) = match e with Exp.Var id -> List.exists ~f:(Ident.equal id) formal_ids | _ -> false in if List.exists ~f:arg_is_formal_param etl then formal_param_used_in_call := true ; true - | Sil.Store (_, _, e, _) - -> exp_is_null e - | _ - -> false + | Sil.Store (_, _, e, _) -> + exp_is_null e + | _ -> + false in List.exists ~f:filter (Procdesc.Node.get_instrs node) in @@ -137,16 +140,18 @@ let check_access access_opt de_opt = else None in match access_opt with - | Some Localise.Last_assigned (n, ncf) - -> find_bucket n ncf - | Some Localise.Returned_from_call n - -> find_bucket n false - | Some Localise.Last_accessed (_, is_nullable) when is_nullable - -> Some Localise.BucketLevel.b1 + | Some Localise.Last_assigned (n, ncf) -> + find_bucket n ncf + | Some Localise.Returned_from_call n -> + find_bucket n false + | Some Localise.Last_accessed (_, is_nullable) when is_nullable -> + Some Localise.BucketLevel.b1 | _ -> match de_opt with Some DecompiledExp.Dconst _ -> Some Localise.BucketLevel.b1 | _ -> None + let classify_access desc access_opt de_opt is_nullable = let default_bucket = if is_nullable then Localise.BucketLevel.b1 else Localise.BucketLevel.b5 in let bucket = check_access access_opt de_opt |> Option.value ~default:default_bucket in Localise.error_desc_set_bucket desc bucket + diff --git a/infer/src/backend/builtin.ml b/infer/src/backend/builtin.ml index 7964d6299..e5a479bb5 100644 --- a/infer/src/backend/builtin.ml +++ b/infer/src/backend/builtin.ml @@ -37,18 +37,23 @@ let check_register_populated () = if Int.equal (Typ.Procname.Hash.length builtin_functions) 0 then L.(die InternalError) "Builtins were not initialized" + (** check if the function is a builtin *) let is_registered name = Typ.Procname.Hash.mem builtin_functions name || (check_register_populated () ; false) + (** get the symbolic execution handler associated to the builtin function name *) let get name : t option = try Some (Typ.Procname.Hash.find builtin_functions name) with Not_found -> check_register_populated () ; None + (** register a builtin [Typ.Procname.t] and symbolic execution handler *) let register proc_name sym_exe_fun : registered = - Typ.Procname.Hash.replace builtin_functions proc_name sym_exe_fun ; sym_exe_fun + Typ.Procname.Hash.replace builtin_functions proc_name sym_exe_fun ; + sym_exe_fun + (** print the functions registered *) let pp_registered fmt () = @@ -60,5 +65,9 @@ let pp_registered fmt () = List.iter ~f:pp !builtin_names ; Format.fprintf fmt "@]@." + (** print the builtin functions and exit *) -let print_and_exit () = pp_registered Format.std_formatter () ; L.exit 0 +let print_and_exit () = + pp_registered Format.std_formatter () ; + L.exit 0 + diff --git a/infer/src/backend/callbacks.ml b/infer/src/backend/callbacks.ml index d6ba51275..38b6302a5 100644 --- a/infer/src/backend/callbacks.ml +++ b/infer/src/backend/callbacks.ml @@ -34,14 +34,17 @@ let cluster_callbacks = ref [] let register_procedure_callback ?(dynamic_dispath= false) language (callback: proc_callback_t) = procedure_callbacks := (language, dynamic_dispath, callback) :: !procedure_callbacks + let register_cluster_callback language (callback: cluster_callback_t) = cluster_callbacks := (language, callback) :: !cluster_callbacks + (** Collect what we need to know about a procedure for the analysis. *) let get_procedure_definition exe_env proc_name = let tenv = Exe_env.get_tenv exe_env proc_name in Option.map ~f:(fun proc_desc -> (tenv, proc_desc)) (Exe_env.get_proc_desc exe_env proc_name) + let get_language proc_name = if Typ.Procname.is_java proc_name then Config.Java else Config.Clang (** Invoke all registered procedure callbacks on the given procedure. *) @@ -51,10 +54,10 @@ let iterate_procedure_callbacks get_proc_desc exe_env summary proc_desc = Config.curr_language := procedure_language ; let get_procs_in_file proc_name = match Exe_env.get_cfg exe_env proc_name with - | Some cfg - -> List.map ~f:Procdesc.get_proc_name (Cfg.get_defined_procs cfg) - | None - -> [] + | Some cfg -> + List.map ~f:Procdesc.get_proc_name (Cfg.get_defined_procs cfg) + | None -> + [] in let tenv = Exe_env.get_tenv exe_env proc_name in let is_specialized = Procdesc.is_specialized proc_desc in @@ -65,22 +68,24 @@ let iterate_procedure_callbacks get_proc_desc exe_env summary proc_desc = else summary) !procedure_callbacks + (** Invoke all registered cluster callbacks on a cluster of procedures. *) let iterate_cluster_callbacks all_procs exe_env get_proc_desc = let procedures = List.filter_map ~f:(get_procedure_definition exe_env) all_procs in let environment = {procedures; get_proc_desc} in let language_matches language = match procedures with - | (_, pdesc) :: _ - -> Config.equal_language language (get_language (Procdesc.get_proc_name pdesc)) - | _ - -> true + | (_, pdesc) :: _ -> + Config.equal_language language (get_language (Procdesc.get_proc_name pdesc)) + | _ -> + true in List.iter ~f:(fun (language_opt, cluster_callback) -> if language_matches language_opt then cluster_callback environment) !cluster_callbacks + (** Invoke all procedure and cluster callbacks on a given environment. *) let iterate_callbacks call_graph exe_env = let saved_language = !Config.curr_language in @@ -90,24 +95,24 @@ let iterate_callbacks call_graph exe_env = in let get_proc_desc proc_name = match Exe_env.get_proc_desc exe_env proc_name with - | Some pdesc - -> Some pdesc - | None when Config.(equal_dynamic_dispatch dynamic_dispatch Lazy) - -> Option.bind (Specs.get_summary proc_name) ~f:(fun summary -> summary.Specs.proc_desc_option) - | None - -> None + | Some pdesc -> + Some pdesc + | None when Config.(equal_dynamic_dispatch dynamic_dispatch Lazy) -> + Option.bind (Specs.get_summary proc_name) ~f:(fun summary -> summary.Specs.proc_desc_option) + | None -> + None in let analyze_ondemand summary proc_desc = iterate_procedure_callbacks get_proc_desc exe_env summary proc_desc in - let callbacks = {Ondemand.analyze_ondemand= analyze_ondemand; get_proc_desc} in + let callbacks = {Ondemand.analyze_ondemand; get_proc_desc} in (* Create and register on-demand analysis callback *) let analyze_proc_name pname = match Ondemand.get_proc_desc pname with - | None - -> L.(die InternalError) "Could not find proc desc for %a" Typ.Procname.pp pname - | Some pdesc - -> ignore (Ondemand.analyze_proc_desc pdesc pdesc) + | None -> + L.(die InternalError) "Could not find proc desc for %a" Typ.Procname.pp pname + | Some pdesc -> + ignore (Ondemand.analyze_proc_desc pdesc pdesc) in Ondemand.set_callbacks callbacks ; (* Invoke procedure callbacks using on-demand anlaysis schedulling *) @@ -117,3 +122,4 @@ let iterate_callbacks call_graph exe_env = (* Unregister callbacks *) Ondemand.unset_callbacks () ; Config.curr_language := saved_language + diff --git a/infer/src/backend/callbacks.mli b/infer/src/backend/callbacks.mli index dcec36ef1..08da5ee20 100644 --- a/infer/src/backend/callbacks.mli +++ b/infer/src/backend/callbacks.mli @@ -30,7 +30,8 @@ type cluster_callback_args = type cluster_callback_t = cluster_callback_args -> unit -val register_procedure_callback : ?dynamic_dispath:bool -> Config.language -> proc_callback_t -> unit +val register_procedure_callback : + ?dynamic_dispath:bool -> Config.language -> proc_callback_t -> unit (** register a procedure callback *) val register_cluster_callback : Config.language -> cluster_callback_t -> unit diff --git a/infer/src/backend/cluster.ml b/infer/src/backend/cluster.ml index 4895bbf3e..9a063ade8 100644 --- a/infer/src/backend/cluster.ml +++ b/infer/src/backend/cluster.ml @@ -23,14 +23,17 @@ type serializer_t = int * t let serializer : serializer_t Serialization.serializer = Serialization.create_serializer Serialization.Key.cluster + (** Load a cluster from a file *) let load_from_file (filename: DB.filename) : serializer_t option = Serialization.read_from_file serializer filename + (** Save a cluster into a file *) let store_to_file (filename: DB.filename) (data: serializer_t) = Serialization.write_to_file serializer filename ~data + let cl_name n = "cl" ^ string_of_int n let cl_file n = "x" ^ cl_name n ^ ".cluster" @@ -46,3 +49,4 @@ let pp_cluster fmt (nr, cluster) = (* touch the target of the rule to let `make` know that the job has been done *) F.fprintf fmt "\t%@touch $%@@\n" ; F.fprintf fmt "@\n" + diff --git a/infer/src/backend/clusterMakefile.ml b/infer/src/backend/clusterMakefile.ml index 18542f6ec..e4d92512d 100644 --- a/infer/src/backend/clusterMakefile.ml +++ b/infer/src/backend/clusterMakefile.ml @@ -17,10 +17,10 @@ module CLOpt = CommandLineOption let pp_prolog fmt clusters = let escape = Escape.escape_map (fun c -> if Char.equal c '#' then Some "\\#" else None) in let infer_flag_of_compilation_db = function - | `Escaped f - -> F.sprintf "--compilation-database-escaped '%s'" f - | `Raw f - -> F.sprintf "--compilation-database '%s'" f + | `Escaped f -> + F.sprintf "--compilation-database-escaped '%s'" f + | `Raw f -> + F.sprintf "--compilation-database '%s'" f in let compilation_dbs_cmd = List.map ~f:infer_flag_of_compilation_db !Config.clang_compilation_dbs @@ -35,6 +35,7 @@ let pp_prolog fmt clusters = F.fprintf fmt "test: $(CLUSTERS)@\n" ; if Config.show_progress_bar then F.fprintf fmt "\t%@echo@\n@." + let pp_epilog fmt () = F.fprintf fmt "@.clean:@.\trm -f $(CLUSTERS)@." let create_cluster_makefile (clusters: Cluster.t list) (fname: string) = @@ -48,3 +49,4 @@ let create_cluster_makefile (clusters: Cluster.t list) (fname: string) = List.iteri ~f:do_cluster clusters ; pp_epilog fmt () ; Out_channel.close outc + diff --git a/infer/src/backend/crashcontext.ml b/infer/src/backend/crashcontext.ml index 880fc85a7..569b3ae82 100644 --- a/infer/src/backend/crashcontext.ml +++ b/infer/src/backend/crashcontext.ml @@ -14,23 +14,25 @@ module L = Logging let frame_id_of_stackframe frame = let loc_str = match frame.Stacktrace.line_num with - | None - -> frame.Stacktrace.file_str - | Some line - -> F.sprintf "%s:%d" frame.Stacktrace.file_str line + | None -> + frame.Stacktrace.file_str + | Some line -> + F.sprintf "%s:%d" frame.Stacktrace.file_str line in F.sprintf "%s.%s(%s)" frame.Stacktrace.class_str frame.Stacktrace.method_str loc_str + let frame_id_of_summary stacktree = let short_name = List.hd_exn (Str.split (Str.regexp "(") stacktree.Stacktree_j.method_name) in match stacktree.Stacktree_j.location with - | None - -> L.(die InternalError) + | None -> + L.(die InternalError) "Attempted to take signature of a frame without location information. This is undefined." - | Some {line= Some line_num; file} - -> F.sprintf "%s(%s:%d)" short_name (Filename.basename file) line_num - | Some {file} - -> F.sprintf "%s(%s)" short_name (Filename.basename file) + | Some {line= Some line_num; file} -> + F.sprintf "%s(%s:%d)" short_name (Filename.basename file) line_num + | Some {file} -> + F.sprintf "%s(%s)" short_name (Filename.basename file) + let stracktree_of_frame frame = { Stacktree_j.method_name= @@ -43,6 +45,7 @@ let stracktree_of_frame frame = ; blame_range= [] } ; callees= [] } + (** k = 1 implementation, where k is the number of levels of calls inlined *) let stitch_summaries stacktrace_file summary_files out_file = let stacktrace = Stacktrace.of_json_file stacktrace_file in @@ -64,6 +67,7 @@ let stitch_summaries stacktrace_file summary_files out_file = let crashcontext = {Stacktree_j.stack= expanded_frames} in Ag_util.Json.to_file Stacktree_j.write_crashcontext_t out_file crashcontext + let collect_all_summaries root_summaries_dir stacktrace_file stacktraces_dir = let method_summaries = Utils.directory_fold @@ -77,19 +81,19 @@ let collect_all_summaries root_summaries_dir stacktrace_file stacktraces_dir = in let pair_for_stacktrace_file = match stacktrace_file with - | None - -> None - | Some file - -> let crashcontext_dir = Config.results_dir ^/ "crashcontext" in + | None -> + None + | Some file -> + let crashcontext_dir = Config.results_dir ^/ "crashcontext" in Utils.create_dir crashcontext_dir ; Some (file, crashcontext_dir ^/ "crashcontext.json") in let trace_file_regexp = Str.regexp "\\(.*\\)\\.json" in let pairs_for_stactrace_dir = match stacktraces_dir with - | None - -> [] - | Some s - -> let dir = DB.filename_from_string s in + | None -> + [] + | Some s -> + let dir = DB.filename_from_string s in let trace_file_matcher path = let path_str = DB.filename_to_string path in Str.string_match trace_file_regexp path_str 0 @@ -101,24 +105,25 @@ let collect_all_summaries root_summaries_dir stacktrace_file stacktraces_dir = in try DB.fold_paths_matching ~dir ~p:trace_file_matcher ~init:[] ~f:trace_fold with - | (* trace_fold runs immediately after trace_file_matcher in the + (* trace_fold runs immediately after trace_file_matcher in the DB.fold_paths_matching statement below, so we don't need to call Str.string_match again. *) - Not_found + | Not_found -> assert false in let input_output_file_pairs = match pair_for_stacktrace_file with - | None - -> pairs_for_stactrace_dir - | Some pair - -> pair :: pairs_for_stactrace_dir + | None -> + pairs_for_stactrace_dir + | Some pair -> + pair :: pairs_for_stactrace_dir in let process_stacktrace (stacktrace_file, out_file) = stitch_summaries stacktrace_file method_summaries out_file in List.iter ~f:process_stacktrace input_output_file_pairs + let crashcontext_epilogue ~in_buck_mode = (* if we are the top-level process, then find the output directory and collect all crashcontext summaries under it in a single @@ -134,4 +139,5 @@ let crashcontext_epilogue ~in_buck_mode = in collect_all_summaries root_summaries_dir Config.stacktrace Config.stacktraces_dir + let pp_stacktree fmt st = Format.fprintf fmt "%s" (Stacktree_j.string_of_stacktree st) diff --git a/infer/src/backend/dom.ml b/infer/src/backend/dom.ml index 003a74a1b..59fa6e625 100644 --- a/infer/src/backend/dom.ml +++ b/infer/src/backend/dom.ml @@ -29,24 +29,26 @@ let can_rename id = Ident.is_primed id || Ident.is_footprint id let equal_sigma sigma1 sigma2 = let rec f sigma1_rest sigma2_rest = match (sigma1_rest, sigma2_rest) with - | [], [] - -> () - | [], _ :: _ | _ :: _, [] - -> L.d_strln "failure reason 1" ; raise Sil.JoinFail - | hpred1 :: sigma1_rest', hpred2 :: sigma2_rest' - -> if Sil.equal_hpred hpred1 hpred2 then f sigma1_rest' sigma2_rest' + | [], [] -> + () + | [], _ :: _ | _ :: _, [] -> + L.d_strln "failure reason 1" ; raise Sil.JoinFail + | hpred1 :: sigma1_rest', hpred2 :: sigma2_rest' -> + if Sil.equal_hpred hpred1 hpred2 then f sigma1_rest' sigma2_rest' else ( L.d_strln "failure reason 2" ; raise Sil.JoinFail ) in let sigma1_sorted = List.sort ~cmp:Sil.compare_hpred sigma1 in let sigma2_sorted = List.sort ~cmp:Sil.compare_hpred sigma2 in f sigma1_sorted sigma2_sorted + let sigma_get_start_lexps_sort sigma = let exp_compare_neg e1 e2 = -Exp.compare e1 e2 in let filter e = Sil.fav_for_all (Sil.exp_fav e) Ident.is_normal in let lexps = Sil.hpred_list_get_lexps filter sigma in List.sort ~cmp:exp_compare_neg lexps + (** {2 Utility functions for side} *) type side = Lhs | Rhs @@ -90,6 +92,7 @@ end = struct Hashtbl.clear const_tbl1 ; Hashtbl.clear const_tbl2 + let init () = reset () let final () = reset () @@ -99,8 +102,9 @@ end = struct | Exp.Var _ -> ( try Hashtbl.find tbl e with Not_found -> Hashtbl.replace tbl e default ; default ) - | _ - -> assert false + | _ -> + assert false + let lookup_equiv' tbl e = lookup' tbl e e @@ -109,13 +113,14 @@ end = struct let rec find' tbl e = let e' = lookup_equiv' tbl e in match e' with - | Exp.Var _ - -> if Exp.equal e e' then e + | Exp.Var _ -> + if Exp.equal e e' then e else let root = find' tbl e' in Hashtbl.replace tbl e root ; root - | _ - -> assert false + | _ -> + assert false + let union' tbl const_tbl e1 e2 = let r1 = find' tbl e1 in @@ -128,12 +133,14 @@ end = struct Hashtbl.replace tbl old_r new_r ; Hashtbl.replace const_tbl new_r res_c + let replace_const' tbl const_tbl e c = let r = find' tbl e in let set = Exp.Set.add c (lookup_const' const_tbl r) in if Exp.Set.cardinal set > 1 then ( L.d_strln "failure reason 4" ; raise Sil.JoinFail ) ; Hashtbl.replace const_tbl r set + let add side e e' = let tbl, const_tbl = match side with Lhs -> (equiv_tbl1, const_tbl1) | Rhs -> (equiv_tbl2, const_tbl2) @@ -141,22 +148,23 @@ end = struct match (e, e') with | Exp.Var id, Exp.Var id' -> ( match (can_rename id, can_rename id') with - | true, true - -> union' tbl const_tbl e e' - | true, false - -> replace_const' tbl const_tbl e e' - | false, true - -> replace_const' tbl const_tbl e' e - | _ - -> L.d_strln "failure reason 5" ; raise Sil.JoinFail ) - | Exp.Var id, Exp.Const _ | Exp.Var id, Exp.Lvar _ - -> if can_rename id then replace_const' tbl const_tbl e e' + | true, true -> + union' tbl const_tbl e e' + | true, false -> + replace_const' tbl const_tbl e e' + | false, true -> + replace_const' tbl const_tbl e' e + | _ -> + L.d_strln "failure reason 5" ; raise Sil.JoinFail ) + | Exp.Var id, Exp.Const _ | Exp.Var id, Exp.Lvar _ -> + if can_rename id then replace_const' tbl const_tbl e e' else ( L.d_strln "failure reason 6" ; raise Sil.JoinFail ) - | Exp.Const _, Exp.Var id' | Exp.Lvar _, Exp.Var id' - -> if can_rename id' then replace_const' tbl const_tbl e' e + | Exp.Const _, Exp.Var id' | Exp.Lvar _, Exp.Var id' -> + if can_rename id' then replace_const' tbl const_tbl e' e else ( L.d_strln "failure reason 7" ; raise Sil.JoinFail ) - | _ - -> if not (Exp.equal e e') then ( L.d_strln "failure reason 8" ; raise Sil.JoinFail ) else () + | _ -> + if not (Exp.equal e e') then ( L.d_strln "failure reason 8" ; raise Sil.JoinFail ) else () + let check side es = let f = function Exp.Var id -> can_rename id | _ -> false in @@ -167,13 +175,14 @@ end = struct if List.length nonvars > 1 then false else match (vars, nonvars) with - | [], _ | [_], [] - -> true - | v :: vars', _ - -> let r = find' tbl v in + | [], _ | [_], [] -> + true + | v :: vars', _ -> + let r = find' tbl v in let set = lookup_const' const_tbl r in List.for_all ~f:(fun v' -> Exp.equal (find' tbl v') r) vars' && List.for_all ~f:(fun c -> Exp.Set.mem c set) nonvars + end (** {2 Modules for checking whether join or meet loses too much info} *) @@ -203,26 +212,30 @@ end = struct let lexp_lst = Sil.hpred_list_get_lexps (fun _ -> true) sigma in List.fold ~f:(fun set e -> Exp.Set.add e set) ~init:Exp.Set.empty lexp_lst + let init sigma1 sigma2 = lexps1 := get_lexp_set' sigma1 ; lexps2 := get_lexp_set' sigma2 + let final () = lexps1 := Exp.Set.empty ; lexps2 := Exp.Set.empty + (* conservatively checks whether e is dangling *) let check side e = let lexps = match side with Lhs -> !lexps1 | Rhs -> !lexps2 in match e with - | Exp.Var id - -> can_rename id && not (Exp.Set.mem e lexps) - | Exp.Const _ - -> not (Exp.Set.mem e lexps) - | Exp.BinOp _ - -> not (Exp.Set.mem e lexps) - | _ - -> false + | Exp.Var id -> + can_rename id && not (Exp.Set.mem e lexps) + | Exp.Const _ -> + not (Exp.Set.mem e lexps) + | Exp.BinOp _ -> + not (Exp.Set.mem e lexps) + | _ -> + false + end module CheckJoinPre : InfoLossCheckerSig = struct @@ -233,12 +246,12 @@ module CheckJoinPre : InfoLossCheckerSig = struct let fail_case side e es = let side_op = opposite side in match e with - | Exp.Lvar _ - -> false - | Exp.Var id when Ident.is_normal id - -> List.length es >= 1 - | Exp.Var _ - -> if Int.equal Config.join_cond 0 then List.exists ~f:(Exp.equal Exp.zero) es + | Exp.Lvar _ -> + false + | Exp.Var id when Ident.is_normal id -> + List.length es >= 1 + | Exp.Var _ -> + if Int.equal Config.join_cond 0 then List.exists ~f:(Exp.equal Exp.zero) es else if Dangling.check side e then let r = List.exists ~f:(fun e' -> not (Dangling.check side_op e')) es in if r then ( @@ -259,8 +272,9 @@ module CheckJoinPre : InfoLossCheckerSig = struct L.d_strln ") ...." ; L.d_ln () ) ; r - | _ - -> false + | _ -> + false + let lost_little side e es = let side_op = opposite side in @@ -268,6 +282,7 @@ module CheckJoinPre : InfoLossCheckerSig = struct if fail_case side e es then false else match es with [] | [_] -> true | _ -> NonInj.check side_op es + let add = NonInj.add end @@ -278,14 +293,15 @@ module CheckJoinPost : InfoLossCheckerSig = struct let fail_case _ e es = match e with - | Exp.Lvar _ - -> false - | Exp.Var id when Ident.is_normal id - -> List.length es >= 1 - | Exp.Var _ - -> false - | _ - -> false + | Exp.Lvar _ -> + false + | Exp.Var id when Ident.is_normal id -> + List.length es >= 1 + | Exp.Var _ -> + false + | _ -> + false + let lost_little side e es = let side_op = opposite side in @@ -293,6 +309,7 @@ module CheckJoinPost : InfoLossCheckerSig = struct if fail_case side e es then false else match es with [] | [_] -> true | _ -> NonInj.check side_op es + let add = NonInj.add end @@ -310,33 +327,37 @@ end = struct let init mode sigma1 sigma2 = mode_ref := mode ; match mode with - | JoinState.Pre - -> CheckJoinPre.init sigma1 sigma2 - | JoinState.Post - -> CheckJoinPost.init sigma1 sigma2 + | JoinState.Pre -> + CheckJoinPre.init sigma1 sigma2 + | JoinState.Post -> + CheckJoinPost.init sigma1 sigma2 + let final () = match !mode_ref with - | JoinState.Pre - -> CheckJoinPre.final () ; + | JoinState.Pre -> + CheckJoinPre.final () ; mode_ref := JoinState.Post - | JoinState.Post - -> CheckJoinPost.final () ; + | JoinState.Post -> + CheckJoinPost.final () ; mode_ref := JoinState.Post + let lost_little side e es = match !mode_ref with - | JoinState.Pre - -> CheckJoinPre.lost_little side e es - | JoinState.Post - -> CheckJoinPost.lost_little side e es + | JoinState.Pre -> + CheckJoinPre.lost_little side e es + | JoinState.Post -> + CheckJoinPost.lost_little side e es + let add side e1 e2 = match !mode_ref with - | JoinState.Pre - -> CheckJoinPre.add side e1 e2 - | JoinState.Post - -> CheckJoinPost.add side e1 e2 + | JoinState.Pre -> + CheckJoinPre.add side e1 e2 + | JoinState.Post -> + CheckJoinPost.add side e1 e2 + end module CheckMeet : InfoLossCheckerSig = struct @@ -350,31 +371,34 @@ module CheckMeet : InfoLossCheckerSig = struct lexps1 := Sil.elist_to_eset lexps1_lst ; lexps2 := Sil.elist_to_eset lexps2_lst + let final () = lexps1 := Exp.Set.empty ; lexps2 := Exp.Set.empty + let lost_little side e es = let lexps = match side with Lhs -> !lexps1 | Rhs -> !lexps2 in match (es, e) with - | [], _ - -> true - | [(Exp.Const _)], Exp.Lvar _ - -> false - | [(Exp.Const _)], Exp.Var _ - -> not (Exp.Set.mem e lexps) - | [(Exp.Const _)], _ - -> assert false - | [_], Exp.Lvar _ | [_], Exp.Var _ - -> true - | [_], _ - -> assert false - | _, Exp.Lvar _ | _, Exp.Var _ - -> false - | _, Exp.Const _ - -> assert false - | _ - -> assert false + | [], _ -> + true + | [(Exp.Const _)], Exp.Lvar _ -> + false + | [(Exp.Const _)], Exp.Var _ -> + not (Exp.Set.mem e lexps) + | [(Exp.Const _)], _ -> + assert false + | [_], Exp.Lvar _ | [_], Exp.Var _ -> + true + | [_], _ -> + assert false + | _, Exp.Lvar _ | _, Exp.Var _ -> + false + | _, Exp.Const _ -> + assert false + | _ -> + assert false + let add = NonInj.add end @@ -416,11 +440,12 @@ end = struct let pop () = match !tbl with - | h :: t - -> tbl := t ; + | h :: t -> + tbl := t ; h - | _ - -> raise Empty + | _ -> + raise Empty + let set todo = tbl := todo @@ -428,6 +453,7 @@ end = struct let res = !tbl in tbl := [] ; res + end (** {2 Module for introducing fresh variables} *) @@ -454,42 +480,45 @@ end = struct let n1 = Exp.compare e1 e2 in if n1 <> 0 then n1 else Exp.compare e2 e2' + let get_fresh_exp e1 e2 = match List.find ~f:(fun (e1', e2', _) -> Exp.equal e1 e1' && Exp.equal e2 e2') !t |> Option.map ~f:trd3 with - | Some res - -> res - | None - -> let e = Exp.get_undefined (JoinState.get_footprint ()) in + | Some res -> + res + | None -> + let e = Exp.get_undefined (JoinState.get_footprint ()) in t := (e1, e2, e) :: !t ; e + let get_induced_atom tenv acc strict_lower upper e = let ineq_lower = Prop.mk_inequality tenv (Exp.BinOp (Binop.Lt, strict_lower, e)) in let ineq_upper = Prop.mk_inequality tenv (Exp.BinOp (Binop.Le, e, upper)) in ineq_lower :: ineq_upper :: acc + let minus2_to_2 = List.map ~f:IntLit.of_int [-2; -1; 0; 1; 2] let get_induced_pi tenv () = let t_sorted = List.sort ~cmp:entry_compare !t in let add_and_chk_eq e1 e1' n = match (e1, e1') with - | Exp.Const Const.Cint n1, Exp.Const Const.Cint n1' - -> IntLit.eq (n1 ++ n) n1' - | _ - -> false + | Exp.Const Const.Cint n1, Exp.Const Const.Cint n1' -> + IntLit.eq (n1 ++ n) n1' + | _ -> + false in let add_and_gen_eq e e' n = let e_plus_n = Exp.BinOp (Binop.PlusA, e, Exp.int n) in Prop.mk_eq tenv e_plus_n e' in - let rec f_eqs_entry (e1, e2, e as entry) eqs_acc t_seen = function - | [] - -> (eqs_acc, t_seen) - | (e1', e2', e' as entry') :: t_rest' -> + let rec f_eqs_entry ((e1, e2, e) as entry) eqs_acc t_seen = function + | [] -> + (eqs_acc, t_seen) + | ((e1', e2', e') as entry') :: t_rest' -> match List.find ~f:(fun n -> add_and_chk_eq e1 e1' n && add_and_chk_eq e2 e2' n) minus2_to_2 |> Option.map ~f:(fun n -> @@ -497,34 +526,35 @@ end = struct let eqs_acc' = eq :: eqs_acc in f_eqs_entry entry eqs_acc' t_seen t_rest' ) with - | Some res - -> res - | None - -> let t_seen' = entry' :: t_seen in + | Some res -> + res + | None -> + let t_seen' = entry' :: t_seen in f_eqs_entry entry eqs_acc t_seen' t_rest' in let rec f_eqs eqs_acc t_acc = function - | [] - -> (eqs_acc, t_acc) - | entry :: t_rest - -> let eqs_acc', t_rest' = f_eqs_entry entry eqs_acc [] t_rest in + | [] -> + (eqs_acc, t_acc) + | entry :: t_rest -> + let eqs_acc', t_rest' = f_eqs_entry entry eqs_acc [] t_rest in let t_acc' = entry :: t_acc in f_eqs eqs_acc' t_acc' t_rest' in let eqs, t_minimal = f_eqs [] [] t_sorted in let f_ineqs acc (e1, e2, e) = match (e1, e2) with - | Exp.Const Const.Cint n1, Exp.Const Const.Cint n2 - -> let strict_lower1, upper1 = + | Exp.Const Const.Cint n1, Exp.Const Const.Cint n2 -> + let strict_lower1, upper1 = if IntLit.leq n1 n2 then (n1 -- IntLit.one, n2) else (n2 -- IntLit.one, n1) in let e_strict_lower1 = Exp.int strict_lower1 in let e_upper1 = Exp.int upper1 in get_induced_atom tenv acc e_strict_lower1 e_upper1 e - | _ - -> acc + | _ -> + acc in List.fold ~f:f_ineqs ~init:eqs t_minimal + end (** {2 Modules for renaming} *) @@ -570,16 +600,17 @@ end = struct let reset () = let f = function - | Exp.Var id, e, _ | e, Exp.Var id, _ - -> Ident.is_footprint id + | Exp.Var id, e, _ | e, Exp.Var id, _ -> + Ident.is_footprint id && Sil.fav_for_all (Sil.exp_fav e) (fun id -> not (Ident.is_primed id)) - | _ - -> false + | _ -> + false in let t' = List.filter ~f !tbl in tbl := t' ; t' + let push v = tbl := v :: !tbl let check lost_little = @@ -587,14 +618,14 @@ end = struct let side_op = opposite side in let assoc_es = match e with - | Exp.Const _ - -> [] - | Exp.Lvar _ | Exp.Var _ | Exp.BinOp (Binop.PlusA, Exp.Var _, _) - -> let is_same_e (e1, e2, _) = Exp.equal e (select side e1 e2) in + | Exp.Const _ -> + [] + | Exp.Lvar _ | Exp.Var _ | Exp.BinOp (Binop.PlusA, Exp.Var _, _) -> + let is_same_e (e1, e2, _) = Exp.equal e (select side e1 e2) in let assoc = List.filter ~f:is_same_e !tbl in List.map ~f:(fun (e1, e2, _) -> select side_op e1 e2) assoc - | _ - -> L.d_str "no pattern match in check lost_little e: " ; + | _ -> + L.d_str "no pattern match in check lost_little e: " ; Sil.d_exp e ; L.d_ln () ; raise Sil.JoinFail @@ -605,45 +636,49 @@ end = struct let rhs_es = List.map ~f:(fun (_, e2, _) -> e2) !tbl in List.for_all ~f:(f Rhs) rhs_es && List.for_all ~f:(f Lhs) lhs_es + let lookup_side' side e = let f (e1, e2, _) = Exp.equal e (select side e1 e2) in List.filter ~f !tbl + let lookup_side_induced' side e = let res = ref [] in let f v = match (v, side) with - | (Exp.BinOp (Binop.PlusA, e1', Exp.Const Const.Cint i), e2, e'), Lhs when Exp.equal e e1' - -> let c' = Exp.int (IntLit.neg i) in + | (Exp.BinOp (Binop.PlusA, e1', Exp.Const Const.Cint i), e2, e'), Lhs when Exp.equal e e1' -> + let c' = Exp.int (IntLit.neg i) in let v' = (e1', Exp.BinOp (Binop.PlusA, e2, c'), Exp.BinOp (Binop.PlusA, e', c')) in res := v' :: !res - | (e1, Exp.BinOp (Binop.PlusA, e2', Exp.Const Const.Cint i), e'), Rhs when Exp.equal e e2' - -> let c' = Exp.int (IntLit.neg i) in + | (e1, Exp.BinOp (Binop.PlusA, e2', Exp.Const Const.Cint i), e'), Rhs when Exp.equal e e2' -> + let c' = Exp.int (IntLit.neg i) in let v' = (Exp.BinOp (Binop.PlusA, e1, c'), e2', Exp.BinOp (Binop.PlusA, e', c')) in res := v' :: !res - | _ - -> () + | _ -> + () in List.iter ~f !tbl ; List.rev !res + (* Return the triple whose side is [e], if it exists unique *) let lookup' todo side e : Exp.t = match e with | Exp.Var id when can_rename id - -> ( + -> ( let r = lookup_side' side e in match r with - | [(_, _, id as t)] - -> if todo then Todo.push t ; + | [((_, _, id) as t)] -> + if todo then Todo.push t ; id - | _ - -> L.d_strln "failure reason 9" ; raise Sil.JoinFail ) - | Exp.Var _ | Exp.Const _ | Exp.Lvar _ - -> if todo then Todo.push (e, e, e) ; + | _ -> + L.d_strln "failure reason 9" ; raise Sil.JoinFail ) + | Exp.Var _ | Exp.Const _ | Exp.Lvar _ -> + if todo then Todo.push (e, e, e) ; e - | _ - -> L.d_strln "failure reason 10" ; raise Sil.JoinFail + | _ -> + L.d_strln "failure reason 10" ; raise Sil.JoinFail + let lookup side e = lookup' false side e @@ -666,15 +701,16 @@ end = struct List.sort ~cmp:(fun (_, e) (_, e') -> Exp.compare e e') sub_list_side in let rec find_duplicates = function - | (_, e) :: ((_, e') :: _ as t) - -> Exp.equal e e' || find_duplicates t - | _ - -> false + | (_, e) :: ((_, e') :: _ as t) -> + Exp.equal e e' || find_duplicates t + | _ -> + false in if find_duplicates sub_list_side_sorted then ( L.d_strln "failure reason 11" ; raise Sil.JoinFail ) else Sil.exp_subst_of_list sub_list_side + let to_subst_emb (side: side) = let renaming_restricted = let pick_id_case (e1, e2, _) = @@ -693,39 +729,43 @@ end = struct List.sort ~cmp:compare sub_list in let rec find_duplicates = function - | (i, _) :: ((i', _) :: _ as t) - -> Ident.equal i i' || find_duplicates t - | _ - -> false + | (i, _) :: ((i', _) :: _ as t) -> + Ident.equal i i' || find_duplicates t + | _ -> + false in if find_duplicates sub_list_sorted then ( L.d_strln "failure reason 12" ; raise Sil.JoinFail ) else Sil.exp_subst_of_list sub_list_sorted + let get_others' f_lookup side e = let side_op = opposite side in let r = f_lookup side e in match r with [] -> None | [(e1, e2, e')] -> Some (e', select side_op e1 e2) | _ -> None + let get_others = get_others' lookup_side' let get_others_direct_or_induced side e = let others = get_others side e in match others with None -> get_others' lookup_side_induced' side e | Some _ -> others + let get_others_deep side = function | Exp.BinOp (op, e, e') - -> ( + -> ( let others = get_others_direct_or_induced side e in let others' = get_others_direct_or_induced side e' in match (others, others') with - | None, _ | _, None - -> None - | Some (e_res, e_op), Some (e_res', e_op') - -> let e_res'' = Exp.BinOp (op, e_res, e_res') in + | None, _ | _, None -> + None + | Some (e_res, e_op), Some (e_res', e_op') -> + let e_res'' = Exp.BinOp (op, e_res, e_res') in let e_op'' = Exp.BinOp (op, e_op, e_op') in Some (e_res'', e_op'') ) - | _ - -> None + | _ -> + None + let get_other_atoms tenv side atom_in = let build_other_atoms construct side e = @@ -733,10 +773,10 @@ end = struct let others1 = get_others_direct_or_induced side e in let others2 = match others1 with None -> get_others_deep side e | Some _ -> others1 in match others2 with - | None - -> None - | Some (e_res, e_op) - -> let a_res = construct e_res in + | None -> + None + | Some (e_res, e_op) -> + let a_res = construct e_res in let a_op = construct e_op in if Config.trace_join then ( L.d_str "build_other_atoms (successful) " ; @@ -759,39 +799,40 @@ end = struct else match atom_in with | Sil.Aneq ((Exp.Var id as e), e') - when exp_contains_only_normal_ids e' && not (Ident.is_normal id) - -> (* e' cannot also be a normal id according to the guard so we can consider the two cases + when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> + (* e' cannot also be a normal id according to the guard so we can consider the two cases separately (this case and the next) *) build_other_atoms (fun e0 -> Prop.mk_neq tenv e0 e') side e | Sil.Aneq (e', (Exp.Var id as e)) - when exp_contains_only_normal_ids e' && not (Ident.is_normal id) - -> build_other_atoms (fun e0 -> Prop.mk_neq tenv e0 e') side e + when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> + build_other_atoms (fun e0 -> Prop.mk_neq tenv e0 e') side e | Sil.Apred (a, (Var id as e) :: es) - when not (Ident.is_normal id) && List.for_all ~f:exp_contains_only_normal_ids es - -> build_other_atoms (fun e0 -> Prop.mk_pred tenv a (e0 :: es)) side e + when not (Ident.is_normal id) && List.for_all ~f:exp_contains_only_normal_ids es -> + build_other_atoms (fun e0 -> Prop.mk_pred tenv a (e0 :: es)) side e | Sil.Anpred (a, (Var id as e) :: es) - when not (Ident.is_normal id) && List.for_all ~f:exp_contains_only_normal_ids es - -> build_other_atoms (fun e0 -> Prop.mk_npred tenv a (e0 :: es)) side e + when not (Ident.is_normal id) && List.for_all ~f:exp_contains_only_normal_ids es -> + build_other_atoms (fun e0 -> Prop.mk_npred tenv a (e0 :: es)) side e | Sil.Aeq ((Exp.Var id as e), e') - when exp_contains_only_normal_ids e' && not (Ident.is_normal id) - -> (* e' cannot also be a normal id according to the guard so we can consider the two cases + when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> + (* e' cannot also be a normal id according to the guard so we can consider the two cases separately (this case and the next) *) build_other_atoms (fun e0 -> Prop.mk_eq tenv e0 e') side e | Sil.Aeq (e', (Exp.Var id as e)) - when exp_contains_only_normal_ids e' && not (Ident.is_normal id) - -> build_other_atoms (fun e0 -> Prop.mk_eq tenv e0 e') side e + when exp_contains_only_normal_ids e' && not (Ident.is_normal id) -> + build_other_atoms (fun e0 -> Prop.mk_eq tenv e0 e') side e | Sil.Aeq (Exp.BinOp (Binop.Le, e, e'), Exp.Const Const.Cint i) | Sil.Aeq (Exp.Const Const.Cint i, Exp.BinOp (Binop.Le, e, e')) - when IntLit.isone i && exp_contains_only_normal_ids e' - -> let construct e0 = Prop.mk_inequality tenv (Exp.BinOp (Binop.Le, e0, e')) in + when IntLit.isone i && exp_contains_only_normal_ids e' -> + let construct e0 = Prop.mk_inequality tenv (Exp.BinOp (Binop.Le, e0, e')) in build_other_atoms construct side e | Sil.Aeq (Exp.BinOp (Binop.Lt, e', e), Exp.Const Const.Cint i) | Sil.Aeq (Exp.Const Const.Cint i, Exp.BinOp (Binop.Lt, e', e)) - when IntLit.isone i && exp_contains_only_normal_ids e' - -> let construct e0 = Prop.mk_inequality tenv (Exp.BinOp (Binop.Lt, e', e0)) in + when IntLit.isone i && exp_contains_only_normal_ids e' -> + let construct e0 = Prop.mk_inequality tenv (Exp.BinOp (Binop.Lt, e', e0)) in build_other_atoms construct side e - | Sil.Aeq _ | Aneq _ | Apred _ | Anpred _ - -> None + | Sil.Aeq _ | Aneq _ | Apred _ | Anpred _ -> + None + type data_opt = ExtFresh | ExtDefault of Exp.t @@ -802,10 +843,10 @@ end = struct List.find ~f:(fun (f1, f2, _) -> Exp.equal e1 f1 && Exp.equal e2 f2) !tbl |> Option.map ~f:trd3 with - | Some res - -> res - | None - -> let fav1 = Sil.exp_fav e1 in + | Some res -> + res + | None -> + let fav1 = Sil.exp_fav e1 in let fav2 = Sil.exp_fav e2 in let no_ren1 = not (Sil.fav_exists fav1 can_rename) in let no_ren2 = not (Sil.fav_exists fav2 can_rename) in @@ -817,10 +858,10 @@ end = struct if Exp.equal e1 e2 then e1 else ( L.d_strln "failure reason 13" ; raise Sil.JoinFail ) else match default_op with - | ExtDefault e - -> e - | ExtFresh - -> let kind = + | ExtDefault e -> + e + | ExtFresh -> + let kind = if JoinState.get_footprint () && not (some_primed ()) then Ident.kfootprint else Ident.kprimed in @@ -828,110 +869,119 @@ end = struct in let entry = (e1, e2, e) in push entry ; Todo.push entry ; e + end (** {2 Functions for constructing fresh sil data types} *) let extend_side' kind side e = match Rename.get_others side e with - | None - -> let e_op = Exp.Var (Ident.create_fresh kind) in + | None -> + let e_op = Exp.Var (Ident.create_fresh kind) in let e_new = Exp.Var (Ident.create_fresh kind) in let e1, e2 = match side with Lhs -> (e, e_op) | Rhs -> (e_op, e) in Rename.extend e1 e2 (Rename.ExtDefault e_new) - | Some (e', _) - -> e' + | Some (e', _) -> + e' + let rec exp_construct_fresh side e = match e with - | Exp.Var id - -> if Ident.is_normal id then ( + | Exp.Var id -> + if Ident.is_normal id then ( Todo.push (e, e, e) ; e ) else if Ident.is_footprint id then extend_side' Ident.kfootprint side e else extend_side' Ident.kprimed side e - | Exp.Const _ - -> e - | Exp.Cast (t, e1) - -> let e1' = exp_construct_fresh side e1 in + | Exp.Const _ -> + e + | Exp.Cast (t, e1) -> + let e1' = exp_construct_fresh side e1 in Exp.Cast (t, e1') - | Exp.UnOp (unop, e1, topt) - -> let e1' = exp_construct_fresh side e1 in + | Exp.UnOp (unop, e1, topt) -> + let e1' = exp_construct_fresh side e1 in Exp.UnOp (unop, e1', topt) - | Exp.BinOp (binop, e1, e2) - -> let e1' = exp_construct_fresh side e1 in + | Exp.BinOp (binop, e1, e2) -> + let e1' = exp_construct_fresh side e1 in let e2' = exp_construct_fresh side e2 in Exp.BinOp (binop, e1', e2') - | Exp.Exn _ - -> e - | Exp.Closure _ - -> e - | Exp.Lvar _ - -> e - | Exp.Lfield (e1, fld, typ) - -> let e1' = exp_construct_fresh side e1 in + | Exp.Exn _ -> + e + | Exp.Closure _ -> + e + | Exp.Lvar _ -> + e + | Exp.Lfield (e1, fld, typ) -> + let e1' = exp_construct_fresh side e1 in Exp.Lfield (e1', fld, typ) - | Exp.Lindex (e1, e2) - -> let e1' = exp_construct_fresh side e1 in + | Exp.Lindex (e1, e2) -> + let e1' = exp_construct_fresh side e1 in let e2' = exp_construct_fresh side e2 in Exp.Lindex (e1', e2') - | Exp.Sizeof {dynamic_length= None} - -> e - | Exp.Sizeof ({dynamic_length= Some len} as sizeof) - -> Exp.Sizeof {sizeof with dynamic_length= Some (exp_construct_fresh side len)} + | Exp.Sizeof {dynamic_length= None} -> + e + | Exp.Sizeof ({dynamic_length= Some len} as sizeof) -> + Exp.Sizeof {sizeof with dynamic_length= Some (exp_construct_fresh side len)} + let strexp_construct_fresh side = let f (e, inst_opt) = (exp_construct_fresh side e, inst_opt) in Sil.strexp_expmap f + let hpred_construct_fresh side = let f (e, inst_opt) = (exp_construct_fresh side e, inst_opt) in Sil.hpred_expmap f + (** {2 Join and Meet for Ids} *) let ident_same_kind_primed_footprint id1 id2 = Ident.is_primed id1 && Ident.is_primed id2 || Ident.is_footprint id1 && Ident.is_footprint id2 + let ident_partial_join (id1: Ident.t) (id2: Ident.t) = match (Ident.is_normal id1, Ident.is_normal id2) with - | true, true - -> if Ident.equal id1 id2 then Exp.Var id1 + | true, true -> + if Ident.equal id1 id2 then Exp.Var id1 else ( L.d_strln "failure reason 14" ; raise Sil.JoinFail ) - | true, _ | _, true - -> Rename.extend (Exp.Var id1) (Exp.Var id2) Rename.ExtFresh - | _ - -> if not (ident_same_kind_primed_footprint id1 id2) then ( + | true, _ | _, true -> + Rename.extend (Exp.Var id1) (Exp.Var id2) Rename.ExtFresh + | _ -> + if not (ident_same_kind_primed_footprint id1 id2) then ( L.d_strln "failure reason 15" ; raise Sil.JoinFail ) else let e1 = Exp.Var id1 in let e2 = Exp.Var id2 in Rename.extend e1 e2 Rename.ExtFresh + let ident_partial_meet (id1: Ident.t) (id2: Ident.t) = match (Ident.is_normal id1, Ident.is_normal id2) with - | true, true - -> if Ident.equal id1 id2 then Exp.Var id1 + | true, true -> + if Ident.equal id1 id2 then Exp.Var id1 else ( L.d_strln "failure reason 16" ; raise Sil.JoinFail ) - | true, _ - -> let e1, e2 = (Exp.Var id1, Exp.Var id2) in + | true, _ -> + let e1, e2 = (Exp.Var id1, Exp.Var id2) in Rename.extend e1 e2 (Rename.ExtDefault e1) - | _, true - -> let e1, e2 = (Exp.Var id1, Exp.Var id2) in + | _, true -> + let e1, e2 = (Exp.Var id1, Exp.Var id2) in Rename.extend e1 e2 (Rename.ExtDefault e2) - | _ - -> if Ident.is_primed id1 && Ident.is_primed id2 then + | _ -> + if Ident.is_primed id1 && Ident.is_primed id2 then Rename.extend (Exp.Var id1) (Exp.Var id2) Rename.ExtFresh else if Ident.is_footprint id1 && Ident.equal id1 id2 then let e = Exp.Var id1 in Rename.extend e e (Rename.ExtDefault e) else ( L.d_strln "failure reason 17" ; raise Sil.JoinFail ) + (** {2 Join and Meet for Exps} *) let option_partial_join partial_join o1 o2 = match (o1, o2) with None, _ -> o2 | _, None -> o1 | Some x1, Some x2 -> partial_join x1 x2 + let const_partial_join c1 c2 = let is_int = function Const.Cint _ -> true | _ -> false in if Const.equal c1 c2 then Exp.Const c1 @@ -940,174 +990,181 @@ let const_partial_join c1 c2 = else if !Config.abs_val >= 2 then FreshVarExp.get_fresh_exp (Exp.Const c1) (Exp.Const c2) else ( L.d_strln "failure reason 19" ; raise Sil.JoinFail ) + let rec exp_partial_join (e1: Exp.t) (e2: Exp.t) : Exp.t = (* L.d_str "exp_partial_join "; Sil.d_exp e1; L.d_str " "; Sil.d_exp e2; L.d_ln (); *) match (e1, e2) with - | Exp.Var id1, Exp.Var id2 - -> ident_partial_join id1 id2 - | Exp.Var id, Exp.Const _ | Exp.Const _, Exp.Var id - -> if Ident.is_normal id then ( L.d_strln "failure reason 20" ; raise Sil.JoinFail ) + | Exp.Var id1, Exp.Var id2 -> + ident_partial_join id1 id2 + | Exp.Var id, Exp.Const _ | Exp.Const _, Exp.Var id -> + if Ident.is_normal id then ( L.d_strln "failure reason 20" ; raise Sil.JoinFail ) else Rename.extend e1 e2 Rename.ExtFresh - | Exp.Const c1, Exp.Const c2 - -> const_partial_join c1 c2 - | Exp.Var id, Exp.Lvar _ | Exp.Lvar _, Exp.Var id - -> if Ident.is_normal id then ( L.d_strln "failure reason 21" ; raise Sil.JoinFail ) + | Exp.Const c1, Exp.Const c2 -> + const_partial_join c1 c2 + | Exp.Var id, Exp.Lvar _ | Exp.Lvar _, Exp.Var id -> + if Ident.is_normal id then ( L.d_strln "failure reason 21" ; raise Sil.JoinFail ) else Rename.extend e1 e2 Rename.ExtFresh | Exp.BinOp (Binop.PlusA, Exp.Var id1, Exp.Const _), Exp.Var id2 | Exp.Var id1, Exp.BinOp (Binop.PlusA, Exp.Var id2, Exp.Const _) - when ident_same_kind_primed_footprint id1 id2 - -> Rename.extend e1 e2 Rename.ExtFresh + when ident_same_kind_primed_footprint id1 id2 -> + Rename.extend e1 e2 Rename.ExtFresh | Exp.BinOp (Binop.PlusA, Exp.Var id1, Exp.Const Const.Cint c1), Exp.Const Const.Cint c2 - when can_rename id1 - -> let c2' = c2 -- c1 in + when can_rename id1 -> + let c2' = c2 -- c1 in let e_res = Rename.extend (Exp.Var id1) (Exp.int c2') Rename.ExtFresh in Exp.BinOp (Binop.PlusA, e_res, Exp.int c1) | Exp.Const Const.Cint c1, Exp.BinOp (Binop.PlusA, Exp.Var id2, Exp.Const Const.Cint c2) - when can_rename id2 - -> let c1' = c1 -- c2 in + when can_rename id2 -> + let c1' = c1 -- c2 in let e_res = Rename.extend (Exp.int c1') (Exp.Var id2) Rename.ExtFresh in Exp.BinOp (Binop.PlusA, e_res, Exp.int c2) - | Exp.Cast (t1, e1), Exp.Cast (t2, e2) - -> if not (Typ.equal t1 t2) then ( L.d_strln "failure reason 22" ; raise Sil.JoinFail ) + | Exp.Cast (t1, e1), Exp.Cast (t2, e2) -> + if not (Typ.equal t1 t2) then ( L.d_strln "failure reason 22" ; raise Sil.JoinFail ) else let e1'' = exp_partial_join e1 e2 in Exp.Cast (t1, e1'') - | Exp.UnOp (unop1, e1, topt1), Exp.UnOp (unop2, e2, _) - -> if not (Unop.equal unop1 unop2) then ( L.d_strln "failure reason 23" ; raise Sil.JoinFail ) + | Exp.UnOp (unop1, e1, topt1), Exp.UnOp (unop2, e2, _) -> + if not (Unop.equal unop1 unop2) then ( L.d_strln "failure reason 23" ; raise Sil.JoinFail ) else Exp.UnOp (unop1, exp_partial_join e1 e2, topt1) (* should be topt1 = topt2 *) - | Exp.BinOp (Binop.PlusPI, e1, e1'), Exp.BinOp (Binop.PlusPI, e2, e2') - -> let e1'' = exp_partial_join e1 e2 in + | Exp.BinOp (Binop.PlusPI, e1, e1'), Exp.BinOp (Binop.PlusPI, e2, e2') -> + let e1'' = exp_partial_join e1 e2 in let e2'' = match (e1', e2') with - | Exp.Const _, Exp.Const _ - -> exp_partial_join e1' e2' - | _ - -> FreshVarExp.get_fresh_exp e1 e2 + | Exp.Const _, Exp.Const _ -> + exp_partial_join e1' e2' + | _ -> + FreshVarExp.get_fresh_exp e1 e2 in Exp.BinOp (Binop.PlusPI, e1'', e2'') - | Exp.BinOp (binop1, e1, e1'), Exp.BinOp (binop2, e2, e2') - -> if not (Binop.equal binop1 binop2) then ( L.d_strln "failure reason 24" ; raise Sil.JoinFail ) + | Exp.BinOp (binop1, e1, e1'), Exp.BinOp (binop2, e2, e2') -> + if not (Binop.equal binop1 binop2) then ( L.d_strln "failure reason 24" ; raise Sil.JoinFail ) else let e1'' = exp_partial_join e1 e2 in let e2'' = exp_partial_join e1' e2' in Exp.BinOp (binop1, e1'', e2'') - | Exp.Lvar pvar1, Exp.Lvar pvar2 - -> if not (Pvar.equal pvar1 pvar2) then ( L.d_strln "failure reason 25" ; raise Sil.JoinFail ) + | Exp.Lvar pvar1, Exp.Lvar pvar2 -> + if not (Pvar.equal pvar1 pvar2) then ( L.d_strln "failure reason 25" ; raise Sil.JoinFail ) else e1 - | Exp.Lfield (e1, f1, t1), Exp.Lfield (e2, f2, _) - -> if not (Typ.Fieldname.equal f1 f2) then ( L.d_strln "failure reason 26" ; raise Sil.JoinFail ) + | Exp.Lfield (e1, f1, t1), Exp.Lfield (e2, f2, _) -> + if not (Typ.Fieldname.equal f1 f2) then ( L.d_strln "failure reason 26" ; raise Sil.JoinFail ) else Exp.Lfield (exp_partial_join e1 e2, f1, t1) (* should be t1 = t2 *) - | Exp.Lindex (e1, e1'), Exp.Lindex (e2, e2') - -> let e1'' = exp_partial_join e1 e2 in + | Exp.Lindex (e1, e1'), Exp.Lindex (e2, e2') -> + let e1'' = exp_partial_join e1 e2 in let e2'' = exp_partial_join e1' e2' in Exp.Lindex (e1'', e2'') | ( Exp.Sizeof {typ= t1; nbytes= nbytes1; dynamic_length= len1; subtype= st1} - , Exp.Sizeof {typ= t2; nbytes= nbytes2; dynamic_length= len2; subtype= st2} ) - -> (* forget the static sizes if they differ *) + , Exp.Sizeof {typ= t2; nbytes= nbytes2; dynamic_length= len2; subtype= st2} ) -> + (* forget the static sizes if they differ *) let nbytes_join i1 i2 = if Int.equal i1 i2 then Some i1 else None in Exp.Sizeof { typ= typ_partial_join t1 t2 ; nbytes= option_partial_join nbytes_join nbytes1 nbytes2 ; dynamic_length= dynamic_length_partial_join len1 len2 ; subtype= Subtype.join st1 st2 } - | _ - -> L.d_str "exp_partial_join no match " ; + | _ -> + L.d_str "exp_partial_join no match " ; Sil.d_exp e1 ; L.d_str " " ; Sil.d_exp e2 ; L.d_ln () ; raise Sil.JoinFail + and length_partial_join len1 len2 = match (len1, len2) with - | Exp.BinOp (Binop.PlusA, e1, Exp.Const c1), Exp.BinOp (Binop.PlusA, e2, Exp.Const c2) - -> let e' = exp_partial_join e1 e2 in + | Exp.BinOp (Binop.PlusA, e1, Exp.Const c1), Exp.BinOp (Binop.PlusA, e2, Exp.Const c2) -> + let e' = exp_partial_join e1 e2 in let c' = exp_partial_join (Exp.Const c1) (Exp.Const c2) in Exp.BinOp (Binop.PlusA, e', c') - | Exp.BinOp (Binop.PlusA, _, _), Exp.BinOp (Binop.PlusA, _, _) - -> Rename.extend len1 len2 Rename.ExtFresh - | Exp.Var id1, Exp.Var id2 when Ident.equal id1 id2 - -> len1 - | _ - -> exp_partial_join len1 len2 + | Exp.BinOp (Binop.PlusA, _, _), Exp.BinOp (Binop.PlusA, _, _) -> + Rename.extend len1 len2 Rename.ExtFresh + | Exp.Var id1, Exp.Var id2 when Ident.equal id1 id2 -> + len1 + | _ -> + exp_partial_join len1 len2 + and static_length_partial_join l1 l2 = option_partial_join (fun len1 len2 -> if IntLit.eq len1 len2 then Some len1 else None) l1 l2 + and dynamic_length_partial_join l1 l2 = option_partial_join (fun len1 len2 -> Some (length_partial_join len1 len2)) l1 l2 + and typ_partial_join (t1: Typ.t) (t2: Typ.t) = match (t1.desc, t2.desc) with | Typ.Tptr (t1, pk1), Typ.Tptr (t2, pk2) - when Typ.equal_ptr_kind pk1 pk2 && Typ.equal_quals t1.quals t2.quals - -> Typ.mk ~default:t1 (Tptr (typ_partial_join t1 t2, pk1)) + when Typ.equal_ptr_kind pk1 pk2 && Typ.equal_quals t1.quals t2.quals -> + Typ.mk ~default:t1 (Tptr (typ_partial_join t1 t2, pk1)) (* quals are the same for t1 and t2 *) | Typ.Tarray (typ1, len1, stride1), Typ.Tarray (typ2, len2, stride2) - when Typ.equal_quals typ1.quals typ2.quals - -> let t = typ_partial_join typ1 typ2 in + when Typ.equal_quals typ1.quals typ2.quals -> + let t = typ_partial_join typ1 typ2 in let len = static_length_partial_join len1 len2 in let stride = static_length_partial_join stride1 stride2 in Typ.mk ~default:t1 (Tarray (t, len, stride)) (* quals are the same for t1 and t2 *) - | _ when Typ.equal t1 t2 - -> t1 (* common case *) - | _ - -> L.d_str "typ_partial_join no match " ; + | _ when Typ.equal t1 t2 -> + t1 (* common case *) + | _ -> + L.d_str "typ_partial_join no match " ; Typ.d_full t1 ; L.d_str " " ; Typ.d_full t2 ; L.d_ln () ; raise Sil.JoinFail + let rec exp_partial_meet (e1: Exp.t) (e2: Exp.t) : Exp.t = match (e1, e2) with - | Exp.Var id1, Exp.Var id2 - -> ident_partial_meet id1 id2 - | Exp.Var id, Exp.Const _ - -> if not (Ident.is_normal id) then Rename.extend e1 e2 (Rename.ExtDefault e2) + | Exp.Var id1, Exp.Var id2 -> + ident_partial_meet id1 id2 + | Exp.Var id, Exp.Const _ -> + if not (Ident.is_normal id) then Rename.extend e1 e2 (Rename.ExtDefault e2) else ( L.d_strln "failure reason 27" ; raise Sil.JoinFail ) - | Exp.Const _, Exp.Var id - -> if not (Ident.is_normal id) then Rename.extend e1 e2 (Rename.ExtDefault e1) + | Exp.Const _, Exp.Var id -> + if not (Ident.is_normal id) then Rename.extend e1 e2 (Rename.ExtDefault e1) else ( L.d_strln "failure reason 28" ; raise Sil.JoinFail ) - | Exp.Const c1, Exp.Const c2 - -> if Const.equal c1 c2 then e1 else ( L.d_strln "failure reason 29" ; raise Sil.JoinFail ) - | Exp.Cast (t1, e1), Exp.Cast (t2, e2) - -> if not (Typ.equal t1 t2) then ( L.d_strln "failure reason 30" ; raise Sil.JoinFail ) + | Exp.Const c1, Exp.Const c2 -> + if Const.equal c1 c2 then e1 else ( L.d_strln "failure reason 29" ; raise Sil.JoinFail ) + | Exp.Cast (t1, e1), Exp.Cast (t2, e2) -> + if not (Typ.equal t1 t2) then ( L.d_strln "failure reason 30" ; raise Sil.JoinFail ) else let e1'' = exp_partial_meet e1 e2 in Exp.Cast (t1, e1'') - | Exp.UnOp (unop1, e1, topt1), Exp.UnOp (unop2, e2, _) - -> if not (Unop.equal unop1 unop2) then ( L.d_strln "failure reason 31" ; raise Sil.JoinFail ) + | Exp.UnOp (unop1, e1, topt1), Exp.UnOp (unop2, e2, _) -> + if not (Unop.equal unop1 unop2) then ( L.d_strln "failure reason 31" ; raise Sil.JoinFail ) else Exp.UnOp (unop1, exp_partial_meet e1 e2, topt1) (* should be topt1 = topt2 *) - | Exp.BinOp (binop1, e1, e1'), Exp.BinOp (binop2, e2, e2') - -> if not (Binop.equal binop1 binop2) then ( L.d_strln "failure reason 32" ; raise Sil.JoinFail ) + | Exp.BinOp (binop1, e1, e1'), Exp.BinOp (binop2, e2, e2') -> + if not (Binop.equal binop1 binop2) then ( L.d_strln "failure reason 32" ; raise Sil.JoinFail ) else let e1'' = exp_partial_meet e1 e2 in let e2'' = exp_partial_meet e1' e2' in Exp.BinOp (binop1, e1'', e2'') - | Exp.Var id, Exp.Lvar _ - -> if not (Ident.is_normal id) then Rename.extend e1 e2 (Rename.ExtDefault e2) + | Exp.Var id, Exp.Lvar _ -> + if not (Ident.is_normal id) then Rename.extend e1 e2 (Rename.ExtDefault e2) else ( L.d_strln "failure reason 33" ; raise Sil.JoinFail ) - | Exp.Lvar _, Exp.Var id - -> if not (Ident.is_normal id) then Rename.extend e1 e2 (Rename.ExtDefault e1) + | Exp.Lvar _, Exp.Var id -> + if not (Ident.is_normal id) then Rename.extend e1 e2 (Rename.ExtDefault e1) else ( L.d_strln "failure reason 34" ; raise Sil.JoinFail ) - | Exp.Lvar pvar1, Exp.Lvar pvar2 - -> if not (Pvar.equal pvar1 pvar2) then ( L.d_strln "failure reason 35" ; raise Sil.JoinFail ) + | Exp.Lvar pvar1, Exp.Lvar pvar2 -> + if not (Pvar.equal pvar1 pvar2) then ( L.d_strln "failure reason 35" ; raise Sil.JoinFail ) else e1 - | Exp.Lfield (e1, f1, t1), Exp.Lfield (e2, f2, _) - -> if not (Typ.Fieldname.equal f1 f2) then ( L.d_strln "failure reason 36" ; raise Sil.JoinFail ) + | Exp.Lfield (e1, f1, t1), Exp.Lfield (e2, f2, _) -> + if not (Typ.Fieldname.equal f1 f2) then ( L.d_strln "failure reason 36" ; raise Sil.JoinFail ) else Exp.Lfield (exp_partial_meet e1 e2, f1, t1) (* should be t1 = t2 *) - | Exp.Lindex (e1, e1'), Exp.Lindex (e2, e2') - -> let e1'' = exp_partial_meet e1 e2 in + | Exp.Lindex (e1, e1'), Exp.Lindex (e2, e2') -> + let e1'' = exp_partial_meet e1 e2 in let e2'' = exp_partial_meet e1' e2' in Exp.Lindex (e1'', e2'') - | _ - -> L.d_strln "failure reason 37" ; raise Sil.JoinFail + | _ -> + L.d_strln "failure reason 37" ; raise Sil.JoinFail + let exp_list_partial_join = List.map2_exn ~f:exp_partial_join @@ -1118,58 +1175,60 @@ let exp_list_partial_meet = List.map2_exn ~f:exp_partial_meet let rec strexp_partial_join mode (strexp1: Sil.strexp) (strexp2: Sil.strexp) : Sil.strexp = let rec f_fld_se_list inst mode acc fld_se_list1 fld_se_list2 = match (fld_se_list1, fld_se_list2) with - | [], [] - -> Sil.Estruct (List.rev acc, inst) + | [], [] -> + Sil.Estruct (List.rev acc, inst) | [], _ | _, [] -> ( match mode with - | JoinState.Pre - -> L.d_strln "failure reason 42" ; raise Sil.JoinFail - | JoinState.Post - -> Sil.Estruct (List.rev acc, inst) ) - | (fld1, se1) :: fld_se_list1', (fld2, se2) :: fld_se_list2' - -> let comparison = Typ.Fieldname.compare fld1 fld2 in + | JoinState.Pre -> + L.d_strln "failure reason 42" ; raise Sil.JoinFail + | JoinState.Post -> + Sil.Estruct (List.rev acc, inst) ) + | (fld1, se1) :: fld_se_list1', (fld2, se2) :: fld_se_list2' -> + let comparison = Typ.Fieldname.compare fld1 fld2 in if Int.equal comparison 0 then let strexp' = strexp_partial_join mode se1 se2 in let fld_se_list_new = (fld1, strexp') :: acc in f_fld_se_list inst mode fld_se_list_new fld_se_list1' fld_se_list2' else match mode with - | JoinState.Pre - -> L.d_strln "failure reason 43" ; raise Sil.JoinFail - | JoinState.Post - -> if comparison < 0 then f_fld_se_list inst mode acc fld_se_list1' fld_se_list2 + | JoinState.Pre -> + L.d_strln "failure reason 43" ; raise Sil.JoinFail + | JoinState.Post -> + if comparison < 0 then f_fld_se_list inst mode acc fld_se_list1' fld_se_list2 else if comparison > 0 then f_fld_se_list inst mode acc fld_se_list1 fld_se_list2' else assert false (* This case should not happen. *) in let rec f_idx_se_list inst len idx_se_list_acc idx_se_list1 idx_se_list2 = match (idx_se_list1, idx_se_list2) with - | [], [] - -> Sil.Earray (len, List.rev idx_se_list_acc, inst) + | [], [] -> + Sil.Earray (len, List.rev idx_se_list_acc, inst) | [], _ | _, [] -> ( match mode with - | JoinState.Pre - -> L.d_strln "failure reason 44" ; raise Sil.JoinFail - | JoinState.Post - -> Sil.Earray (len, List.rev idx_se_list_acc, inst) ) - | (idx1, se1) :: idx_se_list1', (idx2, se2) :: idx_se_list2' - -> let idx = exp_partial_join idx1 idx2 in + | JoinState.Pre -> + L.d_strln "failure reason 44" ; raise Sil.JoinFail + | JoinState.Post -> + Sil.Earray (len, List.rev idx_se_list_acc, inst) ) + | (idx1, se1) :: idx_se_list1', (idx2, se2) :: idx_se_list2' -> + let idx = exp_partial_join idx1 idx2 in let strexp' = strexp_partial_join mode se1 se2 in let idx_se_list_new = (idx, strexp') :: idx_se_list_acc in f_idx_se_list inst len idx_se_list_new idx_se_list1' idx_se_list2' in match (strexp1, strexp2) with - | Sil.Eexp (e1, inst1), Sil.Eexp (e2, inst2) - -> Sil.Eexp (exp_partial_join e1 e2, Sil.inst_partial_join inst1 inst2) - | Sil.Estruct (fld_se_list1, inst1), Sil.Estruct (fld_se_list2, inst2) - -> let inst = Sil.inst_partial_join inst1 inst2 in + | Sil.Eexp (e1, inst1), Sil.Eexp (e2, inst2) -> + Sil.Eexp (exp_partial_join e1 e2, Sil.inst_partial_join inst1 inst2) + | Sil.Estruct (fld_se_list1, inst1), Sil.Estruct (fld_se_list2, inst2) -> + let inst = Sil.inst_partial_join inst1 inst2 in f_fld_se_list inst mode [] fld_se_list1 fld_se_list2 - | Sil.Earray (len1, idx_se_list1, inst1), Sil.Earray (len2, idx_se_list2, inst2) - -> let len = length_partial_join len1 len2 in + | Sil.Earray (len1, idx_se_list1, inst1), Sil.Earray (len2, idx_se_list2, inst2) -> + let len = length_partial_join len1 len2 in let inst = Sil.inst_partial_join inst1 inst2 in f_idx_se_list inst len [] idx_se_list1 idx_se_list2 - | _ - -> L.d_strln "no match in strexp_partial_join" ; raise Sil.JoinFail + | _ -> + L.d_strln "no match in strexp_partial_join" ; + raise Sil.JoinFail + let rec strexp_partial_meet (strexp1: Sil.strexp) (strexp2: Sil.strexp) : Sil.strexp = let construct side rev_list ref_list = @@ -1179,14 +1238,14 @@ let rec strexp_partial_meet (strexp1: Sil.strexp) (strexp2: Sil.strexp) : Sil.st in let rec f_fld_se_list inst acc fld_se_list1 fld_se_list2 = match (fld_se_list1, fld_se_list2) with - | [], [] - -> Sil.Estruct (List.rev acc, inst) - | [], _ - -> Sil.Estruct (construct Rhs acc fld_se_list2, inst) - | _, [] - -> Sil.Estruct (construct Lhs acc fld_se_list1, inst) - | (fld1, se1) :: fld_se_list1', (fld2, se2) :: fld_se_list2' - -> let comparison = Typ.Fieldname.compare fld1 fld2 in + | [], [] -> + Sil.Estruct (List.rev acc, inst) + | [], _ -> + Sil.Estruct (construct Rhs acc fld_se_list2, inst) + | _, [] -> + Sil.Estruct (construct Lhs acc fld_se_list1, inst) + | (fld1, se1) :: fld_se_list1', (fld2, se2) :: fld_se_list2' -> + let comparison = Typ.Fieldname.compare fld1 fld2 in if comparison < 0 then let se' = strexp_construct_fresh Lhs se1 in let acc_new = (fld1, se') :: acc in @@ -1202,88 +1261,95 @@ let rec strexp_partial_meet (strexp1: Sil.strexp) (strexp2: Sil.strexp) : Sil.st in let rec f_idx_se_list inst len acc idx_se_list1 idx_se_list2 = match (idx_se_list1, idx_se_list2) with - | [], [] - -> Sil.Earray (len, List.rev acc, inst) - | [], _ - -> Sil.Earray (len, construct Rhs acc idx_se_list2, inst) - | _, [] - -> Sil.Earray (len, construct Lhs acc idx_se_list1, inst) - | (idx1, se1) :: idx_se_list1', (idx2, se2) :: idx_se_list2' - -> let idx = exp_partial_meet idx1 idx2 in + | [], [] -> + Sil.Earray (len, List.rev acc, inst) + | [], _ -> + Sil.Earray (len, construct Rhs acc idx_se_list2, inst) + | _, [] -> + Sil.Earray (len, construct Lhs acc idx_se_list1, inst) + | (idx1, se1) :: idx_se_list1', (idx2, se2) :: idx_se_list2' -> + let idx = exp_partial_meet idx1 idx2 in let se' = strexp_partial_meet se1 se2 in let acc_new = (idx, se') :: acc in f_idx_se_list inst len acc_new idx_se_list1' idx_se_list2' in match (strexp1, strexp2) with - | Sil.Eexp (e1, inst1), Sil.Eexp (e2, inst2) - -> Sil.Eexp (exp_partial_meet e1 e2, Sil.inst_partial_meet inst1 inst2) - | Sil.Estruct (fld_se_list1, inst1), Sil.Estruct (fld_se_list2, inst2) - -> let inst = Sil.inst_partial_meet inst1 inst2 in + | Sil.Eexp (e1, inst1), Sil.Eexp (e2, inst2) -> + Sil.Eexp (exp_partial_meet e1 e2, Sil.inst_partial_meet inst1 inst2) + | Sil.Estruct (fld_se_list1, inst1), Sil.Estruct (fld_se_list2, inst2) -> + let inst = Sil.inst_partial_meet inst1 inst2 in f_fld_se_list inst [] fld_se_list1 fld_se_list2 | Sil.Earray (len1, idx_se_list1, inst1), Sil.Earray (len2, idx_se_list2, inst2) - when Exp.equal len1 len2 - -> let inst = Sil.inst_partial_meet inst1 inst2 in + when Exp.equal len1 len2 -> + let inst = Sil.inst_partial_meet inst1 inst2 in f_idx_se_list inst len1 [] idx_se_list1 idx_se_list2 - | _ - -> L.d_strln "failure reason 52" ; raise Sil.JoinFail + | _ -> + L.d_strln "failure reason 52" ; raise Sil.JoinFail + (** {2 Join and Meet for kind, hpara, hpara_dll} *) let kind_join k1 k2 = match (k1, k2) with - | Sil.Lseg_PE, _ - -> Sil.Lseg_PE - | _, Sil.Lseg_PE - -> Sil.Lseg_PE - | Sil.Lseg_NE, Sil.Lseg_NE - -> Sil.Lseg_NE + | Sil.Lseg_PE, _ -> + Sil.Lseg_PE + | _, Sil.Lseg_PE -> + Sil.Lseg_PE + | Sil.Lseg_NE, Sil.Lseg_NE -> + Sil.Lseg_NE + let kind_meet k1 k2 = match (k1, k2) with - | Sil.Lseg_NE, _ - -> Sil.Lseg_NE - | _, Sil.Lseg_NE - -> Sil.Lseg_NE - | Sil.Lseg_PE, Sil.Lseg_PE - -> Sil.Lseg_PE + | Sil.Lseg_NE, _ -> + Sil.Lseg_NE + | _, Sil.Lseg_NE -> + Sil.Lseg_NE + | Sil.Lseg_PE, Sil.Lseg_PE -> + Sil.Lseg_PE + let hpara_partial_join tenv (hpara1: Sil.hpara) (hpara2: Sil.hpara) : Sil.hpara = if Match.hpara_match_with_impl tenv true hpara2 hpara1 then hpara1 else if Match.hpara_match_with_impl tenv true hpara1 hpara2 then hpara2 else ( L.d_strln "failure reason 53" ; raise Sil.JoinFail ) + let hpara_partial_meet tenv (hpara1: Sil.hpara) (hpara2: Sil.hpara) : Sil.hpara = if Match.hpara_match_with_impl tenv true hpara2 hpara1 then hpara2 else if Match.hpara_match_with_impl tenv true hpara1 hpara2 then hpara1 else ( L.d_strln "failure reason 54" ; raise Sil.JoinFail ) + let hpara_dll_partial_join tenv (hpara1: Sil.hpara_dll) (hpara2: Sil.hpara_dll) : Sil.hpara_dll = if Match.hpara_dll_match_with_impl tenv true hpara2 hpara1 then hpara1 else if Match.hpara_dll_match_with_impl tenv true hpara1 hpara2 then hpara2 else ( L.d_strln "failure reason 55" ; raise Sil.JoinFail ) + let hpara_dll_partial_meet tenv (hpara1: Sil.hpara_dll) (hpara2: Sil.hpara_dll) : Sil.hpara_dll = if Match.hpara_dll_match_with_impl tenv true hpara2 hpara1 then hpara2 else if Match.hpara_dll_match_with_impl tenv true hpara1 hpara2 then hpara1 else ( L.d_strln "failure reason 56" ; raise Sil.JoinFail ) + (** {2 Join and Meet for hpred} *) let hpred_partial_join tenv mode (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpred) (hpred2: Sil.hpred) : Sil.hpred = let e1, e2, e = todo in match (hpred1, hpred2) with - | Sil.Hpointsto (_, se1, te1), Sil.Hpointsto (_, se2, te2) - -> let te = exp_partial_join te1 te2 in + | Sil.Hpointsto (_, se1, te1), Sil.Hpointsto (_, se2, te2) -> + let te = exp_partial_join te1 te2 in Prop.mk_ptsto tenv e (strexp_partial_join mode se1 se2) te - | Sil.Hlseg (k1, hpara1, _, next1, shared1), Sil.Hlseg (k2, hpara2, _, next2, shared2) - -> let hpara' = hpara_partial_join tenv hpara1 hpara2 in + | Sil.Hlseg (k1, hpara1, _, next1, shared1), Sil.Hlseg (k2, hpara2, _, next2, shared2) -> + let hpara' = hpara_partial_join tenv hpara1 hpara2 in let next' = exp_partial_join next1 next2 in let shared' = exp_list_partial_join shared1 shared2 in Prop.mk_lseg tenv (kind_join k1 k2) hpara' e next' shared' | ( Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1) - , Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) ) - -> let fwd1 = Exp.equal e1 iF1 in + , Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) ) -> + let fwd1 = Exp.equal e1 iF1 in let fwd2 = Exp.equal e2 iF2 in let hpara' = hpara_dll_partial_join tenv para1 para2 in let iF', iB' = @@ -1295,25 +1361,26 @@ let hpred_partial_join tenv mode (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpre let oB' = exp_partial_join oB1 oB2 in let shared' = exp_list_partial_join shared1 shared2 in Prop.mk_dllseg tenv (kind_join k1 k2) hpara' iF' oB' oF' iB' shared' - | _ - -> assert false + | _ -> + assert false + let hpred_partial_meet tenv (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpred) (hpred2: Sil.hpred) : Sil.hpred = let e1, e2, e = todo in match (hpred1, hpred2) with - | Sil.Hpointsto (_, se1, te1), Sil.Hpointsto (_, se2, te2) when Exp.equal te1 te2 - -> Prop.mk_ptsto tenv e (strexp_partial_meet se1 se2) te1 - | Sil.Hpointsto _, _ | _, Sil.Hpointsto _ - -> L.d_strln "failure reason 58" ; raise Sil.JoinFail - | Sil.Hlseg (k1, hpara1, _, next1, shared1), Sil.Hlseg (k2, hpara2, _, next2, shared2) - -> let hpara' = hpara_partial_meet tenv hpara1 hpara2 in + | Sil.Hpointsto (_, se1, te1), Sil.Hpointsto (_, se2, te2) when Exp.equal te1 te2 -> + Prop.mk_ptsto tenv e (strexp_partial_meet se1 se2) te1 + | Sil.Hpointsto _, _ | _, Sil.Hpointsto _ -> + L.d_strln "failure reason 58" ; raise Sil.JoinFail + | Sil.Hlseg (k1, hpara1, _, next1, shared1), Sil.Hlseg (k2, hpara2, _, next2, shared2) -> + let hpara' = hpara_partial_meet tenv hpara1 hpara2 in let next' = exp_partial_meet next1 next2 in let shared' = exp_list_partial_meet shared1 shared2 in Prop.mk_lseg tenv (kind_meet k1 k2) hpara' e next' shared' | ( Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1) - , Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) ) - -> let fwd1 = Exp.equal e1 iF1 in + , Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) ) -> + let fwd1 = Exp.equal e1 iF1 in let fwd2 = Exp.equal e2 iF2 in let hpara' = hpara_dll_partial_meet tenv para1 para2 in let iF', iB' = @@ -1325,8 +1392,9 @@ let hpred_partial_meet tenv (todo: Exp.t * Exp.t * Exp.t) (hpred1: Sil.hpred) (h let oB' = exp_partial_meet oB1 oB2 in let shared' = exp_list_partial_meet shared1 shared2 in Prop.mk_dllseg tenv (kind_meet k1 k2) hpara' iF' oB' oF' iB' shared' - | _ - -> assert false + | _ -> + assert false + (** {2 Join and Meet for Sigma} *) @@ -1335,32 +1403,34 @@ let find_hpred_by_address tenv (e: Exp.t) (sigma: Prop.sigma) : Sil.hpred option match Prover.is_root tenv Prop.prop_emp e' e with None -> false | Some _ -> true in let contains_e = function - | Sil.Hpointsto (e', _, _) - -> is_root_for_e e' - | Sil.Hlseg (_, _, e', _, _) - -> is_root_for_e e' - | Sil.Hdllseg (_, _, iF, _, _, iB, _) - -> is_root_for_e iF || is_root_for_e iB + | Sil.Hpointsto (e', _, _) -> + is_root_for_e e' + | Sil.Hlseg (_, _, e', _, _) -> + is_root_for_e e' + | Sil.Hdllseg (_, _, iF, _, _, iB, _) -> + is_root_for_e iF || is_root_for_e iB in let rec f sigma_acc = function - | [] - -> (None, sigma) - | hpred :: sigma - -> if contains_e hpred then (Some hpred, List.rev_append sigma_acc sigma) + | [] -> + (None, sigma) + | hpred :: sigma -> + if contains_e hpred then (Some hpred, List.rev_append sigma_acc sigma) else f (hpred :: sigma_acc) sigma in f [] sigma + let same_pred (hpred1: Sil.hpred) (hpred2: Sil.hpred) : bool = match (hpred1, hpred2) with - | Sil.Hpointsto _, Sil.Hpointsto _ - -> true - | Sil.Hlseg _, Sil.Hlseg _ - -> true - | Sil.Hdllseg _, Sil.Hdllseg _ - -> true - | _ - -> false + | Sil.Hpointsto _, Sil.Hpointsto _ -> + true + | Sil.Hlseg _, Sil.Hlseg _ -> + true + | Sil.Hdllseg _, Sil.Hdllseg _ -> + true + | _ -> + false + (* check that applying renaming to the lhs / rhs of [sigma_new] * gives [sigma] and that the renaming is injective *) @@ -1373,6 +1443,7 @@ let sigma_renaming_check (lhs: side) (sigma: Prop.sigma) (sigma_new: Prop.sigma) let sigma' = Prop.sigma_sub (`Exp sub) sigma_new in equal_sigma sigma sigma' + let sigma_renaming_check_lhs = sigma_renaming_check Lhs let sigma_renaming_check_rhs = sigma_renaming_check Rhs @@ -1381,21 +1452,21 @@ let rec sigma_partial_join' tenv mode (sigma_acc: Prop.sigma) (sigma1_in: Prop.s (sigma2_in: Prop.sigma) : Prop.sigma * Prop.sigma * Prop.sigma = let lookup_and_expand side e e' = match (Rename.get_others side e, side) with - | None, _ - -> L.d_strln "failure reason 60" ; raise Sil.JoinFail - | Some (e_res, e_op), Lhs - -> (e_res, exp_partial_join e' e_op) - | Some (e_res, e_op), Rhs - -> (e_res, exp_partial_join e_op e') + | None, _ -> + L.d_strln "failure reason 60" ; raise Sil.JoinFail + | Some (e_res, e_op), Lhs -> + (e_res, exp_partial_join e' e_op) + | Some (e_res, e_op), Rhs -> + (e_res, exp_partial_join e_op e') in let join_list_and_non side root' hlseg e opposite = match hlseg with - | Sil.Hlseg (_, hpara, root, next, shared) - -> let next' = do_side side exp_partial_join next opposite in + | Sil.Hlseg (_, hpara, root, next, shared) -> + let next' = do_side side exp_partial_join next opposite in let shared' = Rename.lookup_list side shared in CheckJoin.add side root next ; Sil.Hlseg (Sil.Lseg_PE, hpara, root', next', shared') - | Sil.Hdllseg (_, hpara, iF, oB, oF, iB, shared) when Exp.equal iF e - -> let oF' = do_side side exp_partial_join oF opposite in + | Sil.Hdllseg (_, hpara, iF, oB, oF, iB, shared) when Exp.equal iF e -> + let oF' = do_side side exp_partial_join oF opposite in let shared' = Rename.lookup_list side shared in let oB', iB' = lookup_and_expand side oB iB in (* @@ -1405,8 +1476,8 @@ let rec sigma_partial_join' tenv mode (sigma_acc: Prop.sigma) (sigma1_in: Prop.s CheckJoin.add side iF oF ; CheckJoin.add side oB iB ; Sil.Hdllseg (Sil.Lseg_PE, hpara, root', oB', oF', iB', shared') - | Sil.Hdllseg (_, hpara, iF, oB, oF, iB, shared) when Exp.equal iB e - -> let oB' = do_side side exp_partial_join oB opposite in + | Sil.Hdllseg (_, hpara, iF, oB, oF, iB, shared) when Exp.equal iB e -> + let oB' = do_side side exp_partial_join oB opposite in let shared' = Rename.lookup_list side shared in let oF', iF' = lookup_and_expand side oF iF in (* @@ -1416,26 +1487,26 @@ let rec sigma_partial_join' tenv mode (sigma_acc: Prop.sigma) (sigma1_in: Prop.s CheckJoin.add side iF oF ; CheckJoin.add side oB iB ; Sil.Hdllseg (Sil.Lseg_PE, hpara, iF', oB', oF', root', shared') - | _ - -> assert false + | _ -> + assert false in let update_list side lseg root' = match lseg with - | Sil.Hlseg (k, hpara, _, next, shared) - -> let next' = Rename.lookup side next and shared' = Rename.lookup_list_todo side shared in + | Sil.Hlseg (k, hpara, _, next, shared) -> + let next' = Rename.lookup side next and shared' = Rename.lookup_list_todo side shared in Sil.Hlseg (k, hpara, root', next', shared') - | _ - -> assert false + | _ -> + assert false in let update_dllseg side dllseg iF iB = match dllseg with - | Sil.Hdllseg (k, hpara, _, oB, oF, _, shared) - -> let oB' = Rename.lookup side oB + | Sil.Hdllseg (k, hpara, _, oB, oF, _, shared) -> + let oB' = Rename.lookup side oB and oF' = Rename.lookup side oF and shared' = Rename.lookup_list_todo side shared in Sil.Hdllseg (k, hpara, iF, oB', oF', iB, shared') - | _ - -> assert false + | _ -> + assert false in (* Drop the part of 'other' sigma corresponding to 'target' sigma if possible. 'side' describes that target is Lhs or Rhs. @@ -1446,30 +1517,34 @@ let rec sigma_partial_join' tenv mode (sigma_acc: Prop.sigma) (sigma1_in: Prop.s Todo.push todo ; let res = match side with - | Lhs - -> let res, target', other' = sigma_partial_join' tenv mode [] target other in - list_is_empty target' ; sigma_renaming_check_lhs target res ; other' - | Rhs - -> let res, other', target' = sigma_partial_join' tenv mode [] other target in - list_is_empty target' ; sigma_renaming_check_rhs target res ; other' + | Lhs -> + let res, target', other' = sigma_partial_join' tenv mode [] target other in + list_is_empty target' ; + sigma_renaming_check_lhs target res ; + other' + | Rhs -> + let res, other', target' = sigma_partial_join' tenv mode [] other target in + list_is_empty target' ; + sigma_renaming_check_rhs target res ; + other' in Todo.set x ; res in let cut_lseg side todo lseg sigma = match lseg with - | Sil.Hlseg (_, hpara, root, next, shared) - -> let _, sigma_lseg = Sil.hpara_instantiate hpara root next shared in + | Sil.Hlseg (_, hpara, root, next, shared) -> + let _, sigma_lseg = Sil.hpara_instantiate hpara root next shared in cut_sigma side todo sigma_lseg sigma - | _ - -> assert false + | _ -> + assert false in let cut_dllseg side todo root lseg sigma = match lseg with - | Sil.Hdllseg (_, hpara, _, oB, oF, _, shared) - -> let _, sigma_dllseg = Sil.hpara_dll_instantiate hpara root oB oF shared in + | Sil.Hdllseg (_, hpara, _, oB, oF, _, shared) -> + let _, sigma_dllseg = Sil.hpara_dll_instantiate hpara root oB oF shared in cut_sigma side todo sigma_dllseg sigma - | _ - -> assert false + | _ -> + assert false in try let todo_curr = Todo.pop () in @@ -1493,71 +1568,73 @@ let rec sigma_partial_join' tenv mode (sigma_acc: Prop.sigma) (sigma1_in: Prop.s let hpred_opt1, sigma1 = find_hpred_by_address tenv e1 sigma1_in in let hpred_opt2, sigma2 = find_hpred_by_address tenv e2 sigma2_in in match (hpred_opt1, hpred_opt2) with - | None, None - -> sigma_partial_join' tenv mode sigma_acc sigma1 sigma2 + | None, None -> + sigma_partial_join' tenv mode sigma_acc sigma1 sigma2 | Some (Sil.Hlseg (k, _, _, _, _) as lseg), None - | Some (Sil.Hdllseg (k, _, _, _, _, _, _) as lseg), None - -> if not Config.nelseg || Sil.equal_lseg_kind k Sil.Lseg_PE then + | Some (Sil.Hdllseg (k, _, _, _, _, _, _) as lseg), None -> + if not Config.nelseg || Sil.equal_lseg_kind k Sil.Lseg_PE then let sigma_acc' = join_list_and_non Lhs e lseg e1 e2 :: sigma_acc in sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2 else ( L.d_strln "failure reason 62" ; raise Sil.JoinFail ) | None, Some (Sil.Hlseg (k, _, _, _, _) as lseg) - | None, Some (Sil.Hdllseg (k, _, _, _, _, _, _) as lseg) - -> if not Config.nelseg || Sil.equal_lseg_kind k Sil.Lseg_PE then + | None, Some (Sil.Hdllseg (k, _, _, _, _, _, _) as lseg) -> + if not Config.nelseg || Sil.equal_lseg_kind k Sil.Lseg_PE then let sigma_acc' = join_list_and_non Rhs e lseg e2 e1 :: sigma_acc in sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2 else ( L.d_strln "failure reason 63" ; raise Sil.JoinFail ) - | None, _ | _, None - -> L.d_strln "failure reason 64" ; raise Sil.JoinFail - | Some hpred1, Some hpred2 when same_pred hpred1 hpred2 - -> let hpred_res1 = hpred_partial_join tenv mode todo_curr hpred1 hpred2 in + | None, _ | _, None -> + L.d_strln "failure reason 64" ; raise Sil.JoinFail + | Some hpred1, Some hpred2 when same_pred hpred1 hpred2 -> + let hpred_res1 = hpred_partial_join tenv mode todo_curr hpred1 hpred2 in sigma_partial_join' tenv mode (hpred_res1 :: sigma_acc) sigma1 sigma2 - | Some (Sil.Hlseg _ as lseg), Some hpred2 - -> let sigma2' = cut_lseg Lhs todo_curr lseg (hpred2 :: sigma2) in + | Some (Sil.Hlseg _ as lseg), Some hpred2 -> + let sigma2' = cut_lseg Lhs todo_curr lseg (hpred2 :: sigma2) in let sigma_acc' = update_list Lhs lseg e :: sigma_acc in sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2' - | Some hpred1, Some (Sil.Hlseg _ as lseg) - -> let sigma1' = cut_lseg Rhs todo_curr lseg (hpred1 :: sigma1) in + | Some hpred1, Some (Sil.Hlseg _ as lseg) -> + let sigma1' = cut_lseg Rhs todo_curr lseg (hpred1 :: sigma1) in let sigma_acc' = update_list Rhs lseg e :: sigma_acc in sigma_partial_join' tenv mode sigma_acc' sigma1' sigma2 - | Some (Sil.Hdllseg (_, _, iF1, _, _, iB1, _) as dllseg), Some hpred2 when Exp.equal e1 iF1 - -> let iB_res = exp_partial_join iB1 e2 in + | Some (Sil.Hdllseg (_, _, iF1, _, _, iB1, _) as dllseg), Some hpred2 when Exp.equal e1 iF1 -> + let iB_res = exp_partial_join iB1 e2 in let sigma2' = cut_dllseg Lhs todo_curr iF1 dllseg (hpred2 :: sigma2) in let sigma_acc' = update_dllseg Lhs dllseg e iB_res :: sigma_acc in CheckJoin.add Lhs iF1 iB1 ; (* add equality iF1=iB1 *) sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2' | Some (Sil.Hdllseg (_, _, iF1, _, _, iB1, _) as dllseg), Some hpred2 - (* when Exp.equal e1 iB1 *) - -> let iF_res = exp_partial_join iF1 e2 in + (* when Exp.equal e1 iB1 *) -> + let iF_res = exp_partial_join iF1 e2 in let sigma2' = cut_dllseg Lhs todo_curr iB1 dllseg (hpred2 :: sigma2) in let sigma_acc' = update_dllseg Lhs dllseg iF_res e :: sigma_acc in CheckJoin.add Lhs iF1 iB1 ; (* add equality iF1=iB1 *) sigma_partial_join' tenv mode sigma_acc' sigma1 sigma2' - | Some hpred1, Some (Sil.Hdllseg (_, _, iF2, _, _, iB2, _) as dllseg) when Exp.equal e2 iF2 - -> let iB_res = exp_partial_join e1 iB2 in + | Some hpred1, Some (Sil.Hdllseg (_, _, iF2, _, _, iB2, _) as dllseg) when Exp.equal e2 iF2 -> + let iB_res = exp_partial_join e1 iB2 in let sigma1' = cut_dllseg Rhs todo_curr iF2 dllseg (hpred1 :: sigma1) in let sigma_acc' = update_dllseg Rhs dllseg e iB_res :: sigma_acc in CheckJoin.add Rhs iF2 iB2 ; (* add equality iF2=iB2 *) sigma_partial_join' tenv mode sigma_acc' sigma1' sigma2 - | Some hpred1, Some (Sil.Hdllseg (_, _, iF2, _, _, iB2, _) as dllseg) - -> let iF_res = exp_partial_join e1 iF2 in + | Some hpred1, Some (Sil.Hdllseg (_, _, iF2, _, _, iB2, _) as dllseg) -> + let iF_res = exp_partial_join e1 iF2 in let sigma1' = cut_dllseg Rhs todo_curr iB2 dllseg (hpred1 :: sigma1) in let sigma_acc' = update_dllseg Rhs dllseg iF_res e :: sigma_acc in CheckJoin.add Rhs iF2 iB2 ; (* add equality iF2=iB2 *) sigma_partial_join' tenv mode sigma_acc' sigma1' sigma2 - | Some Sil.Hpointsto _, Some Sil.Hpointsto _ - -> assert false + | Some Sil.Hpointsto _, Some Sil.Hpointsto _ -> + assert false (* Should be handled by a guarded case *) with Todo.Empty -> match (sigma1_in, sigma2_in) with - | _ :: _, _ :: _ - -> L.d_strln "todo is empty, but the sigmas are not" ; raise Sil.JoinFail - | _ - -> (sigma_acc, sigma1_in, sigma2_in) + | _ :: _, _ :: _ -> + L.d_strln "todo is empty, but the sigmas are not" ; + raise Sil.JoinFail + | _ -> + (sigma_acc, sigma1_in, sigma2_in) + let sigma_partial_join tenv mode (sigma1: Prop.sigma) (sigma2: Prop.sigma) : Prop.sigma * Prop.sigma * Prop.sigma = @@ -1570,6 +1647,7 @@ let sigma_partial_join tenv mode (sigma1: Prop.sigma) (sigma2: Prop.sigma) else ( L.d_strln "failed Rename.check" ; raise Sil.JoinFail )) ~finally:CheckJoin.final + let rec sigma_partial_meet' tenv (sigma_acc: Prop.sigma) (sigma1_in: Prop.sigma) (sigma2_in: Prop.sigma) : Prop.sigma = try @@ -1593,39 +1671,44 @@ let rec sigma_partial_meet' tenv (sigma_acc: Prop.sigma) (sigma1_in: Prop.sigma) let hpred_opt1, sigma1 = find_hpred_by_address tenv e1 sigma1_in in let hpred_opt2, sigma2 = find_hpred_by_address tenv e2 sigma2_in in match (hpred_opt1, hpred_opt2) with - | None, None - -> sigma_partial_meet' tenv sigma_acc sigma1 sigma2 - | Some hpred, None - -> let hpred' = hpred_construct_fresh Lhs hpred in + | None, None -> + sigma_partial_meet' tenv sigma_acc sigma1 sigma2 + | Some hpred, None -> + let hpred' = hpred_construct_fresh Lhs hpred in let sigma_acc' = hpred' :: sigma_acc in sigma_partial_meet' tenv sigma_acc' sigma1 sigma2 - | None, Some hpred - -> let hpred' = hpred_construct_fresh Rhs hpred in + | None, Some hpred -> + let hpred' = hpred_construct_fresh Rhs hpred in let sigma_acc' = hpred' :: sigma_acc in sigma_partial_meet' tenv sigma_acc' sigma1 sigma2 - | Some hpred1, Some hpred2 when same_pred hpred1 hpred2 - -> let hpred' = hpred_partial_meet tenv todo_curr hpred1 hpred2 in + | Some hpred1, Some hpred2 when same_pred hpred1 hpred2 -> + let hpred' = hpred_partial_meet tenv todo_curr hpred1 hpred2 in sigma_partial_meet' tenv (hpred' :: sigma_acc) sigma1 sigma2 - | Some _, Some _ - -> L.d_strln "failure reason 65" ; raise Sil.JoinFail + | Some _, Some _ -> + L.d_strln "failure reason 65" ; raise Sil.JoinFail with Todo.Empty -> match (sigma1_in, sigma2_in) with - | [], [] - -> sigma_acc - | _, _ - -> L.d_strln "todo is empty, but the sigmas are not" ; raise Sil.JoinFail + | [], [] -> + sigma_acc + | _, _ -> + L.d_strln "todo is empty, but the sigmas are not" ; + raise Sil.JoinFail + let sigma_partial_meet tenv (sigma1: Prop.sigma) (sigma2: Prop.sigma) : Prop.sigma = sigma_partial_meet' tenv [] sigma1 sigma2 + let widening_top = (* nearly max_int but not so close to overflow *) IntLit.of_int64 Int64.max_value -- IntLit.of_int 1000 + let widening_bottom = (* nearly min_int but not so close to underflow *) IntLit.of_int64 Int64.min_value ++ IntLit.of_int 1000 + (** {2 Join and Meet for Pi} *) let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) (pi1: Prop.pi) (pi2: Prop.pi) : Prop.pi = @@ -1633,12 +1716,13 @@ let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop (* find some array length in the prop, to be used as heuritic for upper bound in widening *) let len_list = ref [] in let do_hpred = function - | Sil.Hpointsto (_, Sil.Earray (Exp.Const Const.Cint n, _, _), _) - -> if IntLit.geq n IntLit.one then len_list := n :: !len_list - | _ - -> () + | Sil.Hpointsto (_, Sil.Earray (Exp.Const Const.Cint n, _, _), _) -> + if IntLit.geq n IntLit.one then len_list := n :: !len_list + | _ -> + () in - List.iter ~f:do_hpred prop.Prop.sigma ; !len_list + List.iter ~f:do_hpred prop.Prop.sigma ; + !len_list in let bounds = let bounds1 = get_array_len ep1 in @@ -1649,8 +1733,8 @@ let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop let widening_atom a = (* widening heuristic for upper bound: take the length of some array, -2 and -1 *) match (Prop.atom_exp_le_const a, bounds) with - | Some (e, n), len :: _ - -> let first_try = IntLit.sub len IntLit.one in + | Some (e, n), len :: _ -> + let first_try = IntLit.sub len IntLit.one in let second_try = IntLit.sub len IntLit.two in let bound = if IntLit.leq n first_try then if IntLit.leq n second_try then second_try else first_try @@ -1658,16 +1742,16 @@ let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop in let a' = Prop.mk_inequality tenv (Exp.BinOp (Binop.Le, e, Exp.int bound)) in Some a' - | Some (e, _), [] - -> let bound = widening_top in + | Some (e, _), [] -> + let bound = widening_top in let a' = Prop.mk_inequality tenv (Exp.BinOp (Binop.Le, e, Exp.int bound)) in Some a' | _ -> match Prop.atom_const_lt_exp a with - | None - -> None - | Some (n, e) - -> let bound = + | None -> + None + | Some (n, e) -> + let bound = if IntLit.leq IntLit.minus_one n then IntLit.minus_one else widening_bottom in let a' = Prop.mk_inequality tenv (Exp.BinOp (Binop.Lt, Exp.int bound, e)) in @@ -1675,23 +1759,26 @@ let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop in let is_stronger_le e n a = match Prop.atom_exp_le_const a with - | None - -> false - | Some (e', n') - -> Exp.equal e e' && IntLit.lt n' n + | None -> + false + | Some (e', n') -> + Exp.equal e e' && IntLit.lt n' n in let is_stronger_lt n e a = match Prop.atom_const_lt_exp a with - | None - -> false - | Some (n', e') - -> Exp.equal e e' && IntLit.lt n n' + | None -> + false + | Some (n', e') -> + Exp.equal e e' && IntLit.lt n n' in let join_atom_check_pre p a = (* check for atoms in pre mode: fail if the negation is implied by the other side *) let not_a = Prover.atom_negate tenv a in if Prover.check_atom tenv p not_a then ( - L.d_str "join_atom_check failed on " ; Sil.d_atom a ; L.d_ln () ; raise Sil.JoinFail ) + L.d_str "join_atom_check failed on " ; + Sil.d_atom a ; + L.d_ln () ; + raise Sil.JoinFail ) in let join_atom_check_attribute p a = (* check for attribute: fail if the attribute is not in the other side *) @@ -1704,35 +1791,35 @@ let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop let join_atom side p_op pi_op a = (* try to find the atom corresponding to a on the other side, and check if it is implied *) match Rename.get_other_atoms tenv side a with - | None - -> None - | Some (a_res, a_op) - -> if JoinState.equal_mode mode JoinState.Pre then join_atom_check_pre p_op a_op ; + | None -> + None + | Some (a_res, a_op) -> + if JoinState.equal_mode mode JoinState.Pre then join_atom_check_pre p_op a_op ; if Attribute.is_pred a then join_atom_check_attribute p_op a_op ; if not (Prover.check_atom tenv p_op a_op) then None else match Prop.atom_exp_le_const a_op with | None -> ( match Prop.atom_const_lt_exp a_op with - | None - -> Some a_res - | Some (n, e) - -> if List.exists ~f:(is_stronger_lt n e) pi_op then widening_atom a_res + | None -> + Some a_res + | Some (n, e) -> + if List.exists ~f:(is_stronger_lt n e) pi_op then widening_atom a_res else Some a_res ) - | Some (e, n) - -> if List.exists ~f:(is_stronger_le e n) pi_op then widening_atom a_res else Some a_res + | Some (e, n) -> + if List.exists ~f:(is_stronger_le e n) pi_op then widening_atom a_res else Some a_res in let handle_atom_with_widening len p_op pi_op atom_list a = (* find a join for the atom, if it fails apply widening heuristing and try again *) match join_atom len p_op pi_op a with | None -> ( match widening_atom a with - | None - -> atom_list + | None -> + atom_list | Some a' -> match join_atom len p_op pi_op a' with None -> atom_list | Some a' -> a' :: atom_list ) - | Some a' - -> a' :: atom_list + | Some a' -> + a' :: atom_list in if Config.trace_join then ( L.d_str "pi1: " ; Prop.d_pi pi1 ; L.d_ln () ; L.d_str "pi2: " ; Prop.d_pi pi2 ; L.d_ln () ) ; @@ -1751,6 +1838,7 @@ let pi_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop L.d_str "atom_list_combined: " ; Prop.d_pi atom_list_combined ; L.d_ln () ) ; atom_list_combined + let pi_partial_meet tenv (p: Prop.normal Prop.t) (ep1: 'a Prop.t) (ep2: 'b Prop.t) : Prop.normal Prop.t = let sub1 = Rename.to_subst_emb Lhs in @@ -1770,9 +1858,11 @@ let pi_partial_meet tenv (p: Prop.normal Prop.t) (ep1: 'a Prop.t) (ep2: 'b Prop. let p_pi1 = List.fold ~f:f1 ~init:p pi1 in let p_pi2 = List.fold ~f:f2 ~init:p_pi1 pi2 in if Prover.check_inconsistency_base tenv p_pi2 then ( - L.d_strln "check_inconsistency_base failed" ; raise Sil.JoinFail ) + L.d_strln "check_inconsistency_base failed" ; + raise Sil.JoinFail ) else p_pi2 + (** {2 Join and Meet for Prop} *) let eprop_partial_meet tenv (ep1: 'a Prop.t) (ep2: 'b Prop.t) : 'c Prop.t = @@ -1802,6 +1892,7 @@ let eprop_partial_meet tenv (ep1: 'a Prop.t) (ep2: 'b Prop.t) : 'c Prop.t = let res = Prop.prop_rename_primed_footprint_vars tenv p'' in res + let prop_partial_meet tenv p1 p2 = Rename.init () ; FreshVarExp.init () ; @@ -1811,6 +1902,7 @@ let prop_partial_meet tenv p1 p2 = Rename.final () ; FreshVarExp.final () ; Todo.final () ) with Sil.JoinFail -> None + let eprop_partial_join' tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) : Prop.normal Prop.t = SymOp.pay () ; @@ -1822,12 +1914,12 @@ let eprop_partial_join' tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed let simple_check = Int.equal (List.length es1) (List.length es2) in let rec expensive_check es1' es2' = match (es1', es2') with - | [], [] - -> true - | [], _ :: _ | _ :: _, [] - -> false - | e1 :: es1'', e2 :: es2'' - -> Exp.equal e1 e2 && expensive_check es1'' es2'' + | [], [] -> + true + | [], _ :: _ | _ :: _, [] -> + false + | e1 :: es1'', e2 :: es2'' -> + Exp.equal e1 e2 && expensive_check es1'' es2'' in let sub_common, eqs_from_sub1, eqs_from_sub2 = let sub1 = ep1.Prop.sub in @@ -1854,8 +1946,8 @@ let eprop_partial_join' tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed let todos = List.map ~f:(fun x -> (x, x, x)) es1 in List.iter ~f:Todo.push todos ; match sigma_partial_join tenv mode sigma1 sigma2 with - | sigma_new, [], [] - -> L.d_strln "sigma_partial_join succeeded" ; + | sigma_new, [], [] -> + L.d_strln "sigma_partial_join succeeded" ; let ep_sub = let ep = Prop.set ep1 ~pi:[] in Prop.set ep ~sub:sub_common @@ -1871,8 +1963,9 @@ let eprop_partial_join' tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed List.fold ~f:(Prop.prop_atom_and tenv) ~init:p_sub_sigma pi_all in p_sub_sigma_pi - | _ - -> L.d_strln "leftovers not empty" ; raise Sil.JoinFail + | _ -> + L.d_strln "leftovers not empty" ; raise Sil.JoinFail + let footprint_partial_join' tenv (p1: Prop.normal Prop.t) (p2: Prop.normal Prop.t) : Prop.normal Prop.t * Prop.normal Prop.t = @@ -1896,6 +1989,7 @@ let footprint_partial_join' tenv (p1: Prop.normal Prop.t) (p2: Prop.normal Prop. let ep2' = Prop.set p2 ~pi_fp ~sigma_fp in (Prop.normalize tenv ep1', Prop.normalize tenv ep2') + let prop_partial_join pname tenv mode p1 p2 = let res_by_implication_only = if !Config.footprint then None @@ -1905,7 +1999,7 @@ let prop_partial_join pname tenv mode p1 p2 = in match res_by_implication_only with | None - -> ( + -> ( if !Config.footprint then JoinState.set_footprint true ; Rename.init () ; FreshVarExp.init () ; @@ -1920,8 +2014,9 @@ let prop_partial_join pname tenv mode p1 p2 = if !Config.footprint then JoinState.set_footprint false ; Some res) ~finally:(fun () -> Rename.final () ; FreshVarExp.final () ; Todo.final () ) with Sil.JoinFail -> None ) - | Some _ - -> res_by_implication_only + | Some _ -> + res_by_implication_only + let eprop_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed Prop.t) : Prop.normal Prop.t = @@ -1931,14 +2026,15 @@ let eprop_partial_join tenv mode (ep1: Prop.exposed Prop.t) (ep2: Prop.exposed P SymOp.try_finally ~f:(fun () -> eprop_partial_join' tenv mode ep1 ep2) ~finally:(fun () -> Rename.final () ; FreshVarExp.final () ; Todo.final () ) + (** {2 Join and Meet for Propset} *) let list_reduce name dd f list = let rec element_list_reduce acc (x, p1) = function - | [] - -> ((x, p1), List.rev acc) - | (y, p2) :: ys - -> L.d_strln ("COMBINE[" ^ name ^ "] ....") ; + | [] -> + ((x, p1), List.rev acc) + | (y, p2) :: ys -> + L.d_strln ("COMBINE[" ^ name ^ "] ....") ; L.d_str "ENTRY1: " ; L.d_ln () ; dd x ; @@ -1949,25 +2045,26 @@ let list_reduce name dd f list = L.d_ln () ; L.d_ln () ; match f x y with - | None - -> L.d_strln_color Red (".... COMBINE[" ^ name ^ "] FAILED ...") ; + | None -> + L.d_strln_color Red (".... COMBINE[" ^ name ^ "] FAILED ...") ; element_list_reduce ((y, p2) :: acc) (x, p1) ys - | Some x' - -> L.d_strln_color Green (".... COMBINE[" ^ name ^ "] SUCCEEDED ....") ; + | Some x' -> + L.d_strln_color Green (".... COMBINE[" ^ name ^ "] SUCCEEDED ....") ; L.d_strln "RESULT:" ; dd x' ; L.d_ln () ; element_list_reduce acc (x', p1) ys in let rec reduce acc = function - | [] - -> List.rev acc - | x :: xs - -> let x', xs' = element_list_reduce [] x xs in + | [] -> + List.rev acc + | x :: xs -> + let x', xs' = element_list_reduce [] x xs in reduce (x' :: acc) xs' in reduce [] list + let pathset_collapse_impl pname tenv pset = let f x y = if Prover.check_implication pname tenv x (Prop.expose y) then Some y @@ -1978,6 +2075,7 @@ let pathset_collapse_impl pname tenv pset = let plist' = list_reduce "JOIN_IMPL" Prop.d_prop f plist in Paths.PathSet.from_renamed_list plist' + let jprop_partial_join tenv mode jp1 jp2 = let p1, p2 = (Prop.expose (Specs.Jprop.to_prop jp1), Prop.expose (Specs.Jprop.to_prop jp2)) in try @@ -1986,38 +2084,44 @@ let jprop_partial_join tenv mode jp1 jp2 = Some (Specs.Jprop.Joined (0, p_renamed, jp1, jp2)) with Sil.JoinFail -> None + let jplist_collapse tenv mode jplist = let f = jprop_partial_join tenv mode in list_reduce "JOIN" Specs.Jprop.d_shallow f jplist + (** Add identifiers to a list of jprops *) let jprop_list_add_ids jplist = let seq_number = ref 0 in let rec do_jprop = function - | Specs.Jprop.Prop (_, p) - -> incr seq_number ; Specs.Jprop.Prop (!seq_number, p) - | Specs.Jprop.Joined (_, p, jp1, jp2) - -> let jp1' = do_jprop jp1 in + | Specs.Jprop.Prop (_, p) -> + incr seq_number ; Specs.Jprop.Prop (!seq_number, p) + | Specs.Jprop.Joined (_, p, jp1, jp2) -> + let jp1' = do_jprop jp1 in let jp2' = do_jprop jp2 in incr seq_number ; Specs.Jprop.Joined (!seq_number, p, jp1', jp2') in List.map ~f:(fun (p, path) -> (do_jprop p, path)) jplist + let proplist_collapse tenv mode plist = let jplist = List.map ~f:(fun (p, path) -> (Specs.Jprop.Prop (0, p), path)) plist in let jplist_joined = jplist_collapse tenv mode (jplist_collapse tenv mode jplist) in jprop_list_add_ids jplist_joined + let proplist_collapse_pre tenv plist = let plist' = List.map ~f:(fun p -> (p, ())) plist in List.map ~f:fst (proplist_collapse tenv JoinState.Pre plist') + let pathset_collapse tenv pset = let plist = Paths.PathSet.elements pset in let plist' = proplist_collapse tenv JoinState.Post plist in Paths.PathSet.from_renamed_list (List.map ~f:(fun (p, path) -> (Specs.Jprop.to_prop p, path)) plist') + let pathset_join pname tenv (pset1: Paths.PathSet.t) (pset2: Paths.PathSet.t) : Paths.PathSet.t * Paths.PathSet.t = let mode = JoinState.Post in @@ -2027,11 +2131,11 @@ let pathset_join pname tenv (pset1: Paths.PathSet.t) (pset2: Paths.PathSet.t) in let ppalist1 = pset_to_plist pset1 in let ppalist2 = pset_to_plist pset2 in - let rec join_proppath_plist ppalist2_acc (p2, pa2 as ppa2) = function - | [] - -> (ppa2, List.rev ppalist2_acc) - | (p2', pa2' as ppa2') :: ppalist2_rest - -> L.d_strln ".... JOIN ...." ; + let rec join_proppath_plist ppalist2_acc ((p2, pa2) as ppa2) = function + | [] -> + (ppa2, List.rev ppalist2_acc) + | ((p2', pa2') as ppa2') :: ppalist2_rest -> + L.d_strln ".... JOIN ...." ; L.d_strln "JOIN SYM HEAP1: " ; Prop.d_prop p2 ; L.d_ln () ; @@ -2040,12 +2144,12 @@ let pathset_join pname tenv (pset1: Paths.PathSet.t) (pset2: Paths.PathSet.t) L.d_ln () ; L.d_ln () ; match prop_partial_join pname tenv mode p2 p2' with - | None - -> L.d_strln_color Red ".... JOIN FAILED ...." ; + | None -> + L.d_strln_color Red ".... JOIN FAILED ...." ; L.d_ln () ; join_proppath_plist (ppa2' :: ppalist2_acc) ppa2 ppalist2_rest - | Some p2'' - -> L.d_strln_color Green ".... JOIN SUCCEEDED ...." ; + | Some p2'' -> + L.d_strln_color Green ".... JOIN SUCCEEDED ...." ; L.d_strln "RESULT SYM HEAP:" ; Prop.d_prop p2'' ; L.d_ln () ; @@ -2053,10 +2157,10 @@ let pathset_join pname tenv (pset1: Paths.PathSet.t) (pset2: Paths.PathSet.t) join_proppath_plist ppalist2_acc (p2'', Paths.Path.join pa2 pa2') ppalist2_rest in let rec join ppalist1_cur ppalist2_acc = function - | [] - -> (ppalist1_cur, ppalist2_acc) - | ppa2 :: ppalist2_rest - -> let ppa2', ppalist2_acc' = join_proppath_plist [] ppa2 ppalist2_acc in + | [] -> + (ppalist1_cur, ppalist2_acc) + | ppa2 :: ppalist2_rest -> + let ppa2', ppalist2_acc' = join_proppath_plist [] ppa2 ppalist2_acc in let ppa2'', ppalist2_rest' = join_proppath_plist [] ppa2' ppalist2_rest in let ppa2_new, ppalist1_cur' = join_proppath_plist [] ppa2'' ppalist1_cur in join ppalist1_cur' (ppa2_new :: ppalist2_acc') ppalist2_rest' @@ -2069,6 +2173,7 @@ let pathset_join pname tenv (pset1: Paths.PathSet.t) (pset2: Paths.PathSet.t) in res + (** The meet operator does two things: 1) makes the result logically stronger (just like additive conjunction) @@ -2092,10 +2197,12 @@ let proplist_meet_generate tenv plist = Prop.d_prop pcombined ; L.d_ln () ; match prop_partial_meet tenv p pcombined with - | None - -> L.d_strln_color Red ".... MEET FAILED ...." ; L.d_ln () ; (porig, pcombined) - | Some pcombined' - -> L.d_strln_color Green ".... MEET SUCCEEDED ...." ; + | None -> + L.d_strln_color Red ".... MEET FAILED ...." ; + L.d_ln () ; + (porig, pcombined) + | Some pcombined' -> + L.d_strln_color Green ".... MEET SUCCEEDED ...." ; L.d_strln "RESULT SYM HEAP:" ; Prop.d_prop pcombined' ; L.d_ln () ; @@ -2103,10 +2210,10 @@ let proplist_meet_generate tenv plist = (porig, pcombined') in let rec proplist_meet = function - | [] - -> () - | (porig, pcombined) :: pplist - -> (* use porig instead of pcombined because it might be combinable with more othe props *) + | [] -> + () + | (porig, pcombined) :: pplist -> + (* use porig instead of pcombined because it might be combinable with more othe props *) (* e.g. porig might contain a global var to add to the ture branch of a conditional *) (* but pcombined might have been combined with the false branch already *) let pplist' = List.map ~f:(combine porig) pplist in @@ -2116,6 +2223,7 @@ let proplist_meet_generate tenv plist = proplist_meet (List.map ~f:(fun p -> (p, p)) plist) ; !props_done + let propset_meet_generate_pre tenv pset = let plist = Propset.to_proplist pset in if Int.equal Config.meet_level 0 then plist @@ -2125,3 +2233,4 @@ let propset_meet_generate_pre tenv pset = let plist_old = Propset.to_proplist pset in let plist_new = Propset.to_proplist pset_new in plist_new @ plist_old + diff --git a/infer/src/backend/dotty.ml b/infer/src/backend/dotty.ml index 9e9c662e1..cfc981858 100644 --- a/infer/src/backend/dotty.ml +++ b/infer/src/backend/dotty.ml @@ -130,73 +130,81 @@ let strip_special_chars b = let s7 = replace s6 '-' 'M' in s7 + let rec strexp_to_string pe coo f se = match se with - | Sil.Eexp (Exp.Lvar pvar, _) - -> F.fprintf f "%a" (Pvar.pp pe) pvar - | Sil.Eexp (Exp.Var id, _) - -> if !print_full_prop then F.fprintf f "%a" (Ident.pp pe) id else () - | Sil.Eexp (e, _) - -> if !print_full_prop then F.fprintf f "%a" (Sil.pp_exp_printenv pe) e else F.fprintf f "_" - | Sil.Estruct (ls, _) - -> F.fprintf f " STRUCT | { %a } " (struct_to_dotty_str pe coo) ls - | Sil.Earray (e, idx, _) - -> F.fprintf f " ARRAY[%a] | { %a } " (Sil.pp_exp_printenv pe) e (get_contents pe coo) idx + | Sil.Eexp (Exp.Lvar pvar, _) -> + F.fprintf f "%a" (Pvar.pp pe) pvar + | Sil.Eexp (Exp.Var id, _) -> + if !print_full_prop then F.fprintf f "%a" (Ident.pp pe) id else () + | Sil.Eexp (e, _) -> + if !print_full_prop then F.fprintf f "%a" (Sil.pp_exp_printenv pe) e else F.fprintf f "_" + | Sil.Estruct (ls, _) -> + F.fprintf f " STRUCT | { %a } " (struct_to_dotty_str pe coo) ls + | Sil.Earray (e, idx, _) -> + F.fprintf f " ARRAY[%a] | { %a } " (Sil.pp_exp_printenv pe) e (get_contents pe coo) idx + and struct_to_dotty_str pe coo f ls : unit = match ls with - | [] - -> () - | [(fn, se)] - -> F.fprintf f "{ <%s%iL%i> %s: %a } " (Typ.Fieldname.to_string fn) coo.id coo.lambda + | [] -> + () + | [(fn, se)] -> + F.fprintf f "{ <%s%iL%i> %s: %a } " (Typ.Fieldname.to_string fn) coo.id coo.lambda (Typ.Fieldname.to_string fn) (strexp_to_string pe coo) se - | (fn, se) :: ls' - -> F.fprintf f " { <%s%iL%i> %s: %a } | %a" (Typ.Fieldname.to_string fn) coo.id coo.lambda + | (fn, se) :: ls' -> + F.fprintf f " { <%s%iL%i> %s: %a } | %a" (Typ.Fieldname.to_string fn) coo.id coo.lambda (Typ.Fieldname.to_string fn) (strexp_to_string pe coo) se (struct_to_dotty_str pe coo) ls' + and get_contents_sexp pe coo f se = match se with - | Sil.Eexp (e', _) - -> F.fprintf f "%a" (Sil.pp_exp_printenv pe) e' - | Sil.Estruct (se', _) - -> F.fprintf f "| { %a }" (struct_to_dotty_str pe coo) se' - | Sil.Earray (e', [], _) - -> F.fprintf f "(ARRAY Size: %a) | { }" (Sil.pp_exp_printenv pe) e' - | Sil.Earray (e', (idx, a) :: linner, _) - -> F.fprintf f "(ARRAY Size: %a) | { %a: %a | %a }" (Sil.pp_exp_printenv pe) e' + | Sil.Eexp (e', _) -> + F.fprintf f "%a" (Sil.pp_exp_printenv pe) e' + | Sil.Estruct (se', _) -> + F.fprintf f "| { %a }" (struct_to_dotty_str pe coo) se' + | Sil.Earray (e', [], _) -> + F.fprintf f "(ARRAY Size: %a) | { }" (Sil.pp_exp_printenv pe) e' + | Sil.Earray (e', (idx, a) :: linner, _) -> + F.fprintf f "(ARRAY Size: %a) | { %a: %a | %a }" (Sil.pp_exp_printenv pe) e' (Sil.pp_exp_printenv pe) idx (strexp_to_string pe coo) a (get_contents pe coo) linner + and get_contents_single pe coo f (e, se) = let e_no_special_char = strip_special_chars (Exp.to_string e) in F.fprintf f "{ <%s> %a : %a }" e_no_special_char (Sil.pp_exp_printenv pe) e (get_contents_sexp pe coo) se + and get_contents pe coo f = function - | [] - -> () - | [idx_se] - -> F.fprintf f "%a" (get_contents_single pe coo) idx_se - | idx_se :: l - -> F.fprintf f "%a | %a" (get_contents_single pe coo) idx_se (get_contents pe coo) l + | [] -> + () + | [idx_se] -> + F.fprintf f "%a" (get_contents_single pe coo) idx_se + | idx_se :: l -> + F.fprintf f "%a | %a" (get_contents_single pe coo) idx_se (get_contents pe coo) l + (* true if node is the sorce node of the expression e*) let is_source_node_of_exp e node = match node with Dotpointsto (_, e', _) -> Exp.equal e e' | _ -> false + (* given a node returns its coordinates and the expression. Return -1 in case the expression doesn't*) (* make sense for that case *) let get_coordinate_and_exp dotnode = match dotnode with - | Dotnil coo - -> (coo, Exp.minus_one) - | Dotarray (coo, _, _, _, _, _) - -> (coo, Exp.minus_one) + | Dotnil coo -> + (coo, Exp.minus_one) + | Dotarray (coo, _, _, _, _, _) -> + (coo, Exp.minus_one) | Dotpointsto (coo, b, _) | Dotlseg (coo, b, _, _, _, _) | Dotdllseg (coo, b, _, _, _, _, _, _) | Dotstruct (coo, b, _, _, _) - | Dotdangling (coo, b, _) - -> (coo, b) + | Dotdangling (coo, b, _) -> + (coo, b) + (* true if a node is of a Dotstruct *) let is_not_struct node = match node with Dotstruct _ -> false | _ -> true @@ -206,27 +214,30 @@ let get_coordinate_id node = let coo = fst (get_coordinate_and_exp node) in coo.id + let rec look_up_for_back_pointer e dotnodes lambda = match dotnodes with - | [] - -> [] - | (Dotdllseg (coo, _, _, _, e4, _, _, _)) :: dotnodes' - -> if Exp.equal e e4 && Int.equal lambda coo.lambda then [coo.id + 1] + | [] -> + [] + | (Dotdllseg (coo, _, _, _, e4, _, _, _)) :: dotnodes' -> + if Exp.equal e e4 && Int.equal lambda coo.lambda then [coo.id + 1] else look_up_for_back_pointer e dotnodes' lambda - | _ :: dotnodes' - -> look_up_for_back_pointer e dotnodes' lambda + | _ :: dotnodes' -> + look_up_for_back_pointer e dotnodes' lambda + (* get the nodes corresponding to an expression and a lambda*) let rec select_nodes_exp_lambda dotnodes e lambda = match dotnodes with - | [] - -> [] - | node :: l' - -> let coo, e' = get_coordinate_and_exp node in - if Exp.equal e e' && Int.equal lambda coo.lambda then node - :: select_nodes_exp_lambda l' e lambda + | [] -> + [] + | node :: l' -> + let coo, e' = get_coordinate_and_exp node in + if Exp.equal e e' && Int.equal lambda coo.lambda then + node :: select_nodes_exp_lambda l' e lambda else select_nodes_exp_lambda l' e lambda + (* look-up the coordinate id in the list of dotnodes those nodes which correspond to expression e*) (* this is written in this strange way for legacy reason. It should be changed a bit*) let look_up dotnodes e lambda = @@ -234,22 +245,24 @@ let look_up dotnodes e lambda = let r' = List.map ~f:get_coordinate_id r in r' @ look_up_for_back_pointer e dotnodes lambda + let reset_proposition_counter () = proposition_counter := 0 let reset_dotty_spec_counter () = spec_counter := 0 let color_to_str (c: Pp.color) = match c with - | Black - -> "black" - | Blue - -> "blue" - | Green - -> "green" - | Orange - -> "orange" - | Red - -> "red" + | Black -> + "black" + | Blue -> + "blue" + | Green -> + "green" + | Orange -> + "orange" + | Red -> + "red" + let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list) = let exp_color hpred (exp: Exp.t) = @@ -261,58 +274,58 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list incr dotty_state_count ; let coo = mk_coordinate n lambda in match hpred with - | Sil.Hpointsto (_, Sil.Eexp (e, _), _) when not (Exp.equal e Exp.zero) && !print_full_prop - -> let e_color_str = color_to_str (exp_color hpred e) in + | Sil.Hpointsto (_, Sil.Eexp (e, _), _) when not (Exp.equal e Exp.zero) && !print_full_prop -> + let e_color_str = color_to_str (exp_color hpred e) in [Dotdangling (coo, e, e_color_str)] - | Sil.Hlseg (_, _, _, e2, _) when not (Exp.equal e2 Exp.zero) - -> let e2_color_str = color_to_str (exp_color hpred e2) in + | Sil.Hlseg (_, _, _, e2, _) when not (Exp.equal e2 Exp.zero) -> + let e2_color_str = color_to_str (exp_color hpred e2) in [Dotdangling (coo, e2, e2_color_str)] - | Sil.Hdllseg (_, _, _, e2, e3, _, _) - -> let e2_color_str = color_to_str (exp_color hpred e2) in + | Sil.Hdllseg (_, _, _, e2, e3, _, _) -> + let e2_color_str = color_to_str (exp_color hpred e2) in let e3_color_str = color_to_str (exp_color hpred e3) in let ll = if not (Exp.equal e2 Exp.zero) then [Dotdangling (coo, e2, e2_color_str)] else [] in if not (Exp.equal e3 Exp.zero) then Dotdangling (coo, e3, e3_color_str) :: ll else ll - | Sil.Hpointsto (_, _, _) | _ - -> [] + | Sil.Hpointsto (_, _, _) | _ -> + [] (* arrays and struct do not give danglings*) in let is_allocated d = match d with - | Dotdangling (_, e, _) - -> List.exists + | Dotdangling (_, e, _) -> + List.exists ~f:(fun a -> match a with | Dotpointsto (_, e', _) | Dotarray (_, _, e', _, _, _) | Dotlseg (_, e', _, _, _, _) - | Dotdllseg (_, e', _, _, _, _, _, _) - -> Exp.equal e e' - | _ - -> false) + | Dotdllseg (_, e', _, _, _, _, _, _) -> + Exp.equal e e' + | _ -> + false) allocated_nodes - | _ - -> false + | _ -> + false (*this should never happen since d must be a dangling node *) in let rec filter_duplicate l seen_exp = match l with - | [] - -> [] - | (Dotdangling (coo, e, color)) :: l' - -> if List.exists ~f:(Exp.equal e) seen_exp then filter_duplicate l' seen_exp + | [] -> + [] + | (Dotdangling (coo, e, color)) :: l' -> + if List.exists ~f:(Exp.equal e) seen_exp then filter_duplicate l' seen_exp else Dotdangling (coo, e, color) :: filter_duplicate l' (e :: seen_exp) - | box :: l' - -> box :: filter_duplicate l' seen_exp + | box :: l' -> + box :: filter_duplicate l' seen_exp (* this case cannot happen*) in let rec subtract_allocated candidate_dangling = match candidate_dangling with - | [] - -> [] - | d :: candidates - -> if is_allocated d then subtract_allocated candidates + | [] -> + [] + | d :: candidates -> + if is_allocated d then subtract_allocated candidates else d :: subtract_allocated candidates in let candidate_dangling = List.concat_map ~f:get_rhs_predicate sigma_lambda in @@ -320,61 +333,64 @@ let make_dangling_boxes pe allocated_nodes (sigma_lambda: (Sil.hpred * int) list let dangling = subtract_allocated candidate_dangling in dangling_dotboxes := dangling + let rec dotty_mk_node pe sigma = let n = !dotty_state_count in incr dotty_state_count ; let do_hpred_lambda exp_color = function | ( Sil.Hpointsto (e, Sil.Earray (e', l, _), Exp.Sizeof {typ= {Typ.desc= Tarray (t, _, _)}}) - , lambda ) - -> incr dotty_state_count ; + , lambda ) -> + incr dotty_state_count ; (* increment once more n+1 is the box for the array *) let e_color_str = color_to_str (exp_color e) in let e_color_str' = color_to_str (exp_color e') in [ Dotpointsto (mk_coordinate n lambda, e, e_color_str) ; Dotarray (mk_coordinate (n + 1) lambda, e, e', l, t, e_color_str') ] - | Sil.Hpointsto (e, Sil.Estruct (l, _), te), lambda - -> incr dotty_state_count ; + | Sil.Hpointsto (e, Sil.Estruct (l, _), te), lambda -> + incr dotty_state_count ; (* increment once more n+1 is the box for the struct *) let e_color_str = color_to_str (exp_color e) in (* [Dotpointsto((mk_coordinate n lambda), e, l, true, e_color_str)] *) [ Dotpointsto (mk_coordinate n lambda, e, e_color_str) ; Dotstruct (mk_coordinate (n + 1) lambda, e, l, e_color_str, te) ] - | Sil.Hpointsto (e, _, _), lambda - -> let e_color_str = color_to_str (exp_color e) in + | Sil.Hpointsto (e, _, _), lambda -> + let e_color_str = color_to_str (exp_color e) in if List.mem ~equal:Exp.equal !struct_exp_nodes e then [] else [Dotpointsto (mk_coordinate n lambda, e, e_color_str)] - | Sil.Hlseg (k, hpara, e1, e2, _), lambda - -> incr dotty_state_count ; + | Sil.Hlseg (k, hpara, e1, e2, _), lambda -> + incr dotty_state_count ; (* increment once more n+1 is the box for last element of the list *) let eq_color_str = color_to_str (exp_color e1) in [Dotlseg (mk_coordinate n lambda, e1, e2, k, hpara.Sil.body, eq_color_str)] - | Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, _), lambda - -> let e1_color_str = color_to_str (exp_color e1) in + | Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, _), lambda -> + let e1_color_str = color_to_str (exp_color e1) in incr dotty_state_count ; (* increment once more n+1 is the box for e4 *) [ Dotdllseg (mk_coordinate n lambda, e1, e2, e3, e4, k, hpara_dll.Sil.body_dll, e1_color_str) ] in match sigma with - | [] - -> [] - | (hpred, lambda) :: sigma' - -> let exp_color (exp: Exp.t) = + | [] -> + [] + | (hpred, lambda) :: sigma' -> + let exp_color (exp: Exp.t) = if Pp.equal_color (pe.Pp.cmap_norm (Obj.repr hpred)) Pp.Red then Pp.Red else pe.Pp.cmap_norm (Obj.repr exp) in do_hpred_lambda exp_color (hpred, lambda) @ dotty_mk_node pe sigma' + let set_exps_neq_zero pi = let f = function - | Sil.Aneq (e, Exp.Const Const.Cint i) when IntLit.iszero i - -> exps_neq_zero := e :: !exps_neq_zero - | _ - -> () + | Sil.Aneq (e, Exp.Const Const.Cint i) when IntLit.iszero i -> + exps_neq_zero := e :: !exps_neq_zero + | _ -> + () in exps_neq_zero := [] ; List.iter ~f pi + let box_dangling e = let entry_e = List.filter @@ -383,6 +399,7 @@ let box_dangling e = in match entry_e with [] -> None | (Dotdangling (coo, _, _)) :: _ -> Some coo.id | _ -> None + (* NOTE: this cannot be possible since entry_e can be composed only by Dotdangling, see def of entry_e*) (* construct a Dotnil and returns it's id *) let make_nil_node lambda = @@ -391,42 +408,45 @@ let make_nil_node lambda = nil_dotboxes := Dotnil (mk_coordinate n lambda) :: !nil_dotboxes ; n + let compute_fields_struct sigma = fields_structs := [] ; let rec do_strexp se in_struct = match se with - | Sil.Eexp (e, _) - -> if in_struct then fields_structs := e :: !fields_structs else () - | Sil.Estruct (l, _) - -> List.iter ~f:(fun e -> do_strexp e true) (snd (List.unzip l)) - | Sil.Earray (_, l, _) - -> List.iter ~f:(fun e -> do_strexp e false) (snd (List.unzip l)) + | Sil.Eexp (e, _) -> + if in_struct then fields_structs := e :: !fields_structs else () + | Sil.Estruct (l, _) -> + List.iter ~f:(fun e -> do_strexp e true) (snd (List.unzip l)) + | Sil.Earray (_, l, _) -> + List.iter ~f:(fun e -> do_strexp e false) (snd (List.unzip l)) in let rec fs s = match s with - | [] - -> () - | (Sil.Hpointsto (_, se, _)) :: s' - -> do_strexp se false ; fs s' - | _ :: s' - -> fs s' + | [] -> + () + | (Sil.Hpointsto (_, se, _)) :: s' -> + do_strexp se false ; fs s' + | _ :: s' -> + fs s' in fs sigma + let compute_struct_exp_nodes sigma = struct_exp_nodes := [] ; let rec sen s = match s with - | [] - -> () - | (Sil.Hpointsto (e, Sil.Estruct _, _)) :: s' - -> struct_exp_nodes := e :: !struct_exp_nodes ; + | [] -> + () + | (Sil.Hpointsto (e, Sil.Estruct _, _)) :: s' -> + struct_exp_nodes := e :: !struct_exp_nodes ; + sen s' + | _ :: s' -> sen s' - | _ :: s' - -> sen s' in sen sigma + (* returns the expression of a node*) let get_node_exp n = snd (get_coordinate_and_exp n) @@ -435,28 +455,30 @@ let is_nil e prop = Exp.equal e Exp.zero || Prover.check_equal (Tenv.create ()) (* an edge is in cycle *) let in_cycle cycle edge = match cycle with - | Some cycle' - -> let fn, se = edge in + | Some cycle' -> + let fn, se = edge in List.exists ~f:(fun (_, fn', se') -> Typ.Fieldname.equal fn fn' && Sil.equal_strexp se se') cycle' - | _ - -> false + | _ -> + false + let node_in_cycle cycle node = match (cycle, node) with - | Some _, Dotstruct (_, _, l, _, _) - -> (* only struct nodes can be in cycle *) + | Some _, Dotstruct (_, _, l, _, _) -> + (* only struct nodes can be in cycle *) List.exists ~f:(in_cycle cycle) l - | _ - -> false + | _ -> + false + (* compute a list of (kind of link, field name, coo.id target, name_target) *) let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle = let find_target_one_fld (fn, se) = match se with | Sil.Eexp (e, _) - -> ( + -> ( if is_nil e p then let n' = make_nil_node lambda in if !print_full_prop then [(LinkStructToExp, Typ.Fieldname.to_string fn, n', "")] else [] @@ -465,12 +487,12 @@ let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle = match nodes_e with | [] -> ( match box_dangling e with - | None - -> [] - | Some n' - -> [(LinkStructToExp, Typ.Fieldname.to_string fn, n', "")] ) - | [node] | [(Dotpointsto _); node] | [node; (Dotpointsto _)] - -> let n = get_coordinate_id node in + | None -> + [] + | Some n' -> + [(LinkStructToExp, Typ.Fieldname.to_string fn, n', "")] ) + | [node] | [(Dotpointsto _); node] | [node; (Dotpointsto _)] -> + let n = get_coordinate_id node in if List.mem ~equal:Exp.equal !struct_exp_nodes e then let e_no_special_char = strip_special_chars (Exp.to_string e) in let link_kind = @@ -479,29 +501,30 @@ let rec compute_target_struct_fields dotnodes list_fld p f lambda cycle = in [(link_kind, Typ.Fieldname.to_string fn, n, e_no_special_char)] else [(LinkStructToExp, Typ.Fieldname.to_string fn, n, "")] - | _ - -> (* by construction there must be at most 2 nodes for an expression*) + | _ -> + (* by construction there must be at most 2 nodes for an expression*) L.internal_error "@\n Too many nodes! Error! @\n@." ; assert false ) - | Sil.Estruct (_, _) - -> [] (* inner struct are printed by print_struc function *) - | Sil.Earray _ - -> [] + | Sil.Estruct (_, _) -> + [] (* inner struct are printed by print_struc function *) + | Sil.Earray _ -> + [] (* inner arrays are printed by print_array function *) in match list_fld with - | [] - -> [] - | a :: list_fld' - -> let targets_a = find_target_one_fld a in + | [] -> + [] + | a :: list_fld' -> + let targets_a = find_target_one_fld a in targets_a @ compute_target_struct_fields dotnodes list_fld' p f lambda cycle + (* compute a list of (kind of link, field name, coo.id target, name_target) *) let rec compute_target_array_elements dotnodes list_elements p f lambda = let find_target_one_element (idx, se) = match se with | Sil.Eexp (e, _) - -> ( + -> ( if is_nil e p then let n' = make_nil_node lambda in [(LinkArrayToExp, Exp.to_string idx, n', "")] @@ -510,33 +533,34 @@ let rec compute_target_array_elements dotnodes list_elements p f lambda = match nodes_e with | [] -> ( match box_dangling e with - | None - -> [] - | Some n' - -> [(LinkArrayToExp, Exp.to_string idx, n', "")] ) - | [node] | [(Dotpointsto _); node] | [node; (Dotpointsto _)] - -> let n = get_coordinate_id node in + | None -> + [] + | Some n' -> + [(LinkArrayToExp, Exp.to_string idx, n', "")] ) + | [node] | [(Dotpointsto _); node] | [node; (Dotpointsto _)] -> + let n = get_coordinate_id node in if List.mem ~equal:Exp.equal !struct_exp_nodes e then let e_no_special_char = strip_special_chars (Exp.to_string e) in [(LinkArrayToStruct, Exp.to_string idx, n, e_no_special_char)] else [(LinkArrayToExp, Exp.to_string idx, n, "")] - | _ - -> (* by construction there must be at most 2 nodes for an expression*) + | _ -> + (* by construction there must be at most 2 nodes for an expression*) L.internal_error "@\nToo many nodes! Error!@\n@." ; assert false ) - | Sil.Estruct (_, _) - -> [] (* inner struct are printed by print_struc function *) - | Sil.Earray _ - -> [] + | Sil.Estruct (_, _) -> + [] (* inner struct are printed by print_struc function *) + | Sil.Earray _ -> + [] (* inner arrays are printed by print_array function *) in match list_elements with - | [] - -> [] - | a :: list_ele' - -> let targets_a = find_target_one_element a in + | [] -> + [] + | a :: list_ele' -> + let targets_a = find_target_one_element a in targets_a @ compute_target_array_elements dotnodes list_ele' p f lambda + let compute_target_from_eexp dotnodes e p lambda = if is_nil e p then let n' = make_nil_node lambda in @@ -548,8 +572,9 @@ let compute_target_from_eexp dotnodes e p lambda = match trg with | [] -> ( match box_dangling e with None -> [] | Some n -> [(LinkExpToExp, n, "")] ) - | _ - -> List.map ~f:(fun n -> (LinkExpToExp, n, "")) trg + | _ -> + List.map ~f:(fun n -> (LinkExpToExp, n, "")) trg + (* build the set of edges between nodes *) let rec dotty_mk_set_links dotnodes sigma p f cycle = @@ -557,10 +582,10 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle = (* used for both Earray and ENarray*) let src = look_up dotnodes e lambda in match src with - | [] - -> assert false - | n :: nl - -> let target_list = compute_target_array_elements dotnodes lie p f lambda in + | [] -> + assert false + | n :: nl -> + let target_list = compute_target_array_elements dotnodes lie p f lambda in (* below it's n+1 because n is the address, n+1 is the actual array node*) let ff n = List.map @@ -579,18 +604,18 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle = lnk :: links_from_elements @ dotty_mk_set_links dotnodes sigma' p f cycle in match sigma with - | [] - -> [] - | (Sil.Hpointsto (e, Sil.Earray (_, lie, _), _), lambda) :: sigma' - -> make_links_for_arrays e lie lambda sigma' + | [] -> + [] + | (Sil.Hpointsto (e, Sil.Earray (_, lie, _), _), lambda) :: sigma' -> + make_links_for_arrays e lie lambda sigma' | (Sil.Hpointsto (e, Sil.Estruct (lfld, _), _), lambda) :: sigma' - -> ( + -> ( let src = look_up dotnodes e lambda in match src with - | [] - -> assert false - | nl - -> (* L.out "@\n@\n List of nl= "; List.iter ~f:(L.out " %i ") nl; L.out "@.@.@."; *) + | [] -> + assert false + | nl -> + (* L.out "@\n@\n List of nl= "; List.iter ~f:(L.out " %i ") nl; L.out "@.@.@."; *) let target_list = compute_target_struct_fields dotnodes lfld p f lambda cycle in let ff n = List.map @@ -608,7 +633,9 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle = let lnk_from_address_struct = if !print_full_prop then let trg_label = strip_special_chars (Exp.to_string e) in - [ mk_link LinkExpToStruct (mk_coordinate address_struct_id lambda) "" + [ mk_link LinkExpToStruct + (mk_coordinate address_struct_id lambda) + "" (mk_coordinate (address_struct_id + 1) lambda) trg_label ] else [] @@ -616,13 +643,13 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle = lnk_from_address_struct @ links_from_fields @ dotty_mk_set_links dotnodes sigma' p f cycle ) | (Sil.Hpointsto (e, Sil.Eexp (e', _), _), lambda) :: sigma' - -> ( + -> ( let src = look_up dotnodes e lambda in match src with - | [] - -> assert false - | nl - -> if !print_full_prop then + | [] -> + assert false + | nl -> + if !print_full_prop then let target_list = compute_target_from_eexp dotnodes e' p lambda in let ff n = List.map @@ -635,75 +662,77 @@ let rec dotty_mk_set_links dotnodes sigma p f cycle = ll @ dotty_mk_set_links dotnodes sigma' p f cycle else dotty_mk_set_links dotnodes sigma' p f cycle ) | (Sil.Hlseg (_, _, e1, e2, _), lambda) :: sigma' - -> ( + -> ( let src = look_up dotnodes e1 lambda in match src with - | [] - -> assert false - | n :: _ - -> let _, m, lab = List.hd_exn (compute_target_from_eexp dotnodes e2 p lambda) in + | [] -> + assert false + | n :: _ -> + let _, m, lab = List.hd_exn (compute_target_from_eexp dotnodes e2 p lambda) in let lnk = mk_link LinkToSSL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) lab in lnk :: dotty_mk_set_links dotnodes sigma' p f cycle ) - | (Sil.Hdllseg (_, _, e1, e2, e3, _, _), lambda) :: sigma' - -> let src = look_up dotnodes e1 lambda in + | (Sil.Hdllseg (_, _, e1, e2, e3, _, _), lambda) :: sigma' -> + let src = look_up dotnodes e1 lambda in match src with - | [] - -> assert false - | n :: _ - -> (* n is e1's box and n+1 is e4's box *) + | [] -> + assert false + | n :: _ -> + (* n is e1's box and n+1 is e4's box *) let targetF = look_up dotnodes e3 lambda in let target_Flink = match targetF with - | [] - -> [] - | m :: _ - -> [mk_link LinkToDLL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) ""] + | [] -> + [] + | m :: _ -> + [mk_link LinkToDLL (mk_coordinate (n + 1) lambda) "" (mk_coordinate m lambda) ""] in let targetB = look_up dotnodes e2 lambda in let target_Blink = match targetB with - | [] - -> [] - | m :: _ - -> [mk_link LinkToDLL (mk_coordinate n lambda) "" (mk_coordinate m lambda) ""] + | [] -> + [] + | m :: _ -> + [mk_link LinkToDLL (mk_coordinate n lambda) "" (mk_coordinate m lambda) ""] in target_Blink @ target_Flink @ dotty_mk_set_links dotnodes sigma' p f cycle + let print_kind f kind = incr dotty_state_count ; match kind with - | Spec_precondition - -> incr dotty_state_count ; + | Spec_precondition -> + incr dotty_state_count ; current_pre := !dotty_state_count ; F.fprintf f "@\n PRE%iL0 [label=\"PRE %i \", style=filled, color= yellow]@\n" !dotty_state_count !spec_counter ; print_stack_info := true - | Spec_postcondition _ - -> F.fprintf f "@\n POST%iL0 [label=\"POST %i \", style=filled, color= yellow]@\n" + | Spec_postcondition _ -> + F.fprintf f "@\n POST%iL0 [label=\"POST %i \", style=filled, color= yellow]@\n" !dotty_state_count !post_counter ; print_stack_info := true - | Generic_proposition - -> if !print_full_prop then + | Generic_proposition -> + if !print_full_prop then F.fprintf f "@\n HEAP%iL0 [label=\"HEAP %i \", style=filled, color= yellow]@\n" !dotty_state_count !proposition_counter | Lambda_pred (no, lev, array) -> match array with - | false - -> F.fprintf f "%s @\n state%iL%i [label=\"INTERNAL STRUCTURE %i \", %s]@\n" + | false -> + F.fprintf f "%s @\n state%iL%i [label=\"INTERNAL STRUCTURE %i \", %s]@\n" "style=dashed; color=blue" !dotty_state_count !lambda_counter !lambda_counter "style=filled, color= lightblue" ; F.fprintf f "state%iL%i -> state%iL%i [color=\"lightblue \" arrowhead=none] @\n" !dotty_state_count !lambda_counter no lev - | true - -> F.fprintf f "%s @\n state%iL%i [label=\"INTERNAL STRUCTURE %i \", %s]@\n" + | true -> + F.fprintf f "%s @\n state%iL%i [label=\"INTERNAL STRUCTURE %i \", %s]@\n" "style=dashed; color=blue" !dotty_state_count !lambda_counter !lambda_counter "style=filled, color= lightblue" ; (* F.fprintf f "state%iL%i -> struct%iL%i:%s [color=\"lightblue \" arrowhead=none] @\n" !dotty_state_count !lambda_counter no lev lab;*) incr dotty_state_count + (* print a link between two nodes in the graph *) let dotty_pp_link f link = let n1 = link.src.id in @@ -713,33 +742,34 @@ let dotty_pp_link f link = let src_fld = link.src_fld in let trg_fld = link.trg_fld in match (n2, link.kind) with - | 0, _ when !print_full_prop - -> F.fprintf f "state%iL%i -> state%iL%i[label=\"%s DANG\", color= red];@\n" n1 lambda1 n2 + | 0, _ when !print_full_prop -> + F.fprintf f "state%iL%i -> state%iL%i[label=\"%s DANG\", color= red];@\n" n1 lambda1 n2 lambda2 src_fld - | _, LinkToArray when !print_full_prop - -> F.fprintf f "state%iL%i -> struct%iL%i:%s%iL%i[label=\"\"]@\n" n1 lambda1 n2 lambda2 trg_fld + | _, LinkToArray when !print_full_prop -> + F.fprintf f "state%iL%i -> struct%iL%i:%s%iL%i[label=\"\"]@\n" n1 lambda1 n2 lambda2 trg_fld n2 lambda2 - | _, LinkExpToStruct when !print_full_prop - -> F.fprintf f "state%iL%i -> struct%iL%i:%s%iL%i[label=\"\"]@\n" n1 lambda1 n2 lambda2 trg_fld + | _, LinkExpToStruct when !print_full_prop -> + F.fprintf f "state%iL%i -> struct%iL%i:%s%iL%i[label=\"\"]@\n" n1 lambda1 n2 lambda2 trg_fld n2 lambda2 - | _, LinkStructToExp when !print_full_prop - -> F.fprintf f "struct%iL%i:%s%iL%i -> state%iL%i[label=\"\"]@\n" n1 lambda1 src_fld n1 lambda1 + | _, LinkStructToExp when !print_full_prop -> + F.fprintf f "struct%iL%i:%s%iL%i -> state%iL%i[label=\"\"]@\n" n1 lambda1 src_fld n1 lambda1 n2 lambda2 - | _, LinkRetainCycle - -> F.fprintf f "struct%iL%i:%s%iL%i -> struct%iL%i:%s%iL%i[label=\"\", color= red]@\n" n1 + | _, LinkRetainCycle -> + F.fprintf f "struct%iL%i:%s%iL%i -> struct%iL%i:%s%iL%i[label=\"\", color= red]@\n" n1 lambda1 src_fld n1 lambda1 n2 lambda2 trg_fld n2 lambda2 - | _, LinkStructToStruct when !print_full_prop - -> F.fprintf f "struct%iL%i:%s%iL%i -> struct%iL%i:%s%iL%i[label=\"\"]@\n" n1 lambda1 src_fld n1 + | _, LinkStructToStruct when !print_full_prop -> + F.fprintf f "struct%iL%i:%s%iL%i -> struct%iL%i:%s%iL%i[label=\"\"]@\n" n1 lambda1 src_fld n1 lambda1 n2 lambda2 trg_fld n2 lambda2 - | _, LinkArrayToExp when !print_full_prop - -> F.fprintf f "struct%iL%i:%s -> state%iL%i[label=\"\"]@\n" n1 lambda1 src_fld n2 lambda2 - | _, LinkArrayToStruct when !print_full_prop - -> F.fprintf f "struct%iL%i:%s -> struct%iL%i[label=\"\"]@\n" n1 lambda1 src_fld n2 lambda2 - | _, _ - -> if !print_full_prop then + | _, LinkArrayToExp when !print_full_prop -> + F.fprintf f "struct%iL%i:%s -> state%iL%i[label=\"\"]@\n" n1 lambda1 src_fld n2 lambda2 + | _, LinkArrayToStruct when !print_full_prop -> + F.fprintf f "struct%iL%i:%s -> struct%iL%i[label=\"\"]@\n" n1 lambda1 src_fld n2 lambda2 + | _, _ -> + if !print_full_prop then F.fprintf f "state%iL%i -> state%iL%i[label=\"%s\"];@\n" n1 lambda1 n2 lambda2 src_fld else () + (* given the list of nodes and links get rid of spec nodes that are not pointed to by anybody*) let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) = let tmp_nodes = ref nodes in @@ -755,10 +785,10 @@ let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) = in let rec boxes_pointed_by n lns = match lns with - | [] - -> [] - | l :: ln' - -> let n_id = get_coordinate_id n in + | [] -> + [] + | l :: ln' -> + let n_id = get_coordinate_id n in if Int.equal l.src.id n_id && String.equal l.src_fld "" then (*L.out "@\n Found link (%i,%i)" l.src.id l.trg.id;*) l :: boxes_pointed_by n ln' @@ -766,50 +796,52 @@ let filter_useless_spec_dollar_box (nodes: dotty_node list) (links: link list) = in let rec boxes_pointing_at n lns = match lns with - | [] - -> [] - | l :: ln' - -> let n_id = get_coordinate_id n in + | [] -> + [] + | l :: ln' -> + let n_id = get_coordinate_id n in if Int.equal l.trg.id n_id && String.equal l.trg_fld "" then (*L.out "@\n Found link (%i,%i)" l.src.id l.trg.id;*) l :: boxes_pointing_at n ln' else boxes_pointing_at n ln' in let is_spec_variable = function - | Exp.Var id - -> Ident.is_normal id && Ident.equal_name (Ident.get_name id) Ident.name_spec - | _ - -> false + | Exp.Var id -> + Ident.is_normal id && Ident.equal_name (Ident.get_name id) Ident.name_spec + | _ -> + false in let handle_one_node node = match node with - | Dotpointsto _ - -> let e = get_node_exp node in + | Dotpointsto _ -> + let e = get_node_exp node in if is_spec_variable e then let links_from_node = boxes_pointed_by node links in let links_to_node = boxes_pointing_at node links in if List.is_empty links_to_node then ( tmp_links := remove_links_from links_from_node ; tmp_nodes := remove_node node !tmp_nodes ) - | _ - -> () + | _ -> + () in - List.iter ~f:handle_one_node nodes ; (!tmp_nodes, !tmp_links) + List.iter ~f:handle_one_node nodes ; + (!tmp_nodes, !tmp_links) + (* print a struct node *) let rec print_struct f pe e te l coo c = let print_type = match te with | Exp.Sizeof {typ} - -> ( + -> ( let str_t = Typ.to_string typ in match Str.split_delim (Str.regexp_string Config.anonymous_block_prefix) str_t with - | [_; _] - -> "BLOCK object" - | _ - -> str_t ) - | _ - -> Exp.to_string te + | [_; _] -> + "BLOCK object" + | _ -> + str_t ) + | _ -> + Exp.to_string te in let n = coo.id in let lambda = coo.lambda in @@ -827,6 +859,7 @@ let rec print_struct f pe e te l coo c = c ; F.fprintf f "}@\n" + and print_array f pe e1 e2 l coo c = let n = coo.id in let lambda = coo.lambda in @@ -838,18 +871,19 @@ and print_array f pe e1 e2 l coo c = (get_contents pe coo) l c ; F.fprintf f "}@\n" + and print_sll f pe nesting k e1 coo = let n = coo.id in let lambda = coo.lambda in let n' = !dotty_state_count in incr dotty_state_count ; ( match k with - | Sil.Lseg_NE - -> F.fprintf f + | Sil.Lseg_NE -> + F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"list NE\";" n' lambda "style=filled; color=lightgrey;" - | Sil.Lseg_PE - -> F.fprintf f + | Sil.Lseg_PE -> + F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"list PE\";" n' lambda "style=filled; color=lightgrey;" ) ; F.fprintf f "state%iL%i [label=\"%a\"]@\n" n lambda (Sil.pp_exp_printenv pe) e1 ; @@ -864,17 +898,18 @@ and print_sll f pe nesting k e1 coo = (Prop.normalize (Tenv.create ()) (Prop.from_sigma nesting)) None + and print_dll f pe nesting k e1 e4 coo = let n = coo.id in let lambda = coo.lambda in let n' = !dotty_state_count in incr dotty_state_count ; ( match k with - | Sil.Lseg_NE - -> F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"%s\";" n' + | Sil.Lseg_NE -> + F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"%s\";" n' lambda "style=filled; color=lightgrey;" "doubly-linked list NE" - | Sil.Lseg_PE - -> F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"%s\";" n' + | Sil.Lseg_PE -> + F.fprintf f "subgraph cluster_%iL%i { %s node [style=filled,color=white]; label=\"%s\";" n' lambda "style=filled; color=lightgrey;" "doubly-linked list PE" ) ; F.fprintf f "state%iL%i [label=\"%a\"]@\n" n lambda (Sil.pp_exp_printenv pe) e1 ; let n' = !dotty_state_count in @@ -890,6 +925,7 @@ and print_dll f pe nesting k e1 e4 coo = (Prop.normalize (Tenv.create ()) (Prop.from_sigma nesting)) None + and dotty_pp_state f pe cycle dotnode = let dotty_exp coo e c is_dangling = let n = coo.id in @@ -901,29 +937,30 @@ and dotty_pp_state f pe cycle dotnode = F.fprintf f "state%iL%i [label=\"%a\" fontcolor=%s]@\n" n lambda (Sil.pp_exp_printenv pe) e c in match dotnode with - | Dotnil coo when !print_full_prop - -> F.fprintf f "state%iL%i [label=\"NIL \", color=green, style=filled]@\n" coo.id coo.lambda - | Dotdangling (coo, e, c) when !print_full_prop - -> dotty_exp coo e c true - | Dotpointsto (coo, e1, c) when !print_full_prop - -> dotty_exp coo e1 c false - | Dotstruct (coo, e1, l, c, te) - -> let l' = + | Dotnil coo when !print_full_prop -> + F.fprintf f "state%iL%i [label=\"NIL \", color=green, style=filled]@\n" coo.id coo.lambda + | Dotdangling (coo, e, c) when !print_full_prop -> + dotty_exp coo e c true + | Dotpointsto (coo, e1, c) when !print_full_prop -> + dotty_exp coo e1 c false + | Dotstruct (coo, e1, l, c, te) -> + let l' = if !print_full_prop then l else List.filter ~f:(fun edge -> in_cycle cycle edge) l in print_struct f pe e1 te l' coo c - | Dotarray (coo, e1, e2, l, _, c) when !print_full_prop - -> print_array f pe e1 e2 l coo c - | Dotlseg (coo, e1, _, Sil.Lseg_NE, nesting, _) when !print_full_prop - -> print_sll f pe nesting Sil.Lseg_NE e1 coo - | Dotlseg (coo, e1, _, Sil.Lseg_PE, nesting, _) when !print_full_prop - -> print_sll f pe nesting Sil.Lseg_PE e1 coo - | Dotdllseg (coo, e1, _, _, e4, Sil.Lseg_NE, nesting, _) when !print_full_prop - -> print_dll f pe nesting Sil.Lseg_NE e1 e4 coo - | Dotdllseg (coo, e1, _, _, e4, Sil.Lseg_PE, nesting, _) when !print_full_prop - -> print_dll f pe nesting Sil.Lseg_PE e1 e4 coo - | _ - -> () + | Dotarray (coo, e1, e2, l, _, c) when !print_full_prop -> + print_array f pe e1 e2 l coo c + | Dotlseg (coo, e1, _, Sil.Lseg_NE, nesting, _) when !print_full_prop -> + print_sll f pe nesting Sil.Lseg_NE e1 coo + | Dotlseg (coo, e1, _, Sil.Lseg_PE, nesting, _) when !print_full_prop -> + print_sll f pe nesting Sil.Lseg_PE e1 coo + | Dotdllseg (coo, e1, _, _, e4, Sil.Lseg_NE, nesting, _) when !print_full_prop -> + print_dll f pe nesting Sil.Lseg_NE e1 e4 coo + | Dotdllseg (coo, e1, _, _, e4, Sil.Lseg_PE, nesting, _) when !print_full_prop -> + print_dll f pe nesting Sil.Lseg_PE e1 e4 coo + | _ -> + () + (* Build the graph data structure to be printed *) and build_visual_graph f pe p cycle = @@ -942,6 +979,7 @@ and build_visual_graph f pe p cycle = let links = dotty_mk_set_links nodes sigma_lambda p f cycle in filter_useless_spec_dollar_box nodes links + and display_pure_info f pe prop = let print_invisible_objects () = for j = 1 to 4 do @@ -964,13 +1002,14 @@ and display_pure_info f pe prop = if !invisible_arrows then print_invisible_objects () ; F.fprintf f "}@\n" + (** Pretty print a proposition in dotty format. *) and pp_dotty f kind (_prop: Prop.normal Prop.t) cycle = incr proposition_counter ; let pe, prop = match kind with - | Spec_postcondition pre - -> target_invisible_arrow_pre := !proposition_counter ; + | Spec_postcondition pre -> + target_invisible_arrow_pre := !proposition_counter ; let diff = Propgraph.compute_diff Black (Propgraph.from_prop pre) (Propgraph.from_prop _prop) in @@ -981,8 +1020,8 @@ and pp_dotty f kind (_prop: Prop.normal Prop.t) cycle = let pre_stack = fst (Prop.sigma_get_stack_nonstack true pre.Prop.sigma) in let prop = Prop.set _prop ~sigma:(pre_stack @ _prop.Prop.sigma) in (pe, Prop.normalize (Tenv.create ()) prop) - | _ - -> let pe = Prop.prop_update_obj_sub Pp.text _prop in + | _ -> + let pe = Prop.prop_update_obj_sub Pp.text _prop in (pe, _prop) in dangling_dotboxes := [] ; @@ -1006,6 +1045,7 @@ and pp_dotty f kind (_prop: Prop.normal Prop.t) cycle = (* F.fprintf f "@\n } @\n"; *) F.fprintf f "@\n } @\n" + let pp_dotty_one_spec f pre posts = post_counter := 0 ; incr spec_counter ; @@ -1030,6 +1070,7 @@ let pp_dotty_one_spec f pre posts = posts ; F.fprintf f "@\n } @\n" + (* this is used to print a list of proposition when considered in a path of nodes *) let pp_dotty_prop_list_in_path f plist prev_n curr_n = try @@ -1040,12 +1081,15 @@ let pp_dotty_prop_list_in_path f plist prev_n curr_n = F.fprintf f "@\n state%iN [label=\"NODE %i \", style=filled, color= lightblue]@\n" curr_n curr_n ; List.iter - ~f:(fun po -> incr proposition_counter ; pp_dotty f Generic_proposition po None) + ~f:(fun po -> + incr proposition_counter ; + pp_dotty f Generic_proposition po None) plist ; if prev_n <> -1 then F.fprintf f "@\n state%iN ->state%iN@\n" prev_n curr_n ; F.fprintf f "@\n } @\n" with exn when SymOp.exn_not_failure exn -> () + let pp_dotty_prop fmt (prop, cycle) = reset_proposition_counter () ; Format.fprintf fmt "@\n@\n@\ndigraph main { @\nnode [shape=box]; @\n" ; @@ -1053,10 +1097,12 @@ let pp_dotty_prop fmt (prop, cycle) = pp_dotty fmt Generic_proposition prop (Some cycle) ; Format.fprintf fmt "@\n}" + let dotty_prop_to_str prop cycle = try Some (F.asprintf "%a" pp_dotty_prop (prop, cycle)) with exn when SymOp.exn_not_failure exn -> None + (* create a dotty file with a single proposition *) let dotty_prop_to_dotty_file fname prop cycle = try @@ -1066,6 +1112,7 @@ let dotty_prop_to_dotty_file fname prop cycle = Out_channel.close out_dot with exn when SymOp.exn_not_failure exn -> () + (* This is used only to print a list of prop parsed with the external parser. Basically deprecated.*) let pp_proplist_parsed2dotty_file filename plist = @@ -1080,9 +1127,11 @@ let pp_proplist_parsed2dotty_file filename plist = in let outc = Out_channel.create filename in let fmt = F.formatter_of_out_channel outc in - F.fprintf fmt "#### Dotty version: ####@.%a@.@." pp_list plist ; Out_channel.close outc + F.fprintf fmt "#### Dotty version: ####@.%a@.@." pp_list plist ; + Out_channel.close outc with exn when SymOp.exn_not_failure exn -> () + (********** START of Print interprocedural cfgs in dotty format *) (********** Print control flow graph (in dot form) for fundec to *) (* channel. You have to compute an interprocedural cfg first *) @@ -1092,6 +1141,7 @@ let pp_cfgnodename pname fmt (n: Procdesc.Node.t) = (Escape.escape_dotty (Typ.Procname.to_filename pname)) (Procdesc.Node.get_id n :> int) + let pp_etlist byvals fmt etl = List.iteri ~f:(fun index (id, ({Typ.desc} as ty)) -> @@ -1102,16 +1152,18 @@ let pp_etlist byvals fmt etl = Format.fprintf fmt " %a:%a%s" Mangled.pp id (Typ.pp_full Pp.text) ty byval_mark) etl + let pp_local_list fmt etl = List.iter ~f:(fun (id, ty) -> Format.fprintf fmt " %a:%a" Mangled.pp id (Typ.pp_full Pp.text) ty) etl + let pp_cfgnodelabel pdesc fmt (n: Procdesc.Node.t) = let pp_label fmt n = match Procdesc.Node.get_kind n with - | Procdesc.Node.Start_node pname - -> let pname_string = Escape.escape_dotty (Typ.Procname.to_string pname) in + | Procdesc.Node.Start_node pname -> + let pname_string = Escape.escape_dotty (Typ.Procname.to_string pname) in let attributes = Procdesc.get_attributes pdesc in let byvals = attributes.ProcAttributes.by_vals in Format.fprintf fmt "Start %s\\nFormals: %a\\nLocals: %a" pname_string (pp_etlist byvals) @@ -1121,16 +1173,16 @@ let pp_cfgnodelabel pdesc fmt (n: Procdesc.Node.t) = let method_annotation = attributes.ProcAttributes.method_annotation in if not (Annot.Method.is_empty method_annotation) then Format.fprintf fmt "\\nAnnotation: %a" (Annot.Method.pp pname_string) method_annotation - | Procdesc.Node.Exit_node pname - -> Format.fprintf fmt "Exit %s" (Escape.escape_dotty (Typ.Procname.to_string pname)) - | Procdesc.Node.Join_node - -> Format.fprintf fmt "+" - | Procdesc.Node.Prune_node (is_true_branch, _, _) - -> Format.fprintf fmt "Prune (%b branch)" is_true_branch - | Procdesc.Node.Stmt_node s - -> Format.fprintf fmt " %s" s - | Procdesc.Node.Skip_node s - -> Format.fprintf fmt "Skip %s" s + | Procdesc.Node.Exit_node pname -> + Format.fprintf fmt "Exit %s" (Escape.escape_dotty (Typ.Procname.to_string pname)) + | Procdesc.Node.Join_node -> + Format.fprintf fmt "+" + | Procdesc.Node.Prune_node (is_true_branch, _, _) -> + Format.fprintf fmt "Prune (%b branch)" is_true_branch + | Procdesc.Node.Stmt_node s -> + Format.fprintf fmt " %s" s + | Procdesc.Node.Skip_node s -> + Format.fprintf fmt "Skip %s" s in let instr_string i = let pp f = Sil.pp_instr Pp.text f i in @@ -1143,18 +1195,20 @@ let pp_cfgnodelabel pdesc fmt (n: Procdesc.Node.t) = let instrs = Procdesc.Node.get_instrs n in F.fprintf fmt "%d: %a \\n %a" (Procdesc.Node.get_id n :> int) pp_label n pp_instrs instrs + let pp_cfgnodeshape fmt (n: Procdesc.Node.t) = match Procdesc.Node.get_kind n with - | Procdesc.Node.Start_node _ | Procdesc.Node.Exit_node _ - -> F.fprintf fmt "color=yellow style=filled" - | Procdesc.Node.Prune_node _ - -> F.fprintf fmt "shape=\"invhouse\"" - | Procdesc.Node.Skip_node _ - -> F.fprintf fmt "color=\"gray\"" - | Procdesc.Node.Stmt_node _ - -> F.fprintf fmt "shape=\"box\"" - | _ - -> () + | Procdesc.Node.Start_node _ | Procdesc.Node.Exit_node _ -> + F.fprintf fmt "color=yellow style=filled" + | Procdesc.Node.Prune_node _ -> + F.fprintf fmt "shape=\"invhouse\"" + | Procdesc.Node.Skip_node _ -> + F.fprintf fmt "color=\"gray\"" + | Procdesc.Node.Stmt_node _ -> + F.fprintf fmt "shape=\"box\"" + | _ -> + () + let pp_cfgnode pdesc fmt (n: Procdesc.Node.t) = let pname = Procdesc.get_proc_name pdesc in @@ -1163,16 +1217,17 @@ let pp_cfgnode pdesc fmt (n: Procdesc.Node.t) = let print_edge n1 n2 is_exn = let color = if is_exn then "[color=\"red\" ]" else "" in match Procdesc.Node.get_kind n2 with - | Procdesc.Node.Exit_node _ when is_exn - -> (* don't print exception edges to the exit node *) + | Procdesc.Node.Exit_node _ when is_exn -> + (* don't print exception edges to the exit node *) () - | _ - -> F.fprintf fmt "@\n\t %a -> %a %s;" (pp_cfgnodename pname) n1 (pp_cfgnodename pname) n2 + | _ -> + F.fprintf fmt "@\n\t %a -> %a %s;" (pp_cfgnodename pname) n1 (pp_cfgnodename pname) n2 color in List.iter ~f:(fun n' -> print_edge n n' false) (Procdesc.Node.get_succs n) ; List.iter ~f:(fun n' -> print_edge n n' true) (Procdesc.Node.get_exn n) + (* * print control flow graph (in dot form) for fundec to channel let *) (* print_cfg_channel (chan : out_channel) (fd : fundec) = let pnode (s: *) (* stmt) = fprintf chan "%a@\n" d_cfgnode s in forallStmts pnode fd * *) @@ -1190,6 +1245,7 @@ let print_icfg source fmt cfg = in Cfg.iter_all_nodes ~sorted:true print_node cfg + let write_icfg_dotty_to_file source cfg fname = let chan = Out_channel.create fname in let fmt = Format.formatter_of_out_channel chan in @@ -1199,20 +1255,22 @@ let write_icfg_dotty_to_file source cfg fname = F.fprintf fmt "}@\n" ; Out_channel.close chan + let print_icfg_dotty source cfg = let fname = match Config.icfg_dotty_outfile with - | Some file - -> file - | None when Config.frontend_tests - -> SourceFile.to_abs_path source ^ ".test.dot" - | None - -> DB.filename_to_string + | Some file -> + file + | None when Config.frontend_tests -> + SourceFile.to_abs_path source ^ ".test.dot" + | None -> + DB.filename_to_string (DB.Results_dir.path_to_filename (DB.Results_dir.Abs_source_dir source) [Config.dotty_output]) in write_icfg_dotty_to_file source cfg fname + (********** END of Printing dotty files ***********) (** Dotty printing for specs *) @@ -1230,6 +1288,7 @@ let pp_speclist_dotty f (splist: Prop.normal Specs.spec list) = F.fprintf f "@\n}" ; Config.pp_simple := pp_simple_saved + let pp_speclist_to_file (filename: DB.filename) spec_list = let pp_simple_saved = !Config.pp_simple in Config.pp_simple := true ; @@ -1239,10 +1298,12 @@ let pp_speclist_to_file (filename: DB.filename) spec_list = Out_channel.close outc ; Config.pp_simple := pp_simple_saved + let pp_speclist_dotty_file (filename: DB.filename) spec_list = try pp_speclist_to_file filename spec_list with exn when SymOp.exn_not_failure exn -> () + (**********************************************************************) (* Code prodicing a xml version of a graph *) (**********************************************************************) @@ -1284,12 +1345,13 @@ let exp_dangling_node e = !set_dangling_nodes in match entry_e with - | [] - -> None - | (VH_dangling (n, e')) :: _ - -> Some (VH_dangling (n, e')) - | _ - -> None + | [] -> + None + | (VH_dangling (n, e')) :: _ -> + Some (VH_dangling (n, e')) + | _ -> + None + (* NOTE: this cannot be possible since entry_e can be composed only by VH_dangling, see def of entry_e*) (* make nodes and when it finds a list records in the working list *) @@ -1300,26 +1362,27 @@ let rec make_visual_heap_nodes sigma = let n = !global_node_counter in incr global_node_counter ; match sigma with - | [] - -> [] - | (Sil.Hpointsto (e, se, t)) :: sigma' - -> VH_pointsto (n, e, se, t) :: make_visual_heap_nodes sigma' - | (Sil.Hlseg (k, hpara, e1, e2, _)) :: sigma' - -> working_list := (n, hpara.Sil.body) :: !working_list ; + | [] -> + [] + | (Sil.Hpointsto (e, se, t)) :: sigma' -> + VH_pointsto (n, e, se, t) :: make_visual_heap_nodes sigma' + | (Sil.Hlseg (k, hpara, e1, e2, _)) :: sigma' -> + working_list := (n, hpara.Sil.body) :: !working_list ; VH_lseg (n, e1, e2, k) :: make_visual_heap_nodes sigma' - | (Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, _)) :: sigma' - -> working_list := (n, hpara_dll.Sil.body_dll) :: !working_list ; + | (Sil.Hdllseg (k, hpara_dll, e1, e2, e3, e4, _)) :: sigma' -> + working_list := (n, hpara_dll.Sil.body_dll) :: !working_list ; VH_dllseg (n, e1, e2, e3, e4, k) :: make_visual_heap_nodes sigma' + (* given a node returns its id and address*) let get_node_id_and_addr node = - match node - with + match node with | VH_dangling (n, e) | VH_pointsto (n, e, _, _) | VH_lseg (n, e, _, _) - | VH_dllseg (n, e, _, _, _, _) - -> (n, e) + | VH_dllseg (n, e, _, _, _, _) -> + (n, e) + (* return node's id*) let get_node_id node = fst (get_node_id_and_addr node) @@ -1330,12 +1393,13 @@ let get_node_addr node = snd (get_node_id_and_addr node) (* return the nodes corresponding to an address given by an expression *) let rec select_node_at_address nodes e = match nodes with - | [] - -> None - | n :: l' - -> let e' = get_node_addr n in + | [] -> + None + | n :: l' -> + let e' = get_node_addr n in if Exp.equal e e' then Some n else select_node_at_address l' e + (* look-up the ids in the list of nodes corresponding to expression e*) (* let look_up_nodes_ids nodes e = List.map ~f:get_node_id (select_nodes_exp nodes e) *) @@ -1347,14 +1411,14 @@ let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) = in let get_rhs_predicate hpred = match hpred with - | Sil.Hpointsto (_, Sil.Eexp (e, _), _) when not (Exp.equal e Exp.zero) - -> [e] - | Sil.Hlseg (_, _, _, e2, _) when not (Exp.equal e2 Exp.zero) - -> [e2] - | Sil.Hdllseg (_, _, _, e2, e3, _, _) - -> if Exp.equal e2 Exp.zero then if Exp.equal e3 Exp.zero then [] else [e3] else [e2; e3] - | Sil.Hpointsto (_, _, _) | _ - -> [] + | Sil.Hpointsto (_, Sil.Eexp (e, _), _) when not (Exp.equal e Exp.zero) -> + [e] + | Sil.Hlseg (_, _, _, e2, _) when not (Exp.equal e2 Exp.zero) -> + [e2] + | Sil.Hdllseg (_, _, _, e2, e3, _, _) -> + if Exp.equal e2 Exp.zero then if Exp.equal e3 Exp.zero then [] else [e3] else [e2; e3] + | Sil.Hpointsto (_, _, _) | _ -> + [] (* arrays and struct do not give danglings. CHECK THIS!*) in let is_not_allocated e = @@ -1362,20 +1426,20 @@ let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) = List.exists ~f:(fun a -> match a with - | VH_pointsto (_, e', _, _) | VH_lseg (_, e', _, _) | VH_dllseg (_, e', _, _, _, _) - -> Exp.equal e e' - | _ - -> false) + | VH_pointsto (_, e', _, _) | VH_lseg (_, e', _, _) | VH_dllseg (_, e', _, _, _, _) -> + Exp.equal e e' + | _ -> + false) allocated_nodes in not allocated in let rec filter_duplicate l seen_exp = match l with - | [] - -> [] - | e :: l' - -> if List.exists ~f:(Exp.equal e) seen_exp then filter_duplicate l' seen_exp + | [] -> + [] + | e :: l' -> + if List.exists ~f:(Exp.equal e) seen_exp then filter_duplicate l' seen_exp else e :: filter_duplicate l' (e :: seen_exp) in let rhs_exp_list = List.concat_map ~f:get_rhs_predicate sigma in @@ -1384,75 +1448,77 @@ let make_set_dangling_nodes allocated_nodes (sigma: Sil.hpred list) = let dangling_exps = List.filter ~f:is_not_allocated candidate_dangling_exps in List.map ~f:make_new_dangling dangling_exps + (* return a list of pairs (n,field_lab) where n is a target node*) (* corresponding to se and is going to be used a target for and edge*) (* field_lab is the name of the field which points to n (if any)*) let rec compute_target_nodes_from_sexp nodes se prop field_lab = match se with - | Sil.Eexp (e, _) when is_nil e prop - -> (* Nil is not represented by a node, it's just a value which should be printed*) + | Sil.Eexp (e, _) when is_nil e prop -> + (* Nil is not represented by a node, it's just a value which should be printed*) [] | Sil.Eexp (e, _) - -> ( + -> ( let e_node = select_node_at_address nodes e in match e_node with | None -> ( match exp_dangling_node e with None -> [] | Some dang_node -> [(dang_node, field_lab)] ) - | Some n - -> [(n, field_lab)] ) + | Some n -> + [(n, field_lab)] ) | Sil.Estruct (lfld, inst) -> ( match lfld with - | [] - -> [] - | (fn, se2) :: l' - -> compute_target_nodes_from_sexp nodes se2 prop (Typ.Fieldname.to_string fn) + | [] -> + [] + | (fn, se2) :: l' -> + compute_target_nodes_from_sexp nodes se2 prop (Typ.Fieldname.to_string fn) @ compute_target_nodes_from_sexp nodes (Sil.Estruct (l', inst)) prop "" ) | Sil.Earray (len, lie, inst) -> match lie with - | [] - -> [] - | (idx, se2) :: l' - -> let lab = "[" ^ exp_to_xml_string idx ^ "]" in + | [] -> + [] + | (idx, se2) :: l' -> + let lab = "[" ^ exp_to_xml_string idx ^ "]" in compute_target_nodes_from_sexp nodes se2 prop lab @ compute_target_nodes_from_sexp nodes (Sil.Earray (len, l', inst)) prop "" + (* build the set of edges between nodes *) let rec make_visual_heap_edges nodes sigma prop = let combine_source_target_label n (m, lab) = mk_visual_heap_edge (get_node_id n) (get_node_id m) lab in match sigma with - | [] - -> [] + | [] -> + [] | (Sil.Hpointsto (e, se, _)) :: sigma' - -> ( + -> ( let e_node = select_node_at_address nodes e in match e_node with - | None - -> assert false - | Some n - -> let target_nodes = compute_target_nodes_from_sexp nodes se prop "" in + | None -> + assert false + | Some n -> + let target_nodes = compute_target_nodes_from_sexp nodes se prop "" in let ll = List.map ~f:(combine_source_target_label n) target_nodes in ll @ make_visual_heap_edges nodes sigma' prop ) | (Sil.Hlseg (_, _, e1, e2, _)) :: sigma' - -> ( + -> ( let e1_node = select_node_at_address nodes e1 in match e1_node with - | None - -> assert false - | Some n - -> let target_nodes = + | None -> + assert false + | Some n -> + let target_nodes = compute_target_nodes_from_sexp nodes (Sil.Eexp (e2, Sil.inst_none)) prop "" in let ll = List.map ~f:(combine_source_target_label n) target_nodes in ll @ make_visual_heap_edges nodes sigma' prop ) - | (Sil.Hdllseg (_, _, e1, e2, e3, _, _)) :: sigma' - -> let e1_node = select_node_at_address nodes e1 in + | (Sil.Hdllseg (_, _, e1, e2, e3, _, _)) :: sigma' -> + let e1_node = select_node_at_address nodes e1 in match e1_node with - | None - -> assert false - | Some n - -> let target_nodesF = + | None -> + assert false + | Some n -> + let target_nodesF = compute_target_nodes_from_sexp nodes (Sil.Eexp (e3, Sil.inst_none)) prop "" in let target_nodesB = @@ -1462,6 +1528,7 @@ let rec make_visual_heap_edges nodes sigma prop = let llB = List.map ~f:(combine_source_target_label n) target_nodesB in llF @ llB @ make_visual_heap_edges nodes sigma' prop + (* from a prop generate and return visual proposition *) let prop_to_set_of_visual_heaps prop = let result = ref [] in @@ -1478,69 +1545,74 @@ let prop_to_set_of_visual_heaps prop = done ; !result + let rec pointsto_contents_to_xml (co: Sil.strexp) : Io_infer.Xml.node = match co with - | Sil.Eexp (e, _) - -> Io_infer.Xml.create_tree "cell" [("content-value", exp_to_xml_string e)] [] - | Sil.Estruct (fel, _) - -> let f (fld, exp) = + | Sil.Eexp (e, _) -> + Io_infer.Xml.create_tree "cell" [("content-value", exp_to_xml_string e)] [] + | Sil.Estruct (fel, _) -> + let f (fld, exp) = Io_infer.Xml.create_tree "struct-field" [("id", Typ.Fieldname.to_string fld)] [pointsto_contents_to_xml exp] in Io_infer.Xml.create_tree "struct" [] (List.map ~f fel) - | Sil.Earray (len, nel, _) - -> let f (e, se) = + | Sil.Earray (len, nel, _) -> + let f (e, se) = Io_infer.Xml.create_tree "array-element" [("index", exp_to_xml_string e)] [pointsto_contents_to_xml se] in Io_infer.Xml.create_tree "array" [("size", exp_to_xml_string len)] (List.map ~f nel) + (* Convert an atom to xml in a light version. Namely, the expressions are not fully blown-up into *) (* xml tree but visualized as strings *) let atom_to_xml_light (a: Sil.atom) : Io_infer.Xml.node = let kind_info = match a with - | Sil.Aeq _ when Prop.atom_is_inequality a - -> "inequality" - | Sil.Aeq _ - -> "equality" - | Sil.Aneq _ - -> "disequality" - | Sil.Apred _ - -> "pred" - | Sil.Anpred _ - -> "npred" + | Sil.Aeq _ when Prop.atom_is_inequality a -> + "inequality" + | Sil.Aeq _ -> + "equality" + | Sil.Aneq _ -> + "disequality" + | Sil.Apred _ -> + "pred" + | Sil.Anpred _ -> + "npred" in Io_infer.Xml.create_tree "stack-variable" [("type", kind_info); ("instance", atom_to_xml_string a)] [] + let xml_pure_info prop = let pure = Prop.get_pure prop in let xml_atom_list = List.map ~f:atom_to_xml_light pure in Io_infer.Xml.create_tree "stack" [] xml_atom_list + (** Return a string describing the kind of a pointsto address *) let pointsto_addr_kind = function - | Exp.Lvar pv - -> if Pvar.is_global pv then "global" + | Exp.Lvar pv -> + if Pvar.is_global pv then "global" else if Pvar.is_local pv && Mangled.equal (Pvar.get_name pv) Ident.name_return then "return" else if Pvar.is_local pv then "parameter" else "other" - | _ - -> "other" + | _ -> + "other" + let heap_node_to_xml node = match node with - | VH_dangling (id, addr) - -> let atts = + | VH_dangling (id, addr) -> + let atts = [ ("id", string_of_int id) ; ("address", exp_to_xml_string addr) ; ("node-type", "dangling") ; ("memory-type", pointsto_addr_kind addr) ] in Io_infer.Xml.create_tree "node" atts [] - | VH_pointsto (id, addr, cont, _) - -> let atts = + | VH_pointsto (id, addr, cont, _) -> + let atts = [ ("id", string_of_int id) ; ("address", exp_to_xml_string addr) ; ("node-type", "allocated") @@ -1548,8 +1620,8 @@ let heap_node_to_xml node = in let contents = pointsto_contents_to_xml cont in Io_infer.Xml.create_tree "node" atts [contents] - | VH_lseg (id, addr, _, Sil.Lseg_NE) - -> let atts = + | VH_lseg (id, addr, _, Sil.Lseg_NE) -> + let atts = [ ("id", string_of_int id) ; ("address", exp_to_xml_string addr) ; ("node-type", "single linked list") @@ -1557,8 +1629,8 @@ let heap_node_to_xml node = ; ("memory-type", "other") ] in Io_infer.Xml.create_tree "node" atts [] - | VH_lseg (id, addr, _, Sil.Lseg_PE) - -> let atts = + | VH_lseg (id, addr, _, Sil.Lseg_PE) -> + let atts = [ ("id", string_of_int id) ; ("address", exp_to_xml_string addr) ; ("node-type", "single linked list") @@ -1566,8 +1638,8 @@ let heap_node_to_xml node = ; ("memory-type", "other") ] in Io_infer.Xml.create_tree "node" atts [] - | VH_dllseg (id, addr1, cont1, cont2, addr2, _) - -> let contents1 = pointsto_contents_to_xml (Sil.Eexp (cont1, Sil.inst_none)) in + | VH_dllseg (id, addr1, cont1, cont2, addr2, _) -> + let contents1 = pointsto_contents_to_xml (Sil.Eexp (cont1, Sil.inst_none)) in let contents2 = pointsto_contents_to_xml (Sil.Eexp (cont2, Sil.inst_none)) in let atts = [ ("id", string_of_int id) @@ -1578,18 +1650,21 @@ let heap_node_to_xml node = in Io_infer.Xml.create_tree "node" atts [contents1; contents2] + let heap_edge_to_xml edge = let atts = [("source", string_of_int edge.src); ("target", string_of_int edge.trg); ("label", edge.lab)] in Io_infer.Xml.create_tree "edge" atts [] + let visual_heap_to_xml heap = let n, nodes, edges = heap in let xml_heap_nodes = List.map ~f:heap_node_to_xml nodes in let xml_heap_edges = List.map ~f:heap_edge_to_xml edges in Io_infer.Xml.create_tree "heap" [("id", string_of_int n)] (xml_heap_nodes @ xml_heap_edges) + (** convert a proposition to xml with the given tag and id *) let prop_to_xml prop tag_name id = let visual_heaps = prop_to_set_of_visual_heaps prop in @@ -1601,6 +1676,7 @@ let prop_to_xml prop tag_name id = in xml_graph + (** reset the counter used for node and heap identifiers *) let reset_node_counter () = global_node_counter := 0 @@ -1641,3 +1717,4 @@ let print_specs_xml signature specs loc fmt = [xml_signature; xml_specifications] in Io_infer.Xml.pp_document true fmt proc_summary + diff --git a/infer/src/backend/errdesc.ml b/infer/src/backend/errdesc.ml index 9245ba735..50228edd9 100644 --- a/infer/src/backend/errdesc.ml +++ b/infer/src/backend/errdesc.ml @@ -22,15 +22,17 @@ let mutex_matcher = QualifiedCppName.Match.of_fuzzy_qual_names ["std::__infer_mutex_model"; "std::mutex"; "std::timed_mutex"] + let is_one_of_classes = QualifiedCppName.Match.match_qualifiers let is_method_of_objc_cpp_class pname matcher = match pname with - | Typ.Procname.ObjC_Cpp objc_cpp - -> let class_qual_opt = Typ.Procname.objc_cpp_get_class_qualifiers objc_cpp in + | Typ.Procname.ObjC_Cpp objc_cpp -> + let class_qual_opt = Typ.Procname.objc_cpp_get_class_qualifiers objc_cpp in is_one_of_classes matcher class_qual_opt - | _ - -> false + | _ -> + false + let is_mutex_method pname = is_method_of_objc_cpp_class pname mutex_matcher @@ -41,33 +43,37 @@ let is_special_field matcher field_name_opt field = let class_qual_opt = Typ.Fieldname.clang_get_qual_class field in let field_ok = match field_name_opt with - | Some field_name' - -> String.equal field_name' field_name - | None - -> true + | Some field_name' -> + String.equal field_name' field_name + | None -> + true in field_ok && Option.value_map ~f:(is_one_of_classes matcher) ~default:false class_qual_opt + (** Check whether the hpred is a |-> representing a resource in the Racquire state *) let hpred_is_open_resource tenv prop = function | Sil.Hpointsto (e, _, _) -> ( match Attribute.get_resource tenv prop e with - | Some Apred (Aresource {ra_kind= Racquire; ra_res= res}, _) - -> Some res - | _ - -> None ) - | _ - -> None + | Some Apred (Aresource {ra_kind= Racquire; ra_res= res}, _) -> + Some res + | _ -> + None ) + | _ -> + None + (** Produce a description of a persistent reference to an Android Context *) let explain_context_leak pname context_typ fieldname error_path = Localise.desc_context_leak pname context_typ fieldname error_path + (** Explain a deallocate stack variable error *) let explain_deallocate_stack_var pvar ra = let pvar_str = Pvar.to_string pvar in Localise.desc_deallocate_stack_variable pvar_str ra.PredSymb.ra_pname ra.PredSymb.ra_loc + (** Explain a deallocate constant string error *) let explain_deallocate_constant_string s ra = let const_str = @@ -76,6 +82,7 @@ let explain_deallocate_constant_string s ra = in Localise.desc_deallocate_static_memory const_str ra.PredSymb.ra_pname ra.PredSymb.ra_loc + let verbose = Config.trace_error let find_in_node_or_preds start_node f_node_instr = @@ -86,83 +93,88 @@ let find_in_node_or_preds start_node f_node_instr = visited := Procdesc.NodeSet.add node !visited ; let instrs = Procdesc.Node.get_instrs node in match List.find_map ~f:(f_node_instr node) (List.rev instrs) with - | Some res - -> Some res - | None - -> List.find_map ~f:find (Procdesc.Node.get_preds node) ) + | Some res -> + Some res + | None -> + List.find_map ~f:find (Procdesc.Node.get_preds node) ) in find start_node + (** Find the Set instruction used to assign [id] to a program variable, if any *) let find_variable_assigment node id : Sil.instr option = let find_set _ instr = match instr with - | Sil.Store (Exp.Lvar _, _, e, _) when Exp.equal (Exp.Var id) e - -> Some instr - | _ - -> None + | Sil.Store (Exp.Lvar _, _, e, _) when Exp.equal (Exp.Var id) e -> + Some instr + | _ -> + None in find_in_node_or_preds node find_set + (** Check if a nullify instruction exists for the program variable after the given instruction *) let find_nullify_after_instr node instr pvar : bool = let node_instrs = Procdesc.Node.get_instrs node in let found_instr = ref false in let find_nullify = function - | Sil.Nullify (pv, _) when !found_instr - -> Pvar.equal pv pvar - | instr_ - -> if Sil.equal_instr instr instr_ then found_instr := true ; + | Sil.Nullify (pv, _) when !found_instr -> + Pvar.equal pv pvar + | instr_ -> + if Sil.equal_instr instr instr_ then found_instr := true ; false in List.exists ~f:find_nullify node_instrs + (** Find the other prune node of a conditional (e.g. the false branch given the true branch of a conditional) *) let find_other_prune_node node = match Procdesc.Node.get_preds node with | [n_pre] -> ( match Procdesc.Node.get_succs n_pre with - | [n1; n2] - -> if Procdesc.Node.equal n1 node then Some n2 else Some n1 - | _ - -> None ) - | _ - -> None + | [n1; n2] -> + if Procdesc.Node.equal n1 node then Some n2 else Some n1 + | _ -> + None ) + | _ -> + None + (** Return true if [id] is assigned to a program variable which is then nullified *) let id_is_assigned_then_dead node id = match find_variable_assigment node id with | Some (Sil.Store (Exp.Lvar pvar, _, _, _) as instr) - when Pvar.is_local pvar || Pvar.is_callee pvar - -> let is_prune = + when Pvar.is_local pvar || Pvar.is_callee pvar -> + let is_prune = match Procdesc.Node.get_kind node with Procdesc.Node.Prune_node _ -> true | _ -> false in let prune_check = function (* if prune node, check that it's also nullified in the other branch *) | Some node' -> ( match Procdesc.Node.get_instrs node' with - | instr' :: _ - -> find_nullify_after_instr node' instr' pvar - | _ - -> false ) - | _ - -> false + | instr' :: _ -> + find_nullify_after_instr node' instr' pvar + | _ -> + false ) + | _ -> + false in find_nullify_after_instr node instr pvar && (not is_prune || prune_check (find_other_prune_node node)) - | _ - -> false + | _ -> + false + (** Find the function call instruction used to initialize normal variable [id], and return the function name and arguments *) let find_normal_variable_funcall (node: Procdesc.Node.t) (id: Ident.t) : (Exp.t * Exp.t list * Location.t * CallFlags.t) option = let find_declaration _ = function - | Sil.Call (Some (id0, _), fun_exp, args, loc, call_flags) when Ident.equal id id0 - -> Some (fun_exp, List.map ~f:fst args, loc, call_flags) - | _ - -> None + | Sil.Call (Some (id0, _), fun_exp, args, loc, call_flags) when Ident.equal id id0 -> + Some (fun_exp, List.map ~f:fst args, loc, call_flags) + | _ -> + None in let res = find_in_node_or_preds node find_declaration in if verbose && is_none res then ( @@ -172,16 +184,18 @@ let find_normal_variable_funcall (node: Procdesc.Node.t) (id: Ident.t) L.d_ln () ) ; res + (** Find a program variable assignment in the current node or predecessors. *) let find_program_variable_assignment node pvar : (Procdesc.Node.t * Ident.t) option = let find_instr node = function - | Sil.Store (Exp.Lvar _pvar, _, Exp.Var id, _) when Pvar.equal pvar _pvar && Ident.is_normal id - -> Some (node, id) - | _ - -> None + | Sil.Store (Exp.Lvar _pvar, _, Exp.Var id, _) when Pvar.equal pvar _pvar && Ident.is_normal id -> + Some (node, id) + | _ -> + None in find_in_node_or_preds node find_instr + (** Special case for C++, where we translate code like `struct X; X getX() { X x; return X; }` as `void getX(struct X * frontend_generated_pvar)`. @@ -191,61 +205,72 @@ let find_struct_by_value_assignment node pvar = let find_instr node = function | Sil.Call (_, Const Cfun pname, args, loc, cf) -> ( match List.last args with - | Some (Exp.Lvar last_arg, _) when Pvar.equal pvar last_arg - -> Some (node, pname, loc, cf) - | _ - -> None ) - | _ - -> None + | Some (Exp.Lvar last_arg, _) when Pvar.equal pvar last_arg -> + Some (node, pname, loc, cf) + | _ -> + None ) + | _ -> + None in find_in_node_or_preds node find_instr else None + (** Find a program variable assignment to id in the current node or predecessors. *) let find_ident_assignment node id : (Procdesc.Node.t * Exp.t) option = let find_instr node = function - | Sil.Load (_id, e, _, _) when Ident.equal _id id - -> Some (node, e) - | _ - -> None + | Sil.Load (_id, e, _, _) when Ident.equal _id id -> + Some (node, e) + | _ -> + None in find_in_node_or_preds node find_instr + (** Find a boolean assignment to a temporary variable holding a boolean condition. The boolean parameter indicates whether the true or false branch is required. *) let rec find_boolean_assignment node pvar true_branch : Procdesc.Node.t option = let find_instr n = let filter = function - | Sil.Store (Exp.Lvar _pvar, _, Exp.Const Const.Cint i, _) when Pvar.equal pvar _pvar - -> IntLit.iszero i <> true_branch - | _ - -> false + | Sil.Store (Exp.Lvar _pvar, _, Exp.Const Const.Cint i, _) when Pvar.equal pvar _pvar -> + IntLit.iszero i <> true_branch + | _ -> + false in List.exists ~f:filter (Procdesc.Node.get_instrs n) in match Procdesc.Node.get_preds node with - | [pred_node] - -> find_boolean_assignment pred_node pvar true_branch - | [n1; n2] - -> if find_instr n1 then Some n1 else if find_instr n2 then Some n2 else None - | _ - -> None + | [pred_node] -> + find_boolean_assignment pred_node pvar true_branch + | [n1; n2] -> + if find_instr n1 then Some n1 else if find_instr n2 then Some n2 else None + | _ -> + None + (** Find the Load instruction used to declare normal variable [id], and return the expression dereferenced to initialize [id] *) let rec _find_normal_variable_load tenv (seen: Exp.Set.t) node id : DExp.t option = let find_declaration node = function - | Sil.Load (id0, e, _, _) when Ident.equal id id0 - -> if verbose then ( L.d_str "find_normal_variable_load defining " ; Sil.d_exp e ; L.d_ln () ) ; + | Sil.Load (id0, e, _, _) when Ident.equal id id0 -> + if verbose then ( + L.d_str "find_normal_variable_load defining " ; + Sil.d_exp e ; + L.d_ln () ) ; _exp_lv_dexp tenv seen node e | Sil.Call (Some (id0, _), Exp.Const Const.Cfun pn, (e, _) :: _, _, _) - when Ident.equal id id0 && Typ.Procname.equal pn (Typ.Procname.from_string_c_fun "__cast") - -> if verbose then ( L.d_str "find_normal_variable_load cast on " ; Sil.d_exp e ; L.d_ln () ) ; + when Ident.equal id id0 && Typ.Procname.equal pn (Typ.Procname.from_string_c_fun "__cast") -> + if verbose then ( + L.d_str "find_normal_variable_load cast on " ; + Sil.d_exp e ; + L.d_ln () ) ; _exp_rv_dexp tenv seen node e | Sil.Call (Some (id0, _), (Exp.Const Const.Cfun pname as fun_exp), args, loc, call_flags) - when Ident.equal id id0 - -> if verbose then ( - L.d_str "find_normal_variable_load function call " ; Sil.d_exp fun_exp ; L.d_ln () ) ; + when Ident.equal id id0 -> + if verbose then ( + L.d_str "find_normal_variable_load function call " ; + Sil.d_exp fun_exp ; + L.d_ln () ) ; let fun_dexp = DExp.Dconst (Const.Cfun pname) in let args_dexp = let args_dexpo = List.map ~f:(fun (e, _) -> _exp_rv_dexp tenv seen node e) args in @@ -256,15 +281,15 @@ let rec _find_normal_variable_load tenv (seen: Exp.Set.t) node id : DExp.t optio in Some (DExp.Dretcall (fun_dexp, args_dexp, loc, call_flags)) | Sil.Store (Exp.Lvar pvar, _, Exp.Var id0, _) - when Config.biabduction && Ident.equal id id0 && not (Pvar.is_frontend_tmp pvar) - -> (* this case is a hack to make bucketing continue to work in the presence of copy + when Config.biabduction && Ident.equal id id0 && not (Pvar.is_frontend_tmp pvar) -> + (* this case is a hack to make bucketing continue to work in the presence of copy propagation. previously, we would have code like: n1 = foo(); x = n1; n2 = x; n2.toString(), but copy-propagation will optimize this to: n1 = foo(); x = n1; n1.toString(). This case allows us to recognize the association between n1 and x. Eradicate/checkers don't use copy-prop, so they don't need this. *) Some (DExp.Dpvar pvar) - | _ - -> None + | _ -> + None in let res = find_in_node_or_preds node find_declaration in if verbose && is_none res then ( @@ -274,161 +299,191 @@ let rec _find_normal_variable_load tenv (seen: Exp.Set.t) node id : DExp.t optio L.d_ln () ) ; res + (** describe lvalue [e] as a dexp *) and _exp_lv_dexp tenv (_seen: Exp.Set.t) node e : DExp.t option = if Exp.Set.mem e _seen then ( - L.d_str "exp_lv_dexp: cycle detected" ; Sil.d_exp e ; L.d_ln () ; None ) + L.d_str "exp_lv_dexp: cycle detected" ; + Sil.d_exp e ; + L.d_ln () ; + None ) else let seen = Exp.Set.add e _seen in match Prop.exp_normalize_noabs tenv Sil.sub_empty e with - | Exp.Const c - -> if verbose then ( L.d_str "exp_lv_dexp: constant " ; Sil.d_exp e ; L.d_ln () ) ; + | Exp.Const c -> + if verbose then ( L.d_str "exp_lv_dexp: constant " ; Sil.d_exp e ; L.d_ln () ) ; Some (DExp.Dderef (DExp.Dconst c)) | Exp.BinOp (Binop.PlusPI, e1, e2) - -> ( - if verbose then ( L.d_str "exp_lv_dexp: (e1 +PI e2) " ; Sil.d_exp e ; L.d_ln () ) ; + -> ( + if verbose then ( + L.d_str "exp_lv_dexp: (e1 +PI e2) " ; + Sil.d_exp e ; + L.d_ln () ) ; match (_exp_lv_dexp tenv seen node e1, _exp_rv_dexp tenv seen node e2) with - | Some de1, Some de2 - -> Some (DExp.Dbinop (Binop.PlusPI, de1, de2)) - | _ - -> None ) + | Some de1, Some de2 -> + Some (DExp.Dbinop (Binop.PlusPI, de1, de2)) + | _ -> + None ) | Exp.Var id when Ident.is_normal id - -> ( - if verbose then ( L.d_str "exp_lv_dexp: normal var " ; Sil.d_exp e ; L.d_ln () ) ; + -> ( + if verbose then ( + L.d_str "exp_lv_dexp: normal var " ; + Sil.d_exp e ; + L.d_ln () ) ; match _find_normal_variable_load tenv seen node id with - | None - -> None - | Some de - -> Some (DExp.Dderef de) ) - | Exp.Lvar pvar - -> if verbose then ( L.d_str "exp_lv_dexp: program var " ; Sil.d_exp e ; L.d_ln () ) ; + | None -> + None + | Some de -> + Some (DExp.Dderef de) ) + | Exp.Lvar pvar -> + if verbose then ( + L.d_str "exp_lv_dexp: program var " ; + Sil.d_exp e ; + L.d_ln () ) ; if Pvar.is_frontend_tmp pvar then match find_program_variable_assignment node pvar with | None -> ( match find_struct_by_value_assignment node pvar with - | Some (_, pname, loc, call_flags) - -> Some (DExp.Dfcall (DExp.Dconst (Cfun pname), [], loc, call_flags)) - | None - -> None ) + | Some (_, pname, loc, call_flags) -> + Some (DExp.Dfcall (DExp.Dconst (Cfun pname), [], loc, call_flags)) + | None -> + None ) | Some (node', id) -> match find_normal_variable_funcall node' id with - | Some (fun_exp, eargs, loc, call_flags) - -> let fun_dexpo = _exp_rv_dexp tenv seen node' fun_exp in + | Some (fun_exp, eargs, loc, call_flags) -> + let fun_dexpo = _exp_rv_dexp tenv seen node' fun_exp in let blame_args = List.map ~f:(_exp_rv_dexp tenv seen node') eargs in if List.exists ~f:is_none (fun_dexpo :: blame_args) then None else let unNone = function Some x -> x | None -> assert false in let args = List.map ~f:unNone blame_args in Some (DExp.Dfcall (unNone fun_dexpo, args, loc, call_flags)) - | None - -> _exp_rv_dexp tenv seen node' (Exp.Var id) + | None -> + _exp_rv_dexp tenv seen node' (Exp.Var id) else Some (DExp.Dpvar pvar) | Exp.Lfield (Exp.Var id, f, _) when Ident.is_normal id - -> ( + -> ( if verbose then ( L.d_str "exp_lv_dexp: Lfield with var " ; Sil.d_exp (Exp.Var id) ; L.d_str (" " ^ Typ.Fieldname.to_string f) ; L.d_ln () ) ; match _find_normal_variable_load tenv seen node id with - | None - -> None - | Some de - -> Some (DExp.Darrow (de, f)) ) + | None -> + None + | Some de -> + Some (DExp.Darrow (de, f)) ) | Exp.Lfield (e1, f, _) - -> ( + -> ( if verbose then ( L.d_str "exp_lv_dexp: Lfield " ; Sil.d_exp e1 ; L.d_str (" " ^ Typ.Fieldname.to_string f) ; L.d_ln () ) ; match _exp_lv_dexp tenv seen node e1 with - | None - -> None - | Some de - -> Some (DExp.Ddot (de, f)) ) + | None -> + None + | Some de -> + Some (DExp.Ddot (de, f)) ) | Exp.Lindex (e1, e2) - -> ( + -> ( if verbose then ( L.d_str "exp_lv_dexp: Lindex " ; Sil.d_exp e1 ; L.d_str " " ; Sil.d_exp e2 ; L.d_ln () ) ; match (_exp_lv_dexp tenv seen node e1, _exp_rv_dexp tenv seen node e2) with - | None, _ - -> None - | Some de1, None - -> (* even if the index is unknown, the array info is useful for bound errors *) + | None, _ -> + None + | Some de1, None -> + (* even if the index is unknown, the array info is useful for bound errors *) Some (DExp.Darray (de1, DExp.Dunknown)) - | Some de1, Some de2 - -> Some (DExp.Darray (de1, de2)) ) - | _ - -> if verbose then ( L.d_str "exp_lv_dexp: no match for " ; Sil.d_exp e ; L.d_ln () ) ; + | Some de1, Some de2 -> + Some (DExp.Darray (de1, de2)) ) + | _ -> + if verbose then ( + L.d_str "exp_lv_dexp: no match for " ; + Sil.d_exp e ; + L.d_ln () ) ; None + (** describe rvalue [e] as a dexp *) and _exp_rv_dexp tenv (_seen: Exp.Set.t) node e : DExp.t option = if Exp.Set.mem e _seen then ( - L.d_str "exp_rv_dexp: cycle detected" ; Sil.d_exp e ; L.d_ln () ; None ) + L.d_str "exp_rv_dexp: cycle detected" ; + Sil.d_exp e ; + L.d_ln () ; + None ) else let seen = Exp.Set.add e _seen in match e with - | Exp.Const c - -> if verbose then ( L.d_str "exp_rv_dexp: constant " ; Sil.d_exp e ; L.d_ln () ) ; + | Exp.Const c -> + if verbose then ( L.d_str "exp_rv_dexp: constant " ; Sil.d_exp e ; L.d_ln () ) ; Some (DExp.Dconst c) - | Exp.Lvar pv - -> if verbose then ( L.d_str "exp_rv_dexp: program var " ; Sil.d_exp e ; L.d_ln () ) ; + | Exp.Lvar pv -> + if verbose then ( + L.d_str "exp_rv_dexp: program var " ; + Sil.d_exp e ; + L.d_ln () ) ; if Pvar.is_frontend_tmp pv then _exp_lv_dexp tenv _seen (* avoid spurious cycle detection *) node e else Some (DExp.Dpvaraddr pv) - | Exp.Var id when Ident.is_normal id - -> if verbose then ( L.d_str "exp_rv_dexp: normal var " ; Sil.d_exp e ; L.d_ln () ) ; + | Exp.Var id when Ident.is_normal id -> + if verbose then ( + L.d_str "exp_rv_dexp: normal var " ; + Sil.d_exp e ; + L.d_ln () ) ; _find_normal_variable_load tenv seen node id | Exp.Lfield (e1, f, _) - -> ( + -> ( if verbose then ( L.d_str "exp_rv_dexp: Lfield " ; Sil.d_exp e1 ; L.d_str (" " ^ Typ.Fieldname.to_string f) ; L.d_ln () ) ; match _exp_rv_dexp tenv seen node e1 with - | None - -> None - | Some de - -> Some (DExp.Ddot (de, f)) ) + | None -> + None + | Some de -> + Some (DExp.Ddot (de, f)) ) | Exp.Lindex (e1, e2) - -> ( + -> ( if verbose then ( L.d_str "exp_rv_dexp: Lindex " ; Sil.d_exp e1 ; L.d_str " " ; Sil.d_exp e2 ; L.d_ln () ) ; match (_exp_rv_dexp tenv seen node e1, _exp_rv_dexp tenv seen node e2) with - | None, _ | _, None - -> None - | Some de1, Some de2 - -> Some (DExp.Darray (de1, de2)) ) + | None, _ | _, None -> + None + | Some de1, Some de2 -> + Some (DExp.Darray (de1, de2)) ) | Exp.BinOp (op, e1, e2) - -> ( + -> ( if verbose then ( L.d_str "exp_rv_dexp: BinOp " ; Sil.d_exp e ; L.d_ln () ) ; match (_exp_rv_dexp tenv seen node e1, _exp_rv_dexp tenv seen node e2) with - | None, _ | _, None - -> None - | Some de1, Some de2 - -> Some (DExp.Dbinop (op, de1, de2)) ) + | None, _ | _, None -> + None + | Some de1, Some de2 -> + Some (DExp.Dbinop (op, de1, de2)) ) | Exp.UnOp (op, e1, _) - -> ( + -> ( if verbose then ( L.d_str "exp_rv_dexp: UnOp " ; Sil.d_exp e ; L.d_ln () ) ; match _exp_rv_dexp tenv seen node e1 with - | None - -> None - | Some de1 - -> Some (DExp.Dunop (op, de1)) ) - | Exp.Cast (_, e1) - -> if verbose then ( L.d_str "exp_rv_dexp: Cast " ; Sil.d_exp e ; L.d_ln () ) ; + | None -> + None + | Some de1 -> + Some (DExp.Dunop (op, de1)) ) + | Exp.Cast (_, e1) -> + if verbose then ( L.d_str "exp_rv_dexp: Cast " ; Sil.d_exp e ; L.d_ln () ) ; _exp_rv_dexp tenv seen node e1 - | Exp.Sizeof {typ; dynamic_length; subtype} - -> if verbose then ( L.d_str "exp_rv_dexp: type " ; Sil.d_exp e ; L.d_ln () ) ; + | Exp.Sizeof {typ; dynamic_length; subtype} -> + if verbose then ( L.d_str "exp_rv_dexp: type " ; Sil.d_exp e ; L.d_ln () ) ; Some (DExp.Dsizeof (typ, Option.bind dynamic_length ~f:(_exp_rv_dexp tenv seen node), subtype)) - | _ - -> if verbose then ( L.d_str "exp_rv_dexp: no match for " ; Sil.d_exp e ; L.d_ln () ) ; + | _ -> + if verbose then ( + L.d_str "exp_rv_dexp: no match for " ; + Sil.d_exp e ; + L.d_ln () ) ; None + let find_normal_variable_load tenv = _find_normal_variable_load tenv Exp.Set.empty let exp_lv_dexp tenv = _exp_lv_dexp tenv Exp.Set.empty @@ -443,29 +498,31 @@ let explain_allocation_mismatch ra_alloc ra_dealloc = (* e.g. malloc and my_malloc *) let primitive = match ra.PredSymb.ra_res with - | PredSymb.Rmemory mk_alloc - -> (if is_alloc then PredSymb.mem_alloc_pname else PredSymb.mem_dealloc_pname) mk_alloc - | _ - -> ra_alloc.PredSymb.ra_pname + | PredSymb.Rmemory mk_alloc -> + (if is_alloc then PredSymb.mem_alloc_pname else PredSymb.mem_dealloc_pname) mk_alloc + | _ -> + ra_alloc.PredSymb.ra_pname in let called = ra.PredSymb.ra_pname in (primitive, called, ra.PredSymb.ra_loc) in - Localise.desc_allocation_mismatch (get_primitive_called true ra_alloc) + Localise.desc_allocation_mismatch + (get_primitive_called true ra_alloc) (get_primitive_called false ra_dealloc) + (** check whether the type of leaked [hpred] appears as a predicate in an inductive predicate in [prop] *) let leak_from_list_abstraction hpred prop = let hpred_type = function - | Sil.Hpointsto (_, _, texp) - -> Some texp - | Sil.Hlseg (_, {Sil.body= [(Sil.Hpointsto (_, _, texp))]}, _, _, _) - -> Some texp - | Sil.Hdllseg (_, {Sil.body_dll= [(Sil.Hpointsto (_, _, texp))]}, _, _, _, _, _) - -> Some texp - | _ - -> None + | Sil.Hpointsto (_, _, texp) -> + Some texp + | Sil.Hlseg (_, {Sil.body= [(Sil.Hpointsto (_, _, texp))]}, _, _, _) -> + Some texp + | Sil.Hdllseg (_, {Sil.body_dll= [(Sil.Hpointsto (_, _, texp))]}, _, _, _, _, _) -> + Some texp + | _ -> + None in let found = ref false in let check_hpred texp hp = @@ -474,16 +531,17 @@ let leak_from_list_abstraction hpred prop = let check_hpara texp _ hpara = List.iter ~f:(check_hpred texp) hpara.Sil.body in let check_hpara_dll texp _ hpara = List.iter ~f:(check_hpred texp) hpara.Sil.body_dll in match hpred_type hpred with - | Some texp - -> let env = Prop.prop_pred_env prop in + | Some texp -> + let env = Prop.prop_pred_env prop in Sil.Predicates.iter env (check_hpara texp) (check_hpara_dll texp) ; if !found then ( L.d_str "leak_from_list_abstraction of predicate of type " ; Sil.d_texp_full texp ; L.d_ln () ) ; !found - | None - -> false + | None -> + false + (** find the type of hpred, if any *) let find_hpred_typ hpred = match hpred with Sil.Hpointsto (_, _, texp) -> Some texp | _ -> None @@ -492,12 +550,14 @@ let find_hpred_typ hpred = match hpred with Sil.Hpointsto (_, _, texp) -> Some t let find_typ_without_ptr prop pvar = let res = ref None in let do_hpred = function - | Sil.Hpointsto (e, _, te) when Exp.equal e (Exp.Lvar pvar) - -> res := Some te - | _ - -> () + | Sil.Hpointsto (e, _, te) when Exp.equal e (Exp.Lvar pvar) -> + res := Some te + | _ -> + () in - List.iter ~f:do_hpred prop.Prop.sigma ; !res + List.iter ~f:do_hpred prop.Prop.sigma ; + !res + (** Produce a description of a leak by looking at the current state. If the current instruction is a variable nullify, blame the variable. @@ -516,17 +576,17 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = Some desc_string else match vpath with - | Some de when not (DExp.has_tmp_var de) - -> Some (DExp.to_string de) - | _ - -> None + | Some de when not (DExp.has_tmp_var de) -> + Some (DExp.to_string de) + | _ -> + None in let res_action_opt, resource_opt, vpath = match alloc_att_opt with - | Some PredSymb.Aresource ({ra_kind= Racquire} as ra) - -> (Some ra, Some ra.ra_res, ra.ra_vpath) - | _ - -> (None, None, None) + | Some PredSymb.Aresource ({ra_kind= Racquire} as ra) -> + (Some ra, Some ra.ra_res, ra.ra_vpath) + | _ -> + (None, None, None) in let is_file = match resource_opt with Some PredSymb.Rfile -> true | _ -> false in let check_pvar pvar = @@ -534,42 +594,46 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = (Pvar.is_local pvar || Pvar.is_global pvar) && not (Pvar.is_frontend_tmp pvar) && match (hpred_typ_opt, find_typ_without_ptr prop pvar) with - | Some Exp.Sizeof {typ= t1}, Some Exp.Sizeof {typ= {Typ.desc= Tptr (t2, _)}} - -> Typ.equal t1 t2 + | Some Exp.Sizeof {typ= t1}, Some Exp.Sizeof {typ= {Typ.desc= Tptr (t2, _)}} -> + Typ.equal t1 t2 | Some Exp.Sizeof {typ= {Typ.desc= Tint _}}, Some Exp.Sizeof {typ= {Typ.desc= Tint _}} - when is_file - -> (* must be a file opened with "open" *) + when is_file -> + (* must be a file opened with "open" *) true - | _ - -> false + | _ -> + false in let value_str = match instro with - | None - -> if verbose then ( L.d_str "explain_leak: no current instruction" ; L.d_ln () ) ; + | None -> + if verbose then ( + L.d_str "explain_leak: no current instruction" ; + L.d_ln () ) ; value_str_from_pvars_vpath [] vpath | Some Sil.Nullify (pvar, _) when check_pvar pvar - -> ( + -> ( if verbose then ( L.d_str "explain_leak: current instruction is Nullify for pvar " ; Pvar.d pvar ; L.d_ln () ) ; match exp_lv_dexp tenv (State.get_node ()) (Exp.Lvar pvar) with - | Some de when not (DExp.has_tmp_var de) - -> Some (DExp.to_string de) - | _ - -> None ) - | Some Sil.Abstract _ - -> if verbose then ( L.d_str "explain_leak: current instruction is Abstract" ; L.d_ln () ) ; + | Some de when not (DExp.has_tmp_var de) -> + Some (DExp.to_string de) + | _ -> + None ) + | Some Sil.Abstract _ -> + if verbose then ( + L.d_str "explain_leak: current instruction is Abstract" ; + L.d_ln () ) ; let get_nullify = function - | Sil.Nullify (pvar, _) when check_pvar pvar - -> if verbose then ( + | Sil.Nullify (pvar, _) when check_pvar pvar -> + if verbose then ( L.d_str "explain_leak: found nullify before Abstract for pvar " ; Pvar.d pvar ; L.d_ln () ) ; [pvar] - | _ - -> [] + | _ -> + [] in let nullify_pvars = List.concat_map ~f:get_nullify node_instrs in let nullify_pvars_notmp = @@ -577,27 +641,31 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = in value_str_from_pvars_vpath nullify_pvars_notmp vpath | Some Sil.Store (lexp, _, _, _) when is_none vpath - -> ( + -> ( if verbose then ( - L.d_str "explain_leak: current instruction Set for " ; Sil.d_exp lexp ; L.d_ln () ) ; + L.d_str "explain_leak: current instruction Set for " ; + Sil.d_exp lexp ; + L.d_ln () ) ; match exp_lv_dexp tenv node lexp with - | Some dexp when not (DExp.has_tmp_var dexp) - -> Some (DExp.to_string dexp) - | _ - -> None ) - | Some instr - -> if verbose then ( - L.d_str "explain_leak: case not matched in instr " ; Sil.d_instr instr ; L.d_ln () ) ; + | Some dexp when not (DExp.has_tmp_var dexp) -> + Some (DExp.to_string dexp) + | _ -> + None ) + | Some instr -> + if verbose then ( + L.d_str "explain_leak: case not matched in instr " ; + Sil.d_instr instr ; + L.d_ln () ) ; value_str_from_pvars_vpath [] vpath in let exn_cat, bucket = (* decide whether Exn_user or Exn_developer *) match resource_opt with - | Some _ - -> (* we know it has been allocated *) + | Some _ -> + (* we know it has been allocated *) (Exceptions.Exn_user, bucket) - | None - -> if leak_from_list_abstraction hpred prop && value_str <> None then + | None -> + if leak_from_list_abstraction hpred prop && value_str <> None then (* we don't know it's been allocated, but it's coming from list abstraction and we have a name *) (Exceptions.Exn_user, bucket) @@ -605,6 +673,7 @@ let explain_leak tenv hpred prop alloc_att_opt bucket = in (exn_cat, Localise.desc_leak hpred_typ_opt value_str resource_opt res_action_opt loc bucket) + (** find the dexp, if any, where the given value is stored also return the type of the value if found *) let vpath_find tenv prop _exp : DExp.t option * Typ.t option = @@ -613,152 +682,165 @@ let vpath_find tenv prop _exp : DExp.t option * Typ.t option = let do_fse res sigma_acc' sigma_todo' lexp texp (f, se) = match se with | Sil.Eexp (e, _) when Exp.equal exp e - -> ( + -> ( let sigma' = List.rev_append sigma_acc' sigma_todo' in match lexp with - | Exp.Lvar pv - -> let typo = + | Exp.Lvar pv -> + let typo = match texp with | Exp.Sizeof {typ= {Typ.desc= Tstruct name}} -> ( match Tenv.lookup tenv name with - | Some {fields} - -> List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f' f) fields + | Some {fields} -> + List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f' f) fields |> Option.map ~f:snd3 - | _ - -> None ) - | _ - -> None + | _ -> + None ) + | _ -> + None in res := (Some (DExp.Ddot (DExp.Dpvar pv, f)), typo) | Exp.Var id -> ( match find [] sigma' (Exp.Var id) with - | None, _ - -> () - | Some de, typo - -> res := (Some (DExp.Darrow (de, f)), typo) ) - | lexp - -> if verbose then ( - L.d_str "vpath_find do_fse: no match on Eexp " ; Sil.d_exp lexp ; L.d_ln () ) ) - | _ - -> () + | None, _ -> + () + | Some de, typo -> + res := (Some (DExp.Darrow (de, f)), typo) ) + | lexp -> + if verbose then ( + L.d_str "vpath_find do_fse: no match on Eexp " ; + Sil.d_exp lexp ; + L.d_ln () ) ) + | _ -> + () in let do_sexp sigma_acc' sigma_todo' lexp sexp texp = match sexp with | Sil.Eexp (e, _) when Exp.equal exp e - -> ( + -> ( let sigma' = List.rev_append sigma_acc' sigma_todo' in match lexp with - | Exp.Lvar pv when not (Pvar.is_frontend_tmp pv) - -> let typo = match texp with Exp.Sizeof {typ} -> Some typ | _ -> None in + | Exp.Lvar pv when not (Pvar.is_frontend_tmp pv) -> + let typo = match texp with Exp.Sizeof {typ} -> Some typ | _ -> None in (Some (DExp.Dpvar pv), typo) | Exp.Var id -> ( match find [] sigma' (Exp.Var id) with - | None, typo - -> (None, typo) - | Some de, typo - -> (Some (DExp.Dderef de), typo) ) - | lexp - -> if verbose then ( - L.d_str "vpath_find do_sexp: no match on Eexp " ; Sil.d_exp lexp ; L.d_ln () ) ; + | None, typo -> + (None, typo) + | Some de, typo -> + (Some (DExp.Dderef de), typo) ) + | lexp -> + if verbose then ( + L.d_str "vpath_find do_sexp: no match on Eexp " ; + Sil.d_exp lexp ; + L.d_ln () ) ; (None, None) ) - | Sil.Estruct (fsel, _) - -> let res = ref (None, None) in + | Sil.Estruct (fsel, _) -> + let res = ref (None, None) in List.iter ~f:(do_fse res sigma_acc' sigma_todo' lexp texp) fsel ; !res - | _ - -> (None, None) + | _ -> + (None, None) in let do_hpred sigma_acc' sigma_todo' = let substituted_from_normal id = let filter = function - | ni, Exp.Var id' - -> Ident.is_normal ni && Ident.equal id' id - | _ - -> false + | ni, Exp.Var id' -> + Ident.is_normal ni && Ident.equal id' id + | _ -> + false in List.exists ~f:filter (Sil.sub_to_list prop.Prop.sub) in function | Sil.Hpointsto (Exp.Lvar pv, sexp, texp) - when Pvar.is_local pv || Pvar.is_global pv || Pvar.is_seed pv - -> do_sexp sigma_acc' sigma_todo' (Exp.Lvar pv) sexp texp + when Pvar.is_local pv || Pvar.is_global pv || Pvar.is_seed pv -> + do_sexp sigma_acc' sigma_todo' (Exp.Lvar pv) sexp texp | Sil.Hpointsto (Exp.Var id, sexp, texp) - when Ident.is_normal id || Ident.is_footprint id && substituted_from_normal id - -> do_sexp sigma_acc' sigma_todo' (Exp.Var id) sexp texp - | _ - -> (None, None) + when Ident.is_normal id || Ident.is_footprint id && substituted_from_normal id -> + do_sexp sigma_acc' sigma_todo' (Exp.Var id) sexp texp + | _ -> + (None, None) in match sigma_todo with - | [] - -> (None, None) + | [] -> + (None, None) | hpred :: sigma_todo' -> match do_hpred sigma_acc sigma_todo' hpred with - | Some de, typo - -> (Some de, typo) - | None, _ - -> find (hpred :: sigma_acc) sigma_todo' exp + | Some de, typo -> + (Some de, typo) + | None, _ -> + find (hpred :: sigma_acc) sigma_todo' exp in let res = find [] prop.Prop.sigma _exp in ( if verbose then match res with - | None, _ - -> L.d_str "vpath_find: cannot find " ; Sil.d_exp _exp ; L.d_ln () - | Some de, typo - -> L.d_str "vpath_find: found " ; + | None, _ -> + L.d_str "vpath_find: cannot find " ; + Sil.d_exp _exp ; + L.d_ln () + | Some de, typo -> + L.d_str "vpath_find: found " ; L.d_str (DExp.to_string de) ; L.d_str " : " ; match typo with None -> L.d_str " No type" | Some typ -> Typ.d_full typ ; L.d_ln () ) ; res + (** produce a description of the access from the instrumentation at position [dexp] in [prop] *) let explain_dexp_access prop dexp is_nullable = let sigma = prop.Prop.sigma in let sexpo_to_inst = function - | None - -> None - | Some Sil.Eexp (_, inst) - -> Some inst - | Some se - -> if verbose then ( L.d_str "sexpo_to_inst: can't find inst " ; Sil.d_sexp se ; L.d_ln () ) ; + | None -> + None + | Some Sil.Eexp (_, inst) -> + Some inst + | Some se -> + if verbose then ( + L.d_str "sexpo_to_inst: can't find inst " ; + Sil.d_sexp se ; + L.d_ln () ) ; None in let find_ptsto (e: Exp.t) : Sil.strexp option = let res = ref None in let do_hpred = function - | Sil.Hpointsto (e', se, _) when Exp.equal e e' - -> res := Some se - | _ - -> () + | Sil.Hpointsto (e', se, _) when Exp.equal e e' -> + res := Some se + | _ -> + () in List.iter ~f:do_hpred sigma ; !res in let rec lookup_fld fsel f = match fsel with - | [] - -> if verbose then L.d_strln ("lookup_fld: can't find field " ^ Typ.Fieldname.to_string f) ; + | [] -> + if verbose then L.d_strln ("lookup_fld: can't find field " ^ Typ.Fieldname.to_string f) ; None - | (f1, se) :: fsel' - -> if Typ.Fieldname.equal f1 f then Some se else lookup_fld fsel' f + | (f1, se) :: fsel' -> + if Typ.Fieldname.equal f1 f then Some se else lookup_fld fsel' f in let rec lookup_esel esel e = match esel with - | [] - -> if verbose then ( L.d_str "lookup_esel: can't find index " ; Sil.d_exp e ; L.d_ln () ) ; + | [] -> + if verbose then ( + L.d_str "lookup_esel: can't find index " ; + Sil.d_exp e ; + L.d_ln () ) ; None - | (e1, se) :: esel' - -> if Exp.equal e1 e then Some se else lookup_esel esel' e + | (e1, se) :: esel' -> + if Exp.equal e1 e then Some se else lookup_esel esel' e in let rec lookup : DExp.t -> Sil.strexp option = function - | DExp.Dconst c - -> Some (Sil.Eexp (Exp.Const c, Sil.inst_none)) + | DExp.Dconst c -> + Some (Sil.Eexp (Exp.Const c, Sil.inst_none)) | DExp.Darray (de1, de2) -> ( match (lookup de1, lookup de2) with - | None, _ | _, None - -> None - | Some Sil.Earray (_, esel, _), Some Sil.Eexp (e, _) - -> lookup_esel esel e - | Some se1, Some se2 - -> if verbose then ( + | None, _ | _, None -> + None + | Some Sil.Earray (_, esel, _), Some Sil.Eexp (e, _) -> + lookup_esel esel e + | Some se1, Some se2 -> + if verbose then ( L.d_str "lookup: case not matched on Darray " ; Sil.d_sexp se1 ; L.d_str " " ; @@ -767,105 +849,112 @@ let explain_dexp_access prop dexp is_nullable = None ) | DExp.Darrow (DExp.Dpvaraddr pvar, f) -> ( match lookup (DExp.Dpvaraddr pvar) with - | None - -> None - | Some Sil.Estruct (fsel, _) - -> lookup_fld fsel f - | Some _ - -> if verbose then ( L.d_str "lookup: case not matched on Darrow " ; L.d_ln () ) ; + | None -> + None + | Some Sil.Estruct (fsel, _) -> + lookup_fld fsel f + | Some _ -> + if verbose then ( + L.d_str "lookup: case not matched on Darrow " ; + L.d_ln () ) ; None ) | DExp.Darrow (de1, f) -> ( match lookup (DExp.Dderef de1) with - | None - -> None - | Some Sil.Estruct (fsel, _) - -> lookup_fld fsel f - | Some _ - -> if verbose then ( L.d_str "lookup: case not matched on Darrow " ; L.d_ln () ) ; + | None -> + None + | Some Sil.Estruct (fsel, _) -> + lookup_fld fsel f + | Some _ -> + if verbose then ( + L.d_str "lookup: case not matched on Darrow " ; + L.d_ln () ) ; None ) | DExp.Ddot (de1, f) -> ( match lookup de1 with - | None - -> None - | Some Sil.Estruct (fsel, _) - -> lookup_fld fsel f - | Some (Sil.Eexp (Const Cfun _, _) as fun_strexp) - -> Some fun_strexp - | Some _ - -> if verbose then ( L.d_str "lookup: case not matched on Ddot " ; L.d_ln () ) ; + | None -> + None + | Some Sil.Estruct (fsel, _) -> + lookup_fld fsel f + | Some (Sil.Eexp (Const Cfun _, _) as fun_strexp) -> + Some fun_strexp + | Some _ -> + if verbose then ( + L.d_str "lookup: case not matched on Ddot " ; + L.d_ln () ) ; None ) - | DExp.Dpvar pvar - -> if verbose then ( L.d_str "lookup: found Dpvar " ; L.d_ln () ) ; + | DExp.Dpvar pvar -> + if verbose then ( L.d_str "lookup: found Dpvar " ; L.d_ln () ) ; find_ptsto (Exp.Lvar pvar) | DExp.Dderef de -> ( match lookup de with None -> None | Some Sil.Eexp (e, _) -> find_ptsto e | Some _ -> None ) - | DExp.Dbinop (Binop.PlusPI, DExp.Dpvar _, DExp.Dconst _) as de - -> if verbose then L.d_strln ("lookup: case )pvar + constant) " ^ DExp.to_string de) ; + | DExp.Dbinop (Binop.PlusPI, DExp.Dpvar _, DExp.Dconst _) as de -> + if verbose then L.d_strln ("lookup: case )pvar + constant) " ^ DExp.to_string de) ; None | DExp.Dfcall (DExp.Dconst c, _, loc, _) - -> ( + -> ( if verbose then L.d_strln "lookup: found Dfcall " ; match c with - | Const.Cfun _ - -> (* Treat function as an update *) + | Const.Cfun _ -> + (* Treat function as an update *) Some (Sil.Eexp (Exp.Const c, Sil.Ireturn_from_call loc.Location.line)) - | _ - -> None ) - | DExp.Dpvaraddr pvar - -> L.d_strln ("lookup: found Dvaraddr " ^ DExp.to_string (DExp.Dpvaraddr pvar)) ; + | _ -> + None ) + | DExp.Dpvaraddr pvar -> + L.d_strln ("lookup: found Dvaraddr " ^ DExp.to_string (DExp.Dpvaraddr pvar)) ; find_ptsto (Exp.Lvar pvar) - | de - -> if verbose then L.d_strln ("lookup: unknown case not matched " ^ DExp.to_string de) ; + | de -> + if verbose then L.d_strln ("lookup: unknown case not matched " ^ DExp.to_string de) ; None in let access_opt = match sexpo_to_inst (lookup dexp) with - | None - -> if verbose then + | None -> + if verbose then L.d_strln ("explain_dexp_access: cannot find inst of " ^ DExp.to_string dexp) ; None - | Some Sil.Iupdate (_, ncf, n, _) - -> Some (Localise.Last_assigned (n, ncf)) - | Some Sil.Irearrange (_, _, n, _) - -> Some (Localise.Last_accessed (n, is_nullable)) - | Some Sil.Ireturn_from_call n - -> Some (Localise.Returned_from_call n) - | Some Sil.Ialloc when Config.curr_language_is Config.Java - -> Some Localise.Initialized_automatically - | Some inst - -> if verbose then + | Some Sil.Iupdate (_, ncf, n, _) -> + Some (Localise.Last_assigned (n, ncf)) + | Some Sil.Irearrange (_, _, n, _) -> + Some (Localise.Last_accessed (n, is_nullable)) + | Some Sil.Ireturn_from_call n -> + Some (Localise.Returned_from_call n) + | Some Sil.Ialloc when Config.curr_language_is Config.Java -> + Some Localise.Initialized_automatically + | Some inst -> + if verbose then L.d_strln ("explain_dexp_access: inst is not an update " ^ Sil.inst_to_string inst) ; None in access_opt + let explain_dereference_access outermost_array is_nullable _de_opt prop = let de_opt = let rec remove_outermost_array_access = function (* remove outermost array access from [de] *) - | DExp.Dbinop (Binop.PlusPI, de1, _) - -> (* remove pointer arithmetic before array access *) + | DExp.Dbinop (Binop.PlusPI, de1, _) -> + (* remove pointer arithmetic before array access *) remove_outermost_array_access de1 - | DExp.Darray (DExp.Dderef de1, _) - -> (* array access is a deref already: remove both *) + | DExp.Darray (DExp.Dderef de1, _) -> + (* array access is a deref already: remove both *) de1 - | DExp.Darray (de1, _) - -> (* remove array access *) + | DExp.Darray (de1, _) -> + (* remove array access *) de1 - | DExp.Dderef de - -> (* remove implicit array access *) + | DExp.Dderef de -> + (* remove implicit array access *) de - | DExp.Ddot (de, _) - -> (* remove field access before array access *) + | DExp.Ddot (de, _) -> + (* remove field access before array access *) remove_outermost_array_access de - | de - -> de + | de -> + de in match _de_opt with - | None - -> None - | Some de - -> Some (if outermost_array then remove_outermost_array_access de else de) + | None -> + None + | Some de -> + Some (if outermost_array then remove_outermost_array_access de else de) in let value_str = match de_opt with Some de -> DExp.to_string de | None -> "" in let access_opt = @@ -873,16 +962,17 @@ let explain_dereference_access outermost_array is_nullable _de_opt prop = in (value_str, access_opt) + (** Create a description of a dereference operation *) let create_dereference_desc proc_name tenv ?(use_buckets= false) ?(outermost_array= false) ?(is_nullable= false) ?(is_premature_nil= false) de_opt deref_str prop loc = let value_str, access_opt = explain_dereference_access outermost_array is_nullable de_opt prop in let access_opt' = match access_opt with - | Some Localise.Last_accessed _ when outermost_array - -> None (* don't report last accessed for arrays *) - | _ - -> access_opt + | Some Localise.Last_accessed _ when outermost_array -> + None (* don't report last accessed for arrays *) + | _ -> + access_opt in let desc = Localise.dereference_string proc_name deref_str value_str access_opt' loc in let desc = @@ -890,29 +980,30 @@ let create_dereference_desc proc_name tenv ?(use_buckets= false) ?(outermost_arr match de_opt with | Some DExp.Dpvar pvar | Some DExp.Dpvaraddr pvar -> ( match Attribute.get_objc_null tenv prop (Exp.Lvar pvar) with - | Some Apred (Aobjc_null, [_; vfs]) - -> Localise.parameter_field_not_null_checked_desc desc vfs - | _ - -> desc ) - | Some DExp.Dretcall (Dconst Cfun pname, this_dexp :: _, loc, _) - -> if is_mutex_method pname then + | Some Apred (Aobjc_null, [_; vfs]) -> + Localise.parameter_field_not_null_checked_desc desc vfs + | _ -> + desc ) + | Some DExp.Dretcall (Dconst Cfun pname, this_dexp :: _, loc, _) -> + if is_mutex_method pname then Localise.desc_double_lock (Some pname) (DExp.to_string this_dexp) loc else if is_vector_method pname then Localise.desc_empty_vector_access (Some pname) (DExp.to_string this_dexp) loc else desc - | Some DExp.Darrow (dexp, fieldname) | Some DExp.Ddot (dexp, fieldname) - -> if is_special_field mutex_matcher (Some "null_if_locked") fieldname then + | Some DExp.Darrow (dexp, fieldname) | Some DExp.Ddot (dexp, fieldname) -> + if is_special_field mutex_matcher (Some "null_if_locked") fieldname then Localise.desc_double_lock None (DExp.to_string dexp) loc else if is_special_field vector_matcher (Some "beginPtr") fieldname || is_special_field vector_matcher (Some "endPtr") fieldname then Localise.desc_empty_vector_access None (DExp.to_string dexp) loc else desc - | _ - -> desc + | _ -> + desc else desc in if use_buckets then Buckets.classify_access desc access_opt' de_opt is_nullable else desc + (** explain memory access performed by the current instruction if outermost_array is true, the outermost array access is removed if outermost_dereference is true, stop at the outermost dereference @@ -922,61 +1013,94 @@ let _explain_access proc_name tenv ?(use_buckets= false) ?(outermost_array= fals loc = let rec find_outermost_dereference node e = match e with - | Exp.Const _ - -> if verbose then ( L.d_str "find_outermost_dereference: constant " ; Sil.d_exp e ; L.d_ln () ) ; + | Exp.Const _ -> + if verbose then ( + L.d_str "find_outermost_dereference: constant " ; + Sil.d_exp e ; + L.d_ln () ) ; exp_lv_dexp tenv node e - | Exp.Var id when Ident.is_normal id - -> (* look up the normal variable declaration *) + | Exp.Var id when Ident.is_normal id -> + (* look up the normal variable declaration *) if verbose then ( - L.d_str "find_outermost_dereference: normal var " ; Sil.d_exp e ; L.d_ln () ) ; + L.d_str "find_outermost_dereference: normal var " ; + Sil.d_exp e ; + L.d_ln () ) ; find_normal_variable_load tenv node id - | Exp.Lfield (e', _, _) - -> if verbose then ( L.d_str "find_outermost_dereference: Lfield " ; Sil.d_exp e ; L.d_ln () ) ; + | Exp.Lfield (e', _, _) -> + if verbose then ( + L.d_str "find_outermost_dereference: Lfield " ; + Sil.d_exp e ; + L.d_ln () ) ; find_outermost_dereference node e' - | Exp.Lindex (e', _) - -> if verbose then ( L.d_str "find_outermost_dereference: Lindex " ; Sil.d_exp e ; L.d_ln () ) ; + | Exp.Lindex (e', _) -> + if verbose then ( + L.d_str "find_outermost_dereference: Lindex " ; + Sil.d_exp e ; + L.d_ln () ) ; find_outermost_dereference node e' - | Exp.Lvar _ - -> if verbose then ( L.d_str "find_outermost_dereference: Lvar " ; Sil.d_exp e ; L.d_ln () ) ; + | Exp.Lvar _ -> + if verbose then ( + L.d_str "find_outermost_dereference: Lvar " ; + Sil.d_exp e ; + L.d_ln () ) ; exp_lv_dexp tenv node e - | Exp.BinOp (Binop.PlusPI, Exp.Lvar _, _) - -> if verbose then ( - L.d_str "find_outermost_dereference: Lvar+index " ; Sil.d_exp e ; L.d_ln () ) ; + | Exp.BinOp (Binop.PlusPI, Exp.Lvar _, _) -> + if verbose then ( + L.d_str "find_outermost_dereference: Lvar+index " ; + Sil.d_exp e ; + L.d_ln () ) ; exp_lv_dexp tenv node e - | Exp.Cast (_, e') - -> if verbose then ( L.d_str "find_outermost_dereference: cast " ; Sil.d_exp e ; L.d_ln () ) ; + | Exp.Cast (_, e') -> + if verbose then ( + L.d_str "find_outermost_dereference: cast " ; + Sil.d_exp e ; + L.d_ln () ) ; find_outermost_dereference node e' - | _ - -> if verbose then ( - L.d_str "find_outermost_dereference: no match for " ; Sil.d_exp e ; L.d_ln () ) ; + | _ -> + if verbose then ( + L.d_str "find_outermost_dereference: no match for " ; + Sil.d_exp e ; + L.d_ln () ) ; None in let find_exp_dereferenced () = match State.get_instr () with - | Some Sil.Store (e, _, _, _) - -> if verbose then ( L.d_str "explain_dereference Sil.Store " ; Sil.d_exp e ; L.d_ln () ) ; + | Some Sil.Store (e, _, _, _) -> + if verbose then ( + L.d_str "explain_dereference Sil.Store " ; + Sil.d_exp e ; + L.d_ln () ) ; Some e - | Some Sil.Load (_, e, _, _) - -> if verbose then ( L.d_str "explain_dereference Binop.Leteref " ; Sil.d_exp e ; L.d_ln () ) ; + | Some Sil.Load (_, e, _, _) -> + if verbose then ( + L.d_str "explain_dereference Binop.Leteref " ; + Sil.d_exp e ; + L.d_ln () ) ; Some e | Some Sil.Call (_, Exp.Const Const.Cfun fn, [(e, _)], _, _) when List.exists ~f:(Typ.Procname.equal fn) - [BuiltinDecl.free; BuiltinDecl.__delete; BuiltinDecl.__delete_array] - -> if verbose then ( L.d_str "explain_dereference Sil.Call " ; Sil.d_exp e ; L.d_ln () ) ; + [BuiltinDecl.free; BuiltinDecl.__delete; BuiltinDecl.__delete_array] -> + if verbose then ( + L.d_str "explain_dereference Sil.Call " ; + Sil.d_exp e ; + L.d_ln () ) ; Some e - | Some Sil.Call (_, (Exp.Var _ as e), _, _, _) - -> if verbose then ( L.d_str "explain_dereference Sil.Call " ; Sil.d_exp e ; L.d_ln () ) ; + | Some Sil.Call (_, (Exp.Var _ as e), _, _, _) -> + if verbose then ( + L.d_str "explain_dereference Sil.Call " ; + Sil.d_exp e ; + L.d_ln () ) ; Some e - | _ - -> None + | _ -> + None in let node = State.get_node () in match find_exp_dereferenced () with - | None - -> if verbose then L.d_strln "_explain_access: find_exp_dereferenced returned None" ; + | None -> + if verbose then L.d_strln "_explain_access: find_exp_dereferenced returned None" ; Localise.no_desc - | Some e - -> L.d_strln "Finding deref'd exp" ; + | Some e -> + L.d_strln "Finding deref'd exp" ; let de_opt = if outermost_dereference then find_outermost_dereference node e else exp_lv_dexp tenv node e @@ -984,6 +1108,7 @@ let _explain_access proc_name tenv ?(use_buckets= false) ?(outermost_array= fals create_dereference_desc proc_name tenv ~use_buckets ~outermost_array ~is_nullable ~is_premature_nil de_opt deref_str prop loc + (** Produce a description of which expression is dereferenced in the current instruction, if any. The subexpression to focus on is obtained by removing field and index accesses. *) let explain_dereference proc_name tenv ?(use_buckets= false) ?(is_nullable= false) @@ -991,11 +1116,13 @@ let explain_dereference proc_name tenv ?(use_buckets= false) ?(is_nullable= fals _explain_access proc_name tenv ~use_buckets ~outermost_array:false ~outermost_dereference:true ~is_nullable ~is_premature_nil deref_str prop loc + (** Produce a description of the array access performed in the current instruction, if any. The subexpression to focus on is obtained by removing the outermost array access. *) let explain_array_access tenv deref_str prop loc = _explain_access tenv ~outermost_array:true deref_str prop loc + (** Produce a description of the memory access performed in the current instruction, if any. *) let explain_memory_access tenv deref_str prop loc = _explain_access tenv deref_str prop loc @@ -1009,12 +1136,13 @@ type pvar_off = let dexp_apply_pvar_off dexp pvar_off = let rec add_ddot de = function [] -> de | f :: fl -> add_ddot (DExp.Ddot (de, f)) fl in match pvar_off with - | Fpvar - -> dexp - | Fstruct (f :: fl) - -> add_ddot (DExp.Darrow (dexp, f)) fl - | Fstruct [] - -> dexp + | Fpvar -> + dexp + | Fstruct (f :: fl) -> + add_ddot (DExp.Darrow (dexp, f)) fl + | Fstruct [] -> + dexp + (* case should not happen *) @@ -1033,8 +1161,9 @@ let explain_nth_function_parameter proc_name tenv use_buckets deref_str prop n p in create_dereference_desc proc_name tenv ~use_buckets dexp_opt' deref_str prop loc with exn when SymOp.exn_not_failure exn -> Localise.no_desc ) - | _ - -> Localise.no_desc + | _ -> + Localise.no_desc + (** Find a program variable whose value is [exp] or pointing to a struct containing [exp] *) let find_with_exp prop exp = @@ -1047,27 +1176,29 @@ let find_with_exp prop exp = if is_none !res then res := Some (pv, Fstruct (List.rev fld_lst)) in let rec search_struct pv fld_lst = function - | Sil.Eexp (e, _) - -> if Exp.equal e exp then found_in_struct pv fld_lst - | Sil.Estruct (fsel, _) - -> List.iter ~f:(fun (f, se) -> search_struct pv (f :: fld_lst) se) fsel - | _ - -> () + | Sil.Eexp (e, _) -> + if Exp.equal e exp then found_in_struct pv fld_lst + | Sil.Estruct (fsel, _) -> + List.iter ~f:(fun (f, se) -> search_struct pv (f :: fld_lst) se) fsel + | _ -> + () in let do_hpred_pointed_by_pvar pv e = function - | Sil.Hpointsto (e1, se, _) - -> if Exp.equal e e1 then search_struct pv [] se - | _ - -> () + | Sil.Hpointsto (e1, se, _) -> + if Exp.equal e e1 then search_struct pv [] se + | _ -> + () in let do_hpred = function - | Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (e, _), _) - -> if Exp.equal e exp then found_in_pvar pv + | Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (e, _), _) -> + if Exp.equal e exp then found_in_pvar pv else List.iter ~f:(do_hpred_pointed_by_pvar pv e) prop.Prop.sigma - | _ - -> () + | _ -> + () in - List.iter ~f:do_hpred prop.Prop.sigma ; !res + List.iter ~f:do_hpred prop.Prop.sigma ; + !res + (** return a description explaining value [exp] in [prop] in terms of a source expression using the formal parameters of the call *) @@ -1075,16 +1206,16 @@ let explain_dereference_as_caller_expression proc_name tenv ?(use_buckets= false actual_pre spec_pre exp node loc formal_params = let find_formal_param_number name = let rec find n = function - | [] - -> 0 - | v :: pars - -> if Mangled.equal (Pvar.get_name v) name then n else find (n + 1) pars + | [] -> + 0 + | v :: pars -> + if Mangled.equal (Pvar.get_name v) name then n else find (n + 1) pars in find 1 formal_params in match find_with_exp spec_pre exp with - | Some (pv, pvar_off) - -> if verbose then L.d_strln ("pvar: " ^ Pvar.to_string pv) ; + | Some (pv, pvar_off) -> + if verbose then L.d_strln ("pvar: " ^ Pvar.to_string pv) ; let pv_name = Pvar.get_name pv in if Pvar.is_global pv then let dexp = exp_lv_dexp tenv node (Exp.Lvar pv) in @@ -1097,35 +1228,38 @@ let explain_dereference_as_caller_expression proc_name tenv ?(use_buckets= false else if Attribute.has_dangling_uninit tenv spec_pre exp then Localise.desc_uninitialized_dangling_pointer_deref deref_str (Pvar.to_string pv) loc else Localise.no_desc - | None - -> if verbose then ( + | None -> + if verbose then ( L.d_str "explain_dereference_as_caller_expression " ; Sil.d_exp exp ; L.d_str ": cannot explain None " ; L.d_ln () ) ; Localise.no_desc + (** explain a class cast exception *) let explain_class_cast_exception tenv pname_opt typ1 typ2 exp node loc = let exp_str_opt = match exp_rv_dexp tenv node exp with Some dexp -> Some (DExp.to_string dexp) | None -> None in match (exp_rv_dexp tenv node typ1, exp_rv_dexp tenv node typ2) with - | Some de1, Some de2 - -> let typ_str1 = DExp.to_string de1 in + | Some de1, Some de2 -> + let typ_str1 = DExp.to_string de1 in let typ_str2 = DExp.to_string de2 in Localise.desc_class_cast_exception pname_opt typ_str1 typ_str2 exp_str_opt loc - | _ - -> Localise.no_desc + | _ -> + Localise.no_desc + (** explain a division by zero *) let explain_divide_by_zero tenv exp node loc = match exp_rv_dexp tenv node exp with - | Some de - -> let exp_str = DExp.to_string de in + | Some de -> + let exp_str = DExp.to_string de in Localise.desc_divide_by_zero exp_str loc - | None - -> Localise.no_desc + | None -> + Localise.no_desc + (** explain a return expression required *) let explain_return_expression_required loc typ = @@ -1135,6 +1269,7 @@ let explain_return_expression_required loc typ = in Localise.desc_return_expression_required typ_str loc + (** Explain retain cycle value error *) let explain_retain_cycle cycle loc dotty_str = Localise.desc_retain_cycle cycle loc dotty_str @@ -1154,6 +1289,7 @@ let explain_condition_always_true_false tenv i cond node loc = in Localise.desc_condition_always_true_false i cond_str_opt loc + let explain_unreachable_code_after loc = Localise.desc_unreachable_code_after loc (** explain the escape of a stack variable address from its scope *) @@ -1161,15 +1297,16 @@ let explain_stack_variable_address_escape loc pvar addr_dexp_opt = let addr_dexp_str = match addr_dexp_opt with | Some DExp.Dpvar pv - when Pvar.is_local pv && Mangled.equal (Pvar.get_name pv) Ident.name_return - -> Some "the caller via a return" - | Some dexp - -> Some (DExp.to_string dexp) - | None - -> None + when Pvar.is_local pv && Mangled.equal (Pvar.get_name pv) Ident.name_return -> + Some "the caller via a return" + | Some dexp -> + Some (DExp.to_string dexp) + | None -> + None in Localise.desc_stack_variable_address_escape pvar addr_dexp_str loc + (** explain unary minus applied to unsigned expression *) let explain_unary_minus_applied_to_unsigned_expression tenv exp typ node loc = let exp_str_opt = @@ -1181,14 +1318,17 @@ let explain_unary_minus_applied_to_unsigned_expression tenv exp typ node loc = in Localise.desc_unary_minus_applied_to_unsigned_expression exp_str_opt typ_str loc + (** explain a test for NULL of a dereferenced pointer *) let explain_null_test_after_dereference tenv exp node line loc = match exp_rv_dexp tenv node exp with - | Some de - -> let expr_str = DExp.to_string de in + | Some de -> + let expr_str = DExp.to_string de in Localise.desc_null_test_after_dereference expr_str line loc - | None - -> Localise.no_desc + | None -> + Localise.no_desc + let warning_err loc fmt_string = L.(debug Analysis Medium) ("%a: Warning: " ^^ fmt_string) Location.pp loc + diff --git a/infer/src/backend/exe_env.ml b/infer/src/backend/exe_env.ml index ec1171d63..6dc491c1c 100644 --- a/infer/src/backend/exe_env.ml +++ b/infer/src/backend/exe_env.ml @@ -32,6 +32,7 @@ let tenv_filename file_base = per_source_tenv_filename else DB.global_tenv_fname + module FilenameHash = Hashtbl.Make (struct type t = DB.filename @@ -52,13 +53,16 @@ let new_file_data source cg_fname = cfg_file ; cfg= None (* Cfg.load_cfg_from_file cfg_file *) } + let create_file_data table source cg_fname = match FilenameHash.find table cg_fname with - | file_data - -> file_data - | exception Not_found - -> let file_data = new_file_data source cg_fname in - FilenameHash.add table cg_fname file_data ; file_data + | file_data -> + file_data + | exception Not_found -> + let file_data = new_file_data source cg_fname in + FilenameHash.add table cg_fname file_data ; + file_data + (** execution environment *) type t = @@ -77,37 +81,39 @@ let create () = ; file_map= FilenameHash.create 1 ; source_files= SourceFile.Set.empty } + (** add call graph from fname in the spec db, with relative tenv and cfg, to the execution environment *) let add_cg (exe_env: t) (source_dir: DB.source_dir) = let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in match Cg.load_from_file cg_fname with - | None - -> L.internal_error "Error: cannot load %s@." (DB.filename_to_string cg_fname) - | Some cg - -> let source = Cg.get_source cg in + | None -> + L.internal_error "Error: cannot load %s@." (DB.filename_to_string cg_fname) + | Some cg -> + let source = Cg.get_source cg in exe_env.source_files <- SourceFile.Set.add source exe_env.source_files ; let defined_procs = Cg.get_defined_nodes cg in let duplicate_procs_to_print = List.filter_map defined_procs ~f:(fun pname -> match Attributes.find_file_capturing_procedure pname with - | None - -> None - | Some (source_captured, origin) - -> let multiply_defined = SourceFile.compare source source_captured <> 0 in + | None -> + None + | Some (source_captured, origin) -> + let multiply_defined = SourceFile.compare source source_captured <> 0 in if multiply_defined then Cg.remove_node_defined cg pname ; if multiply_defined && origin <> `Include then Some (pname, source_captured) else None ) in if Config.dump_duplicate_symbols then - Out_channel.with_file (Config.results_dir ^/ Config.duplicates_filename) ~append:true - ~perm:0o666 ~f:(fun outc -> + Out_channel.with_file (Config.results_dir ^/ Config.duplicates_filename) + ~append:true ~perm:0o666 ~f:(fun outc -> let fmt = F.formatter_of_out_channel outc in List.iter duplicate_procs_to_print ~f:(fun (pname, source_captured) -> F.fprintf fmt "@.DUPLICATE_SYMBOLS source: %a source_captured:%a pname:%a@." SourceFile.pp source SourceFile.pp source_captured Typ.Procname.pp pname ) ) ; Cg.extend exe_env.cg cg + (** get the global call graph *) let get_cg exe_env = exe_env.cg @@ -116,83 +122,94 @@ let get_file_data exe_env pname = with Not_found -> let source_file_opt = match Attributes.load pname with - | None - -> L.(debug Analysis Medium) "can't find tenv_cfg_object for %a@." Typ.Procname.pp pname ; + | None -> + L.(debug Analysis Medium) "can't find tenv_cfg_object for %a@." Typ.Procname.pp pname ; None - | Some proc_attributes when Config.reactive_capture - -> let get_captured_file {ProcAttributes.source_file_captured} = source_file_captured in + | Some proc_attributes when Config.reactive_capture -> + let get_captured_file {ProcAttributes.source_file_captured} = source_file_captured in OndemandCapture.try_capture proc_attributes |> Option.map ~f:get_captured_file - | Some proc_attributes - -> Some proc_attributes.ProcAttributes.source_file_captured + | Some proc_attributes -> + Some proc_attributes.ProcAttributes.source_file_captured in let get_file_data_for_source source_file = let source_dir = DB.source_dir_from_source_file source_file in let cg_fname = DB.source_dir_get_internal_file source_dir ".cg" in let file_data = create_file_data exe_env.file_map source_file cg_fname in - Typ.Procname.Hash.replace exe_env.proc_map pname file_data ; file_data + Typ.Procname.Hash.replace exe_env.proc_map pname file_data ; + file_data in Option.map ~f:get_file_data_for_source source_file_opt + (** return the source file associated to the procedure *) let get_source exe_env pname = Option.map ~f:(fun file_data -> file_data.source) (get_file_data exe_env pname) + let file_data_to_tenv file_data = if is_none file_data.tenv then file_data.tenv <- Tenv.load_from_file file_data.tenv_file ; file_data.tenv + let file_data_to_cfg file_data = if is_none file_data.cfg then file_data.cfg <- Cfg.load_cfg_from_file file_data.cfg_file ; file_data.cfg + let java_global_tenv = - ( lazy - ( match Tenv.load_from_file DB.global_tenv_fname with - | None - -> L.(die InternalError) - "Could not load the global tenv at path '%s'" (DB.filename_to_string DB.global_tenv_fname) - | Some tenv - -> tenv ) ) + lazy + ( match Tenv.load_from_file DB.global_tenv_fname with + | None -> + L.(die InternalError) + "Could not load the global tenv at path '%s'" + (DB.filename_to_string DB.global_tenv_fname) + | Some tenv -> + tenv ) + (** return the type environment associated to the procedure *) let get_tenv exe_env proc_name = match proc_name with - | Typ.Procname.Java _ - -> Lazy.force java_global_tenv + | Typ.Procname.Java _ -> + Lazy.force java_global_tenv | _ -> match get_file_data exe_env proc_name with | Some file_data -> ( match file_data_to_tenv file_data with - | Some tenv - -> tenv - | None - -> L.(die InternalError) + | Some tenv -> + tenv + | None -> + L.(die InternalError) "get_tenv: tenv not found for %a in file '%s'" Typ.Procname.pp proc_name (DB.filename_to_string file_data.tenv_file) ) - | None - -> L.(die InternalError) "get_tenv: file_data not found for %a" Typ.Procname.pp proc_name + | None -> + L.(die InternalError) "get_tenv: file_data not found for %a" Typ.Procname.pp proc_name + (** return the cfg associated to the procedure *) let get_cfg exe_env pname = match get_file_data exe_env pname with - | None - -> None - | Some file_data - -> file_data_to_cfg file_data + | None -> + None + | Some file_data -> + file_data_to_cfg file_data + (** return the proc desc associated to the procedure *) let get_proc_desc exe_env pname = match get_cfg exe_env pname with - | Some cfg - -> Cfg.find_proc_desc_from_name cfg pname - | None - -> None + | Some cfg -> + Cfg.find_proc_desc_from_name cfg pname + | None -> + None + (** Create an exe_env from a source dir *) let from_cluster cluster = let exe_env = create () in add_cg exe_env cluster ; exe_env + (** [iter_files f exe_env] applies [f] to the filename and tenv and cfg for each file in [exe_env] *) let iter_files f exe_env = let do_file _ file_data seen_files_acc = @@ -206,3 +223,4 @@ let iter_files f exe_env = SourceFile.Set.add fname seen_files_acc ) in ignore (Typ.Procname.Hash.fold do_file exe_env.proc_map SourceFile.Set.empty) + diff --git a/infer/src/backend/infer.ml b/infer/src/backend/infer.ml index 9b39ea955..4989ff34a 100644 --- a/infer/src/backend/infer.ml +++ b/infer/src/backend/infer.ml @@ -24,40 +24,44 @@ let run driver_mode = analyze_and_report driver_mode ~changed_files ; run_epilogue driver_mode + let setup () = match Config.command with - | Analyze - -> ResultsDir.assert_results_dir "have you run capture before?" - | Report | ReportDiff - -> ResultsDir.create_results_dir () - | Diff - -> ResultsDir.remove_results_dir () ; ResultsDir.create_results_dir () - | Capture | Compile | Run - -> let driver_mode = Lazy.force Driver.mode_from_command_line in + | Analyze -> + ResultsDir.assert_results_dir "have you run capture before?" + | Report | ReportDiff -> + ResultsDir.create_results_dir () + | Diff -> + ResultsDir.remove_results_dir () ; ResultsDir.create_results_dir () + | Capture | Compile | Run -> + let driver_mode = Lazy.force Driver.mode_from_command_line in if not ( Driver.(equal_mode driver_mode Analyze) || Config.(buck || continue_capture || infer_is_clang || infer_is_javac || reactive_mode) ) then ResultsDir.remove_results_dir () ; ResultsDir.create_results_dir () - | Explore - -> ResultsDir.assert_results_dir "please run an infer analysis first" + | Explore -> + ResultsDir.assert_results_dir "please run an infer analysis first" + let print_active_checkers () = (if Config.print_active_checkers && CLOpt.is_originator then L.result else L.environment_info) "Analyzer: %s@." Config.(string_of_analyzer analyzer) ; (if Config.print_active_checkers && CLOpt.is_originator then L.result else L.environment_info) - "Active checkers: %a@." (Pp.seq ~sep:", " RegisterCheckers.pp_checker) + "Active checkers: %a@." + (Pp.seq ~sep:", " RegisterCheckers.pp_checker) (RegisterCheckers.get_active_checkers ()) + let log_environment_info () = L.environment_info "CWD = %s@\n" (Sys.getcwd ()) ; ( match Config.inferconfig_file with - | Some file - -> L.environment_info "Read configuration in %s@\n" file - | None - -> L.environment_info "No .inferconfig file found@\n" ) ; + | Some file -> + L.environment_info "Read configuration in %s@\n" file + | None -> + L.environment_info "No .inferconfig file found@\n" ) ; L.environment_info "Project root = %s@\n" Config.project_root ; let infer_args = Sys.getenv CLOpt.args_env_var |> Option.map ~f:(String.split ~on:CLOpt.env_var_sep) @@ -67,47 +71,48 @@ let log_environment_info () = L.environment_info "command line arguments: %a" Pp.cli_args (Array.to_list Sys.argv) ; print_active_checkers () + let () = ( if Config.linters_validate_syntax_only then match CTLParserHelper.validate_al_files () with - | Ok () - -> L.exit 0 - | Error e - -> print_endline e ; L.exit 3 ) ; + | Ok () -> + L.exit 0 + | Error e -> + print_endline e ; L.exit 3 ) ; if Config.print_builtins then Builtin.print_and_exit () ; setup () ; log_environment_info () ; if Config.debug_mode && CLOpt.is_originator then L.progress "Logs in %s@." (Config.results_dir ^/ Config.log_file) ; match Config.command with - | Analyze - -> let pp_cluster_opt fmt = function - | None - -> F.fprintf fmt "(no cluster)" - | Some cluster - -> F.fprintf fmt "of cluster %s" (Filename.basename cluster) + | Analyze -> + let pp_cluster_opt fmt = function + | None -> + F.fprintf fmt "(no cluster)" + | Some cluster -> + F.fprintf fmt "of cluster %s" (Filename.basename cluster) in L.environment_info "Starting analysis %a" pp_cluster_opt Config.cluster_cmdline ; if Config.developer_mode then InferAnalyze.register_perf_stats_report () ; Driver.analyze_and_report Analyze ~changed_files:(Driver.read_config_changed_files ()) - | Report - -> InferPrint.main ~report_csv:Config.issues_csv ~report_json:None - | ReportDiff - -> (* at least one report must be passed in input to compute differential *) + | Report -> + InferPrint.main ~report_csv:Config.issues_csv ~report_json:None + | ReportDiff -> + (* at least one report must be passed in input to compute differential *) ( match (Config.report_current, Config.report_previous) with - | None, None - -> L.(die UserError) + | None, None -> + L.(die UserError) "Expected at least one argument among 'report-current' and 'report-previous'" - | _ - -> () ) ; + | _ -> + () ) ; ReportDiff.reportdiff ~current_report:Config.report_current ~previous_report:Config.report_previous - | Capture | Compile | Run - -> run (Lazy.force Driver.mode_from_command_line) - | Diff - -> Diff.diff (Lazy.force Driver.mode_from_command_line) - | Explore - -> let if_some key opt args = + | Capture | Compile | Run -> + run (Lazy.force Driver.mode_from_command_line) + | Diff -> + Diff.diff (Lazy.force Driver.mode_from_command_line) + | Explore -> + let if_some key opt args = match opt with None -> args | Some arg -> key :: string_of_int arg :: args in let if_true key opt args = if not opt then args else key :: args in @@ -122,3 +127,4 @@ let () = L.external_error "** Error running the reporting script:@\n** %s %s@\n** See error above@." prog (String.concat ~sep:" " args) + diff --git a/infer/src/backend/inferconfig.ml b/infer/src/backend/inferconfig.ml index 2826d69bf..64755d16e 100644 --- a/infer/src/backend/inferconfig.ml +++ b/infer/src/backend/inferconfig.ml @@ -30,6 +30,7 @@ let do_not_filter : filters = ; error_filter= default_error_filter ; proc_filter= default_proc_filter } + type filter_config = { whitelist: string list ; blacklist: string list @@ -44,12 +45,14 @@ let is_matching patterns source_file = with Not_found -> false) patterns + (** Check if a proc name is matching the name given as string. *) let match_method language proc_name method_name = not (BuiltinDecl.is_declared proc_name) && Config.equal_language (Typ.Procname.get_language proc_name) language && String.equal (Typ.Procname.get_method proc_name) method_name + (* Module to create matcher based on strings present in the source file *) module FileContainsStringMatcher = struct type matcher = SourceFile.t -> bool @@ -59,13 +62,14 @@ module FileContainsStringMatcher = struct let file_contains regexp file_in = let rec loop () = try Str.search_forward regexp (In_channel.input_line_exn file_in) 0 >= 0 with - | Not_found - -> loop () - | End_of_file - -> false + | Not_found -> + loop () + | End_of_file -> + false in loop () + let create_matcher s_patterns = if List.is_empty s_patterns then default_matcher else @@ -81,6 +85,7 @@ module FileContainsStringMatcher = struct source_map := SourceFile.Map.add source_file pattern_found !source_map ; pattern_found with Sys_error _ -> false + end type method_pattern = @@ -123,13 +128,14 @@ module FileOrProcMatcher = struct fun _ proc_name -> match proc_name with Typ.Procname.Java pname_java -> do_java pname_java | _ -> false + let create_file_matcher patterns = let s_patterns, m_patterns = let collect (s_patterns, m_patterns) = function - | Source_contains (_, s) - -> (s :: s_patterns, m_patterns) - | Method_pattern (_, mp) - -> (s_patterns, mp :: m_patterns) + | Source_contains (_, s) -> + (s :: s_patterns, m_patterns) + | Method_pattern (_, mp) -> + (s_patterns, mp :: m_patterns) in List.fold ~f:collect ~init:([], []) patterns in @@ -139,15 +145,16 @@ module FileOrProcMatcher = struct and m_matcher = create_method_matcher m_patterns in fun source_file proc_name -> m_matcher source_file proc_name || s_matcher source_file proc_name + let load_matcher = create_file_matcher let _pp_pattern fmt pattern = let pp_string fmt s = Format.fprintf fmt "%s" s in let pp_option pp_value fmt = function - | None - -> pp_string fmt "None" - | Some value - -> Format.fprintf fmt "%a" pp_value value + | None -> + pp_string fmt "None" + | Some value -> + Format.fprintf fmt "%a" pp_value value in let pp_key_value pp_value fmt (key, value) = Format.fprintf fmt " %s: %a,@\n" key (pp_option pp_value) value @@ -161,12 +168,15 @@ module FileOrProcMatcher = struct ("parameters", mp.parameters) and pp_source_contains fmt sc = Format.fprintf fmt " pattern: %s@\n" sc in match pattern with - | Method_pattern (language, mp) - -> Format.fprintf fmt "Method pattern (%s) {@\n%a}@\n" (Config.string_of_language language) + | Method_pattern (language, mp) -> + Format.fprintf fmt "Method pattern (%s) {@\n%a}@\n" + (Config.string_of_language language) pp_method_pattern mp - | Source_contains (language, sc) - -> Format.fprintf fmt "Source contains (%s) {@\n%a}@\n" (Config.string_of_language language) + | Source_contains (language, sc) -> + Format.fprintf fmt "Source contains (%s) {@\n%a}@\n" + (Config.string_of_language language) pp_source_contains sc + end (* of module FileOrProcMatcher *) @@ -174,62 +184,63 @@ end module OverridesMatcher = struct let load_matcher patterns is_subtype proc_name = let is_matching = function - | Method_pattern (language, mp) - -> is_subtype mp.class_name + | Method_pattern (language, mp) -> + is_subtype mp.class_name && Option.value_map ~f:(match_method language proc_name) ~default:false mp.method_name - | _ - -> L.(die UserError) "Expecting method pattern" + | _ -> + L.(die UserError) "Expecting method pattern" in List.exists ~f:is_matching patterns + end let patterns_of_json_with_key (json_key, json) = let default_method_pattern = {class_name= ""; method_name= None; parameters= None} in let default_source_contains = "" in let language_of_string = function - | "Java" - -> Ok Config.Java - | l - -> Error ("JSON key " ^ json_key ^ " not supported for language " ^ l) + | "Java" -> + Ok Config.Java + | l -> + Error ("JSON key " ^ json_key ^ " not supported for language " ^ l) in let rec detect_language = function - | [] - -> Error ("No language found for " ^ json_key) - | ("language", `String s) :: _ - -> language_of_string s - | _ :: tl - -> detect_language tl + | [] -> + Error ("No language found for " ^ json_key) + | ("language", `String s) :: _ -> + language_of_string s + | _ :: tl -> + detect_language tl in (* Detect the kind of pattern, method pattern or pattern based on the content of the source file. Detecting the kind of patterns in a first step makes it easier to parse the parts of the pattern in a second step *) let detect_pattern assoc = match detect_language assoc with - | Ok language - -> let is_method_pattern key = List.exists ~f:(String.equal key) ["class"; "method"] + | Ok language -> + let is_method_pattern key = List.exists ~f:(String.equal key) ["class"; "method"] and is_source_contains key = List.exists ~f:(String.equal key) ["source_contains"] in let rec loop = function - | [] - -> Error ("Unknown pattern for " ^ json_key) - | (key, _) :: _ when is_method_pattern key - -> Ok (Method_pattern (language, default_method_pattern)) - | (key, _) :: _ when is_source_contains key - -> Ok (Source_contains (language, default_source_contains)) - | _ :: tl - -> loop tl + | [] -> + Error ("Unknown pattern for " ^ json_key) + | (key, _) :: _ when is_method_pattern key -> + Ok (Method_pattern (language, default_method_pattern)) + | (key, _) :: _ when is_source_contains key -> + Ok (Source_contains (language, default_source_contains)) + | _ :: tl -> + loop tl in loop assoc - | Error _ as error - -> error + | Error _ as error -> + error in (* Translate a JSON entry into a matching pattern *) let create_pattern (assoc: (string * Yojson.Basic.json) list) = let collect_params l = let collect accu = function - | `String s - -> s :: accu - | _ - -> L.(die UserError) + | `String s -> + s :: accu + | _ -> + L.(die UserError) "Unrecognised parameters in %s" (Yojson.Basic.to_string (`Assoc assoc)) in @@ -237,74 +248,80 @@ let patterns_of_json_with_key (json_key, json) = in let create_method_pattern assoc = let loop mp = function - | key, `String s when String.equal key "class" - -> {mp with class_name= s} - | key, `String s when String.equal key "method" - -> {mp with method_name= Some s} - | key, `List l when String.equal key "parameters" - -> {mp with parameters= Some (collect_params l)} - | key, _ when String.equal key "language" - -> mp - | _ - -> L.(die UserError) "Failed to parse %s" (Yojson.Basic.to_string (`Assoc assoc)) + | key, `String s when String.equal key "class" -> + {mp with class_name= s} + | key, `String s when String.equal key "method" -> + {mp with method_name= Some s} + | key, `List l when String.equal key "parameters" -> + {mp with parameters= Some (collect_params l)} + | key, _ when String.equal key "language" -> + mp + | _ -> + L.(die UserError) "Failed to parse %s" (Yojson.Basic.to_string (`Assoc assoc)) in List.fold ~f:loop ~init:default_method_pattern assoc and create_string_contains assoc = let loop sc = function - | key, `String pattern when String.equal key "source_contains" - -> pattern - | key, _ when String.equal key "language" - -> sc - | _ - -> L.(die UserError) "Failed to parse %s" (Yojson.Basic.to_string (`Assoc assoc)) + | key, `String pattern when String.equal key "source_contains" -> + pattern + | key, _ when String.equal key "language" -> + sc + | _ -> + L.(die UserError) "Failed to parse %s" (Yojson.Basic.to_string (`Assoc assoc)) in List.fold ~f:loop ~init:default_source_contains assoc in match detect_pattern assoc with - | Ok Method_pattern (language, _) - -> Ok (Method_pattern (language, create_method_pattern assoc)) - | Ok Source_contains (language, _) - -> Ok (Source_contains (language, create_string_contains assoc)) - | Error _ as error - -> error + | Ok Method_pattern (language, _) -> + Ok (Method_pattern (language, create_method_pattern assoc)) + | Ok Source_contains (language, _) -> + Ok (Source_contains (language, create_string_contains assoc)) + | Error _ as error -> + error in let warn_user msg = CLOpt.warnf "WARNING: error parsing option %s@\n%s@." json_key msg in (* Translate all the JSON entries into matching patterns *) let rec translate accu = function | `Assoc l -> ( match create_pattern l with - | Ok pattern - -> pattern :: accu - | Error msg - -> warn_user msg ; accu ) - | `List l - -> List.fold ~f:translate ~init:accu l - | json - -> warn_user + | Ok pattern -> + pattern :: accu + | Error msg -> + warn_user msg ; accu ) + | `List l -> + List.fold ~f:translate ~init:accu l + | json -> + warn_user (Printf.sprintf "expected list or assoc json type, but got value %s" (Yojson.Basic.to_string json)) ; accu in translate [] json + let modeled_expensive_matcher = OverridesMatcher.load_matcher (patterns_of_json_with_key Config.patterns_modeled_expensive) + let never_return_null_matcher = FileOrProcMatcher.load_matcher (patterns_of_json_with_key Config.patterns_never_returning_null) + let skip_translation_matcher = FileOrProcMatcher.load_matcher (patterns_of_json_with_key Config.patterns_skip_translation) + let skip_implementation_matcher = FileOrProcMatcher.load_matcher (patterns_of_json_with_key Config.patterns_skip_implementation) + let load_filters analyzer = { whitelist= Config.analysis_path_regex_whitelist analyzer ; blacklist= Config.analysis_path_regex_blacklist analyzer ; blacklist_files_containing= Config.analysis_blacklist_files_containing analyzer ; suppress_errors= Config.analysis_suppress_errors analyzer } + let filters_from_inferconfig inferconfig : filters = let path_filter = let whitelist_filter : path_filter = @@ -318,22 +335,24 @@ let filters_from_inferconfig inferconfig : filters = FileContainsStringMatcher.create_matcher inferconfig.blacklist_files_containing in function - | source_file - -> whitelist_filter source_file && not (blacklist_filter source_file) + | source_file -> + whitelist_filter source_file && not (blacklist_filter source_file) && not (blacklist_files_containing_filter source_file) in let error_filter = function - | error_name - -> let error_str = error_name.IssueType.unique_id in + | error_name -> + let error_str = error_name.IssueType.unique_id in not (List.exists ~f:(String.equal error_str) inferconfig.suppress_errors) in {path_filter; error_filter; proc_filter= default_proc_filter} + (* Create filters based on .inferconfig *) let create_filters analyzer = if not Config.filter_paths then do_not_filter else filters_from_inferconfig (load_filters analyzer) + (* This function loads and list the path that are being filtered by the analyzer. The results *) (* are of the form: path/to/file.java -> {infer, checkers} meaning that analysis results will *) (* be reported on path/to/file.java both for infer and for the checkers *) @@ -357,3 +376,4 @@ let test () = let matching_s = String.concat ~sep:", " (List.map ~f:fst matching) in L.result "%s -> {%s}@." (SourceFile.to_rel_path source_file) matching_s) (Sys.getcwd ()) + diff --git a/infer/src/backend/interproc.ml b/infer/src/backend/interproc.ml index db41521a7..fe540cfa1 100644 --- a/infer/src/backend/interproc.ml +++ b/infer/src/backend/interproc.ml @@ -28,37 +28,41 @@ module NodeVisitSet = Caml.Set.Make (struct (* higher id is better *) Procdesc.Node.compare n2 n1 + let compare_distance_to_exit {node= n1} {node= n2} = (* smaller means higher priority *) let n = match (Procdesc.Node.get_distance_to_exit n1, Procdesc.Node.get_distance_to_exit n2) with - | None, None - -> 0 - | None, Some _ - -> 1 - | Some _, None - -> -1 - | Some d1, Some d2 - -> (* shorter distance to exit is better *) + | None, None -> + 0 + | None, Some _ -> + 1 + | Some _, None -> + -1 + | Some d1, Some d2 -> + (* shorter distance to exit is better *) Int.compare d1 d2 in if n <> 0 then n else compare_ids n1 n2 + let compare_number_of_visits x1 x2 = let n = Int.compare x1.visits x2.visits in (* visited fewer times is better *) if n <> 0 then n else compare_distance_to_exit x1 x2 + let compare x1 x2 = if !Config.footprint then match Config.worklist_mode with - | 0 - -> compare_ids x1.node x2.node - | 1 - -> compare_distance_to_exit x1 x2 - | _ - -> compare_number_of_visits x1 x2 + | 0 -> + compare_ids x1.node x2.node + | 1 -> + compare_distance_to_exit x1 x2 + | _ -> + compare_number_of_visits x1 x2 else compare_ids x1.node x2.node + end) (** Table for the results of the join operation on nodes. *) @@ -79,6 +83,7 @@ end = struct try Hashtbl.find table i with Not_found -> Paths.PathSet.empty + let add table i dset = Hashtbl.replace table i dset end @@ -98,6 +103,7 @@ module Worklist = struct ; todo_set= NodeVisitSet.empty ; visit_map= Procdesc.NodeMap.empty } + let is_empty (wl: t) : bool = NodeVisitSet.is_empty wl.todo_set let add (wl: t) (node: Procdesc.Node.t) : unit = @@ -108,6 +114,7 @@ module Worklist = struct in wl.todo_set <- NodeVisitSet.add {node; visits} wl.todo_set + (** remove the minimum element from the worklist, and increase its number of visits *) let remove (wl: t) : Procdesc.Node.t = try @@ -119,6 +126,7 @@ module Worklist = struct with Not_found -> L.internal_error "@\n...Work list is empty! Impossible to remove edge...@\n" ; assert false + end (* =============== END of module Worklist =============== *) @@ -129,10 +137,14 @@ let path_set_create_worklist proc_cfg = Procdesc.compute_distance_to_exit_node (ProcCfg.Exceptional.proc_desc proc_cfg) ; Worklist.create () + let htable_retrieve (htable: (Procdesc.Node.id, Paths.PathSet.t) Hashtbl.t) (key: Procdesc.Node.id) : Paths.PathSet.t = try Hashtbl.find htable key - with Not_found -> Hashtbl.replace htable key Paths.PathSet.empty ; Paths.PathSet.empty + with Not_found -> + Hashtbl.replace htable key Paths.PathSet.empty ; + Paths.PathSet.empty + (** Add [d] to the pathset todo at [node] returning true if changed *) let path_set_put_todo (wl: Worklist.t) (node: Procdesc.Node.t) (d: Paths.PathSet.t) : bool = @@ -150,6 +162,7 @@ let path_set_put_todo (wl: Worklist.t) (node: Procdesc.Node.t) (d: Paths.PathSet in changed + let path_set_checkout_todo (wl: Worklist.t) (node: Procdesc.Node.t) : Paths.PathSet.t = try let node_id = Procdesc.Node.get_id node in @@ -157,15 +170,18 @@ let path_set_checkout_todo (wl: Worklist.t) (node: Procdesc.Node.t) : Paths.Path Hashtbl.replace wl.Worklist.path_set_todo node_id Paths.PathSet.empty ; let visited = Hashtbl.find wl.Worklist.path_set_visited node_id in let new_visited = Paths.PathSet.union visited todo in - Hashtbl.replace wl.Worklist.path_set_visited node_id new_visited ; todo + Hashtbl.replace wl.Worklist.path_set_visited node_id new_visited ; + todo with Not_found -> L.die InternalError "could not find todo for node %a" Procdesc.Node.pp node + (* =============== END of the edge_set object =============== *) let collect_do_abstract_pre pname tenv (pset: Propset.t) : Propset.t = if !Config.footprint then Config.run_in_re_execution_mode (Abs.lifted_abstract pname tenv) pset else Abs.lifted_abstract pname tenv pset + let collect_do_abstract_post pname tenv (pathset: Paths.PathSet.t) : Paths.PathSet.t = let abs_option p = if Prover.check_inconsistency tenv p then None else Some (Abs.abstract pname tenv p) @@ -174,16 +190,19 @@ let collect_do_abstract_post pname tenv (pathset: Paths.PathSet.t) : Paths.PathS Config.run_in_re_execution_mode (Paths.PathSet.map_option abs_option) pathset else Paths.PathSet.map_option abs_option pathset + let do_join_pre plist = Dom.proplist_collapse_pre plist let do_join_post pname tenv (pset: Paths.PathSet.t) = if Config.spec_abs_level <= 0 then Dom.pathset_collapse tenv pset else Dom.pathset_collapse tenv (Dom.pathset_collapse_impl pname tenv pset) + let do_meet_pre tenv pset = if Config.meet_level > 0 then Dom.propset_meet_generate_pre tenv pset else Propset.to_proplist pset + (** Find the preconditions in the current spec table, apply meet then join, and return the joined preconditions *) let collect_preconditions tenv summary : Prop.normal Specs.Jprop.t list = @@ -247,6 +266,7 @@ let collect_preconditions tenv summary : Prop.normal Specs.Jprop.t list = L.d_ln () ; jplist'' + (* =============== START of symbolic execution =============== *) (** propagate a set of results to the given node *) @@ -265,6 +285,7 @@ let propagate (wl: Worklist.t) pname ~is_exception (pset: Paths.PathSet.t) let changed = path_set_put_todo wl curr_node edgeset_todo in if changed then Worklist.add wl curr_node + (** propagate a set of results, including exceptions and divergence *) let propagate_nodes_divergence tenv (proc_cfg: ProcCfg.Exceptional.t) (pset: Paths.PathSet.t) (succ_nodes: Procdesc.Node.t list) (exn_nodes: Procdesc.Node.t list) (wl: Worklist.t) = @@ -289,6 +310,7 @@ let propagate_nodes_divergence tenv (proc_cfg: ProcCfg.Exceptional.t) (pset: Pat List.iter ~f:(propagate wl pname ~is_exception:false pset_ok) succ_nodes ; List.iter ~f:(propagate wl pname ~is_exception:true pset_exn) exn_nodes + (* ===================== END of symbolic execution ===================== *) (* =============== START of forward_tabulate =============== *) @@ -312,6 +334,7 @@ let do_symexec_join proc_cfg tenv wl curr_node (edgeset_todo: Paths.PathSet.t) = new_dset') succ_nodes + let prop_max_size = ref (0, Prop.prop_emp) let prop_max_chain_size = ref (0, Prop.prop_emp) @@ -325,14 +348,17 @@ let check_prop_size_ p _ = Prop.d_prop p ; L.d_ln () ) + (* Check prop size and filter out possible unabstracted lists *) let check_prop_size edgeset_todo = if Config.monitor_prop_size then Paths.PathSet.iter check_prop_size_ edgeset_todo + let reset_prop_metrics () = prop_max_size := (0, Prop.prop_emp) ; prop_max_chain_size := (0, Prop.prop_emp) + exception RE_EXE_ERROR let do_before_node session node = @@ -341,6 +367,7 @@ let do_before_node session node = L.reset_delayed_prints () ; Printer.node_start_session node (session :> int) + let do_after_node node = Printer.node_finish_session node (** Return the list of normal ids occurring in the instructions *) @@ -351,7 +378,10 @@ let instrs_get_normal_vars instrs = let exps = Sil.instr_get_exps instr in List.iter ~f:do_e exps in - List.iter ~f:do_instr instrs ; Sil.fav_filter_ident fav Ident.is_normal ; Sil.fav_to_list fav + List.iter ~f:do_instr instrs ; + Sil.fav_filter_ident fav Ident.is_normal ; + Sil.fav_to_list fav + (** Perform symbolic execution for a node starting from an initial prop *) let do_symbolic_execution proc_cfg handle_exn tenv (node: ProcCfg.Exceptional.node) @@ -373,6 +403,7 @@ let do_symbolic_execution proc_cfg handle_exn tenv (node: ProcCfg.Exceptional.no State.mark_execution_end node ; pset + let mark_visited summary node = let node_id = Procdesc.Node.get_id node in let stats = summary.Specs.stats in @@ -380,6 +411,7 @@ let mark_visited summary node = stats.Specs.nodes_visited_fp <- IntSet.add (node_id :> int) stats.Specs.nodes_visited_fp else stats.Specs.nodes_visited_re <- IntSet.add (node_id :> int) stats.Specs.nodes_visited_re + let forward_tabulate tenv proc_cfg wl = let pname = Procdesc.get_proc_name (ProcCfg.Exceptional.proc_desc proc_cfg) in let handle_exn_node curr_node exn = @@ -389,10 +421,10 @@ let forward_tabulate tenv proc_cfg wl = State.get_normalized_pre (Abs.abstract_no_symop pname) in ( match pre_opt with - | Some pre - -> L.d_strln "Precondition:" ; Prop.d_prop pre ; L.d_ln () - | None - -> () ) ; + | Some pre -> + L.d_strln "Precondition:" ; Prop.d_prop pre ; L.d_ln () + | None -> + () ) ; L.d_strln "SIL INSTR:" ; Procdesc.Node.d_instrs ~sub_instrs:true (State.get_instr ()) curr_node ; L.d_ln () ; @@ -452,14 +484,14 @@ let forward_tabulate tenv proc_cfg wl = check_prop_size pathset_todo ; print_node_preamble curr_node session pathset_todo ; match Procdesc.Node.get_kind curr_node with - | Procdesc.Node.Join_node - -> do_symexec_join proc_cfg tenv wl curr_node pathset_todo + | Procdesc.Node.Join_node -> + do_symexec_join proc_cfg tenv wl curr_node pathset_todo | Procdesc.Node.Stmt_node _ | Procdesc.Node.Prune_node _ | Procdesc.Node.Exit_node _ | Procdesc.Node.Skip_node _ - | Procdesc.Node.Start_node _ - -> exe_iter (do_prop curr_node handle_exn) pathset_todo + | Procdesc.Node.Start_node _ -> + exe_iter (do_prop curr_node handle_exn) pathset_todo in let do_node_and_handle curr_node session = let pathset_todo = path_set_checkout_todo wl curr_node in @@ -485,38 +517,40 @@ let forward_tabulate tenv proc_cfg wl = mark_visited summary curr_node ; (* mark nodes visited in fp and re phases *) let session = incr summary.Specs.sessions ; !(summary.Specs.sessions) in - do_before_node session curr_node ; do_node_and_handle curr_node session + do_before_node session curr_node ; + do_node_and_handle curr_node session done ; L.d_strln ".... Work list empty. Stop ...." ; L.d_ln () + (** if possible, produce a (fieldname, typ) path from one of the [src_exps] to [sink_exp] using [reachable_hpreds]. *) let get_fld_typ_path_opt src_exps sink_exp_ reachable_hpreds_ = let strexp_matches target_exp = function - | Sil.Eexp (e, _) - -> Exp.equal target_exp e - | _ - -> false + | Sil.Eexp (e, _) -> + Exp.equal target_exp e + | _ -> + false in let extend_path hpred (sink_exp, path, reachable_hpreds) = match hpred with - | Sil.Hpointsto (lhs, Sil.Estruct (flds, _), Exp.Sizeof {typ}) - -> List.find ~f:(function _, se -> strexp_matches sink_exp se) flds + | Sil.Hpointsto (lhs, Sil.Estruct (flds, _), Exp.Sizeof {typ}) -> + List.find ~f:(function _, se -> strexp_matches sink_exp se) flds |> Option.value_map ~f:(function - | fld, _ - -> let reachable_hpreds' = Sil.HpredSet.remove hpred reachable_hpreds in + | fld, _ -> + let reachable_hpreds' = Sil.HpredSet.remove hpred reachable_hpreds in (lhs, (Some fld, typ) :: path, reachable_hpreds')) ~default:(sink_exp, path, reachable_hpreds) - | Sil.Hpointsto (lhs, Sil.Earray (_, elems, _), Exp.Sizeof {typ}) - -> if List.exists ~f:(function _, se -> strexp_matches sink_exp se) elems then + | Sil.Hpointsto (lhs, Sil.Earray (_, elems, _), Exp.Sizeof {typ}) -> + if List.exists ~f:(function _, se -> strexp_matches sink_exp se) elems then let reachable_hpreds' = Sil.HpredSet.remove hpred reachable_hpreds in (* None means "no field name" ~=~ nameless array index *) (lhs, (None, typ) :: path, reachable_hpreds') else (sink_exp, path, reachable_hpreds) - | _ - -> (sink_exp, path, reachable_hpreds) + | _ -> + (sink_exp, path, reachable_hpreds) in (* terminates because [reachable_hpreds] is shrinking on each recursive call *) let rec get_fld_typ_path sink_exp path reachable_hpreds = @@ -530,6 +564,7 @@ let get_fld_typ_path_opt src_exps sink_exp_ reachable_hpreds_ = in get_fld_typ_path sink_exp_ [] reachable_hpreds_ + (** report an error if any Context is reachable from a static field *) let report_context_leaks pname sigma tenv = (* report an error if an expression in [context_exps] is reachable from [field_strexp] *) @@ -541,10 +576,10 @@ let report_context_leaks pname sigma tenv = ~f:(fun (context_exp, name) -> if Exp.Set.mem context_exp reachable_exps then match get_fld_typ_path_opt fld_exps context_exp reachable_hpreds with - | None - -> () (* TODO (T21871205): the underlying issue still need to be fixed *) - | Some leak_path - -> let err_desc = + | None -> + () (* TODO (T21871205): the underlying issue still need to be fixed *) + | Some leak_path -> + let err_desc = Errdesc.explain_context_leak pname (Typ.mk (Tstruct name)) fld_name leak_path in let exn = Exceptions.Context_leak (err_desc, __POS__) in @@ -558,23 +593,24 @@ let report_context_leaks pname sigma tenv = match hpred with | Sil.Hpointsto (_, Eexp (exp, _), Sizeof {typ= {desc= Tptr ({desc= Tstruct name}, _)}}) when not (Exp.is_null_literal exp) && AndroidFramework.is_context tenv name - && not (AndroidFramework.is_application tenv name) - -> (exp, name) :: exps - | _ - -> exps) + && not (AndroidFramework.is_application tenv name) -> + (exp, name) :: exps + | _ -> + exps) ~init:[] sigma in List.iter ~f:(function - | Sil.Hpointsto (Exp.Lvar pv, Sil.Estruct (static_flds, _), _) when Pvar.is_global pv - -> List.iter + | Sil.Hpointsto (Exp.Lvar pv, Sil.Estruct (static_flds, _), _) when Pvar.is_global pv -> + List.iter ~f:(fun (f_name, f_strexp) -> check_reachable_context_from_fld (f_name, f_strexp) context_exps) static_flds - | _ - -> ()) + | _ -> + ()) sigma + (** Remove locals and formals, and check if the address of a stack variable is left in the result *) let remove_locals_formals_and_check tenv proc_cfg p = @@ -590,6 +626,7 @@ let remove_locals_formals_and_check tenv proc_cfg p = in List.iter ~f:check_pvar pvars ; p' + (** Collect the analysis results for the exit node. *) let collect_analysis_result tenv wl proc_cfg : Paths.PathSet.t = let exit_node = ProcCfg.Exceptional.exit_node proc_cfg in @@ -597,6 +634,7 @@ let collect_analysis_result tenv wl proc_cfg : Paths.PathSet.t = let pathset = htable_retrieve wl.Worklist.path_set_visited exit_node_id in Paths.PathSet.map (remove_locals_formals_and_check tenv proc_cfg) pathset + module Pmap = Caml.Map.Make (struct type t = Prop.normal Prop.t @@ -606,9 +644,11 @@ end) let vset_ref_add_path vset_ref path = Paths.Path.iter_all_nodes_nocalls (fun n -> vset_ref := Procdesc.NodeSet.add n !vset_ref) path + let vset_ref_add_pathset vset_ref pathset = Paths.PathSet.iter (fun _ path -> vset_ref_add_path vset_ref path) pathset + let compute_visited vset = let res = ref Specs.Visitedset.empty in let node_get_all_lines n = @@ -620,7 +660,9 @@ let compute_visited vset = let do_node n = res := Specs.Visitedset.add (Procdesc.Node.get_id n, node_get_all_lines n) !res in - Procdesc.NodeSet.iter do_node vset ; !res + Procdesc.NodeSet.iter do_node vset ; + !res + (** Extract specs from a pathset *) let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list = @@ -665,10 +707,10 @@ let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list = in let new_posts = match post with - | None - -> current_posts - | Some (post, path) - -> Paths.PathSet.add_renamed_prop post path current_posts + | None -> + current_posts + | Some (post, path) -> + Paths.PathSet.add_renamed_prop post path current_posts in let new_visited = Specs.Visitedset.union visited current_visited in Pmap.add pre (new_posts, new_visited) map @@ -682,21 +724,20 @@ let extract_specs tenv pdesc pathset : Prop.normal Specs.spec list = ~f:(fun (p, path) -> (PropUtil.remove_seed_vars tenv p, path)) (Paths.PathSet.elements (do_join_post pname tenv posts)) in - let spec = - {Specs.pre= Specs.Jprop.Prop (1, pre); Specs.posts= posts'; Specs.visited= visited} - in + let spec = {Specs.pre= Specs.Jprop.Prop (1, pre); Specs.posts= posts'; Specs.visited} in specs := spec :: !specs in Pmap.iter add_spec pre_post_map ; !specs + let collect_postconditions wl tenv proc_cfg : Paths.PathSet.t * Specs.Visitedset.t = let pname = Procdesc.get_proc_name (ProcCfg.Exceptional.proc_desc proc_cfg) in let pathset = collect_analysis_result tenv wl proc_cfg in (* Assuming C++ developers use RAII, remove resources from the constructor posts *) let pathset = match pname with - | Typ.Procname.ObjC_Cpp _ - -> if Typ.Procname.is_constructor pname then + | Typ.Procname.ObjC_Cpp _ -> + if Typ.Procname.is_constructor pname then Paths.PathSet.map (fun prop -> Attribute.remove_resource tenv Racquire (Rmemory Mobjc) @@ -704,8 +745,8 @@ let collect_postconditions wl tenv proc_cfg : Paths.PathSet.t * Specs.Visitedset (Attribute.remove_resource tenv Racquire Rfile prop))) pathset else pathset - | _ - -> pathset + | _ -> + pathset in L.d_strln ("#### [FUNCTION " ^ Typ.Procname.to_string pname ^ "] Analysis result ####") ; Propset.d Prop.prop_emp (Paths.PathSet.to_propset tenv pathset) ; @@ -733,15 +774,17 @@ let collect_postconditions wl tenv proc_cfg : Paths.PathSet.t * Specs.Visitedset L.d_ln () ; res + let create_seed_vars sigma = let hpred_add_seed sigma = function - | Sil.Hpointsto (Exp.Lvar pv, se, typ) when not (Pvar.is_abduced pv) - -> Sil.Hpointsto (Exp.Lvar (Pvar.to_seed pv), se, typ) :: sigma - | _ - -> sigma + | Sil.Hpointsto (Exp.Lvar pv, se, typ) when not (Pvar.is_abduced pv) -> + Sil.Hpointsto (Exp.Lvar (Pvar.to_seed pv), se, typ) :: sigma + | _ -> + sigma in List.fold ~f:hpred_add_seed ~init:[] sigma + (** Initialize proposition for execution given formal and global parameters. The footprint is initialized according to the execution mode. The prop is not necessarily emp, so it @@ -751,26 +794,27 @@ let prop_init_formals_seed tenv new_formals (prop: 'a Prop.t) : Prop.exposed Pro let do_formal (pv, typ) = let texp = match !Config.curr_language with - | Config.Clang - -> Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.exact} - | Config.Java - -> Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes} - | Config.Python - -> L.die InternalError "prop_init_formals_seed not implemented for Python" + | Config.Clang -> + Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.exact} + | Config.Java -> + Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.subtypes} + | Config.Python -> + L.die InternalError "prop_init_formals_seed not implemented for Python" in Prop.mk_ptsto_lvar tenv Prop.Fld_init Sil.inst_formal (pv, texp, None) in List.map ~f:do_formal new_formals in let sigma_seed = - create_seed_vars (* formals already there plus new ones *) - (prop.Prop.sigma @ sigma_new_formals) + create_seed_vars ((* formals already there plus new ones *) + prop.Prop.sigma @ sigma_new_formals) in let sigma = sigma_seed @ sigma_new_formals in let new_pi = prop.Prop.pi in let prop' = Prop.set (Prop.prop_sigma_star prop sigma) ~pi:new_pi in Prop.set prop' ~sigma_fp:(prop'.Prop.sigma_fp @ sigma_new_formals) + (** Construct an initial prop by extending [prop] with locals, and formals if [add_formals] is true as well as seed variables *) let initial_prop tenv (curr_f: Procdesc.t) (prop: 'a Prop.t) add_formals : Prop.normal Prop.t = @@ -785,6 +829,7 @@ let initial_prop tenv (curr_f: Procdesc.t) (prop: 'a Prop.t) add_formals : Prop. let prop2 = prop_init_formals_seed tenv new_formals prop1 in Prop.prop_rename_primed_footprint_vars tenv (Prop.normalize tenv prop2) + (** Construct an initial prop from the empty prop *) let initial_prop_from_emp tenv curr_f = initial_prop tenv curr_f Prop.prop_emp true @@ -801,6 +846,7 @@ let initial_prop_from_pre tenv curr_f pre = initial_prop tenv curr_f pre3 false else initial_prop tenv curr_f pre false + (** Re-execute one precondition and return some spec if there was no re-execution error. *) let execute_filter_prop wl tenv proc_cfg init_node (precondition: Prop.normal Specs.Jprop.t) : Prop.normal Specs.spec option = @@ -841,12 +887,12 @@ let execute_filter_prop wl tenv proc_cfg init_node (precondition: Prop.normal Sp let pre = let p = PropUtil.remove_locals_ret tenv pdesc (Specs.Jprop.to_prop precondition) in match precondition with - | Specs.Jprop.Prop (n, _) - -> Specs.Jprop.Prop (n, p) - | Specs.Jprop.Joined (n, _, jp1, jp2) - -> Specs.Jprop.Joined (n, p, jp1, jp2) + | Specs.Jprop.Prop (n, _) -> + Specs.Jprop.Prop (n, p) + | Specs.Jprop.Joined (n, _, jp1, jp2) -> + Specs.Jprop.Joined (n, p, jp1, jp2) in - let spec = {Specs.pre= pre; Specs.posts= posts; Specs.visited= visited} in + let spec = {Specs.pre; Specs.posts; Specs.visited} in L.d_decrease_indent 1 ; do_after_node init_node ; Some spec with RE_EXE_ERROR -> do_before_node 0 init_node ; @@ -860,6 +906,7 @@ let execute_filter_prop wl tenv proc_cfg init_node (precondition: Prop.normal Sp do_after_node init_node ; None + let pp_intra_stats wl proc_cfg fmt _ = let nstates = ref 0 in let nodes = ProcCfg.Exceptional.nodes proc_cfg in @@ -872,6 +919,7 @@ let pp_intra_stats wl proc_cfg fmt _ = nodes ; F.fprintf fmt "(%d nodes containing %d states)" (List.length nodes) !nstates + type exe_phase = (unit -> unit) * (unit -> Prop.normal Specs.spec list * Specs.phase) (** Return functions to perform one phase of the analysis for a procedure. @@ -933,7 +981,8 @@ let perform_analysis_phase tenv (summary: Specs.summary) (proc_cfg: ProcCfg.Exce Exceptions.Internal_error (Localise.verbatim_desc "Leak_while_collecting_specs_after_footprint") in - Reporting.log_error_deprecated pname exn ; (* retuning no specs *) [] + Reporting.log_error_deprecated pname exn ; + (* retuning no specs *) [] in (specs, Specs.FOOTPRINT) in @@ -952,10 +1001,10 @@ let perform_analysis_phase tenv (summary: Specs.summary) (proc_cfg: ProcCfg.Exce let speco = execute_filter_prop wl tenv proc_cfg start_node p in let is_valid = match speco with - | None - -> false - | Some spec - -> valid_specs := !valid_specs @ [spec] ; + | None -> + false + | Some spec -> + valid_specs := !valid_specs @ [spec] ; true in let outcome = if is_valid then "pass" else "fail" in @@ -982,26 +1031,32 @@ let perform_analysis_phase tenv (summary: Specs.summary) (proc_cfg: ProcCfg.Exce L.(debug Analysis Medium) "@\n *** CANDIDATE PRECONDITIONS FOR %a: " Typ.Procname.pp pname ; L.(debug Analysis Medium) "@\n================================================@\n" ; L.(debug Analysis Medium) - "@\n%a @\n@\n" (Specs.Jprop.pp_list Pp.text false) candidate_preconditions ; + "@\n%a @\n@\n" + (Specs.Jprop.pp_list Pp.text false) + candidate_preconditions ; L.(debug Analysis Medium) "@\n@\n================================================" ; L.(debug Analysis Medium) "@\n *** VALID PRECONDITIONS FOR %a: " Typ.Procname.pp pname ; L.(debug Analysis Medium) "@\n================================================@\n" ; L.(debug Analysis Medium) - "@\n%a @\n@." (Specs.Jprop.pp_list Pp.text true) valid_preconditions ; + "@\n%a @\n@." + (Specs.Jprop.pp_list Pp.text true) + valid_preconditions ; (specs, Specs.RE_EXECUTION) in (go, get_results) in match Specs.get_phase summary with - | Specs.FOOTPRINT - -> compute_footprint () - | Specs.RE_EXECUTION - -> re_execution () + | Specs.FOOTPRINT -> + compute_footprint () + | Specs.RE_EXECUTION -> + re_execution () + let set_current_language proc_desc = let language = (Procdesc.get_attributes proc_desc).ProcAttributes.language in Config.curr_language := language + (** reset global values before analysing a procedure *) let reset_global_values proc_desc = Config.reset_abs_val () ; @@ -1011,67 +1066,72 @@ let reset_global_values proc_desc = Abs.reset_current_rules () ; set_current_language proc_desc + (* Collect all pairs of the kind (precondition, runtime exception) from a summary *) let exception_preconditions tenv pname summary = let collect_exceptions pre (exns, all_post_exn) (prop, _) = match Tabulation.prop_get_exn_name pname prop with - | Some exn_name when PatternMatch.is_runtime_exception tenv exn_name - -> ((pre, exn_name) :: exns, all_post_exn) - | _ - -> (exns, false) + | Some exn_name when PatternMatch.is_runtime_exception tenv exn_name -> + ((pre, exn_name) :: exns, all_post_exn) + | _ -> + (exns, false) in let collect_spec errors spec = List.fold ~f:(collect_exceptions spec.Specs.pre) ~init:errors spec.Specs.posts in List.fold ~f:collect_spec ~init:([], true) (Specs.get_specs_from_payload summary) + (* Collect all pairs of the kind (precondition, custom error) from a summary *) let custom_error_preconditions summary = let collect_errors pre (errors, all_post_error) (prop, _) = match Tabulation.lookup_custom_errors prop with - | None - -> (errors, false) - | Some e - -> ((pre, e) :: errors, all_post_error) + | None -> + (errors, false) + | Some e -> + ((pre, e) :: errors, all_post_error) in let collect_spec errors spec = List.fold ~f:(collect_errors spec.Specs.pre) ~init:errors spec.Specs.posts in List.fold ~f:collect_spec ~init:([], true) (Specs.get_specs_from_payload summary) + (* Remove the constrain of the form this != null which is true for all Java virtual calls *) let remove_this_not_null tenv prop = let collect_hpred (var_option, hpreds) = function | Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp (Exp.Var var, _), _) - when Config.curr_language_is Config.Java && Pvar.is_this pvar - -> (Some var, hpreds) - | hpred - -> (var_option, hpred :: hpreds) + when Config.curr_language_is Config.Java && Pvar.is_this pvar -> + (Some var, hpreds) + | hpred -> + (var_option, hpred :: hpreds) in let collect_atom var atoms = function - | Sil.Aneq (Exp.Var v, e) when Ident.equal v var && Exp.equal e Exp.null - -> atoms - | a - -> a :: atoms + | Sil.Aneq (Exp.Var v, e) when Ident.equal v var && Exp.equal e Exp.null -> + atoms + | a -> + a :: atoms in match List.fold ~f:collect_hpred ~init:(None, []) prop.Prop.sigma with - | None, _ - -> prop - | Some var, filtered_hpreds - -> let filtered_atoms = List.fold ~f:(collect_atom var) ~init:[] prop.Prop.pi in + | None, _ -> + prop + | Some var, filtered_hpreds -> + let filtered_atoms = List.fold ~f:(collect_atom var) ~init:[] prop.Prop.pi in let prop' = Prop.set Prop.prop_emp ~pi:filtered_atoms ~sigma:filtered_hpreds in Prop.normalize tenv prop' + (** Is true when the precondition does not contain constrains that can be false at call site. This means that the post-conditions associated with this precondition cannot be prevented by the calling context. *) let is_unavoidable tenv pre = let prop = remove_this_not_null tenv (Specs.Jprop.to_prop pre) in match Prop.CategorizePreconditions.categorize [prop] with - | Prop.CategorizePreconditions.NoPres | Prop.CategorizePreconditions.Empty - -> true - | _ - -> false + | Prop.CategorizePreconditions.NoPres | Prop.CategorizePreconditions.Empty -> + true + | _ -> + false + (** Detects if there are specs of the form {precondition} proc {runtime exception} and report an error in that case, generating the trace that lead to the runtime exception if the method is @@ -1085,11 +1145,11 @@ let report_runtime_exceptions tenv pdesc summary = is_public_method && match pname with - | Typ.Procname.Java pname_java - -> Typ.Procname.java_is_static pname + | Typ.Procname.Java pname_java -> + Typ.Procname.java_is_static pname && String.equal (Typ.Procname.java_get_method pname_java) "main" - | _ - -> false + | _ -> + false in let is_annotated pdesc = Annotations.pdesc_has_return_annot pdesc Annotations.ia_is_verify in let exn_preconditions, all_post_exn = exception_preconditions tenv pname summary in @@ -1105,6 +1165,7 @@ let report_runtime_exceptions tenv pdesc summary = in List.iter ~f:report exn_preconditions + let report_custom_errors tenv summary = let pname = Specs.get_proc_name summary in let error_preconditions, all_post_error = custom_error_preconditions summary in @@ -1117,6 +1178,7 @@ let report_custom_errors tenv summary = in List.iter ~f:report error_preconditions + module SpecMap = Caml.Map.Make (struct type t = Prop.normal Specs.Jprop.t @@ -1180,7 +1242,7 @@ let update_specs tenv prev_summary phase (new_specs: Specs.NormSpec.t list) let convert pre (post_set, visited) = res := Specs.spec_normalize tenv - {Specs.pre= pre; Specs.posts= Paths.PathSet.elements post_set; Specs.visited= visited} + {Specs.pre; Specs.posts= Paths.PathSet.elements post_set; Specs.visited} :: !res in List.iter ~f:re_exe_filter old_specs ; @@ -1190,6 +1252,7 @@ let update_specs tenv prev_summary phase (new_specs: Specs.NormSpec.t list) SpecMap.iter convert !current_specs ; (!res, !changed) + (** update a summary after analysing a procedure *) let update_summary tenv prev_summary specs phase res = let normal_specs = List.map ~f:(Specs.spec_normalize tenv) specs in @@ -1201,13 +1264,14 @@ let update_summary tenv prev_summary specs phase res = let stats = {prev_summary.Specs.stats with symops; stats_failure} in let preposts = match phase with - | Specs.FOOTPRINT - -> Some new_specs - | Specs.RE_EXECUTION - -> Some (List.map ~f:(Specs.NormSpec.erase_join_info_pre tenv) new_specs) + | Specs.FOOTPRINT -> + Some new_specs + | Specs.RE_EXECUTION -> + Some (List.map ~f:(Specs.NormSpec.erase_join_info_pre tenv) new_specs) in - let payload = {prev_summary.Specs.payload with Specs.preposts= preposts} in - {prev_summary with Specs.phase= phase; stats; payload} + let payload = {prev_summary.Specs.payload with Specs.preposts} in + {prev_summary with Specs.phase; stats; payload} + (** Analyze the procedure and return the resulting summary. *) let analyze_proc tenv proc_cfg : Specs.summary = @@ -1225,6 +1289,7 @@ let analyze_proc tenv proc_cfg : Specs.summary = report_runtime_exceptions tenv proc_desc updated_summary ; updated_summary + (** Perform the transition from [FOOTPRINT] to [RE_EXECUTION] in spec table *) let transition_footprint_re_exe tenv proc_name joined_pres = L.(debug Analysis Medium) "Transition %a from footprint to re-exe@." Typ.Procname.pp proc_name ; @@ -1243,6 +1308,7 @@ let transition_footprint_re_exe tenv proc_name joined_pres = in Specs.add_summary proc_name summary' + (** Perform phase transition from [FOOTPRINT] to [RE_EXECUTION] for the procedures enabled after the analysis of [proc_name] *) let perform_transition proc_cfg tenv proc_name = @@ -1269,15 +1335,17 @@ let perform_transition proc_cfg tenv proc_name = "Error in collect_preconditions for %a@." Typ.Procname.pp proc_name ; let error = Exceptions.recognize_exception exn in let err_str = "exception raised " ^ error.name.IssueType.unique_id in - L.(debug Analysis Medium) "Error: %s %a@." err_str L.pp_ml_loc_opt error.ml_loc ; [] + L.(debug Analysis Medium) "Error: %s %a@." err_str L.pp_ml_loc_opt error.ml_loc ; + [] in transition_footprint_re_exe tenv proc_name joined_pres in match Specs.get_summary proc_name with - | Some summary when Specs.equal_phase (Specs.get_phase summary) Specs.FOOTPRINT - -> transition summary - | _ - -> () + | Some summary when Specs.equal_phase (Specs.get_phase summary) Specs.FOOTPRINT -> + transition summary + | _ -> + () + (* Create closures for the interprocedural algorithm *) let interprocedural_algorithm_closures ~prepare_proc exe_env : Tasks.closure list = @@ -1289,17 +1357,18 @@ let interprocedural_algorithm_closures ~prepare_proc exe_env : Tasks.closure lis | Some proc_desc when Config.reactive_mode (* in reactive mode, only analyze changed procedures *) - && (Procdesc.get_attributes proc_desc).ProcAttributes.changed - -> analyze proc_desc - | Some proc_desc - -> analyze proc_desc - | None - -> () + && (Procdesc.get_attributes proc_desc).ProcAttributes.changed -> + analyze proc_desc + | Some proc_desc -> + analyze proc_desc + | None -> + () in let procs_to_analyze = Cg.get_defined_nodes call_graph in let create_closure proc_name () = process_one_proc proc_name in List.map ~f:create_closure procs_to_analyze + let analyze_procedure_aux cg_opt tenv proc_desc = let proc_name = Procdesc.get_proc_name proc_desc in let proc_cfg = ProcCfg.Exceptional.from_pdesc proc_desc in @@ -1311,17 +1380,20 @@ let analyze_procedure_aux cg_opt tenv proc_desc = Specs.add_summary proc_name summaryfp ; perform_transition proc_cfg tenv proc_name ; let summaryre = Config.run_in_re_execution_mode (analyze_proc tenv) proc_cfg in - Specs.add_summary proc_name summaryre ; summaryre + Specs.add_summary proc_name summaryre ; + summaryre + let analyze_procedure {Callbacks.summary; proc_desc; tenv} : Specs.summary = let proc_name = Procdesc.get_proc_name proc_desc in Specs.add_summary proc_name summary ; ( try ignore (analyze_procedure_aux None tenv proc_desc) with exn -> - reraise_if exn ~f:(fun () -> not (Exceptions.handle_exception exn)) ; - Reporting.log_error_deprecated proc_name exn ) ; + reraise_if exn ~f:(fun () -> not (Exceptions.handle_exception exn)) ; + Reporting.log_error_deprecated proc_name exn ) ; Specs.get_summary_unsafe __FILE__ proc_name + (** Create closures to perform the analysis of an exe_env *) let do_analysis_closures exe_env : Tasks.closure list = let get_calls caller_pdesc = @@ -1350,13 +1422,13 @@ let do_analysis_closures exe_env : Tasks.closure list = let callbacks = let get_proc_desc proc_name = match Exe_env.get_proc_desc exe_env proc_name with - | Some pdesc - -> Some pdesc - | None when Config.(equal_dynamic_dispatch dynamic_dispatch Lazy) - -> Option.bind (Specs.get_summary proc_name) ~f:(fun summary -> + | Some pdesc -> + Some pdesc + | None when Config.(equal_dynamic_dispatch dynamic_dispatch Lazy) -> + Option.bind (Specs.get_summary proc_name) ~f:(fun summary -> summary.Specs.proc_desc_option ) - | None - -> None + | None -> + None in let analyze_ondemand _ proc_desc = let proc_name = Procdesc.get_proc_name proc_desc in @@ -1364,7 +1436,7 @@ let do_analysis_closures exe_env : Tasks.closure list = let cg = Exe_env.get_cg exe_env in analyze_procedure_aux (Some cg) tenv proc_desc in - {Ondemand.analyze_ondemand= analyze_ondemand; get_proc_desc} + {Ondemand.analyze_ondemand; get_proc_desc} in let prepare_proc pn = let should_init = Config.models_mode || is_none (Specs.get_summary pn) in @@ -1378,6 +1450,7 @@ let do_analysis_closures exe_env : Tasks.closure list = in closures + let visited_and_total_nodes ~filter cfg = let filter_node pdesc n = Procdesc.is_defined pdesc && filter pdesc @@ -1386,10 +1459,10 @@ let visited_and_total_nodes ~filter cfg = | Procdesc.Node.Stmt_node _ | Procdesc.Node.Prune_node _ | Procdesc.Node.Start_node _ - | Procdesc.Node.Exit_node _ - -> true - | Procdesc.Node.Skip_node _ | Procdesc.Node.Join_node - -> false + | Procdesc.Node.Exit_node _ -> + true + | Procdesc.Node.Skip_node _ | Procdesc.Node.Join_node -> + false in let counted_nodes, visited_nodes_re = let set = ref Procdesc.NodeSet.empty in @@ -1404,6 +1477,7 @@ let visited_and_total_nodes ~filter cfg = in (Procdesc.NodeSet.elements visited_nodes_re, Procdesc.NodeSet.elements counted_nodes) + (** Print the stats for the given cfg. Consider every defined proc unless a proc with the same name was defined in another module, and was the one which was analyzed *) @@ -1411,10 +1485,10 @@ let print_stats_cfg proc_shadowed source cfg = let err_table = Errlog.create_err_table () in let filter pdesc = match Specs.get_summary (Procdesc.get_proc_name pdesc) with - | None - -> false - | Some summary - -> Specs.get_specs_from_payload summary <> [] + | None -> + false + | Some summary -> + Specs.get_specs_from_payload summary <> [] in let nodes_visited, nodes_total = visited_and_total_nodes ~filter cfg in let num_proc = ref 0 in @@ -1428,14 +1502,14 @@ let print_stats_cfg proc_shadowed source cfg = let compute_stats_proc proc_desc = let proc_name = Procdesc.get_proc_name proc_desc in match Specs.get_summary proc_name with - | None - -> () - | Some _ when proc_shadowed proc_desc - -> L.(debug Analysis Medium) + | None -> + () + | Some _ when proc_shadowed proc_desc -> + L.(debug Analysis Medium) "print_stats: ignoring function %a which is also defined in another file@." Typ.Procname.pp proc_name - | Some summary - -> let stats = summary.Specs.stats in + | Some summary -> + let stats = summary.Specs.stats in let err_log = summary.Specs.attributes.ProcAttributes.err_log in incr num_proc ; let specs = Specs.get_specs_from_payload summary in @@ -1448,14 +1522,14 @@ let print_stats_cfg proc_shadowed source cfg = Exceptions.equal_err_kind ekind Exceptions.Kerror && in_footprint) err_log ) with - | [], 0 - -> incr num_nospec_noerror_proc - | _, 0 - -> incr num_spec_noerror_proc - | [], _ - -> incr num_nospec_error_proc - | _, _ - -> incr num_spec_error_proc + | [], 0 -> + incr num_nospec_noerror_proc + | _, 0 -> + incr num_spec_noerror_proc + | [], _ -> + incr num_nospec_error_proc + | _, _ -> + incr num_spec_error_proc in tot_symops := !tot_symops + stats.Specs.symops ; if Option.is_some stats.Specs.stats_failure then incr num_timeout ; @@ -1498,6 +1572,7 @@ let print_stats_cfg proc_shadowed source cfg = L.(debug Analysis Medium) "%a" print_file_stats () ; save_file_stats () + (** Print the stats for all the files in the cluster *) let print_stats cluster = let exe_env = Exe_env.from_cluster cluster in @@ -1510,3 +1585,4 @@ let print_stats cluster = in print_stats_cfg proc_shadowed source cfg) exe_env + diff --git a/infer/src/backend/match.ml b/infer/src/backend/match.ml index 31d8bcdc2..84031b3ab 100644 --- a/infer/src/backend/match.ml +++ b/infer/src/backend/match.ml @@ -25,12 +25,13 @@ type hpred_pat = {hpred: Sil.hpred; flag: bool} let pp_hpat pe f hpat = F.fprintf f "%a" (Sil.pp_hpred pe) hpat.hpred let rec pp_hpat_list pe f = function - | [] - -> () - | [hpat] - -> F.fprintf f "%a" (pp_hpat pe) hpat - | hpat :: hpats - -> F.fprintf f "%a * %a" (pp_hpat pe) hpat (pp_hpat_list pe) hpats + | [] -> + () + | [hpat] -> + F.fprintf f "%a" (pp_hpat pe) hpat + | hpat :: hpats -> + F.fprintf f "%a * %a" (pp_hpat pe) hpat (pp_hpat_list pe) hpats + (** Checks e1 = e2[sub ++ sub'] for some sub' with dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *) @@ -40,124 +41,128 @@ let rec exp_match e1 sub vars e2 : (Sil.exp_subst * Ident.t list) option = if Exp.equal e1 e2_inst then Some (sub, vars) else None in match (e1, e2) with - | _, Exp.Var id2 when Ident.is_primed id2 && mem_idlist id2 vars - -> let vars_new = List.filter ~f:(fun id -> not (Ident.equal id id2)) vars in + | _, Exp.Var id2 when Ident.is_primed id2 && mem_idlist id2 vars -> + let vars_new = List.filter ~f:(fun id -> not (Ident.equal id id2)) vars in let sub_new = match Sil.extend_sub sub id2 e1 with - | None - -> assert false (* happens when vars contains the same variable twice. *) - | Some sub_new - -> sub_new + | None -> + assert false (* happens when vars contains the same variable twice. *) + | Some sub_new -> + sub_new in Some (sub_new, vars_new) - | _, Exp.Var _ - -> check_equal sub vars e1 e2 - | Exp.Var _, _ - -> None - | Exp.Const _, _ | _, Exp.Const _ - -> check_equal sub vars e1 e2 - | Exp.Sizeof _, _ | _, Exp.Sizeof _ - -> check_equal sub vars e1 e2 - | Exp.Cast (_, e1'), Exp.Cast (_, e2') - -> (* we are currently ignoring cast *) + | _, Exp.Var _ -> + check_equal sub vars e1 e2 + | Exp.Var _, _ -> + None + | Exp.Const _, _ | _, Exp.Const _ -> + check_equal sub vars e1 e2 + | Exp.Sizeof _, _ | _, Exp.Sizeof _ -> + check_equal sub vars e1 e2 + | Exp.Cast (_, e1'), Exp.Cast (_, e2') -> + (* we are currently ignoring cast *) + exp_match e1' sub vars e2' + | Exp.Cast _, _ | _, Exp.Cast _ -> + None + | Exp.UnOp (o1, e1', _), Exp.UnOp (o2, e2', _) when Unop.equal o1 o2 -> exp_match e1' sub vars e2' - | Exp.Cast _, _ | _, Exp.Cast _ - -> None - | Exp.UnOp (o1, e1', _), Exp.UnOp (o2, e2', _) when Unop.equal o1 o2 - -> exp_match e1' sub vars e2' - | Exp.UnOp _, _ | _, Exp.UnOp _ - -> None (* Naive *) + | Exp.UnOp _, _ | _, Exp.UnOp _ -> + None (* Naive *) | Exp.BinOp (b1, e1', e1''), Exp.BinOp (b2, e2', e2'') when Binop.equal b1 b2 -> ( match exp_match e1' sub vars e2' with - | None - -> None - | Some (sub', vars') - -> exp_match e1'' sub' vars' e2'' ) - | Exp.BinOp _, _ | _, Exp.BinOp _ - -> None (* Naive *) - | Exp.Exn _, _ | _, Exp.Exn _ - -> check_equal sub vars e1 e2 - | Exp.Closure _, _ | _, Exp.Closure _ - -> check_equal sub vars e1 e2 - | Exp.Lvar _, _ | _, Exp.Lvar _ - -> check_equal sub vars e1 e2 - | Exp.Lfield (e1', fld1, _), Exp.Lfield (e2', fld2, _) when Typ.Fieldname.equal fld1 fld2 - -> exp_match e1' sub vars e2' - | Exp.Lfield _, _ | _, Exp.Lfield _ - -> None + | None -> + None + | Some (sub', vars') -> + exp_match e1'' sub' vars' e2'' ) + | Exp.BinOp _, _ | _, Exp.BinOp _ -> + None (* Naive *) + | Exp.Exn _, _ | _, Exp.Exn _ -> + check_equal sub vars e1 e2 + | Exp.Closure _, _ | _, Exp.Closure _ -> + check_equal sub vars e1 e2 + | Exp.Lvar _, _ | _, Exp.Lvar _ -> + check_equal sub vars e1 e2 + | Exp.Lfield (e1', fld1, _), Exp.Lfield (e2', fld2, _) when Typ.Fieldname.equal fld1 fld2 -> + exp_match e1' sub vars e2' + | Exp.Lfield _, _ | _, Exp.Lfield _ -> + None | Exp.Lindex (base1, idx1), Exp.Lindex (base2, idx2) -> match exp_match base1 sub vars base2 with - | None - -> None - | Some (sub', vars') - -> exp_match idx1 sub' vars' idx2 + | None -> + None + | Some (sub', vars') -> + exp_match idx1 sub' vars' idx2 + let exp_list_match es1 sub vars es2 = let f res_acc (e1, e2) = match res_acc with - | None - -> None - | Some (sub_acc, vars_leftover) - -> exp_match e1 sub_acc vars_leftover e2 + | None -> + None + | Some (sub_acc, vars_leftover) -> + exp_match e1 sub_acc vars_leftover e2 in Option.find_map ~f:(fun es_combined -> List.fold ~f ~init:(Some (sub, vars)) es_combined) (List.zip es1 es2) + (** Checks sexp1 = sexp2[sub ++ sub'] for some sub' with dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). WARNING: This function does not consider the fact that the analyzer sometimes forgets fields of hpred. It can possibly cause a problem. *) let rec strexp_match sexp1 sub vars sexp2 : (Sil.exp_subst * Ident.t list) option = match (sexp1, sexp2) with - | Sil.Eexp (exp1, _), Sil.Eexp (exp2, _) - -> exp_match exp1 sub vars exp2 - | Sil.Eexp _, _ | _, Sil.Eexp _ - -> None - | Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, _) - -> fsel_match fsel1 sub vars fsel2 - | Sil.Estruct _, _ | _, Sil.Estruct _ - -> None + | Sil.Eexp (exp1, _), Sil.Eexp (exp2, _) -> + exp_match exp1 sub vars exp2 + | Sil.Eexp _, _ | _, Sil.Eexp _ -> + None + | Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, _) -> + fsel_match fsel1 sub vars fsel2 + | Sil.Estruct _, _ | _, Sil.Estruct _ -> + None | Sil.Earray (len1, isel1, _), Sil.Earray (len2, isel2, _) -> match exp_match len1 sub vars len2 with - | Some (sub', vars') - -> isel_match isel1 sub' vars' isel2 - | None - -> None + | Some (sub', vars') -> + isel_match isel1 sub' vars' isel2 + | None -> + None + (** Checks fsel1 = fsel2[sub ++ sub'] for some sub' with dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *) and fsel_match fsel1 sub vars fsel2 = match (fsel1, fsel2) with - | [], [] - -> Some (sub, vars) - | [], _ - -> None - | _, [] - -> if Config.abs_struct <= 0 then None else Some (sub, vars) + | [], [] -> + Some (sub, vars) + | [], _ -> + None + | _, [] -> + if Config.abs_struct <= 0 then None else Some (sub, vars) (* This can lead to great information loss *) - | (fld1, se1') :: fsel1', (fld2, se2') :: fsel2' - -> let n = Typ.Fieldname.compare fld1 fld2 in + | (fld1, se1') :: fsel1', (fld2, se2') :: fsel2' -> + let n = Typ.Fieldname.compare fld1 fld2 in if Int.equal n 0 then match strexp_match se1' sub vars se2' with - | None - -> None - | Some (sub', vars') - -> fsel_match fsel1' sub' vars' fsel2' + | None -> + None + | Some (sub', vars') -> + fsel_match fsel1' sub' vars' fsel2' else if n < 0 && Config.abs_struct > 0 then fsel_match fsel1' sub vars fsel2 (* This can lead to great information loss *) else None + (** Checks isel1 = isel2[sub ++ sub'] for some sub' with dom(sub') subseteq vars. Returns (sub ++ sub', vars - dom(sub')). *) and isel_match isel1 sub vars isel2 = match (isel1, isel2) with - | [], [] - -> Some (sub, vars) - | [], _ | _, [] - -> None - | (idx1, se1') :: isel1', (idx2, se2') :: isel2' - -> let idx2 = Sil.exp_sub (`Exp sub) idx2 in + | [], [] -> + Some (sub, vars) + | [], _ | _, [] -> + None + | (idx1, se1') :: isel1', (idx2, se2') :: isel2' -> + let idx2 = Sil.exp_sub (`Exp sub) idx2 in let sanity_check = not (List.exists ~f:(fun id -> Sil.ident_in_exp id idx2) vars) in if not sanity_check then let pe = Pp.text in @@ -169,42 +174,45 @@ and isel_match isel1 sub vars isel2 = assert false else if Exp.equal idx1 idx2 then match strexp_match se1' sub vars se2' with - | None - -> None - | Some (sub', vars') - -> isel_match isel1' sub' vars' isel2' + | None -> + None + | Some (sub', vars') -> + isel_match isel1' sub' vars' isel2' else None + (* extends substitution sub by creating a new substitution for vars *) let sub_extend_with_ren (sub: Sil.exp_subst) vars = let f id = (id, Exp.Var (Ident.create_fresh Ident.kprimed)) in let renaming_for_vars = Sil.exp_subst_of_list (List.map ~f vars) in Sil.sub_join sub renaming_for_vars + type sidecondition = Prop.normal Prop.t -> Sil.exp_subst -> bool let rec execute_with_backtracking = function - | [] - -> None - | [f] - -> f () - | f :: fs - -> let res_f = f () in + | [] -> + None + | [f] -> + f () + | f :: fs -> + let res_f = f () in match res_f with None -> execute_with_backtracking fs | Some _ -> res_f + let rec instantiate_to_emp p condition (sub: Sil.exp_subst) vars = function - | [] - -> if condition p sub then Some (sub, p) else None - | hpat :: hpats - -> if not hpat.flag then None + | [] -> + if condition p sub then Some (sub, p) else None + | hpat :: hpats -> + if not hpat.flag then None else match hpat.hpred with | Sil.Hpointsto _ | Sil.Hlseg (Sil.Lseg_NE, _, _, _, _) - | Sil.Hdllseg (Sil.Lseg_NE, _, _, _, _, _, _) - -> None + | Sil.Hdllseg (Sil.Lseg_NE, _, _, _, _, _, _) -> + None | Sil.Hlseg (_, _, e1, e2, _) - -> ( + -> ( let fully_instantiated = not (List.exists ~f:(fun id -> Sil.ident_in_exp id e1) vars) in @@ -212,12 +220,12 @@ let rec instantiate_to_emp p condition (sub: Sil.exp_subst) vars = function else let e1' = Sil.exp_sub (`Exp sub) e1 in match exp_match e1' sub vars e2 with - | None - -> None - | Some (sub_new, vars_leftover) - -> instantiate_to_emp p condition sub_new vars_leftover hpats ) - | Sil.Hdllseg (_, _, iF, oB, oF, iB, _) - -> let fully_instantiated = + | None -> + None + | Some (sub_new, vars_leftover) -> + instantiate_to_emp p condition sub_new vars_leftover hpats ) + | Sil.Hdllseg (_, _, iF, oB, oF, iB, _) -> + let fully_instantiated = not (List.exists ~f:(fun id -> Sil.ident_in_exp id iF || Sil.ident_in_exp id oB) vars) in @@ -226,10 +234,11 @@ let rec instantiate_to_emp p condition (sub: Sil.exp_subst) vars = function let iF' = Sil.exp_sub (`Exp sub) iF in let oB' = Sil.exp_sub (`Exp sub) oB in match exp_list_match [iF'; oB'] sub vars [oF; iB] with - | None - -> None - | Some (sub_new, vars_leftover) - -> instantiate_to_emp p condition sub_new vars_leftover hpats + | None -> + None + | Some (sub_new, vars_leftover) -> + instantiate_to_emp p condition sub_new vars_leftover hpats + (* This function has to be changed in order to * implement the idea "All lsegs outside are NE, and all lsegs inside @@ -244,15 +253,16 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = *) let do_next iter_cur _ = match Prop.prop_iter_next iter_cur with - | None - -> None - | Some iter_next - -> iter_match_with_impl tenv iter_next condition sub vars hpat hpats + | None -> + None + | Some iter_next -> + iter_match_with_impl tenv iter_next condition sub vars hpat hpats in let do_empty_hpats iter_cur _ = let sub_new, vars_leftover = - match Prop.prop_iter_current tenv iter_cur - with _, (sub_new, vars_leftover) -> (sub_new, vars_leftover) + match Prop.prop_iter_current tenv iter_cur with + | _, (sub_new, vars_leftover) -> + (sub_new, vars_leftover) in let sub_res = sub_extend_with_ren sub_new vars_leftover in let p_leftover = Prop.prop_iter_remove_curr_then_to_prop tenv iter_cur in @@ -265,8 +275,9 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = in let do_nonempty_hpats iter_cur _ = let sub_new, vars_leftover = - match Prop.prop_iter_current tenv iter_cur - with _, (sub_new, vars_leftover) -> (sub_new, vars_leftover) + match Prop.prop_iter_current tenv iter_cur with + | _, (sub_new, vars_leftover) -> + (sub_new, vars_leftover) in let hpat_next, hpats_rest = match hpats with [] -> assert false | hpat_next :: hpats_rest -> (hpat_next, hpats_rest) @@ -277,23 +288,23 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = let gen_filter_pointsto lexp2 strexp2 te2 = function | Sil.Hpointsto (lexp1, strexp1, te1) when Exp.equal te1 te2 -> ( match exp_match lexp1 sub vars lexp2 with - | None - -> None - | Some (sub', vars_leftover) - -> strexp_match strexp1 sub' vars_leftover strexp2 ) - | _ - -> None + | None -> + None + | Some (sub', vars_leftover) -> + strexp_match strexp1 sub' vars_leftover strexp2 ) + | _ -> + None in let gen_filter_lseg k2 para2 e_start2 e_end2 es_shared2 = function - | Sil.Hpointsto _ - -> None - | Sil.Hlseg (k1, para1, e_start1, e_end1, es_shared1) - -> let do_kinds_match = + | Sil.Hpointsto _ -> + None + | Sil.Hlseg (k1, para1, e_start1, e_end1, es_shared1) -> + let do_kinds_match = match (k1, k2) with - | Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_PE - -> true - | Sil.Lseg_PE, Sil.Lseg_NE - -> false + | Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_PE -> + true + | Sil.Lseg_PE, Sil.Lseg_NE -> + false in (* let do_paras_match = hpara_match_with_impl tenv hpat.flag para1 para2 *) let do_paras_match = hpara_match_with_impl tenv true para1 para2 in @@ -302,19 +313,19 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = let es1 = [e_start1; e_end1] @ es_shared1 in let es2 = [e_start2; e_end2] @ es_shared2 in exp_list_match es1 sub vars es2 - | Sil.Hdllseg _ - -> None + | Sil.Hdllseg _ -> + None in let gen_filter_dllseg k2 para2 iF2 oB2 oF2 iB2 es_shared2 = function - | Sil.Hpointsto _ | Sil.Hlseg _ - -> None - | Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, es_shared1) - -> let do_kinds_match = + | Sil.Hpointsto _ | Sil.Hlseg _ -> + None + | Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, es_shared1) -> + let do_kinds_match = match (k1, k2) with - | Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_PE - -> true - | Sil.Lseg_PE, Sil.Lseg_NE - -> false + | Sil.Lseg_NE, Sil.Lseg_NE | Sil.Lseg_NE, Sil.Lseg_PE | Sil.Lseg_PE, Sil.Lseg_PE -> + true + | Sil.Lseg_PE, Sil.Lseg_NE -> + false in (* let do_paras_match = hpara_dll_match_with_impl tenv hpat.flag para1 para2 *) let do_paras_match = hpara_dll_match_with_impl tenv true para1 para2 in @@ -326,17 +337,17 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = in match hpat.hpred with | Sil.Hpointsto (lexp2, strexp2, te2) - -> ( + -> ( let filter = gen_filter_pointsto lexp2 strexp2 te2 in match (Prop.prop_iter_find iter filter, hpats) with - | None, _ - -> None - | Some iter_cur, [] - -> do_empty_hpats iter_cur () - | Some iter_cur, _ - -> execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] ) + | None, _ -> + None + | Some iter_cur, [] -> + do_empty_hpats iter_cur () + | Some iter_cur, _ -> + execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] ) | Sil.Hlseg (k2, para2, e_start2, e_end2, es_shared2) - -> ( + -> ( let filter = gen_filter_lseg k2 para2 e_start2 e_end2 es_shared2 in let do_emp_lseg _ = let fully_instantiated_start2 = @@ -346,20 +357,20 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = else let e_start2' = Sil.exp_sub (`Exp sub) e_start2 in match (exp_match e_start2' sub vars e_end2, hpats) with - | None, _ - -> (* + | None, _ -> + (* L.out "@.... iter_match_with_impl (empty_case, fail) ....@\n@."; L.out "@[<4> sub: %a@\n@." pp_sub sub; L.out "@[<4> e_start2': %a@\n@." pp_exp e_start2'; L.out "@[<4> e_end2: %a@\n@." pp_exp e_end2; *) None - | Some (sub_new, vars_leftover), [] - -> let sub_res = sub_extend_with_ren sub_new vars_leftover in + | Some (sub_new, vars_leftover), [] -> + let sub_res = sub_extend_with_ren sub_new vars_leftover in let p_leftover = Prop.prop_iter_to_prop tenv iter in if condition p_leftover sub_res then Some (sub_res, p_leftover) else None - | Some (sub_new, vars_leftover), hpat_next :: hpats_rest - -> let p = Prop.prop_iter_to_prop tenv iter in + | Some (sub_new, vars_leftover), hpat_next :: hpats_rest -> + let p = Prop.prop_iter_to_prop tenv iter in prop_match_with_impl_sub tenv p condition sub_new vars_leftover hpat_next hpats_rest in let do_para_lseg _ = @@ -370,43 +381,43 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = let allow_impl hpred = {hpred; flag= true} in let para2_hpat, para2_hpats = match List.map ~f:allow_impl para2_inst with - | [] - -> assert false (* the body of a parameter should contain at least one * conjunct *) - | para2_pat :: para2_pats - -> (para2_pat, para2_pats) + | [] -> + assert false (* the body of a parameter should contain at least one * conjunct *) + | para2_pat :: para2_pats -> + (para2_pat, para2_pats) in let new_vars = para2_exist_vars @ vars in let new_hpats = para2_hpats @ hpats in match iter_match_with_impl tenv iter condition sub new_vars para2_hpat new_hpats with - | None - -> None - | Some (sub_res, p_leftover) when condition p_leftover sub_res - -> let not_in_para2_exist_vars id = + | None -> + None + | Some (sub_res, p_leftover) when condition p_leftover sub_res -> + let not_in_para2_exist_vars id = not (List.exists ~f:(fun id' -> Ident.equal id id') para2_exist_vars) in let sub_res' = Sil.sub_filter not_in_para2_exist_vars sub_res in Some (sub_res', p_leftover) - | Some _ - -> None + | Some _ -> + None in match (Prop.prop_iter_find iter filter, hpats) with - | None, _ when not hpat.flag - -> (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) + | None, _ when not hpat.flag -> + (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) None - | None, _ when Sil.equal_lseg_kind k2 Sil.Lseg_NE - -> (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) + | None, _ when Sil.equal_lseg_kind k2 Sil.Lseg_NE -> + (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) do_para_lseg () - | None, _ - -> (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) + | None, _ -> + (* L.out "@[.... iter_match_with_impl (lseg not-matched) ....@\n@."; *) execute_with_backtracking [do_emp_lseg; do_para_lseg] - | Some iter_cur, [] - -> (* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *) + | Some iter_cur, [] -> + (* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *) do_empty_hpats iter_cur () - | Some iter_cur, _ - -> (* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *) + | Some iter_cur, _ -> + (* L.out "@[.... iter_match_with_impl (lseg matched) ....@\n@."; *) execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] ) - | Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, es_shared2) - -> let filter = gen_filter_dllseg k2 para2 iF2 oB2 oF2 iB2 es_shared2 in + | Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, es_shared2) -> + let filter = gen_filter_dllseg k2 para2 iF2 oB2 oF2 iB2 es_shared2 in let do_emp_dllseg _ = let fully_instantiated_iFoB2 = not (List.exists ~f:(fun id -> Sil.ident_in_exp id iF2 || Sil.ident_in_exp id oB2) vars) @@ -416,14 +427,14 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = let iF2' = Sil.exp_sub (`Exp sub) iF2 in let oB2' = Sil.exp_sub (`Exp sub) oB2 in match (exp_list_match [iF2'; oB2'] sub vars [oF2; iB2], hpats) with - | None, _ - -> None - | Some (sub_new, vars_leftover), [] - -> let sub_res = sub_extend_with_ren sub_new vars_leftover in + | None, _ -> + None + | Some (sub_new, vars_leftover), [] -> + let sub_res = sub_extend_with_ren sub_new vars_leftover in let p_leftover = Prop.prop_iter_to_prop tenv iter in if condition p_leftover sub_res then Some (sub_res, p_leftover) else None - | Some (sub_new, vars_leftover), hpat_next :: hpats_rest - -> let p = Prop.prop_iter_to_prop tenv iter in + | Some (sub_new, vars_leftover), hpat_next :: hpats_rest -> + let p = Prop.prop_iter_to_prop tenv iter in prop_match_with_impl_sub tenv p condition sub_new vars_leftover hpat_next hpats_rest in let do_para_dllseg _ = @@ -434,49 +445,50 @@ let rec iter_match_with_impl tenv iter condition sub vars hpat hpats = else let iF2' = Sil.exp_sub (`Exp sub) iF2 in match exp_match iF2' sub vars iB2 with - | None - -> None - | Some (sub_new, vars_leftover) - -> let para2_exist_vars, para2_inst = + | None -> + None + | Some (sub_new, vars_leftover) -> + let para2_exist_vars, para2_inst = Sil.hpara_dll_instantiate para2 iF2 oB2 oF2 es_shared2 in (* let allow_impl hpred = {hpred=hpred; flag=hpat.flag} in *) let allow_impl hpred = {hpred; flag= true} in let para2_hpat, para2_hpats = match List.map ~f:allow_impl para2_inst with - | [] - -> assert false + | [] -> + assert false (* the body of a parameter should contain at least one * conjunct *) - | para2_pat :: para2_pats - -> (para2_pat, para2_pats) + | para2_pat :: para2_pats -> + (para2_pat, para2_pats) in let new_vars = para2_exist_vars @ vars_leftover in let new_hpats = para2_hpats @ hpats in match iter_match_with_impl tenv iter condition sub_new new_vars para2_hpat new_hpats with - | None - -> None - | Some (sub_res, p_leftover) when condition p_leftover sub_res - -> let not_in_para2_exist_vars id = + | None -> + None + | Some (sub_res, p_leftover) when condition p_leftover sub_res -> + let not_in_para2_exist_vars id = not (List.exists ~f:(fun id' -> Ident.equal id id') para2_exist_vars) in let sub_res' = Sil.sub_filter not_in_para2_exist_vars sub_res in Some (sub_res', p_leftover) - | Some _ - -> None + | Some _ -> + None in match (Prop.prop_iter_find iter filter, hpats) with - | None, _ when not hpat.flag - -> None - | None, _ when Sil.equal_lseg_kind k2 Sil.Lseg_NE - -> do_para_dllseg () - | None, _ - -> execute_with_backtracking [do_emp_dllseg; do_para_dllseg] - | Some iter_cur, [] - -> do_empty_hpats iter_cur () - | Some iter_cur, _ - -> execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] + | None, _ when not hpat.flag -> + None + | None, _ when Sil.equal_lseg_kind k2 Sil.Lseg_NE -> + do_para_dllseg () + | None, _ -> + execute_with_backtracking [do_emp_dllseg; do_para_dllseg] + | Some iter_cur, [] -> + do_empty_hpats iter_cur () + | Some iter_cur, _ -> + execute_with_backtracking [do_nonempty_hpats iter_cur; do_next iter_cur] + and prop_match_with_impl_sub tenv p condition sub vars hpat hpats = (* @@ -487,10 +499,11 @@ and prop_match_with_impl_sub tenv p condition sub vars hpat hpats = L.out "@[<4> hpred_rest: %a@\n@." pp_hpat_list hpats; *) match Prop.prop_iter_create p with - | None - -> instantiate_to_emp p condition sub vars (hpat :: hpats) - | Some iter - -> iter_match_with_impl tenv iter condition sub vars hpat hpats + | None -> + instantiate_to_emp p condition sub vars (hpat :: hpats) + | Some iter -> + iter_match_with_impl tenv iter condition sub vars hpat hpats + and hpara_common_match_with_impl tenv impl_ok ids1 sigma1 eids2 ids2 sigma2 = try @@ -508,10 +521,10 @@ and hpara_common_match_with_impl tenv impl_ok ids1 sigma1 eids2 ids2 sigma2 = in let sub = Sil.exp_subst_of_list (sub_ids @ sub_eids) in match sigma2 with - | [] - -> if List.is_empty sigma1 then true else false - | hpred2 :: sigma2 - -> let hpat2, hpats2 = + | [] -> + if List.is_empty sigma1 then true else false + | hpred2 :: sigma2 -> + let hpat2, hpats2 = let hpred2_ren, sigma2_ren = (Sil.hpred_sub (`Exp sub) hpred2, Prop.sigma_sub (`Exp sub) sigma2) in @@ -523,14 +536,15 @@ and hpara_common_match_with_impl tenv impl_ok ids1 sigma1 eids2 ids2 sigma2 = match prop_match_with_impl_sub tenv p1 condition Sil.exp_sub_empty eids_fresh hpat2 hpats2 with - | None - -> false - | Some (_, p1') when Prop.prop_is_emp p1' - -> true - | _ - -> false + | None -> + false + | Some (_, p1') when Prop.prop_is_emp p1' -> + true + | _ -> + false with Invalid_argument _ -> false + and hpara_match_with_impl tenv impl_ok para1 para2 : bool = (* L.out "@[.... hpara_match_with_impl_sub ....@."; @@ -542,6 +556,7 @@ and hpara_match_with_impl tenv impl_ok para1 para2 : bool = let eids2 = para2.Sil.evars in hpara_common_match_with_impl tenv impl_ok ids1 para1.Sil.body eids2 ids2 para2.Sil.body + and hpara_dll_match_with_impl tenv impl_ok para1 para2 : bool = (* L.out "@[.... hpara_dll_match_with_impl_sub ....@."; @@ -553,6 +568,7 @@ and hpara_dll_match_with_impl tenv impl_ok para1 para2 : bool = let eids2 = para2.Sil.evars_dll in hpara_common_match_with_impl tenv impl_ok ids1 para1.Sil.body_dll eids2 ids2 para2.Sil.body_dll + (** [prop_match_with_impl p condition vars hpat hpats] returns [(subst, p_leftover)] such that 1) [dom(subst) = vars] @@ -561,21 +577,23 @@ and hpara_dll_match_with_impl tenv impl_ok para1 para2 : bool = let prop_match_with_impl tenv p condition vars hpat hpats = prop_match_with_impl_sub tenv p condition Sil.exp_sub_empty vars hpat hpats + let sigma_remove_hpred eq sigma e = let filter = function | Sil.Hpointsto (root, _, _) | Sil.Hlseg (_, _, root, _, _) - | Sil.Hdllseg (_, _, root, _, _, _, _) - -> eq root e + | Sil.Hdllseg (_, _, root, _, _, _, _) -> + eq root e in let sigma_e, sigma_no_e = List.partition_tf ~f:filter sigma in match sigma_e with - | [] - -> (None, sigma) - | [hpred_e] - -> (Some hpred_e, sigma_no_e) - | _ - -> assert false + | [] -> + (None, sigma) + | [hpred_e] -> + (Some hpred_e, sigma_no_e) + | _ -> + assert false + (** {2 Routines used when finding disjoint isomorphic sigmas from a single sigma} *) @@ -585,94 +603,102 @@ let equal_iso_mode = [%compare.equal : iso_mode] let rec generate_todos_from_strexp mode todos sexp1 sexp2 = match (sexp1, sexp2) with - | Sil.Eexp (exp1, _), Sil.Eexp (exp2, _) - -> let new_todos = (exp1, exp2) :: todos in + | Sil.Eexp (exp1, _), Sil.Eexp (exp2, _) -> + let new_todos = (exp1, exp2) :: todos in Some new_todos - | Sil.Eexp _, _ - -> None - | Sil.Estruct (fel1, _), Sil.Estruct (fel2, _) - -> (* assume sorted w.r.t. fields *) + | Sil.Eexp _, _ -> + None + | Sil.Estruct (fel1, _), Sil.Estruct (fel2, _) -> + (* assume sorted w.r.t. fields *) if List.length fel1 <> List.length fel2 && equal_iso_mode mode Exact then None else generate_todos_from_fel mode todos fel1 fel2 - | Sil.Estruct _, _ - -> None - | Sil.Earray (len1, iel1, _), Sil.Earray (len2, iel2, _) - -> if not (Exp.equal len1 len2) || List.length iel1 <> List.length iel2 then None + | Sil.Estruct _, _ -> + None + | Sil.Earray (len1, iel1, _), Sil.Earray (len2, iel2, _) -> + if not (Exp.equal len1 len2) || List.length iel1 <> List.length iel2 then None else generate_todos_from_iel mode todos iel1 iel2 - | Sil.Earray _, _ - -> None + | Sil.Earray _, _ -> + None + and generate_todos_from_fel mode todos fel1 fel2 = match (fel1, fel2) with - | [], [] - -> Some todos - | [], _ - -> if equal_iso_mode mode RFieldForget then Some todos else None - | _, [] - -> if equal_iso_mode mode LFieldForget then Some todos else None - | (fld1, strexp1) :: fel1', (fld2, strexp2) :: fel2' - -> let n = Typ.Fieldname.compare fld1 fld2 in + | [], [] -> + Some todos + | [], _ -> + if equal_iso_mode mode RFieldForget then Some todos else None + | _, [] -> + if equal_iso_mode mode LFieldForget then Some todos else None + | (fld1, strexp1) :: fel1', (fld2, strexp2) :: fel2' -> + let n = Typ.Fieldname.compare fld1 fld2 in if Int.equal n 0 then match generate_todos_from_strexp mode todos strexp1 strexp2 with - | None - -> None - | Some todos' - -> generate_todos_from_fel mode todos' fel1' fel2' + | None -> + None + | Some todos' -> + generate_todos_from_fel mode todos' fel1' fel2' else if n < 0 && equal_iso_mode mode LFieldForget then generate_todos_from_fel mode todos fel1' fel2 else if n > 0 && equal_iso_mode mode RFieldForget then generate_todos_from_fel mode todos fel1 fel2' else None + and generate_todos_from_iel mode todos iel1 iel2 = match (iel1, iel2) with - | [], [] - -> Some todos + | [], [] -> + Some todos | (idx1, strexp1) :: iel1', (idx2, strexp2) :: iel2' -> ( match generate_todos_from_strexp mode todos strexp1 strexp2 with - | None - -> None - | Some todos' - -> let new_todos = (idx1, idx2) :: todos' in + | None -> + None + | Some todos' -> + let new_todos = (idx1, idx2) :: todos' in generate_todos_from_iel mode new_todos iel1' iel2' ) - | _ - -> None + | _ -> + None + (** add (e1,e2) at the front of corres, if necessary. *) let corres_extend_front e1 e2 corres = let filter (e1', e2') = Exp.equal e1 e1' || Exp.equal e2 e2' in let checker e1' e2' = Exp.equal e1 e1' && Exp.equal e2 e2' in match List.filter ~f:filter corres with - | [] - -> Some ((e1, e2) :: corres) - | [(e1', e2')] when checker e1' e2' - -> Some corres - | _ - -> None + | [] -> + Some ((e1, e2) :: corres) + | [(e1', e2')] when checker e1' e2' -> + Some corres + | _ -> + None + let corres_extensible corres e1 e2 = let predicate (e1', e2') = Exp.equal e1 e1' || Exp.equal e2 e2' in not (List.exists ~f:predicate corres) && not (Exp.equal e1 e2) + let corres_related corres e1 e2 = let filter (e1', e2') = Exp.equal e1 e1' || Exp.equal e2 e2' in let checker e1' e2' = Exp.equal e1 e1' && Exp.equal e2 e2' in match List.filter ~f:filter corres with - | [] - -> Exp.equal e1 e2 - | [(e1', e2')] when checker e1' e2' - -> true - | _ - -> false + | [] -> + Exp.equal e1 e2 + | [(e1', e2')] when checker e1' e2' -> + true + | _ -> + false + (* TO DO. Perhaps OK. Need to implemenet a better isomorphism check later.*) let hpara_iso tenv para1 para2 = hpara_match_with_impl tenv false para1 para2 && hpara_match_with_impl tenv false para2 para1 + let hpara_dll_iso tenv para1 para2 = hpara_dll_match_with_impl tenv false para1 para2 && hpara_dll_match_with_impl tenv false para2 para1 + (** [generic_find_partial_iso] finds isomorphic subsigmas of [sigma_todo]. The function [update] is used to get rid of hpred pairs from [sigma_todo]. [sigma_corres] records the isormophic copies discovered so far. The first @@ -680,40 +706,40 @@ let hpara_dll_iso tenv para1 para2 = isomorphism finding. *) let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigma_todo = match todos with - | [] - -> let sigma1, sigma2 = sigma_corres in + | [] -> + let sigma1, sigma2 = sigma_corres in Some (List.rev corres, List.rev sigma1, List.rev sigma2, sigma_todo) | (e1, e2) :: todos' when corres_related corres e1 e2 -> ( match corres_extend_front e1 e2 corres with - | None - -> assert false - | Some new_corres - -> generic_find_partial_iso tenv mode update new_corres sigma_corres todos' sigma_todo ) + | None -> + assert false + | Some new_corres -> + generic_find_partial_iso tenv mode update new_corres sigma_corres todos' sigma_todo ) | (e1, e2) :: todos' when corres_extensible corres e1 e2 - -> ( + -> ( let hpredo1, hpredo2, new_sigma_todo = update e1 e2 sigma_todo in match (hpredo1, hpredo2) with | None, None -> ( match corres_extend_front e1 e2 corres with - | None - -> assert false - | Some new_corres - -> generic_find_partial_iso tenv mode update new_corres sigma_corres todos' sigma_todo ) - | None, _ | _, None - -> None - | Some Sil.Hpointsto (_, _, te1), Some Sil.Hpointsto (_, _, te2) when not (Exp.equal te1 te2) - -> None + | None -> + assert false + | Some new_corres -> + generic_find_partial_iso tenv mode update new_corres sigma_corres todos' sigma_todo ) + | None, _ | _, None -> + None + | Some Sil.Hpointsto (_, _, te1), Some Sil.Hpointsto (_, _, te2) when not (Exp.equal te1 te2) -> + None | Some (Sil.Hpointsto (_, se1, _) as hpred1), Some (Sil.Hpointsto (_, se2, _) as hpred2) -> ( match generate_todos_from_strexp mode [] se1 se2 with - | None - -> None - | Some todos'' - -> let new_corres = + | None -> + None + | Some todos'' -> + let new_corres = match corres_extend_front e1 e2 corres with - | None - -> assert false - | Some new_corres - -> new_corres + | None -> + assert false + | Some new_corres -> + new_corres in let new_sigma_corres = let sigma1, sigma2 = sigma_corres in @@ -726,16 +752,16 @@ let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigm new_sigma_todo ) | ( Some (Sil.Hlseg (k1, para1, root1, next1, shared1) as hpred1) , Some (Sil.Hlseg (k2, para2, root2, next2, shared2) as hpred2) ) - -> ( + -> ( if k1 <> k2 || not (hpara_iso tenv para1 para2) then None else try let new_corres = match corres_extend_front e1 e2 corres with - | None - -> assert false - | Some new_corres - -> new_corres + | None -> + assert false + | Some new_corres -> + new_corres in let new_sigma_corres = let sigma1, sigma2 = sigma_corres in @@ -752,16 +778,16 @@ let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigm with Invalid_argument _ -> None ) | ( Some (Sil.Hdllseg (k1, para1, iF1, oB1, oF1, iB1, shared1) as hpred1) , Some (Sil.Hdllseg (k2, para2, iF2, oB2, oF2, iB2, shared2) as hpred2) ) - -> ( + -> ( if k1 <> k2 || not (hpara_dll_iso tenv para1 para2) then None else try let new_corres = match corres_extend_front e1 e2 corres with - | None - -> assert false - | Some new_corres - -> new_corres + | None -> + assert false + | Some new_corres -> + new_corres in let new_sigma_corres = let sigma1, sigma2 = sigma_corres in @@ -776,10 +802,11 @@ let rec generic_find_partial_iso tenv mode update corres sigma_corres todos sigm generic_find_partial_iso tenv mode update new_corres new_sigma_corres new_todos new_sigma_todo with Invalid_argument _ -> None ) - | _ - -> None ) - | _ - -> None + | _ -> + None ) + | _ -> + None + (** [find_partial_iso] finds disjoint isomorphic sub-sigmas inside a given sigma. The function returns a partial iso and three sigmas. The first sigma is the first @@ -797,6 +824,7 @@ let find_partial_iso tenv eq corres todos sigma = let init_sigma_todo = sigma in generic_find_partial_iso tenv Exact update corres init_sigma_corres todos init_sigma_todo + (** [find_partial_iso_from_two_sigmas] finds isomorphic sub-sigmas inside two given sigmas. The function returns a partial iso and four sigmas. The first sigma is the first copy of the two isomorphic sigmas, so it uses expressions in the domain of @@ -815,15 +843,17 @@ let find_partial_iso_from_two_sigmas tenv mode eq corres todos sigma1 sigma2 = let init_sigma_todo = (sigma1, sigma2) in generic_find_partial_iso tenv mode update corres init_sigma_corres todos init_sigma_todo + (** Lift the kind of list segment predicates to PE *) let hpred_lift_to_pe hpred = match hpred with - | Sil.Hpointsto _ - -> hpred - | Sil.Hlseg (_, para, root, next, shared) - -> Sil.Hlseg (Sil.Lseg_PE, para, root, next, shared) - | Sil.Hdllseg (_, para, iF, oB, oF, iB, shared) - -> Sil.Hdllseg (Sil.Lseg_PE, para, iF, oB, oF, iB, shared) + | Sil.Hpointsto _ -> + hpred + | Sil.Hlseg (_, para, root, next, shared) -> + Sil.Hlseg (Sil.Lseg_PE, para, root, next, shared) + | Sil.Hdllseg (_, para, iF, oB, oF, iB, shared) -> + Sil.Hdllseg (Sil.Lseg_PE, para, iF, oB, oF, iB, shared) + (** Lift the kind of list segment predicates to PE in a given sigma *) let sigma_lift_to_pe sigma = List.map ~f:hpred_lift_to_pe sigma @@ -838,10 +868,10 @@ let sigma_lift_to_pe sigma = List.map ~f:hpred_lift_to_pe sigma let generic_para_create tenv corres sigma1 elist1 = let corres_ids = let not_same_consts = function - | Exp.Const c1, Exp.Const c2 - -> not (Const.equal c1 c2) - | _ - -> true + | Exp.Const c1, Exp.Const c2 -> + not (Const.equal c1 c2) + | _ -> + true in let new_corres' = List.filter ~f:not_same_consts corres in let add_fresh_id pair = (pair, Ident.create_fresh Ident.kprimed) in @@ -863,6 +893,7 @@ let generic_para_create tenv corres sigma1 elist1 = in (renaming, body, ids_exists, ids_shared, es_shared) + (** [hpara_create] takes a correspondence, and a sigma, a root and a next for the first part of this correspondence. Then, it creates a hpara and discovers a list of shared expressions that are @@ -878,14 +909,11 @@ let hpara_create tenv corres sigma1 root1 next1 = let id_root = get_id1 root1 in let id_next = get_id1 next1 in let hpara = - { Sil.root= id_root - ; Sil.next= id_next - ; Sil.svars= ids_shared - ; Sil.evars= ids_exists - ; Sil.body= body } + {Sil.root= id_root; Sil.next= id_next; Sil.svars= ids_shared; Sil.evars= ids_exists; Sil.body} in (hpara, es_shared) + (** [hpara_dll_create] takes a correspondence, and a sigma, a root, a blink and a flink for the first part of this correspondence. Then, it creates a hpara_dll and discovers a list of shared expressions that are @@ -910,3 +938,4 @@ let hpara_dll_create tenv corres sigma1 root1 blink1 flink1 = ; Sil.body_dll= body } in (hpara_dll, es_shared) + diff --git a/infer/src/backend/mergeCapture.ml b/infer/src/backend/mergeCapture.ml index 5fa2b9682..ef90fa38c 100644 --- a/infer/src/backend/mergeCapture.ml +++ b/infer/src/backend/mergeCapture.ml @@ -24,10 +24,12 @@ let modified_targets = ref String.Set.empty let record_modified_targets_from_file file = match Utils.read_file file with - | Ok targets - -> modified_targets := List.fold ~f:String.Set.add ~init:String.Set.empty targets - | Error error - -> L.user_error "Failed to read modified targets file '%s': %s@." file error ; () + | Ok targets -> + modified_targets := List.fold ~f:String.Set.add ~init:String.Set.empty targets + | Error error -> + L.user_error "Failed to read modified targets file '%s': %s@." file error ; + () + type stats = {mutable files_linked: int; mutable targets_merged: int} @@ -39,6 +41,7 @@ let link_exists s = true with Unix.Unix_error _ -> false + let create_link ~stats src dst = if link_exists dst then Unix.unlink dst ; Unix.symlink ~src ~dst ; @@ -50,6 +53,7 @@ let create_link ~stats src dst = Unix.utimes src ~access:near_past ~modif:near_past ; stats.files_linked <- stats.files_linked + 1 + (** Create symbolic links recursively from the destination to the source. Replicate the structure of the source directory in the destination, with files replaced by links to the source. *) @@ -66,6 +70,7 @@ let rec slink ~stats ~skiplevels src dst = else if skiplevels > 0 then () else create_link ~stats src dst + (** Determine if the destination should link to the source. To check if it was linked before, check if all the captured source files from the source are also in the destination. @@ -113,6 +118,7 @@ let should_link ~target ~target_results_dir ~stats infer_out_src infer_out_dst = if r then L.(debug MergeCapture Medium) "%s@." target_results_dir ; r + (** should_link needs to know whether the source file has changed, and to determine whether the destination has never been copied. In both cases, perform the link. *) @@ -121,8 +127,8 @@ let process_merge_file deps_file = let stats = empty_stats () in let process_line line = match Str.split_delim (Str.regexp (Str.quote "\t")) line with - | target :: _ :: target_results_dir :: _ - -> let infer_out_src = + | target :: _ :: target_results_dir :: _ -> + let infer_out_src = if Filename.is_relative target_results_dir then Filename.dirname (buck_out ()) ^/ target_results_dir else target_results_dir @@ -131,17 +137,18 @@ let process_merge_file deps_file = (* Don't link toplevel files, definitely not .start *) if should_link ~target ~target_results_dir ~stats infer_out_src infer_out_dst then slink ~stats ~skiplevels infer_out_src infer_out_dst - | _ - -> () + | _ -> + () in ( match Utils.read_file deps_file with - | Ok lines - -> List.iter ~f:process_line lines - | Error error - -> L.internal_error "Couldn't read deps file '%s': %s" deps_file error ) ; + | Ok lines -> + List.iter ~f:process_line lines + | Error error -> + L.internal_error "Couldn't read deps file '%s': %s" deps_file error ) ; L.progress "Targets merged: %d@\n" stats.targets_merged ; L.progress "Files linked: %d@\n" stats.files_linked + let merge_captured_targets () = let time0 = Mtime_clock.counter () in L.progress "Merging captured Buck targets...@\n%!" ; @@ -149,3 +156,4 @@ let merge_captured_targets () = MergeResults.merge_buck_flavors_results infer_deps_file ; process_merge_file infer_deps_file ; L.progress "Merging captured Buck targets took %a@\n%!" Mtime.Span.pp (Mtime_clock.count time0) + diff --git a/infer/src/backend/ondemand.ml b/infer/src/backend/ondemand.ml index c8baa0643..b002882e3 100644 --- a/infer/src/backend/ondemand.ml +++ b/infer/src/backend/ondemand.ml @@ -39,35 +39,39 @@ let is_active, add_active, remove_active = in (is_active, add_active, remove_active) + let should_create_summary proc_name proc_attributes = match proc_name with - | Typ.Procname.Java _ - -> true - | _ - -> proc_attributes.ProcAttributes.is_defined + | Typ.Procname.Java _ -> + true + | _ -> + proc_attributes.ProcAttributes.is_defined + let should_be_analyzed proc_name proc_attributes = let already_analyzed () = match Specs.get_summary proc_name with - | Some summary - -> Specs.equal_status (Specs.get_status summary) Specs.Analyzed - | None - -> false + | Some summary -> + Specs.equal_status (Specs.get_status summary) Specs.Analyzed + | None -> + false in should_create_summary proc_name proc_attributes && not (is_active proc_name) && (* avoid infinite loops *) not (already_analyzed ()) + let procedure_should_be_analyzed proc_name = match Specs.proc_resolve_attributes proc_name with - | Some proc_attributes when Config.reactive_capture && not proc_attributes.is_defined - -> (* try to capture procedure first *) + | Some proc_attributes when Config.reactive_capture && not proc_attributes.is_defined -> + (* try to capture procedure first *) let defined_proc_attributes = OndemandCapture.try_capture proc_attributes in Option.value_map ~f:(should_be_analyzed proc_name) ~default:false defined_proc_attributes - | Some proc_attributes - -> should_be_analyzed proc_name proc_attributes - | None - -> false + | Some proc_attributes -> + should_be_analyzed proc_name proc_attributes + | None -> + false + type global_state = { abs_val: int @@ -89,6 +93,7 @@ let save_global_state () = ; name_generator= Ident.NameGenerator.get_current () ; symexec_state= State.save_state () } + let restore_global_state st = Config.abs_val := st.abs_val ; Abs.set_current_rules st.abstraction_rules ; @@ -99,6 +104,7 @@ let restore_global_state st = State.restore_state st.symexec_state ; Timeout.resume_previous_timeout () + let run_proc_analysis analyze_proc curr_pdesc callee_pdesc = let curr_pname = Procdesc.get_proc_name curr_pdesc in let callee_pname = Procdesc.get_proc_name callee_pdesc in @@ -130,7 +136,7 @@ let run_proc_analysis analyze_proc curr_pdesc callee_pdesc = Reporting.log_error summary exn ; let stats = {summary.Specs.stats with Specs.stats_failure= Some kind} in let payload = {summary.Specs.payload with Specs.preposts= Some []} in - let new_summary = {summary with Specs.stats= stats; payload} in + let new_summary = {summary with Specs.stats; payload} in Specs.store_summary new_summary ; remove_active callee_pname ; log_elapsed_time () ; @@ -151,44 +157,50 @@ let run_proc_analysis analyze_proc curr_pdesc callee_pdesc = L.internal_error "@\nERROR RUNNING BACKEND: %a %s@\n@\nBACK TRACE@\n%s@?" Typ.Procname.pp callee_pname (Exn.to_string exn) (Printexc.get_backtrace ()) ; match exn with - | SymOp.Analysis_failure_exe kind - -> (* in production mode, log the timeout/crash and continue with the summary we had before + | SymOp.Analysis_failure_exe kind -> + (* in production mode, log the timeout/crash and continue with the summary we had before the failure occurred *) log_error_and_continue exn initial_summary kind - | _ - -> (* this happens with assert false or some other unrecognized exception *) + | _ -> + (* this happens with assert false or some other unrecognized exception *) log_error_and_continue exn initial_summary (FKcrash (Exn.to_string exn)) + let analyze_proc_desc curr_pdesc callee_pdesc : Specs.summary option = let callee_pname = Procdesc.get_proc_name callee_pdesc in let proc_attributes = Procdesc.get_attributes callee_pdesc in match !callbacks_ref with - | None - -> L.(die InternalError) + | None -> + L.(die InternalError) "No callbacks registered to analyze proc desc %a when analyzing %a" Typ.Procname.pp - callee_pname Typ.Procname.pp (Procdesc.get_proc_name curr_pdesc) - | Some callbacks - -> if should_be_analyzed callee_pname proc_attributes then + callee_pname Typ.Procname.pp + (Procdesc.get_proc_name curr_pdesc) + | Some callbacks -> + if should_be_analyzed callee_pname proc_attributes then Some (run_proc_analysis callbacks.analyze_ondemand curr_pdesc callee_pdesc) else Specs.get_summary callee_pname + (** analyze_proc_name curr_pdesc proc_name performs an on-demand analysis of proc_name triggered during the analysis of curr_pname *) let analyze_proc_name curr_pdesc callee_pname : Specs.summary option = match !callbacks_ref with - | None - -> L.(die InternalError) + | None -> + L.(die InternalError) "No callbacks registered to analyze proc name %a when analyzing %a@." Typ.Procname.pp - callee_pname Typ.Procname.pp (Procdesc.get_proc_name curr_pdesc) - | Some callbacks - -> if procedure_should_be_analyzed callee_pname then + callee_pname Typ.Procname.pp + (Procdesc.get_proc_name curr_pdesc) + | Some callbacks -> + if procedure_should_be_analyzed callee_pname then match callbacks.get_proc_desc callee_pname with - | Some callee_pdesc - -> analyze_proc_desc curr_pdesc callee_pdesc - | None - -> Specs.get_summary callee_pname + | Some callee_pdesc -> + analyze_proc_desc curr_pdesc callee_pdesc + | None -> + Specs.get_summary callee_pname else Specs.get_summary callee_pname + (** Find a proc desc for the procedure, perhaps loading it from disk. *) let get_proc_desc callee_pname = match !callbacks_ref with Some callbacks -> callbacks.get_proc_desc callee_pname | None -> None + diff --git a/infer/src/backend/paths.ml b/infer/src/backend/paths.ml index 1f985259c..86cc251c8 100644 --- a/infer/src/backend/paths.ml +++ b/infer/src/backend/paths.ml @@ -118,44 +118,51 @@ end = struct let get_description path = match path with Pnode (_, _, _, _, _, descr_opt) -> descr_opt | _ -> None + let add_description path description = let add_descr descr_option description = match descr_option with Some descr -> descr ^ " " ^ description | None -> description in match path with - | Pnode (node, exn_opt, session, path, stats, descr_opt) - -> let description = add_descr descr_opt description in + | Pnode (node, exn_opt, session, path, stats, descr_opt) -> + let description = add_descr descr_opt description in Pnode (node, exn_opt, session, path, stats, Some description) - | _ - -> path + | _ -> + path + let set_dummy_stats stats = stats.max_length <- -1 ; stats.linear_num <- -1.0 + let rec curr_node = function - | Pstart (node, _) - -> Some node - | Pnode (node, _, _, _, _, _) - -> Some node - | Pcall (path, _, _, _) - -> curr_node path - | Pjoin _ - -> None + | Pstart (node, _) -> + Some node + | Pnode (node, _, _, _, _, _) -> + Some node + | Pcall (path, _, _, _) -> + curr_node path + | Pjoin _ -> + None + let start node = Pstart (node, get_dummy_stats ()) let extend (node: Procdesc.Node.t) exn_opt session path = Pnode (node, exn_opt, session, path, get_dummy_stats (), None) + let join p1 p2 = Pjoin (p1, p2, get_dummy_stats ()) let add_call include_subtrace p pname p_sub = if include_subtrace then Pcall (p, pname, ExecCompleted p_sub, get_dummy_stats ()) else p + let add_skipped_call p pname reason loc_opt = Pcall (p, pname, ExecSkipped (reason, loc_opt), get_dummy_stats ()) + (** functions in this module either do not assume, or do not re-establish, the invariant on dummy stats *) module Invariant = struct @@ -164,30 +171,32 @@ end = struct (** return the stats of the path, assumes that the stats are computed *) let get_stats = function - | Pstart (_, stats) - -> stats - | Pnode (_, _, _, _, stats, _) - -> stats - | Pjoin (_, _, stats) - -> stats - | Pcall (_, _, _, stats) - -> stats + | Pstart (_, stats) -> + stats + | Pnode (_, _, _, _, stats, _) -> + stats + | Pjoin (_, _, stats) -> + stats + | Pcall (_, _, _, stats) -> + stats + (** restore the invariant that all the stats are dummy, so the path is ready for another traversal assumes that the stats are computed beforehand, and ensures that the invariant holds afterwards *) let rec reset_stats = function - | Pstart (_, stats) - -> if not (stats_is_dummy stats) then set_dummy_stats stats - | Pnode (_, _, _, path, stats, _) | Pcall (path, _, ExecSkipped _, stats) - -> if not (stats_is_dummy stats) then ( reset_stats path ; set_dummy_stats stats ) - | Pjoin (path1, path2, stats) - -> if not (stats_is_dummy stats) then ( + | Pstart (_, stats) -> + if not (stats_is_dummy stats) then set_dummy_stats stats + | Pnode (_, _, _, path, stats, _) | Pcall (path, _, ExecSkipped _, stats) -> + if not (stats_is_dummy stats) then ( reset_stats path ; set_dummy_stats stats ) + | Pjoin (path1, path2, stats) -> + if not (stats_is_dummy stats) then ( reset_stats path1 ; reset_stats path2 ; set_dummy_stats stats ) - | Pcall (path1, _, ExecCompleted path2, stats) - -> if not (stats_is_dummy stats) then ( + | Pcall (path1, _, ExecCompleted path2, stats) -> + if not (stats_is_dummy stats) then ( reset_stats path1 ; reset_stats path2 ; set_dummy_stats stats ) + (** Iterate [f] over the path and compute the stats, assuming the invariant: all the stats are dummy. Function [f] (typically with side-effects) is applied once to every node, and max_length in the stats is the length of a longest sequence of nodes in the path where [f] @@ -198,13 +207,13 @@ end = struct let rec compute_stats do_calls (f: Procdesc.Node.t -> bool) = let nodes_found stats = stats.max_length > 0 in function - | Pstart (node, stats) - -> if stats_is_dummy stats then + | Pstart (node, stats) -> + if stats_is_dummy stats then let found = f node in stats.max_length <- (if found then 1 else 0) ; stats.linear_num <- 1.0 - | Pnode (node, _, _, path, stats, _) - -> if stats_is_dummy stats then ( + | Pnode (node, _, _, path, stats, _) -> + if stats_is_dummy stats then ( compute_stats do_calls f path ; let stats1 = get_stats path in let found = @@ -213,21 +222,21 @@ end = struct in stats.max_length <- (if found then 1 + stats1.max_length else 0) ; stats.linear_num <- stats1.linear_num ) - | Pjoin (path1, path2, stats) - -> if stats_is_dummy stats then ( + | Pjoin (path1, path2, stats) -> + if stats_is_dummy stats then ( compute_stats do_calls f path1 ; compute_stats do_calls f path2 ; let stats1, stats2 = (get_stats path1, get_stats path2) in stats.max_length <- max stats1.max_length stats2.max_length ; stats.linear_num <- stats1.linear_num +. stats2.linear_num ) - | Pcall (path1, _, ExecCompleted path2, stats) - -> if stats_is_dummy stats then + | Pcall (path1, _, ExecCompleted path2, stats) -> + if stats_is_dummy stats then let stats2 = match do_calls with - | true - -> compute_stats do_calls f path2 ; get_stats path2 - | false - -> {max_length= 0; linear_num= 0.0} + | true -> + compute_stats do_calls f path2 ; get_stats path2 + | false -> + {max_length= 0; linear_num= 0.0} in let stats1 = let f' = @@ -239,11 +248,12 @@ end = struct in stats.max_length <- stats1.max_length + stats2.max_length ; stats.linear_num <- stats1.linear_num - | Pcall (path, _, ExecSkipped _, stats) - -> if stats_is_dummy stats then + | Pcall (path, _, ExecSkipped _, stats) -> + if stats_is_dummy stats then let stats1 = compute_stats do_calls f path ; get_stats path in stats.max_length <- stats1.max_length ; stats.linear_num <- stats1.linear_num + end (* End of module Invariant *) @@ -252,18 +262,23 @@ end = struct Invariant.compute_stats false (fun node -> f node ; true) path ; Invariant.reset_stats path + let get_path_pos node = let pn = Procdesc.Node.get_proc_name node in let n_id = Procdesc.Node.get_id node in (pn, (n_id :> int)) + let contains_position path pos = let found = ref false in let f node = if PredSymb.equal_path_pos (get_path_pos node) pos then found := true ; true in - Invariant.compute_stats true f path ; Invariant.reset_stats path ; !found + Invariant.compute_stats true f path ; + Invariant.reset_stats path ; + !found + (** iterate over the longest sequence belonging to the path, restricting to those where [filter] holds of some element. @@ -273,27 +288,30 @@ end = struct (filter: Procdesc.Node.t -> bool) (path: t) : unit = let rec doit level session path prev_exn_opt = match path with - | Pstart _ - -> f level path session prev_exn_opt - | Pnode (_, exn_opt, session', p, _, _) - -> (* no two consecutive exceptions *) + | Pstart _ -> + f level path session prev_exn_opt + | Pnode (_, exn_opt, session', p, _, _) -> + (* no two consecutive exceptions *) let next_exn_opt = if prev_exn_opt <> None then None else exn_opt in doit level (session' :> int) p next_exn_opt ; f level path session prev_exn_opt - | Pjoin (p1, p2, _) - -> if (Invariant.get_stats p1).max_length <= (Invariant.get_stats p2).max_length then + | Pjoin (p1, p2, _) -> + if (Invariant.get_stats p1).max_length <= (Invariant.get_stats p2).max_length then doit level session p1 prev_exn_opt else doit level session p2 prev_exn_opt - | Pcall (p1, _, ExecCompleted p2, _) - -> let next_exn_opt = None in + | Pcall (p1, _, ExecCompleted p2, _) -> + let next_exn_opt = None in (* exn must already be inside the call *) doit level session p1 next_exn_opt ; doit (level + 1) session p2 next_exn_opt - | Pcall (p, _, ExecSkipped _, _) - -> let next_exn_opt = None in + | Pcall (p, _, ExecSkipped _, _) -> + let next_exn_opt = None in doit level session p next_exn_opt ; f level path session prev_exn_opt in - Invariant.compute_stats true filter path ; doit 0 0 path None ; Invariant.reset_stats path + Invariant.compute_stats true filter path ; + doit 0 0 path None ; + Invariant.reset_stats path + (** iterate over the shortest sequence belonging to the path, restricting to those containing the given position if given. @@ -304,10 +322,10 @@ end = struct (pos_opt: PredSymb.path_pos option) (path: t) : unit = let filter node = match pos_opt with - | None - -> true - | Some pos - -> PredSymb.equal_path_pos (get_path_pos node) pos + | None -> + true + | Some pos -> + PredSymb.equal_path_pos (get_path_pos node) pos in let path_pos_at_path p = try match curr_node p with Some node -> pos_opt <> None && filter node | None -> false @@ -320,15 +338,16 @@ end = struct if path_pos_at_path p then position_seen := true ; log := (level, p, session, exn_opt) :: !log in - iter_shortest_sequence_filter g filter path ; !log + iter_shortest_sequence_filter g filter path ; + !log in let sequence_up_to_last_seen = if !position_seen then let rec remove_until_seen = function - | (_, p, _, _ as x) :: l - -> if path_pos_at_path p then List.rev (x :: l) else remove_until_seen l - | [] - -> [] + | ((_, p, _, _) as x) :: l -> + if path_pos_at_path p then List.rev (x :: l) else remove_until_seen l + | [] -> + [] in remove_until_seen inverse_sequence else List.rev inverse_sequence @@ -337,6 +356,7 @@ end = struct ~f:(fun (level, p, session, exn_opt) -> f level p session exn_opt) sequence_up_to_last_seen + (** return the node visited most, and number of visits, in the shortest linear sequence *) let repetitions path = let map = ref Procdesc.NodeMap.empty in @@ -346,8 +366,8 @@ end = struct let n = Procdesc.NodeMap.find node !map in map := Procdesc.NodeMap.add node (n + 1) !map with Not_found -> map := Procdesc.NodeMap.add node 1 !map ) - | None - -> () + | None -> + () in iter_shortest_sequence (fun _ p _ _ -> add_node (curr_node p)) None path ; let max_rep_node = ref (Procdesc.Node.dummy None) in @@ -360,6 +380,7 @@ end = struct !map ; (!max_rep_node, !max_rep_num) + let stats_string path = Invariant.compute_stats true (fun _ -> true) path ; let node, repetitions = repetitions path in @@ -370,6 +391,7 @@ end = struct in Invariant.reset_stats path ; str + let pp_stats fmt path = F.fprintf fmt "%s" (stats_string path) let d_stats path = L.d_str (stats_string path) @@ -397,12 +419,12 @@ end = struct if not (path_seen path) (* avoid exponential blowup *) then match path with (* build a map from delayed paths to a unique number *) - | Pstart _ - -> () - | Pnode (_, _, _, p, _, _) | Pcall (p, _, ExecSkipped _, _) - -> add_delayed p - | Pjoin (p1, p2, _) | Pcall (p1, _, ExecCompleted p2, _) - -> (* delay paths occurring in a join *) + | Pstart _ -> + () + | Pnode (_, _, _, p, _, _) | Pcall (p, _, ExecSkipped _, _) -> + add_delayed p + | Pjoin (p1, p2, _) | Pcall (p1, _, ExecCompleted p2, _) -> + (* delay paths occurring in a join *) add_delayed p1 ; add_delayed p2 ; add_path p1 ; add_path p2 in let rec doit n fmt path = @@ -412,16 +434,16 @@ end = struct F.fprintf fmt "P%d" num with Not_found -> match path with - | Pstart (node, _) - -> F.fprintf fmt "n%a" Procdesc.Node.pp node - | Pnode (node, _, session, path, _, _) - -> F.fprintf fmt "%a(s%d).n%a" (doit (n - 1)) path (session :> int) Procdesc.Node.pp node - | Pjoin (path1, path2, _) - -> F.fprintf fmt "(%a + %a)" (doit (n - 1)) path1 (doit (n - 1)) path2 - | Pcall (path1, _, ExecCompleted path2, _) - -> F.fprintf fmt "(%a{%a})" (doit (n - 1)) path1 (doit (n - 1)) path2 - | Pcall (path, _, ExecSkipped (reason, _), _) - -> F.fprintf fmt "(%a: %s)" (doit (n - 1)) path reason + | Pstart (node, _) -> + F.fprintf fmt "n%a" Procdesc.Node.pp node + | Pnode (node, _, session, path, _, _) -> + F.fprintf fmt "%a(s%d).n%a" (doit (n - 1)) path (session :> int) Procdesc.Node.pp node + | Pjoin (path1, path2, _) -> + F.fprintf fmt "(%a + %a)" (doit (n - 1)) path1 (doit (n - 1)) path2 + | Pcall (path1, _, ExecCompleted path2, _) -> + F.fprintf fmt "(%a{%a})" (doit (n - 1)) path1 (doit (n - 1)) path2 + | Pcall (path, _, ExecSkipped (reason, _), _) -> + F.fprintf fmt "(%a: %s)" (doit (n - 1)) path reason in let print_delayed () = if not (PathMap.is_empty !delayed) then @@ -431,21 +453,23 @@ end = struct in add_delayed path ; doit 0 fmt path ; print_delayed () + let d p = L.add_print_action (L.PTpath, Obj.repr p) let rec contains p1 p2 = match p2 with - | Pjoin (p2', p2'', _) - -> contains p1 p2' || contains p1 p2'' - | _ - -> phys_equal p1 p2 + | Pjoin (p2', p2'', _) -> + contains p1 p2' || contains p1 p2'' + | _ -> + phys_equal p1 p2 + let create_loc_trace path pos_opt : Errlog.loc_trace = let trace = ref [] in let g level path _ exn_opt = match (path, curr_node path) with - | Pcall (_, pname, ExecSkipped (reason, loc_opt), _), Some curr_node - -> let curr_loc = Procdesc.Node.get_loc curr_node in + | Pcall (_, pname, ExecSkipped (reason, loc_opt), _), Some curr_node -> + let curr_loc = Procdesc.Node.get_loc curr_node in let descr = Format.sprintf "Skipping %s: %s" (Typ.Procname.to_simplified_string pname) reason in @@ -460,48 +484,48 @@ end = struct trace := Errlog.make_trace_element (level + 1) loc definition_descr [] :: !trace) loc_opt | _, Some curr_node - -> ( + -> ( let curr_loc = Procdesc.Node.get_loc curr_node in match Procdesc.Node.get_kind curr_node with - | Procdesc.Node.Join_node - -> () (* omit join nodes from error traces *) - | Procdesc.Node.Start_node pname - -> let descr = "start of procedure " ^ Typ.Procname.to_simplified_string pname in + | Procdesc.Node.Join_node -> + () (* omit join nodes from error traces *) + | Procdesc.Node.Start_node pname -> + let descr = "start of procedure " ^ Typ.Procname.to_simplified_string pname in let node_tags = [Errlog.Procedure_start pname] in trace := Errlog.make_trace_element level curr_loc descr node_tags :: !trace - | Procdesc.Node.Prune_node (is_true_branch, if_kind, _) - -> let descr = + | Procdesc.Node.Prune_node (is_true_branch, if_kind, _) -> + let descr = match (is_true_branch, if_kind) with - | true, Sil.Ik_if - -> "Taking true branch" - | false, Sil.Ik_if - -> "Taking false branch" - | true, (Sil.Ik_for | Sil.Ik_while | Sil.Ik_dowhile) - -> "Loop condition is true. Entering loop body" - | false, (Sil.Ik_for | Sil.Ik_while | Sil.Ik_dowhile) - -> "Loop condition is false. Leaving loop" - | true, Sil.Ik_switch - -> "Switch condition is true. Entering switch case" - | false, Sil.Ik_switch - -> "Switch condition is false. Skipping switch case" - | true, (Sil.Ik_bexp | Sil.Ik_land_lor) - -> "Condition is true" - | false, (Sil.Ik_bexp | Sil.Ik_land_lor) - -> "Condition is false" + | true, Sil.Ik_if -> + "Taking true branch" + | false, Sil.Ik_if -> + "Taking false branch" + | true, (Sil.Ik_for | Sil.Ik_while | Sil.Ik_dowhile) -> + "Loop condition is true. Entering loop body" + | false, (Sil.Ik_for | Sil.Ik_while | Sil.Ik_dowhile) -> + "Loop condition is false. Leaving loop" + | true, Sil.Ik_switch -> + "Switch condition is true. Entering switch case" + | false, Sil.Ik_switch -> + "Switch condition is false. Skipping switch case" + | true, (Sil.Ik_bexp | Sil.Ik_land_lor) -> + "Condition is true" + | false, (Sil.Ik_bexp | Sil.Ik_land_lor) -> + "Condition is false" in let node_tags = [Errlog.Condition is_true_branch] in trace := Errlog.make_trace_element level curr_loc descr node_tags :: !trace - | Procdesc.Node.Exit_node pname - -> let descr = "return from a call to " ^ Typ.Procname.to_string pname in + | Procdesc.Node.Exit_node pname -> + let descr = "return from a call to " ^ Typ.Procname.to_string pname in let node_tags = [Errlog.Procedure_end pname] in trace := Errlog.make_trace_element level curr_loc descr node_tags :: !trace - | _ - -> let descr, node_tags = + | _ -> + let descr, node_tags = match exn_opt with - | None - -> ("", []) - | Some exn_name - -> let exn_str = Typ.Name.name exn_name in + | None -> + ("", []) + | Some exn_name -> + let exn_str = Typ.Name.name exn_name in let desc = if String.is_empty exn_str then "exception" else "exception " ^ exn_str in @@ -509,14 +533,14 @@ end = struct in let descr = match get_description path with - | Some path_descr - -> if String.length descr > 0 then descr ^ " " ^ path_descr else path_descr - | None - -> descr + | Some path_descr -> + if String.length descr > 0 then descr ^ " " ^ path_descr else path_descr + | None -> + descr in trace := Errlog.make_trace_element level curr_loc descr node_tags :: !trace ) - | _, None - -> () + | _, None -> + () in iter_shortest_sequence g pos_opt path ; let compare lt1 lt2 = @@ -525,6 +549,7 @@ end = struct in let relevant lt = lt.Errlog.lt_node_tags <> [] in IList.remove_irrelevant_duplicates compare relevant (List.rev !trace) + end (* =============== END of the Path module ===============*) @@ -612,6 +637,7 @@ end = struct let f prop path = plist := (prop, path) :: !plist in PropMap.iter f ps ; !plist + let to_proplist ps = List.map ~f:fst (elements ps) let to_propset tenv ps = Propset.from_proplist tenv (to_proplist ps) @@ -624,6 +650,7 @@ end = struct List.iter ~f:(fun p -> filtered_map := PropMap.remove p !filtered_map) !elements ; !filtered_map + let partition f ps = let elements = ref [] in PropMap.iter (fun p _ -> elements := p :: !elements) ps ; @@ -633,6 +660,7 @@ end = struct !elements ; (!el1, !el2) + (** It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the prop *) let add_renamed_prop (p: Prop.normal Prop.t) (path: Path.t) (ps: t) : t = let path_new = @@ -643,6 +671,7 @@ end = struct in PropMap.add p path_new ps + let union (ps1: t) (ps2: t) : t = PropMap.fold add_renamed_prop ps1 ps2 (** check if the nodes in path p1 are a subset of those in p2 (not trace subset) *) @@ -654,6 +683,7 @@ end = struct in Procdesc.NodeSet.subset (get_nodes p1) (get_nodes p2) + (** difference between pathsets for the differential fixpoint *) let diff (ps1: t) (ps2: t) : t = let res = ref ps1 in @@ -666,6 +696,7 @@ end = struct in PropMap.iter rem ps2 ; !res + let is_empty = PropMap.is_empty let iter = PropMap.iter @@ -679,6 +710,7 @@ end = struct in iter do_elem ps ; !res + let map f ps = map_option (fun p -> Some (f p)) ps let size ps = @@ -687,6 +719,7 @@ end = struct let () = PropMap.iter add ps in !res + let pp pe fmt ps = let count = ref 0 in let pp_path fmt path = F.fprintf fmt "[path: %a@\n%a]" Path.pp_stats path Path.pp path in @@ -696,6 +729,7 @@ end = struct in iter f ps + let d (ps: t) = L.add_print_action (L.PTpathset, Obj.repr ps) let filter_path path ps = @@ -703,9 +737,11 @@ end = struct let f prop path' = if Path.contains path path' then plist := prop :: !plist in iter f ps ; !plist + (** It's the caller's resposibility to ensure that Prop.prop_rename_primed_footprint_vars was called on the list *) let from_renamed_list (pl: ('a Prop.t * Path.t) list) : t = List.fold ~f:(fun ps (p, pa) -> add_renamed_prop p pa ps) ~init:empty pl + end (* =============== END of the PathSet module ===============*) diff --git a/infer/src/backend/preanal.ml b/infer/src/backend/preanal.ml index 66884deb0..ebeaa443b 100644 --- a/infer/src/backend/preanal.ml +++ b/infer/src/backend/preanal.ml @@ -22,10 +22,10 @@ let add_dispatch_calls pdesc cg tenv = || call_flags.CallFlags.cf_interface in let instr_is_dispatch_call = function - | Sil.Call (_, _, _, _, call_flags) - -> call_flags_is_dispatch call_flags - | _ - -> false + | Sil.Call (_, _, _, _, call_flags) -> + call_flags_is_dispatch call_flags + | _ -> + false in let has_dispatch_call instrs = List.exists ~f:instr_is_dispatch_call instrs in let replace_dispatch_calls = function @@ -36,7 +36,7 @@ let add_dispatch_calls pdesc cg tenv = , loc , call_flags ) as instr when call_flags_is_dispatch call_flags - -> ( + -> ( (* the frontend should not populate the list of targets *) assert (List.is_empty call_flags.CallFlags.cf_targets) ; let receiver_typ_no_ptr = @@ -47,8 +47,8 @@ let add_dispatch_calls pdesc cg tenv = List.sort ~cmp:(fun (_, p1) (_, p2) -> Typ.Procname.compare p1 p2) overrides in match sorted_overrides with - | (_, target_pname) :: _ as all_targets - -> let targets_to_add = + | (_, target_pname) :: _ as all_targets -> + let targets_to_add = if sound_dynamic_dispatch then List.map ~f:snd all_targets else (* if sound dispatch is turned off, consider only the first target. we do this @@ -60,10 +60,10 @@ let add_dispatch_calls pdesc cg tenv = targets_to_add ; let call_flags' = {call_flags with CallFlags.cf_targets= targets_to_add} in Sil.Call (ret_id, call_exp, args, loc, call_flags') - | [] - -> instr ) - | instr - -> instr + | [] -> + instr ) + | instr -> + instr in let instrs = Procdesc.Node.get_instrs node in if has_dispatch_call instrs then List.map ~f:replace_dispatch_calls instrs @@ -72,6 +72,7 @@ let add_dispatch_calls pdesc cg tenv = let pname = Procdesc.get_proc_name pdesc in Procdesc.iter_nodes (node_add_dispatch_calls pname) pdesc + (** add instructions to perform abstraction *) let add_abstraction_instructions pdesc = let open Procdesc in @@ -85,10 +86,10 @@ let add_abstraction_instructions pdesc = in let node_requires_abstraction node = match Node.get_kind node with - | Node.Start_node _ | Node.Join_node - -> false - | Node.Exit_node _ | Node.Stmt_node _ | Node.Prune_node _ | Node.Skip_node _ - -> converging_node node + | Node.Start_node _ | Node.Join_node -> + false + | Node.Exit_node _ | Node.Stmt_node _ | Node.Prune_node _ | Node.Skip_node _ -> + converging_node node in let do_node node = let loc = Node.get_last_loc node in @@ -96,6 +97,7 @@ let add_abstraction_instructions pdesc = in Procdesc.iter_nodes do_node pdesc + module BackwardCfg = ProcCfg.Backward (ProcCfg.Exceptional) module LivenessAnalysis = AbstractInterpreter.Make (BackwardCfg) (Liveness.TransferFunctions) module VarDomain = Liveness.Domain @@ -115,16 +117,17 @@ module NullifyTransferFunctions = struct type extras = LivenessAnalysis.invariant_map - let postprocess (reaching_defs, _ as astate) node {ProcData.extras} = + let postprocess ((reaching_defs, _) as astate) node {ProcData.extras} = let node_id = Procdesc.Node.get_id (CFG.underlying_node node) in match LivenessAnalysis.extract_state node_id extras with (* note: because the analysis is backward, post and pre are reversed *) - | Some {AbstractInterpreter.post= live_before; pre= live_after} - -> let to_nullify = VarDomain.diff (VarDomain.union live_before reaching_defs) live_after in + | Some {AbstractInterpreter.post= live_before; pre= live_after} -> + let to_nullify = VarDomain.diff (VarDomain.union live_before reaching_defs) live_after in let reaching_defs' = VarDomain.diff reaching_defs to_nullify in (reaching_defs', to_nullify) - | None - -> astate + | None -> + astate + let cache_node = ref (Procdesc.Node.dummy None) @@ -142,34 +145,36 @@ module NullifyTransferFunctions = struct cache_instr := last_instr ; last_instr + let is_last_instr_in_node instr node = phys_equal (last_instr_in_node node) instr - let exec_instr (active_defs, to_nullify as astate) extras node instr = + let exec_instr ((active_defs, to_nullify) as astate) extras node instr = let astate' = match instr with - | Sil.Load (lhs_id, _, _, _) - -> (VarDomain.add (Var.of_id lhs_id) active_defs, to_nullify) - | Sil.Call (lhs_id, _, _, _, _) - -> let active_defs' = + | Sil.Load (lhs_id, _, _, _) -> + (VarDomain.add (Var.of_id lhs_id) active_defs, to_nullify) + | Sil.Call (lhs_id, _, _, _, _) -> + let active_defs' = Option.value_map ~f:(fun (id, _) -> VarDomain.add (Var.of_id id) active_defs) ~default:active_defs lhs_id in (active_defs', to_nullify) - | Sil.Store (Exp.Lvar lhs_pvar, _, _, _) - -> (VarDomain.add (Var.of_pvar lhs_pvar) active_defs, to_nullify) - | Sil.Store _ | Prune _ | Declare_locals _ | Remove_temps _ | Abstract _ - -> astate - | Sil.Nullify _ - -> L.(die InternalError) + | Sil.Store (Exp.Lvar lhs_pvar, _, _, _) -> + (VarDomain.add (Var.of_pvar lhs_pvar) active_defs, to_nullify) + | Sil.Store _ | Prune _ | Declare_locals _ | Remove_temps _ | Abstract _ -> + astate + | Sil.Nullify _ -> + L.(die InternalError) "Should not add nullify instructions before running nullify analysis!" in if is_last_instr_in_node instr node then postprocess astate' node extras else astate' + end module NullifyAnalysis = - AbstractInterpreter.MakeNoCFG (Scheduler.ReversePostorder (ProcCfg.Exceptional)) - (NullifyTransferFunctions) + AbstractInterpreter.MakeNoCFG + (Scheduler.ReversePostorder (ProcCfg.Exceptional)) (NullifyTransferFunctions) let add_nullify_instrs pdesc tenv liveness_inv_map = let address_taken_vars = @@ -178,10 +183,10 @@ let add_nullify_instrs pdesc tenv liveness_inv_map = else let initial = AddressTaken.Domain.empty in match AddressTaken.Analyzer.compute_post (ProcData.make_default pdesc tenv) ~initial with - | Some post - -> post - | None - -> AddressTaken.Domain.empty + | Some post -> + post + | None -> + AddressTaken.Domain.empty in let nullify_proc_cfg = ProcCfg.Exceptional.from_pdesc pdesc in let nullify_proc_data = ProcData.make pdesc tenv liveness_inv_map in @@ -206,48 +211,55 @@ let add_nullify_instrs pdesc tenv liveness_inv_map = List.iter ~f:(fun node -> match NullifyAnalysis.extract_post (ProcCfg.Exceptional.id node) nullify_inv_map with - | Some (_, to_nullify) - -> let pvars_to_nullify, ids_to_remove = + | Some (_, to_nullify) -> + let pvars_to_nullify, ids_to_remove = VarDomain.fold (fun var (pvars_acc, ids_acc) -> match Var.to_exp var with (* we nullify all address taken variables at the end of the procedure *) | Exp.Lvar pvar - when not (AddressTaken.Domain.mem pvar address_taken_vars) - -> (pvar :: pvars_acc, ids_acc) - | Exp.Var id - -> (pvars_acc, id :: ids_acc) - | _ - -> (pvars_acc, ids_acc)) + when not (AddressTaken.Domain.mem pvar address_taken_vars) -> + (pvar :: pvars_acc, ids_acc) + | Exp.Var id -> + (pvars_acc, id :: ids_acc) + | _ -> + (pvars_acc, ids_acc)) to_nullify ([], []) in node_add_removetmps_instructions node ids_to_remove ; node_add_nullify_instructions node pvars_to_nullify - | None - -> ()) + | None -> + ()) (ProcCfg.Exceptional.nodes nullify_proc_cfg) ; (* nullify all address taken variables *) if not (AddressTaken.Domain.is_empty address_taken_vars) then let exit_node = ProcCfg.Exceptional.exit_node nullify_proc_cfg in node_add_nullify_instructions exit_node (AddressTaken.Domain.elements address_taken_vars) + let do_liveness pdesc tenv = let liveness_proc_cfg = BackwardCfg.from_pdesc pdesc in let initial = Liveness.Domain.empty in let liveness_inv_map = - LivenessAnalysis.exec_cfg liveness_proc_cfg (ProcData.make_default pdesc tenv) ~initial - ~debug:false + LivenessAnalysis.exec_cfg liveness_proc_cfg + (ProcData.make_default pdesc tenv) + ~initial ~debug:false in - add_nullify_instrs pdesc tenv liveness_inv_map ; Procdesc.signal_did_preanalysis pdesc + add_nullify_instrs pdesc tenv liveness_inv_map ; + Procdesc.signal_did_preanalysis pdesc + let do_abstraction pdesc = - add_abstraction_instructions pdesc ; Procdesc.signal_did_preanalysis pdesc + add_abstraction_instructions pdesc ; + Procdesc.signal_did_preanalysis pdesc + let do_dynamic_dispatch pdesc cg tenv = ( match Config.dynamic_dispatch with - | Interface | Sound - -> let pname = Procdesc.get_proc_name pdesc in + | Interface | Sound -> + let pname = Procdesc.get_proc_name pdesc in if Typ.Procname.is_java pname then add_dispatch_calls pdesc cg tenv - | NoDynamicDispatch | Lazy - -> () ) ; + | NoDynamicDispatch | Lazy -> + () ) ; Procdesc.signal_did_preanalysis pdesc + diff --git a/infer/src/backend/printer.ml b/infer/src/backend/printer.ml index 18f2e4f6a..ddc2f0520 100644 --- a/infer/src/backend/printer.ml +++ b/infer/src/backend/printer.ml @@ -44,6 +44,7 @@ module LineReader = struct In_channel.close cin ; Array.of_list (List.rev !lines) + let file_data (hash: t) fname = try Some (Hashtbl.find hash fname) with Not_found -> @@ -52,14 +53,16 @@ module LineReader = struct Hashtbl.add hash fname lines_arr ; Some lines_arr with exn when SymOp.exn_not_failure exn -> None + let from_file_linenum_original hash fname linenum = match file_data hash fname with - | None - -> None - | Some lines_arr - -> if linenum > 0 && linenum <= Array.length lines_arr then Some lines_arr.(linenum - 1) + | None -> + None + | Some lines_arr -> + if linenum > 0 && linenum <= Array.length lines_arr then Some lines_arr.(linenum - 1) else None + let from_file_linenum hash fname linenum = from_file_linenum_original hash fname linenum let from_loc hash loc = from_file_linenum hash loc.Location.file loc.Location.line @@ -71,10 +74,10 @@ let curr_html_formatter = ref F.std_formatter (** Return true if the node was visited during footprint and during re-execution*) let node_is_visited node = match Specs.get_summary (Procdesc.Node.get_proc_name node) with - | None - -> (false, false) - | Some summary - -> let stats = summary.Specs.stats in + | None -> + (false, false) + | Some summary -> + let stats = summary.Specs.stats in let is_visited_fp = IntSet.mem (Procdesc.Node.get_id node :> int) stats.Specs.nodes_visited_fp in @@ -83,11 +86,13 @@ let node_is_visited node = in (is_visited_fp, is_visited_re) + (** Return true if the node was visited during analysis *) let is_visited node = let visited_fp, visited_re = node_is_visited node in visited_fp || visited_re + (* =============== START of module NodesHtml =============== *) (** Print information into html files for nodes @@ -102,13 +107,16 @@ end = struct let log_files = Hashtbl.create 11 let pp_node_link fmt node = - Io_infer.Html.pp_node_link [".."] (Procdesc.Node.get_proc_name node) ~description:"" + Io_infer.Html.pp_node_link [".."] + (Procdesc.Node.get_proc_name node) + ~description:"" ~preds:(List.map ~f:Procdesc.Node.get_id (Procdesc.Node.get_preds node) :> int list) ~succs:(List.map ~f:Procdesc.Node.get_id (Procdesc.Node.get_succs node) :> int list) ~exn:(List.map ~f:Procdesc.Node.get_id (Procdesc.Node.get_exn node) :> int list) ~isvisited:(is_visited node) ~isproof:false fmt (Procdesc.Node.get_id node :> int) + let start_node nodeid loc proc_name preds succs exns source = let node_fname = Io_infer.Html.node_filename proc_name nodeid in let modified = Io_infer.Html.modified_during_analysis source ["nodes"; node_fname] in @@ -138,11 +146,13 @@ end = struct true ) else false + let finish_node proc_name nodeid source = let node_fname = Io_infer.Html.node_filename proc_name nodeid in let fd = Hashtbl.find log_files (node_fname, source) in Unix.close fd ; curr_html_formatter := F.std_formatter + end (* =============== END of module NodesHtml =============== *) @@ -152,148 +162,149 @@ end let force_delayed_print fmt = let pe_default = if Config.write_html then Pp.html Black else Pp.text in function - | L.PTatom, a - -> let a : Sil.atom = Obj.obj a in + | L.PTatom, a -> + let a : Sil.atom = Obj.obj a in Sil.pp_atom pe_default fmt a - | L.PTattribute, a - -> let a : PredSymb.t = Obj.obj a in + | L.PTattribute, a -> + let a : PredSymb.t = Obj.obj a in F.pp_print_string fmt (PredSymb.to_string pe_default a) - | L.PTdecrease_indent, n - -> let n : int = Obj.obj n in + | L.PTdecrease_indent, n -> + let n : int = Obj.obj n in for _ = 1 to n do F.fprintf fmt "@]" done - | L.PTexp, e - -> let e : Exp.t = Obj.obj e in + | L.PTexp, e -> + let e : Exp.t = Obj.obj e in Sil.pp_exp_printenv pe_default fmt e - | L.PTexp_list, el - -> let el : Exp.t list = Obj.obj el in + | L.PTexp_list, el -> + let el : Exp.t list = Obj.obj el in Sil.pp_exp_list pe_default fmt el - | L.PThpred, hpred - -> let hpred : Sil.hpred = Obj.obj hpred in + | L.PThpred, hpred -> + let hpred : Sil.hpred = Obj.obj hpred in Sil.pp_hpred pe_default fmt hpred - | L.PTincrease_indent, n - -> let n : int = Obj.obj n in + | L.PTincrease_indent, n -> + let n : int = Obj.obj n in let s = ref "" in for _ = 1 to n do s := " " ^ !s done ; F.fprintf fmt "%s@[" !s - | L.PTinstr, i - -> let i : Sil.instr = Obj.obj i in + | L.PTinstr, i -> + let i : Sil.instr = Obj.obj i in if Config.write_html then F.fprintf fmt "%a%a%a" Io_infer.Html.pp_start_color Pp.Green (Sil.pp_instr (Pp.html Green)) i Io_infer.Html.pp_end_color () else Sil.pp_instr Pp.text fmt i - | L.PTinstr_list, il - -> let il : Sil.instr list = Obj.obj il in + | L.PTinstr_list, il -> + let il : Sil.instr list = Obj.obj il in if Config.write_html then F.fprintf fmt "%a%a%a" Io_infer.Html.pp_start_color Pp.Green (Sil.pp_instr_list (Pp.html Green)) il Io_infer.Html.pp_end_color () else Sil.pp_instr_list Pp.text fmt il - | L.PTjprop_list, shallow_jpl - -> let (shallow: bool), (jpl: Prop.normal Specs.Jprop.t list) = Obj.obj shallow_jpl in + | L.PTjprop_list, shallow_jpl -> + let (shallow: bool), (jpl: Prop.normal Specs.Jprop.t list) = Obj.obj shallow_jpl in Specs.Jprop.pp_list pe_default shallow fmt jpl - | L.PTjprop_short, jp - -> let jp : Prop.normal Specs.Jprop.t = Obj.obj jp in + | L.PTjprop_short, jp -> + let jp : Prop.normal Specs.Jprop.t = Obj.obj jp in Specs.Jprop.pp_short pe_default fmt jp - | L.PTloc, loc - -> let loc : Location.t = Obj.obj loc in + | L.PTloc, loc -> + let loc : Location.t = Obj.obj loc in Location.pp fmt loc - | L.PTnode_instrs, b_n - -> let (b: bool), (io: Sil.instr option), (n: Procdesc.Node.t) = Obj.obj b_n in + | L.PTnode_instrs, b_n -> + let (b: bool), (io: Sil.instr option), (n: Procdesc.Node.t) = Obj.obj b_n in if Config.write_html then F.fprintf fmt "%a%a%a" Io_infer.Html.pp_start_color Pp.Green (Procdesc.Node.pp_instrs (Pp.html Green) io ~sub_instrs:b) n Io_infer.Html.pp_end_color () else F.fprintf fmt "%a" (Procdesc.Node.pp_instrs Pp.text io ~sub_instrs:b) n - | L.PToff, off - -> let off : Sil.offset = Obj.obj off in + | L.PToff, off -> + let off : Sil.offset = Obj.obj off in Sil.pp_offset pe_default fmt off - | L.PToff_list, offl - -> let offl : Sil.offset list = Obj.obj offl in + | L.PToff_list, offl -> + let offl : Sil.offset list = Obj.obj offl in Sil.pp_offset_list pe_default fmt offl - | L.PTpathset, ps - -> let ps : Paths.PathSet.t = Obj.obj ps in + | L.PTpathset, ps -> + let ps : Paths.PathSet.t = Obj.obj ps in F.fprintf fmt "%a@\n" (Paths.PathSet.pp pe_default) ps - | L.PTpi, pi - -> let pi : Sil.atom list = Obj.obj pi in + | L.PTpi, pi -> + let pi : Sil.atom list = Obj.obj pi in Prop.pp_pi pe_default fmt pi - | L.PTpath, path - -> let path : Paths.Path.t = Obj.obj path in + | L.PTpath, path -> + let path : Paths.Path.t = Obj.obj path in Paths.Path.pp fmt path - | L.PTprop, p - -> let p : Prop.normal Prop.t = Obj.obj p in + | L.PTprop, p -> + let p : Prop.normal Prop.t = Obj.obj p in Prop.pp_prop pe_default fmt p - | L.PTproplist, x - -> let (p: Prop.normal Prop.t), (pl: Prop.normal Prop.t list) = Obj.obj x in + | L.PTproplist, x -> + let (p: Prop.normal Prop.t), (pl: Prop.normal Prop.t list) = Obj.obj x in Propgraph.pp_proplist pe_default "PROP" (p, false) fmt pl - | L.PTprop_list_with_typ, plist - -> let pl : Prop.normal Prop.t list = Obj.obj plist in + | L.PTprop_list_with_typ, plist -> + let pl : Prop.normal Prop.t list = Obj.obj plist in F.fprintf fmt "%a" (Prop.pp_proplist_with_typ pe_default) pl - | L.PTprop_with_typ, p - -> let p : Prop.normal Prop.t = Obj.obj p in + | L.PTprop_with_typ, p -> + let p : Prop.normal Prop.t = Obj.obj p in Prop.pp_prop_with_typ pe_default fmt p - | L.PTpvar, pvar - -> let pvar : Pvar.t = Obj.obj pvar in + | L.PTpvar, pvar -> + let pvar : Pvar.t = Obj.obj pvar in Pvar.pp pe_default fmt pvar - | L.PTsexp, se - -> let se : Sil.strexp = Obj.obj se in + | L.PTsexp, se -> + let se : Sil.strexp = Obj.obj se in Sil.pp_sexp pe_default fmt se - | L.PTsexp_list, sel - -> let sel : Sil.strexp list = Obj.obj sel in + | L.PTsexp_list, sel -> + let sel : Sil.strexp list = Obj.obj sel in Sil.pp_sexp_list pe_default fmt sel - | L.PTsigma, sigma - -> let sigma : Sil.hpred list = Obj.obj sigma in + | L.PTsigma, sigma -> + let sigma : Sil.hpred list = Obj.obj sigma in Prop.pp_sigma pe_default fmt sigma - | L.PTspec, spec - -> let spec : Prop.normal Specs.spec = Obj.obj spec in + | L.PTspec, spec -> + let spec : Prop.normal Specs.spec = Obj.obj spec in Specs.pp_spec (if Config.write_html then Pp.html Blue else Pp.text) None fmt spec - | L.PTstr, s - -> let s : string = Obj.obj s in + | L.PTstr, s -> + let s : string = Obj.obj s in F.fprintf fmt "%s" s - | L.PTstr_color, s - -> let (s: string), (c: Pp.color) = Obj.obj s in + | L.PTstr_color, s -> + let (s: string), (c: Pp.color) = Obj.obj s in if Config.write_html then F.fprintf fmt "%a%s%a" Io_infer.Html.pp_start_color c s Io_infer.Html.pp_end_color () else F.fprintf fmt "%s" s - | L.PTstrln, s - -> let s : string = Obj.obj s in + | L.PTstrln, s -> + let s : string = Obj.obj s in F.fprintf fmt "%s@\n" s - | L.PTstrln_color, s - -> let (s: string), (c: Pp.color) = Obj.obj s in + | L.PTstrln_color, s -> + let (s: string), (c: Pp.color) = Obj.obj s in if Config.write_html then F.fprintf fmt "%a%s%a@\n" Io_infer.Html.pp_start_color c s Io_infer.Html.pp_end_color () else F.fprintf fmt "%s@\n" s - | L.PTsub, sub - -> let sub : Sil.subst = Obj.obj sub in + | L.PTsub, sub -> + let sub : Sil.subst = Obj.obj sub in Prop.pp_sub pe_default fmt sub - | L.PTtexp_full, te - -> let te : Exp.t = Obj.obj te in + | L.PTtexp_full, te -> + let te : Exp.t = Obj.obj te in Sil.pp_texp_full pe_default fmt te - | L.PTtyp_full, t - -> let t : Typ.t = Obj.obj t in + | L.PTtyp_full, t -> + let t : Typ.t = Obj.obj t in Typ.pp_full pe_default fmt t - | L.PTtyp_list, tl - -> let tl : Typ.t list = Obj.obj tl in + | L.PTtyp_list, tl -> + let tl : Typ.t list = Obj.obj tl in Pp.seq (Typ.pp pe_default) fmt tl - | L.PTerror, s - -> let s : string = Obj.obj s in + | L.PTerror, s -> + let s : string = Obj.obj s in if Config.write_html then F.fprintf fmt "%aERROR: %s%a" Io_infer.Html.pp_start_color Pp.Red s Io_infer.Html.pp_end_color () else F.fprintf fmt "ERROR: %s" s - | L.PTwarning, s - -> let s : string = Obj.obj s in + | L.PTwarning, s -> + let s : string = Obj.obj s in if Config.write_html then F.fprintf fmt "%aWARNING: %s%a" Io_infer.Html.pp_start_color Pp.Orange s Io_infer.Html.pp_end_color () else F.fprintf fmt "WARNING: %s" s - | L.PTinfo, s - -> let s : string = Obj.obj s in + | L.PTinfo, s -> + let s : string = Obj.obj s in if Config.write_html then F.fprintf fmt "%aINFO: %s%a" Io_infer.Html.pp_start_color Pp.Blue s Io_infer.Html.pp_end_color () else F.fprintf fmt "INFO: %s" s + (** Set printer hook as soon as this module is loaded *) let () = L.printer_hook := force_delayed_print @@ -307,6 +318,7 @@ let force_delayed_prints () = L.reset_delayed_prints () ; Config.forcing_delayed_prints := false + (** Start a session, and create a new html fine for the node if it does not exist yet *) let start_session node (loc: Location.t) proc_name session source = let node_id = Procdesc.Node.get_id node in @@ -324,6 +336,7 @@ let start_session node (loc: Location.t) proc_name session source = ((node_id :> int), session, loc.Location.line) ; F.fprintf !curr_html_formatter "%a" Io_infer.Html.pp_start_color Pp.Black + let node_start_session node session = if Config.write_html then let loc = Procdesc.Node.get_loc node in @@ -331,16 +344,19 @@ let node_start_session node session = let pname = Procdesc.Node.get_proc_name node in start_session node loc pname session source + (** Finish a session, and perform delayed print actions if required *) let node_finish_session node = if not Config.only_cheap_debug then force_delayed_prints () else L.reset_delayed_prints () ; if Config.write_html then ( F.fprintf !curr_html_formatter "%a" Io_infer.Html.pp_end_color () ; let source = (Procdesc.Node.get_loc node).file in - NodesHtml.finish_node (Procdesc.Node.get_proc_name node) + NodesHtml.finish_node + (Procdesc.Node.get_proc_name node) (Procdesc.Node.get_id node :> int) source ) + (** Write html file for the procedure. The boolean indicates whether to print whole seconds only *) let write_proc_html pdesc = @@ -368,12 +384,13 @@ let write_proc_html pdesc = (Procdesc.Node.get_id n :> int)) nodes ; match Specs.get_summary pname with - | None - -> () - | Some summary - -> Specs.pp_summary_html source Black fmt summary ; + | None -> + () + | Some summary -> + Specs.pp_summary_html source Black fmt summary ; Io_infer.Html.close (fd, fmt) + (** Creare a hash table mapping line numbers to the set of errors occurring on that line *) let create_table_err_per_line err_log = let err_per_line = Hashtbl.create 17 in @@ -389,10 +406,12 @@ let create_table_err_per_line err_log = in Errlog.iter add_err err_log ; err_per_line + (** Create error message for html file *) let create_err_message err_string = "\n
" ^ err_string ^ "
" + let write_html_proc source proof_cover table_nodes_at_linenum global_err_log proc_desc = let proc_name = Procdesc.get_proc_name proc_desc in let process_node n = @@ -408,22 +427,23 @@ let write_html_proc source proof_cover table_nodes_at_linenum global_err_log pro Procdesc.is_defined proc_desc && SourceFile.equal proc_loc.Location.file source && match Attributes.find_file_capturing_procedure proc_name with - | None - -> true - | Some (source_captured, _) - -> SourceFile.equal source_captured (Procdesc.get_loc proc_desc).file + | None -> + true + | Some (source_captured, _) -> + SourceFile.equal source_captured (Procdesc.get_loc proc_desc).file in if process_proc then ( List.iter ~f:process_node (Procdesc.get_nodes proc_desc) ; match Specs.get_summary proc_name with - | None - -> () - | Some summary - -> List.iter + | None -> + () + | Some summary -> + List.iter ~f:(fun sp -> proof_cover := Specs.Visitedset.union sp.Specs.visited !proof_cover) (Specs.get_specs_from_payload summary) ; Errlog.update global_err_log summary.Specs.attributes.ProcAttributes.err_log ) + (** Create filename.ext.html. *) let write_html_file linereader filename procs = let fname_encoding = DB.source_file_encoding filename in @@ -437,10 +457,10 @@ let write_html_file linereader filename procs = let print_one_line proof_cover table_nodes_at_linenum table_err_per_line line_number = let line_html = match LineReader.from_file_linenum linereader filename line_number with - | Some line_raw - -> Escape.escape_xml line_raw - | None - -> raise End_of_file + | Some line_raw -> + Escape.escape_xml line_raw + | None -> + raise End_of_file in let nodes_at_linenum = try Hashtbl.find table_nodes_at_linenum line_number @@ -473,21 +493,21 @@ let write_html_file linereader filename procs = List.iter ~f:(fun n -> match Procdesc.Node.get_kind n with - | Procdesc.Node.Start_node proc_name - -> let num_specs = + | Procdesc.Node.Start_node proc_name -> + let num_specs = match Specs.get_summary proc_name with - | None - -> 0 - | Some summary - -> List.length (Specs.get_specs_from_payload summary) + | None -> + 0 + | Some summary -> + List.length (Specs.get_specs_from_payload summary) in let label = Escape.escape_xml (Typ.Procname.to_string proc_name) ^ ": " ^ string_of_int num_specs ^ " specs" in Io_infer.Html.pp_proc_link [fname_encoding] proc_name fmt label - | _ - -> ()) + | _ -> + ()) nodes_at_linenum ; List.iter ~f:(fun err_string -> F.fprintf fmt "%s" (create_err_message err_string)) @@ -511,6 +531,7 @@ let write_html_file linereader filename procs = Errlog.pp_html filename [fname_encoding] fmt global_err_log ; Io_infer.Html.close (fd, fmt) + (** Create filename.ext.html for each file in the cluster. *) let write_all_html_files cluster = let exe_env = Exe_env.from_cluster cluster in @@ -518,10 +539,10 @@ let write_all_html_files cluster = let () = List.iter ~f:load_proc_desc (Cg.get_defined_nodes (Exe_env.get_cg exe_env)) in let opt_whitelist_regex = match Config.write_html_whitelist_regex with - | [] - -> None - | _ as reg_list - -> Some (Str.regexp (String.concat ~sep:"\\|" reg_list)) + | [] -> + None + | _ as reg_list -> + Some (Str.regexp (String.concat ~sep:"\\|" reg_list)) in let is_whitelisted file = Option.value_map opt_whitelist_regex ~default:true ~f:(fun regex -> @@ -543,3 +564,4 @@ let write_all_html_files cluster = (fun file -> write_html_file linereader file (Cfg.get_all_procs cfg)) source_files_in_cfg) exe_env + diff --git a/infer/src/backend/prop.ml b/infer/src/backend/prop.ml index a474f0b6e..67f363df2 100644 --- a/infer/src/backend/prop.ml +++ b/infer/src/backend/prop.ml @@ -82,6 +82,7 @@ end = struct in set_ p ?sub ?pi ?sigma ?pi_fp ?sigma_fp () + let unsafe_cast_to_normal (p: exposed t) : normal t = (p :> normal t) end @@ -113,39 +114,43 @@ let pp_footprint _pe f fp = (Pp.semicolon_seq ~print_env:pe (Sil.pp_hpred pe)) fp.sigma_fp + let pp_texp_simple pe = match pe.Pp.opt with SIM_DEFAULT -> Sil.pp_texp pe | SIM_WITH_TYP -> Sil.pp_texp_full pe + (** Pretty print a pointsto representing a stack variable as an equality *) let pp_hpred_stackvar pe0 f (hpred: Sil.hpred) = let pe, changed = Sil.color_pre_wrapper pe0 f hpred in ( match hpred with | Hpointsto (Exp.Lvar pvar, se, te) - -> ( + -> ( let pe' = match se with - | Eexp (Exp.Var _, _) when not (Pvar.is_global pvar) - -> {pe with obj_sub= None} (* dont use obj sub on the var defining it *) - | _ - -> pe + | Eexp (Exp.Var _, _) when not (Pvar.is_global pvar) -> + {pe with obj_sub= None} (* dont use obj sub on the var defining it *) + | _ -> + pe in match pe'.kind with - | TEXT | HTML - -> F.fprintf f "%a = %a:%a" (Pvar.pp_value pe') pvar (Sil.pp_sexp pe') se + | TEXT | HTML -> + F.fprintf f "%a = %a:%a" (Pvar.pp_value pe') pvar (Sil.pp_sexp pe') se (pp_texp_simple pe') te - | LATEX - -> F.fprintf f "%a{=}%a" (Pvar.pp_value pe') pvar (Sil.pp_sexp pe') se ) - | Hpointsto _ | Hlseg _ | Hdllseg _ - -> assert false (* should not happen *) ) ; + | LATEX -> + F.fprintf f "%a{=}%a" (Pvar.pp_value pe') pvar (Sil.pp_sexp pe') se ) + | Hpointsto _ | Hlseg _ | Hdllseg _ -> + assert false (* should not happen *) ) ; Sil.color_post_wrapper changed pe0 f + (** Pretty print a substitution. *) let pp_sub pe f = function - | `Exp sub - -> let pi_sub = List.map ~f:(fun (id, e) -> Sil.Aeq (Var id, e)) (Sil.sub_to_list sub) in + | `Exp sub -> + let pi_sub = List.map ~f:(fun (id, e) -> Sil.Aeq (Var id, e)) (Sil.sub_to_list sub) in Pp.semicolon_seq ~print_env:{pe with break_lines= false} (Sil.pp_atom pe) f pi_sub - | `Typ _ - -> F.fprintf f "Printing typ_subst not implemented." + | `Typ _ -> + F.fprintf f "Printing typ_subst not implemented." + (** Dump a substitution. *) let d_sub (sub: Sil.subst) = L.add_print_action (PTsub, Obj.repr sub) @@ -154,22 +159,25 @@ let pp_sub_entry pe0 f entry = let pe, changed = Sil.color_pre_wrapper pe0 f entry in let x, e = entry in ( match pe.kind with - | TEXT | HTML - -> F.fprintf f "%a = %a" (Ident.pp pe) x (Sil.pp_exp_printenv pe) e - | LATEX - -> F.fprintf f "%a{=}%a" (Ident.pp pe) x (Sil.pp_exp_printenv pe) e ) ; + | TEXT | HTML -> + F.fprintf f "%a = %a" (Ident.pp pe) x (Sil.pp_exp_printenv pe) e + | LATEX -> + F.fprintf f "%a{=}%a" (Ident.pp pe) x (Sil.pp_exp_printenv pe) e ) ; Sil.color_post_wrapper changed pe0 f + (** Pretty print a substitution as a list of (ident,exp) pairs *) let pp_subl pe = if Config.smt_output then Pp.semicolon_seq ~print_env:pe (pp_sub_entry pe) else Pp.semicolon_seq ~print_env:{pe with break_lines= false} (pp_sub_entry pe) + (** Pretty print a pi. *) let pp_pi pe = if Config.smt_output then Pp.semicolon_seq ~print_env:pe (Sil.pp_atom pe) else Pp.semicolon_seq ~print_env:{pe with break_lines= false} (Sil.pp_atom pe) + (** Dump a pi. *) let d_pi (pi: pi) = L.add_print_action (PTpi, Obj.repr pi) @@ -180,13 +188,14 @@ let pp_sigma pe = Pp.semicolon_seq ~print_env:pe (Sil.pp_hpred pe) The boolean indicates whether the stack should only include local variales. *) let sigma_get_stack_nonstack only_local_vars sigma = let hpred_is_stack_var = function - | Sil.Hpointsto (Lvar pvar, _, _) - -> not only_local_vars || Pvar.is_local pvar - | _ - -> false + | Sil.Hpointsto (Lvar pvar, _, _) -> + not only_local_vars || Pvar.is_local pvar + | _ -> + false in List.partition_tf ~f:hpred_is_stack_var sigma + (** Pretty print a sigma in simple mode. *) let pp_sigma_simple pe env fmt sigma = let sigma_stack, sigma_nonstack = sigma_get_stack_nonstack false sigma in @@ -198,10 +207,10 @@ let pp_sigma_simple pe env fmt sigma = let pp_nl fmt doit = if doit then match pe.Pp.kind with - | TEXT | HTML - -> Format.fprintf fmt " ;@\n" - | LATEX - -> Format.fprintf fmt " ; \\\\@\n" + | TEXT | HTML -> + Format.fprintf fmt " ;@\n" + | LATEX -> + Format.fprintf fmt " ; \\\\@\n" in let pp_nonstack fmt = Pp.semicolon_seq ~print_env:pe (Sil.pp_hpred_env pe (Some env)) fmt in if sigma_stack <> [] || sigma_nonstack <> [] then @@ -209,6 +218,7 @@ let pp_sigma_simple pe env fmt sigma = (sigma_stack <> [] && sigma_nonstack <> []) pp_nonstack sigma_nonstack + (** Dump a sigma. *) let d_sigma (sigma: sigma) = L.add_print_action (PTsigma, Obj.repr sigma) @@ -217,6 +227,7 @@ let d_pi_sigma pi sigma = let d_separator () = if pi <> [] && sigma <> [] then L.d_strln " *" in d_pi pi ; d_separator () ; d_sigma sigma + let pi_of_subst sub = List.map ~f:(fun (id1, e2) -> Sil.Aeq (Var id1, e2)) (Sil.sub_to_list sub) (** Return the pure part of [prop]. *) @@ -228,7 +239,8 @@ let get_pure (p: 'a t) : pi = pi_of_subst p.sub @ p.pi let get_pure_extended p = let base = get_pure p in let primed_atoms, _ = - List.fold base ~init:([], Ident.IdentMap.empty) ~f:(fun (atoms, primed_map as acc) base_atom -> + List.fold base ~init:([], Ident.IdentMap.empty) ~f: + (fun ((atoms, primed_map) as acc) base_atom -> let extend_atoms id pid = try let old_id = Ident.IdentMap.find pid primed_map in @@ -237,60 +249,64 @@ let get_pure_extended p = with Not_found -> (atoms, Ident.IdentMap.add pid id primed_map) in match base_atom with - | Sil.Aeq (Exp.Var id0, Exp.Var id1) when Ident.is_primed id0 && not (Ident.is_primed id1) - -> extend_atoms id1 id0 - | Sil.Aeq (Exp.Var id0, Exp.Var id1) when Ident.is_primed id1 && not (Ident.is_primed id0) - -> extend_atoms id0 id1 - | _ - -> acc ) + | Sil.Aeq (Exp.Var id0, Exp.Var id1) when Ident.is_primed id0 && not (Ident.is_primed id1) -> + extend_atoms id1 id0 + | Sil.Aeq (Exp.Var id0, Exp.Var id1) when Ident.is_primed id1 && not (Ident.is_primed id0) -> + extend_atoms id0 id1 + | _ -> + acc ) in primed_atoms @ base + (** Print existential quantification *) let pp_evars pe f evars = if evars <> [] then match pe.Pp.kind with - | TEXT | HTML - -> F.fprintf f "exists [%a]. " (Pp.comma_seq (Ident.pp pe)) evars - | LATEX - -> F.fprintf f "\\exists %a. " (Pp.comma_seq (Ident.pp pe)) evars + | TEXT | HTML -> + F.fprintf f "exists [%a]. " (Pp.comma_seq (Ident.pp pe)) evars + | LATEX -> + F.fprintf f "\\exists %a. " (Pp.comma_seq (Ident.pp pe)) evars + (** Print an hpara in simple mode *) let pp_hpara_simple _pe env n f pred = let pe = Pp.reset_obj_sub _pe in (* no free vars: disable object substitution *) match pe.kind with - | TEXT | HTML - -> F.fprintf f "P%d = %a%a" n (pp_evars pe) pred.Sil.evars + | TEXT | HTML -> + F.fprintf f "P%d = %a%a" n (pp_evars pe) pred.Sil.evars (Pp.semicolon_seq ~print_env:pe (Sil.pp_hpred_env pe (Some env))) pred.Sil.body - | LATEX - -> F.fprintf f "P_{%d} = %a%a\\\\" n (pp_evars pe) pred.Sil.evars + | LATEX -> + F.fprintf f "P_{%d} = %a%a\\\\" n (pp_evars pe) pred.Sil.evars (Pp.semicolon_seq ~print_env:pe (Sil.pp_hpred_env pe (Some env))) pred.Sil.body + (** Print an hpara_dll in simple mode *) let pp_hpara_dll_simple _pe env n f pred = let pe = Pp.reset_obj_sub _pe in (* no free vars: disable object substitution *) match pe.kind with - | TEXT | HTML - -> F.fprintf f "P%d = %a%a" n (pp_evars pe) pred.Sil.evars_dll + | TEXT | HTML -> + F.fprintf f "P%d = %a%a" n (pp_evars pe) pred.Sil.evars_dll (Pp.semicolon_seq ~print_env:pe (Sil.pp_hpred_env pe (Some env))) pred.Sil.body_dll - | LATEX - -> F.fprintf f "P_{%d} = %a%a" n (pp_evars pe) pred.Sil.evars_dll + | LATEX -> + F.fprintf f "P_{%d} = %a%a" n (pp_evars pe) pred.Sil.evars_dll (Pp.semicolon_seq ~print_env:pe (Sil.pp_hpred_env pe (Some env))) pred.Sil.body_dll + (** Create an environment mapping (ident) expressions to the program variables containing them *) let create_pvar_env (sigma: sigma) : Exp.t -> Exp.t = let env = ref [] in let filter = function - | Sil.Hpointsto (Lvar pvar, Eexp (Var v, _), _) - -> if not (Pvar.is_global pvar) then env := (Exp.Var v, Exp.Lvar pvar) :: !env - | _ - -> () + | Sil.Hpointsto (Lvar pvar, Eexp (Var v, _), _) -> + if not (Pvar.is_global pvar) then env := (Exp.Var v, Exp.Lvar pvar) :: !env + | _ -> + () in List.iter ~f:filter sigma ; let find e = @@ -299,10 +315,12 @@ let create_pvar_env (sigma: sigma) : Exp.t -> Exp.t = in find + (** Update the object substitution given the stack variables in the prop *) let prop_update_obj_sub pe prop = if !Config.pp_simple then Pp.set_obj_sub pe (create_pvar_env prop.sigma) else pe + (** Pretty print a footprint in simple mode. *) let pp_footprint_simple _pe env f fp = let pe = {_pe with Pp.cmap_norm= _pe.Pp.cmap_foot} in @@ -311,6 +329,7 @@ let pp_footprint_simple _pe env f fp = F.fprintf f "@\n[footprint@\n @[%a%a@] ]" pp_pure fp.pi_fp (pp_sigma_simple pe env) fp.sigma_fp + (** Create a predicate environment for a prop *) let prop_pred_env prop = let env = Sil.Predicates.empty_env () in @@ -318,6 +337,7 @@ let prop_pred_env prop = List.iter ~f:(Sil.Predicates.process_hpred env) prop.sigma_fp ; env + (** Pretty print a proposition. *) let pp_prop pe0 f prop = let pe = prop_update_obj_sub pe0 prop in @@ -339,8 +359,11 @@ let pp_prop pe0 f prop = let pp_predicates _ () = if Sil.Predicates.is_empty env then () else if latex then ( - F.fprintf f "@\n\\\\\\textsf{where }" ; Sil.Predicates.iter env iter_f iter_f_dll ) - else ( F.fprintf f "@,where" ; Sil.Predicates.iter env iter_f iter_f_dll ) + F.fprintf f "@\n\\\\\\textsf{where }" ; + Sil.Predicates.iter env iter_f iter_f_dll ) + else ( + F.fprintf f "@,where" ; + Sil.Predicates.iter env iter_f iter_f_dll ) in F.fprintf f "%a%a%a%a" pp_pure () (pp_sigma_simple pe env) prop.sigma (pp_footprint_simple pe env) prop pp_predicates () @@ -352,6 +375,7 @@ let pp_prop pe0 f prop = Io_infer.Html.pp_end_color () else (* print in text mode *) do_print f () + let pp_prop_with_typ pe f p = pp_prop {pe with opt= SIM_WITH_TYP} f p (** Dump a proposition. *) @@ -363,15 +387,16 @@ let d_prop_with_typ (prop: 'a t) = L.add_print_action (PTprop_with_typ, Obj.repr (** Print a list of propositions, prepending each one with the given string *) let pp_proplist_with_typ pe f plist = let rec pp_seq_newline f = function - | [] - -> () - | [x] - -> F.fprintf f "@[%a@]" (pp_prop_with_typ pe) x - | x :: l - -> F.fprintf f "@[%a@]@\n(||)@\n%a" (pp_prop_with_typ pe) x pp_seq_newline l + | [] -> + () + | [x] -> + F.fprintf f "@[%a@]" (pp_prop_with_typ pe) x + | x :: l -> + F.fprintf f "@[%a@]@\n(||)@\n%a" (pp_prop_with_typ pe) x pp_seq_newline l in F.fprintf f "@[%a@]" pp_seq_newline plist + (** dump a proplist *) let d_proplist_with_typ (pl: 'a t list) = L.add_print_action (PTprop_list_with_typ, Obj.repr pl) @@ -397,6 +422,7 @@ let prop_fav_add fav prop = pi_fav_add fav prop.pi ; pi_fav_add fav prop.pi_fp + let prop_fav p = Sil.fav_imperative_to_functional prop_fav_add p (** free vars of the prop, excluding the pure part *) @@ -407,10 +433,11 @@ let prop_fav_nonpure = Sil.fav_imperative_to_functional prop_fav_nonpure_add let hpred_fav_in_pvars_add fav (hpred: Sil.hpred) = match hpred with - | Hpointsto (Lvar _, sexp, _) - -> Sil.strexp_fav_add fav sexp - | Hpointsto _ | Hlseg _ | Hdllseg _ - -> () + | Hpointsto (Lvar _, sexp, _) -> + Sil.strexp_fav_add fav sexp + | Hpointsto _ | Hlseg _ | Hdllseg _ -> + () + let sigma_fav_in_pvars_add fav sigma = List.iter ~f:(hpred_fav_in_pvars_add fav) sigma @@ -420,41 +447,48 @@ let pi_sub (subst: Sil.subst) pi = let f = Sil.atom_sub subst in List.map ~f pi + let sigma_sub subst sigma = let f = Sil.hpred_sub subst in List.map ~f sigma + (** Return [true] if the atom is an inequality *) let atom_is_inequality (atom: Sil.atom) = match atom with - | Aeq (BinOp ((Le | Lt), _, _), Const Cint i) when IntLit.isone i - -> true - | _ - -> false + | Aeq (BinOp ((Le | Lt), _, _), Const Cint i) when IntLit.isone i -> + true + | _ -> + false + (** If the atom is [e<=n] return [e,n] *) let atom_exp_le_const (atom: Sil.atom) = match atom with - | Aeq (BinOp (Le, e1, Const Cint n), Const Cint i) when IntLit.isone i - -> Some (e1, n) - | _ - -> None + | Aeq (BinOp (Le, e1, Const Cint n), Const Cint i) when IntLit.isone i -> + Some (e1, n) + | _ -> + None + (** If the atom is [n Some (n, e1) - | _ - -> None + | Aeq (BinOp (Lt, Const Cint n, e1), Const Cint i) when IntLit.isone i -> + Some (n, e1) + | _ -> + None + let exp_reorder e1 e2 = if Exp.compare e1 e2 <= 0 then (e1, e2) else (e2, e1) let rec pp_path f = function - | [] - -> () - | (name, fld) :: path - -> F.fprintf f "%a.%a: " Typ.Name.pp name Typ.Fieldname.pp fld ; pp_path f path + | [] -> + () + | (name, fld) :: path -> + F.fprintf f "%a.%a: " Typ.Name.pp name Typ.Fieldname.pp fld ; + pp_path f path + (** create a strexp of the given type, populating the structures if [struct_init_mode] is [Fld_init] *) let rec create_strexp_of_type ~path tenv struct_init_mode (typ: Typ.t) len inst : Sil.strexp = @@ -470,17 +504,17 @@ let rec create_strexp_of_type ~path tenv struct_init_mode (typ: Typ.t) len inst else create_fresh_var () in match (typ.desc, len) with - | (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _ | TVar _), None - -> Eexp (init_value (), inst) + | (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _ | TVar _), None -> + Eexp (init_value (), inst) | Tstruct name, _ - -> ( + -> ( if List.exists ~f:(fun (n, _) -> Typ.Name.equal n name) path then L.die InternalError "Ill-founded recursion in [create_strexp_of_type]: a sub-element of struct %a is also of type struct %a: %a:%a" Typ.Name.pp name Typ.Name.pp name pp_path (List.rev path) Typ.Name.pp name ; match (struct_init_mode, Tenv.lookup tenv name) with - | Fld_init, Some {fields} - -> (* pass len as an accumulator, so that it is passed to create_strexp_of_type for the last + | Fld_init, Some {fields} -> + (* pass len as an accumulator, so that it is passed to create_strexp_of_type for the last field, but always return None so that only the last field receives len *) let f (fld, t, a) (flds, len) = if Typ.Struct.is_objc_ref_counter_field (fld, t, a) then @@ -494,61 +528,66 @@ let rec create_strexp_of_type ~path tenv struct_init_mode (typ: Typ.t) len inst in let flds, _ = List.fold_right ~f fields ~init:([], len) in Estruct (flds, inst) - | _ - -> Estruct ([], inst) ) - | Tarray (_, len_opt, _), None - -> let len = + | _ -> + Estruct ([], inst) ) + | Tarray (_, len_opt, _), None -> + let len = match len_opt with None -> Exp.get_undefined false | Some len -> Exp.Const (Cint len) in Earray (len, [], inst) - | Tarray _, Some len - -> Earray (len, [], inst) - | (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _ | TVar _), Some _ - -> assert false + | Tarray _, Some len -> + Earray (len, [], inst) + | (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _ | TVar _), Some _ -> + assert false + let create_strexp_of_type tenv struct_init_mode (typ: Typ.t) len inst : Sil.strexp = create_strexp_of_type ~path:[] tenv struct_init_mode (typ : Typ.t) len inst + let replace_array_contents (hpred: Sil.hpred) esel : Sil.hpred = match hpred with - | Hpointsto (root, Sil.Earray (len, [], inst), te) - -> Hpointsto (root, Earray (len, esel, inst), te) - | _ - -> assert false + | Hpointsto (root, Sil.Earray (len, [], inst), te) -> + Hpointsto (root, Earray (len, esel, inst), te) + | _ -> + assert false + (** remove duplicate atoms and redundant inequalities from a sorted pi *) let rec pi_sorted_remove_redundant (pi: pi) = match pi with | (Aeq (BinOp (Le, e1, Const Cint n1), Const Cint i1) as a1) :: (Aeq (BinOp (Le, e2, Const Cint n2), Const Cint i2)) :: rest - when IntLit.isone i1 && IntLit.isone i2 && Exp.equal e1 e2 && IntLit.lt n1 n2 - -> (* second inequality redundant *) + when IntLit.isone i1 && IntLit.isone i2 && Exp.equal e1 e2 && IntLit.lt n1 n2 -> + (* second inequality redundant *) pi_sorted_remove_redundant (a1 :: rest) | (Aeq (BinOp (Lt, Const Cint n1, e1), Const Cint i1)) :: (Aeq (BinOp (Lt, Const Cint n2, e2), Const Cint i2) as a2) :: rest - when IntLit.isone i1 && IntLit.isone i2 && Exp.equal e1 e2 && IntLit.lt n1 n2 - -> (* first inequality redundant *) + when IntLit.isone i1 && IntLit.isone i2 && Exp.equal e1 e2 && IntLit.lt n1 n2 -> + (* first inequality redundant *) pi_sorted_remove_redundant (a2 :: rest) - | a1 :: a2 :: rest - -> if Sil.equal_atom a1 a2 then pi_sorted_remove_redundant (a2 :: rest) + | a1 :: a2 :: rest -> + if Sil.equal_atom a1 a2 then pi_sorted_remove_redundant (a2 :: rest) else a1 :: pi_sorted_remove_redundant (a2 :: rest) - | [a] - -> [a] - | [] - -> [] + | [a] -> + [a] + | [] -> + [] + (** find the unsigned expressions in sigma (immediately inside a pointsto, for now) *) let sigma_get_unsigned_exps sigma = let uexps = ref [] in let do_hpred (hpred: Sil.hpred) = match hpred with - | Hpointsto (_, Eexp (e, _), Sizeof {typ= {desc= Tint ik}}) when Typ.ikind_is_unsigned ik - -> uexps := e :: !uexps - | _ - -> () + | Hpointsto (_, Eexp (e, _), Sizeof {typ= {desc= Tint ik}}) when Typ.ikind_is_unsigned ik -> + uexps := e :: !uexps + | _ -> + () in List.iter ~f:do_hpred sigma ; !uexps + (** Collapse consecutive indices that should be added. For instance, this function reduces x[1][1] to x[2]. The [typ] argument is used to ensure the soundness of this collapsing. *) @@ -561,14 +600,15 @@ let exp_collapse_consecutive_indices_prop (typ: Typ.t) exp = in let rec exp_remove (e0: Exp.t) = match e0 with - | Lindex (Lindex (base, e1), e2) - -> let e0' : Exp.t = Lindex (base, BinOp (PlusA, e1, e2)) in + | Lindex (Lindex (base, e1), e2) -> + let e0' : Exp.t = Lindex (base, BinOp (PlusA, e1, e2)) in exp_remove e0' - | _ - -> e0 + | _ -> + e0 in if typ_is_one_step_from_base then exp_remove exp else exp + (** {2 Compaction} *) (** Return a compact representation of the prop *) @@ -576,6 +616,7 @@ let prop_compact sh (prop: normal t) : normal t = let sigma' = List.map ~f:(Sil.hpred_compact sh) prop.sigma in unsafe_cast_to_normal (set prop ~sigma:sigma') + (** {2 Query about Proposition} *) (** Check if the sigma part of the proposition is emp *) @@ -588,48 +629,52 @@ let prop_hpred_star (p: 'a t) (h: Sil.hpred) : exposed t = let sigma' = h :: p.sigma in set p ~sigma:sigma' + let prop_sigma_star (p: 'a t) (sigma: sigma) : exposed t = let sigma' = sigma @ p.sigma in set p ~sigma:sigma' + (** return the set of subexpressions of [strexp] *) let strexp_get_exps strexp = let rec strexp_get_exps_rec exps (se: Sil.strexp) = match se with - | Eexp (Exn e, _) - -> Exp.Set.add e exps - | Eexp (e, _) - -> Exp.Set.add e exps - | Estruct (flds, _) - -> List.fold ~f:(fun exps (_, strexp) -> strexp_get_exps_rec exps strexp) ~init:exps flds - | Earray (_, elems, _) - -> List.fold ~f:(fun exps (_, strexp) -> strexp_get_exps_rec exps strexp) ~init:exps elems + | Eexp (Exn e, _) -> + Exp.Set.add e exps + | Eexp (e, _) -> + Exp.Set.add e exps + | Estruct (flds, _) -> + List.fold ~f:(fun exps (_, strexp) -> strexp_get_exps_rec exps strexp) ~init:exps flds + | Earray (_, elems, _) -> + List.fold ~f:(fun exps (_, strexp) -> strexp_get_exps_rec exps strexp) ~init:exps elems in strexp_get_exps_rec Exp.Set.empty strexp + (** get the set of expressions on the righthand side of [hpred] *) let hpred_get_targets (hpred: Sil.hpred) = match hpred with - | Hpointsto (_, rhs, _) - -> strexp_get_exps rhs - | Hlseg (_, _, _, e, el) - -> List.fold ~f:(fun exps e -> Exp.Set.add e exps) ~init:Exp.Set.empty (e :: el) - | Hdllseg (_, _, _, oB, oF, iB, el) - -> (* only one direction supported for now *) + | Hpointsto (_, rhs, _) -> + strexp_get_exps rhs + | Hlseg (_, _, _, e, el) -> + List.fold ~f:(fun exps e -> Exp.Set.add e exps) ~init:Exp.Set.empty (e :: el) + | Hdllseg (_, _, _, oB, oF, iB, el) -> + (* only one direction supported for now *) List.fold ~f:(fun exps e -> Exp.Set.add e exps) ~init:Exp.Set.empty (oB :: oF :: iB :: el) + (** return the set of hpred's and exp's in [sigma] that are reachable from an expression in [exps] *) let compute_reachable_hpreds sigma exps = let rec compute_reachable_hpreds_rec sigma (reach, exps) = let add_hpred_if_reachable (reach, exps) (hpred: Sil.hpred) = match hpred with - | Hpointsto (lhs, _, _) as hpred when Exp.Set.mem lhs exps - -> let reach' = Sil.HpredSet.add hpred reach in + | Hpointsto (lhs, _, _) as hpred when Exp.Set.mem lhs exps -> + let reach' = Sil.HpredSet.add hpred reach in let reach_exps = hpred_get_targets hpred in (reach', Exp.Set.union exps reach_exps) - | _ - -> (reach, exps) + | _ -> + (reach, exps) in let reach', exps' = List.fold ~f:add_hpred_if_reachable ~init:(reach, exps) sigma in if Int.equal (Sil.HpredSet.cardinal reach) (Sil.HpredSet.cardinal reach') then (reach, exps) @@ -637,6 +682,7 @@ let compute_reachable_hpreds sigma exps = in compute_reachable_hpreds_rec sigma (Sil.HpredSet.empty, exps) + (* Module for normalization *) module Normalize = struct (** Eliminates all empty lsegs from sigma, and collect equalities @@ -650,58 +696,60 @@ module Normalize = struct let alloc_set = let rec f_alloc set (sigma1: sigma) = match sigma1 with - | [] - -> set - | (Hpointsto (e, _, _)) :: sigma' | (Hlseg (Sil.Lseg_NE, _, e, _, _)) :: sigma' - -> f_alloc (Exp.Set.add e set) sigma' - | (Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _)) :: sigma' - -> f_alloc (Exp.Set.add iF (Exp.Set.add iB set)) sigma' - | _ :: sigma' - -> f_alloc set sigma' + | [] -> + set + | (Hpointsto (e, _, _)) :: sigma' | (Hlseg (Sil.Lseg_NE, _, e, _, _)) :: sigma' -> + f_alloc (Exp.Set.add e set) sigma' + | (Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _)) :: sigma' -> + f_alloc (Exp.Set.add iF (Exp.Set.add iB set)) sigma' + | _ :: sigma' -> + f_alloc set sigma' in f_alloc Exp.Set.empty sigma in let rec f eqs_zero sigma_passed (sigma1: sigma) = match sigma1 with - | [] - -> (List.rev eqs_zero, List.rev sigma_passed) - | (Hpointsto _ as hpred) :: sigma' - -> f eqs_zero (hpred :: sigma_passed) sigma' + | [] -> + (List.rev eqs_zero, List.rev sigma_passed) + | (Hpointsto _ as hpred) :: sigma' -> + f eqs_zero (hpred :: sigma_passed) sigma' | (Hlseg (Lseg_PE, _, e1, e2, _)) :: sigma' - when Exp.equal e1 Exp.zero || Exp.Set.mem e1 alloc_set - -> f (Sil.Aeq (e1, e2) :: eqs_zero) sigma_passed sigma' - | (Hlseg _ as hpred) :: sigma' - -> f eqs_zero (hpred :: sigma_passed) sigma' + when Exp.equal e1 Exp.zero || Exp.Set.mem e1 alloc_set -> + f (Sil.Aeq (e1, e2) :: eqs_zero) sigma_passed sigma' + | (Hlseg _ as hpred) :: sigma' -> + f eqs_zero (hpred :: sigma_passed) sigma' | (Hdllseg (Lseg_PE, _, iF, oB, oF, iB, _)) :: sigma' when Exp.equal iF Exp.zero || Exp.Set.mem iF alloc_set || Exp.equal iB Exp.zero - || Exp.Set.mem iB alloc_set - -> f (Sil.Aeq (iF, oF) :: Sil.Aeq (iB, oB) :: eqs_zero) sigma_passed sigma' - | (Hdllseg _ as hpred) :: sigma' - -> f eqs_zero (hpred :: sigma_passed) sigma' + || Exp.Set.mem iB alloc_set -> + f (Sil.Aeq (iF, oF) :: Sil.Aeq (iB, oB) :: eqs_zero) sigma_passed sigma' + | (Hdllseg _ as hpred) :: sigma' -> + f eqs_zero (hpred :: sigma_passed) sigma' in f [] [] sigma + let sigma_intro_nonemptylseg e1 e2 sigma = let rec f sigma_passed (sigma1: sigma) = match sigma1 with - | [] - -> List.rev sigma_passed - | (Hpointsto _ as hpred) :: sigma' - -> f (hpred :: sigma_passed) sigma' + | [] -> + List.rev sigma_passed + | (Hpointsto _ as hpred) :: sigma' -> + f (hpred :: sigma_passed) sigma' | (Hlseg (Lseg_PE, para, f1, f2, shared)) :: sigma' - when Exp.equal e1 f1 && Exp.equal e2 f2 || Exp.equal e2 f1 && Exp.equal e1 f2 - -> f (Sil.Hlseg (Lseg_NE, para, f1, f2, shared) :: sigma_passed) sigma' - | (Hlseg _ as hpred) :: sigma' - -> f (hpred :: sigma_passed) sigma' + when Exp.equal e1 f1 && Exp.equal e2 f2 || Exp.equal e2 f1 && Exp.equal e1 f2 -> + f (Sil.Hlseg (Lseg_NE, para, f1, f2, shared) :: sigma_passed) sigma' + | (Hlseg _ as hpred) :: sigma' -> + f (hpred :: sigma_passed) sigma' | (Hdllseg (Lseg_PE, para, iF, oB, oF, iB, shared)) :: sigma' when Exp.equal e1 iF && Exp.equal e2 oF || Exp.equal e2 iF && Exp.equal e1 oF - || Exp.equal e1 iB && Exp.equal e2 oB || Exp.equal e2 iB && Exp.equal e1 oB - -> f (Sil.Hdllseg (Lseg_NE, para, iF, oB, oF, iB, shared) :: sigma_passed) sigma' - | (Hdllseg _ as hpred) :: sigma' - -> f (hpred :: sigma_passed) sigma' + || Exp.equal e1 iB && Exp.equal e2 oB || Exp.equal e2 iB && Exp.equal e1 oB -> + f (Sil.Hdllseg (Lseg_NE, para, iF, oB, oF, iB, shared) :: sigma_passed) sigma' + | (Hdllseg _ as hpred) :: sigma' -> + f (hpred :: sigma_passed) sigma' in f [] sigma + let ( -- ) = IntLit.sub let ( ++ ) = IntLit.add @@ -711,171 +759,171 @@ module Normalize = struct let rec eval (e: Exp.t) : Exp.t = (* L.d_str " ["; Sil.d_exp e; L.d_str"] "; *) match e with - | Var _ - -> e - | Closure c - -> let captured_vars = + | Var _ -> + e + | Closure c -> + let captured_vars = List.map ~f:(fun (exp, pvar, typ) -> (eval exp, pvar, typ)) c.captured_vars in Closure {c with captured_vars} - | Const _ - -> e - | Sizeof {nbytes= Some n} when destructive - -> Exp.Const (Const.Cint (IntLit.of_int n)) + | Const _ -> + e + | Sizeof {nbytes= Some n} when destructive -> + Exp.Const (Const.Cint (IntLit.of_int n)) | Sizeof {typ= {desc= Tarray ({desc= Tint ik}, _, _)}; dynamic_length= Some l} - when Typ.ikind_is_char ik && Config.curr_language_is Config.Clang - -> eval l + when Typ.ikind_is_char ik && Config.curr_language_is Config.Clang -> + eval l | Sizeof {typ= {desc= Tarray ({desc= Tint ik}, Some l, _)}} - when Typ.ikind_is_char ik && Config.curr_language_is Config.Clang - -> Const (Cint l) - | Sizeof _ - -> e - | Cast (_, e1) - -> eval e1 + when Typ.ikind_is_char ik && Config.curr_language_is Config.Clang -> + Const (Cint l) + | Sizeof _ -> + e + | Cast (_, e1) -> + eval e1 | UnOp (Unop.LNot, e1, topt) -> ( match eval e1 with - | Const Cint i when IntLit.iszero i - -> Exp.one - | Const Cint _ - -> Exp.zero - | UnOp (LNot, e1', _) - -> e1' - | e1' - -> if abs then Exp.get_undefined false else UnOp (LNot, e1', topt) ) + | Const Cint i when IntLit.iszero i -> + Exp.one + | Const Cint _ -> + Exp.zero + | UnOp (LNot, e1', _) -> + e1' + | e1' -> + if abs then Exp.get_undefined false else UnOp (LNot, e1', topt) ) | UnOp (Neg, e1, topt) -> ( match eval e1 with - | UnOp (Neg, e2', _) - -> e2' - | Const Cint i - -> Exp.int (IntLit.neg i) - | Const Cfloat v - -> Exp.float ~-.v - | Var id - -> UnOp (Neg, Var id, topt) - | e1' - -> if abs then Exp.get_undefined false else UnOp (Neg, e1', topt) ) + | UnOp (Neg, e2', _) -> + e2' + | Const Cint i -> + Exp.int (IntLit.neg i) + | Const Cfloat v -> + Exp.float ~-.v + | Var id -> + UnOp (Neg, Var id, topt) + | e1' -> + if abs then Exp.get_undefined false else UnOp (Neg, e1', topt) ) | UnOp (BNot, e1, topt) -> ( match eval e1 with - | UnOp (BNot, e2', _) - -> e2' - | Const Cint i - -> Exp.int (IntLit.lognot i) - | e1' - -> if abs then Exp.get_undefined false else UnOp (BNot, e1', topt) ) + | UnOp (BNot, e2', _) -> + e2' + | Const Cint i -> + Exp.int (IntLit.lognot i) + | e1' -> + if abs then Exp.get_undefined false else UnOp (BNot, e1', topt) ) | BinOp (Le, e1, e2) -> ( match (eval e1, eval e2) with - | Const Cint n, Const Cint m - -> Exp.bool (IntLit.leq n m) - | Const Cfloat v, Const Cfloat w - -> Exp.bool (v <= w) - | BinOp (PlusA, e3, Const Cint n), Const Cint m - -> BinOp (Le, e3, Exp.int (m -- n)) - | e1', e2' - -> Exp.le e1' e2' ) + | Const Cint n, Const Cint m -> + Exp.bool (IntLit.leq n m) + | Const Cfloat v, Const Cfloat w -> + Exp.bool (v <= w) + | BinOp (PlusA, e3, Const Cint n), Const Cint m -> + BinOp (Le, e3, Exp.int (m -- n)) + | e1', e2' -> + Exp.le e1' e2' ) | BinOp (Lt, e1, e2) -> ( match (eval e1, eval e2) with - | Const Cint n, Const Cint m - -> Exp.bool (IntLit.lt n m) - | Const Cfloat v, Const Cfloat w - -> Exp.bool (v < w) - | Const Cint n, BinOp (MinusA, f1, f2) - -> BinOp (Le, BinOp (MinusA, f2, f1), Exp.int (IntLit.minus_one -- n)) - | BinOp (MinusA, f1, f2), Const Cint n - -> Exp.le (BinOp (MinusA, f1, f2)) (Exp.int (n -- IntLit.one)) - | BinOp (PlusA, e3, Const Cint n), Const Cint m - -> BinOp (Lt, e3, Exp.int (m -- n)) - | e1', e2' - -> Exp.lt e1' e2' ) - | BinOp (Ge, e1, e2) - -> eval (Exp.le e2 e1) - | BinOp (Gt, e1, e2) - -> eval (Exp.lt e2 e1) + | Const Cint n, Const Cint m -> + Exp.bool (IntLit.lt n m) + | Const Cfloat v, Const Cfloat w -> + Exp.bool (v < w) + | Const Cint n, BinOp (MinusA, f1, f2) -> + BinOp (Le, BinOp (MinusA, f2, f1), Exp.int (IntLit.minus_one -- n)) + | BinOp (MinusA, f1, f2), Const Cint n -> + Exp.le (BinOp (MinusA, f1, f2)) (Exp.int (n -- IntLit.one)) + | BinOp (PlusA, e3, Const Cint n), Const Cint m -> + BinOp (Lt, e3, Exp.int (m -- n)) + | e1', e2' -> + Exp.lt e1' e2' ) + | BinOp (Ge, e1, e2) -> + eval (Exp.le e2 e1) + | BinOp (Gt, e1, e2) -> + eval (Exp.lt e2 e1) | BinOp (Eq, e1, e2) -> ( match (eval e1, eval e2) with - | Const Cint n, Const Cint m - -> Exp.bool (IntLit.eq n m) - | Const Cfloat v, Const Cfloat w - -> Exp.bool (Float.equal v w) - | Const Cint _, Exp.Lvar _ | Exp.Lvar _, Const Cint _ - -> (* Comparing pointer with nonzero integer is undefined behavior in ISO C++ *) + | Const Cint n, Const Cint m -> + Exp.bool (IntLit.eq n m) + | Const Cfloat v, Const Cfloat w -> + Exp.bool (Float.equal v w) + | Const Cint _, Exp.Lvar _ | Exp.Lvar _, Const Cint _ -> + (* Comparing pointer with nonzero integer is undefined behavior in ISO C++ *) (* Assume they are not equal *) Exp.zero - | e1', e2' - -> Exp.eq e1' e2' ) + | e1', e2' -> + Exp.eq e1' e2' ) | BinOp (Ne, e1, e2) -> ( match (eval e1, eval e2) with - | Const Cint n, Const Cint m - -> Exp.bool (IntLit.neq n m) - | Const Cfloat v, Const Cfloat w - -> Exp.bool (v <> w) - | Const Cint _, Exp.Lvar _ | Exp.Lvar _, Const Cint _ - -> (* Comparing pointer with nonzero integer is undefined behavior in ISO C++ *) + | Const Cint n, Const Cint m -> + Exp.bool (IntLit.neq n m) + | Const Cfloat v, Const Cfloat w -> + Exp.bool (v <> w) + | Const Cint _, Exp.Lvar _ | Exp.Lvar _, Const Cint _ -> + (* Comparing pointer with nonzero integer is undefined behavior in ISO C++ *) (* Assume they are not equal *) Exp.one - | e1', e2' - -> Exp.ne e1' e2' ) + | e1', e2' -> + Exp.ne e1' e2' ) | BinOp (LAnd, e1, e2) - -> ( + -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with - | Const Cint i, _ when IntLit.iszero i - -> e1' - | Const Cint _, _ - -> e2' - | _, Const Cint i when IntLit.iszero i - -> e2' - | _, Const Cint _ - -> e1' - | _ - -> BinOp (LAnd, e1', e2') ) + | Const Cint i, _ when IntLit.iszero i -> + e1' + | Const Cint _, _ -> + e2' + | _, Const Cint i when IntLit.iszero i -> + e2' + | _, Const Cint _ -> + e1' + | _ -> + BinOp (LAnd, e1', e2') ) | BinOp (LOr, e1, e2) - -> ( + -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with - | Const Cint i, _ when IntLit.iszero i - -> e2' - | Const Cint _, _ - -> e1' - | _, Const Cint i when IntLit.iszero i - -> e1' - | _, Const Cint _ - -> e2' - | _ - -> BinOp (LOr, e1', e2') ) - | BinOp (PlusPI, Lindex (ep, e1), e2) - -> (* array access with pointer arithmetic *) + | Const Cint i, _ when IntLit.iszero i -> + e2' + | Const Cint _, _ -> + e1' + | _, Const Cint i when IntLit.iszero i -> + e1' + | _, Const Cint _ -> + e2' + | _ -> + BinOp (LOr, e1', e2') ) + | BinOp (PlusPI, Lindex (ep, e1), e2) -> + (* array access with pointer arithmetic *) let e' : Exp.t = BinOp (PlusA, e1, e2) in eval (Exp.Lindex (ep, e')) - | BinOp (PlusPI, BinOp (PlusPI, e11, e12), e2) - -> (* take care of pattern ((ptr + off1) + off2) *) + | BinOp (PlusPI, BinOp (PlusPI, e11, e12), e2) -> + (* take care of pattern ((ptr + off1) + off2) *) (* progress: convert inner +I to +A *) let e2' : Exp.t = BinOp (PlusA, e12, e2) in eval (Exp.BinOp (PlusPI, e11, e2')) | BinOp ((PlusA as oplus), e1, e2) | BinOp ((PlusPI as oplus), e1, e2) - -> ( + -> ( let e1' = eval e1 in let e2' = eval e2 in let isPlusA = Binop.equal oplus Binop.PlusA in let ominus = if isPlusA then Binop.MinusA else Binop.MinusPI in let ( +++ ) (x: Exp.t) (y: Exp.t) : Exp.t = match (x, y) with - | _, Const Cint i when IntLit.iszero i - -> x - | Const Cint i, Const Cint j - -> Const (Cint (IntLit.add i j)) - | _ - -> BinOp (oplus, x, y) + | _, Const Cint i when IntLit.iszero i -> + x + | Const Cint i, Const Cint j -> + Const (Cint (IntLit.add i j)) + | _ -> + BinOp (oplus, x, y) in let ( --- ) (x: Exp.t) (y: Exp.t) : Exp.t = match (x, y) with - | _, Const Cint i when IntLit.iszero i - -> x - | Const Cint i, Const Cint j - -> Const (Cint (IntLit.sub i j)) - | _ - -> BinOp (ominus, x, y) + | _, Const Cint i when IntLit.iszero i -> + x + | Const Cint i, Const Cint j -> + Const (Cint (IntLit.sub i j)) + | _ -> + BinOp (ominus, x, y) in (* test if the extensible array at the end of [typ] has elements of type [elt] *) let extensible_array_element_typ_equal elt typ = @@ -887,43 +935,43 @@ module Normalize = struct sizeof(struct s {... t[l]}) + k * sizeof(t)) = sizeof(struct s {... t[l + k]}) *) | ( Sizeof ({typ; dynamic_length= len1_opt} as sizeof_data) , BinOp (Mult, len2, Sizeof {typ= elt; dynamic_length= None}) ) - when isPlusA && extensible_array_element_typ_equal elt typ - -> let len = match len1_opt with Some len1 -> len1 +++ len2 | None -> len2 in + when isPlusA && extensible_array_element_typ_equal elt typ -> + let len = match len1_opt with Some len1 -> len1 +++ len2 | None -> len2 in Sizeof {sizeof_data with dynamic_length= Some len} - | Const c, _ when Const.iszero_int_float c - -> e2' - | _, Const c when Const.iszero_int_float c - -> e1' - | Const Cint n, Const Cint m - -> Exp.int (n ++ m) - | Const Cfloat v, Const Cfloat w - -> Exp.float (v +. w) - | UnOp (Neg, f1, _), f2 | f2, UnOp (Neg, f1, _) - -> BinOp (ominus, f2, f1) + | Const c, _ when Const.iszero_int_float c -> + e2' + | _, Const c when Const.iszero_int_float c -> + e1' + | Const Cint n, Const Cint m -> + Exp.int (n ++ m) + | Const Cfloat v, Const Cfloat w -> + Exp.float (v +. w) + | UnOp (Neg, f1, _), f2 | f2, UnOp (Neg, f1, _) -> + BinOp (ominus, f2, f1) | BinOp (PlusA, e, Const Cint n1), Const Cint n2 | BinOp (PlusPI, e, Const Cint n1), Const Cint n2 | Const Cint n2, BinOp (PlusA, e, Const Cint n1) - | Const Cint n2, BinOp (PlusPI, e, Const Cint n1) - -> e +++ Exp.int (n1 ++ n2) + | Const Cint n2, BinOp (PlusPI, e, Const Cint n1) -> + e +++ Exp.int (n1 ++ n2) | BinOp (MinusA, Const Cint n1, e), Const Cint n2 - | Const Cint n2, BinOp (MinusA, Const Cint n1, e) - -> Exp.int (n1 ++ n2) --- e - | BinOp (MinusA, e1, e2), e3 - -> (* (e1-e2)+e3 --> e1 + (e3-e2) *) + | Const Cint n2, BinOp (MinusA, Const Cint n1, e) -> + Exp.int (n1 ++ n2) --- e + | BinOp (MinusA, e1, e2), e3 -> + (* (e1-e2)+e3 --> e1 + (e3-e2) *) (* progress: brings + to the outside *) eval (e1 +++ (e3 --- e2)) - | _, Const _ - -> e1' +++ e2' - | Const _, _ - -> if isPlusA then e2' +++ e1' else e1' +++ e2' - | Var _, Var _ - -> e1' +++ e2' - | _ - -> if abs && isPlusA then Exp.get_undefined false + | _, Const _ -> + e1' +++ e2' + | Const _, _ -> + if isPlusA then e2' +++ e1' else e1' +++ e2' + | Var _, Var _ -> + e1' +++ e2' + | _ -> + if abs && isPlusA then Exp.get_undefined false else if abs && not isPlusA then e1' +++ Exp.get_undefined false else e1' +++ e2' ) | BinOp ((MinusA as ominus), e1, e2) | BinOp ((MinusPI as ominus), e1, e2) - -> ( + -> ( let e1' = eval e1 in let e2' = eval e2 in let isMinusA = Binop.equal ominus Binop.MinusA in @@ -933,181 +981,181 @@ module Normalize = struct if Exp.equal e1' e2' then Exp.zero else match (e1', e2') with - | Const c, _ when Const.iszero_int_float c - -> eval (Exp.UnOp (Neg, e2', None)) - | _, Const c when Const.iszero_int_float c - -> e1' - | Const Cint n, Const Cint m - -> Exp.int (n -- m) - | Const Cfloat v, Const Cfloat w - -> Exp.float (v -. w) - | _, UnOp (Neg, f2, _) - -> eval (e1 +++ f2) - | _, Const Cint n - -> eval (e1' +++ Exp.int (IntLit.neg n)) - | Const _, _ - -> e1' --- e2' - | Var _, Var _ - -> e1' --- e2' - | _, _ - -> if abs then Exp.get_undefined false else e1' --- e2' ) - | BinOp (MinusPP, e1, e2) - -> if abs then Exp.get_undefined false else BinOp (MinusPP, eval e1, eval e2) + | Const c, _ when Const.iszero_int_float c -> + eval (Exp.UnOp (Neg, e2', None)) + | _, Const c when Const.iszero_int_float c -> + e1' + | Const Cint n, Const Cint m -> + Exp.int (n -- m) + | Const Cfloat v, Const Cfloat w -> + Exp.float (v -. w) + | _, UnOp (Neg, f2, _) -> + eval (e1 +++ f2) + | _, Const Cint n -> + eval (e1' +++ Exp.int (IntLit.neg n)) + | Const _, _ -> + e1' --- e2' + | Var _, Var _ -> + e1' --- e2' + | _, _ -> + if abs then Exp.get_undefined false else e1' --- e2' ) + | BinOp (MinusPP, e1, e2) -> + if abs then Exp.get_undefined false else BinOp (MinusPP, eval e1, eval e2) | BinOp (Mult, e1, e2) - -> ( + -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with - | Const c, _ when Const.iszero_int_float c - -> Exp.zero - | Const c, _ when Const.isone_int_float c - -> e2' - | Const c, _ when Const.isminusone_int_float c - -> eval (Exp.UnOp (Neg, e2', None)) - | _, Const c when Const.iszero_int_float c - -> Exp.zero - | _, Const c when Const.isone_int_float c - -> e1' - | _, Const c when Const.isminusone_int_float c - -> eval (Exp.UnOp (Neg, e1', None)) - | Const Cint n, Const Cint m - -> Exp.int (IntLit.mul n m) - | Const Cfloat v, Const Cfloat w - -> Exp.float (v *. w) - | Var _, Var _ - -> BinOp (Mult, e1', e2') - | _, Sizeof _ | Sizeof _, _ - -> BinOp (Mult, e1', e2') - | _, _ - -> if abs then Exp.get_undefined false else BinOp (Mult, e1', e2') ) + | Const c, _ when Const.iszero_int_float c -> + Exp.zero + | Const c, _ when Const.isone_int_float c -> + e2' + | Const c, _ when Const.isminusone_int_float c -> + eval (Exp.UnOp (Neg, e2', None)) + | _, Const c when Const.iszero_int_float c -> + Exp.zero + | _, Const c when Const.isone_int_float c -> + e1' + | _, Const c when Const.isminusone_int_float c -> + eval (Exp.UnOp (Neg, e1', None)) + | Const Cint n, Const Cint m -> + Exp.int (IntLit.mul n m) + | Const Cfloat v, Const Cfloat w -> + Exp.float (v *. w) + | Var _, Var _ -> + BinOp (Mult, e1', e2') + | _, Sizeof _ | Sizeof _, _ -> + BinOp (Mult, e1', e2') + | _, _ -> + if abs then Exp.get_undefined false else BinOp (Mult, e1', e2') ) | BinOp (Div, e1, e2) - -> ( + -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with - | _, Const c when Const.iszero_int_float c - -> Exp.get_undefined false - | Const c, _ when Const.iszero_int_float c - -> e1' - | _, Const c when Const.isone_int_float c - -> e1' - | Const Cint n, Const Cint m - -> Exp.int (IntLit.div n m) - | Const Cfloat v, Const Cfloat w - -> Exp.float (v /. w) + | _, Const c when Const.iszero_int_float c -> + Exp.get_undefined false + | Const c, _ when Const.iszero_int_float c -> + e1' + | _, Const c when Const.isone_int_float c -> + e1' + | Const Cint n, Const Cint m -> + Exp.int (IntLit.div n m) + | Const Cfloat v, Const Cfloat w -> + Exp.float (v /. w) | ( Sizeof {typ= {desc= Tarray (elt, _, _)}; dynamic_length= Some len} , Sizeof {typ= elt2; dynamic_length= None} ) (* pattern: sizeof(elt[len]) / sizeof(elt) = len *) - when Typ.equal elt elt2 - -> len + when Typ.equal elt elt2 -> + len | ( Sizeof {typ= {desc= Tarray (elt, Some len, _)}; dynamic_length= None} , Sizeof {typ= elt2; dynamic_length= None} ) (* pattern: sizeof(elt[len]) / sizeof(elt) = len *) - when Typ.equal elt elt2 - -> Const (Cint len) - | _ - -> if abs then Exp.get_undefined false else BinOp (Div, e1', e2') ) + when Typ.equal elt elt2 -> + Const (Cint len) + | _ -> + if abs then Exp.get_undefined false else BinOp (Div, e1', e2') ) | BinOp (Mod, e1, e2) - -> ( + -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with - | _, Const Cint i when IntLit.iszero i - -> Exp.get_undefined false - | Const Cint i, _ when IntLit.iszero i - -> e1' - | _, Const Cint i when IntLit.isone i - -> Exp.zero - | Const Cint n, Const Cint m - -> Exp.int (IntLit.rem n m) - | _ - -> if abs then Exp.get_undefined false else BinOp (Mod, e1', e2') ) + | _, Const Cint i when IntLit.iszero i -> + Exp.get_undefined false + | Const Cint i, _ when IntLit.iszero i -> + e1' + | _, Const Cint i when IntLit.isone i -> + Exp.zero + | Const Cint n, Const Cint m -> + Exp.int (IntLit.rem n m) + | _ -> + if abs then Exp.get_undefined false else BinOp (Mod, e1', e2') ) | BinOp (Shiftlt, e1, e2) - -> ( + -> ( if abs then Exp.get_undefined false else match (e1, e2) with | Const Cint n, Const Cint m -> ( try Exp.int (IntLit.shift_left n m) with IntLit.OversizedShift -> BinOp (Shiftlt, eval e1, eval e2) ) - | _, Const Cint m when IntLit.iszero m - -> eval e1 - | _, Const Cint m when IntLit.isone m - -> eval (Exp.BinOp (PlusA, e1, e1)) - | Const Cint m, _ when IntLit.iszero m - -> e1 - | _ - -> BinOp (Shiftlt, eval e1, eval e2) ) + | _, Const Cint m when IntLit.iszero m -> + eval e1 + | _, Const Cint m when IntLit.isone m -> + eval (Exp.BinOp (PlusA, e1, e1)) + | Const Cint m, _ when IntLit.iszero m -> + e1 + | _ -> + BinOp (Shiftlt, eval e1, eval e2) ) | BinOp (Shiftrt, e1, e2) - -> ( + -> ( if abs then Exp.get_undefined false else match (e1, e2) with | Const Cint n, Const Cint m -> ( try Exp.int (IntLit.shift_right n m) with IntLit.OversizedShift -> BinOp (Shiftrt, eval e1, eval e2) ) - | _, Const Cint m when IntLit.iszero m - -> eval e1 - | Const Cint m, _ when IntLit.iszero m - -> e1 - | _ - -> BinOp (Shiftrt, eval e1, eval e2) ) + | _, Const Cint m when IntLit.iszero m -> + eval e1 + | Const Cint m, _ when IntLit.iszero m -> + e1 + | _ -> + BinOp (Shiftrt, eval e1, eval e2) ) | BinOp (BAnd, e1, e2) - -> ( + -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with - | Const Cint i, _ when IntLit.iszero i - -> e1' - | _, Const Cint i when IntLit.iszero i - -> e2' - | Const Cint i1, Const Cint i2 - -> Exp.int (IntLit.logand i1 i2) - | _ - -> if abs then Exp.get_undefined false else BinOp (BAnd, e1', e2') ) + | Const Cint i, _ when IntLit.iszero i -> + e1' + | _, Const Cint i when IntLit.iszero i -> + e2' + | Const Cint i1, Const Cint i2 -> + Exp.int (IntLit.logand i1 i2) + | _ -> + if abs then Exp.get_undefined false else BinOp (BAnd, e1', e2') ) | BinOp (BOr, e1, e2) - -> ( + -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with - | Const Cint i, _ when IntLit.iszero i - -> e2' - | _, Const Cint i when IntLit.iszero i - -> e1' - | Const Cint i1, Const Cint i2 - -> Exp.int (IntLit.logor i1 i2) - | _ - -> if abs then Exp.get_undefined false else BinOp (BOr, e1', e2') ) + | Const Cint i, _ when IntLit.iszero i -> + e2' + | _, Const Cint i when IntLit.iszero i -> + e1' + | Const Cint i1, Const Cint i2 -> + Exp.int (IntLit.logor i1 i2) + | _ -> + if abs then Exp.get_undefined false else BinOp (BOr, e1', e2') ) | BinOp (BXor, e1, e2) - -> ( + -> ( let e1' = eval e1 in let e2' = eval e2 in match (e1', e2') with - | Const Cint i, _ when IntLit.iszero i - -> e2' - | _, Const Cint i when IntLit.iszero i - -> e1' - | Const Cint i1, Const Cint i2 - -> Exp.int (IntLit.logxor i1 i2) - | _ - -> if abs then Exp.get_undefined false else BinOp (BXor, e1', e2') ) - | Exn _ - -> e - | Lvar _ - -> e - | Lfield (e1, fld, typ) - -> let e1' = eval e1 in + | Const Cint i, _ when IntLit.iszero i -> + e2' + | _, Const Cint i when IntLit.iszero i -> + e1' + | Const Cint i1, Const Cint i2 -> + Exp.int (IntLit.logxor i1 i2) + | _ -> + if abs then Exp.get_undefined false else BinOp (BXor, e1', e2') ) + | Exn _ -> + e + | Lvar _ -> + e + | Lfield (e1, fld, typ) -> + let e1' = eval e1 in Lfield (e1', fld, typ) | Lindex (Lvar pv, e2) - when false (* removed: it interferes with re-arrangement and error messages *) - -> (* &x[n] --> &x + n *) + when false (* removed: it interferes with re-arrangement and error messages *) -> + (* &x[n] --> &x + n *) eval (Exp.BinOp (PlusPI, Lvar pv, e2)) - | Lindex (BinOp (PlusPI, ep, e1), e2) - -> (* array access with pointer arithmetic *) + | Lindex (BinOp (PlusPI, ep, e1), e2) -> + (* array access with pointer arithmetic *) let e' : Exp.t = BinOp (PlusA, e1, e2) in eval (Exp.Lindex (ep, e')) - | Lindex (e1, e2) - -> let e1' = eval e1 in + | Lindex (e1, e2) -> + let e1' = eval e1 in let e2' = eval e2 in Lindex (e1', e2') in @@ -1115,83 +1163,88 @@ module Normalize = struct (* L.d_str "sym_eval "; Sil.d_exp e; L.d_str" --> "; Sil.d_exp e'; L.d_ln (); *) e' + let exp_normalize ?destructive tenv sub exp = let exp' = Sil.exp_sub sub exp in let abstract_expressions = !Config.abs_val >= 1 in sym_eval ?destructive tenv abstract_expressions exp' + let texp_normalize tenv sub (exp: Exp.t) : Exp.t = match exp with - | Sizeof ({dynamic_length} as sizeof_data) - -> Sizeof + | Sizeof ({dynamic_length} as sizeof_data) -> + Sizeof {sizeof_data with dynamic_length= Option.map ~f:(exp_normalize tenv sub) dynamic_length} - | _ - -> exp_normalize tenv sub exp + | _ -> + exp_normalize tenv sub exp + let exp_normalize_noabs tenv sub exp = Config.run_with_abs_val_equal_zero (exp_normalize tenv sub) exp + (** Turn an inequality expression into an atom *) let mk_inequality tenv (e: Exp.t) : Sil.atom = match e with | BinOp (Le, base, Const Cint n) - -> ( + -> ( (* base <= n case *) let nbase = exp_normalize_noabs tenv Sil.sub_empty base in match nbase with - | BinOp (PlusA, base', Const Cint n') - -> let new_offset = Exp.int (n -- n') in + | BinOp (PlusA, base', Const Cint n') -> + let new_offset = Exp.int (n -- n') in let new_e : Exp.t = BinOp (Le, base', new_offset) in Aeq (new_e, Exp.one) - | BinOp (PlusA, Const Cint n', base') - -> let new_offset = Exp.int (n -- n') in + | BinOp (PlusA, Const Cint n', base') -> + let new_offset = Exp.int (n -- n') in let new_e : Exp.t = BinOp (Le, base', new_offset) in Aeq (new_e, Exp.one) - | BinOp (MinusA, base', Const Cint n') - -> let new_offset = Exp.int (n ++ n') in + | BinOp (MinusA, base', Const Cint n') -> + let new_offset = Exp.int (n ++ n') in let new_e : Exp.t = BinOp (Le, base', new_offset) in Aeq (new_e, Exp.one) - | BinOp (MinusA, Const Cint n', base') - -> let new_offset = Exp.int (n' -- n -- IntLit.one) in + | BinOp (MinusA, Const Cint n', base') -> + let new_offset = Exp.int (n' -- n -- IntLit.one) in let new_e : Exp.t = BinOp (Lt, new_offset, base') in Aeq (new_e, Exp.one) - | UnOp (Neg, new_base, _) - -> (* In this case, base = -new_base. Construct -n-1 < new_base. *) + | UnOp (Neg, new_base, _) -> + (* In this case, base = -new_base. Construct -n-1 < new_base. *) let new_offset = Exp.int (IntLit.zero -- n -- IntLit.one) in let new_e : Exp.t = BinOp (Lt, new_offset, new_base) in Aeq (new_e, Exp.one) - | _ - -> Aeq (e, Exp.one) ) + | _ -> + Aeq (e, Exp.one) ) | BinOp (Lt, Const Cint n, base) - -> ( + -> ( (* n < base case *) let nbase = exp_normalize_noabs tenv Sil.sub_empty base in match nbase with - | BinOp (PlusA, base', Const Cint n') - -> let new_offset = Exp.int (n -- n') in + | BinOp (PlusA, base', Const Cint n') -> + let new_offset = Exp.int (n -- n') in let new_e : Exp.t = BinOp (Lt, new_offset, base') in Aeq (new_e, Exp.one) - | BinOp (PlusA, Const Const.Cint n', base') - -> let new_offset = Exp.int (n -- n') in + | BinOp (PlusA, Const Const.Cint n', base') -> + let new_offset = Exp.int (n -- n') in let new_e : Exp.t = BinOp (Lt, new_offset, base') in Aeq (new_e, Exp.one) - | BinOp (MinusA, base', Const Cint n') - -> let new_offset = Exp.int (n ++ n') in + | BinOp (MinusA, base', Const Cint n') -> + let new_offset = Exp.int (n ++ n') in let new_e : Exp.t = BinOp (Lt, new_offset, base') in Aeq (new_e, Exp.one) - | BinOp (MinusA, Const Cint n', base') - -> let new_offset = Exp.int (n' -- n -- IntLit.one) in + | BinOp (MinusA, Const Cint n', base') -> + let new_offset = Exp.int (n' -- n -- IntLit.one) in let new_e : Exp.t = BinOp (Le, base', new_offset) in Aeq (new_e, Exp.one) - | UnOp (Neg, new_base, _) - -> (* In this case, base = -new_base. Construct new_base <= -n-1 *) + | UnOp (Neg, new_base, _) -> + (* In this case, base = -new_base. Construct new_base <= -n-1 *) let new_offset = Exp.int (IntLit.zero -- n -- IntLit.one) in let new_e : Exp.t = BinOp (Le, new_base, new_offset) in Aeq (new_e, Exp.one) - | _ - -> Aeq (e, Exp.one) ) - | _ - -> Aeq (e, Exp.one) + | _ -> + Aeq (e, Exp.one) ) + | _ -> + Aeq (e, Exp.one) + (** Normalize an inequality *) let inequality_normalize tenv (a: Sil.atom) = @@ -1199,21 +1252,21 @@ module Normalize = struct integer offset representing inequality [sum(pos) - sum(neg) + off <= 0] *) let rec exp_to_posnegoff (e: Exp.t) = match e with - | Const Cint n - -> ([], [], n) - | BinOp (PlusA, e1, e2) | BinOp (PlusPI, e1, e2) - -> let pos1, neg1, n1 = exp_to_posnegoff e1 in + | Const Cint n -> + ([], [], n) + | BinOp (PlusA, e1, e2) | BinOp (PlusPI, e1, e2) -> + let pos1, neg1, n1 = exp_to_posnegoff e1 in let pos2, neg2, n2 = exp_to_posnegoff e2 in (pos1 @ pos2, neg1 @ neg2, n1 ++ n2) - | BinOp (MinusA, e1, e2) | BinOp (MinusPI, e1, e2) | BinOp (MinusPP, e1, e2) - -> let pos1, neg1, n1 = exp_to_posnegoff e1 in + | BinOp (MinusA, e1, e2) | BinOp (MinusPI, e1, e2) | BinOp (MinusPP, e1, e2) -> + let pos1, neg1, n1 = exp_to_posnegoff e1 in let pos2, neg2, n2 = exp_to_posnegoff e2 in (pos1 @ neg2, neg1 @ pos2, n1 -- n2) - | UnOp (Neg, e1, _) - -> let pos1, neg1, n1 = exp_to_posnegoff e1 in + | UnOp (Neg, e1, _) -> + let pos1, neg1, n1 = exp_to_posnegoff e1 in (neg1, pos1, IntLit.zero -- n1) - | _ - -> ([e], [], IntLit.zero) + | _ -> + ([e], [], IntLit.zero) in (* sort and filter out expressions appearing in both the positive and negative part *) let normalize_posnegoff (pos, neg, off) = @@ -1222,51 +1275,52 @@ module Normalize = struct let rec combine pacc nacc = function | x :: ps, y :: ng -> ( match Exp.compare x y with - | n when n < 0 - -> combine (x :: pacc) nacc (ps, y :: ng) - | 0 - -> combine pacc nacc (ps, ng) - | _ - -> combine pacc (y :: nacc) (x :: ps, ng) ) - | ps, ng - -> (List.rev_append pacc ps, List.rev_append nacc ng) + | n when n < 0 -> + combine (x :: pacc) nacc (ps, y :: ng) + | 0 -> + combine pacc nacc (ps, ng) + | _ -> + combine pacc (y :: nacc) (x :: ps, ng) ) + | ps, ng -> + (List.rev_append pacc ps, List.rev_append nacc ng) in let pos'', neg'' = combine [] [] (pos', neg') in (pos'', neg'', off) in (* turn a non-empty list of expressions into a sum expression *) let rec exp_list_to_sum : Exp.t list -> Exp.t = function - | [] - -> assert false - | [e] - -> e - | e :: el - -> BinOp (PlusA, e, exp_list_to_sum el) + | [] -> + assert false + | [e] -> + e + | e :: el -> + BinOp (PlusA, e, exp_list_to_sum el) in let norm_from_exp e : Exp.t = match normalize_posnegoff (exp_to_posnegoff e) with - | [], [], n - -> BinOp (Le, Exp.int n, Exp.zero) - | [], neg, n - -> BinOp (Lt, Exp.int (n -- IntLit.one), exp_list_to_sum neg) - | pos, [], n - -> BinOp (Le, exp_list_to_sum pos, Exp.int (IntLit.zero -- n)) - | pos, neg, n - -> let lhs_e : Exp.t = BinOp (MinusA, exp_list_to_sum pos, exp_list_to_sum neg) in + | [], [], n -> + BinOp (Le, Exp.int n, Exp.zero) + | [], neg, n -> + BinOp (Lt, Exp.int (n -- IntLit.one), exp_list_to_sum neg) + | pos, [], n -> + BinOp (Le, exp_list_to_sum pos, Exp.int (IntLit.zero -- n)) + | pos, neg, n -> + let lhs_e : Exp.t = BinOp (MinusA, exp_list_to_sum pos, exp_list_to_sum neg) in BinOp (Le, lhs_e, Exp.int (IntLit.zero -- n)) in let ineq = match a with Aeq (ineq, Const Cint i) when IntLit.isone i -> ineq | _ -> assert false in match ineq with - | BinOp (Le, e1, e2) - -> let e : Exp.t = BinOp (MinusA, e1, e2) in + | BinOp (Le, e1, e2) -> + let e : Exp.t = BinOp (MinusA, e1, e2) in mk_inequality tenv (norm_from_exp e) - | BinOp (Lt, e1, e2) - -> let e : Exp.t = BinOp (MinusA, BinOp (MinusA, e1, e2), Exp.minus_one) in + | BinOp (Lt, e1, e2) -> + let e : Exp.t = BinOp (MinusA, BinOp (MinusA, e1, e2), Exp.minus_one) in mk_inequality tenv (norm_from_exp e) - | _ - -> a + | _ -> + a + (** Normalize an atom. We keep the convention that inequalities with constants @@ -1277,40 +1331,40 @@ module Normalize = struct match eq with | BinOp (PlusA, e1, Const Cint n1), Const Cint n2 (* e1+n1==n2 ---> e1==n2-n1 *) - | BinOp (PlusPI, e1, Const Cint n1), Const Cint n2 - -> (e1, Exp.int (n2 -- n1)) + | BinOp (PlusPI, e1, Const Cint n1), Const Cint n2 -> + (e1, Exp.int (n2 -- n1)) | BinOp (MinusA, e1, Const Cint n1), Const Cint n2 (* e1-n1==n2 ---> e1==n1+n2 *) - | BinOp (MinusPI, e1, Const Cint n1), Const Cint n2 - -> (e1, Exp.int (n1 ++ n2)) - | BinOp (MinusA, Const Cint n1, e1), Const Cint n2 - -> (* n1-e1 == n2 -> e1==n1-n2 *) + | BinOp (MinusPI, e1, Const Cint n1), Const Cint n2 -> + (e1, Exp.int (n1 ++ n2)) + | BinOp (MinusA, Const Cint n1, e1), Const Cint n2 -> + (* n1-e1 == n2 -> e1==n1-n2 *) (e1, Exp.int (n1 -- n2)) - | Lfield (e1', fld1, _), Lfield (e2', fld2, _) - -> if Typ.Fieldname.equal fld1 fld2 then normalize_eq (e1', e2') else eq - | Lindex (e1', idx1), Lindex (e2', idx2) - -> if Exp.equal idx1 idx2 then normalize_eq (e1', e2') + | Lfield (e1', fld1, _), Lfield (e2', fld2, _) -> + if Typ.Fieldname.equal fld1 fld2 then normalize_eq (e1', e2') else eq + | Lindex (e1', idx1), Lindex (e2', idx2) -> + if Exp.equal idx1 idx2 then normalize_eq (e1', e2') else if Exp.equal e1' e2' then normalize_eq (idx1, idx2) else eq - | BinOp ((PlusA | PlusPI | MinusA | MinusPI), e1, e2), e1' when Exp.equal e1 e1' - -> (e2, Exp.int IntLit.zero) - | BinOp ((PlusA | PlusPI), e2, e1), e1' when Exp.equal e1 e1' - -> (e2, Exp.int IntLit.zero) - | e1', BinOp ((PlusA | PlusPI | MinusA | MinusPI), e1, e2) when Exp.equal e1 e1' - -> (e2, Exp.int IntLit.zero) - | e1', BinOp ((PlusA | PlusPI), e2, e1) when Exp.equal e1 e1' - -> (e2, Exp.int IntLit.zero) - | _ - -> eq + | BinOp ((PlusA | PlusPI | MinusA | MinusPI), e1, e2), e1' when Exp.equal e1 e1' -> + (e2, Exp.int IntLit.zero) + | BinOp ((PlusA | PlusPI), e2, e1), e1' when Exp.equal e1 e1' -> + (e2, Exp.int IntLit.zero) + | e1', BinOp ((PlusA | PlusPI | MinusA | MinusPI), e1, e2) when Exp.equal e1 e1' -> + (e2, Exp.int IntLit.zero) + | e1', BinOp ((PlusA | PlusPI), e2, e1) when Exp.equal e1 e1' -> + (e2, Exp.int IntLit.zero) + | _ -> + eq in let handle_unary_negation (e1: Exp.t) (e2: Exp.t) = match (e1, e2) with | UnOp (LNot, e1', _), Const Cint i | Const Cint i, UnOp (LNot, e1', _) - when IntLit.iszero i - -> (e1', Exp.zero, true) - | _ - -> (e1, e2, false) + when IntLit.iszero i -> + (e1', Exp.zero, true) + | _ -> + (e1, e2, false) in let handle_boolean_operation from_equality e1 e2 : Sil.atom = let ne1 = exp_normalize tenv sub e1 in @@ -1323,54 +1377,56 @@ module Normalize = struct in let a' : Sil.atom = match a with - | Aeq (e1, e2) - -> handle_boolean_operation true e1 e2 - | Aneq (e1, e2) - -> handle_boolean_operation false e1 e2 - | Apred (a, es) - -> Apred (a, List.map ~f:(fun e -> exp_normalize tenv sub e) es) - | Anpred (a, es) - -> Anpred (a, List.map ~f:(fun e -> exp_normalize tenv sub e) es) + | Aeq (e1, e2) -> + handle_boolean_operation true e1 e2 + | Aneq (e1, e2) -> + handle_boolean_operation false e1 e2 + | Apred (a, es) -> + Apred (a, List.map ~f:(fun e -> exp_normalize tenv sub e) es) + | Anpred (a, es) -> + Anpred (a, List.map ~f:(fun e -> exp_normalize tenv sub e) es) in if atom_is_inequality a' then inequality_normalize tenv a' else a' + let normalize_and_strengthen_atom tenv (p: normal t) (a: Sil.atom) : Sil.atom = let a' = atom_normalize tenv (`Exp p.sub) a in match a' with - | Aeq (BinOp (Le, Var id, Const Cint n), Const Cint i) when IntLit.isone i - -> let lower = Exp.int (n -- IntLit.one) in + | Aeq (BinOp (Le, Var id, Const Cint n), Const Cint i) when IntLit.isone i -> + let lower = Exp.int (n -- IntLit.one) in let a_lower : Sil.atom = Aeq (BinOp (Lt, lower, Var id), Exp.one) in if not (List.mem ~equal:Sil.equal_atom p.pi a_lower) then a' else Aeq (Var id, Exp.int n) - | Aeq (BinOp (Lt, Const Cint n, Var id), Const Cint i) when IntLit.isone i - -> let upper = Exp.int (n ++ IntLit.one) in + | Aeq (BinOp (Lt, Const Cint n, Var id), Const Cint i) when IntLit.isone i -> + let upper = Exp.int (n ++ IntLit.one) in let a_upper : Sil.atom = Aeq (BinOp (Le, Var id, upper), Exp.one) in if not (List.mem ~equal:Sil.equal_atom p.pi a_upper) then a' else Aeq (Var id, upper) - | Aeq (BinOp (Ne, e1, e2), Const Cint i) when IntLit.isone i - -> Aneq (e1, e2) - | _ - -> a' + | Aeq (BinOp (Ne, e1, e2), Const Cint i) when IntLit.isone i -> + Aneq (e1, e2) + | _ -> + a' + let rec strexp_normalize tenv sub (se: Sil.strexp) : Sil.strexp = match se with - | Eexp (e, inst) - -> Eexp (exp_normalize tenv sub e, inst) + | Eexp (e, inst) -> + Eexp (exp_normalize tenv sub e, inst) | Estruct (fld_cnts, inst) -> ( match fld_cnts with - | [] - -> se - | _ - -> let fld_cnts' = + | [] -> + se + | _ -> + let fld_cnts' = List.map ~f:(fun (fld, cnt) -> (fld, strexp_normalize tenv sub cnt)) fld_cnts in let fld_cnts'' = List.sort ~cmp:[%compare : Typ.Fieldname.t * Sil.strexp] fld_cnts' in Estruct (fld_cnts'', inst) ) - | Earray (len, idx_cnts, inst) - -> let len' = exp_normalize_noabs tenv sub len in + | Earray (len, idx_cnts, inst) -> + let len' = exp_normalize_noabs tenv sub len in match idx_cnts with - | [] - -> if Exp.equal len len' then se else Earray (len', idx_cnts, inst) - | _ - -> let idx_cnts' = + | [] -> + if Exp.equal len len' then se else Earray (len', idx_cnts, inst) + | _ -> + let idx_cnts' = List.map ~f:(fun (idx, cnt) -> let idx' = exp_normalize tenv sub idx in @@ -1380,23 +1436,25 @@ module Normalize = struct let idx_cnts'' = List.sort ~cmp:[%compare : Exp.t * Sil.strexp] idx_cnts' in Earray (len', idx_cnts'', inst) + (** Exp.Construct a pointsto. *) let mk_ptsto tenv lexp sexp te : Sil.hpred = let nsexp = strexp_normalize tenv Sil.sub_empty sexp in Hpointsto (lexp, nsexp, te) + (** Construct a points-to predicate for an expression using either the provided expression [name] as base for fresh identifiers. If [struct_init_mode] is [Fld_init], initialize the fields of structs with fresh variables. *) let mk_ptsto_exp tenv struct_init_mode (exp, (te: Exp.t), expo) inst : Sil.hpred = let default_strexp () : Sil.strexp = match te with - | Sizeof {typ; dynamic_length} - -> create_strexp_of_type tenv struct_init_mode typ dynamic_length inst - | Var _ - -> Estruct ([], inst) - | te - -> L.internal_error "trying to create ptsto with type: %a@." (Sil.pp_texp_full Pp.text) te ; + | Sizeof {typ; dynamic_length} -> + create_strexp_of_type tenv struct_init_mode typ dynamic_length inst + | Var _ -> + Estruct ([], inst) + | te -> + L.internal_error "trying to create ptsto with type: %a@." (Sil.pp_texp_full Pp.text) te ; assert false in let strexp : Sil.strexp = @@ -1404,6 +1462,7 @@ module Normalize = struct in mk_ptsto tenv exp strexp te + let rec hpred_normalize tenv sub (hpred: Sil.hpred) : Sil.hpred = let replace_hpred hpred' = L.d_strln "found array with sizeof(..) size" ; @@ -1417,56 +1476,56 @@ module Normalize = struct in match hpred with | Hpointsto (root, cnt, te) - -> ( + -> ( let normalized_root = exp_normalize tenv sub root in let normalized_cnt = strexp_normalize tenv sub cnt in let normalized_te = texp_normalize tenv sub te in match (normalized_cnt, normalized_te) with - | Earray ((Exp.Sizeof _ as size), [], inst), Sizeof {typ= {desc= Tarray _}} - -> (* check for an empty array whose size expression is (Sizeof type), and turn the array + | Earray ((Exp.Sizeof _ as size), [], inst), Sizeof {typ= {desc= Tarray _}} -> + (* check for an empty array whose size expression is (Sizeof type), and turn the array into a strexp of the given type *) let hpred' = mk_ptsto_exp tenv Fld_init (root, size, None) inst in replace_hpred hpred' | ( Earray (BinOp (Mult, Sizeof {typ= t; dynamic_length= None; subtype= st1}, x), esel, inst) , Sizeof {typ= {desc= Tarray (elt, _, _)} as arr} ) - when Typ.equal t elt - -> let dynamic_length = Some x in + when Typ.equal t elt -> + let dynamic_length = Some x in let sizeof_data = {Exp.typ= arr; nbytes= None; dynamic_length; subtype= st1} in let hpred' = mk_ptsto_exp tenv Fld_init (root, Sizeof sizeof_data, None) inst in replace_hpred (replace_array_contents hpred' esel) | ( Earray (BinOp (Mult, x, Sizeof {typ; dynamic_length= None; subtype}), esel, inst) , Sizeof {typ= {desc= Tarray (elt, _, _)} as arr} ) - when Typ.equal typ elt - -> let sizeof_data = {Exp.typ= arr; nbytes= None; dynamic_length= Some x; subtype} in + when Typ.equal typ elt -> + let sizeof_data = {Exp.typ= arr; nbytes= None; dynamic_length= Some x; subtype} in let hpred' = mk_ptsto_exp tenv Fld_init (root, Sizeof sizeof_data, None) inst in replace_hpred (replace_array_contents hpred' esel) | ( Earray (BinOp (Mult, Sizeof {typ; dynamic_length= Some len; subtype}, x), esel, inst) , Sizeof {typ= {desc= Tarray (elt, _, _)} as arr} ) - when Typ.equal typ elt - -> let sizeof_data = + when Typ.equal typ elt -> + let sizeof_data = {Exp.typ= arr; nbytes= None; dynamic_length= Some (Exp.BinOp (Mult, x, len)); subtype} in let hpred' = mk_ptsto_exp tenv Fld_init (root, Sizeof sizeof_data, None) inst in replace_hpred (replace_array_contents hpred' esel) | ( Earray (BinOp (Mult, x, Sizeof {typ; dynamic_length= Some len; subtype}), esel, inst) , Sizeof {typ= {desc= Tarray (elt, _, _)} as arr} ) - when Typ.equal typ elt - -> let sizeof_data = + when Typ.equal typ elt -> + let sizeof_data = {Exp.typ= arr; nbytes= None; dynamic_length= Some (Exp.BinOp (Mult, x, len)); subtype} in let hpred' = mk_ptsto_exp tenv Fld_init (root, Sizeof sizeof_data, None) inst in replace_hpred (replace_array_contents hpred' esel) - | _ - -> Hpointsto (normalized_root, normalized_cnt, normalized_te) ) - | Hlseg (k, para, e1, e2, elist) - -> let normalized_e1 = exp_normalize tenv sub e1 in + | _ -> + Hpointsto (normalized_root, normalized_cnt, normalized_te) ) + | Hlseg (k, para, e1, e2, elist) -> + let normalized_e1 = exp_normalize tenv sub e1 in let normalized_e2 = exp_normalize tenv sub e2 in let normalized_elist = List.map ~f:(exp_normalize tenv sub) elist in let normalized_para = hpara_normalize tenv para in Hlseg (k, normalized_para, normalized_e1, normalized_e2, normalized_elist) - | Hdllseg (k, para, e1, e2, e3, e4, elist) - -> let norm_e1 = exp_normalize tenv sub e1 in + | Hdllseg (k, para, e1, e2, e3, e4, elist) -> + let norm_e1 = exp_normalize tenv sub e1 in let norm_e2 = exp_normalize tenv sub e2 in let norm_e3 = exp_normalize tenv sub e3 in let norm_e4 = exp_normalize tenv sub e4 in @@ -1474,22 +1533,26 @@ module Normalize = struct let norm_para = hpara_dll_normalize tenv para in Hdllseg (k, norm_para, norm_e1, norm_e2, norm_e3, norm_e4, norm_elist) + and hpara_normalize tenv (para: Sil.hpara) = let normalized_body = List.map ~f:(hpred_normalize tenv Sil.sub_empty) para.body in let sorted_body = List.sort ~cmp:Sil.compare_hpred normalized_body in {para with body= sorted_body} + and hpara_dll_normalize tenv (para: Sil.hpara_dll) = let normalized_body = List.map ~f:(hpred_normalize tenv Sil.sub_empty) para.body_dll in let sorted_body = List.sort ~cmp:Sil.compare_hpred normalized_body in {para with body_dll= sorted_body} + let sigma_normalize tenv sub sigma = let sigma' = List.stable_sort ~cmp:Sil.compare_hpred (List.map ~f:(hpred_normalize tenv sub) sigma) in if equal_sigma sigma sigma' then sigma else sigma' + let pi_tighten_ineq tenv pi = let ineq_list, nonineq_list = List.partition_tf ~f:atom_is_inequality pi in let diseq_list = @@ -1506,10 +1569,10 @@ module Normalize = struct match atom_exp_le_const a with Some (e, n) -> (e, n) :: acc | _ -> acc in let rec le_tighten le_list_done = function - | [] - -> List.rev le_list_done - | (e, n) :: le_list_todo - -> (* e <= n *) + | [] -> + List.rev le_list_done + | (e, n) :: le_list_todo -> + (* e <= n *) if is_neq e n then le_tighten le_list_done ((e, n -- IntLit.one) :: le_list_todo) else le_tighten ((e, n) :: le_list_done) le_list_todo in @@ -1521,10 +1584,10 @@ module Normalize = struct match atom_const_lt_exp a with Some (n, e) -> (n, e) :: acc | _ -> acc in let rec lt_tighten lt_list_done = function - | [] - -> List.rev lt_list_done - | (n, e) :: lt_list_todo - -> (* n < e *) + | [] -> + List.rev lt_list_done + | (n, e) :: lt_list_todo -> + (* n < e *) let n_plus_one = n ++ IntLit.one in if is_neq e n_plus_one then lt_tighten lt_list_done ((n ++ IntLit.one, e) :: lt_list_todo) @@ -1546,8 +1609,8 @@ module Normalize = struct List.filter ~f:(fun (a: Sil.atom) -> match a with - | Aneq (Const Cint n, e) | Aneq (e, Const Cint n) - -> not + | Aneq (Const Cint n, e) | Aneq (e, Const Cint n) -> + not (List.exists ~f:(fun (e', n') -> Exp.equal e e' && IntLit.lt n' n) le_list_tightened) @@ -1555,38 +1618,39 @@ module Normalize = struct (List.exists ~f:(fun (n', e') -> Exp.equal e e' && IntLit.leq n n') lt_list_tightened) - | _ - -> true) + | _ -> + true) nonineq_list in (ineq_list', nonineq_list') + (** Normalization of pi. The normalization filters out obviously - true disequalities, such as e <> e + 1. *) let pi_normalize tenv sub sigma pi0 = let pi = List.map ~f:(atom_normalize tenv sub) pi0 in let ineq_list, nonineq_list = pi_tighten_ineq tenv pi in let syntactically_different : Exp.t * Exp.t -> bool = function - | BinOp (op1, e1, Const c1), BinOp (op2, e2, Const c2) when Exp.equal e1 e2 - -> Binop.equal op1 op2 && Binop.injective op1 && not (Const.equal c1 c2) - | e1, BinOp (op2, e2, Const c2) when Exp.equal e1 e2 - -> Binop.injective op2 && Binop.is_zero_runit op2 && not (Const.equal (Cint IntLit.zero) c2) - | BinOp (op1, e1, Const c1), e2 when Exp.equal e1 e2 - -> Binop.injective op1 && Binop.is_zero_runit op1 && not (Const.equal (Cint IntLit.zero) c1) - | _ - -> false + | BinOp (op1, e1, Const c1), BinOp (op2, e2, Const c2) when Exp.equal e1 e2 -> + Binop.equal op1 op2 && Binop.injective op1 && not (Const.equal c1 c2) + | e1, BinOp (op2, e2, Const c2) when Exp.equal e1 e2 -> + Binop.injective op2 && Binop.is_zero_runit op2 && not (Const.equal (Cint IntLit.zero) c2) + | BinOp (op1, e1, Const c1), e2 when Exp.equal e1 e2 -> + Binop.injective op1 && Binop.is_zero_runit op1 && not (Const.equal (Cint IntLit.zero) c1) + | _ -> + false in let filter_useful_atom : Sil.atom -> bool = - let unsigned_exps = (lazy (sigma_get_unsigned_exps sigma)) in + let unsigned_exps = lazy (sigma_get_unsigned_exps sigma) in function - | Aneq ((Var _ as e), Const Cint n) when IntLit.isnegative n - -> not (List.exists ~f:(Exp.equal e) (Lazy.force unsigned_exps)) - | Aneq (e1, e2) - -> not (syntactically_different (e1, e2)) - | Aeq (Const c1, Const c2) - -> not (Const.equal c1 c2) - | _ - -> true + | Aneq ((Var _ as e), Const Cint n) when IntLit.isnegative n -> + not (List.exists ~f:(Exp.equal e) (Lazy.force unsigned_exps)) + | Aneq (e1, e2) -> + not (syntactically_different (e1, e2)) + | Aeq (Const c1, Const c2) -> + not (Const.equal c1 c2) + | _ -> + true in let pi' = List.stable_sort ~cmp:Sil.compare_atom @@ -1595,6 +1659,7 @@ module Normalize = struct let pi'' = pi_sorted_remove_redundant pi' in if equal_pi pi0 pi'' then pi0 else pi'' + (** normalize the footprint part, and rename any primed vars in the footprint with fresh footprint vars *) let footprint_normalize tenv prop = @@ -1623,12 +1688,14 @@ module Normalize = struct in set prop ~pi_fp:npi' ~sigma_fp:nsigma' + (** This function assumes that if (x,Exp.Var(y)) in sub, then compare x y = 1 *) let sub_normalize sub = let f (id, e) = not (Ident.is_primed id) && not (Sil.ident_in_exp id e) in let sub' = Sil.sub_filter_pair ~f sub in if Sil.equal_exp_subst sub sub' then sub else sub' + (** Conjoin a pure atomic predicate by normal conjunction. *) let rec prop_atom_and tenv ?(footprint= false) (p: normal t) a : normal t = let a' = normalize_and_strengthen_atom tenv p a in @@ -1636,10 +1703,10 @@ module Normalize = struct else let p' = match a' with - | Aeq (Var i, e) when Sil.ident_in_exp i e - -> p - | Aeq (Var i, e) - -> let sub_list = [(i, e)] in + | Aeq (Var i, e) when Sil.ident_in_exp i e -> + p + | Aeq (Var i, e) -> + let sub_list = [(i, e)] in let mysub = Sil.exp_subst_of_list sub_list in let p_sub = Sil.sub_filter (fun i' -> not (Ident.equal i i')) p.sub in let exp_sub' = @@ -1653,30 +1720,31 @@ module Normalize = struct let eqs_zero, nsigma'' = sigma_remove_emptylseg nsigma' in let p' = unsafe_cast_to_normal (set p ~sub:nsub' ~pi:npi' ~sigma:nsigma'') in List.fold ~f:(prop_atom_and tenv ~footprint) ~init:p' eqs_zero - | Aeq (e1, e2) when Exp.equal e1 e2 - -> p - | Aneq (e1, e2) - -> let sigma' = sigma_intro_nonemptylseg e1 e2 p.sigma in + | Aeq (e1, e2) when Exp.equal e1 e2 -> + p + | Aneq (e1, e2) -> + let sigma' = sigma_intro_nonemptylseg e1 e2 p.sigma in let pi' = pi_normalize tenv (`Exp p.sub) sigma' (a' :: p.pi) in unsafe_cast_to_normal (set p ~pi:pi' ~sigma:sigma') - | _ - -> let pi' = pi_normalize tenv (`Exp p.sub) p.sigma (a' :: p.pi) in + | _ -> + let pi' = pi_normalize tenv (`Exp p.sub) p.sigma (a' :: p.pi) in unsafe_cast_to_normal (set p ~pi:pi') in if not footprint then p' else let p'' = match a' with - | Aeq (Exp.Var i, e) when not (Sil.ident_in_exp i e) - -> let mysub = Sil.subst_of_list [(i, e)] in + | Aeq (Exp.Var i, e) when not (Sil.ident_in_exp i e) -> + let mysub = Sil.subst_of_list [(i, e)] in let sigma_fp' = sigma_normalize tenv mysub p'.sigma_fp in let pi_fp' = a' :: pi_normalize tenv mysub sigma_fp' p'.pi_fp in footprint_normalize tenv (set p' ~pi_fp:pi_fp' ~sigma_fp:sigma_fp') - | _ - -> footprint_normalize tenv (set p' ~pi_fp:(a' :: p'.pi_fp)) + | _ -> + footprint_normalize tenv (set p' ~pi_fp:(a' :: p'.pi_fp)) in unsafe_cast_to_normal p'' + (** normalize a prop *) let normalize tenv (eprop: 'a t) : normal t = let p0 = @@ -1685,6 +1753,7 @@ module Normalize = struct let nprop = List.fold ~f:(prop_atom_and tenv) ~init:p0 (get_pure_extended eprop) in unsafe_cast_to_normal (footprint_normalize tenv (set nprop ~pi_fp:eprop.pi_fp ~sigma_fp:eprop.sigma_fp)) + end (* End of module Normalize *) @@ -1694,6 +1763,7 @@ let exp_normalize_prop ?destructive tenv prop exp = (Normalize.exp_normalize ?destructive tenv (`Exp prop.sub)) exp + let lexp_normalize_prop tenv p lexp = let root = Exp.root_of_lexp lexp in let offsets = Sil.exp_get_offsets lexp in @@ -1706,31 +1776,39 @@ let lexp_normalize_prop tenv p lexp = in Sil.exp_add_offsets nroot noffsets + let atom_normalize_prop tenv prop atom = Config.run_with_abs_val_equal_zero (Normalize.atom_normalize tenv (`Exp prop.sub)) atom + let strexp_normalize_prop tenv prop strexp = Config.run_with_abs_val_equal_zero (Normalize.strexp_normalize tenv (`Exp prop.sub)) strexp + let hpred_normalize_prop tenv prop hpred = Config.run_with_abs_val_equal_zero (Normalize.hpred_normalize tenv (`Exp prop.sub)) hpred + let sigma_normalize_prop tenv prop sigma = Config.run_with_abs_val_equal_zero (Normalize.sigma_normalize tenv (`Exp prop.sub)) sigma + let pi_normalize_prop tenv prop pi = Config.run_with_abs_val_equal_zero (Normalize.pi_normalize tenv (`Exp prop.sub) prop.sigma) pi + let sigma_replace_exp tenv epairs sigma = let sigma' = List.map ~f:(Sil.hpred_replace_exp epairs) sigma in Normalize.sigma_normalize tenv Sil.sub_empty sigma' + (** Construct an atom. *) let mk_atom tenv atom = Config.run_with_abs_val_equal_zero (fun () -> Normalize.atom_normalize tenv Sil.sub_empty atom) () + (** Exp.Construct a disequality. *) let mk_neq tenv e1 e2 = mk_atom tenv (Aneq (e1, e2)) @@ -1748,16 +1826,19 @@ let mk_lseg tenv k para e_start e_end es_shared : Sil.hpred = let npara = Normalize.hpara_normalize tenv para in Hlseg (k, npara, e_start, e_end, es_shared) + (** Exp.Construct a dllseg predicate *) let mk_dllseg tenv k para exp_iF exp_oB exp_oF exp_iB exps_shared : Sil.hpred = let npara = Normalize.hpara_dll_normalize tenv para in Hdllseg (k, npara, exp_iF, exp_oB, exp_oF, exp_iB, exps_shared) + (** Exp.Construct a hpara *) let mk_hpara tenv root next svars evars body = - let para = {Sil.root= root; next; svars; evars; body} in + let para = {Sil.root; next; svars; evars; body} in Normalize.hpara_normalize tenv para + (** Exp.Construct a dll_hpara *) let mk_dll_hpara tenv iF oB oF svars evars body = let para = @@ -1765,25 +1846,30 @@ let mk_dll_hpara tenv iF oB oF svars evars body = in Normalize.hpara_dll_normalize tenv para + (** Construct a points-to predicate for a single program variable. If [expand_structs] is [Fld_init], initialize the fields of structs with fresh variables. *) let mk_ptsto_lvar tenv expand_structs inst ((pvar: Pvar.t), texp, expo) : Sil.hpred = Normalize.mk_ptsto_exp tenv expand_structs (Lvar pvar, texp, expo) inst + (** Conjoin [exp1]=[exp2] with a symbolic heap [prop]. *) let conjoin_eq tenv ?(footprint= false) exp1 exp2 prop = Normalize.prop_atom_and tenv ~footprint prop (Aeq (exp1, exp2)) + (** Conjoin [exp1!=exp2] with a symbolic heap [prop]. *) let conjoin_neq tenv ?(footprint= false) exp1 exp2 prop = Normalize.prop_atom_and tenv ~footprint prop (Aneq (exp1, exp2)) + (** Reset every inst in the prop using the given map *) let prop_reset_inst inst_map prop = let sigma' = List.map ~f:(Sil.hpred_instmap inst_map) prop.sigma in let sigma_fp' = List.map ~f:(Sil.hpred_instmap inst_map) prop.sigma_fp in set prop ~sigma:sigma' ~sigma_fp:sigma_fp' + (** {1 Functions for transforming footprints into propositions.} *) (** The ones used for abstraction add/remove local stacks in order to @@ -1799,6 +1885,7 @@ let extract_spec (p: normal t) : normal t * normal t = let post = set p ~pi_fp:[] ~sigma_fp:[] in (unsafe_cast_to_normal pre, unsafe_cast_to_normal post) + (** [prop_set_fooprint p p_foot] sets proposition [p_foot] as footprint of [p]. *) let prop_set_footprint p p_foot = let pi = @@ -1806,6 +1893,7 @@ let prop_set_footprint p p_foot = in set p ~pi_fp:pi ~sigma_fp:p_foot.sigma + (** {2 Functions for renaming primed variables by "canonical names"} *) module ExpStack : sig @@ -1825,6 +1913,7 @@ end = struct Stack.clear stack ; List.iter ~f:(fun e -> Stack.push stack e) (List.rev es) + let final () = Stack.clear stack let is_empty () = Stack.is_empty stack @@ -1840,6 +1929,7 @@ let sigma_get_start_lexps_sort sigma = let lexps = Sil.hpred_list_get_lexps filter sigma in List.sort ~cmp:exp_compare_neg lexps + let sigma_dfs_sort tenv sigma = let init () = let start_lexps = sigma_get_start_lexps_sort sigma in @@ -1848,35 +1938,35 @@ let sigma_dfs_sort tenv sigma = let final () = ExpStack.final () in let rec handle_strexp (se: Sil.strexp) = match se with - | Eexp (e, _) - -> ExpStack.push e - | Estruct (fld_se_list, _) - -> List.iter ~f:(fun (_, se) -> handle_strexp se) fld_se_list - | Earray (_, idx_se_list, _) - -> List.iter ~f:(fun (_, se) -> handle_strexp se) idx_se_list + | Eexp (e, _) -> + ExpStack.push e + | Estruct (fld_se_list, _) -> + List.iter ~f:(fun (_, se) -> handle_strexp se) fld_se_list + | Earray (_, idx_se_list, _) -> + List.iter ~f:(fun (_, se) -> handle_strexp se) idx_se_list in let rec handle_e visited seen e (sigma: sigma) = match sigma with - | [] - -> (visited, List.rev seen) + | [] -> + (visited, List.rev seen) | hpred :: cur -> match hpred with - | Hpointsto (e', se, _) when Exp.equal e e' - -> handle_strexp se ; (hpred :: visited, List.rev_append cur seen) - | Hlseg (_, _, root, next, shared) when Exp.equal e root - -> List.iter ~f:ExpStack.push (next :: shared) ; + | Hpointsto (e', se, _) when Exp.equal e e' -> + handle_strexp se ; (hpred :: visited, List.rev_append cur seen) + | Hlseg (_, _, root, next, shared) when Exp.equal e root -> + List.iter ~f:ExpStack.push (next :: shared) ; (hpred :: visited, List.rev_append cur seen) - | Hdllseg (_, _, iF, oB, oF, iB, shared) when Exp.equal e iF || Exp.equal e iB - -> List.iter ~f:ExpStack.push (oB :: oF :: shared) ; + | Hdllseg (_, _, iF, oB, oF, iB, shared) when Exp.equal e iF || Exp.equal e iB -> + List.iter ~f:ExpStack.push (oB :: oF :: shared) ; (hpred :: visited, List.rev_append cur seen) - | _ - -> handle_e visited (hpred :: seen) e cur + | _ -> + handle_e visited (hpred :: seen) e cur in let rec handle_sigma visited = function - | [] - -> List.rev visited - | cur - -> if ExpStack.is_empty () then + | [] -> + List.rev visited + | cur -> + if ExpStack.is_empty () then let cur' = Normalize.sigma_normalize tenv Sil.sub_empty cur in List.rev_append cur' visited else @@ -1888,6 +1978,7 @@ let sigma_dfs_sort tenv sigma = let sigma' = handle_sigma [] sigma in final () ; sigma' + let prop_dfs_sort tenv p = let sigma = p.sigma in let sigma' = sigma_dfs_sort tenv sigma in @@ -1897,43 +1988,47 @@ let prop_dfs_sort tenv p = (* L.out "@[<2>P SORTED:@\n%a@\n@." pp_prop p'; *) p' + let prop_fav_add_dfs tenv fav prop = prop_fav_add fav (prop_dfs_sort tenv prop) let rec strexp_get_array_indices acc (se: Sil.strexp) = match se with - | Eexp _ - -> acc - | Estruct (fsel, _) - -> let se_list = List.map ~f:snd fsel in + | Eexp _ -> + acc + | Estruct (fsel, _) -> + let se_list = List.map ~f:snd fsel in List.fold ~f:strexp_get_array_indices ~init:acc se_list - | Earray (_, isel, _) - -> let acc_new = List.fold ~f:(fun acc' (idx, _) -> idx :: acc') ~init:acc isel in + | Earray (_, isel, _) -> + let acc_new = List.fold ~f:(fun acc' (idx, _) -> idx :: acc') ~init:acc isel in let se_list = List.map ~f:snd isel in List.fold ~f:strexp_get_array_indices ~init:acc_new se_list + let hpred_get_array_indices acc (hpred: Sil.hpred) = match hpred with - | Hpointsto (_, se, _) - -> strexp_get_array_indices acc se - | Hlseg _ | Hdllseg _ - -> acc + | Hpointsto (_, se, _) -> + strexp_get_array_indices acc se + | Hlseg _ | Hdllseg _ -> + acc + let sigma_get_array_indices sigma = let indices = List.fold ~f:hpred_get_array_indices ~init:[] sigma in List.rev indices + let compute_reindexing fav_add get_id_offset list = let rec select list_passed list_seen = function - | [] - -> list_passed - | x :: list_rest - -> let id_offset_opt = get_id_offset x in + | [] -> + list_passed + | x :: list_rest -> + let id_offset_opt = get_id_offset x in let list_passed_new = match id_offset_opt with - | None - -> list_passed - | Some (id, _) - -> let fav = Sil.fav_new () in + | None -> + list_passed + | Some (id, _) -> + let fav = Sil.fav_new () in List.iter ~f:(fav_add fav) list_seen ; List.iter ~f:(fav_add fav) list_passed ; if Sil.fav_exists fav (Ident.equal id) then list_passed else x :: list_passed @@ -1952,17 +2047,19 @@ let compute_reindexing fav_add get_id_offset list = let reindexing = List.map ~f:transform list_passed in Sil.exp_subst_of_list reindexing + let compute_reindexing_from_indices indices = let get_id_offset (e: Exp.t) = match e with - | BinOp (PlusA, Var id, Const Cint offset) - -> if Ident.is_primed id then Some (id, offset) else None - | _ - -> None + | BinOp (PlusA, Var id, Const Cint offset) -> + if Ident.is_primed id then Some (id, offset) else None + | _ -> + None in let fav_add = Sil.exp_fav_add in compute_reindexing fav_add get_id_offset indices + let apply_reindexing tenv (exp_subst: Sil.exp_subst) prop = let subst = `Exp exp_subst in let nsigma = Normalize.sigma_normalize tenv subst prop.sigma in @@ -1982,22 +2079,23 @@ let apply_reindexing tenv (exp_subst: Sil.exp_subst) prop = let p' = unsafe_cast_to_normal (set prop ~sub:nsub ~pi:npi ~sigma:nsigma) in List.fold ~f:(Normalize.prop_atom_and tenv) ~init:p' atoms + let prop_rename_array_indices tenv prop = if !Config.footprint then prop else let indices = sigma_get_array_indices prop.sigma in let not_same_base_lt_offsets (e1: Exp.t) (e2: Exp.t) = match (e1, e2) with - | BinOp (PlusA, e1', Const Cint n1'), BinOp (PlusA, e2', Const Cint n2') - -> not (Exp.equal e1' e2' && IntLit.lt n1' n2') - | _ - -> true + | BinOp (PlusA, e1', Const Cint n1'), BinOp (PlusA, e2', Const Cint n2') -> + not (Exp.equal e1' e2' && IntLit.lt n1' n2') + | _ -> + true in let rec select_minimal_indices indices_seen = function - | [] - -> List.rev indices_seen - | index :: indices_rest - -> let indices_seen' = List.filter ~f:(not_same_base_lt_offsets index) indices_seen in + | [] -> + List.rev indices_seen + | index :: indices_rest -> + let indices_seen' = List.filter ~f:(not_same_base_lt_offsets index) indices_seen in let indices_seen_new = index :: indices_seen' in let indices_rest_new = List.filter ~f:(not_same_base_lt_offsets index) indices_rest in select_minimal_indices indices_seen_new indices_rest_new @@ -2006,6 +2104,7 @@ let prop_rename_array_indices tenv prop = let subst = compute_reindexing_from_indices minimal_indices in apply_reindexing tenv subst prop + let compute_renaming fav = let ids = Sil.fav_to_list fav in let ids_primed, ids_nonprimed = List.partition_tf ~f:Ident.is_primed ids in @@ -2013,10 +2112,10 @@ let compute_renaming fav = let id_base_primed = Ident.create Ident.kprimed 0 in let id_base_footprint = Ident.create Ident.kfootprint 0 in let rec f id_base index ren_subst = function - | [] - -> ren_subst - | id :: ids - -> let new_id = Ident.set_stamp id_base index in + | [] -> + ren_subst + | id :: ids -> + let new_id = Ident.set_stamp id_base index in if Ident.equal id new_id then f id_base (index + 1) ren_subst ids else f id_base (index + 1) ((id, new_id) :: ren_subst) ids in @@ -2024,88 +2123,94 @@ let compute_renaming fav = let ren_footprint = f id_base_footprint 0 [] ids_footprint in ren_primed @ ren_footprint + let rec idlist_assoc id = function - | [] - -> raise Not_found - | (i, x) :: l - -> if Ident.equal i id then x else idlist_assoc id l + | [] -> + raise Not_found + | (i, x) :: l -> + if Ident.equal i id then x else idlist_assoc id l + let ident_captured_ren ren id = try idlist_assoc id ren with Not_found -> id + (* If not defined in ren, id should be mapped to itself *) let rec exp_captured_ren ren (e: Exp.t) : Exp.t = match e with - | Var id - -> Var (ident_captured_ren ren id) - | Exn e - -> Exn (exp_captured_ren ren e) - | Closure _ - -> e (* TODO: why captured vars not renamed? *) - | Const _ - -> e - | Sizeof ({dynamic_length} as sizeof_data) - -> Sizeof {sizeof_data with dynamic_length= Option.map ~f:(exp_captured_ren ren) dynamic_length} - | Cast (t, e) - -> Cast (t, exp_captured_ren ren e) - | UnOp (op, e, topt) - -> UnOp (op, exp_captured_ren ren e, topt) - | BinOp (op, e1, e2) - -> let e1' = exp_captured_ren ren e1 in + | Var id -> + Var (ident_captured_ren ren id) + | Exn e -> + Exn (exp_captured_ren ren e) + | Closure _ -> + e (* TODO: why captured vars not renamed? *) + | Const _ -> + e + | Sizeof ({dynamic_length} as sizeof_data) -> + Sizeof {sizeof_data with dynamic_length= Option.map ~f:(exp_captured_ren ren) dynamic_length} + | Cast (t, e) -> + Cast (t, exp_captured_ren ren e) + | UnOp (op, e, topt) -> + UnOp (op, exp_captured_ren ren e, topt) + | BinOp (op, e1, e2) -> + let e1' = exp_captured_ren ren e1 in let e2' = exp_captured_ren ren e2 in BinOp (op, e1', e2') - | Lvar id - -> Lvar id - | Lfield (e, fld, typ) - -> Lfield (exp_captured_ren ren e, fld, typ) - | Lindex (e1, e2) - -> let e1' = exp_captured_ren ren e1 in + | Lvar id -> + Lvar id + | Lfield (e, fld, typ) -> + Lfield (exp_captured_ren ren e, fld, typ) + | Lindex (e1, e2) -> + let e1' = exp_captured_ren ren e1 in let e2' = exp_captured_ren ren e2 in Lindex (e1', e2') + let atom_captured_ren ren (a: Sil.atom) : Sil.atom = match a with - | Aeq (e1, e2) - -> Aeq (exp_captured_ren ren e1, exp_captured_ren ren e2) - | Aneq (e1, e2) - -> Aneq (exp_captured_ren ren e1, exp_captured_ren ren e2) - | Apred (a, es) - -> Apred (a, List.map ~f:(fun e -> exp_captured_ren ren e) es) - | Anpred (a, es) - -> Anpred (a, List.map ~f:(fun e -> exp_captured_ren ren e) es) + | Aeq (e1, e2) -> + Aeq (exp_captured_ren ren e1, exp_captured_ren ren e2) + | Aneq (e1, e2) -> + Aneq (exp_captured_ren ren e1, exp_captured_ren ren e2) + | Apred (a, es) -> + Apred (a, List.map ~f:(fun e -> exp_captured_ren ren e) es) + | Anpred (a, es) -> + Anpred (a, List.map ~f:(fun e -> exp_captured_ren ren e) es) + let rec strexp_captured_ren ren (se: Sil.strexp) : Sil.strexp = match se with - | Eexp (e, inst) - -> Eexp (exp_captured_ren ren e, inst) - | Estruct (fld_se_list, inst) - -> let f (fld, se) = (fld, strexp_captured_ren ren se) in + | Eexp (e, inst) -> + Eexp (exp_captured_ren ren e, inst) + | Estruct (fld_se_list, inst) -> + let f (fld, se) = (fld, strexp_captured_ren ren se) in Estruct (List.map ~f fld_se_list, inst) - | Earray (len, idx_se_list, inst) - -> let f (idx, se) = + | Earray (len, idx_se_list, inst) -> + let f (idx, se) = let idx' = exp_captured_ren ren idx in (idx', strexp_captured_ren ren se) in let len' = exp_captured_ren ren len in Earray (len', List.map ~f idx_se_list, inst) + and hpred_captured_ren ren (hpred: Sil.hpred) : Sil.hpred = match hpred with - | Hpointsto (base, se, te) - -> let base' = exp_captured_ren ren base in + | Hpointsto (base, se, te) -> + let base' = exp_captured_ren ren base in let se' = strexp_captured_ren ren se in let te' = exp_captured_ren ren te in Hpointsto (base', se', te') - | Hlseg (k, para, e1, e2, elist) - -> let para' = hpara_ren para in + | Hlseg (k, para, e1, e2, elist) -> + let para' = hpara_ren para in let e1' = exp_captured_ren ren e1 in let e2' = exp_captured_ren ren e2 in let elist' = List.map ~f:(exp_captured_ren ren) elist in Hlseg (k, para', e1', e2', elist') - | Hdllseg (k, para, e1, e2, e3, e4, elist) - -> let para' = hpara_dll_ren para in + | Hdllseg (k, para, e1, e2, e3, e4, elist) -> + let para' = hpara_dll_ren para in let e1' = exp_captured_ren ren e1 in let e2' = exp_captured_ren ren e2 in let e3' = exp_captured_ren ren e3 in @@ -2113,6 +2218,7 @@ and hpred_captured_ren ren (hpred: Sil.hpred) : Sil.hpred = let elist' = List.map ~f:(exp_captured_ren ren) elist in Hdllseg (k, para', e1', e2', e3', e4', elist') + and hpara_ren (para: Sil.hpara) : Sil.hpara = let av = Sil.hpara_shallow_av para in let ren = compute_renaming av in @@ -2123,6 +2229,7 @@ and hpara_ren (para: Sil.hpara) : Sil.hpara = let body = List.map ~f:(hpred_captured_ren ren) para.body in {root; next; svars; evars; body} + and hpara_dll_ren (para: Sil.hpara_dll) : Sil.hpara_dll = let av = Sil.hpara_dll_shallow_av para in let ren = compute_renaming av in @@ -2134,6 +2241,7 @@ and hpara_dll_ren (para: Sil.hpara_dll) : Sil.hpara_dll = let body' = List.map ~f:(hpred_captured_ren ren) para.body_dll in {cell= iF; flink= oF; blink= oB; svars_dll= svars'; evars_dll= evars'; body_dll= body'} + let pi_captured_ren ren pi = List.map ~f:(atom_captured_ren ren) pi let sigma_captured_ren ren sigma = List.map ~f:(hpred_captured_ren ren) sigma @@ -2147,7 +2255,8 @@ let prop_rename_primed_footprint_vars tenv (p: normal t) : normal t = let filter id = Ident.is_footprint id || Ident.is_primed id in let p_dfs = prop_dfs_sort tenv p in let fvars_in_p = prop_fav p_dfs in - Sil.fav_filter_ident fvars_in_p filter ; fvars_in_p + Sil.fav_filter_ident fvars_in_p filter ; + fvars_in_p in let ren = compute_renaming bound_vars in let sub' = sub_captured_ren ren p.sub in @@ -2167,6 +2276,7 @@ let prop_rename_primed_footprint_vars tenv (p: normal t) : normal t = in unsafe_cast_to_normal p' + let expose (p: normal t) : exposed t = Obj.magic p (** Apply subsitution to prop. *) @@ -2177,10 +2287,12 @@ let prop_sub subst (prop: 'a t) : exposed t = let sigma_fp = sigma_sub subst prop.sigma_fp in set prop_emp ~pi ~sigma ~pi_fp ~sigma_fp + (** Apply renaming substitution to a proposition. *) let prop_ren_sub tenv (ren_sub: Sil.exp_subst) (prop: normal t) : normal t = Normalize.normalize tenv (prop_sub (`Exp ren_sub) prop) + (** Existentially quantify the [fav] in [prop]. [fav] should not contain any primed variables. *) let exist_quantify tenv fav (prop: normal t) : normal t = @@ -2205,6 +2317,7 @@ let exist_quantify tenv fav (prop: normal t) : normal t = *) prop_ren_sub tenv ren_sub prop' + (** Apply the substitution [fe] to all the expressions in the prop. *) let prop_expmap (fe: Exp.t -> Exp.t) prop = let f (e, sil_opt) = (fe e, sil_opt) in @@ -2214,6 +2327,7 @@ let prop_expmap (fe: Exp.t -> Exp.t) prop = let sigma_fp = List.map ~f:(Sil.hpred_expmap f) prop.sigma_fp in set prop ~pi ~sigma ~pi_fp ~sigma_fp + (** convert identifiers in fav to kind [k] *) let vars_make_unprimed tenv fav prop = let ids = Sil.fav_to_list fav in @@ -2223,15 +2337,20 @@ let vars_make_unprimed tenv fav prop = in prop_ren_sub tenv ren_sub prop + (** convert the normal vars to primed vars. *) let prop_normal_vars_to_primed_vars tenv p = let fav = prop_fav p in - Sil.fav_filter_ident fav Ident.is_normal ; exist_quantify tenv fav p + Sil.fav_filter_ident fav Ident.is_normal ; + exist_quantify tenv fav p + (** convert the primed vars to normal vars. *) let prop_primed_vars_to_normal_vars tenv (p: normal t) : normal t = let fav = prop_fav p in - Sil.fav_filter_ident fav Ident.is_primed ; vars_make_unprimed tenv fav p + Sil.fav_filter_ident fav Ident.is_primed ; + vars_make_unprimed tenv fav p + let from_pi pi = set prop_emp ~pi @@ -2248,19 +2367,21 @@ let prop_rename_fav_with_existentials tenv (p: normal t) : normal t = (*L.d_strln "Prop after renaming:"; d_prop p'; L.d_strln "";*) Normalize.normalize tenv p' + (** Removes seeds variables from a prop corresponding to captured variables in an objc block *) let remove_seed_captured_vars_block tenv captured_vars prop = let hpred_seed_captured = function - | Sil.Hpointsto (Exp.Lvar pv, _, _) - -> let pname = Pvar.get_name pv in + | Sil.Hpointsto (Exp.Lvar pv, _, _) -> + let pname = Pvar.get_name pv in Pvar.is_seed pv && List.mem ~equal:Mangled.equal captured_vars pname - | _ - -> false + | _ -> + false in let sigma = prop.sigma in let sigma' = List.filter ~f:(fun hpred -> not (hpred_seed_captured hpred)) sigma in Normalize.normalize tenv (set prop ~sigma:sigma') + (** {2 Prop iterators} *) (** Iterator state over sigma. *) @@ -2278,8 +2399,8 @@ type 'a prop_iter = let prop_iter_create prop = match prop.sigma with - | hpred :: sigma' - -> Some + | hpred :: sigma' -> + Some { pit_sub= prop.sub ; pit_pi= prop.pi ; pit_newpi= [] @@ -2289,8 +2410,9 @@ let prop_iter_create prop = ; pit_new= sigma' ; pit_pi_fp= prop.pi_fp ; pit_sigma_fp= prop.sigma_fp } - | _ - -> None + | _ -> + None + (** Return the prop associated to the iterator. *) let prop_iter_to_prop tenv iter = @@ -2304,12 +2426,14 @@ let prop_iter_to_prop tenv iter = ~f:(fun p (footprint, atom) -> Normalize.prop_atom_and tenv ~footprint p atom) ~init:prop iter.pit_newpi + (** Add an atom to the pi part of prop iter. The first parameter records whether it is done during footprint or during re - execution. *) let prop_iter_add_atom footprint iter atom = {iter with pit_newpi= (footprint, atom) :: iter.pit_newpi} + (** Remove the current element of the iterator, and return the prop associated to the resulting iterator *) let prop_iter_remove_curr_then_to_prop tenv iter : normal t = @@ -2321,6 +2445,7 @@ let prop_iter_remove_curr_then_to_prop tenv iter : normal t = in unsafe_cast_to_normal prop + (** Return the current hpred and state. *) let prop_iter_current tenv iter = let curr = Normalize.hpred_normalize tenv (`Exp iter.pit_sub) iter.pit_curr in @@ -2332,45 +2457,51 @@ let prop_iter_current tenv iter = in match prop'.sigma with [curr'] -> (curr', iter.pit_state) | _ -> assert false + (** Update the current element of the iterator. *) let prop_iter_update_current iter hpred = {iter with pit_curr= hpred} (** Update the current element of the iterator by a nonempty list of elements. *) let prop_iter_update_current_by_list iter = function - | [] - -> assert false (* the list should be nonempty *) - | hpred :: hpred_list - -> let pit_new' = hpred_list @ iter.pit_new in + | [] -> + assert false (* the list should be nonempty *) + | hpred :: hpred_list -> + let pit_new' = hpred_list @ iter.pit_new in {iter with pit_curr= hpred; pit_state= (); pit_new= pit_new'} + let prop_iter_next iter = match iter.pit_new with - | [] - -> None - | hpred' :: new' - -> Some + | [] -> + None + | hpred' :: new' -> + Some { iter with pit_old= iter.pit_curr :: iter.pit_old; pit_curr= hpred'; pit_state= (); pit_new= new' } + let prop_iter_remove_curr_then_next iter = match iter.pit_new with - | [] - -> None - | hpred' :: new' - -> Some {iter with pit_old= iter.pit_old; pit_curr= hpred'; pit_state= (); pit_new= new'} + | [] -> + None + | hpred' :: new' -> + Some {iter with pit_old= iter.pit_old; pit_curr= hpred'; pit_state= (); pit_new= new'} + (** Insert before the current element of the iterator. *) let prop_iter_prev_then_insert iter hpred = {iter with pit_new= iter.pit_curr :: iter.pit_new; pit_curr= hpred} + (** Scan sigma to find an [hpred] satisfying the filter function. *) let rec prop_iter_find iter filter = match filter iter.pit_curr with - | Some st - -> Some {iter with pit_state= st} + | Some st -> + Some {iter with pit_state= st} | None -> match prop_iter_next iter with None -> None | Some iter' -> prop_iter_find iter' filter + (** Set the state of the iterator *) let prop_iter_set_state iter state = {iter with pit_state= state} @@ -2382,39 +2513,39 @@ let prop_iter_make_id_primed tenv id iter = Normalize.atom_normalize tenv Sil.sub_empty eq' in let rec split pairs_unpid pairs_pid = function - | [] - -> (List.rev pairs_unpid, List.rev pairs_pid) + | [] -> + (List.rev pairs_unpid, List.rev pairs_pid) | (eq :: eqs_cur: pi) -> match eq with - | Aeq (Var id1, e1) when Sil.ident_in_exp id1 e1 - -> L.internal_error "@[<2>#### ERROR: an assumption of the analyzer broken ####@\n" ; + | Aeq (Var id1, e1) when Sil.ident_in_exp id1 e1 -> + L.internal_error "@[<2>#### ERROR: an assumption of the analyzer broken ####@\n" ; L.internal_error "Broken Assumption: id notin e for all (id,e) in sub@\n" ; L.internal_error "(id,e) : (%a,%a)@\n" (Ident.pp Pp.text) id1 Exp.pp e1 ; L.internal_error "PROP : %a@\n@." (pp_prop Pp.text) (prop_iter_to_prop tenv iter) ; assert false - | Aeq (Var id1, e1) when Ident.equal pid id1 - -> split pairs_unpid ((id1, e1) :: pairs_pid) eqs_cur - | Aeq (Var id1, e1) - -> split ((id1, e1) :: pairs_unpid) pairs_pid eqs_cur - | _ - -> assert false + | Aeq (Var id1, e1) when Ident.equal pid id1 -> + split pairs_unpid ((id1, e1) :: pairs_pid) eqs_cur + | Aeq (Var id1, e1) -> + split ((id1, e1) :: pairs_unpid) pairs_pid eqs_cur + | _ -> + assert false in let rec get_eqs acc = function - | [] | [_] - -> List.rev acc - | (_, e1) :: ((_, e2) :: _ as pairs) - -> get_eqs (Sil.Aeq (e1, e2) :: acc) pairs + | [] | [_] -> + List.rev acc + | (_, e1) :: ((_, e2) :: _ as pairs) -> + get_eqs (Sil.Aeq (e1, e2) :: acc) pairs in let sub_new, sub_use, eqs_add = let eqs = List.map ~f:normalize (Sil.sub_to_list iter.pit_sub) in let pairs_unpid, pairs_pid = split [] [] eqs in match pairs_pid with - | [] - -> let sub_unpid = Sil.exp_subst_of_list pairs_unpid in + | [] -> + let sub_unpid = Sil.exp_subst_of_list pairs_unpid in let pairs = (id, Exp.Var pid) :: pairs_unpid in (sub_unpid, Sil.subst_of_list pairs, []) - | (id1, e1) :: _ - -> let sub_id1 = Sil.subst_of_list [(id1, e1)] in + | (id1, e1) :: _ -> + let sub_id1 = Sil.subst_of_list [(id1, e1)] in let pairs_unpid' = List.map ~f:(fun (id', e') -> (id', Sil.exp_sub sub_id1 e')) pairs_unpid in @@ -2430,13 +2561,17 @@ let prop_iter_make_id_primed tenv id iter = ; pit_curr= Sil.hpred_sub sub_use iter.pit_curr ; pit_new= sigma_sub sub_use iter.pit_new } + let prop_iter_footprint_fav_add fav iter = - sigma_fav_add fav iter.pit_sigma_fp ; pi_fav_add fav iter.pit_pi_fp + sigma_fav_add fav iter.pit_sigma_fp ; + pi_fav_add fav iter.pit_pi_fp + (** Find fav of the footprint part of the iterator *) let prop_iter_footprint_fav iter = Sil.fav_imperative_to_functional prop_iter_footprint_fav_add iter + let prop_iter_fav_add fav iter = Sil.sub_fav_add fav iter.pit_sub ; pi_fav_add fav iter.pit_pi ; @@ -2446,6 +2581,7 @@ let prop_iter_fav_add fav iter = Sil.hpred_fav_add fav iter.pit_curr ; prop_iter_footprint_fav_add fav iter + (** Find fav of the iterator *) let prop_iter_fav iter = Sil.fav_imperative_to_functional prop_iter_fav_add iter @@ -2456,6 +2592,7 @@ let prop_iter_noncurr_fav_add fav iter = Sil.sub_fav_add fav iter.pit_sub ; pi_fav_add fav iter.pit_pi + (** Extract the sigma part of the footprint *) let prop_iter_get_footprint_sigma iter = iter.pit_sigma_fp @@ -2466,38 +2603,41 @@ let prop_iter_noncurr_fav iter = Sil.fav_imperative_to_functional prop_iter_nonc let rec strexp_gc_fields (fav: Sil.fav) (se: Sil.strexp) = match se with - | Eexp _ - -> Some se - | Estruct (fsel, inst) - -> let fselo = List.map ~f:(fun (f, se) -> (f, strexp_gc_fields fav se)) fsel in + | Eexp _ -> + Some se + | Estruct (fsel, inst) -> + let fselo = List.map ~f:(fun (f, se) -> (f, strexp_gc_fields fav se)) fsel in let fsel' = let fselo' = List.filter ~f:(function _, Some _ -> true | _ -> false) fselo in List.map ~f:(function f, seo -> (f, unSome seo)) fselo' in if [%compare.equal : (Typ.Fieldname.t * Sil.strexp) list] fsel fsel' then Some se else Some (Sil.Estruct (fsel', inst)) - | Earray _ - -> Some se + | Earray _ -> + Some se + let hpred_gc_fields (fav: Sil.fav) (hpred: Sil.hpred) : Sil.hpred = match hpred with | Hpointsto (e, se, te) - -> ( + -> ( Sil.exp_fav_add fav e ; Sil.exp_fav_add fav te ; match strexp_gc_fields fav se with - | None - -> hpred - | Some se' - -> if Sil.equal_strexp se se' then hpred else Hpointsto (e, se', te) ) - | Hlseg _ | Hdllseg _ - -> hpred + | None -> + hpred + | Some se' -> + if Sil.equal_strexp se se' then hpred else Hpointsto (e, se', te) ) + | Hlseg _ | Hdllseg _ -> + hpred + let rec prop_iter_map f iter = let hpred_curr = f iter in let iter' = {iter with pit_curr= hpred_curr} in match prop_iter_next iter' with None -> iter' | Some iter'' -> prop_iter_map f iter'' + (** Collect garbage fields. *) let prop_iter_gc_fields iter = let f iter' = @@ -2506,6 +2646,7 @@ let prop_iter_gc_fields iter = in prop_iter_map f iter + let prop_case_split tenv prop = let pi_sigma_list = Sil.sigma_to_sigma_ne prop.sigma in let f props_acc (pi, sigma) = @@ -2515,12 +2656,14 @@ let prop_case_split tenv prop = in List.fold ~f ~init:[] pi_sigma_list + let prop_expand prop = (* let _ = check_prop_normalized prop in *) prop_case_split prop + (*** START of module Metrics ***) module Metrics : sig val prop_size : 'a t -> int @@ -2539,18 +2682,20 @@ end = struct and hpred_size (hpred: Sil.hpred) = match hpred with - | Hpointsto _ - -> ptsto_weight - | Hlseg (_, hpara, _, _, _) - -> lseg_weight * hpara_size hpara - | Hdllseg (_, hpara_dll, _, _, _, _, _) - -> lseg_weight * hpara_dll_size hpara_dll + | Hpointsto _ -> + ptsto_weight + | Hlseg (_, hpara, _, _, _) -> + lseg_weight * hpara_size hpara + | Hdllseg (_, hpara_dll, _, _, _, _, _) -> + lseg_weight * hpara_dll_size hpara_dll + and sigma_size sigma = let size = ref 0 in List.iter ~f:(fun hpred -> size := hpred_size hpred + !size) sigma ; !size + let pi_size pi = pi_weight * List.length pi (** Compute a size value for the prop, which indicates its @@ -2560,12 +2705,14 @@ end = struct let size_footprint = sigma_size p.sigma_fp in max size_current size_footprint + (** Approximate the size of the longest chain by counting the max number of |-> with the same type and whose lhs is primed or footprint *) let prop_chain_size p = let fp_size = pi_size p.pi_fp + sigma_size p.sigma_fp in pi_size p.pi + sigma_size p.sigma + fp_size + end (*** END of module Metrics ***) @@ -2587,28 +2734,28 @@ module CategorizePreconditions = struct let lhs_is_var_lvar : Exp.t -> bool = function Var _ -> true | Lvar _ -> true | _ -> false in let rhs_is_var : Sil.strexp -> bool = function Eexp (Var _, _) -> true | _ -> false in let rec rhs_only_vars : Sil.strexp -> bool = function - | Eexp (Var _, _) - -> true - | Estruct (fsel, _) - -> List.for_all ~f:(fun (_, se) -> rhs_only_vars se) fsel - | Earray _ - -> true - | _ - -> false + | Eexp (Var _, _) -> + true + | Estruct (fsel, _) -> + List.for_all ~f:(fun (_, se) -> rhs_only_vars se) fsel + | Earray _ -> + true + | _ -> + false in let hpred_is_var : Sil.hpred -> bool = function (* stack variable with no constraints *) - | Hpointsto (e, se, _) - -> lhs_is_lvar e && rhs_is_var se - | _ - -> false + | Hpointsto (e, se, _) -> + lhs_is_lvar e && rhs_is_var se + | _ -> + false in let hpred_only_allocation : Sil.hpred -> bool = function (* only constraint is allocation *) - | Hpointsto (e, se, _) - -> lhs_is_var_lvar e && rhs_only_vars se - | _ - -> false + | Hpointsto (e, se, _) -> + lhs_is_var_lvar e && rhs_only_vars se + | _ -> + false in let check_pre hpred_filter pre = let check_pi pi = List.is_empty pi in @@ -2618,14 +2765,15 @@ module CategorizePreconditions = struct let pres_no_constraints = List.filter ~f:(check_pre hpred_is_var) preconditions in let pres_only_allocation = List.filter ~f:(check_pre hpred_only_allocation) preconditions in match (preconditions, pres_no_constraints, pres_only_allocation) with - | [], _, _ - -> NoPres - | _ :: _, _ :: _, _ - -> Empty - | _ :: _, [], _ :: _ - -> OnlyAllocation - | _ :: _, [], [] - -> DataConstraints + | [], _, _ -> + NoPres + | _ :: _, _ :: _, _ -> + Empty + | _ :: _, [], _ :: _ -> + OnlyAllocation + | _ :: _, [], [] -> + DataConstraints + end (* Export for interface *) diff --git a/infer/src/backend/propgraph.ml b/infer/src/backend/propgraph.ml index cb472af7d..0cc991037 100644 --- a/infer/src/backend/propgraph.ml +++ b/infer/src/backend/propgraph.ml @@ -27,14 +27,15 @@ let from_prop p = p (** Return [true] if root node *) let rec is_root = function - | Exp.Var id - -> Ident.is_normal id - | Exp.Exn _ | Exp.Closure _ | Exp.Const _ | Exp.Lvar _ - -> true - | Exp.Cast (_, e) - -> is_root e - | Exp.UnOp _ | Exp.BinOp _ | Exp.Lfield _ | Exp.Lindex _ | Exp.Sizeof _ - -> false + | Exp.Var id -> + Ident.is_normal id + | Exp.Exn _ | Exp.Closure _ | Exp.Const _ | Exp.Lvar _ -> + true + | Exp.Cast (_, e) -> + is_root e + | Exp.UnOp _ | Exp.BinOp _ | Exp.Lfield _ | Exp.Lindex _ | Exp.Sizeof _ -> + false + (** Return [true] if the nodes are connected. Used to compute reachability. *) let nodes_connected n1 n2 = Exp.equal n1 n2 @@ -46,35 +47,37 @@ let edge_is_hpred = function Ehpred _ -> true | Eatom _ -> false | Esub_entry _ (** Return the source of the edge *) let edge_get_source = function - | Ehpred Sil.Hpointsto (e, _, _) - -> Some e - | Ehpred Sil.Hlseg (_, _, e, _, _) - -> Some e - | Ehpred Sil.Hdllseg (_, _, e1, _, _, _, _) - -> Some e1 (* only one direction supported for now *) - | Eatom Sil.Aeq (e1, _) - -> Some e1 - | Eatom Sil.Aneq (e1, _) - -> Some e1 - | Eatom (Sil.Apred (_, e :: _) | Anpred (_, e :: _)) - -> Some e - | Eatom (Sil.Apred (_, []) | Anpred (_, [])) - -> None - | Esub_entry (x, _) - -> Some (Exp.Var x) + | Ehpred Sil.Hpointsto (e, _, _) -> + Some e + | Ehpred Sil.Hlseg (_, _, e, _, _) -> + Some e + | Ehpred Sil.Hdllseg (_, _, e1, _, _, _, _) -> + Some e1 (* only one direction supported for now *) + | Eatom Sil.Aeq (e1, _) -> + Some e1 + | Eatom Sil.Aneq (e1, _) -> + Some e1 + | Eatom (Sil.Apred (_, e :: _) | Anpred (_, e :: _)) -> + Some e + | Eatom (Sil.Apred (_, []) | Anpred (_, [])) -> + None + | Esub_entry (x, _) -> + Some (Exp.Var x) + (** Return the successor nodes of the edge *) let edge_get_succs = function - | Ehpred hpred - -> Exp.Set.elements (Prop.hpred_get_targets hpred) - | Eatom Sil.Aeq (_, e2) - -> [e2] - | Eatom Sil.Aneq (_, e2) - -> [e2] - | Eatom (Sil.Apred _ | Anpred _) - -> [] - | Esub_entry (_, e) - -> [e] + | Ehpred hpred -> + Exp.Set.elements (Prop.hpred_get_targets hpred) + | Eatom Sil.Aeq (_, e2) -> + [e2] + | Eatom Sil.Aneq (_, e2) -> + [e2] + | Eatom (Sil.Apred _ | Anpred _) -> + [] + | Esub_entry (_, e) -> + [e] + let get_sigma footprint_part g = if footprint_part then g.Prop.sigma_fp else g.Prop.sigma @@ -95,11 +98,13 @@ let edge_from_source g n footprint_part is_hpred = in match List.filter ~f:starts_from edges with [] -> None | edge :: _ -> Some edge + (** [get_succs g n footprint_part is_hpred] returns the successor nodes of [n] in [g]. [footprint_part] indicates whether to search the successors in the footprint part, and [is_pred] whether to follow hpred edges. *) let get_succs g n footprint_part is_hpred = match edge_from_source g n footprint_part is_hpred with None -> [] | Some e -> edge_get_succs e + (** [get_edges footprint_part g] returns the list of edges in [g], in the footprint part if [fotprint_part] is true *) let get_edges footprint_part g = let hpreds = get_sigma footprint_part g in @@ -108,22 +113,25 @@ let get_edges footprint_part g = List.map ~f:(fun hpred -> Ehpred hpred) hpreds @ List.map ~f:(fun a -> Eatom a) atoms @ List.map ~f:(fun entry -> Esub_entry entry) subst_entries + let edge_equal e1 e2 = match (e1, e2) with - | Ehpred hp1, Ehpred hp2 - -> Sil.equal_hpred hp1 hp2 - | Eatom a1, Eatom a2 - -> Sil.equal_atom a1 a2 - | Esub_entry (x1, e1), Esub_entry (x2, e2) - -> Ident.equal x1 x2 && Exp.equal e1 e2 - | _ - -> false + | Ehpred hp1, Ehpred hp2 -> + Sil.equal_hpred hp1 hp2 + | Eatom a1, Eatom a2 -> + Sil.equal_atom a1 a2 + | Esub_entry (x1, e1), Esub_entry (x2, e2) -> + Ident.equal x1 x2 && Exp.equal e1 e2 + | _ -> + false + (** [contains_edge footprint_part g e] returns true if the graph [g] contains edge [e], searching the footprint part if [footprint_part] is true. *) let contains_edge (footprint_part: bool) (g: t) (e: edge) = List.exists ~f:(fun e' -> edge_equal e e') (get_edges footprint_part g) + (** [iter_edges footprint_part f g] iterates function [f] on the edges in [g] in the same order as returned by [get_edges]; if [footprint_part] is true the edges are taken from the footprint part. *) let iter_edges footprint_part f g = List.iter ~f (get_edges footprint_part g) @@ -140,66 +148,71 @@ type diff = let compute_exp_diff (e1: Exp.t) (e2: Exp.t) : Obj.t list = if Exp.equal e1 e2 then [] else [Obj.repr e2] + (** Compute the subobjects in [se2] which are different from those in [se1] *) let rec compute_sexp_diff (se1: Sil.strexp) (se2: Sil.strexp) : Obj.t list = match (se1, se2) with - | Sil.Eexp (e1, _), Sil.Eexp (e2, _) - -> if Exp.equal e1 e2 then [] else [Obj.repr se2] - | Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, _) - -> compute_fsel_diff fsel1 fsel2 - | Sil.Earray (e1, esel1, _), Sil.Earray (e2, esel2, _) - -> compute_exp_diff e1 e2 @ compute_esel_diff esel1 esel2 - | _ - -> [Obj.repr se2] + | Sil.Eexp (e1, _), Sil.Eexp (e2, _) -> + if Exp.equal e1 e2 then [] else [Obj.repr se2] + | Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, _) -> + compute_fsel_diff fsel1 fsel2 + | Sil.Earray (e1, esel1, _), Sil.Earray (e2, esel2, _) -> + compute_exp_diff e1 e2 @ compute_esel_diff esel1 esel2 + | _ -> + [Obj.repr se2] + and compute_fsel_diff fsel1 fsel2 : Obj.t list = match (fsel1, fsel2) with - | (f1, se1) :: fsel1', (f2, se2 as x) :: fsel2' -> ( + | (f1, se1) :: fsel1', ((f2, se2) as x) :: fsel2' -> ( match Typ.Fieldname.compare f1 f2 with - | n when n < 0 - -> compute_fsel_diff fsel1' fsel2 - | 0 - -> compute_sexp_diff se1 se2 @ compute_fsel_diff fsel1' fsel2' - | _ - -> Obj.repr x :: compute_fsel_diff fsel1 fsel2' ) - | _, [] - -> [] - | [], x :: fsel2' - -> Obj.repr x :: compute_fsel_diff [] fsel2' + | n when n < 0 -> + compute_fsel_diff fsel1' fsel2 + | 0 -> + compute_sexp_diff se1 se2 @ compute_fsel_diff fsel1' fsel2' + | _ -> + Obj.repr x :: compute_fsel_diff fsel1 fsel2' ) + | _, [] -> + [] + | [], x :: fsel2' -> + Obj.repr x :: compute_fsel_diff [] fsel2' + and compute_esel_diff esel1 esel2 : Obj.t list = match (esel1, esel2) with - | (e1, se1) :: esel1', (e2, se2 as x) :: esel2' -> ( + | (e1, se1) :: esel1', ((e2, se2) as x) :: esel2' -> ( match Exp.compare e1 e2 with - | n when n < 0 - -> compute_esel_diff esel1' esel2 - | 0 - -> compute_sexp_diff se1 se2 @ compute_esel_diff esel1' esel2' - | _ - -> Obj.repr x :: compute_esel_diff esel1 esel2' ) - | _, [] - -> [] - | [], x :: esel2' - -> Obj.repr x :: compute_esel_diff [] esel2' + | n when n < 0 -> + compute_esel_diff esel1' esel2 + | 0 -> + compute_sexp_diff se1 se2 @ compute_esel_diff esel1' esel2' + | _ -> + Obj.repr x :: compute_esel_diff esel1 esel2' ) + | _, [] -> + [] + | [], x :: esel2' -> + Obj.repr x :: compute_esel_diff [] esel2' + (** Compute the subobjects in [newedge] which are different from those in [oldedge] *) let compute_edge_diff (oldedge: edge) (newedge: edge) : Obj.t list = match (oldedge, newedge) with - | Ehpred Sil.Hpointsto (_, se1, e1), Ehpred Sil.Hpointsto (_, se2, e2) - -> compute_sexp_diff se1 se2 @ compute_exp_diff e1 e2 - | Eatom Sil.Aeq (_, e1), Eatom Sil.Aeq (_, e2) - -> compute_exp_diff e1 e2 - | Eatom Sil.Aneq (_, e1), Eatom Sil.Aneq (_, e2) - -> compute_exp_diff e1 e2 + | Ehpred Sil.Hpointsto (_, se1, e1), Ehpred Sil.Hpointsto (_, se2, e2) -> + compute_sexp_diff se1 se2 @ compute_exp_diff e1 e2 + | Eatom Sil.Aeq (_, e1), Eatom Sil.Aeq (_, e2) -> + compute_exp_diff e1 e2 + | Eatom Sil.Aneq (_, e1), Eatom Sil.Aneq (_, e2) -> + compute_exp_diff e1 e2 | Eatom Sil.Apred (_, es1), Eatom Sil.Apred (_, es2) - | Eatom Sil.Anpred (_, es1), Eatom Sil.Anpred (_, es2) - -> List.concat + | Eatom Sil.Anpred (_, es1), Eatom Sil.Anpred (_, es2) -> + List.concat ( try List.map2_exn ~f:compute_exp_diff es1 es2 with Invalid_argument _ -> [] ) - | Esub_entry (_, e1), Esub_entry (_, e2) - -> compute_exp_diff e1 e2 - | _ - -> [Obj.repr newedge] + | Esub_entry (_, e1), Esub_entry (_, e2) -> + compute_exp_diff e1 e2 + | _ -> + [Obj.repr newedge] + (** [compute_diff oldgraph newgraph] returns the list of edges which are only in [newgraph] *) let compute_diff default_color oldgraph newgraph : diff = @@ -211,21 +224,21 @@ let compute_diff default_color oldgraph newgraph : diff = match edge_get_source edge with | Some source -> ( match edge_from_source oldgraph source footprint_part (edge_is_hpred edge) with - | None - -> let changed_obj = + | None -> + let changed_obj = match edge with - | Ehpred hpred - -> Obj.repr hpred - | Eatom a - -> Obj.repr a - | Esub_entry entry - -> Obj.repr entry + | Ehpred hpred -> + Obj.repr hpred + | Eatom a -> + Obj.repr a + | Esub_entry entry -> + Obj.repr entry in changed := changed_obj :: !changed - | Some oldedge - -> changed := compute_edge_diff oldedge edge @ !changed ) - | None - -> () + | Some oldedge -> + changed := compute_edge_diff oldedge edge @ !changed ) + | None -> + () in List.iter ~f:build_changed newedges ; let colormap (o: Obj.t) = @@ -241,11 +254,13 @@ let compute_diff default_color oldgraph newgraph : diff = ; diff_changed_foot= changed_foot ; diff_cmap_foot= colormap_foot } + (** [diff_get_colormap footprint_part diff] returns the colormap of a computed diff, selecting the footprint colormap if [footprint_part] is true. *) let diff_get_colormap footprint_part diff = if footprint_part then diff.diff_cmap_foot else diff.diff_cmap_norm + (** Print a list of propositions, prepending each one with the given string. If !Config.pring_using_diff is true, print the diff w.r.t. the given prop, extracting its local stack vars if the boolean is true. *) @@ -264,38 +279,40 @@ let pp_proplist pe0 s (base_prop, extract_stack) f plist = else pe0 in let rec pp_seq_newline n f = function - | [] - -> () + | [] -> + () | [_x] - -> ( + -> ( let pe = update_pe_diff _x in let x = add_base_stack _x in match pe.kind with - | TEXT - -> F.fprintf f "%s %d of %d:@\n%a" s n num (Prop.pp_prop pe) x - | HTML - -> F.fprintf f "%s %d of %d:@\n%a@\n" s n num (Prop.pp_prop pe) x - | LATEX - -> F.fprintf f "@[%a@]@\n" (Prop.pp_prop pe) x ) - | _x :: l - -> let pe = update_pe_diff _x in + | TEXT -> + F.fprintf f "%s %d of %d:@\n%a" s n num (Prop.pp_prop pe) x + | HTML -> + F.fprintf f "%s %d of %d:@\n%a@\n" s n num (Prop.pp_prop pe) x + | LATEX -> + F.fprintf f "@[%a@]@\n" (Prop.pp_prop pe) x ) + | _x :: l -> + let pe = update_pe_diff _x in let x = add_base_stack _x in match pe.kind with - | TEXT - -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x + | TEXT -> + F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l - | HTML - -> F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x + | HTML -> + F.fprintf f "%s %d of %d:@\n%a@\n%a" s n num (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l - | LATEX - -> F.fprintf f "@[%a@]\\\\@\n\\bigvee\\\\@\n%a" (Prop.pp_prop pe) x + | LATEX -> + F.fprintf f "@[%a@]\\\\@\n\\bigvee\\\\@\n%a" (Prop.pp_prop pe) x (pp_seq_newline (n + 1)) l in pp_seq_newline 1 f plist + (** dump a propset *) let d_proplist (p: 'a Prop.t) (pl: 'b Prop.t list) = L.add_print_action (L.PTproplist, Obj.repr (p, pl)) + diff --git a/infer/src/backend/propset.ml b/infer/src/backend/propset.ml index 5482f4d16..7910b9f93 100644 --- a/infer/src/backend/propset.ml +++ b/infer/src/backend/propset.ml @@ -35,6 +35,7 @@ let add tenv p pset = ~f:(fun pset' p' -> PropSet.add (Prop.prop_rename_primed_footprint_vars tenv p') pset') ~init:pset ps + (** Singleton set. *) let singleton tenv p = add tenv p PropSet.empty @@ -71,6 +72,7 @@ let map_option tenv f pset = let plist = List.map ~f:(function Some p -> p | None -> assert false) plisto in from_proplist tenv plist + (** Apply function to all the elements of [propset]. *) let map tenv f pset = from_proplist tenv (List.map ~f (to_proplist pset)) @@ -80,6 +82,7 @@ let fold f a pset = let l = to_proplist pset in List.fold ~f ~init:a l + (** [iter f pset] computes (f p1;f p2;..;f pN) where [p1 ... pN] are the elements of pset, in increasing order. *) let iter = PropSet.iter @@ -95,6 +98,8 @@ let pp pe prop f pset = let plist = to_proplist pset in Propgraph.pp_proplist pe "PROP" (prop, false) f plist + let d p ps = let plist = to_proplist ps in Propgraph.d_proplist p plist + diff --git a/infer/src/backend/prover.ml b/infer/src/backend/prover.ml index 5f7e9ea50..be0020a6c 100644 --- a/infer/src/backend/prover.ml +++ b/infer/src/backend/prover.ml @@ -19,6 +19,7 @@ let decrease_indent_when_exception thunk = try thunk () with exn when SymOp.exn_not_failure exn -> reraise_after exn ~f:(fun () -> L.d_decrease_indent 1) + let compute_max_from_nonempty_int_list l = uw (List.max_elt ~cmp:IntLit.compare_value l) let compute_min_from_nonempty_int_list l = uw (List.min_elt ~cmp:IntLit.compare_value l) @@ -26,37 +27,40 @@ let compute_min_from_nonempty_int_list l = uw (List.min_elt ~cmp:IntLit.compare_ let rec list_rev_acc acc = function [] -> acc | x :: l -> list_rev_acc (x :: acc) l let rec remove_redundancy have_same_key acc = function - | [] - -> List.rev acc - | [x] - -> List.rev (x :: acc) - | x :: (y :: l' as l) - -> if have_same_key x y then remove_redundancy have_same_key acc (x :: l') + | [] -> + List.rev acc + | [x] -> + List.rev (x :: acc) + | x :: (y :: l' as l) -> + if have_same_key x y then remove_redundancy have_same_key acc (x :: l') else remove_redundancy have_same_key (x :: acc) l + let rec is_java_class tenv (typ: Typ.t) = match typ.desc with - | Tstruct name - -> Typ.Name.Java.is_class name - | Tarray (inner_typ, _, _) | Tptr (inner_typ, _) - -> is_java_class tenv inner_typ - | _ - -> false + | Tstruct name -> + Typ.Name.Java.is_class name + | Tarray (inner_typ, _, _) | Tptr (inner_typ, _) -> + is_java_class tenv inner_typ + | _ -> + false + (** Negate an atom *) let atom_negate tenv = function - | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i - -> Prop.mk_inequality tenv (Exp.lt e2 e1) - | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i - -> Prop.mk_inequality tenv (Exp.le e2 e1) - | Sil.Aeq (e1, e2) - -> Sil.Aneq (e1, e2) - | Sil.Aneq (e1, e2) - -> Sil.Aeq (e1, e2) - | Sil.Apred (a, es) - -> Sil.Anpred (a, es) - | Sil.Anpred (a, es) - -> Sil.Apred (a, es) + | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i -> + Prop.mk_inequality tenv (Exp.lt e2 e1) + | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i -> + Prop.mk_inequality tenv (Exp.le e2 e1) + | Sil.Aeq (e1, e2) -> + Sil.Aneq (e1, e2) + | Sil.Aneq (e1, e2) -> + Sil.Aeq (e1, e2) + | Sil.Apred (a, es) -> + Sil.Anpred (a, es) + | Sil.Anpred (a, es) -> + Sil.Apred (a, es) + (** {2 Ordinary Theorem Proving} *) @@ -90,6 +94,7 @@ end = struct let to_lt (e1, e2, n) = (Exp.int (IntLit.zero -- n -- IntLit.one), Exp.BinOp (Binop.MinusA, e2, e1)) + let to_triple entry = entry let from_leq acc (e1, e2) = @@ -98,31 +103,33 @@ end = struct , Exp.Const Const.Cint n ) when not (Ident.equal id11 id12) -> ( match IntLit.to_signed n with - | None - -> acc (* ignore: constraint algorithm only terminates on signed integers *) - | Some n' - -> (e11, e12, n') :: acc ) - | _ - -> acc + | None -> + acc (* ignore: constraint algorithm only terminates on signed integers *) + | Some n' -> + (e11, e12, n') :: acc ) + | _ -> + acc + let from_lt acc (e1, e2) = match (e1, e2) with | Exp.Const Const.Cint n, Exp.BinOp (Binop.MinusA, (Exp.Var id21 as e21), (Exp.Var id22 as e22)) when not (Ident.equal id21 id22) -> ( match IntLit.to_signed n with - | None - -> acc (* ignore: constraint algorithm only terminates on signed integers *) - | Some n' - -> let m = IntLit.zero -- n' -- IntLit.one in + | None -> + acc (* ignore: constraint algorithm only terminates on signed integers *) + | Some n' -> + let m = IntLit.zero -- n' -- IntLit.one in (e22, e21, m) :: acc ) - | _ - -> acc - - let rec generate (e1, e2, n as constr) acc = function - | [] - -> (false, acc) - | (f1, f2, m) :: rest - -> let equal_e2_f1 = Exp.equal e2 f1 in + | _ -> + acc + + + let rec generate ((e1, e2, n) as constr) acc = function + | [] -> + (false, acc) + | (f1, f2, m) :: rest -> + let equal_e2_f1 = Exp.equal e2 f1 in let equal_e1_f2 = Exp.equal e1 f2 in if equal_e2_f1 && equal_e1_f2 && IntLit.lt (n ++ m) IntLit.zero then (true, []) (* constraints are inconsistent *) @@ -135,6 +142,7 @@ end = struct generate constr (constr_new :: acc) rest else generate constr acc rest + let sort_then_remove_redundancy constraints = let constraints_sorted = List.sort ~cmp:compare constraints in let have_same_key (e1, e2, _) (f1, f2, _) = @@ -142,20 +150,22 @@ end = struct in remove_redundancy have_same_key [] constraints_sorted + let remove_redundancy constraints = let constraints' = sort_then_remove_redundancy constraints in List.filter ~f:(fun entry -> List.exists ~f:(equal entry) constraints') constraints + let rec combine acc_todos acc_seen constraints_new constraints_old = match (constraints_new, constraints_old) with - | [], [] - -> (List.rev acc_todos, List.rev acc_seen) - | [], _ - -> (List.rev acc_todos, list_rev_acc constraints_old acc_seen) - | _, [] - -> (list_rev_acc constraints_new acc_todos, list_rev_acc constraints_new acc_seen) - | constr :: rest, constr' :: rest' - -> let e1, e2, n = constr in + | [], [] -> + (List.rev acc_todos, List.rev acc_seen) + | [], _ -> + (List.rev acc_todos, list_rev_acc constraints_old acc_seen) + | _, [] -> + (list_rev_acc constraints_new acc_todos, list_rev_acc constraints_new acc_seen) + | constr :: rest, constr' :: rest' -> + let e1, e2, n = constr in let f1, f2, m = constr' in let c1 = [%compare : Exp.t * Exp.t] (e1, e2) (f1, f2) in if Int.equal c1 0 && IntLit.lt n m then combine acc_todos acc_seen constraints_new rest' @@ -163,13 +173,14 @@ end = struct else if c1 < 0 then combine (constr :: acc_todos) (constr :: acc_seen) rest constraints_old else combine acc_todos (constr' :: acc_seen) constraints_new rest' + let rec _saturate seen todos = (* seen is a superset of todos. "seen" is sorted and doesn't have redundancy. *) match todos with - | [] - -> (false, seen) - | constr :: rest - -> let inconsistent, constraints_new = generate constr [] seen in + | [] -> + (false, seen) + | constr :: rest -> + let inconsistent, constraints_new = generate constr [] seen in if inconsistent then (true, []) else let constraints_new' = sort_then_remove_redundancy constraints_new in @@ -179,46 +190,51 @@ end = struct let seen_new' = sort_then_remove_redundancy seen_new in _saturate seen_new' rest_new + let saturate constraints = let constraints_cleaned = sort_then_remove_redundancy constraints in _saturate constraints_cleaned constraints_cleaned + end (** Return true if the two types have sizes which can be compared *) let type_size_comparable t1 t2 = match (t1.Typ.desc, t2.Typ.desc) with Typ.Tint _, Typ.Tint _ -> true | _ -> false + (** Compare the size of comparable types *) let type_size_compare t1 t2 = let ik_compare ik1 ik2 = let ik_size = function - | Typ.IChar | Typ.ISChar | Typ.IUChar | Typ.IBool - -> 1 - | Typ.IShort | Typ.IUShort - -> 2 - | Typ.IInt | Typ.IUInt - -> 3 - | Typ.ILong | Typ.IULong - -> 4 - | Typ.ILongLong | Typ.IULongLong - -> 5 - | Typ.I128 | Typ.IU128 - -> 6 + | Typ.IChar | Typ.ISChar | Typ.IUChar | Typ.IBool -> + 1 + | Typ.IShort | Typ.IUShort -> + 2 + | Typ.IInt | Typ.IUInt -> + 3 + | Typ.ILong | Typ.IULong -> + 4 + | Typ.ILongLong | Typ.IULongLong -> + 5 + | Typ.I128 | Typ.IU128 -> + 6 in let n1 = ik_size ik1 in let n2 = ik_size ik2 in n1 - n2 in match (t1.Typ.desc, t2.Typ.desc) with - | Typ.Tint ik1, Typ.Tint ik2 - -> Some (ik_compare ik1 ik2) - | _ - -> None + | Typ.Tint ik1, Typ.Tint ik2 -> + Some (ik_compare ik1 ik2) + | _ -> + None + (** Check <= on the size of comparable types *) let check_type_size_leq t1 t2 = match type_size_compare t1 t2 with None -> false | Some n -> n <= 0 + (** Check < on the size of comparable types *) let check_type_size_lt t1 t2 = match type_size_compare t1 t2 with None -> false | Some n -> n < 0 @@ -281,32 +297,36 @@ end = struct let c1 = Exp.compare e1 f1 in if c1 <> 0 then c1 else Exp.compare e2 f2 + let lt_compare (e1, e2) (f1, f2) = let c2 = Exp.compare e2 f2 in if c2 <> 0 then c2 else -Exp.compare e1 f1 + let leqs_sort_then_remove_redundancy leqs = let leqs_sorted = List.sort ~cmp:leq_compare leqs in let have_same_key leq1 leq2 = match (leq1, leq2) with - | (e1, Exp.Const Const.Cint n1), (e2, Exp.Const Const.Cint n2) - -> Exp.equal e1 e2 && IntLit.leq n1 n2 - | _, _ - -> false + | (e1, Exp.Const Const.Cint n1), (e2, Exp.Const Const.Cint n2) -> + Exp.equal e1 e2 && IntLit.leq n1 n2 + | _, _ -> + false in remove_redundancy have_same_key [] leqs_sorted + let lts_sort_then_remove_redundancy lts = let lts_sorted = List.sort ~cmp:lt_compare lts in let have_same_key lt1 lt2 = match (lt1, lt2) with - | (Exp.Const Const.Cint n1, e1), (Exp.Const Const.Cint n2, e2) - -> Exp.equal e1 e2 && IntLit.geq n1 n2 - | _, _ - -> false + | (Exp.Const Const.Cint n1, e1), (Exp.Const Const.Cint n2, e2) -> + Exp.equal e1 e2 && IntLit.geq n1 n2 + | _, _ -> + false in remove_redundancy have_same_key [] lts_sorted + let saturate {leqs; lts; neqs} = let diff_constraints1 = List.fold ~f:DiffConstr.from_lt ~init:(List.fold ~f:DiffConstr.from_leq ~init:[] leqs) lts @@ -327,26 +347,26 @@ end = struct with Not_found -> Exp.Map.add e new_lower lmap in let rec umap_create_from_leqs umap = function - | [] - -> umap - | (e1, Exp.Const Const.Cint upper1) :: leqs_rest - -> let umap' = umap_add umap e1 upper1 in + | [] -> + umap + | (e1, Exp.Const Const.Cint upper1) :: leqs_rest -> + let umap' = umap_add umap e1 upper1 in umap_create_from_leqs umap' leqs_rest - | _ :: leqs_rest - -> umap_create_from_leqs umap leqs_rest + | _ :: leqs_rest -> + umap_create_from_leqs umap leqs_rest in let rec lmap_create_from_lts lmap = function - | [] - -> lmap - | (Exp.Const Const.Cint lower1, e1) :: lts_rest - -> let lmap' = lmap_add lmap e1 lower1 in + | [] -> + lmap + | (Exp.Const Const.Cint lower1, e1) :: lts_rest -> + let lmap' = lmap_add lmap e1 lower1 in lmap_create_from_lts lmap' lts_rest - | _ :: lts_rest - -> lmap_create_from_lts lmap lts_rest + | _ :: lts_rest -> + lmap_create_from_lts lmap lts_rest in let rec umap_improve_by_difference_constraints umap = function - | [] - -> umap + | [] -> + umap | constr :: constrs_rest -> try let e1, e2, n = DiffConstr.to_triple constr (* e1 - e2 <= n *) in @@ -357,8 +377,8 @@ end = struct with Not_found -> umap_improve_by_difference_constraints umap constrs_rest in let rec lmap_improve_by_difference_constraints lmap = function - | [] - -> lmap + | [] -> + lmap | constr :: constrs_rest -> (* e2 - e1 > -n-1 *) try @@ -387,6 +407,7 @@ end = struct in {leqs= leqs_res; lts= lts_res; neqs} + (** Extract inequalities and disequalities from [pi] *) let from_pi pi = let leqs = ref [] in @@ -396,44 +417,45 @@ end = struct let neqs = ref [] in (* != facts *) let process_atom = function - | Sil.Aneq (e1, e2) - -> (* != *) + | Sil.Aneq (e1, e2) -> + (* != *) neqs := (e1, e2) :: !neqs - | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i - -> leqs := (e1, e2) :: !leqs (* <= *) - | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i - -> lts := (e1, e2) :: !lts (* < *) - | Sil.Aeq _ | Sil.Apred _ | Anpred _ - -> () + | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i -> + leqs := (e1, e2) :: !leqs (* <= *) + | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i -> + lts := (e1, e2) :: !lts (* < *) + | Sil.Aeq _ | Sil.Apred _ | Anpred _ -> + () in List.iter ~f:process_atom pi ; saturate {leqs= !leqs; lts= !lts; neqs= !neqs} + let from_sigma tenv sigma = let lookup = Tenv.lookup tenv in let leqs = ref [] in let lts = ref [] in let add_lt_minus1_e e = lts := (Exp.minus_one, e) :: !lts in let type_opt_is_unsigned = function - | Some {Typ.desc= Tint ik} - -> Typ.ikind_is_unsigned ik - | _ - -> false + | Some {Typ.desc= Tint ik} -> + Typ.ikind_is_unsigned ik + | _ -> + false in let type_of_texp = function Exp.Sizeof {typ} -> Some typ | _ -> None in let texp_is_unsigned texp = type_opt_is_unsigned @@ type_of_texp texp in let strexp_lt_minus1 = function Sil.Eexp (e, _) -> add_lt_minus1_e e | _ -> () in let rec strexp_extract = function - | Sil.Eexp (e, _), t - -> if type_opt_is_unsigned t then add_lt_minus1_e e - | Sil.Estruct (fsel, _), t - -> let get_field_type f = + | Sil.Eexp (e, _), t -> + if type_opt_is_unsigned t then add_lt_minus1_e e + | Sil.Estruct (fsel, _), t -> + let get_field_type f = Option.bind t ~f:(fun t' -> Option.map ~f:fst @@ Typ.Struct.get_field_type_and_annotation ~lookup f t' ) in List.iter ~f:(fun (f, se) -> strexp_extract (se, get_field_type f)) fsel - | Sil.Earray (len, isel, _), t - -> let elt_t = match t with Some {Typ.desc= Tarray (t, _, _)} -> Some t | _ -> None in + | Sil.Earray (len, isel, _), t -> + let elt_t = match t with Some {Typ.desc= Tarray (t, _, _)} -> Some t | _ -> None in add_lt_minus1_e len ; List.iter ~f:(fun (idx, se) -> @@ -442,21 +464,23 @@ end = struct isel in let hpred_extract = function - | Sil.Hpointsto (_, se, texp) - -> if texp_is_unsigned texp then strexp_lt_minus1 se ; + | Sil.Hpointsto (_, se, texp) -> + if texp_is_unsigned texp then strexp_lt_minus1 se ; strexp_extract (se, type_of_texp texp) - | Sil.Hlseg _ | Sil.Hdllseg _ - -> () + | Sil.Hlseg _ | Sil.Hdllseg _ -> + () in List.iter ~f:hpred_extract sigma ; saturate {leqs= !leqs; lts= !lts; neqs= []} + let join ineq1 ineq2 = let leqs_new = ineq1.leqs @ ineq2.leqs in let lts_new = ineq1.lts @ ineq2.lts in let neqs_new = ineq1.neqs @ ineq2.neqs in saturate {leqs= leqs_new; lts= lts_new; neqs= neqs_new} + let from_prop tenv prop = let sigma = prop.Prop.sigma in let pi = prop.Prop.pi in @@ -464,6 +488,7 @@ end = struct let ineq_pi = from_pi pi in saturate (join ineq_sigma ineq_pi) + (** Return true if the two pairs of expressions are equal *) let exp_pair_eq (e1, e2) (f1, f2) = Exp.equal e1 f1 && Exp.equal e2 f2 @@ -471,70 +496,73 @@ end = struct let check_le {leqs; lts; neqs= _} e1 e2 = (* L.d_str "check_le "; Sil.d_exp e1; L.d_str " "; Sil.d_exp e2; L.d_ln (); *) match (e1, e2) with - | Exp.Const Const.Cint n1, Exp.Const Const.Cint n2 - -> IntLit.leq n1 n2 + | Exp.Const Const.Cint n1, Exp.Const Const.Cint n2 -> + IntLit.leq n1 n2 | ( Exp.BinOp (Binop.MinusA, Exp.Sizeof {nbytes= Some nb1}, Exp.Sizeof {nbytes= Some nb2}) - , Exp.Const Const.Cint n2 ) - -> (* [ sizeof(t1) - sizeof(t2) <= n2 ] *) + , Exp.Const Const.Cint n2 ) -> + (* [ sizeof(t1) - sizeof(t2) <= n2 ] *) IntLit.(leq (sub (of_int nb1) (of_int nb2)) n2) | Exp.BinOp (Binop.MinusA, Exp.Sizeof {typ= t1}, Exp.Sizeof {typ= t2}), Exp.Const Const.Cint n2 - when IntLit.isminusone n2 && type_size_comparable t1 t2 - -> (* [ sizeof(t1) - sizeof(t2) <= -1 ] *) + when IntLit.isminusone n2 && type_size_comparable t1 t2 -> + (* [ sizeof(t1) - sizeof(t2) <= -1 ] *) check_type_size_lt t1 t2 - | e, Exp.Const Const.Cint n - -> (* [e <= n' <= n |- e <= n] *) + | e, Exp.Const Const.Cint n -> + (* [e <= n' <= n |- e <= n] *) List.exists ~f:(function | e', Exp.Const Const.Cint n' -> Exp.equal e e' && IntLit.leq n' n | _, _ -> false) leqs - | Exp.Const Const.Cint n, e - -> (* [ n-1 <= n' < e |- n <= e] *) + | Exp.Const Const.Cint n, e -> + (* [ n-1 <= n' < e |- n <= e] *) List.exists ~f:(function - | Exp.Const Const.Cint n', e' - -> Exp.equal e e' && IntLit.leq (n -- IntLit.one) n' - | _, _ - -> false) + | Exp.Const Const.Cint n', e' -> + Exp.equal e e' && IntLit.leq (n -- IntLit.one) n' + | _, _ -> + false) lts - | _ - -> Exp.equal e1 e2 + | _ -> + Exp.equal e1 e2 + (** Check [prop |- e1 IntLit.lt n1 n2 - | Exp.Const Const.Cint n, e - -> (* [n <= n' < e |- n < e] *) + | Exp.Const Const.Cint n1, Exp.Const Const.Cint n2 -> + IntLit.lt n1 n2 + | Exp.Const Const.Cint n, e -> + (* [n <= n' < e |- n < e] *) List.exists ~f:(function | Exp.Const Const.Cint n', e' -> Exp.equal e e' && IntLit.leq n n' | _, _ -> false) lts - | e, Exp.Const Const.Cint n - -> (* [e <= n' <= n-1 |- e < n] *) + | e, Exp.Const Const.Cint n -> + (* [e <= n' <= n-1 |- e < n] *) List.exists ~f:(function - | e', Exp.Const Const.Cint n' - -> Exp.equal e e' && IntLit.leq n' (n -- IntLit.one) - | _, _ - -> false) + | e', Exp.Const Const.Cint n' -> + Exp.equal e e' && IntLit.leq n' (n -- IntLit.one) + | _, _ -> + false) leqs - | _ - -> false + | _ -> + false + (** Check [prop |- e1!=e2]. Result [false] means "don't know". *) let check_ne ineq _e1 _e2 = let e1, e2 = if Exp.compare _e1 _e2 <= 0 then (_e1, _e2) else (_e2, _e1) in List.exists ~f:(exp_pair_eq (e1, e2)) ineq.neqs || check_lt ineq e1 e2 || check_lt ineq e2 e1 + (** Find a IntLit.t n such that [t |- e<=n] if possible. *) let compute_upper_bound {leqs; lts= _; neqs= _} e1 = match e1 with - | Exp.Const Const.Cint n1 - -> Some n1 - | _ - -> let e_upper_list = + | Exp.Const Const.Cint n1 -> + Some n1 + | _ -> + let e_upper_list = List.filter ~f:(function e', Exp.Const Const.Cint _ -> Exp.equal e1 e' | _, _ -> false) leqs @@ -545,17 +573,18 @@ end = struct if List.is_empty upper_list then None else Some (compute_min_from_nonempty_int_list upper_list) + (** Find a IntLit.t n such that [t |- n < e] if possible. *) let compute_lower_bound {leqs= _; lts; neqs= _} e1 = match e1 with - | Exp.Const Const.Cint n1 - -> Some (n1 -- IntLit.one) - | Exp.Sizeof {nbytes= Some n1} - -> Some (IntLit.of_int n1 -- IntLit.one) - | Exp.Sizeof _ - -> Some IntLit.zero - | _ - -> let e_lower_list = + | Exp.Const Const.Cint n1 -> + Some (n1 -- IntLit.one) + | Exp.Sizeof {nbytes= Some n1} -> + Some (IntLit.of_int n1 -- IntLit.one) + | Exp.Sizeof _ -> + Some IntLit.zero + | _ -> + let e_lower_list = List.filter ~f:(function Exp.Const Const.Cint _, e' -> Exp.equal e1 e' | _, _ -> false) lts @@ -566,6 +595,7 @@ end = struct if List.is_empty lower_list then None else Some (compute_max_from_nonempty_int_list lower_list) + (** Return [true] if a simple inconsistency is detected *) let inconsistent ({leqs; lts; neqs} as ineq) = let inconsistent_neq (e1, e2) = check_le ineq e1 e2 && check_le ineq e2 e1 in @@ -574,6 +604,7 @@ end = struct List.exists ~f:inconsistent_neq neqs || List.exists ~f:inconsistent_leq leqs || List.exists ~f:inconsistent_lt lts + (* (** Pretty print inequalities and disequalities *) let pp pe fmt { leqs = leqs; lts = lts; neqs = neqs } = @@ -606,14 +637,14 @@ let check_equal tenv prop e1_0 e2_0 = let check_equal_const () = match (n_e1, n_e2) with | Exp.BinOp (Binop.PlusA, e1, Exp.Const Const.Cint d), e2 - | e2, Exp.BinOp (Binop.PlusA, e1, Exp.Const Const.Cint d) - -> if Exp.equal e1 e2 then IntLit.iszero d else false - | Exp.Const c1, Exp.Lindex (Exp.Const c2, Exp.Const Const.Cint i) when IntLit.iszero i - -> Const.equal c1 c2 - | Exp.Lindex (Exp.Const c1, Exp.Const Const.Cint i), Exp.Const c2 when IntLit.iszero i - -> Const.equal c1 c2 - | _, _ - -> false + | e2, Exp.BinOp (Binop.PlusA, e1, Exp.Const Const.Cint d) -> + if Exp.equal e1 e2 then IntLit.iszero d else false + | Exp.Const c1, Exp.Lindex (Exp.Const c2, Exp.Const Const.Cint i) when IntLit.iszero i -> + Const.equal c1 c2 + | Exp.Lindex (Exp.Const c1, Exp.Const Const.Cint i), Exp.Const c2 when IntLit.iszero i -> + Const.equal c1 c2 + | _, _ -> + false in let check_equal_pi () = let eq = Sil.Aeq (n_e1, n_e2) in @@ -623,6 +654,7 @@ let check_equal tenv prop e1_0 e2_0 = in check_equal () || check_equal_const () || check_equal_pi () + (** Check [ |- e=0]. Result [false] means "don't know". *) let check_zero tenv e = check_equal tenv Prop.prop_emp e Exp.zero @@ -641,28 +673,29 @@ let is_root tenv prop base_exp exp = | Exp.Exn _ | Exp.Closure _ | Exp.Lvar _ - | Exp.Sizeof _ - -> if check_equal tenv prop base_exp e then Some offlist_past else None - | Exp.Cast (_, sub_exp) - -> f offlist_past sub_exp - | Exp.Lfield (sub_exp, fldname, typ) - -> f (Sil.Off_fld (fldname, typ) :: offlist_past) sub_exp - | Exp.Lindex (sub_exp, e) - -> f (Sil.Off_index e :: offlist_past) sub_exp + | Exp.Sizeof _ -> + if check_equal tenv prop base_exp e then Some offlist_past else None + | Exp.Cast (_, sub_exp) -> + f offlist_past sub_exp + | Exp.Lfield (sub_exp, fldname, typ) -> + f (Sil.Off_fld (fldname, typ) :: offlist_past) sub_exp + | Exp.Lindex (sub_exp, e) -> + f (Sil.Off_index e :: offlist_past) sub_exp in f [] exp + (** Get upper and lower bounds of an expression, if any *) let get_bounds tenv prop e0 = let e_norm = Prop.exp_normalize_prop ~destructive:true tenv prop e0 in let e_root, off = match e_norm with - | Exp.BinOp (Binop.PlusA, e, Exp.Const Const.Cint n1) - -> (e, IntLit.neg n1) - | Exp.BinOp (Binop.MinusA, e, Exp.Const Const.Cint n1) - -> (e, n1) - | _ - -> (e_norm, IntLit.zero) + | Exp.BinOp (Binop.PlusA, e, Exp.Const Const.Cint n1) -> + (e, IntLit.neg n1) + | Exp.BinOp (Binop.MinusA, e, Exp.Const Const.Cint n1) -> + (e, n1) + | _ -> + (e_norm, IntLit.zero) in let ineq = Inequalities.from_prop tenv prop in let upper_opt = Inequalities.compute_upper_bound ineq e_root in @@ -670,6 +703,7 @@ let get_bounds tenv prop e0 = let ( +++ ) n_opt k = match n_opt with None -> None | Some n -> Some (n ++ k) in (upper_opt +++ off, lower_opt +++ off) + (** Check whether [prop |- e1!=e2]. *) let check_disequal tenv prop e1 e2 = let spatial_part = prop.Prop.sigma in @@ -677,67 +711,67 @@ let check_disequal tenv prop e1 e2 = let n_e2 = Prop.exp_normalize_prop ~destructive:true tenv prop e2 in let rec check_expr_disequal ce1 ce2 = match (ce1, ce2) with - | Exp.Const c1, Exp.Const c2 - -> Const.kind_equal c1 c2 && not (Const.equal c1 c2) - | Exp.Const c1, Exp.Lindex (Exp.Const c2, Exp.Const Const.Cint d) - -> if IntLit.iszero d then not (Const.equal c1 c2) (* offset=0 is no offset *) + | Exp.Const c1, Exp.Const c2 -> + Const.kind_equal c1 c2 && not (Const.equal c1 c2) + | Exp.Const c1, Exp.Lindex (Exp.Const c2, Exp.Const Const.Cint d) -> + if IntLit.iszero d then not (Const.equal c1 c2) (* offset=0 is no offset *) else Const.equal c1 c2 (* same base, different offsets *) | ( Exp.BinOp (Binop.PlusA, e1, Exp.Const Const.Cint d1) - , Exp.BinOp (Binop.PlusA, e2, Exp.Const Const.Cint d2) ) - -> if Exp.equal e1 e2 then IntLit.neq d1 d2 else false + , Exp.BinOp (Binop.PlusA, e2, Exp.Const Const.Cint d2) ) -> + if Exp.equal e1 e2 then IntLit.neq d1 d2 else false | Exp.BinOp (Binop.PlusA, e1, Exp.Const Const.Cint d), e2 - | e2, Exp.BinOp (Binop.PlusA, e1, Exp.Const Const.Cint d) - -> if Exp.equal e1 e2 then not (IntLit.iszero d) else false - | Exp.Lindex (Exp.Const c1, Exp.Const Const.Cint d), Exp.Const c2 - -> if IntLit.iszero d then not (Const.equal c1 c2) else Const.equal c1 c2 - | Exp.Lindex (Exp.Const c1, Exp.Const d1), Exp.Lindex (Exp.Const c2, Exp.Const d2) - -> Const.equal c1 c2 && not (Const.equal d1 d2) + | e2, Exp.BinOp (Binop.PlusA, e1, Exp.Const Const.Cint d) -> + if Exp.equal e1 e2 then not (IntLit.iszero d) else false + | Exp.Lindex (Exp.Const c1, Exp.Const Const.Cint d), Exp.Const c2 -> + if IntLit.iszero d then not (Const.equal c1 c2) else Const.equal c1 c2 + | Exp.Lindex (Exp.Const c1, Exp.Const d1), Exp.Lindex (Exp.Const c2, Exp.Const d2) -> + Const.equal c1 c2 && not (Const.equal d1 d2) | Exp.Const Const.Cint n, Exp.BinOp (Binop.Mult, Exp.Sizeof _, e21) | Exp.Const Const.Cint n, Exp.BinOp (Binop.Mult, e21, Sizeof _) | Exp.BinOp (Binop.Mult, Exp.Sizeof _, e21), Exp.Const Const.Cint n - | Exp.BinOp (Binop.Mult, e21, Exp.Sizeof _), Exp.Const Const.Cint n - -> IntLit.iszero n && not (Exp.is_zero e21) - | Exp.Lvar pv0, Exp.Lvar pv1 - -> (* Addresses of any two local vars must be different *) + | Exp.BinOp (Binop.Mult, e21, Exp.Sizeof _), Exp.Const Const.Cint n -> + IntLit.iszero n && not (Exp.is_zero e21) + | Exp.Lvar pv0, Exp.Lvar pv1 -> + (* Addresses of any two local vars must be different *) not (Pvar.equal pv0 pv1) - | Exp.Lvar pv, Exp.Var id | Exp.Var id, Exp.Lvar pv - -> (* Address of any non-global var must be different from the value of any footprint var *) + | Exp.Lvar pv, Exp.Var id | Exp.Var id, Exp.Lvar pv -> + (* Address of any non-global var must be different from the value of any footprint var *) not (Pvar.is_global pv) && Ident.is_footprint id - | Exp.Lvar _, Exp.Const Const.Cint _ | Exp.Const Const.Cint _, Exp.Lvar _ - -> (* Comparing pointer with nonzero integer is undefined behavior in ISO C++ *) + | Exp.Lvar _, Exp.Const Const.Cint _ | Exp.Const Const.Cint _, Exp.Lvar _ -> + (* Comparing pointer with nonzero integer is undefined behavior in ISO C++ *) (* Assume they are not equal *) true - | Exp.UnOp (op1, e1, _), Exp.UnOp (op2, e2, _) - -> if Unop.equal op1 op2 then check_expr_disequal e1 e2 else false - | Exp.Lfield (e1, f1, _), Exp.Lfield (e2, f2, _) - -> if Typ.Fieldname.equal f1 f2 then check_expr_disequal e1 e2 else false - | Exp.Exn e1, Exp.Exn e2 - -> check_expr_disequal e1 e2 - | _, _ - -> false + | Exp.UnOp (op1, e1, _), Exp.UnOp (op2, e2, _) -> + if Unop.equal op1 op2 then check_expr_disequal e1 e2 else false + | Exp.Lfield (e1, f1, _), Exp.Lfield (e2, f2, _) -> + if Typ.Fieldname.equal f1 f2 then check_expr_disequal e1 e2 else false + | Exp.Exn e1, Exp.Exn e2 -> + check_expr_disequal e1 e2 + | _, _ -> + false in - let ineq = (lazy (Inequalities.from_prop tenv prop)) in + let ineq = lazy (Inequalities.from_prop tenv prop) in let check_pi_implies_disequal e1 e2 = Inequalities.check_ne (Lazy.force ineq) e1 e2 in let neq_spatial_part () = let rec f sigma_irrelevant e = function - | [] - -> None + | [] -> + None | (Sil.Hpointsto (base, _, _) as hpred) :: sigma_rest -> ( match is_root tenv prop base e with - | None - -> let sigma_irrelevant' = hpred :: sigma_irrelevant in + | None -> + let sigma_irrelevant' = hpred :: sigma_irrelevant in f sigma_irrelevant' e sigma_rest - | Some _ - -> let sigma_irrelevant' = List.rev_append sigma_irrelevant sigma_rest in + | Some _ -> + let sigma_irrelevant' = List.rev_append sigma_irrelevant sigma_rest in Some (true, sigma_irrelevant') ) | (Sil.Hlseg (k, _, e1, e2, _) as hpred) :: sigma_rest -> ( match is_root tenv prop e1 e with - | None - -> let sigma_irrelevant' = hpred :: sigma_irrelevant in + | None -> + let sigma_irrelevant' = hpred :: sigma_irrelevant in f sigma_irrelevant' e sigma_rest - | Some _ - -> if Sil.equal_lseg_kind k Sil.Lseg_NE || check_pi_implies_disequal e1 e2 then + | Some _ -> + if Sil.equal_lseg_kind k Sil.Lseg_NE || check_pi_implies_disequal e1 e2 then let sigma_irrelevant' = List.rev_append sigma_irrelevant sigma_rest in Some (true, sigma_irrelevant') else if Exp.equal e2 Exp.zero then @@ -746,8 +780,8 @@ let check_disequal tenv prop e1 e2 = else let sigma_rest' = List.rev_append sigma_irrelevant sigma_rest in f [] e2 sigma_rest' ) - | (Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _)) :: sigma_rest - -> if is_root tenv prop iF e <> None || is_root tenv prop iB e <> None then + | (Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _)) :: sigma_rest -> + if is_root tenv prop iF e <> None || is_root tenv prop iB e <> None then let sigma_irrelevant' = List.rev_append sigma_irrelevant sigma_rest in Some (true, sigma_irrelevant') else @@ -755,11 +789,11 @@ let check_disequal tenv prop e1 e2 = Some (false, sigma_irrelevant') | (Sil.Hdllseg (Sil.Lseg_PE, _, iF, _, oF, _, _) as hpred) :: sigma_rest -> match is_root tenv prop iF e with - | None - -> let sigma_irrelevant' = hpred :: sigma_irrelevant in + | None -> + let sigma_irrelevant' = hpred :: sigma_irrelevant in f sigma_irrelevant' e sigma_rest - | Some _ - -> if check_pi_implies_disequal iF oF then + | Some _ -> + if check_pi_implies_disequal iF oF then let sigma_irrelevant' = List.rev_append sigma_irrelevant sigma_rest in Some (true, sigma_irrelevant') else if Exp.equal oF Exp.zero then @@ -776,41 +810,43 @@ let check_disequal tenv prop e1 e2 = Some (false, sigma_irrelevant') in match f_null_check [] n_e1 spatial_part with - | None - -> false + | None -> + false | Some (e1_allocated, spatial_part_leftover) -> match f_null_check [] n_e2 spatial_part_leftover with - | None - -> false - | Some ((e2_allocated: bool), _) - -> e1_allocated || e2_allocated + | None -> + false + | Some ((e2_allocated: bool), _) -> + e1_allocated || e2_allocated in let check_disequal_expr () = check_expr_disequal n_e1 n_e2 in let neq_pure_part () = check_pi_implies_disequal n_e1 n_e2 in check_disequal_expr () || neq_pure_part () || neq_spatial_part () + (** Check [prop |- e1<=e2], to be called from normalized atom *) let check_le_normalized tenv prop e1 e2 = (* L.d_str "check_le_normalized "; Sil.d_exp e1; L.d_str " "; Sil.d_exp e2; L.d_ln (); *) let eL, eR, off = match (e1, e2) with - | Exp.BinOp (Binop.MinusA, f1, f2), Exp.Const Const.Cint n - -> if Exp.equal f1 f2 then (Exp.zero, Exp.zero, n) else (f1, f2, n) - | _ - -> (e1, e2, IntLit.zero) + | Exp.BinOp (Binop.MinusA, f1, f2), Exp.Const Const.Cint n -> + if Exp.equal f1 f2 then (Exp.zero, Exp.zero, n) else (f1, f2, n) + | _ -> + (e1, e2, IntLit.zero) in let ineq = Inequalities.from_prop tenv prop in let upper_lower_check () = let upperL_opt = Inequalities.compute_upper_bound ineq eL in let lowerR_opt = Inequalities.compute_lower_bound ineq eR in match (upperL_opt, lowerR_opt) with - | None, _ | _, None - -> false - | Some upper1, Some lower2 - -> IntLit.leq upper1 (lower2 ++ IntLit.one ++ off) + | None, _ | _, None -> + false + | Some upper1, Some lower2 -> + IntLit.leq upper1 (lower2 ++ IntLit.one ++ off) in upper_lower_check () || Inequalities.check_le ineq e1 e2 || check_equal tenv prop e1 e2 + (** Check [prop |- e1 false - | Some upper1, Some lower2 - -> IntLit.leq upper1 lower2 + | None, _ | _, None -> + false + | Some upper1, Some lower2 -> + IntLit.leq upper1 lower2 in upper_lower_check () || Inequalities.check_lt ineq e1 e2 + (** Given an atom and a proposition returns a unique identifier. We use this to distinguish among different queries. *) let get_smt_key a p = @@ -836,6 +873,7 @@ let get_smt_key a p = Out_channel.close outc_tmp ; Digest.to_hex (Digest.file tmp_filename) + (** Check whether [prop |- a]. False means dont know. *) let check_atom tenv prop a0 = let a = Prop.atom_normalize_prop tenv prop a0 in @@ -844,7 +882,7 @@ let check_atom tenv prop a0 = let key = get_smt_key a prop_no_fp in let key_filename = let source = (State.get_loc ()).file in - DB.Results_dir.path_to_filename (DB.Results_dir.Abs_source_dir source) [(key ^ ".cns")] + DB.Results_dir.path_to_filename (DB.Results_dir.Abs_source_dir source) [key ^ ".cns"] in let outc = Out_channel.create (DB.filename_to_string key_filename) in let fmt = F.formatter_of_out_channel outc in @@ -862,62 +900,66 @@ let check_atom tenv prop a0 = (Prop.pp_prop Pp.text) prop_no_fp ; Out_channel.close outc ) ; match a with - | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i - -> check_le_normalized tenv prop e1 e2 - | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i - -> check_lt_normalized tenv prop e1 e2 - | Sil.Aeq (e1, e2) - -> check_equal tenv prop e1 e2 - | Sil.Aneq (e1, e2) - -> check_disequal tenv prop e1 e2 - | Sil.Apred _ | Anpred _ - -> List.exists ~f:(Sil.equal_atom a) prop.Prop.pi + | Sil.Aeq (Exp.BinOp (Binop.Le, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i -> + check_le_normalized tenv prop e1 e2 + | Sil.Aeq (Exp.BinOp (Binop.Lt, e1, e2), Exp.Const Const.Cint i) when IntLit.isone i -> + check_lt_normalized tenv prop e1 e2 + | Sil.Aeq (e1, e2) -> + check_equal tenv prop e1 e2 + | Sil.Aneq (e1, e2) -> + check_disequal tenv prop e1 e2 + | Sil.Apred _ | Anpred _ -> + List.exists ~f:(Sil.equal_atom a) prop.Prop.pi + (** Check [prop |- e1<=e2]. Result [false] means "don't know". *) let check_le tenv prop e1 e2 = let e1_le_e2 = Exp.BinOp (Binop.Le, e1, e2) in check_atom tenv prop (Prop.mk_inequality tenv e1_le_e2) + (** Check whether [prop |- allocated(e)]. *) let check_allocatedness tenv prop e = let n_e = Prop.exp_normalize_prop ~destructive:true tenv prop e in let spatial_part = prop.Prop.sigma in let f = function - | Sil.Hpointsto (base, _, _) - -> is_root tenv prop base n_e <> None - | Sil.Hlseg (k, _, e1, e2, _) - -> if Sil.equal_lseg_kind k Sil.Lseg_NE || check_disequal tenv prop e1 e2 then + | Sil.Hpointsto (base, _, _) -> + is_root tenv prop base n_e <> None + | Sil.Hlseg (k, _, e1, e2, _) -> + if Sil.equal_lseg_kind k Sil.Lseg_NE || check_disequal tenv prop e1 e2 then is_root tenv prop e1 n_e <> None else false - | Sil.Hdllseg (k, _, iF, oB, oF, iB, _) - -> if Sil.equal_lseg_kind k Sil.Lseg_NE || check_disequal tenv prop iF oF + | Sil.Hdllseg (k, _, iF, oB, oF, iB, _) -> + if Sil.equal_lseg_kind k Sil.Lseg_NE || check_disequal tenv prop iF oF || check_disequal tenv prop iB oB then is_root tenv prop iF n_e <> None || is_root tenv prop iB n_e <> None else false in List.exists ~f spatial_part + (** Compute an upper bound of an expression *) let compute_upper_bound_of_exp tenv p e = let ineq = Inequalities.from_prop tenv p in Inequalities.compute_upper_bound ineq e + (** Check if two hpreds have the same allocated lhs *) let check_inconsistency_two_hpreds tenv prop = let sigma = prop.Prop.sigma in let rec f e sigma_seen = function - | [] - -> false + | [] -> + false | (Sil.Hpointsto (e1, _, _) as hpred) :: sigma_rest - | (Sil.Hlseg (Sil.Lseg_NE, _, e1, _, _) as hpred) :: sigma_rest - -> if Exp.equal e1 e then true else f e (hpred :: sigma_seen) sigma_rest - | (Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) as hpred) :: sigma_rest - -> if Exp.equal iF e || Exp.equal iB e then true else f e (hpred :: sigma_seen) sigma_rest + | (Sil.Hlseg (Sil.Lseg_NE, _, e1, _, _) as hpred) :: sigma_rest -> + if Exp.equal e1 e then true else f e (hpred :: sigma_seen) sigma_rest + | (Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) as hpred) :: sigma_rest -> + if Exp.equal iF e || Exp.equal iB e then true else f e (hpred :: sigma_seen) sigma_rest | (Sil.Hlseg (Sil.Lseg_PE, _, e1, Exp.Const Const.Cint i, _) as hpred) :: sigma_rest - when IntLit.iszero i - -> if Exp.equal e1 e then true else f e (hpred :: sigma_seen) sigma_rest - | (Sil.Hlseg (Sil.Lseg_PE, _, e1, e2, _) as hpred) :: sigma_rest - -> if Exp.equal e1 e then + when IntLit.iszero i -> + if Exp.equal e1 e then true else f e (hpred :: sigma_seen) sigma_rest + | (Sil.Hlseg (Sil.Lseg_PE, _, e1, e2, _) as hpred) :: sigma_rest -> + if Exp.equal e1 e then let prop' = Prop.normalize tenv (Prop.from_sigma (sigma_seen @ sigma_rest)) in let prop_new = Prop.conjoin_eq tenv e1 e2 prop' in let sigma_new = prop_new.Prop.sigma in @@ -925,10 +967,10 @@ let check_inconsistency_two_hpreds tenv prop = f e_new [] sigma_new else f e (hpred :: sigma_seen) sigma_rest | (Sil.Hdllseg (Sil.Lseg_PE, _, e1, _, Exp.Const Const.Cint i, _, _) as hpred) :: sigma_rest - when IntLit.iszero i - -> if Exp.equal e1 e then true else f e (hpred :: sigma_seen) sigma_rest - | (Sil.Hdllseg (Sil.Lseg_PE, _, e1, _, e3, _, _) as hpred) :: sigma_rest - -> if Exp.equal e1 e then + when IntLit.iszero i -> + if Exp.equal e1 e then true else f e (hpred :: sigma_seen) sigma_rest + | (Sil.Hdllseg (Sil.Lseg_PE, _, e1, _, e3, _, _) as hpred) :: sigma_rest -> + if Exp.equal e1 e then let prop' = Prop.normalize tenv (Prop.from_sigma (sigma_seen @ sigma_rest)) in let prop_new = Prop.conjoin_eq tenv e1 e3 prop' in let sigma_new = prop_new.Prop.sigma in @@ -937,20 +979,21 @@ let check_inconsistency_two_hpreds tenv prop = else f e (hpred :: sigma_seen) sigma_rest in let rec check sigma_seen = function - | [] - -> false + | [] -> + false | (Sil.Hpointsto (e1, _, _) as hpred) :: sigma_rest - | (Sil.Hlseg (Sil.Lseg_NE, _, e1, _, _) as hpred) :: sigma_rest - -> if f e1 [] (sigma_seen @ sigma_rest) then true else check (hpred :: sigma_seen) sigma_rest - | (Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) as hpred) :: sigma_rest - -> if f iF [] (sigma_seen @ sigma_rest) || f iB [] (sigma_seen @ sigma_rest) then true + | (Sil.Hlseg (Sil.Lseg_NE, _, e1, _, _) as hpred) :: sigma_rest -> + if f e1 [] (sigma_seen @ sigma_rest) then true else check (hpred :: sigma_seen) sigma_rest + | (Sil.Hdllseg (Sil.Lseg_NE, _, iF, _, _, iB, _) as hpred) :: sigma_rest -> + if f iF [] (sigma_seen @ sigma_rest) || f iB [] (sigma_seen @ sigma_rest) then true else check (hpred :: sigma_seen) sigma_rest | (Sil.Hlseg (Sil.Lseg_PE, _, _, _, _) as hpred) :: sigma_rest - | (Sil.Hdllseg (Sil.Lseg_PE, _, _, _, _, _, _) as hpred) :: sigma_rest - -> check (hpred :: sigma_seen) sigma_rest + | (Sil.Hdllseg (Sil.Lseg_PE, _, _, _, _, _, _) as hpred) :: sigma_rest -> + check (hpred :: sigma_seen) sigma_rest in check [] sigma + (** Inconsistency checking ignoring footprint. *) let check_inconsistency_base tenv prop = let pi = prop.Prop.pi in @@ -958,10 +1001,10 @@ let check_inconsistency_base tenv prop = let inconsistent_ptsto _ = check_allocatedness tenv prop Exp.zero in let inconsistent_this_self_var () = match State.get_prop_tenv_pdesc () with - | None - -> false - | Some (_, _, pdesc) - -> let procedure_attr = Procdesc.get_attributes pdesc in + | None -> + false + | Some (_, _, pdesc) -> + let procedure_attr = Procdesc.get_attributes pdesc in let is_java_this pvar = Config.equal_language procedure_attr.ProcAttributes.language Config.Java && Pvar.is_this pvar @@ -976,25 +1019,25 @@ let check_inconsistency_base tenv prop = && Pvar.is_this pvar && procedure_attr.ProcAttributes.is_cpp_instance_method in let do_hpred = function - | Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (e, _), _) - -> Exp.equal e Exp.zero && Pvar.is_seed pv + | Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (e, _), _) -> + Exp.equal e Exp.zero && Pvar.is_seed pv && (is_java_this pv || is_cpp_this pv || is_objc_instance_self pv) - | _ - -> false + | _ -> + false in List.exists ~f:do_hpred sigma in let inconsistent_atom = function | Sil.Aeq (e1, e2) -> ( match (e1, e2) with - | Exp.Const c1, Exp.Const c2 - -> not (Const.equal c1 c2) - | _ - -> check_disequal tenv prop e1 e2 ) + | Exp.Const c1, Exp.Const c2 -> + not (Const.equal c1 c2) + | _ -> + check_disequal tenv prop e1 e2 ) | Sil.Aneq (e1, e2) -> ( match (e1, e2) with Exp.Const c1, Exp.Const c2 -> Const.equal c1 c2 | _ -> Exp.equal e1 e2 ) - | Sil.Apred _ | Anpred _ - -> false + | Sil.Apred _ | Anpred _ -> + false in let inconsistent_inequalities () = let ineq = Inequalities.from_prop tenv prop in @@ -1011,15 +1054,18 @@ let check_inconsistency_base tenv prop = || List.exists ~f:inconsistent_atom pi || inconsistent_inequalities () || inconsistent_this_self_var () + (** Inconsistency checking. *) let check_inconsistency tenv prop = check_inconsistency_base tenv prop || check_inconsistency_base tenv (Prop.normalize tenv (Prop.extract_footprint prop)) + (** Inconsistency checking for the pi part ignoring footprint. *) let check_inconsistency_pi tenv pi = check_inconsistency_base tenv (Prop.normalize tenv (Prop.from_pi pi)) + (** {2 Abduction prover} *) type subst2 = Sil.exp_subst * Sil.exp_subst @@ -1042,6 +1088,7 @@ let d_typings typings = let d_elem (exp, texp) = Sil.d_exp exp ; L.d_str ": " ; Sil.d_texp_full texp ; L.d_str " " in List.iter ~f:d_elem typings + (** Module to encapsulate operations on the internal state of the prover *) module ProverState : sig val reset : Prop.normal Prop.t -> Prop.exposed Prop.t -> unit @@ -1118,12 +1165,14 @@ end = struct let prop_fav_len prop = let fav = Sil.fav_new () in let do_hpred = function - | Sil.Hpointsto (_, Sil.Earray ((Exp.Var _ as len), _, _), _) - -> Sil.exp_fav_add fav len - | _ - -> () + | Sil.Hpointsto (_, Sil.Earray ((Exp.Var _ as len), _, _), _) -> + Sil.exp_fav_add fav len + | _ -> + () in - List.iter ~f:do_hpred prop.Prop.sigma ; fav + List.iter ~f:do_hpred prop.Prop.sigma ; + fav + let reset lhs rhs = checks := [] ; @@ -1138,6 +1187,7 @@ end = struct missing_sigma := [] ; missing_typ := [] + let add_bounds_check bounds_check = bounds_checks := bounds_check :: !bounds_checks let add_frame_fld hpred = frame_fld := hpred :: !frame_fld @@ -1158,6 +1208,7 @@ end = struct let fav_a = Sil.atom_fav atom in Prop.atom_is_inequality atom && Sil.fav_exists fav_a (fun a -> Sil.fav_mem !fav_in_array_len a) + let get_bounds_checks () = !bounds_checks let get_frame_fld () = !frame_fld @@ -1202,12 +1253,14 @@ end = struct d_typings !missing_typ ; L.d_decrease_indent 1 ) + let d_missing sub = (* optional print of missing: if print something, prepend with newline *) if !missing_pi <> [] || !missing_sigma <> [] || !missing_fld <> [] || !missing_typ <> [] || not (Sil.is_sub_empty sub) then ( L.d_ln () ; L.d_str "[" ; _d_missing sub ; L.d_str "]" ) + let d_frame_fld () = (* optional print of frame fld: if print something, prepend with newline *) if !frame_fld <> [] then ( @@ -1218,6 +1271,7 @@ end = struct L.d_str "]" ; L.d_decrease_indent 1 ) + let d_frame_typ () = (* optional print of frame typ: if print something, prepend with newline *) if !frame_typ <> [] then ( @@ -1228,6 +1282,7 @@ end = struct L.d_str "]" ; L.d_decrease_indent 1 ) + (** Dump an implication *) let d_implication (sub1, sub2) (p1, p2) = let p1, p2 = (Prop.prop_sub sub1 p1, Prop.prop_sub sub2 p2) in @@ -1244,22 +1299,23 @@ end = struct d_frame_fld () ; d_frame_typ () + let d_implication_error (s, subs, body) = let p1, p2 = (!implication_lhs, !implication_rhs) in let d_inner () = match body with - | EXC_FALSE - -> () - | EXC_FALSE_HPRED hpred - -> L.d_str " on " ; Sil.d_hpred hpred - | EXC_FALSE_EXPS (e1, e2) - -> L.d_str " on " ; Sil.d_exp e1 ; L.d_str "," ; Sil.d_exp e2 - | EXC_FALSE_SEXPS (se1, se2) - -> L.d_str " on " ; Sil.d_sexp se1 ; L.d_str "," ; Sil.d_sexp se2 - | EXC_FALSE_ATOM a - -> L.d_str " on " ; Sil.d_atom a - | EXC_FALSE_SIGMA sigma - -> L.d_str " on " ; Prop.d_sigma sigma + | EXC_FALSE -> + () + | EXC_FALSE_HPRED hpred -> + L.d_str " on " ; Sil.d_hpred hpred + | EXC_FALSE_EXPS (e1, e2) -> + L.d_str " on " ; Sil.d_exp e1 ; L.d_str "," ; Sil.d_exp e2 + | EXC_FALSE_SEXPS (se1, se2) -> + L.d_str " on " ; Sil.d_sexp se1 ; L.d_str "," ; Sil.d_sexp se2 + | EXC_FALSE_ATOM a -> + L.d_str " on " ; Sil.d_atom a + | EXC_FALSE_SIGMA sigma -> + L.d_str " on " ; Prop.d_sigma sigma in L.d_ln () ; L.d_strln "$$$$$$$ Implication" ; @@ -1269,6 +1325,7 @@ end = struct d_inner () ; L.d_strln " returning FALSE" ; L.d_ln () + end let d_impl (s1, s2) = ProverState.d_implication (`Exp s1, `Exp s2) @@ -1276,12 +1333,14 @@ let d_impl (s1, s2) = ProverState.d_implication (`Exp s1, `Exp s2) let d_impl_err (arg1, (s1, s2), arg3) = ProverState.d_implication_error (arg1, (`Exp s1, `Exp s2), arg3) + (** extend a substitution *) let extend_sub sub v e = let new_exp_sub = Sil.exp_subst_of_list [(v, e)] in let new_sub = `Exp new_exp_sub in Sil.sub_join new_exp_sub (Sil.sub_range_map (Sil.exp_sub new_sub) sub) + (** Extend [sub1] and [sub2] to witnesses that each instance of [e1[sub1]] is an instance of [e2[sub2]]. Raise IMPL_FALSE if not possible. *) @@ -1290,19 +1349,19 @@ let exp_imply tenv calc_missing (subs: subst2) e1_in e2_in : subst2 = let e2 = Prop.exp_normalize_noabs tenv (`Exp (snd subs)) e2_in in let var_imply (subs: subst2) v1 v2 : subst2 = match (Ident.is_primed v1, Ident.is_primed v2) with - | false, false - -> if Ident.equal v1 v2 then subs + | false, false -> + if Ident.equal v1 v2 then subs else if calc_missing && Ident.is_footprint v1 && Ident.is_footprint v2 then let () = ProverState.add_missing_pi (Sil.Aeq (e1_in, e2_in)) in subs else raise (IMPL_EXC ("exps", subs, EXC_FALSE_EXPS (e1, e2))) - | true, false - -> raise (IMPL_EXC ("exps", subs, EXC_FALSE_EXPS (e1, e2))) - | false, true - -> let sub2' = extend_sub (snd subs) v2 (Sil.exp_sub (`Exp (fst subs)) (Exp.Var v1)) in + | true, false -> + raise (IMPL_EXC ("exps", subs, EXC_FALSE_EXPS (e1, e2))) + | false, true -> + let sub2' = extend_sub (snd subs) v2 (Sil.exp_sub (`Exp (fst subs)) (Exp.Var v1)) in (fst subs, sub2') - | true, true - -> let v1' = Ident.create_fresh Ident.knormal in + | true, true -> + let v1' = Ident.create_fresh Ident.knormal in let sub1' = extend_sub (fst subs) v1 (Exp.Var v1') in let sub2' = extend_sub (snd subs) v2 (Exp.Var v1') in (sub1', sub2') @@ -1314,15 +1373,15 @@ let exp_imply tenv calc_missing (subs: subst2) e1_in e2_in : subst2 = Sil.d_exp e2 ; L.d_ln () ; match (e1, e2) with - | Exp.Var v1, Exp.Var v2 - -> var_imply subs v1 v2 + | Exp.Var v1, Exp.Var v2 -> + var_imply subs v1 v2 | Exp.BinOp ((PlusA | PlusPI | MinusA | MinusPI), Exp.Var v1, e2), Exp.Var v2 - when Ident.equal v1 v2 - -> do_imply subs e2 Exp.zero - | Exp.BinOp ((PlusA | PlusPI), e2, Exp.Var v1), Exp.Var v2 when Ident.equal v1 v2 - -> do_imply subs e2 Exp.zero - | e1, Exp.Var v2 - -> let occurs_check v e = + when Ident.equal v1 v2 -> + do_imply subs e2 Exp.zero + | Exp.BinOp ((PlusA | PlusPI), e2, Exp.Var v1), Exp.Var v2 when Ident.equal v1 v2 -> + do_imply subs e2 Exp.zero + | e1, Exp.Var v2 -> + let occurs_check v e = (* check whether [v] occurs in normalized [e] *) if Sil.fav_mem (Sil.exp_fav e) v && Sil.fav_mem @@ -1336,97 +1395,98 @@ let exp_imply tenv calc_missing (subs: subst2) e1_in e2_in : subst2 = (fst subs, sub2') else raise (IMPL_EXC ("expressions not equal", subs, EXC_FALSE_EXPS (e1, e2))) | e1, Exp.BinOp (Binop.PlusA, (Exp.Var v2 as e2), e2') - when Ident.is_primed v2 || Ident.is_footprint v2 - -> (* here e2' could also be a variable that we could try to substitute (as in the next match + when Ident.is_primed v2 || Ident.is_footprint v2 -> + (* here e2' could also be a variable that we could try to substitute (as in the next match case), but we ignore that to avoid backtracking *) let e' = Exp.BinOp (Binop.MinusA, e1, e2') in do_imply subs (Prop.exp_normalize_noabs tenv Sil.sub_empty e') e2 | e1, Exp.BinOp (Binop.PlusA, e2, (Exp.Var v2 as e2')) - when Ident.is_primed v2 || Ident.is_footprint v2 - -> (* symmetric of above case *) + when Ident.is_primed v2 || Ident.is_footprint v2 -> + (* symmetric of above case *) let e' = Exp.BinOp (Binop.MinusA, e1, e2') in do_imply subs (Prop.exp_normalize_noabs tenv Sil.sub_empty e') e2 - | Exp.Var id, Exp.Lvar pv when Ident.is_footprint id && Pvar.is_local pv - -> (* Footprint var could never be the same as local address *) + | Exp.Var id, Exp.Lvar pv when Ident.is_footprint id && Pvar.is_local pv -> + (* Footprint var could never be the same as local address *) raise (IMPL_EXC ("expression not equal", subs, EXC_FALSE_EXPS (e1, e2))) - | Exp.Var _, e2 - -> if calc_missing then + | Exp.Var _, e2 -> + if calc_missing then let () = ProverState.add_missing_pi (Sil.Aeq (e1_in, e2_in)) in subs else raise (IMPL_EXC ("expressions not equal", subs, EXC_FALSE_EXPS (e1, e2))) - | Exp.Lvar pv1, Exp.Const _ when Pvar.is_global pv1 - -> if calc_missing then + | Exp.Lvar pv1, Exp.Const _ when Pvar.is_global pv1 -> + if calc_missing then let () = ProverState.add_missing_pi (Sil.Aeq (e1_in, e2_in)) in subs else raise (IMPL_EXC ("expressions not equal", subs, EXC_FALSE_EXPS (e1, e2))) - | Exp.Lvar v1, Exp.Lvar v2 - -> if Pvar.equal v1 v2 then subs + | Exp.Lvar v1, Exp.Lvar v2 -> + if Pvar.equal v1 v2 then subs else raise (IMPL_EXC ("expressions not equal", subs, EXC_FALSE_EXPS (e1, e2))) - | Exp.Const c1, Exp.Const c2 - -> if Const.equal c1 c2 then subs + | Exp.Const c1, Exp.Const c2 -> + if Const.equal c1 c2 then subs else raise (IMPL_EXC ("constants not equal", subs, EXC_FALSE_EXPS (e1, e2))) - | Exp.Const Const.Cint _, Exp.BinOp (Binop.PlusPI, _, _) - -> raise + | Exp.Const Const.Cint _, Exp.BinOp (Binop.PlusPI, _, _) -> + raise (IMPL_EXC ("pointer+index cannot evaluate to a constant", subs, EXC_FALSE_EXPS (e1, e2))) - | Exp.Const Const.Cint n1, Exp.BinOp (Binop.PlusA, f1, Exp.Const Const.Cint n2) - -> do_imply subs (Exp.int (n1 -- n2)) f1 - | Exp.BinOp (op1, e1, f1), Exp.BinOp (op2, e2, f2) when Binop.equal op1 op2 - -> do_imply (do_imply subs e1 e2) f1 f2 - | Exp.BinOp (Binop.PlusA, Exp.Var v1, e1), e2 - -> do_imply subs (Exp.Var v1) (Exp.BinOp (Binop.MinusA, e2, e1)) - | Exp.BinOp (Binop.PlusPI, Exp.Lvar pv1, e1), e2 - -> do_imply subs (Exp.Lvar pv1) (Exp.BinOp (Binop.MinusA, e2, e1)) + | Exp.Const Const.Cint n1, Exp.BinOp (Binop.PlusA, f1, Exp.Const Const.Cint n2) -> + do_imply subs (Exp.int (n1 -- n2)) f1 + | Exp.BinOp (op1, e1, f1), Exp.BinOp (op2, e2, f2) when Binop.equal op1 op2 -> + do_imply (do_imply subs e1 e2) f1 f2 + | Exp.BinOp (Binop.PlusA, Exp.Var v1, e1), e2 -> + do_imply subs (Exp.Var v1) (Exp.BinOp (Binop.MinusA, e2, e1)) + | Exp.BinOp (Binop.PlusPI, Exp.Lvar pv1, e1), e2 -> + do_imply subs (Exp.Lvar pv1) (Exp.BinOp (Binop.MinusA, e2, e1)) | ( Exp.Sizeof {typ= t1; dynamic_length= None; subtype= st1} , Exp.Sizeof {typ= t2; dynamic_length= None; subtype= st2} ) - when Typ.equal t1 t2 && Subtype.equal_modulo_flag st1 st2 - -> subs + when Typ.equal t1 t2 && Subtype.equal_modulo_flag st1 st2 -> + subs | ( Exp.Sizeof {typ= t1; dynamic_length= Some d1; subtype= st1} , Exp.Sizeof {typ= t2; dynamic_length= Some d2; subtype= st2} ) - when Typ.equal t1 t2 && Exp.equal d1 d2 && Subtype.equal_modulo_flag st1 st2 - -> subs + when Typ.equal t1 t2 && Exp.equal d1 d2 && Subtype.equal_modulo_flag st1 st2 -> + subs | e', Exp.Const Const.Cint n - when IntLit.iszero n && check_disequal tenv Prop.prop_emp e' Exp.zero - -> raise (IMPL_EXC ("expressions not equal", subs, EXC_FALSE_EXPS (e1, e2))) + when IntLit.iszero n && check_disequal tenv Prop.prop_emp e' Exp.zero -> + raise (IMPL_EXC ("expressions not equal", subs, EXC_FALSE_EXPS (e1, e2))) | Exp.Const Const.Cint n, e' - when IntLit.iszero n && check_disequal tenv Prop.prop_emp e' Exp.zero - -> raise (IMPL_EXC ("expressions not equal", subs, EXC_FALSE_EXPS (e1, e2))) - | e1, Exp.Const _ - -> raise (IMPL_EXC ("lhs not constant", subs, EXC_FALSE_EXPS (e1, e2))) - | Exp.Lfield (e1, fd1, _), Exp.Lfield (e2, fd2, _) when Typ.Fieldname.equal fd1 fd2 - -> do_imply subs e1 e2 - | Exp.Lindex (e1, f1), Exp.Lindex (e2, f2) - -> do_imply (do_imply subs e1 e2) f1 f2 - | Exp.Exn e1, Exp.Exn e2 - -> do_imply subs e1 e2 - | _ - -> d_impl_err ("exp_imply not implemented", subs, EXC_FALSE_EXPS (e1, e2)) ; + when IntLit.iszero n && check_disequal tenv Prop.prop_emp e' Exp.zero -> + raise (IMPL_EXC ("expressions not equal", subs, EXC_FALSE_EXPS (e1, e2))) + | e1, Exp.Const _ -> + raise (IMPL_EXC ("lhs not constant", subs, EXC_FALSE_EXPS (e1, e2))) + | Exp.Lfield (e1, fd1, _), Exp.Lfield (e2, fd2, _) when Typ.Fieldname.equal fd1 fd2 -> + do_imply subs e1 e2 + | Exp.Lindex (e1, f1), Exp.Lindex (e2, f2) -> + do_imply (do_imply subs e1 e2) f1 f2 + | Exp.Exn e1, Exp.Exn e2 -> + do_imply subs e1 e2 + | _ -> + d_impl_err ("exp_imply not implemented", subs, EXC_FALSE_EXPS (e1, e2)) ; raise (Exceptions.Abduction_case_not_implemented __POS__) in do_imply subs e1 e2 + (** Convert a path (from lhs of a |-> to a field name present only in the rhs) into an id. If the lhs was a footprint var, the id is a new footprint var. Othewise it is a var with the path in the name and stamp - 1 *) let path_to_id path = let rec f = function - | Exp.Var id - -> if Ident.is_footprint id then None + | Exp.Var id -> + if Ident.is_footprint id then None else Some (Ident.name_to_string (Ident.get_name id) ^ string_of_int (Ident.get_stamp id)) | Exp.Lfield (e, fld, _) -> ( match f e with None -> None | Some s -> Some (s ^ "_" ^ Typ.Fieldname.to_string fld) ) | Exp.Lindex (e, ind) -> ( match f e with None -> None | Some s -> Some (s ^ "_" ^ Exp.to_string ind) ) - | Exp.Lvar _ - -> Some (Exp.to_string path) - | Exp.Const Const.Cstr s - -> Some ("_const_str_" ^ s) - | Exp.Const Const.Cclass c - -> Some ("_const_class_" ^ Ident.name_to_string c) - | Exp.Const _ - -> None - | _ - -> L.d_str "path_to_id undefined on " ; + | Exp.Lvar _ -> + Some (Exp.to_string path) + | Exp.Const Const.Cstr s -> + Some ("_const_str_" ^ s) + | Exp.Const Const.Cclass c -> + Some ("_const_class_" ^ Ident.name_to_string c) + | Exp.Const _ -> + None + | _ -> + L.d_str "path_to_id undefined on " ; Sil.d_exp path ; L.d_ln () ; assert false @@ -1436,6 +1496,7 @@ let path_to_id path = else match f path with None -> Ident.create_fresh Ident.kfootprint | Some s -> Ident.create_path s + (** Implication for the length of arrays *) let array_len_imply tenv calc_missing subs len1 len2 indices2 = match (len1, len2) with @@ -1445,10 +1506,11 @@ let array_len_imply tenv calc_missing subs len1 len2 indices2 = | Exp.BinOp (Binop.Mult, _, _), _ -> ( try exp_imply tenv calc_missing subs len1 len2 with IMPL_EXC (s, subs', x) -> raise (IMPL_EXC ("array len:" ^ s, subs', x)) ) - | _ - -> ProverState.add_bounds_check (ProverState.BClen_imply (len1, len2, indices2)) ; + | _ -> + ProverState.add_bounds_check (ProverState.BClen_imply (len1, len2, indices2)) ; subs + (** Extend [sub1] and [sub2] to witnesses that each instance of [se1[sub1]] is an instance of [se2[sub2]]. Raise IMPL_FALSE if not possible. *) @@ -1457,10 +1519,10 @@ let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 (* L.d_str "sexp_imply "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_str " : "; Typ.d_full typ2; L.d_ln(); *) match (se1, se2) with - | Sil.Eexp (e1, _), Sil.Eexp (e2, _) - -> (exp_imply tenv calc_missing subs e1 e2, None, None) - | Sil.Estruct (fsel1, inst1), Sil.Estruct (fsel2, _) - -> let subs', fld_frame, fld_missing = + | Sil.Eexp (e1, _), Sil.Eexp (e2, _) -> + (exp_imply tenv calc_missing subs e1 e2, None, None) + | Sil.Estruct (fsel1, inst1), Sil.Estruct (fsel2, _) -> + let subs', fld_frame, fld_missing = struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 in let fld_frame_opt = @@ -1471,18 +1533,18 @@ let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 in (subs', fld_frame_opt, fld_missing_opt) | Sil.Estruct _, Sil.Eexp (e2, _) - -> ( + -> ( let e2' = Sil.exp_sub (`Exp (snd subs)) e2 in match e2' with - | Exp.Var id2 when Ident.is_primed id2 - -> let id2' = Ident.create_fresh Ident.knormal in + | Exp.Var id2 when Ident.is_primed id2 -> + let id2' = Ident.create_fresh Ident.knormal in let sub2' = extend_sub (snd subs) id2 (Exp.Var id2') in ((fst subs, sub2'), None, None) - | _ - -> d_impl_err ("sexp_imply not implemented", subs, EXC_FALSE_SEXPS (se1, se2)) ; + | _ -> + d_impl_err ("sexp_imply not implemented", subs, EXC_FALSE_SEXPS (se1, se2)) ; raise (Exceptions.Abduction_case_not_implemented __POS__) ) - | Sil.Earray (len1, esel1, inst1), Sil.Earray (len2, esel2, _) - -> let indices2 = List.map ~f:fst esel2 in + | Sil.Earray (len1, esel1, inst1), Sil.Earray (len2, esel2, _) -> + let indices2 = List.map ~f:fst esel2 in let subs' = array_len_imply tenv calc_missing subs len1 len2 indices2 in let subs'', index_frame, index_missing = array_imply tenv source calc_index_frame calc_missing subs' esel1 esel2 typ2 @@ -1496,8 +1558,8 @@ let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 else None in (subs'', index_frame_opt, index_missing_opt) - | Sil.Eexp (_, inst), Sil.Estruct (fsel, inst') - -> d_impl_err + | Sil.Eexp (_, inst), Sil.Estruct (fsel, inst') -> + d_impl_err ( "WARNING: function call with parameters of struct type, treating as unknown" , subs , EXC_FALSE_SEXPS (se1, se2) ) ; @@ -1507,11 +1569,11 @@ let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 in sexp_imply tenv source calc_index_frame calc_missing subs (Sil.Estruct (fsel', inst')) se2 typ2 - | Sil.Eexp _, Sil.Earray (len, _, inst) | Sil.Estruct _, Sil.Earray (len, _, inst) - -> let se1' = Sil.Earray (len, [(Exp.zero, se1)], inst) in + | Sil.Eexp _, Sil.Earray (len, _, inst) | Sil.Estruct _, Sil.Earray (len, _, inst) -> + let se1' = Sil.Earray (len, [(Exp.zero, se1)], inst) in sexp_imply tenv source calc_index_frame calc_missing subs se1' se2 typ2 - | Sil.Earray (len, _, _), Sil.Eexp (_, inst) - -> let se2' = Sil.Earray (len, [(Exp.zero, se2)], inst) in + | Sil.Earray (len, _, _), Sil.Eexp (_, inst) -> + let se2' = Sil.Earray (len, [(Exp.zero, se2)], inst) in let typ2' = Typ.mk (Tarray (typ2, None, None)) in (* In the sexp_imply, struct_imply, array_imply, and sexp_imply_nolhs functions, the typ2 argument is only used by eventually passing its value to Typ.Struct.fld, Exp.Lfield, @@ -1520,20 +1582,21 @@ let rec sexp_imply tenv source calc_index_frame calc_missing subs se1 se2 typ2 functions use typ.quals either *) sexp_imply tenv source true calc_missing subs se1 se2' typ2' (* calculate index_frame because the rhs is a singleton array *) - | _ - -> d_impl_err ("sexp_imply not implemented", subs, EXC_FALSE_SEXPS (se1, se2)) ; + | _ -> + d_impl_err ("sexp_imply not implemented", subs, EXC_FALSE_SEXPS (se1, se2)) ; raise (Exceptions.Abduction_case_not_implemented __POS__) + and struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 : subst2 * (Typ.Fieldname.t * Sil.strexp) list * (Typ.Fieldname.t * Sil.strexp) list = let lookup = Tenv.lookup tenv in match (fsel1, fsel2) with - | _, [] - -> (subs, fsel1, []) + | _, [] -> + (subs, fsel1, []) | (f1, se1) :: fsel1', (f2, se2) :: fsel2' -> ( match Typ.Fieldname.compare f1 f2 with - | 0 - -> let typ' = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f2 typ2 in + | 0 -> + let typ' = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f2 typ2 in let subs', se_frame, se_missing = sexp_imply tenv (Exp.Lfield (source, f2, typ2)) false calc_missing subs se1 se2 typ' in @@ -1547,13 +1610,13 @@ and struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 match se_missing with None -> fld_missing | Some se -> (f1, se) :: fld_missing in (subs'', fld_frame', fld_missing') - | n when n < 0 - -> let subs', fld_frame, fld_missing = + | n when n < 0 -> + let subs', fld_frame, fld_missing = struct_imply tenv source calc_missing subs fsel1' fsel2 typ2 in (subs', (f1, se1) :: fld_frame, fld_missing) - | _ - -> let typ' = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f2 typ2 in + | _ -> + let typ' = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f2 typ2 in let subs' = sexp_imply_nolhs tenv (Exp.Lfield (source, f2, typ2)) calc_missing subs se2 typ' in @@ -1562,8 +1625,8 @@ and struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 in let fld_missing' = (f2, se2) :: fld_missing in (subs', fld_frame, fld_missing') ) - | [], (f2, se2) :: fsel2' - -> let typ' = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f2 typ2 in + | [], (f2, se2) :: fsel2' -> + let typ' = Typ.Struct.fld_typ ~lookup ~default:(Typ.mk Tvoid) f2 typ2 in let subs' = sexp_imply_nolhs tenv (Exp.Lfield (source, f2, typ2)) calc_missing subs se2 typ' in @@ -1572,14 +1635,15 @@ and struct_imply tenv source calc_missing subs fsel1 fsel2 typ2 in (subs'', fld_frame, (f2, se2) :: fld_missing) + and array_imply tenv source calc_index_frame calc_missing subs esel1 esel2 typ2 : subst2 * (Exp.t * Sil.strexp) list * (Exp.t * Sil.strexp) list = let typ_elem = Typ.array_elem (Some (Typ.mk Tvoid)) typ2 in match (esel1, esel2) with - | _, [] - -> (subs, esel1, []) - | (e1, se1) :: esel1', (e2, se2) :: esel2' - -> let e1n = Prop.exp_normalize_noabs tenv (`Exp (fst subs)) e1 in + | _, [] -> + (subs, esel1, []) + | (e1, se1) :: esel1', (e2, se2) :: esel2' -> + let e1n = Prop.exp_normalize_noabs tenv (`Exp (fst subs)) e1 in let e2n = Prop.exp_normalize_noabs tenv (`Exp (snd subs)) e2 in let n = Exp.compare e1n e2n in if n < 0 then array_imply tenv source calc_index_frame calc_missing subs esel1' esel2 typ2 @@ -1591,112 +1655,119 @@ and array_imply tenv source calc_index_frame calc_missing subs esel1 esel2 typ2 sexp_imply tenv (Exp.Lindex (source, e1)) false calc_missing subs se1 se2 typ_elem in array_imply tenv source calc_index_frame calc_missing subs' esel1' esel2' typ2 - | [], (e2, se2) :: esel2' - -> let subs' = sexp_imply_nolhs tenv (Exp.Lindex (source, e2)) calc_missing subs se2 typ_elem in + | [], (e2, se2) :: esel2' -> + let subs' = sexp_imply_nolhs tenv (Exp.Lindex (source, e2)) calc_missing subs se2 typ_elem in let subs'', index_frame, index_missing = array_imply tenv source calc_index_frame calc_missing subs' [] esel2' typ2 in let index_missing' = (e2, se2) :: index_missing in (subs'', index_frame, index_missing') + and sexp_imply_nolhs tenv source calc_missing (subs: subst2) se2 typ2 = match se2 with | Sil.Eexp (_e2, _) - -> ( + -> ( let e2 = Sil.exp_sub (`Exp (snd subs)) _e2 in match e2 with - | Exp.Var v2 when Ident.is_primed v2 - -> let v2' = path_to_id source in + | Exp.Var v2 when Ident.is_primed v2 -> + let v2' = path_to_id source in (* L.d_str "called path_to_id on "; Sil.d_exp e2; *) (* L.d_str " returns "; Sil.d_exp (Exp.Var v2'); L.d_ln (); *) let sub2' = extend_sub (snd subs) v2 (Exp.Var v2') in (fst subs, sub2') - | Exp.Var _ - -> if calc_missing then subs + | Exp.Var _ -> + if calc_missing then subs else raise (IMPL_EXC ("exp only in rhs is not a primed var", subs, EXC_FALSE)) - | Exp.Const _ when calc_missing - -> let id = path_to_id source in + | Exp.Const _ when calc_missing -> + let id = path_to_id source in ProverState.add_missing_pi (Sil.Aeq (Exp.Var id, _e2)) ; subs - | _ - -> raise (IMPL_EXC ("exp only in rhs is not a primed var", subs, EXC_FALSE)) ) - | Sil.Estruct (fsel2, _) - -> (fun (x, _, _) -> x) (struct_imply tenv source calc_missing subs [] fsel2 typ2) - | Sil.Earray (_, esel2, _) - -> (fun (x, _, _) -> x) (array_imply tenv source false calc_missing subs [] esel2 typ2) + | _ -> + raise (IMPL_EXC ("exp only in rhs is not a primed var", subs, EXC_FALSE)) ) + | Sil.Estruct (fsel2, _) -> + (fun (x, _, _) -> x) (struct_imply tenv source calc_missing subs [] fsel2 typ2) + | Sil.Earray (_, esel2, _) -> + (fun (x, _, _) -> x) (array_imply tenv source false calc_missing subs [] esel2 typ2) + let rec exp_list_imply tenv calc_missing subs l1 l2 = match (l1, l2) with - | [], [] - -> subs - | e1 :: l1, e2 :: l2 - -> exp_list_imply tenv calc_missing (exp_imply tenv calc_missing subs e1 e2) l1 l2 - | _ - -> assert false + | [], [] -> + subs + | e1 :: l1, e2 :: l2 -> + exp_list_imply tenv calc_missing (exp_imply tenv calc_missing subs e1 e2) l1 l2 + | _ -> + assert false + let filter_ne_lhs sub e0 = function - | Sil.Hpointsto (e, _, _) - -> if Exp.equal e0 (Sil.exp_sub sub e) then Some () else None - | Sil.Hlseg (Sil.Lseg_NE, _, e, _, _) - -> if Exp.equal e0 (Sil.exp_sub sub e) then Some () else None - | Sil.Hdllseg (Sil.Lseg_NE, _, e, _, _, e', _) - -> if Exp.equal e0 (Sil.exp_sub sub e) || Exp.equal e0 (Sil.exp_sub sub e') then Some () + | Sil.Hpointsto (e, _, _) -> + if Exp.equal e0 (Sil.exp_sub sub e) then Some () else None + | Sil.Hlseg (Sil.Lseg_NE, _, e, _, _) -> + if Exp.equal e0 (Sil.exp_sub sub e) then Some () else None + | Sil.Hdllseg (Sil.Lseg_NE, _, e, _, _, e', _) -> + if Exp.equal e0 (Sil.exp_sub sub e) || Exp.equal e0 (Sil.exp_sub sub e') then Some () else None - | _ - -> None + | _ -> + None + let filter_hpred sub hpred2 hpred1 = match (Sil.hpred_sub (`Exp sub) hpred1, hpred2) with - | Sil.Hlseg (Sil.Lseg_NE, hpara1, e1, f1, el1), Sil.Hlseg (Sil.Lseg_PE, _, _, _, _) - -> if Sil.equal_hpred (Sil.Hlseg (Sil.Lseg_PE, hpara1, e1, f1, el1)) hpred2 then Some false + | Sil.Hlseg (Sil.Lseg_NE, hpara1, e1, f1, el1), Sil.Hlseg (Sil.Lseg_PE, _, _, _, _) -> + if Sil.equal_hpred (Sil.Hlseg (Sil.Lseg_PE, hpara1, e1, f1, el1)) hpred2 then Some false else None - | Sil.Hlseg (Sil.Lseg_PE, hpara1, e1, f1, el1), Sil.Hlseg (Sil.Lseg_NE, _, _, _, _) - -> if Sil.equal_hpred (Sil.Hlseg (Sil.Lseg_NE, hpara1, e1, f1, el1)) hpred2 then Some true + | Sil.Hlseg (Sil.Lseg_PE, hpara1, e1, f1, el1), Sil.Hlseg (Sil.Lseg_NE, _, _, _, _) -> + if Sil.equal_hpred (Sil.Hlseg (Sil.Lseg_NE, hpara1, e1, f1, el1)) hpred2 then Some true else None (* return missing disequality *) - | Sil.Hpointsto (e1, _, _), Sil.Hlseg (_, _, e2, _, _) - -> if Exp.equal e1 e2 then Some false else None - | hpred1, hpred2 - -> if Sil.equal_hpred hpred1 hpred2 then Some false else None + | Sil.Hpointsto (e1, _, _), Sil.Hlseg (_, _, e2, _, _) -> + if Exp.equal e1 e2 then Some false else None + | hpred1, hpred2 -> + if Sil.equal_hpred hpred1 hpred2 then Some false else None + let hpred_has_primed_lhs sub hpred = let rec find_primed e = match e with - | Exp.Lfield (e, _, _) - -> find_primed e - | Exp.Lindex (e, _) - -> find_primed e - | Exp.BinOp (Binop.PlusPI, e1, _) - -> find_primed e1 - | _ - -> Sil.fav_exists (Sil.exp_fav e) Ident.is_primed + | Exp.Lfield (e, _, _) -> + find_primed e + | Exp.Lindex (e, _) -> + find_primed e + | Exp.BinOp (Binop.PlusPI, e1, _) -> + find_primed e1 + | _ -> + Sil.fav_exists (Sil.exp_fav e) Ident.is_primed in let exp_has_primed e = find_primed (Sil.exp_sub sub e) in match hpred with - | Sil.Hpointsto (e, _, _) - -> exp_has_primed e - | Sil.Hlseg (_, _, e, _, _) - -> exp_has_primed e - | Sil.Hdllseg (_, _, iF, _, _, iB, _) - -> exp_has_primed iF && exp_has_primed iB + | Sil.Hpointsto (e, _, _) -> + exp_has_primed e + | Sil.Hlseg (_, _, e, _, _) -> + exp_has_primed e + | Sil.Hdllseg (_, _, iF, _, _, iB, _) -> + exp_has_primed iF && exp_has_primed iB + let move_primed_lhs_from_front subs sigma = match sigma with - | [] - -> sigma - | hpred :: _ - -> if hpred_has_primed_lhs (`Exp (snd subs)) hpred then + | [] -> + sigma + | hpred :: _ -> + if hpred_has_primed_lhs (`Exp (snd subs)) hpred then let sigma_primed, sigma_unprimed = List.partition_tf ~f:(hpred_has_primed_lhs (`Exp (snd subs))) sigma in match sigma_unprimed with - | [] - -> raise + | [] -> + raise (IMPL_EXC ("every hpred has primed lhs, cannot proceed", subs, EXC_FALSE_SIGMA sigma)) - | _ :: _ - -> sigma_unprimed @ sigma_primed + | _ :: _ -> + sigma_unprimed @ sigma_primed else sigma + (** [expand_hpred_pointer calc_index_frame hpred] expands [hpred] if it is a |-> whose lhs is a Lfield or Lindex or ptr+off. Return [(changed, calc_index_frame', hpred')] where [changed] indicates whether the predicate has changed. *) let expand_hpred_pointer = @@ -1704,36 +1775,36 @@ let expand_hpred_pointer = fun tenv calc_index_frame hpred -> let rec expand changed calc_index_frame hpred = match hpred with - | Sil.Hpointsto (Lfield (adr_base, fld, adr_typ), cnt, cnt_texp) - -> let cnt_texp' = + | Sil.Hpointsto (Lfield (adr_base, fld, adr_typ), cnt, cnt_texp) -> + let cnt_texp' = match match adr_typ.desc with | Tstruct name -> ( match Tenv.lookup tenv name with - | Some _ - -> (* type of struct at adr_base is known *) + | Some _ -> + (* type of struct at adr_base is known *) Some (Exp.Sizeof {typ= adr_typ; nbytes= None; dynamic_length= None; subtype= Subtype.exact}) - | None - -> None ) - | _ - -> None + | None -> + None ) + | _ -> + None with - | Some se - -> se + | Some se -> + se | None -> match cnt_texp with - | Sizeof ({typ= cnt_typ} as sizeof_data) - -> (* type of struct at adr_base is unknown (typically Tvoid), but + | Sizeof ({typ= cnt_typ} as sizeof_data) -> + (* type of struct at adr_base is unknown (typically Tvoid), but type of contents is known, so construct struct type for single fld:cnt_typ *) let name = Typ.Name.C.from_string ("counterfeit" ^ string_of_int !count) in incr count ; let fields = [(fld, cnt_typ, Annot.Item.empty)] in ignore (Tenv.mk_struct tenv ~fields name) ; Exp.Sizeof {sizeof_data with typ= Typ.mk (Tstruct name)} - | _ - -> (* type of struct at adr_base and of contents are both unknown: give up *) + | _ -> + (* type of struct at adr_base and of contents are both unknown: give up *) L.(die InternalError) "expand_hpred_pointer: Unexpected non-sizeof type in Lfield" in @@ -1741,34 +1812,35 @@ let expand_hpred_pointer = Sil.Hpointsto (adr_base, Estruct ([(fld, cnt)], Sil.inst_none), cnt_texp') in expand true true hpred' - | Sil.Hpointsto (Exp.Lindex (e, ind), se, t) - -> let t' = + | Sil.Hpointsto (Exp.Lindex (e, ind), se, t) -> + let t' = match t with - | Exp.Sizeof ({typ= t_} as sizeof_data) - -> Exp.Sizeof {sizeof_data with typ= Typ.mk (Tarray (t_, None, None))} - | _ - -> L.(die InternalError) "expand_hpred_pointer: Unexpected non-sizeof type in Lindex" + | Exp.Sizeof ({typ= t_} as sizeof_data) -> + Exp.Sizeof {sizeof_data with typ= Typ.mk (Tarray (t_, None, None))} + | _ -> + L.(die InternalError) "expand_hpred_pointer: Unexpected non-sizeof type in Lindex" in let len = match t' with - | Exp.Sizeof {dynamic_length= Some len} - -> len - | _ - -> Exp.get_undefined false + | Exp.Sizeof {dynamic_length= Some len} -> + len + | _ -> + Exp.get_undefined false in let hpred' = Sil.Hpointsto (e, Sil.Earray (len, [(ind, se)], Sil.inst_none), t') in expand true true hpred' - | Sil.Hpointsto (Exp.BinOp (Binop.PlusPI, e1, e2), Sil.Earray (len, esel, inst), t) - -> let shift_exp e = Exp.BinOp (Binop.PlusA, e, e2) in + | Sil.Hpointsto (Exp.BinOp (Binop.PlusPI, e1, e2), Sil.Earray (len, esel, inst), t) -> + let shift_exp e = Exp.BinOp (Binop.PlusA, e, e2) in let len' = shift_exp len in let esel' = List.map ~f:(fun (e, se) -> (shift_exp e, se)) esel in let hpred' = Sil.Hpointsto (e1, Sil.Earray (len', esel', inst), t) in expand true calc_index_frame hpred' - | _ - -> (changed, calc_index_frame, hpred) + | _ -> + (changed, calc_index_frame, hpred) in expand false calc_index_frame hpred + module Subtyping_check = struct (** check that t1 and t2 are the same primitive type *) let check_subtype_basic_type t1 t2 = @@ -1779,106 +1851,112 @@ module Subtyping_check = struct | Typ.Tfloat Typ.FDouble | Typ.Tfloat Typ.FFloat | Typ.Tint Typ.ILong - | Typ.Tint Typ.IShort - -> Typ.equal t1 t2 - | _ - -> false + | Typ.Tint Typ.IShort -> + Typ.equal t1 t2 + | _ -> + false + (** check if t1 is a subtype of t2, in Java *) let rec check_subtype_java tenv (t1: Typ.t) (t2: Typ.t) = match (t1.Typ.desc, t2.Typ.desc) with - | Tstruct (JavaClass _ as cn1), Tstruct (JavaClass _ as cn2) - -> Subtype.is_known_subtype tenv cn1 cn2 - | Tarray (dom_type1, _, _), Tarray (dom_type2, _, _) - -> check_subtype_java tenv dom_type1 dom_type2 - | Tptr (dom_type1, _), Tptr (dom_type2, _) - -> check_subtype_java tenv dom_type1 dom_type2 - | Tarray _, Tstruct (JavaClass _ as cn2) - -> Typ.Name.equal cn2 Typ.Name.Java.java_io_serializable + | Tstruct (JavaClass _ as cn1), Tstruct (JavaClass _ as cn2) -> + Subtype.is_known_subtype tenv cn1 cn2 + | Tarray (dom_type1, _, _), Tarray (dom_type2, _, _) -> + check_subtype_java tenv dom_type1 dom_type2 + | Tptr (dom_type1, _), Tptr (dom_type2, _) -> + check_subtype_java tenv dom_type1 dom_type2 + | Tarray _, Tstruct (JavaClass _ as cn2) -> + Typ.Name.equal cn2 Typ.Name.Java.java_io_serializable || Typ.Name.equal cn2 Typ.Name.Java.java_lang_cloneable || Typ.Name.equal cn2 Typ.Name.Java.java_lang_object - | _ - -> check_subtype_basic_type t1 t2 + | _ -> + check_subtype_basic_type t1 t2 + (** check if t1 is a subtype of t2 *) let check_subtype tenv t1 t2 = if is_java_class tenv t1 then check_subtype_java tenv t1 t2 else match (Typ.name t1, Typ.name t2) with - | Some cn1, Some cn2 - -> Subtype.is_known_subtype tenv cn1 cn2 - | _ - -> false + | Some cn1, Some cn2 -> + Subtype.is_known_subtype tenv cn1 cn2 + | _ -> + false + let rec case_analysis_type tenv ((t1: Typ.t), st1) ((t2: Typ.t), st2) = match (t1.desc, t2.desc) with - | Tstruct (JavaClass _ as cn1), Tstruct (JavaClass _ as cn2) - -> Subtype.case_analysis tenv (cn1, st1) (cn2, st2) + | Tstruct (JavaClass _ as cn1), Tstruct (JavaClass _ as cn2) -> + Subtype.case_analysis tenv (cn1, st1) (cn2, st2) | Tstruct (JavaClass _ as cn1), Tarray _ when ( Typ.Name.equal cn1 Typ.Name.Java.java_io_serializable || Typ.Name.equal cn1 Typ.Name.Java.java_lang_cloneable || Typ.Name.equal cn1 Typ.Name.Java.java_lang_object ) - && st1 <> Subtype.exact - -> (Some st1, None) + && st1 <> Subtype.exact -> + (Some st1, None) | Tstruct cn1, Tstruct cn2 (* cn1 <: cn2 or cn2 <: cn1 is implied in Java when we get two types compared *) (* that get through the type system, but not in C++ because of multiple inheritance, *) (* and not in ObjC because of being weakly typed, *) (* and the algorithm will only work correctly if this is the case *) - when Subtype.is_known_subtype tenv cn1 cn2 || Subtype.is_known_subtype tenv cn2 cn1 - -> Subtype.case_analysis tenv (cn1, st1) (cn2, st2) - | Tarray (dom_type1, _, _), Tarray (dom_type2, _, _) - -> case_analysis_type tenv (dom_type1, st1) (dom_type2, st2) - | Tptr (dom_type1, _), Tptr (dom_type2, _) - -> case_analysis_type tenv (dom_type1, st1) (dom_type2, st2) - | _ when check_subtype_basic_type t1 t2 - -> (Some st1, None) - | _ - -> (* The case analysis did not succeed *) + when Subtype.is_known_subtype tenv cn1 cn2 || Subtype.is_known_subtype tenv cn2 cn1 -> + Subtype.case_analysis tenv (cn1, st1) (cn2, st2) + | Tarray (dom_type1, _, _), Tarray (dom_type2, _, _) -> + case_analysis_type tenv (dom_type1, st1) (dom_type2, st2) + | Tptr (dom_type1, _), Tptr (dom_type2, _) -> + case_analysis_type tenv (dom_type1, st1) (dom_type2, st2) + | _ when check_subtype_basic_type t1 t2 -> + (Some st1, None) + | _ -> + (* The case analysis did not succeed *) (None, Some st1) + (** perform case analysis on [texp1 <: texp2], and return the updated types in the true and false case, if they are possible *) let subtype_case_analysis tenv texp1 texp2 = match (texp1, texp2) with - | Exp.Sizeof sizeof1, Exp.Sizeof sizeof2 - -> let pos_opt, neg_opt = + | Exp.Sizeof sizeof1, Exp.Sizeof sizeof2 -> + let pos_opt, neg_opt = case_analysis_type tenv (sizeof1.typ, sizeof1.subtype) (sizeof2.typ, sizeof2.subtype) in let pos_type_opt = match pos_opt with - | None - -> None - | Some subtype - -> if check_subtype tenv sizeof1.typ sizeof2.typ then + | None -> + None + | Some subtype -> + if check_subtype tenv sizeof1.typ sizeof2.typ then Some (Exp.Sizeof {sizeof1 with subtype}) else Some (Exp.Sizeof {sizeof2 with subtype}) in let neg_type_opt = match neg_opt with - | None - -> None - | Some subtype - -> Some (Exp.Sizeof {sizeof1 with subtype}) + | None -> + None + | Some subtype -> + Some (Exp.Sizeof {sizeof1 with subtype}) in (pos_type_opt, neg_type_opt) - | _ - -> (* don't know, consider both possibilities *) + | _ -> + (* don't know, consider both possibilities *) (Some texp1, Some texp1) + end let cast_exception tenv texp1 texp2 e1 subs = let _ = match (texp1, texp2) with - | Exp.Sizeof {typ= t1}, Exp.Sizeof {typ= t2; subtype= st2} - -> if Config.developer_mode + | Exp.Sizeof {typ= t1}, Exp.Sizeof {typ= t2; subtype= st2} -> + if Config.developer_mode || Subtype.is_cast st2 && not (Subtyping_check.check_subtype tenv t1 t2) then ProverState.checks := Class_cast_check (texp1, texp2, e1) :: !ProverState.checks - | _ - -> () + | _ -> + () in raise (IMPL_EXC ("class cast exception", subs, EXC_FALSE)) + (** get all methods that override [supertype].[pname] in [tenv]. Note: supertype should be a type T rather than a pointer to type T Note: [pname] wil never be included in the returned result *) @@ -1887,12 +1965,12 @@ let get_overrides_of tenv supertype pname = match typ.desc with | Tstruct name -> ( match Tenv.lookup tenv name with - | Some {methods} - -> List.exists ~f:(fun m -> Typ.Procname.equal pname m) methods - | None - -> false ) - | _ - -> false + | Some {methods} -> + List.exists ~f:(fun m -> Typ.Procname.equal pname m) methods + | None -> + false ) + | _ -> + false in let gather_overrides tname _ overrides_acc = let typ = Typ.mk (Tstruct tname) in @@ -1907,15 +1985,17 @@ let get_overrides_of tenv supertype pname = in Tenv.fold gather_overrides tenv [] + (** Check the equality of two types ignoring flags in the subtyping components *) let texp_equal_modulo_subtype_flag texp1 texp2 = match (texp1, texp2) with | ( Exp.Sizeof {typ= t1; dynamic_length= len1; subtype= st1} - , Exp.Sizeof {typ= t2; dynamic_length= len2; subtype= st2} ) - -> [%compare.equal : Typ.t * Exp.t option] (t1, len1) (t2, len2) + , Exp.Sizeof {typ= t2; dynamic_length= len2; subtype= st2} ) -> + [%compare.equal : Typ.t * Exp.t option] (t1, len1) (t2, len2) && Subtype.equal_modulo_flag st1 st2 - | _ - -> Exp.equal texp1 texp2 + | _ -> + Exp.equal texp1 texp2 + (** check implication between type expressions *) let texp_imply tenv subs texp1 texp2 e1 calc_missing = @@ -1925,47 +2005,48 @@ let texp_imply tenv subs texp1 texp2 e1 calc_missing = match (texp1, texp2) with | Exp.Sizeof {typ= typ1}, Exp.Sizeof {typ= typ2} -> ( match (typ1.desc, typ2.desc) with - | (Tstruct _ | Tarray _), (Tstruct _ | Tarray _) - -> is_java_class tenv typ1 || Typ.is_cpp_class typ1 && Typ.is_cpp_class typ2 + | (Tstruct _ | Tarray _), (Tstruct _ | Tarray _) -> + is_java_class tenv typ1 || Typ.is_cpp_class typ1 && Typ.is_cpp_class typ2 || Typ.is_objc_class typ1 && Typ.is_objc_class typ2 - | _ - -> false ) - | _ - -> false + | _ -> + false ) + | _ -> + false in if types_subject_to_dynamic_cast then let pos_type_opt, neg_type_opt = Subtyping_check.subtype_case_analysis tenv texp1 texp2 in let has_changed = match pos_type_opt with - | Some texp1' - -> not (texp_equal_modulo_subtype_flag texp1' texp1) - | None - -> false + | Some texp1' -> + not (texp_equal_modulo_subtype_flag texp1' texp1) + | None -> + false in if calc_missing then (* footprint *) match pos_type_opt with - | None - -> cast_exception tenv texp1 texp2 e1 subs - | Some _ - -> if has_changed then (None, pos_type_opt) (* missing *) else (pos_type_opt, None) + | None -> + cast_exception tenv texp1 texp2 e1 subs + | Some _ -> + if has_changed then (None, pos_type_opt) (* missing *) else (pos_type_opt, None) (* frame *) else (* re-execution *) match neg_type_opt with - | Some _ - -> cast_exception tenv texp1 texp2 e1 subs - | None - -> if has_changed then cast_exception tenv texp1 texp2 e1 subs (* missing *) + | Some _ -> + cast_exception tenv texp1 texp2 e1 subs + | None -> + if has_changed then cast_exception tenv texp1 texp2 e1 subs (* missing *) else (pos_type_opt, None) (* frame *) else (None, None) + (** pre-process implication between a non-array and an array: the non-array is turned into an array of length given by its type only active in type_size mode *) let sexp_imply_preprocess se1 texp1 se2 = match (se1, texp1, se2) with - | Sil.Eexp (_, inst), Exp.Sizeof _, Sil.Earray _ when Config.type_size - -> let se1' = Sil.Earray (texp1, [(Exp.zero, se1)], inst) in + | Sil.Eexp (_, inst), Exp.Sizeof _, Sil.Earray _ when Config.type_size -> + let se1' = Sil.Earray (texp1, [(Exp.zero, se1)], inst) in L.d_strln_color Orange "sexp_imply_preprocess" ; L.d_str " se1: " ; Sil.d_sexp se1 ; @@ -1974,8 +2055,9 @@ let sexp_imply_preprocess se1 texp1 se2 = Sil.d_sexp se1' ; L.d_ln () ; se1' - | _ - -> se1 + | _ -> + se1 + (** handle parameter subtype: when the type of a callee variable in the caller is a strict subtype of the one in the callee, add a type frame and type missing *) @@ -1988,11 +2070,11 @@ let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2 let type_rhs e = let sub_opt = ref None in let filter = function - | Sil.Hpointsto (e', _, Exp.Sizeof sizeof_data) when Exp.equal e' e - -> sub_opt := Some sizeof_data ; + | Sil.Hpointsto (e', _, Exp.Sizeof sizeof_data) when Exp.equal e' e -> + sub_opt := Some sizeof_data ; true - | _ - -> false + | _ -> + false in if List.exists ~f:filter sigma2 then !sub_opt else None in @@ -2005,7 +2087,7 @@ let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2 when not (is_allocated_lhs e1') -> ( match type_rhs e2' with | Some sizeof_data2 - -> ( + -> ( if not (Typ.equal t1 t2) && Subtyping_check.check_subtype tenv t1 t2 then let pos_type_opt, _ = Subtyping_check.subtype_case_analysis tenv @@ -2013,42 +2095,43 @@ let handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2 (Exp.Sizeof sizeof_data2) in match pos_type_opt with - | Some t1_noptr - -> ProverState.add_frame_typ (e1', t1_noptr) ; + | Some t1_noptr -> + ProverState.add_frame_typ (e1', t1_noptr) ; ProverState.add_missing_typ (e2', t1_noptr) - | None - -> cast_exception tenv texp1 texp2 e1 subs ) - | None - -> () ) - | _ - -> () + | None -> + cast_exception tenv texp1 texp2 e1 subs ) + | None -> + () ) + | _ -> + () in if is_callee && !Config.footprint then add_subtype () + let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 : subst2 * Prop.normal Prop.t = match hpred2 with | Sil.Hpointsto (_e2, se2, texp2) - -> ( + -> ( let e2 = Sil.exp_sub (`Exp (snd subs)) _e2 in let _ = match e2 with - | Exp.Lvar _ - -> () - | Exp.Var v - -> if Ident.is_primed v then ( + | Exp.Lvar _ -> + () + | Exp.Var v -> + if Ident.is_primed v then ( d_impl_err ("rhs |-> not implemented", subs, EXC_FALSE_HPRED hpred2) ; raise (Exceptions.Abduction_case_not_implemented __POS__) ) - | _ - -> () + | _ -> + () in match Prop.prop_iter_create prop1 with - | None - -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) + | None -> + raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) | Some iter1 -> match Prop.prop_iter_find iter1 (filter_ne_lhs (`Exp (fst subs)) e2) with - | None - -> raise (IMPL_EXC ("lhs does not have e|->", subs, EXC_FALSE_HPRED hpred2)) + | None -> + raise (IMPL_EXC ("lhs does not have e|->", subs, EXC_FALSE_HPRED hpred2)) | Some iter1' -> match Prop.prop_iter_current tenv iter1' with | Sil.Hpointsto (e1, se1, texp1), _ -> ( @@ -2064,30 +2147,30 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 if calc_missing then ( handle_parameter_subtype tenv prop1 sigma2 subs (e1, se1, texp1) (se2, texp2) ; ( match fld_missing with - | Some fld_missing - -> ProverState.add_missing_fld (Sil.Hpointsto (_e2, fld_missing, texp1)) - | None - -> () ) ; + | Some fld_missing -> + ProverState.add_missing_fld (Sil.Hpointsto (_e2, fld_missing, texp1)) + | None -> + () ) ; ( match fld_frame with - | Some fld_frame - -> ProverState.add_frame_fld (Sil.Hpointsto (e1, fld_frame, texp1)) - | None - -> () ) ; + | Some fld_frame -> + ProverState.add_frame_fld (Sil.Hpointsto (e1, fld_frame, texp1)) + | None -> + () ) ; ( match typing_missing with - | Some t_missing - -> ProverState.add_missing_typ (_e2, t_missing) - | None - -> () ) ; + | Some t_missing -> + ProverState.add_missing_typ (_e2, t_missing) + | None -> + () ) ; match typing_frame with - | Some t_frame - -> ProverState.add_frame_typ (e1, t_frame) - | None - -> () ) ; + | Some t_frame -> + ProverState.add_frame_typ (e1, t_frame) + | None -> + () ) ; let prop1' = Prop.prop_iter_remove_curr_then_to_prop tenv iter1' in (subs', prop1') with IMPL_EXC (s, _, _) when calc_missing -> raise (MISSING_EXC s) ) - | Sil.Hlseg (Sil.Lseg_NE, para1, e1, f1, elist1), _ - -> (* Unroll lseg *) + | Sil.Hlseg (Sil.Lseg_NE, para1, e1, f1, elist1), _ -> + (* Unroll lseg *) let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in let _, para_inst1 = Sil.hpara_instantiate para1 e1 n' elist1 in let hpred_list1 = para_inst1 @ [Prop.mk_lseg tenv Sil.Lseg_PE para1 n' f1 elist1] in @@ -2096,12 +2179,13 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 let res = decrease_indent_when_exception (fun () -> hpred_imply tenv calc_index_frame calc_missing subs - (Prop.prop_iter_to_prop tenv iter1'') sigma2 hpred2 ) + (Prop.prop_iter_to_prop tenv iter1'') + sigma2 hpred2 ) in L.d_decrease_indent 1 ; res | Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _ - when Exp.equal (Sil.exp_sub (`Exp (fst subs)) iF1) e2 - -> (* Unroll dllseg forward *) + when Exp.equal (Sil.exp_sub (`Exp (fst subs)) iF1) e2 -> + (* Unroll dllseg forward *) let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in let _, para_inst1 = Sil.hpara_dll_instantiate para1 iF1 oB1 n' elist1 in let hpred_list1 = @@ -2112,12 +2196,13 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 let res = decrease_indent_when_exception (fun () -> hpred_imply tenv calc_index_frame calc_missing subs - (Prop.prop_iter_to_prop tenv iter1'') sigma2 hpred2 ) + (Prop.prop_iter_to_prop tenv iter1'') + sigma2 hpred2 ) in L.d_decrease_indent 1 ; res | Sil.Hdllseg (Sil.Lseg_NE, para1, iF1, oB1, oF1, iB1, elist1), _ - when Exp.equal (Sil.exp_sub (`Exp (fst subs)) iB1) e2 - -> (* Unroll dllseg backward *) + when Exp.equal (Sil.exp_sub (`Exp (fst subs)) iB1) e2 -> + (* Unroll dllseg backward *) let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in let _, para_inst1 = Sil.hpara_dll_instantiate para1 iB1 n' oF1 elist1 in let hpred_list1 = @@ -2128,38 +2213,39 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 let res = decrease_indent_when_exception (fun () -> hpred_imply tenv calc_index_frame calc_missing subs - (Prop.prop_iter_to_prop tenv iter1'') sigma2 hpred2 ) + (Prop.prop_iter_to_prop tenv iter1'') + sigma2 hpred2 ) in L.d_decrease_indent 1 ; res - | _ - -> assert false ) + | _ -> + assert false ) | Sil.Hlseg (k, para2, _e2, _f2, _elist2) - -> ( + -> ( (* for now ignore implications between PE and NE *) let e2, f2 = (Sil.exp_sub (`Exp (snd subs)) _e2, Sil.exp_sub (`Exp (snd subs)) _f2) in let _ = match e2 with - | Exp.Lvar _ - -> () - | Exp.Var v - -> if Ident.is_primed v then ( + | Exp.Lvar _ -> + () + | Exp.Var v -> + if Ident.is_primed v then ( d_impl_err ("rhs |-> not implemented", subs, EXC_FALSE_HPRED hpred2) ; raise (Exceptions.Abduction_case_not_implemented __POS__) ) - | _ - -> () + | _ -> + () in if Exp.equal e2 f2 && Sil.equal_lseg_kind k Sil.Lseg_PE then (subs, prop1) else match Prop.prop_iter_create prop1 with - | None - -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) + | None -> + raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) | Some iter1 -> match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (`Exp (snd subs)) hpred2)) with - | None - -> let elist2 = List.map ~f:(fun e -> Sil.exp_sub (`Exp (snd subs)) e) _elist2 in + | None -> + let elist2 = List.map ~f:(fun e -> Sil.exp_sub (`Exp (snd subs)) e) _elist2 in let _, para_inst2 = Sil.hpara_instantiate para2 e2 f2 elist2 in L.d_increase_indent 1 ; let res = @@ -2168,23 +2254,23 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 in (* calc_missing is false as we're checking an instantiation of the original list *) L.d_decrease_indent 1 ; res - | Some iter1' - -> let elist2 = List.map ~f:(fun e -> Sil.exp_sub (`Exp (snd subs)) e) _elist2 in + | Some iter1' -> + let elist2 = List.map ~f:(fun e -> Sil.exp_sub (`Exp (snd subs)) e) _elist2 in (* force instantiation of existentials *) let subs' = exp_list_imply tenv calc_missing subs (f2 :: elist2) (f2 :: elist2) in let prop1' = Prop.prop_iter_remove_curr_then_to_prop tenv iter1' in let hpred1 = - match Prop.prop_iter_current tenv iter1' - with hpred1, b -> - if b then ProverState.add_missing_pi (Sil.Aneq (_e2, _f2)) ; - (* for PE |- NE *) - hpred1 + match Prop.prop_iter_current tenv iter1' with + | hpred1, b -> + if b then ProverState.add_missing_pi (Sil.Aneq (_e2, _f2)) ; + (* for PE |- NE *) + hpred1 in match hpred1 with - | Sil.Hlseg _ - -> (subs', prop1') - | Sil.Hpointsto _ - -> (* unroll rhs list and try again *) + | Sil.Hlseg _ -> + (subs', prop1') + | Sil.Hpointsto _ -> + (* unroll rhs list and try again *) let n' = Exp.Var (Ident.create_fresh Ident.kprimed) in let _, para_inst2 = Sil.hpara_instantiate para2 _e2 n' elist2 in let hpred_list2 = @@ -2200,47 +2286,47 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 sigma_imply tenv calc_index_frame calc_missing subs prop1 para_inst3 ) in L.d_decrease_indent 1 ; res - | Sil.Hdllseg _ - -> assert false ) - | Sil.Hdllseg (Sil.Lseg_PE, _, _, _, _, _, _) - -> d_impl_err ("rhs dllsegPE not implemented", subs, EXC_FALSE_HPRED hpred2) ; + | Sil.Hdllseg _ -> + assert false ) + | Sil.Hdllseg (Sil.Lseg_PE, _, _, _, _, _, _) -> + d_impl_err ("rhs dllsegPE not implemented", subs, EXC_FALSE_HPRED hpred2) ; raise (Exceptions.Abduction_case_not_implemented __POS__) - | Sil.Hdllseg (_, para2, iF2, oB2, oF2, iB2, elist2) - -> (* for now ignore implications between PE and NE *) + | Sil.Hdllseg (_, para2, iF2, oB2, oF2, iB2, elist2) -> + (* for now ignore implications between PE and NE *) let iF2, oF2 = (Sil.exp_sub (`Exp (snd subs)) iF2, Sil.exp_sub (`Exp (snd subs)) oF2) in let iB2, oB2 = (Sil.exp_sub (`Exp (snd subs)) iB2, Sil.exp_sub (`Exp (snd subs)) oB2) in let _ = match oF2 with - | Exp.Lvar _ - -> () - | Exp.Var v - -> if Ident.is_primed v then ( + | Exp.Lvar _ -> + () + | Exp.Var v -> + if Ident.is_primed v then ( d_impl_err ("rhs dllseg not implemented", subs, EXC_FALSE_HPRED hpred2) ; raise (Exceptions.Abduction_case_not_implemented __POS__) ) - | _ - -> () + | _ -> + () in let _ = match oB2 with - | Exp.Lvar _ - -> () - | Exp.Var v - -> if Ident.is_primed v then ( + | Exp.Lvar _ -> + () + | Exp.Var v -> + if Ident.is_primed v then ( d_impl_err ("rhs dllseg not implemented", subs, EXC_FALSE_HPRED hpred2) ; raise (Exceptions.Abduction_case_not_implemented __POS__) ) - | _ - -> () + | _ -> + () in match Prop.prop_iter_create prop1 with - | None - -> raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) + | None -> + raise (IMPL_EXC ("lhs is empty", subs, EXC_FALSE)) | Some iter1 -> match Prop.prop_iter_find iter1 (filter_hpred (fst subs) (Sil.hpred_sub (`Exp (snd subs)) hpred2)) with - | None - -> let elist2 = List.map ~f:(fun e -> Sil.exp_sub (`Exp (snd subs)) e) elist2 in + | None -> + let elist2 = List.map ~f:(fun e -> Sil.exp_sub (`Exp (snd subs)) e) elist2 in let _, para_inst2 = if Exp.equal iF2 iB2 then Sil.hpara_dll_instantiate para2 iF2 oB2 oF2 elist2 else assert false @@ -2253,8 +2339,8 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 in (* calc_missing is false as we're checking an instantiation of the original list *) L.d_decrease_indent 1 ; res - | Some iter1' - -> (* Only consider implications between identical listsegs for now *) + | Some iter1' -> + (* Only consider implications between identical listsegs for now *) let elist2 = List.map ~f:(fun e -> Sil.exp_sub (`Exp (snd subs)) e) elist2 in (* force instantiation of existentials *) let subs' = @@ -2264,6 +2350,7 @@ let rec hpred_imply tenv calc_index_frame calc_missing subs prop1 sigma2 hpred2 let prop1' = Prop.prop_iter_remove_curr_then_to_prop tenv iter1' in (subs', prop1') + (** Check that [sigma1] implies [sigma2] and return two substitution instantiations for the primed variables of [sigma1] and [sigma2] and a frame. Raise IMPL_FALSE if the implication cannot be @@ -2272,17 +2359,17 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * let is_constant_string_class subs = function (* if the hpred represents a constant string, return the string *) | Sil.Hpointsto (_e2, _, _) - -> ( + -> ( let e2 = Sil.exp_sub (`Exp (snd subs)) _e2 in match e2 with - | Exp.Const Const.Cstr s - -> Some (s, true) - | Exp.Const Const.Cclass c - -> Some (Ident.name_to_string c, false) - | _ - -> None ) - | _ - -> None + | Exp.Const Const.Cstr s -> + Some (s, true) + | Exp.Const Const.Cclass c -> + Some (Ident.name_to_string c, false) + | _ -> + None ) + | _ -> + None in let mk_constant_string_hpred s = (* create an hpred from a constant string *) @@ -2291,10 +2378,10 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * let sexp = let index = Exp.int (IntLit.of_int (String.length s)) in match !Config.curr_language with - | Config.Clang - -> Sil.Earray (Exp.int len, [(index, Sil.Eexp (Exp.zero, Sil.inst_none))], Sil.inst_none) - | Config.Java - -> let mk_fld_sexp s = + | Config.Clang -> + Sil.Earray (Exp.int len, [(index, Sil.Eexp (Exp.zero, Sil.inst_none))], Sil.inst_none) + | Config.Java -> + let mk_fld_sexp s = let fld = Typ.Fieldname.Java.from_string s in let se = Sil.Eexp (Exp.Var (Ident.create_fresh Ident.kprimed), Sil.Inone) in (fld, se) @@ -2306,26 +2393,26 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * ; "java.lang.String.value" ] in Sil.Estruct (List.map ~f:mk_fld_sexp fields, Sil.inst_none) - | Config.Python - -> L.die InternalError "mk_constant_string_hpred not implemented for Python" + | Config.Python -> + L.die InternalError "mk_constant_string_hpred not implemented for Python" in let const_string_texp = match !Config.curr_language with - | Config.Clang - -> Exp.Sizeof + | Config.Clang -> + Exp.Sizeof { typ= Typ.mk (Tarray (Typ.mk (Tint Typ.IChar), Some len, Some (IntLit.of_int 1))) ; nbytes= None ; dynamic_length= None ; subtype= Subtype.exact } - | Config.Java - -> let object_type = Typ.Name.Java.from_string "java.lang.String" in + | Config.Java -> + let object_type = Typ.Name.Java.from_string "java.lang.String" in Exp.Sizeof { typ= Typ.mk (Tstruct object_type) ; nbytes= None ; dynamic_length= None ; subtype= Subtype.exact } - | Config.Python - -> L.die InternalError "const_string_texp not implemented for Python" + | Config.Python -> + L.die InternalError "const_string_texp not implemented for Python" in Sil.Hpointsto (root, sexp, const_string_texp) in @@ -2351,12 +2438,12 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * in try match move_primed_lhs_from_front subs sigma2 with - | [] - -> L.d_strln "Final Implication" ; + | [] -> + L.d_strln "Final Implication" ; d_impl subs (prop1, Prop.prop_emp) ; (subs, prop1) - | hpred2 :: sigma2' - -> L.d_strln "Current Implication" ; + | hpred2 :: sigma2' -> + L.d_strln "Current Implication" ; d_impl subs (prop1, Prop.normalize tenv (Prop.from_sigma (hpred2 :: sigma2'))) ; L.d_ln () ; L.d_ln () ; @@ -2371,8 +2458,8 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * L.d_decrease_indent 1 ; res with IMPL_EXC _ when calc_missing -> match is_constant_string_class subs hpred2' with - | Some (s, is_string) - -> (* allocate constant string hpred1', do implication, then add hpred1' as missing *) + | Some (s, is_string) -> + (* allocate constant string hpred1', do implication, then add hpred1' as missing *) let hpred1' = if is_string then mk_constant_string_hpred s else mk_constant_class_hpred s in @@ -2384,14 +2471,14 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * in (* ProverState.add_missing_sigma [hpred1']; *) (subs', frame_prop) - | None - -> let subs' = + | None -> + let subs' = match hpred2' with - | Sil.Hpointsto (e2, se2, te2) - -> let typ2 = Exp.texp_to_typ (Some (Typ.mk Tvoid)) te2 in + | Sil.Hpointsto (e2, se2, te2) -> + let typ2 = Exp.texp_to_typ (Some (Typ.mk Tvoid)) te2 in sexp_imply_nolhs tenv e2 calc_missing subs se2 typ2 - | _ - -> subs + | _ -> + subs in ProverState.add_missing_sigma [hpred2'] ; (subs', prop1) @@ -2404,8 +2491,8 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * L.d_decrease_indent 1 ; res in match hpred2 with - | Sil.Hpointsto (_e2, se2, t) - -> let changed, calc_index_frame', hpred2' = + | Sil.Hpointsto (_e2, se2, t) -> + let changed, calc_index_frame', hpred2' = expand_hpred_pointer tenv calc_index_frame (Sil.Hpointsto (Prop.exp_normalize_noabs tenv (`Exp (snd subs)) _e2, se2, t)) in @@ -2413,19 +2500,21 @@ and sigma_imply tenv calc_index_frame calc_missing subs prop1 sigma2 : subst2 * sigma_imply tenv calc_index_frame' calc_missing subs prop1 (hpred2' :: sigma2') (* calc_index_frame=true *) else normal_case hpred2' - | _ - -> normal_case hpred2 + | _ -> + normal_case hpred2 with IMPL_EXC (s, _, _) when calc_missing -> L.d_strln ("Adding rhs as missing: " ^ s) ; ProverState.add_missing_sigma sigma2 ; (subs, prop1) + let prepare_prop_for_implication tenv (_, sub2) pi1 sigma1 = let pi1' = Prop.pi_sub (`Exp sub2) (ProverState.get_missing_pi ()) @ pi1 in let sigma1' = Prop.sigma_sub (`Exp sub2) (ProverState.get_missing_sigma ()) @ sigma1 in let ep = Prop.set Prop.prop_emp ~sub:sub2 ~sigma:sigma1' ~pi:pi1' in Prop.normalize tenv ep + let imply_pi tenv calc_missing (sub1, sub2) prop pi2 = let do_atom a = let a' = Sil.atom_sub (`Exp sub2) a in @@ -2440,44 +2529,47 @@ let imply_pi tenv calc_missing (sub1, sub2) prop pi2 = in List.iter ~f:do_atom pi2 + let imply_atom tenv calc_missing (sub1, sub2) prop a = imply_pi tenv calc_missing (sub1, sub2) prop [a] + (** Check pure implications before looking at the spatial part. Add necessary instantiations for equalities and check that instantiations are possible for disequalities. *) let rec pre_check_pure_implication tenv calc_missing (subs: subst2) pi1 pi2 = match pi2 with - | [] - -> subs + | [] -> + subs | (Sil.Aeq (e2_in, f2_in) as a) :: pi2' when not (Prop.atom_is_inequality a) - -> ( + -> ( let e2, f2 = (Sil.exp_sub (`Exp (snd subs)) e2_in, Sil.exp_sub (`Exp (snd subs)) f2_in) in if Exp.equal e2 f2 then pre_check_pure_implication tenv calc_missing subs pi1 pi2' else match (e2, f2) with - | Exp.Var v2, f2 when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) - -> (* The commented-out condition should always hold. *) + | Exp.Var v2, f2 when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) -> + (* The commented-out condition should always hold. *) let sub2' = extend_sub (snd subs) v2 f2 in pre_check_pure_implication tenv calc_missing (fst subs, sub2') pi1 pi2' - | e2, Exp.Var v2 when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) - -> (* The commented-out condition should always hold. *) + | e2, Exp.Var v2 when Ident.is_primed v2 (* && not (Sil.mem_sub v2 (snd subs)) *) -> + (* The commented-out condition should always hold. *) let sub2' = extend_sub (snd subs) v2 e2 in pre_check_pure_implication tenv calc_missing (fst subs, sub2') pi1 pi2' - | _ - -> let pi1' = Prop.pi_sub (`Exp (fst subs)) pi1 in + | _ -> + let pi1' = Prop.pi_sub (`Exp (fst subs)) pi1 in let prop_for_impl = prepare_prop_for_implication tenv subs pi1' [] in imply_atom tenv calc_missing subs prop_for_impl (Sil.Aeq (e2_in, f2_in)) ; pre_check_pure_implication tenv calc_missing subs pi1 pi2' ) | (Sil.Aneq (e, _) | Apred (_, e :: _) | Anpred (_, e :: _)) :: _ - when not calc_missing && match e with Var v -> not (Ident.is_primed v) | _ -> true - -> raise + when not calc_missing && match e with Var v -> not (Ident.is_primed v) | _ -> true -> + raise (IMPL_EXC ( "ineq e2=f2 in rhs with e2 not primed var" , (Sil.exp_sub_empty, Sil.exp_sub_empty) , EXC_FALSE )) - | (Sil.Aeq _ | Aneq _ | Apred _ | Anpred _) :: pi2' - -> pre_check_pure_implication tenv calc_missing subs pi1 pi2' + | (Sil.Aeq _ | Aneq _ | Apred _ | Anpred _) :: pi2' -> + pre_check_pure_implication tenv calc_missing subs pi1 pi2' + (** Perform the array bound checks delayed (to instantiate variables) by the prover. If there is a provable violation of the array bounds, set the prover status to Bounds_check @@ -2496,24 +2588,24 @@ let check_array_bounds tenv (sub1, sub2) prop = if check_atom tenv prop lt_ineq then check_failed lt_ineq in let check_bound = function - | ProverState.BClen_imply (len1_, len2_, _indices2) - -> let len1 = Sil.exp_sub (`Exp sub1) len1_ in + | ProverState.BClen_imply (len1_, len2_, _indices2) -> + let len1 = Sil.exp_sub (`Exp sub1) len1_ in let len2 = Sil.exp_sub (`Exp sub2) len2_ in (* L.d_strln_color Orange "check_bound "; Sil.d_exp len1; L.d_str " "; Sil.d_exp len2; L.d_ln(); *) let indices_to_check = - match len2 - with _ -> [Exp.BinOp (Binop.PlusA, len2, Exp.minus_one)] + match len2 with _ -> [Exp.BinOp (Binop.PlusA, len2, Exp.minus_one)] (* only check len *) in List.iter ~f:(fail_if_le len1) indices_to_check - | ProverState.BCfrom_pre _atom - -> let atom_neg = atom_negate tenv (Sil.atom_sub (`Exp sub2) _atom) in + | ProverState.BCfrom_pre _atom -> + let atom_neg = atom_negate tenv (Sil.atom_sub (`Exp sub2) _atom) in (* L.d_strln_color Orange "BCFrom_pre"; Sil.d_atom atom_neg; L.d_ln (); *) if check_atom tenv prop atom_neg then check_failed atom_neg in List.iter ~f:check_bound (ProverState.get_bounds_checks ()) + (** [check_implication_base] returns true if [prop1|-prop2], ignoring the footprint part of the props *) let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2 = @@ -2571,14 +2663,16 @@ let check_implication_base pname tenv check_frame_empty calc_missing prop1 prop2 if check_frame_empty && frame <> [] then raise (IMPL_EXC ("frame not empty", subs, EXC_FALSE)) ; Some ((sub1, sub2), frame) with - | IMPL_EXC (s, subs, body) - -> d_impl_err (s, subs, body) ; + | IMPL_EXC (s, subs, body) -> + d_impl_err (s, subs, body) ; + None + | MISSING_EXC s -> + L.d_strln ("WARNING: footprint failed to find MISSING because: " ^ s) ; None - | MISSING_EXC s - -> L.d_strln ("WARNING: footprint failed to find MISSING because: " ^ s) ; + | Exceptions.Abduction_case_not_implemented _ as exn -> + Reporting.log_error_deprecated pname exn ; None - | Exceptions.Abduction_case_not_implemented _ as exn - -> Reporting.log_error_deprecated pname exn ; None + type implication_result = | ImplOK of @@ -2602,8 +2696,8 @@ let check_implication_for_footprint pname tenv p1 (p2: Prop.exposed Prop.t) = let check_frame_empty = false in let calc_missing = true in match check_implication_base pname tenv check_frame_empty calc_missing p1 p2 with - | Some ((sub1, sub2), frame) - -> ImplOK + | Some ((sub1, sub2), frame) -> + ImplOK ( !ProverState.checks , sub1 , sub2 @@ -2614,8 +2708,9 @@ let check_implication_for_footprint pname tenv p1 (p2: Prop.exposed Prop.t) = , ProverState.get_missing_fld () , ProverState.get_frame_typ () , ProverState.get_missing_typ () ) - | None - -> ImplFail !ProverState.checks + | None -> + ImplFail !ProverState.checks + (** [check_implication p1 p2] returns true if [p1|-p2] *) let check_implication pname tenv p1 p2 = @@ -2623,10 +2718,10 @@ let check_implication pname tenv p1 p2 = let check_frame_empty = true in let calc_missing = false in match check_implication_base pname tenv check_frame_empty calc_missing p1 p2 with - | Some _ - -> true - | None - -> false + | Some _ -> + true + | None -> + false in check p1 p2 && @@ -2634,6 +2729,7 @@ let check_implication pname tenv p1 p2 = check (Prop.normalize tenv (Prop.extract_footprint p1)) (Prop.extract_footprint p2) else true + (** {2 Cover: miminum set of pi's whose disjunction is equivalent to true} *) (** check if the pi's in [cases] cover true *) @@ -2647,13 +2743,14 @@ let is_cover tenv cases = let rec _is_cover acc_pi cases = check () ; match cases with - | [] - -> check_inconsistency_pi tenv acc_pi - | (pi, _) :: cases' - -> List.for_all ~f:(fun a -> _is_cover (atom_negate tenv a :: acc_pi) cases') pi + | [] -> + check_inconsistency_pi tenv acc_pi + | (pi, _) :: cases' -> + List.for_all ~f:(fun a -> _is_cover (atom_negate tenv a :: acc_pi) cases') pi in _is_cover [] cases + exception NO_COVER (** Find miminum set of pi's in [cases] whose disjunction covers true *) @@ -2664,23 +2761,24 @@ let find_minimum_pure_cover tenv cases = in let rec grow seen todo = match todo with - | [] - -> raise NO_COVER - | (pi, x) :: todo' - -> if is_cover tenv ((pi, x) :: seen) then (pi, x) :: seen else grow ((pi, x) :: seen) todo' + | [] -> + raise NO_COVER + | (pi, x) :: todo' -> + if is_cover tenv ((pi, x) :: seen) then (pi, x) :: seen else grow ((pi, x) :: seen) todo' in let rec _shrink seen todo = match todo with - | [] - -> seen - | (pi, x) :: todo' - -> if is_cover tenv (seen @ todo') then _shrink seen todo' + | [] -> + seen + | (pi, x) :: todo' -> + if is_cover tenv (seen @ todo') then _shrink seen todo' else _shrink ((pi, x) :: seen) todo' in let shrink cases = if List.length cases > 2 then _shrink [] cases else cases in try Some (shrink (grow [] cases)) with NO_COVER -> None + (* (** Check [prop |- e1 List.fold ~f:(fun acc' y -> (x, y) :: acc') ~init:acc l2') ~init:[] l1' + let rec list_rev_and_concat l1 l2 = match l1 with [] -> l2 | x1 :: l1' -> list_rev_and_concat l1' (x1 :: l2) + (** Check whether the index is out of bounds. If the length is - 1, no check is performed. If the index is provably out of bound, a bound error is given. @@ -70,12 +72,14 @@ let check_bad_index tenv pname p len index loc = in Reporting.log_warning_deprecated pname exn + (** Perform bounds checking *) let bounds_check tenv pname prop len e = if Config.trace_rearrange then ( L.d_str "Bounds check index:" ; Sil.d_exp e ; L.d_str " len: " ; Sil.d_exp len ; L.d_ln () ) ; check_bad_index tenv pname prop len e + let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp (t: Typ.t) (off: Sil.offset list) inst : Sil.atom list * Sil.strexp * Typ.t = if Config.trace_rearrange then ( @@ -102,14 +106,14 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp raise (Exceptions.Bad_footprint pos) in match (t.desc, off) with - | Tstruct _, [] - -> ([], Sil.Estruct ([], inst), t) + | Tstruct _, [] -> + ([], Sil.Estruct ([], inst), t) | Tstruct name, (Off_fld (f, _)) :: off' -> ( match Tenv.lookup tenv name with | Some ({fields; statics} as struct_typ) -> ( match List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f f') (fields @ statics) with - | Some (_, t', _) - -> let atoms', se', res_t' = + | Some (_, t', _) -> + let atoms', se', res_t' = create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst in let se = Sil.Estruct ([(f, se')], inst) in @@ -121,12 +125,12 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp in ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ; (atoms', se, t) - | None - -> fail t off __POS__ ) - | None - -> fail t off __POS__ ) - | Tstruct _, (Off_index e) :: off' - -> let atoms', se', res_t' = + | None -> + fail t off __POS__ ) + | None -> + fail t off __POS__ ) + | Tstruct _, (Off_index e) :: off' -> + let atoms', se', res_t' = create_struct_values pname tenv orig_prop footprint_part kind max_stamp t off' inst in let e' = Sil.array_clean_new_index footprint_part e in @@ -135,15 +139,15 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp let res_t = Typ.mk (Tarray (res_t', None, None)) in (Sil.Aeq (e, e') :: atoms', se, res_t) | Tarray (t', len_, stride_), off - -> ( + -> ( let len = match len_ with None -> Exp.Var (new_id ()) | Some len -> Exp.Const (Const.Cint len) in match off with - | [] - -> ([], Sil.Earray (len, [], inst), t) - | (Sil.Off_index e) :: off' - -> bounds_check tenv pname orig_prop len e (State.get_loc ()) ; + | [] -> + ([], Sil.Earray (len, [], inst), t) + | (Sil.Off_index e) :: off' -> + bounds_check tenv pname orig_prop len e (State.get_loc ()) ; let atoms', se', res_t' = create_struct_values pname tenv orig_prop footprint_part kind max_stamp t' off' inst in @@ -151,20 +155,20 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp let se = Sil.Earray (len, [(e', se')], inst) in let res_t = Typ.mk ~default:t (Tarray (res_t', len_, stride_)) in (Sil.Aeq (e, e') :: atoms', se, res_t) - | (Sil.Off_fld _) :: _ - -> assert false ) - | Tint _, [] | Tfloat _, [] | Tvoid, [] | Tfun _, [] | Tptr _, [] | TVar _, [] - -> let id = new_id () in + | (Sil.Off_fld _) :: _ -> + assert false ) + | Tint _, [] | Tfloat _, [] | Tvoid, [] | Tfun _, [] | Tptr _, [] | TVar _, [] -> + let id = new_id () in ([], Sil.Eexp (Exp.Var id, inst), t) - | (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _ | TVar _), (Off_index e) :: off' - -> (* In this case, we lift t to the t array. *) + | (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _ | TVar _), (Off_index e) :: off' -> + (* In this case, we lift t to the t array. *) let t', mk_typ_f = match t.Typ.desc with | Typ.Tptr (t', _) - -> ( + -> ( (t', function desc -> Typ.mk ~default:t desc) ) - | _ - -> (t, fun desc -> Typ.mk desc) + | _ -> + (t, fun desc -> Typ.mk desc) in let len = Exp.Var (new_id ()) in let atoms', se', res_t' = @@ -174,8 +178,8 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp let se = Sil.Earray (len, [(e', se')], inst) in let res_t = mk_typ_f (Tarray (res_t', None, None)) in (Sil.Aeq (e, e') :: atoms', se, res_t) - | Tint _, _ | Tfloat _, _ | Tvoid, _ | Tfun _, _ | Tptr _, _ | TVar _, _ - -> fail t off __POS__ + | Tint _, _ | Tfloat _, _ | Tvoid, _ | Tfun _, _ | Tptr _, _ | TVar _, _ -> + fail t off __POS__ in ( if Config.trace_rearrange then let _, se, _ = res in @@ -186,6 +190,7 @@ let rec create_struct_values pname tenv orig_prop footprint_part kind max_stamp L.d_ln () ) ; res + (** Extend the strexp by populating the path indicated by [off]. This means that it will add missing flds and do the case - analysis for array accesses. This does not catch the array - bounds errors. @@ -198,13 +203,13 @@ let rec _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp Ident.create kind !max_stamp in match (off, se, typ.desc) with - | [], Sil.Eexp _, _ | [], Sil.Estruct _, _ - -> [([], se, typ)] - | [], Sil.Earray _, _ - -> let off_new = Sil.Off_index Exp.zero :: off in + | [], Sil.Eexp _, _ | [], Sil.Estruct _, _ -> + [([], se, typ)] + | [], Sil.Earray _, _ -> + let off_new = Sil.Off_index Exp.zero :: off in _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst - | (Off_fld _) :: _, Sil.Earray _, Tarray _ - -> let off_new = Sil.Off_index Exp.zero :: off in + | (Off_fld _) :: _, Sil.Earray _, Tarray _ -> + let off_new = Sil.Off_index Exp.zero :: off in _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se typ off_new inst | (Off_fld (f, _)) :: off', Sil.Estruct (fsel, inst'), Tstruct name -> ( match Tenv.lookup tenv name with @@ -212,13 +217,13 @@ let rec _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp match List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f f') (fields @ statics) with | Some (_, typ', _) -> ( match List.find ~f:(fun (f', _) -> Typ.Fieldname.equal f f') fsel with - | Some (_, se') - -> let atoms_se_typ_list' = + | Some (_, se') -> + let atoms_se_typ_list' = _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se' typ' off' inst in let replace acc (res_atoms', res_se', res_typ') = - let replace_fse (f1, _ as ft1) = + let replace_fse ((f1, _) as ft1) = if Typ.Fieldname.equal f1 f then (f1, res_se') else ft1 in let res_fsel' = @@ -226,7 +231,7 @@ let rec _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp ~cmp:[%compare : Typ.Fieldname.t * Sil.strexp] (List.map ~f:replace_fse fsel) in - let replace_fta (f1, _, a1 as fta1) = + let replace_fta ((f1, _, a1) as fta1) = if Typ.Fieldname.equal f f1 then (f1, res_typ', a1) else fta1 in let fields' = @@ -236,8 +241,8 @@ let rec _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp (res_atoms', Sil.Estruct (res_fsel', inst'), typ) :: acc in List.fold ~f:replace ~init:[] atoms_se_typ_list' - | None - -> let atoms', se', res_typ' = + | None -> + let atoms', se', res_typ' = create_struct_values pname tenv orig_prop footprint_part kind max_stamp typ' off' inst in @@ -252,21 +257,21 @@ let rec _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp in ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ; [(atoms', Sil.Estruct (res_fsel', inst'), typ)] ) - | None - -> raise (Exceptions.Missing_fld (f, __POS__)) ) - | None - -> raise (Exceptions.Missing_fld (f, __POS__)) ) - | (Off_fld _) :: _, _, _ - -> raise (Exceptions.Bad_footprint __POS__) + | None -> + raise (Exceptions.Missing_fld (f, __POS__)) ) + | None -> + raise (Exceptions.Missing_fld (f, __POS__)) ) + | (Off_fld _) :: _, _, _ -> + raise (Exceptions.Bad_footprint __POS__) | (Off_index _) :: _, Sil.Eexp _, (Tint _ | Tfloat _ | Tvoid | Tfun _ | Tptr _) - | (Off_index _) :: _, Sil.Estruct _, Tstruct _ - -> (* L.d_strln_color Orange "turn into an array"; *) + | (Off_index _) :: _, Sil.Estruct _, Tstruct _ -> + (* L.d_strln_color Orange "turn into an array"; *) let len = match se with - | Sil.Eexp (_, Sil.Ialloc) - -> Exp.one (* if allocated explicitly, we know len is 1 *) - | _ - -> if Config.type_size then Exp.one (* Exp.Sizeof (typ, Subtype.exact) *) + | Sil.Eexp (_, Sil.Ialloc) -> + Exp.one (* if allocated explicitly, we know len is 1 *) + | _ -> + if Config.type_size then Exp.one (* Exp.Sizeof (typ, Subtype.exact) *) else Exp.Var (new_id ()) in let se_new = Sil.Earray (len, [(Exp.zero, se)], inst) in @@ -274,11 +279,11 @@ let rec _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se_new typ_new off inst | (Off_index e) :: off', Sil.Earray (len, esel, inst_arr), Tarray (typ', len_for_typ', stride) - -> ( + -> ( bounds_check tenv pname orig_prop len e (State.get_loc ()) ; match List.find ~f:(fun (e', _) -> Exp.equal e e') esel with - | Some (_, se') - -> let atoms_se_typ_list' = + | Some (_, se') -> + let atoms_se_typ_list' = _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se' typ' off' inst in @@ -288,15 +293,17 @@ let rec _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp if Typ.equal res_typ' typ' || Int.equal (List.length res_esel') 1 then ( res_atoms' , Sil.Earray (len, res_esel', inst_arr) - , Typ.mk ~default:typ (Tarray (res_typ', len_for_typ', stride)) ) :: acc + , Typ.mk ~default:typ (Tarray (res_typ', len_for_typ', stride)) ) + :: acc else raise (Exceptions.Bad_footprint __POS__) in List.fold ~f:replace ~init:[] atoms_se_typ_list' - | None - -> array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp len esel + | None -> + array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp len esel len_for_typ' typ' typ e off' inst_arr inst ) - | _, _, _ - -> raise (Exceptions.Bad_footprint __POS__) + | _, _, _ -> + raise (Exceptions.Bad_footprint __POS__) + and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp array_len array_cont typ_array_len typ_cont typ_array index off inst_arr inst = @@ -309,10 +316,10 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp in let array_is_full = match array_len with - | Exp.Const Const.Cint n' - -> IntLit.geq (IntLit.of_int (List.length array_cont)) n' - | _ - -> false + | Exp.Const Const.Cint n' -> + IntLit.geq (IntLit.of_int (List.length array_cont)) n' + | _ -> + false in if index_in_array then let array_default = Sil.Earray (array_len, array_cont, inst_arr) in @@ -345,10 +352,10 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp [(atoms, array_new, typ_new)] in let rec handle_case acc isel_seen_rev = function - | [] - -> List.concat (List.rev (res_new :: acc)) - | (i, se as ise) :: isel_unseen - -> let atoms_se_typ_list = + | [] -> + List.concat (List.rev (res_new :: acc)) + | ((i, se) as ise) :: isel_unseen -> + let atoms_se_typ_list = _strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se typ_cont off inst in @@ -369,21 +376,23 @@ and array_case_analysis_index pname tenv orig_prop footprint_part kind max_stamp in handle_case [] [] array_cont + let exp_has_only_footprint_ids e = let fav = Sil.exp_fav e in Sil.fav_filter_ident fav (fun id -> not (Ident.is_footprint id)) ; Sil.fav_is_empty fav + let laundry_offset_for_footprint max_stamp offs_in = let rec laundry offs_seen eqs offs = match offs with - | [] - -> (List.rev offs_seen, List.rev eqs) - | (Sil.Off_fld _ as off) :: offs' - -> let offs_seen' = off :: offs_seen in + | [] -> + (List.rev offs_seen, List.rev eqs) + | (Sil.Off_fld _ as off) :: offs' -> + let offs_seen' = off :: offs_seen in laundry offs_seen' eqs offs' - | (Sil.Off_index idx as off) :: offs' - -> if exp_has_only_footprint_ids idx then + | (Sil.Off_index idx as off) :: offs' -> + if exp_has_only_footprint_ids idx then let offs_seen' = off :: offs_seen in laundry offs_seen' eqs offs' else @@ -397,6 +406,7 @@ let laundry_offset_for_footprint max_stamp offs_in = in laundry [] [] offs_in + let strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se te (off: Sil.offset list) inst = let typ = Exp.texp_to_typ None te in @@ -427,21 +437,23 @@ let strexp_extend_values pname tenv orig_prop footprint_part kind max_stamp se t if Config.trace_rearrange then L.d_strln "exiting strexp_extend_values" ; let sizeof_data = match te with - | Exp.Sizeof sizeof_data - -> sizeof_data - | _ - -> {Exp.typ= Typ.mk Typ.Tvoid; nbytes= None; dynamic_length= None; subtype= Subtype.exact} + | Exp.Sizeof sizeof_data -> + sizeof_data + | _ -> + {Exp.typ= Typ.mk Typ.Tvoid; nbytes= None; dynamic_length= None; subtype= Subtype.exact} in List.map ~f:(fun (atoms', se', typ') -> (laundry_atoms @ atoms', se', Exp.Sizeof {sizeof_data with typ= typ'})) atoms_se_typ_list_filtered + let collect_root_offset exp = let root = Exp.root_of_lexp exp in let offsets = Sil.exp_get_offsets exp in (root, offsets) + (** Exp.Construct a points-to predicate for an expression, to add to a footprint. *) let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst : Sil.hpred * Sil.hpred * Sil.atom list = @@ -460,31 +472,31 @@ let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst let off_foot, eqs = laundry_offset_for_footprint max_stamp off in let subtype = match !Config.curr_language with - | Config.Clang - -> Subtype.exact - | Config.Java - -> Subtype.subtypes - | Config.Python - -> L.die InternalError "Subtypes for Python not implemented" + | Config.Clang -> + Subtype.exact + | Config.Java -> + Subtype.subtypes + | Config.Python -> + L.die InternalError "Subtypes for Python not implemented" in let create_ptsto footprint_part off0 = match (root, off0, typ.Typ.desc) with - | Exp.Lvar pvar, [], Typ.Tfun _ - -> let fun_name = Typ.Procname.from_string_c_fun (Mangled.to_string (Pvar.get_name pvar)) in + | Exp.Lvar pvar, [], Typ.Tfun _ -> + let fun_name = Typ.Procname.from_string_c_fun (Mangled.to_string (Pvar.get_name pvar)) in let fun_exp = Exp.Const (Const.Cfun fun_name) in ( [] , Prop.mk_ptsto tenv root (Sil.Eexp (fun_exp, inst)) (Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype}) ) - | _, [], Typ.Tfun _ - -> let atoms, se, typ = + | _, [], Typ.Tfun _ -> + let atoms, se, typ = create_struct_values pname tenv orig_prop footprint_part Ident.kfootprint max_stamp typ off0 inst in ( atoms , Prop.mk_ptsto tenv root se (Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype}) ) - | _ - -> let atoms, se, typ = + | _ -> + let atoms, se, typ = create_struct_values pname tenv orig_prop footprint_part Ident.kfootprint max_stamp typ off0 inst in @@ -498,54 +510,59 @@ let mk_ptsto_exp_footprint pname tenv orig_prop (lexp, typ) max_stamp inst let atoms' = List.map ~f:(fun (id, e) -> Prop.mk_eq tenv (Exp.Var id) e) eqs in (ptsto, ptsto_foot, atoms @ atoms') + (** Check if the path in exp exists already in the current ptsto predicate. If it exists, return None. Otherwise, return [Some fld] with [fld] the missing field. *) let prop_iter_check_fields_ptsto_shallow tenv iter lexp = let offset = Sil.exp_get_offsets lexp in let _, se, _ = match Prop.prop_iter_current tenv iter with - | Sil.Hpointsto (e, se, t), _ - -> (e, se, t) - | _ - -> assert false + | Sil.Hpointsto (e, se, t), _ -> + (e, se, t) + | _ -> + assert false in let rec check_offset se = function - | [] - -> None + | [] -> + None | (Sil.Off_fld (fld, _)) :: off' -> ( match se with | Sil.Estruct (fsel, _) -> ( match List.find ~f:(fun (fld', _) -> Typ.Fieldname.equal fld fld') fsel with - | Some (_, se') - -> check_offset se' off' - | None - -> Some fld ) - | _ - -> Some fld ) - | (Sil.Off_index _) :: _ - -> None + | Some (_, se') -> + check_offset se' off' + | None -> + Some fld ) + | _ -> + Some fld ) + | (Sil.Off_index _) :: _ -> + None in check_offset se offset + let fav_max_stamp fav = let max_stamp = ref 0 in let f id = max_stamp := max !max_stamp (Ident.get_stamp id) in List.iter ~f (Sil.fav_to_list fav) ; max_stamp + (** [prop_iter_extend_ptsto iter lexp] extends the current psto predicate in [iter] with enough fields to follow the path in [lexp] -- field splitting model. It also materializes all indices accessed in lexp. *) let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = if Config.trace_rearrange then ( - L.d_str "entering prop_iter_extend_ptsto lexp: " ; Sil.d_exp lexp ; L.d_ln () ) ; + L.d_str "entering prop_iter_extend_ptsto lexp: " ; + Sil.d_exp lexp ; + L.d_ln () ) ; let offset = Sil.exp_get_offsets lexp in let max_stamp = fav_max_stamp (Prop.prop_iter_fav iter) in let max_stamp_val = !max_stamp in let extend_footprint_pred = function - | Sil.Hpointsto (e, se, te) - -> let atoms_se_te_list = + | Sil.Hpointsto (e, se, te) -> + let atoms_se_te_list = strexp_extend_values pname tenv orig_prop true Ident.kfootprint (ref max_stamp_val) se te offset inst in @@ -554,8 +571,8 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = atoms_se_te_list | Sil.Hlseg (k, hpara, e1, e2, el) -> ( match hpara.Sil.body with - | (Sil.Hpointsto (e', se', te')) :: body_rest - -> let atoms_se_te_list = + | (Sil.Hpointsto (e', se', te')) :: body_rest -> + let atoms_se_te_list = strexp_extend_values pname tenv orig_prop true Ident.kfootprint (ref max_stamp_val) se' te' offset inst in @@ -572,10 +589,10 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = List.map ~f:(fun (atoms, hpara') -> (atoms, Sil.Hlseg (k, hpara', e1, e2, el))) atoms_hpara_list - | _ - -> assert false ) - | _ - -> assert false + | _ -> + assert false ) + | _ -> + assert false in let atoms_se_te_to_iter e (atoms, se, te) = let iter' = List.fold ~f:(Prop.prop_iter_add_atom !Config.footprint) ~init:iter atoms in @@ -596,12 +613,12 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = match e with (* Determine whether to extend the footprint part or just the normal part *) | Exp.Var id - when not (Ident.is_footprint id) - -> Ident.kprimed - | Exp.Lvar pvar when Pvar.is_local pvar - -> Ident.kprimed - | _ - -> Ident.kfootprint + when not (Ident.is_footprint id) -> + Ident.kprimed + | Exp.Lvar pvar when Pvar.is_local pvar -> + Ident.kprimed + | _ -> + Ident.kfootprint in let iter_list = let atoms_se_te_list = @@ -619,21 +636,21 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = let sigma_pto, sigma_rest = List.partition_tf ~f:(function - | Sil.Hpointsto (e', _, _) - -> Exp.equal e e' - | Sil.Hlseg (_, _, e1, _, _) - -> Exp.equal e e1 - | Sil.Hdllseg (_, _, e_iF, _, _, e_iB, _) - -> Exp.equal e e_iF || Exp.equal e e_iB) + | Sil.Hpointsto (e', _, _) -> + Exp.equal e e' + | Sil.Hlseg (_, _, e1, _, _) -> + Exp.equal e e1 + | Sil.Hdllseg (_, _, e_iF, _, _, e_iB, _) -> + Exp.equal e e_iF || Exp.equal e e_iB) footprint_sigma in let atoms_sigma_list = match sigma_pto with - | [hpred] - -> let atoms_hpred_list = extend_footprint_pred hpred in + | [hpred] -> + let atoms_hpred_list = extend_footprint_pred hpred in List.map ~f:(fun (atoms, hpred') -> (atoms, hpred' :: sigma_rest)) atoms_hpred_list - | _ - -> L.d_warning "Cannot extend " ; + | _ -> + L.d_warning "Cannot extend " ; Sil.d_exp lexp ; L.d_strln " in" ; Prop.d_prop (Prop.prop_iter_to_prop tenv iter) ; @@ -671,10 +688,11 @@ let prop_iter_extend_ptsto pname tenv orig_prop iter lexp inst = res_iter_list in match Prop.prop_iter_current tenv iter with - | Sil.Hpointsto (e, se, te), _ - -> do_extend e se te - | _ - -> assert false + | Sil.Hpointsto (e, se, te), _ -> + do_extend e se te + | _ -> + assert false + (** Add a pointsto for [root(lexp): typ] to the sigma and footprint of a prop, if it's compatible with the allowed footprint @@ -700,15 +718,16 @@ let prop_iter_add_hpred_footprint_to_prop pname tenv prop (lexp, typ) inst = let iter = match Prop.prop_iter_create prop_new with | None - -> ( + -> ( let prop_new' = Prop.normalize tenv (Prop.prop_hpred_star prop_new ptsto) in match Prop.prop_iter_create prop_new' with None -> assert false | Some iter -> iter ) - | Some iter - -> Prop.prop_iter_prev_then_insert iter ptsto + | Some iter -> + Prop.prop_iter_prev_then_insert iter ptsto in let offsets_default = Sil.exp_get_offsets lexp in Prop.prop_iter_set_state iter offsets_default + (** If [lexp] is an access to a field that is annotated with @GuardedBy, add constraints to [prop] expressing the safety conditions for the access. Complain if these conditions cannot be met. *) let add_guarded_by_constraints tenv prop lexp pdesc = @@ -732,11 +751,11 @@ let add_guarded_by_constraints tenv prop lexp pdesc = (dollar_normalize (class_str ^ ".class")) in let guarded_by_str_is_current_class guarded_by_str = function - | Typ.Procname.Java java_pname - -> (* programmers write @GuardedBy("MyClass.class") when the field is guarded by the class *) + | Typ.Procname.Java java_pname -> + (* programmers write @GuardedBy("MyClass.class") when the field is guarded by the class *) guarded_by_str_is_class guarded_by_str (Typ.Procname.java_get_class_name java_pname) - | _ - -> false + | _ -> + false in let guarded_by_str_is_class_this class_name guarded_by_str = let fully_qualified_this = Printf.sprintf "%s.this" class_name in @@ -745,30 +764,30 @@ let add_guarded_by_constraints tenv prop lexp pdesc = (* return true if [guarded_by_str] is a suffix of ".this" *) let guarded_by_str_is_super_class_this guarded_by_str pname = match pname with - | Typ.Procname.Java java_pname - -> let current_class_type_name = Typ.Procname.java_get_class_type_name java_pname in + | Typ.Procname.Java java_pname -> + let current_class_type_name = Typ.Procname.java_get_class_type_name java_pname in let comparison class_type_name _ = guarded_by_str_is_class_this (Typ.Name.to_string class_type_name) guarded_by_str in PatternMatch.supertype_exists tenv comparison current_class_type_name - | _ - -> false + | _ -> + false in (* return true if [guarded_by_str] is as suffix of ".this" *) let guarded_by_str_is_current_class_this guarded_by_str = function - | Typ.Procname.Java java_pname - -> guarded_by_str_is_class_this (Typ.Procname.java_get_class_name java_pname) guarded_by_str - | _ - -> false + | Typ.Procname.Java java_pname -> + guarded_by_str_is_class_this (Typ.Procname.java_get_class_name java_pname) guarded_by_str + | _ -> + false in let extract_guarded_by_str item_annot = let annot_extract_guarded_by_str ((annot: Annot.t), _) = if Annotations.annot_ends_with annot Annotations.guarded_by then match annot.parameters with - | [guarded_by_str] when not (excluded_guardedby_string guarded_by_str) - -> Some guarded_by_str - | _ - -> None + | [guarded_by_str] when not (excluded_guardedby_string guarded_by_str) -> + Some guarded_by_str + | _ -> + None else None in List.find_map ~f:annot_extract_guarded_by_str item_annot @@ -786,13 +805,13 @@ let add_guarded_by_constraints tenv prop lexp pdesc = match Typ.Struct.get_field_type_and_annotation ~lookup fld typ with | Some (_, item_annot) -> ( match extract_guarded_by_str item_annot with - | Some "this" - -> (* expand "this" into .this *) + | Some "this" -> + (* expand "this" into .this *) Some (Printf.sprintf "%s.this" (Typ.Fieldname.java_get_class fld)) - | guarded_by_str_opt - -> guarded_by_str_opt ) - | _ - -> None + | guarded_by_str_opt -> + guarded_by_str_opt ) + | _ -> + None in (* find A.guarded_by_fld_str |-> B and return Some B, or None if there is no such hpred *) let find_guarded_by_exp guarded_by_str0 sigma = @@ -805,10 +824,10 @@ let add_guarded_by_constraints tenv prop lexp pdesc = let get_fld_strexp_and_typ typ f flds = let match_one (fld, strexp) = match Typ.Struct.get_field_type_and_annotation ~lookup fld typ with - | Some (fld_typ, _) when f fld fld_typ - -> Some (strexp, fld_typ) - | _ - -> None + | Some (fld_typ, _) when f fld fld_typ -> + Some (strexp, fld_typ) + | _ -> + None in List.find_map ~f:match_one flds in @@ -818,58 +837,58 @@ let add_guarded_by_constraints tenv prop lexp pdesc = let match_on_field_type typ flds = match String.rsplit2 guarded_by_str0 ~on:'.' with | Some (class_part, field_part) - -> ( + -> ( let typ_matches_guarded_by _ {Typ.desc} = match desc with - | Typ.Tptr (ptr_typ, _) - -> String.is_suffix ~suffix:class_part (Typ.to_string ptr_typ) - | _ - -> false + | Typ.Tptr (ptr_typ, _) -> + String.is_suffix ~suffix:class_part (Typ.to_string ptr_typ) + | _ -> + false in match get_fld_strexp_and_typ typ typ_matches_guarded_by flds with - | Some (Sil.Eexp (matching_exp, _), _) - -> List.find_map + | Some (Sil.Eexp (matching_exp, _), _) -> + List.find_map ~f:(function | Sil.Hpointsto (lhs_exp, Estruct (matching_flds, _), Sizeof {typ= fld_typ}) - when Exp.equal lhs_exp matching_exp - -> get_fld_strexp_and_typ fld_typ (is_guarded_by_fld field_part) matching_flds - | _ - -> None) + when Exp.equal lhs_exp matching_exp -> + get_fld_strexp_and_typ fld_typ (is_guarded_by_fld field_part) matching_flds + | _ -> + None) sigma - | _ - -> None ) - | _ - -> None + | _ -> + None ) + | _ -> + None in List.find_map ~f:(fun hpred -> - match[@warning "-57"] (* FIXME: silenced warning may be legit *) hpred with + ( match[@warning "-57"] (* FIXME: silenced warning may be legit *) hpred with | Sil.Hpointsto ((Const Cclass clazz as lhs_exp), _, Exp.Sizeof {typ}) | Sil.Hpointsto (_, Sil.Eexp ((Const Cclass clazz as lhs_exp), _), Exp.Sizeof {typ}) - when guarded_by_str_is_class guarded_by_str0 (Ident.name_to_string clazz) - -> Some (Sil.Eexp (lhs_exp, Sil.inst_none), typ) + when guarded_by_str_is_class guarded_by_str0 (Ident.name_to_string clazz) -> + Some (Sil.Eexp (lhs_exp, Sil.inst_none), typ) | Sil.Hpointsto (_, Estruct (flds, _), Exp.Sizeof {typ}) -> ( match (* first, try to find a field that exactly matches the guarded-by string *) get_fld_strexp_and_typ typ (is_guarded_by_fld guarded_by_str0) flds with - | None when guarded_by_str_is_this guarded_by_str0 - -> (* if the guarded-by string is "OuterClass.this", look for "this$n" for some n. + | None when guarded_by_str_is_this guarded_by_str0 -> + (* if the guarded-by string is "OuterClass.this", look for "this$n" for some n. note that this is a bit sketchy when there are mutliple this$n's, but there's nothing we can do to disambiguate them. *) get_fld_strexp_and_typ typ (fun f _ -> Typ.Fieldname.java_is_outer_instance f) flds - | None - -> (* can't find an exact match. try a different convention. *) + | None -> + (* can't find an exact match. try a different convention. *) match_on_field_type typ flds - | Some _ as res_opt - -> res_opt ) + | Some _ as res_opt -> + res_opt ) | Sil.Hpointsto (Lvar pvar, rhs_exp, Exp.Sizeof {typ}) when ( guarded_by_str_is_current_class_this guarded_by_str0 pname || guarded_by_str_is_super_class_this guarded_by_str0 pname ) - && Pvar.is_this pvar - -> Some (rhs_exp, typ) - | _ - -> None) + && Pvar.is_this pvar -> + Some (rhs_exp, typ) + | _ -> + None )) sigma in (* warn if the access to [lexp] is not protected by the [guarded_by_fld_str] lock *) @@ -877,11 +896,11 @@ let add_guarded_by_constraints tenv prop lexp pdesc = (* return true if [pdesc] has an annotation that matches [guarded_by_str] *) let proc_has_matching_annot pdesc guarded_by_str = match extract_guarded_by_str (Annotations.pdesc_get_return_annot pdesc) with - | Some proc_guarded_by_str - -> (* the lock is not held, but the procedure is annotated with @GuardedBy *) + | Some proc_guarded_by_str -> + (* the lock is not held, but the procedure is annotated with @GuardedBy *) String.equal proc_guarded_by_str guarded_by_str - | None - -> false + | None -> + false in let is_synchronized_on_class guarded_by_str = guarded_by_str_is_current_class guarded_by_str pname && Procdesc.is_java_synchronized pdesc @@ -899,12 +918,12 @@ let add_guarded_by_constraints tenv prop lexp pdesc = || String.is_suffix ~suffix:"ReadWriteLock" str in match typ.Typ.desc with - | Typ.Tstruct name - -> str_is_read_write_lock (Typ.Name.name name) - | Typ.Tptr (typ, _) - -> is_read_write_lock typ - | _ - -> false + | Typ.Tstruct name -> + str_is_read_write_lock (Typ.Name.name name) + | Typ.Tptr (typ, _) -> + is_read_write_lock typ + | _ -> + false in let has_lock guarded_by_exp = ( guarded_by_str_is_current_class_this guarded_by_str pname @@ -923,10 +942,10 @@ let add_guarded_by_constraints tenv prop lexp pdesc = in let proc_has_suppress_guarded_by_annot pdesc = match extract_suppress_warnings_str (Annotations.pdesc_get_return_annot pdesc) with - | Some suppression_str - -> String.equal suppression_str "InvalidAccessToGuardedField" - | None - -> false + | Some suppression_str -> + String.equal suppression_str "InvalidAccessToGuardedField" + | None -> + false in let should_warn pdesc = (* adding this check implements "by reference" semantics for guarded-by rather than "by value" @@ -936,19 +955,19 @@ let add_guarded_by_constraints tenv prop lexp pdesc = let is_accessible_through_local_ref exp = List.exists ~f:(function - | Sil.Hpointsto (Lvar _, Eexp (rhs_exp, _), _) - -> Exp.equal exp rhs_exp - | Sil.Hpointsto (_, Estruct (flds, _), _) - -> List.exists + | Sil.Hpointsto (Lvar _, Eexp (rhs_exp, _), _) -> + Exp.equal exp rhs_exp + | Sil.Hpointsto (_, Estruct (flds, _), _) -> + List.exists ~f:(fun (fld, strexp) -> match strexp with - | Sil.Eexp (rhs_exp, _) - -> Exp.equal exp rhs_exp && not (Typ.Fieldname.equal fld accessed_fld) - | _ - -> false) + | Sil.Eexp (rhs_exp, _) -> + Exp.equal exp rhs_exp && not (Typ.Fieldname.equal fld accessed_fld) + | _ -> + false) flds - | _ - -> false) + | _ -> + false) prop.Prop.sigma in Procdesc.get_access pdesc <> PredSymb.Private @@ -958,8 +977,8 @@ let add_guarded_by_constraints tenv prop lexp pdesc = && not (proc_has_suppress_guarded_by_annot pdesc) in match find_guarded_by_exp guarded_by_str prop.Prop.sigma with - | Some (Sil.Eexp (guarded_by_exp, _), typ) - -> if is_read_write_lock typ then + | Some (Sil.Eexp (guarded_by_exp, _), typ) -> + if is_read_write_lock typ then (* TODO: model/understand read-write locks rather than ignoring them *) prop else if has_lock guarded_by_exp then @@ -974,8 +993,8 @@ let add_guarded_by_constraints tenv prop lexp pdesc = else (* private method. add locked proof obligation to [pdesc] *) Attribute.add tenv ~footprint:true prop Alocked [guarded_by_exp] - | _ - -> if not + | _ -> + if not ( proc_has_matching_annot pdesc guarded_by_str || is_synchronized_on_class guarded_by_str ) && should_warn pdesc @@ -991,32 +1010,33 @@ let add_guarded_by_constraints tenv prop lexp pdesc = in let enforce_guarded_access fld typ prop = match get_guarded_by_fld_str fld typ with - | Some guarded_by_fld_str - -> enforce_guarded_access_ fld guarded_by_fld_str prop - | None - -> prop + | Some guarded_by_fld_str -> + enforce_guarded_access_ fld guarded_by_fld_str prop + | None -> + prop in let check_fld_locks typ prop_acc (fld, strexp) = match strexp with - | Sil.Eexp (exp, _) when Exp.equal exp lexp - -> enforce_guarded_access fld typ prop_acc - | _ - -> prop_acc + | Sil.Eexp (exp, _) when Exp.equal exp lexp -> + enforce_guarded_access fld typ prop_acc + | _ -> + prop_acc in let hpred_check_flds prop_acc = function - | Sil.Hpointsto (_, Estruct (flds, _), Sizeof {typ}) - -> List.fold ~f:(check_fld_locks typ) ~init:prop_acc flds - | _ - -> prop_acc + | Sil.Hpointsto (_, Estruct (flds, _), Sizeof {typ}) -> + List.fold ~f:(check_fld_locks typ) ~init:prop_acc flds + | _ -> + prop_acc in match lexp with - | Exp.Lfield (_, fld, typ) - -> (* check for direct access to field annotated with @GuardedBy *) + | Exp.Lfield (_, fld, typ) -> + (* check for direct access to field annotated with @GuardedBy *) enforce_guarded_access fld typ prop - | _ - -> (* check for access via alias *) + | _ -> + (* check for access via alias *) List.fold ~f:hpred_check_flds ~init:prop prop.Prop.sigma + (** Add a pointsto for [root(lexp): typ] to the iterator and to the footprint, if it's compatible with the allowed footprint variables. This function ensures that [root(lexp): typ] is the @@ -1047,6 +1067,7 @@ let prop_iter_add_hpred_footprint pname tenv orig_prop iter (lexp, typ) inst = let offsets_default = Sil.exp_get_offsets lexp in Prop.prop_iter_set_state iter' offsets_default + exception ARRAY_ACCESS let rearrange_arith tenv lexp prop = @@ -1066,6 +1087,7 @@ let rearrange_arith tenv lexp prop = if Prover.check_allocatedness tenv prop root then raise ARRAY_ACCESS else raise (Exceptions.Symexec_memory_error __POS__) + let pp_rearrangement_error message prop lexp = L.d_strln (".... Rearrangement Error .... " ^ message) ; L.d_str "Exp:" ; @@ -1077,6 +1099,7 @@ let pp_rearrangement_error message prop lexp = L.d_ln () ; L.d_ln () + (** do re-arrangment for an iter whose current element is a pointsto *) let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst = if Config.trace_rearrange then ( @@ -1094,10 +1117,10 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst = L.d_ln () ) ; let check_field_splitting () = match prop_iter_check_fields_ptsto_shallow tenv iter lexp with - | None - -> () - | Some fld - -> pp_rearrangement_error "field splitting check failed" orig_prop lexp ; + | None -> + () + | Some fld -> + pp_rearrangement_error "field splitting check failed" orig_prop lexp ; raise (Exceptions.Missing_fld (fld, __POS__)) in let res = @@ -1105,8 +1128,8 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst = else ( check_field_splitting () ; match Prop.prop_iter_current tenv iter with - | Sil.Hpointsto (e, se, te), offset - -> let max_stamp = fav_max_stamp (Prop.prop_iter_fav iter) in + | Sil.Hpointsto (e, se, te), offset -> + let max_stamp = fav_max_stamp (Prop.prop_iter_fav iter) in let atoms_se_te_list = strexp_extend_values pname tenv orig_prop false Ident.kprimed max_stamp se te offset inst @@ -1122,8 +1145,8 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst = not (Prover.check_inconsistency tenv p) in List.filter ~f:filter (List.map ~f:handle_case atoms_se_te_list) - | _ - -> [iter] ) + | _ -> + [iter] ) in if Config.trace_rearrange then ( L.d_strln "exiting iter_rearrange_ptsto, returning results" ; @@ -1133,6 +1156,7 @@ let iter_rearrange_ptsto pname tenv orig_prop iter lexp inst = L.d_ln () ) ; res + (** do re-arrangment for an iter whose current element is a nonempty listseg *) let iter_rearrange_ne_lseg tenv recurse_on_iters iter para e1 e2 elist = if Config.nelseg then @@ -1156,6 +1180,7 @@ let iter_rearrange_ne_lseg tenv recurse_on_iters iter para e1 e2 elist = in recurse_on_iters [iter_inductive_case] + (** do re-arrangment for an iter whose current element is a nonempty dllseg to be unrolled from lhs *) let iter_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist = let iter_inductive_case = @@ -1175,6 +1200,7 @@ let iter_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3 in recurse_on_iters [iter_inductive_case; iter_base_case] + (** do re-arrangment for an iter whose current element is a nonempty dllseg to be unrolled from rhs *) let iter_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist = let iter_inductive_case = @@ -1194,6 +1220,7 @@ let iter_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e in recurse_on_iters [iter_inductive_case; iter_base_case] + (** do re-arrangment for an iter whose current element is a possibly empty listseg *) let iter_rearrange_pe_lseg tenv recurse_on_iters default_case_iter iter para e1 e2 elist = let iter_nonemp_case = @@ -1206,14 +1233,15 @@ let iter_rearrange_pe_lseg tenv recurse_on_iters default_case_iter iter para e1 let removed_prop = Prop.prop_iter_remove_curr_then_to_prop tenv iter in let prop' = Prop.conjoin_eq tenv ~footprint:!Config.footprint e1 e2 removed_prop in match Prop.prop_iter_create prop' with - | None - -> let iter' = default_case_iter (Prop.prop_iter_set_state iter ()) in + | None -> + let iter' = default_case_iter (Prop.prop_iter_set_state iter ()) in [Prop.prop_iter_set_state iter' ()] - | Some iter' - -> [iter_nonemp_case; iter'] + | Some iter' -> + [iter_nonemp_case; iter'] in recurse_on_iters iter_subcases + (** do re-arrangment for an iter whose current element is a possibly empty dllseg to be unrolled from lhs *) let iter_rearrange_pe_dllseg_first tenv recurse_on_iters default_case_iter iter para_dll e1 e2 e3 e4 elist = @@ -1230,14 +1258,15 @@ let iter_rearrange_pe_dllseg_first tenv recurse_on_iters default_case_iter iter let prop' = Prop.conjoin_eq tenv ~footprint:!Config.footprint e1 e3 removed_prop in let prop'' = Prop.conjoin_eq tenv ~footprint:!Config.footprint e2 e4 prop' in match Prop.prop_iter_create prop'' with - | None - -> let iter' = default_case_iter (Prop.prop_iter_set_state iter ()) in + | None -> + let iter' = default_case_iter (Prop.prop_iter_set_state iter ()) in [Prop.prop_iter_set_state iter' ()] - | Some iter' - -> [iter_inductive_case; iter'] + | Some iter' -> + [iter_inductive_case; iter'] in recurse_on_iters iter_subcases + (** do re-arrangment for an iter whose current element is a possibly empty dllseg to be unrolled from rhs *) let iter_rearrange_pe_dllseg_last tenv recurse_on_iters default_case_iter iter para_dll e1 e2 e3 e4 elist = @@ -1254,37 +1283,39 @@ let iter_rearrange_pe_dllseg_last tenv recurse_on_iters default_case_iter iter p let prop' = Prop.conjoin_eq tenv ~footprint:!Config.footprint e1 e3 removed_prop in let prop'' = Prop.conjoin_eq tenv ~footprint:!Config.footprint e2 e4 prop' in match Prop.prop_iter_create prop'' with - | None - -> let iter' = default_case_iter (Prop.prop_iter_set_state iter ()) in + | None -> + let iter' = default_case_iter (Prop.prop_iter_set_state iter ()) in [Prop.prop_iter_set_state iter' ()] - | Some iter' - -> [iter_inductive_case; iter'] + | Some iter' -> + [iter_inductive_case; iter'] in recurse_on_iters iter_subcases + (** find the type at the offset from the given type expression, if any *) let type_at_offset tenv texp off = let rec strip_offset (off: Sil.offset list) (typ: Typ.t) = match (off, typ.desc) with - | [], _ - -> Some typ + | [], _ -> + Some typ | (Off_fld (f, _)) :: off', Tstruct name -> ( match Tenv.lookup tenv name with | Some {fields} -> ( match List.find ~f:(fun (f', _, _) -> Typ.Fieldname.equal f f') fields with - | Some (_, typ', _) - -> strip_offset off' typ' - | None - -> None ) - | None - -> None ) - | (Off_index _) :: off', Tarray (typ', _, _) - -> strip_offset off' typ' - | _ - -> None + | Some (_, typ', _) -> + strip_offset off' typ' + | None -> + None ) + | None -> + None ) + | (Off_index _) :: off', Tarray (typ', _, _) -> + strip_offset off' typ' + | _ -> + None in match texp with Exp.Sizeof {typ} -> strip_offset off typ | _ -> None + (** Check that the size of a type coming from an instruction does not exceed the size of the type from the pointsto predicate For example, that a pointer to int is not used to assign to a char *) let check_type_size tenv pname prop texp off typ_from_instr = @@ -1296,8 +1327,8 @@ let check_type_size tenv pname prop texp off typ_from_instr = Typ.d_full typ_from_instr ; L.d_ln () ; match type_at_offset tenv texp off with - | Some typ_of_object - -> L.d_str "typ_o: " ; + | Some typ_of_object -> + L.d_str "typ_o: " ; Typ.d_full typ_of_object ; L.d_ln () ; if Prover.type_size_comparable typ_from_instr typ_of_object @@ -1310,8 +1341,9 @@ let check_type_size tenv pname prop texp off typ_from_instr = (Errdesc.explain_dereference pname tenv deref_str prop loc, __POS__) in Reporting.log_warning_deprecated pname exn - | None - -> L.d_str "texp: " ; Sil.d_texp_full texp ; L.d_ln () + | None -> + L.d_str "texp: " ; Sil.d_texp_full texp ; L.d_ln () + (** Exposes lexp |->- from iter. In case that it is not possible to * expose lexp |->-, this function prints an error message and @@ -1327,8 +1359,8 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst let rec root_typ_of_offsets = function | (Sil.Off_fld (f, fld_typ)) :: _ -> ( match fld_typ.desc with - | Tstruct _ - -> (* access through field: get the struct type from the field *) + | Tstruct _ -> + (* access through field: get the struct type from the field *) if Config.trace_rearrange then ( L.d_increase_indent 1 ; L.d_str "iter_rearrange: root of lexp accesses field " ; @@ -1339,12 +1371,12 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst L.d_decrease_indent 1 ; L.d_ln () ) ; fld_typ - | _ - -> typ_from_instr ) - | (Sil.Off_index _) :: off - -> Typ.mk (Tarray (root_typ_of_offsets off, None, None)) - | _ - -> typ_from_instr + | _ -> + typ_from_instr ) + | (Sil.Off_index _) :: off -> + Typ.mk (Tarray (root_typ_of_offsets off, None, None)) + | _ -> + typ_from_instr in let typ = root_typ_of_offsets (Sil.exp_get_offsets lexp) in if Config.trace_rearrange then ( @@ -1384,55 +1416,55 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst iter_rearrange pname tenv (Prop.lexp_normalize_prop tenv prop' lexp) typ prop' iter' inst in let rec f_many_iters iters_lst = function - | [] - -> List.concat (List.rev iters_lst) - | iter' :: iters' - -> let iters_res' = f_one_iter iter' in + | [] -> + List.concat (List.rev iters_lst) + | iter' :: iters' -> + let iters_res' = f_one_iter iter' in f_many_iters (iters_res' :: iters_lst) iters' in f_many_iters [] iters in let filter = function - | Sil.Hpointsto (base, _, _) | Sil.Hlseg (_, _, base, _, _) - -> Prover.is_root tenv prop base lexp - | Sil.Hdllseg (_, _, first, _, _, last, _) - -> let result_first = Prover.is_root tenv prop first lexp in + | Sil.Hpointsto (base, _, _) | Sil.Hlseg (_, _, base, _, _) -> + Prover.is_root tenv prop base lexp + | Sil.Hdllseg (_, _, first, _, _, last, _) -> + let result_first = Prover.is_root tenv prop first lexp in match result_first with - | None - -> Prover.is_root tenv prop last lexp - | Some _ - -> result_first + | None -> + Prover.is_root tenv prop last lexp + | Some _ -> + result_first in let res = match Prop.prop_iter_find iter filter with - | None - -> [default_case_iter iter] + | None -> + [default_case_iter iter] | Some iter -> match Prop.prop_iter_current tenv iter with - | Sil.Hpointsto (_, _, texp), off - -> if Config.type_size then check_type_size tenv pname prop texp off typ_from_instr ; + | Sil.Hpointsto (_, _, texp), off -> + if Config.type_size then check_type_size tenv pname prop texp off typ_from_instr ; iter_rearrange_ptsto pname tenv prop iter lexp inst - | Sil.Hlseg (Sil.Lseg_NE, para, e1, e2, elist), _ - -> iter_rearrange_ne_lseg tenv recurse_on_iters iter para e1 e2 elist - | Sil.Hlseg (Sil.Lseg_PE, para, e1, e2, elist), _ - -> iter_rearrange_pe_lseg tenv recurse_on_iters default_case_iter iter para e1 e2 elist + | Sil.Hlseg (Sil.Lseg_NE, para, e1, e2, elist), _ -> + iter_rearrange_ne_lseg tenv recurse_on_iters iter para e1 e2 elist + | Sil.Hlseg (Sil.Lseg_PE, para, e1, e2, elist), _ -> + iter_rearrange_pe_lseg tenv recurse_on_iters default_case_iter iter para e1 e2 elist | Sil.Hdllseg (Sil.Lseg_NE, para_dll, e1, e2, e3, e4, elist), _ -> ( match (Prover.is_root tenv prop e1 lexp, Prover.is_root tenv prop e4 lexp) with - | None, None - -> assert false - | Some _, _ - -> iter_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist - | _, Some _ - -> iter_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist ) + | None, None -> + assert false + | Some _, _ -> + iter_rearrange_ne_dllseg_first tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist + | _, Some _ -> + iter_rearrange_ne_dllseg_last tenv recurse_on_iters iter para_dll e1 e2 e3 e4 elist ) | Sil.Hdllseg (Sil.Lseg_PE, para_dll, e1, e2, e3, e4, elist), _ -> match (Prover.is_root tenv prop e1 lexp, Prover.is_root tenv prop e4 lexp) with - | None, None - -> assert false - | Some _, _ - -> iter_rearrange_pe_dllseg_first tenv recurse_on_iters default_case_iter iter para_dll e1 + | None, None -> + assert false + | Some _, _ -> + iter_rearrange_pe_dllseg_first tenv recurse_on_iters default_case_iter iter para_dll e1 e2 e3 e4 elist - | _, Some _ - -> iter_rearrange_pe_dllseg_last tenv recurse_on_iters default_case_iter iter para_dll e1 + | _, Some _ -> + iter_rearrange_pe_dllseg_last tenv recurse_on_iters default_case_iter iter para_dll e1 e2 e3 e4 elist in if Config.trace_rearrange then ( @@ -1443,20 +1475,22 @@ let rec iter_rearrange pname tenv lexp typ_from_instr prop iter inst L.d_ln () ) ; res + let is_weak_captured_var pdesc var_name = let pname = Procdesc.get_proc_name pdesc in match pname with - | Block _ - -> let is_weak_captured (var, typ) = + | Block _ -> + let is_weak_captured (var, typ) = match typ.Typ.desc with - | Typ.Tptr (_, Pk_objc_weak) - -> String.equal var_name (Mangled.to_string var) - | _ - -> false + | Typ.Tptr (_, Pk_objc_weak) -> + String.equal var_name (Mangled.to_string var) + | _ -> + false in List.exists ~f:is_weak_captured (Procdesc.get_captured pdesc) - | _ - -> false + | _ -> + false + let var_has_annotation ?(check_weak_captured_var= false) pdesc is_annotation pvar = let is_weak_captured_var = is_weak_captured_var pdesc (Pvar.to_string pvar) in @@ -1464,33 +1498,36 @@ let var_has_annotation ?(check_weak_captured_var= false) pdesc is_annotation pva AnnotatedSignature.param_has_annot is_annotation pvar ann_sig || check_weak_captured_var && is_weak_captured_var + let attr_has_annot is_annotation tenv prop exp = let attr_has_annot = function | Sil.Apred ((Aretval (pname, ret_attr) | Aundef (pname, ret_attr, _, _)), _) - when is_annotation ret_attr - -> Some (Typ.Procname.to_string pname) - | _ - -> None + when is_annotation ret_attr -> + Some (Typ.Procname.to_string pname) + | _ -> + None in try List.find_map ~f:attr_has_annot (Attribute.get_for_exp tenv prop exp) with Not_found -> None + let is_strexp_pt_fld_with_annot tenv obj_str is_annotation typ deref_exp (fld, strexp) = let lookup = Tenv.lookup tenv in let fld_has_annot fld = match Typ.Struct.get_field_type_and_annotation ~lookup fld typ with - | Some (_, annot) - -> is_annotation annot - | _ - -> false + | Some (_, annot) -> + is_annotation annot + | _ -> + false in match strexp with - | Sil.Eexp ((Exp.Var _ as exp), _) when Exp.equal exp deref_exp - -> let has_annot = fld_has_annot fld in + | Sil.Eexp ((Exp.Var _ as exp), _) when Exp.equal exp deref_exp -> + let has_annot = fld_has_annot fld in if has_annot then obj_str := Some (Typ.Fieldname.to_simplified_string fld) ; has_annot - | _ - -> true + | _ -> + true + (* This returns true if the exp is pointed to only by fields or parameters with a given annotation. In that case it also returns a string representation of the annotation @@ -1501,8 +1538,8 @@ let is_only_pt_by_fld_or_param_with_annot ?(check_weak_captured_var= false) pdes let is_pt_by_fld_or_param_with_annot hpred = match hpred with | Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp ((Exp.Var _ as exp), _), _) - when Exp.equal exp deref_exp - -> let var_has_annotation = + when Exp.equal exp deref_exp -> + let var_has_annotation = Pvar.is_seed pvar && var_has_annotation ~check_weak_captured_var pdesc is_annotation pvar in if var_has_annotation then obj_str := Some (Pvar.to_string pvar) ; @@ -1510,23 +1547,26 @@ let is_only_pt_by_fld_or_param_with_annot ?(check_weak_captured_var= false) pdes if Option.is_some procname_str_opt then obj_str := procname_str_opt ; (* it's ok for a local with no annotation to point to deref_exp *) var_has_annotation || Option.is_some procname_str_opt || Pvar.is_local pvar - | Sil.Hpointsto (_, Sil.Estruct (flds, _), Exp.Sizeof {typ}) - -> List.for_all ~f:(is_strexp_pt_fld_with_annot tenv obj_str is_annotation typ deref_exp) flds - | _ - -> true + | Sil.Hpointsto (_, Sil.Estruct (flds, _), Exp.Sizeof {typ}) -> + List.for_all ~f:(is_strexp_pt_fld_with_annot tenv obj_str is_annotation typ deref_exp) flds + | _ -> + true in if List.for_all ~f:is_pt_by_fld_or_param_with_annot prop.Prop.sigma && !obj_str <> None then !obj_str else None + let is_only_pt_by_fld_or_param_nullable pdesc tenv prop deref_exp = is_only_pt_by_fld_or_param_with_annot ~check_weak_captured_var:true pdesc tenv prop deref_exp Annotations.ia_is_nullable + let is_only_pt_by_fld_or_param_nonnull pdesc tenv prop deref_exp = Option.is_some (is_only_pt_by_fld_or_param_with_annot pdesc tenv prop deref_exp Annotations.ia_is_nonnull) + (** Check for dereference errors: dereferencing 0, a freed value, or an undefined value *) let check_dereference_error tenv pdesc (prop: Prop.normal Prop.t) lexp loc = let pname = Procdesc.get_proc_name pdesc in @@ -1540,8 +1580,8 @@ let check_dereference_error tenv pdesc (prop: Prop.normal Prop.t) lexp loc = let relevant_attributes_getters = [Attribute.get_resource tenv; Attribute.get_undef tenv] in let get_relevant_attributes exp = let rec fold_getters = function - | [] - -> None + | [] -> + None | getter :: tl -> match getter prop exp with Some _ as some_attr -> some_attr | None -> fold_getters tl in @@ -1549,16 +1589,16 @@ let check_dereference_error tenv pdesc (prop: Prop.normal Prop.t) lexp loc = in let attribute_opt = match get_relevant_attributes root with - | Some att - -> Some att - | None - -> (* try to remove an offset if any, and find the attribute there *) + | Some att -> + Some att + | None -> + (* try to remove an offset if any, and find the attribute there *) let root_no_offset = match root with - | Exp.BinOp ((Binop.PlusPI | Binop.PlusA | Binop.MinusPI | Binop.MinusA), base, _) - -> base - | _ - -> root + | Exp.BinOp ((Binop.PlusPI | Binop.PlusA | Binop.MinusPI | Binop.MinusA), base, _) -> + base + | _ -> + root in get_relevant_attributes root_no_offset in @@ -1566,12 +1606,12 @@ let check_dereference_error tenv pdesc (prop: Prop.normal Prop.t) lexp loc = let deref_str = if is_deref_of_nullable then match nullable_var_opt with - | Some str - -> if is_weak_captured_var pdesc str then + | Some str -> + if is_weak_captured_var pdesc str then Localise.deref_str_weak_variable_in_block None str else Localise.deref_str_nullable None str - | None - -> Localise.deref_str_nullable None "" + | None -> + Localise.deref_str_nullable None "" else Localise.deref_str_null None in let err_desc = @@ -1588,34 +1628,35 @@ let check_dereference_error tenv pdesc (prop: Prop.normal Prop.t) lexp loc = raise (Exceptions.Empty_vector_access (err_desc, __POS__)) else raise (Exceptions.Null_dereference (err_desc, __POS__)) ) ; match attribute_opt with - | Some Apred (Adangling dk, _) - -> let deref_str = Localise.deref_str_dangling (Some dk) in + | Some Apred (Adangling dk, _) -> + let deref_str = Localise.deref_str_dangling (Some dk) in let err_desc = Errdesc.explain_dereference pname tenv deref_str prop (State.get_loc ()) in raise (Exceptions.Dangling_pointer_dereference (Some dk, err_desc, __POS__)) - | Some Apred (Aundef _, _) - -> () - | Some Apred (Aresource ({ra_kind= Rrelease} as ra), _) - -> let deref_str = Localise.deref_str_freed ra in + | Some Apred (Aundef _, _) -> + () + | Some Apred (Aresource ({ra_kind= Rrelease} as ra), _) -> + let deref_str = Localise.deref_str_freed ra in let err_desc = Errdesc.explain_dereference pname tenv ~use_buckets:true deref_str prop loc in raise (Exceptions.Use_after_free (err_desc, __POS__)) - | _ - -> if Prover.check_equal tenv Prop.prop_emp (Exp.root_of_lexp root) Exp.minus_one then + | _ -> + if Prover.check_equal tenv Prop.prop_emp (Exp.root_of_lexp root) Exp.minus_one then let deref_str = Localise.deref_str_dangling None in let err_desc = Errdesc.explain_dereference pname tenv deref_str prop loc in raise (Exceptions.Dangling_pointer_dereference (None, err_desc, __POS__)) + (* Check that an expression representin an objc block can be null and raise a [B1] null exception.*) (* It's used to check that we don't call possibly null blocks *) let check_call_to_objc_block_error tenv pdesc prop fun_exp loc = let pname = Procdesc.get_proc_name pdesc in let is_this = function - | Exp.Lvar pvar - -> let {ProcAttributes.is_objc_instance_method; is_cpp_instance_method} = + | Exp.Lvar pvar -> + let {ProcAttributes.is_objc_instance_method; is_cpp_instance_method} = Procdesc.get_attributes pdesc in is_objc_instance_method && Pvar.is_self pvar || is_cpp_instance_method && Pvar.is_this pvar - | _ - -> false + | _ -> + false in let fun_exp_may_be_null () = (* may be null if we don't know if it is definitely not null *) @@ -1626,42 +1667,42 @@ let check_call_to_objc_block_error tenv pdesc prop fun_exp loc = match e with | Exp.Var id -> ( match Errdesc.find_ident_assignment (State.get_node ()) id with - | Some (_, e') - -> e' - | None - -> e ) - | _ - -> e + | Some (_, e') -> + e' + | None -> + e ) + | _ -> + e in let get_exp_called () = (* Exp called in the block's function call*) match State.get_instr () with - | Some Sil.Call (_, Exp.Var id, _, _, _) - -> Errdesc.find_ident_assignment (State.get_node ()) id - | _ - -> None + | Some Sil.Call (_, Exp.Var id, _, _, _) -> + Errdesc.find_ident_assignment (State.get_node ()) id + | _ -> + None in let is_fun_exp_captured_var () = (* Called expression is a captured variable of the block *) match get_exp_called () with - | Some (_, Exp.Lvar pvar) - -> (* pvar is the block *) + | Some (_, Exp.Lvar pvar) -> + (* pvar is the block *) let name = Pvar.get_name pvar in List.exists ~f:(fun (cn, _) -> Mangled.equal name cn) (Procdesc.get_captured pdesc) - | _ - -> false + | _ -> + false in let is_field_deref () = (*Called expression is a field *) match get_exp_called () with - | Some (_, Exp.Lfield (e', fn, t)) - -> let e'' = try_explaining_exp e' in + | Some (_, Exp.Lfield (e', fn, t)) -> + let e'' = try_explaining_exp e' in (Some (Exp.Lfield (e'', fn, t)), true) (* the block dereferences is a field of an object*) - | Some (_, e) - -> (Some e, false) - | _ - -> (None, false) + | Some (_, e) -> + (Some e, false) + | _ -> + (None, false) in if Config.curr_language_is Config.Clang && fun_exp_may_be_null () && not (is_fun_exp_captured_var ()) @@ -1672,7 +1713,7 @@ let check_call_to_objc_block_error tenv pdesc prop fun_exp loc = in match fun_exp with | Exp.Var id when Ident.is_footprint id - -> ( + -> ( let e_opt, is_field_deref = is_field_deref () in let warn err_desc = let err_desc = Localise.error_desc_set_bucket err_desc Localise.BucketLevel.b1 in @@ -1680,19 +1721,20 @@ let check_call_to_objc_block_error tenv pdesc prop fun_exp loc = else raise (Exceptions.Parameter_not_null_checked (err_desc, __POS__)) in match e_opt with - | Some e when is_this e - -> (* don't warn that this/self can be null *) + | Some e when is_this e -> + (* don't warn that this/self can be null *) () - | Some e - -> warn (Localise.parameter_field_not_null_checked_desc err_desc_nobuckets e) - | _ - -> warn err_desc_nobuckets ) - | _ - -> (* HP: fun_exp is not a footprint therefore, + | Some e -> + warn (Localise.parameter_field_not_null_checked_desc err_desc_nobuckets e) + | _ -> + warn err_desc_nobuckets ) + | _ -> + (* HP: fun_exp is not a footprint therefore, either is a local or it's a modified param *) let err_desc = Localise.error_desc_set_bucket err_desc_nobuckets Localise.BucketLevel.b1 in raise (Exceptions.Null_dereference (err_desc, __POS__)) + (** [rearrange lexp prop] rearranges [prop] into the form [prop' * lexp|->strexp:typ]. It returns an iterator with [lexp |-> strexp: typ] as current predicate and the path (an [offsetlist]) which leads to [lexp] as the iterator state. *) @@ -1700,11 +1742,11 @@ let rearrange ?(report_deref_errors= true) pdesc tenv lexp typ prop loc : Sil.offset list Prop.prop_iter list = let nlexp = match Prop.exp_normalize_prop tenv prop lexp with - | Exp.BinOp (Binop.PlusPI, ep, e) - -> (* array access with pointer arithmetic *) + | Exp.BinOp (Binop.PlusPI, ep, e) -> + (* array access with pointer arithmetic *) Exp.Lindex (ep, e) - | e - -> e + | e -> + e in let ptr_tested_for_zero = Prover.check_disequal tenv prop (Exp.root_of_lexp nlexp) Exp.zero in let inst = Sil.inst_rearrange (not ptr_tested_for_zero) loc (State.get_path_pos ()) in @@ -1726,11 +1768,12 @@ let rearrange ?(report_deref_errors= true) pdesc tenv lexp typ prop loc else prop in match Prop.prop_iter_create prop' with - | None - -> if !Config.footprint then + | None -> + if !Config.footprint then [prop_iter_add_hpred_footprint_to_prop pname tenv prop' (nlexp, typ) inst] else ( pp_rearrangement_error "sigma is empty" prop nlexp ; raise (Exceptions.Symexec_memory_error __POS__) ) - | Some iter - -> iter_rearrange pname tenv nlexp typ prop' iter inst + | Some iter -> + iter_rearrange pname tenv nlexp typ prop' iter inst + diff --git a/infer/src/backend/reporting.ml b/infer/src/backend/reporting.ml index a011e93c1..cf4d7d721 100644 --- a/infer/src/backend/reporting.ml +++ b/infer/src/backend/reporting.ml @@ -30,6 +30,7 @@ let log_issue_from_errlog err_kind err_log ?loc ?node_id ?session ?ltr ?linters_ if not Config.filtering (* no-filtering takes priority *) || issue_type.IssueType.enabled then Errlog.log_issue err_kind err_log loc node_id session ltr ?linters_def_file ?doc_url exn + let log_issue_from_summary err_kind summary ?loc ?node_id ?session ?ltr ?linters_def_file ?doc_url exn = let is_generated_method = Typ.Procname.java_is_generated (Specs.get_proc_name summary) in @@ -44,20 +45,22 @@ let log_issue_from_summary err_kind summary ?loc ?node_id ?session ?ltr ?linters log_issue_from_errlog err_kind err_log ?loc ?node_id ?session ?ltr ?linters_def_file ?doc_url exn + let log_issue_deprecated ?(store_summary= false) err_kind proc_name ?loc ?node_id ?session ?ltr ?linters_def_file ?doc_url exn = match Specs.get_summary proc_name with - | Some summary - -> log_issue_from_summary err_kind summary ?loc ?node_id ?session ?ltr ?linters_def_file + | Some summary -> + log_issue_from_summary err_kind summary ?loc ?node_id ?session ?ltr ?linters_def_file ?doc_url exn ; if store_summary then (* TODO (#16348004): This is currently needed as ThreadSafety works as a cluster checker *) Specs.store_summary summary - | None - -> L.(die InternalError) + | None -> + L.(die InternalError) "Trying to report error on procedure %a, but cannot because no summary exists for this procedure. Did you mean to log the error on the caller of %a instead?" Typ.Procname.pp proc_name Typ.Procname.pp proc_name + let log_error_from_errlog = log_issue_from_errlog Exceptions.Kerror let log_warning_from_errlog = log_issue_from_errlog Exceptions.Kwarning @@ -73,8 +76,11 @@ let log_info = log_issue_from_summary Exceptions.Kwarning let log_error_deprecated ?(store_summary= false) = log_issue_deprecated ~store_summary Exceptions.Kerror + let log_warning_deprecated ?(store_summary= false) = log_issue_deprecated ~store_summary Exceptions.Kwarning + let log_info_deprecated ?(store_summary= false) = log_issue_deprecated ~store_summary Exceptions.Kinfo + diff --git a/infer/src/backend/specs.ml b/infer/src/backend/specs.ml index f46137fcf..912ed8c5e 100644 --- a/infer/src/backend/specs.ml +++ b/infer/src/backend/specs.ml @@ -43,23 +43,26 @@ module Jprop = struct let to_number = function Prop (n, _) -> n | Joined (n, _, _, _) -> n let rec fav_add_dfs tenv fav = function - | Prop (_, p) - -> Prop.prop_fav_add_dfs tenv fav p - | Joined (_, p, jp1, jp2) - -> Prop.prop_fav_add_dfs tenv fav p ; fav_add_dfs tenv fav jp1 ; fav_add_dfs tenv fav jp2 + | Prop (_, p) -> + Prop.prop_fav_add_dfs tenv fav p + | Joined (_, p, jp1, jp2) -> + Prop.prop_fav_add_dfs tenv fav p ; fav_add_dfs tenv fav jp1 ; fav_add_dfs tenv fav jp2 + let rec normalize tenv = function - | Prop (n, p) - -> Prop (n, Prop.normalize tenv p) - | Joined (n, p, jp1, jp2) - -> Joined (n, Prop.normalize tenv p, normalize tenv jp1, normalize tenv jp2) + | Prop (n, p) -> + Prop (n, Prop.normalize tenv p) + | Joined (n, p, jp1, jp2) -> + Joined (n, Prop.normalize tenv p, normalize tenv jp1, normalize tenv jp2) + (** Return a compact representation of the jprop *) let rec compact sh = function - | Prop (n, p) - -> Prop (n, Prop.prop_compact sh p) - | Joined (n, p, jp1, jp2) - -> Joined (n, Prop.prop_compact sh p, compact sh jp1, compact sh jp2) + | Prop (n, p) -> + Prop (n, Prop.prop_compact sh p) + | Joined (n, p, jp1, jp2) -> + Joined (n, Prop.prop_compact sh p, compact sh jp1, compact sh jp2) + (** Print the toplevel prop *) let pp_short pe f jp = Prop.pp_prop pe f (to_prop jp) @@ -73,59 +76,65 @@ module Jprop = struct (** Print a list of joined props, the boolean indicates whether to print subcomponents of joined props *) let pp_list pe shallow f jplist = let rec pp_seq_newline f = function - | [] - -> () - | [(Prop (n, p))] - -> F.fprintf f "PROP %d:@\n%a" n (Prop.pp_prop pe) p - | [(Joined (n, p, p1, p2))] - -> if not shallow then F.fprintf f "%a@\n" pp_seq_newline [p1] ; + | [] -> + () + | [(Prop (n, p))] -> + F.fprintf f "PROP %d:@\n%a" n (Prop.pp_prop pe) p + | [(Joined (n, p, p1, p2))] -> + if not shallow then F.fprintf f "%a@\n" pp_seq_newline [p1] ; if not shallow then F.fprintf f "%a@\n" pp_seq_newline [p2] ; F.fprintf f "PROP %d (join of %d,%d):@\n%a" n (get_id p1) (get_id p2) (Prop.pp_prop pe) p - | jp :: l - -> F.fprintf f "%a@\n" pp_seq_newline [jp] ; + | jp :: l -> + F.fprintf f "%a@\n" pp_seq_newline [jp] ; pp_seq_newline f l in pp_seq_newline f jplist + (** dump a joined prop list, the boolean indicates whether to print toplevel props only *) let d_list (shallow: bool) (jplist: Prop.normal t list) = L.add_print_action (L.PTjprop_list, Obj.repr (shallow, jplist)) + let rec fav_add fav = function - | Prop (_, p) - -> Prop.prop_fav_add fav p - | Joined (_, p, jp1, jp2) - -> Prop.prop_fav_add fav p ; fav_add fav jp1 ; fav_add fav jp2 + | Prop (_, p) -> + Prop.prop_fav_add fav p + | Joined (_, p, jp1, jp2) -> + Prop.prop_fav_add fav p ; fav_add fav jp1 ; fav_add fav jp2 + let rec jprop_sub sub = function - | Prop (n, p) - -> Prop (n, Prop.prop_sub sub p) - | Joined (n, p, jp1, jp2) - -> let p' = Prop.prop_sub sub p in + | Prop (n, p) -> + Prop (n, Prop.prop_sub sub p) + | Joined (n, p, jp1, jp2) -> + let p' = Prop.prop_sub sub p in let jp1' = jprop_sub sub jp1 in let jp2' = jprop_sub sub jp2 in Joined (n, p', jp1', jp2') + let filter (f: 'a t -> 'b option) jpl = let rec do_filter acc = function - | [] - -> acc + | [] -> + acc | (Prop _ as jp) :: jpl -> ( match f jp with Some x -> do_filter (x :: acc) jpl | None -> do_filter acc jpl ) | (Joined (_, _, jp1, jp2) as jp) :: jpl -> match f jp with - | Some x - -> do_filter (x :: acc) jpl - | None - -> do_filter acc (jpl @ [jp1; jp2]) + | Some x -> + do_filter (x :: acc) jpl + | None -> + do_filter acc (jpl @ [jp1; jp2]) in do_filter [] jpl + let rec map (f: 'a Prop.t -> 'b Prop.t) = function - | Prop (n, p) - -> Prop (n, f p) - | Joined (n, p, jp1, jp2) - -> Joined (n, f p, map f jp1, map f jp2) + | Prop (n, p) -> + Prop (n, f p) + | Joined (n, p, jp1, jp2) -> + Joined (n, f p, map f jp1, map f jp2) + (* let rec jprop_sub sub = function @@ -159,6 +168,7 @@ let visited_str vis = Int.Set.iter ~f:(fun n -> s := !s ^ " " ^ string_of_int n) !lines ; !s + (** A spec consists of: pre: a joined prop post: a list of props with path @@ -189,12 +199,14 @@ end = struct List.iter ~f:(fun (p, _) -> Prop.prop_fav_add_dfs tenv fav p) spec.posts ; fav + let spec_sub tenv sub spec = { pre= Jprop.normalize tenv (Jprop.jprop_sub sub spec.pre) ; posts= List.map ~f:(fun (p, path) -> (Prop.normalize tenv (Prop.prop_sub sub p), path)) spec.posts ; visited= spec.visited } + (** Convert spec into normal form w.r.t. variable renaming *) let normalize tenv (spec: Prop.normal spec) : Prop.normal spec = let fav = spec_fav tenv spec in @@ -208,16 +220,19 @@ end = struct in spec_sub tenv sub spec + (** Return a compact representation of the spec *) let compact sh spec = let pre = Jprop.compact sh spec.pre in let posts = List.map ~f:(fun (p, path) -> (Prop.prop_compact sh p, path)) spec.posts in {pre; posts; visited= spec.visited} + (** Erase join info from pre of spec *) let erase_join_info_pre tenv spec = let spec' = {spec with pre= Jprop.Prop (1, Jprop.to_prop spec.pre)} in normalize tenv spec' + end (** Convert spec into normal form w.r.t. variable renaming *) @@ -256,6 +271,7 @@ module CallStats = struct let do_call pn_loc = PnameLocHash.add hash pn_loc empty_trace in List.iter ~f:do_call calls ; hash + let trace t proc_name loc res in_footprint = let tr_old = try PnameLocHash.find t (proc_name, loc) @@ -266,21 +282,23 @@ module CallStats = struct let tr_new = trace_add tr_old res in_footprint in PnameLocHash.replace t (proc_name, loc) tr_new + let tr_elem_str (cr, in_footprint) = let s1 = match cr with - | CR_success - -> "OK" - | CR_not_met - -> "NotMet" - | CR_not_found - -> "NotFound" - | CR_skip - -> "Skip" + | CR_success -> + "OK" + | CR_not_met -> + "NotMet" + | CR_not_found -> + "NotFound" + | CR_skip -> + "Skip" in let s2 = if in_footprint then "FP" else "RE" in s1 ^ ":" ^ s2 + let pp_trace fmt tr = Pp.seq (fun fmt x -> F.fprintf fmt "%s" (tr_elem_str x)) fmt (List.rev tr) let iter f t = @@ -294,6 +312,7 @@ module CallStats = struct in List.iter ~f:(fun (x, tr) -> f x tr) sorted_elems + (* let pp fmt t = let do_call (pname, loc) tr = @@ -358,51 +377,55 @@ let clear_spec_tbl () = Typ.Procname.Hash.clear spec_tbl let pp_failure_kind_opt fmt failure_kind_opt = match failure_kind_opt with - | Some failure_kind - -> SymOp.pp_failure_kind fmt failure_kind - | None - -> F.fprintf fmt "NONE" + | Some failure_kind -> + SymOp.pp_failure_kind fmt failure_kind + | None -> + F.fprintf fmt "NONE" + let pp_errlog fmt err_log = F.fprintf fmt "ERRORS: @[%a@]@\n%!" Errlog.pp_errors err_log ; F.fprintf fmt "WARNINGS: @[%a@]" Errlog.pp_warnings err_log + let pp_stats fmt stats = F.fprintf fmt "FAILURE:%a SYMOPS:%d@\n" pp_failure_kind_opt stats.stats_failure stats.symops + (** Print the spec *) let pp_spec pe num_opt fmt spec = let num_str = match num_opt with - | None - -> "----------" - | Some (n, tot) - -> Format.sprintf "%d of %d [nvisited:%s]" n tot (visited_str spec.visited) + | None -> + "----------" + | Some (n, tot) -> + Format.sprintf "%d of %d [nvisited:%s]" n tot (visited_str spec.visited) in let pre = Jprop.to_prop spec.pre in let pe_post = Prop.prop_update_obj_sub pe pre in let post_list = List.map ~f:fst spec.posts in match pe.Pp.kind with - | TEXT - -> F.fprintf fmt "--------------------------- %s ---------------------------@\n" num_str ; + | TEXT -> + F.fprintf fmt "--------------------------- %s ---------------------------@\n" num_str ; F.fprintf fmt "PRE:@\n%a@\n" (Prop.pp_prop Pp.text) pre ; F.fprintf fmt "%a@\n" (Propgraph.pp_proplist pe_post "POST" (pre, true)) post_list ; F.fprintf fmt "----------------------------------------------------------------" - | HTML - -> F.fprintf fmt "--------------------------- %s ---------------------------@\n" num_str ; + | HTML -> + F.fprintf fmt "--------------------------- %s ---------------------------@\n" num_str ; F.fprintf fmt "PRE:@\n%a%a%a@\n" Io_infer.Html.pp_start_color Pp.Blue (Prop.pp_prop (Pp.html Blue)) pre Io_infer.Html.pp_end_color () ; F.fprintf fmt "%a" (Propgraph.pp_proplist pe_post "POST" (pre, true)) post_list ; F.fprintf fmt "----------------------------------------------------------------" - | LATEX - -> F.fprintf fmt "\\textbf{\\large Requires}\\\\@\n@[%a%a%a@]\\\\@\n" Latex.pp_color Pp.Blue + | LATEX -> + F.fprintf fmt "\\textbf{\\large Requires}\\\\@\n@[%a%a%a@]\\\\@\n" Latex.pp_color Pp.Blue (Prop.pp_prop (Pp.latex Blue)) pre Latex.pp_color pe.Pp.color ; F.fprintf fmt "\\textbf{\\large Ensures}\\\\@\n@[%a@]" (Propgraph.pp_proplist pe_post "POST" (pre, true)) post_list + (** Dump a spec *) let d_spec (spec: 'a spec) = L.add_print_action (L.PTspec, Obj.repr spec) @@ -410,29 +433,31 @@ let pp_specs pe fmt specs = let total = List.length specs in let cnt = ref 0 in match pe.Pp.kind with - | TEXT - -> List.iter + | TEXT -> + List.iter ~f:(fun spec -> incr cnt ; F.fprintf fmt "%a" (pp_spec pe (Some (!cnt, total))) spec) specs - | HTML - -> List.iter + | HTML -> + List.iter ~f:(fun spec -> incr cnt ; F.fprintf fmt "%a
@\n" (pp_spec pe (Some (!cnt, total))) spec) specs - | LATEX - -> List.iter + | LATEX -> + List.iter ~f:(fun spec -> incr cnt ; F.fprintf fmt "\\subsection*{Spec %d of %d}@\n\\(%a\\)@\n" !cnt total (pp_spec pe None) spec) specs + let describe_phase summary = ("Phase", if equal_phase summary.phase FOOTPRINT then "FOOTPRINT" else "RE_EXECUTION") + (** Return the signature of a procedure declaration as a string *) let get_signature summary = let s = ref "" in @@ -449,6 +474,7 @@ let get_signature summary = let decl = F.asprintf "%t" pp in decl ^ "(" ^ !s ^ ")" + let get_specs_from_preposts preposts = Option.value_map ~f:NormSpec.tospecs ~default:[] preposts let get_specs_from_payload summary = get_specs_from_preposts summary.payload.preposts @@ -459,6 +485,7 @@ let pp_summary_no_stats_specs fmt summary = F.fprintf fmt "%a@\n" pp_status summary.status ; F.fprintf fmt "%a@\n" pp_pair (describe_phase summary) + let pp_payload pe fmt { preposts ; typestate @@ -470,21 +497,29 @@ let pp_payload pe fmt ; annot_map ; uninit } = let pp_opt prefix pp fmt = function - | Some x - -> F.fprintf fmt "%s: %a@\n" prefix pp x - | None - -> () + | Some x -> + F.fprintf fmt "%s: %a@\n" prefix pp x + | None -> + () in F.fprintf fmt "%a%a%a%a%a%a%a%a%a@\n" (pp_opt "PrePosts" (pp_specs pe)) (Option.map ~f:NormSpec.tospecs preposts) (pp_opt "TypeState" (TypeState.pp TypeState.unit_ext)) - typestate (pp_opt "CrashContext" Crashcontext.pp_stacktree) crashcontext_frame - (pp_opt "Quandary" QuandarySummary.pp) quandary (pp_opt "Siof" SiofDomain.pp) siof - (pp_opt "RacerD" RacerDDomain.pp_summary) racerd - (pp_opt "BufferOverrun" BufferOverrunDomain.Summary.pp) buffer_overrun - (pp_opt "AnnotationReachability" AnnotReachabilityDomain.pp) annot_map - (pp_opt "Uninitialised" UninitDomain.pp_summary) uninit + typestate + (pp_opt "CrashContext" Crashcontext.pp_stacktree) + crashcontext_frame + (pp_opt "Quandary" QuandarySummary.pp) + quandary (pp_opt "Siof" SiofDomain.pp) siof + (pp_opt "RacerD" RacerDDomain.pp_summary) + racerd + (pp_opt "BufferOverrun" BufferOverrunDomain.Summary.pp) + buffer_overrun + (pp_opt "AnnotationReachability" AnnotReachabilityDomain.pp) + annot_map + (pp_opt "Uninitialised" UninitDomain.pp_summary) + uninit + let pp_summary_text fmt summary = let err_log = summary.attributes.ProcAttributes.err_log in @@ -493,6 +528,7 @@ let pp_summary_text fmt summary = F.fprintf fmt "%a@\n%a%a" pp_errlog err_log pp_stats summary.stats (pp_payload pe) summary.payload + let pp_summary_latex color fmt summary = let err_log = summary.attributes.ProcAttributes.err_log in let pe = Pp.latex color in @@ -503,6 +539,7 @@ let pp_summary_latex color fmt summary = F.fprintf fmt "\\end{verbatim}@\n" ; F.fprintf fmt "%a@\n" (pp_specs pe) (get_specs_from_payload summary) + let pp_summary_html source color fmt summary = let err_log = summary.attributes.ProcAttributes.err_log in let pe = Pp.html color in @@ -516,6 +553,7 @@ let pp_summary_html source color fmt summary = pp_payload pe fmt summary.payload ; F.fprintf fmt "@\n" + let empty_stats calls = { stats_failure= None ; symops= 0 @@ -523,12 +561,14 @@ let empty_stats calls = ; nodes_visited_re= IntSet.empty ; call_stats= CallStats.init calls } + let payload_compact sh payload = match payload.preposts with - | Some specs - -> {payload with preposts= Some (List.map ~f:(NormSpec.compact sh) specs)} - | None - -> payload + | Some specs -> + {payload with preposts= Some (List.map ~f:(NormSpec.compact sh) specs)} + | None -> + payload + (** Return a compact representation of the summary *) let summary_compact sh summary = {summary with payload= payload_compact sh summary.payload} @@ -539,15 +579,18 @@ let add_summary (proc_name: Typ.Procname.t) (summary: summary) : unit = "Adding summary for %a@\n@[ %a@]@." Typ.Procname.pp proc_name pp_summary_text summary ; Typ.Procname.Hash.replace spec_tbl proc_name summary + let specs_filename pname = let pname_file = Typ.Procname.to_filename pname in pname_file ^ Config.specs_files_suffix + (** path to the .specs file for the given procedure in the current results directory *) let res_dir_specs_filename pname = DB.Results_dir.path_to_filename DB.Results_dir.Abs_root [Config.specs_dir_name; specs_filename pname] + (** paths to the .specs file for the given procedure in the current spec libraries *) let specs_library_filenames pname = List.map @@ -555,16 +598,20 @@ let specs_library_filenames pname = DB.filename_from_string (Filename.concat specs_dir (specs_filename pname))) Config.specs_library + (** paths to the .specs file for the given procedure in the models folder *) let specs_models_filename pname = DB.filename_from_string (Filename.concat Config.models_dir (specs_filename pname)) + let summary_exists_in_models pname = Sys.file_exists (DB.filename_to_string (specs_models_filename pname)) = `Yes + let summary_serializer : summary Serialization.serializer = Serialization.create_serializer Serialization.Key.summary + (** Load procedure summary from the given file *) let load_summary specs_file = Serialization.read_from_file summary_serializer specs_file @@ -575,57 +622,61 @@ let load_summary_to_spec_table proc_name = match load_summary models_dir with None -> false | Some summ -> add summ in let rec load_summary_libs = function - | (* try to load the summary from a list of libs *) - [] - -> false + (* try to load the summary from a list of libs *) + | [] -> + false | spec_path :: spec_paths -> match load_summary spec_path with - | None - -> load_summary_libs spec_paths - | Some summ - -> add summ + | None -> + load_summary_libs spec_paths + | Some summ -> + add summ in let load_summary_ziplibs zip_specs_filename = let zip_specs_path = Filename.concat Config.specs_dir_name zip_specs_filename in match ZipLib.load summary_serializer zip_specs_path with - | None - -> false - | Some summary - -> add summary + | None -> + false + | Some summary -> + add summary in let default_spec_dir = res_dir_specs_filename proc_name in match load_summary default_spec_dir with - | None - -> (* search on models, libzips, and libs *) + | None -> + (* search on models, libzips, and libs *) load_summary_models (specs_models_filename proc_name) || load_summary_ziplibs (specs_filename proc_name) || load_summary_libs (specs_library_filenames proc_name) - | Some summ - -> add summ + | Some summ -> + add summ + let rec get_summary proc_name = try Some (Typ.Procname.Hash.find spec_tbl proc_name) with Not_found -> if load_summary_to_spec_table proc_name then get_summary proc_name else None + let get_summary_unsafe s proc_name = match get_summary proc_name with - | None - -> L.(die InternalError) + | None -> + L.(die InternalError) "[%s] Specs.get_summary_unsafe: %a Not found" s Typ.Procname.pp proc_name - | Some summary - -> summary + | Some summary -> + summary + (** Check if the procedure is from a library: It's not defined, and there is no spec file for it. *) let proc_is_library proc_attributes = if not proc_attributes.ProcAttributes.is_defined then match get_summary proc_attributes.ProcAttributes.proc_name with - | None - -> true - | Some _ - -> false + | None -> + true + | Some _ -> + false else false + (** Try to find the attributes for a defined proc. First look at specs (to get attributes computed by analysis) then look at the attributes table. @@ -638,27 +689,29 @@ let proc_resolve_attributes proc_name = in match from_specs () with | Some attributes - -> ( + -> ( if attributes.ProcAttributes.is_defined then Some attributes else match from_attributes_table () with - | Some attributes' - -> Some attributes' - | None - -> Some attributes ) - | None - -> from_attributes_table () + | Some attributes' -> + Some attributes' + | None -> + Some attributes ) + | None -> + from_attributes_table () + (** Like proc_resolve_attributes but start from a proc_desc. *) let pdesc_resolve_attributes proc_desc = let proc_name = Procdesc.get_proc_name proc_desc in match proc_resolve_attributes proc_name with - | Some proc_attributes - -> proc_attributes - | None - -> (* this should not happen *) + | Some proc_attributes -> + proc_attributes + | None -> + (* this should not happen *) assert false + let summary_exists proc_name = match get_summary proc_name with Some _ -> true | None -> false let get_status summary = summary.status @@ -684,9 +737,11 @@ let store_summary (summ1: summary) = let proc_name = get_proc_name final_summary in (* Make sure the summary in memory is identical to the saved one *) add_summary proc_name final_summary ; - Serialization.write_to_file summary_serializer (res_dir_specs_filename proc_name) + Serialization.write_to_file summary_serializer + (res_dir_specs_filename proc_name) ~data:final_summary + let empty_payload = { preposts= None ; typestate= None @@ -699,6 +754,7 @@ let empty_payload = ; buffer_overrun= None ; uninit= None } + (** [init_summary (depend_list, nodes, proc_flags, calls, in_out_calls_opt, proc_attributes)] initializes the summary for [proc_name] given dependent procs in list [depend_list]. *) @@ -710,10 +766,12 @@ let init_summary (nodes, proc_flags, calls, proc_attributes, proc_desc_option) = ; payload= empty_payload ; stats= empty_stats calls ; status= Pending - ; attributes= {proc_attributes with ProcAttributes.proc_flags= proc_flags} + ; attributes= {proc_attributes with ProcAttributes.proc_flags} ; proc_desc_option } in - Typ.Procname.Hash.replace spec_tbl proc_attributes.ProcAttributes.proc_name summary ; summary + Typ.Procname.Hash.replace spec_tbl proc_attributes.ProcAttributes.proc_name summary ; + summary + let dummy = init_summary @@ -723,6 +781,7 @@ let dummy = , ProcAttributes.default Typ.Procname.empty_block Config.Java , None ) + (** Reset a summary rebuilding the dependents and preserving the proc attributes if present. *) let reset_summary proc_desc = let proc_desc_option = @@ -732,6 +791,7 @@ let reset_summary proc_desc = let proc_flags = attributes.ProcAttributes.proc_flags in init_summary ([], proc_flags, [], attributes, proc_desc_option) + (* =============== END of support for spec tables =============== *) (* let rec post_equal pl1 pl2 = match pl1, pl2 with diff --git a/infer/src/backend/state.ml b/infer/src/backend/state.ml index 669eced37..54bbcd7be 100644 --- a/infer/src/backend/state.ml +++ b/infer/src/backend/state.ml @@ -57,6 +57,7 @@ let initial () = ; last_session= 0 ; failure_map= NodeHash.create 1 } + (** Global state *) let gs = ref (initial ()) @@ -66,6 +67,7 @@ let save_state () = gs := initial () ; old + (** Restore the old state. *) let restore_state st = gs := st @@ -77,12 +79,15 @@ let get_failure_stats node = try NodeHash.find !gs.failure_map node with Not_found -> let fs = {instr_fail= 0; instr_ok= 0; node_fail= 0; node_ok= 0; first_failure= None} in - NodeHash.add !gs.failure_map node fs ; fs + NodeHash.add !gs.failure_map node fs ; + fs + let add_diverging_states pset = !gs.diverging_states_proc <- Paths.PathSet.union pset !gs.diverging_states_proc ; !gs.diverging_states_node <- Paths.PathSet.union pset !gs.diverging_states_node + let get_diverging_states_node () = !gs.diverging_states_node let get_diverging_states_proc () = !gs.diverging_states_proc @@ -91,10 +96,11 @@ let get_instr () = !gs.last_instr let get_loc () = match !gs.last_instr with - | Some instr - -> Sil.instr_get_loc instr - | None - -> Procdesc.Node.get_loc !gs.last_node + | Some instr -> + Sil.instr_get_loc instr + | None -> + Procdesc.Node.get_loc !gs.last_node + let get_node () = !gs.last_node @@ -106,26 +112,27 @@ let node_simple_key node = if Sil.instr_is_auxiliary instr then () else match instr with - | Sil.Load _ - -> add_key 1 - | Sil.Store _ - -> add_key 2 - | Sil.Prune _ - -> add_key 3 - | Sil.Call _ - -> add_key 4 - | Sil.Nullify _ - -> add_key 5 - | Sil.Abstract _ - -> add_key 6 - | Sil.Remove_temps _ - -> add_key 7 - | Sil.Declare_locals _ - -> add_key 8 + | Sil.Load _ -> + add_key 1 + | Sil.Store _ -> + add_key 2 + | Sil.Prune _ -> + add_key 3 + | Sil.Call _ -> + add_key 4 + | Sil.Nullify _ -> + add_key 5 + | Sil.Abstract _ -> + add_key 6 + | Sil.Remove_temps _ -> + add_key 7 + | Sil.Declare_locals _ -> + add_key 8 in List.iter ~f:do_instr (Procdesc.Node.get_instrs node) ; Hashtbl.hash !key + (** key for a node: look at the current node, successors and predecessors *) let node_key node = let succs = Procdesc.Node.get_succs node in @@ -135,6 +142,7 @@ let node_key node = in Hashtbl.hash v + (** normalize the list of instructions by renaming let-bound ids *) let instrs_normalize instrs = let bound_ids = @@ -151,6 +159,7 @@ let instrs_normalize instrs = in List.map ~f:(Sil.instr_sub subst) instrs + (** Create a function to find duplicate nodes. A node is a duplicate of another one if they have the same kind and location and normalized (w.r.t. renaming of let - bound ids) list of instructions. *) @@ -202,10 +211,10 @@ let mk_find_duplicate_nodes proc_desc : Procdesc.Node.t -> Procdesc.NodeSet.t = let (_, node_normalized_instrs), _ = let filter (node', _) = Procdesc.Node.equal node node' in match List.partition_tf ~f:filter elements with - | [this], others - -> (this, others) - | _ - -> raise Not_found + | [this], others -> + (this, others) + | _ -> + raise Not_found in let duplicates = let equal_normalized_instrs (_, normalized_instrs') = @@ -220,6 +229,7 @@ let mk_find_duplicate_nodes proc_desc : Procdesc.Node.t -> Procdesc.NodeSet.t = in find_duplicate_nodes + let get_node_id () = Procdesc.Node.get_id !gs.last_node let get_node_id_key () = (Procdesc.Node.get_id !gs.last_node, node_key !gs.last_node) @@ -228,17 +238,20 @@ let get_inst_update pos = let loc = get_loc () in Sil.inst_update loc pos + let get_path () = match !gs.last_path with - | None - -> (Paths.Path.start !gs.last_node, None) - | Some (path, pos_opt) - -> (path, pos_opt) + | None -> + (Paths.Path.start !gs.last_node, None) + | Some (path, pos_opt) -> + (path, pos_opt) + let get_loc_trace () : Errlog.loc_trace = let path, pos_opt = get_path () in Paths.Path.create_loc_trace path pos_opt + let get_prop_tenv_pdesc () = !gs.last_prop_tenv_pdesc (** extract the footprint of the prop, and turn it into a normalized precondition using spec variables *) @@ -260,34 +273,38 @@ let extract_pre p tenv pdesc abstract_fun = in Prop.normalize tenv (Prop.prop_sub sub pre') + (** return the normalized precondition extracted form the last prop seen, if any the abstraction function is a parameter to get around module dependencies *) let get_normalized_pre (abstract_fun: Tenv.t -> Prop.normal Prop.t -> Prop.normal Prop.t) : Prop.normal Prop.t option = match get_prop_tenv_pdesc () with - | None - -> None - | Some (prop, tenv, pdesc) - -> Some (extract_pre prop tenv pdesc abstract_fun) + | None -> + None + | Some (prop, tenv, pdesc) -> + Some (extract_pre prop tenv pdesc abstract_fun) + let get_session () = !gs.last_session let get_path_pos () = let pname = match get_prop_tenv_pdesc () with - | Some (_, _, pdesc) - -> Procdesc.get_proc_name pdesc - | None - -> Typ.Procname.from_string_c_fun "unknown_procedure" + | Some (_, _, pdesc) -> + Procdesc.get_proc_name pdesc + | None -> + Typ.Procname.from_string_c_fun "unknown_procedure" in let nid = get_node_id () in (pname, (nid :> int)) + let mark_execution_start node = let fs = get_failure_stats node in fs.instr_ok <- 0 ; fs.instr_fail <- 0 + let mark_execution_end node = let fs = get_failure_stats node in let success = Int.equal fs.instr_fail 0 in @@ -295,10 +312,12 @@ let mark_execution_end node = fs.instr_fail <- 0 ; if success then fs.node_ok <- fs.node_ok + 1 else fs.node_fail <- fs.node_fail + 1 + let mark_instr_ok () = let fs = get_failure_stats (get_node ()) in fs.instr_ok <- fs.instr_ok + 1 + let mark_instr_fail exn = let loc = get_loc () in let key = (get_node_id_key () :> int * int) in @@ -309,6 +328,7 @@ let mark_instr_fail exn = fs.first_failure <- Some (loc, key, (session :> int), loc_trace, exn) ; fs.instr_fail <- fs.instr_fail + 1 + type log_issue = ?store_summary:bool -> Typ.Procname.t -> ?loc:Location.t -> ?node_id:int * int -> ?session:int -> ?ltr:Errlog.loc_trace -> ?linters_def_file:string -> ?doc_url:string -> exn -> unit @@ -317,16 +337,17 @@ let process_execution_failures (log_issue: log_issue) pname = let do_failure _ fs = (* L.out "Node:%a node_ok:%d node_fail:%d@." Procdesc.Node.pp node fs.node_ok fs.node_fail; *) match (fs.node_ok, fs.first_failure) with - | 0, Some (loc, key, _, loc_trace, exn) when not Config.debug_exceptions - -> let error = Exceptions.recognize_exception exn in + | 0, Some (loc, key, _, loc_trace, exn) when not Config.debug_exceptions -> + let error = Exceptions.recognize_exception exn in let desc' = Localise.verbatim_desc ("exception: " ^ error.name.IssueType.unique_id) in let exn' = Exceptions.Analysis_stops (desc', error.ml_loc) in log_issue pname ~loc ~node_id:key ~ltr:loc_trace exn' - | _ - -> () + | _ -> + () in NodeHash.iter do_failure !gs.failure_map + let set_instr (instr: Sil.instr) = !gs.last_instr <- Some instr let set_path path pos_opt = !gs.last_path <- Some (path, pos_opt) @@ -337,6 +358,7 @@ let set_node (node: Procdesc.Node.t) = !gs.last_instr <- None ; !gs.last_node <- node + let set_session (session: int) = !gs.last_session <- session let get_const_map () = !gs.const_map diff --git a/infer/src/backend/symExec.ml b/infer/src/backend/symExec.ml index 9e13aa03e..27c360da4 100644 --- a/infer/src/backend/symExec.ml +++ b/infer/src/backend/symExec.ml @@ -17,10 +17,11 @@ module L = Logging module F = Format let rec fldlist_assoc fld = function - | [] - -> raise Not_found - | (fld', x, _) :: l - -> if Typ.Fieldname.equal fld fld' then x else fldlist_assoc fld l + | [] -> + raise Not_found + | (fld', x, _) :: l -> + if Typ.Fieldname.equal fld fld' then x else fldlist_assoc fld l + let unroll_type tenv (typ: Typ.t) (off: Sil.offset) = let fail fld_to_string fld = @@ -38,14 +39,15 @@ let unroll_type tenv (typ: Typ.t) (off: Sil.offset) = | Some {fields; statics} -> ( try fldlist_assoc fld (fields @ statics) with Not_found -> fail Typ.Fieldname.to_string fld ) - | None - -> fail Typ.Fieldname.to_string fld ) - | Tarray (typ', _, _), Off_index _ - -> typ' - | _, Off_index Const Cint i when IntLit.iszero i - -> typ - | _ - -> fail Sil.offset_to_string off + | None -> + fail Typ.Fieldname.to_string fld ) + | Tarray (typ', _, _), Off_index _ -> + typ' + | _, Off_index Const Cint i when IntLit.iszero i -> + typ + | _ -> + fail Sil.offset_to_string off + (** Given a node, returns a list of pvar of blocks that have been nullified in the block. *) let get_blocks_nullified node = @@ -57,6 +59,7 @@ let get_blocks_nullified node = in null_blocks + (** Given a proposition and an objc block checks whether by existentially quantifying captured variables in the block we obtain a leak. *) let check_block_retain_cycle tenv caller_pname prop block_nullified = @@ -64,16 +67,17 @@ let check_block_retain_cycle tenv caller_pname prop block_nullified = let block_pname = Typ.Procname.mangled_objc_block (Mangled.to_string mblock) in let block_captured = match Attributes.load block_pname with - | Some attributes - -> fst (List.unzip attributes.ProcAttributes.captured) - | None - -> [] + | Some attributes -> + fst (List.unzip attributes.ProcAttributes.captured) + | None -> + [] in let prop' = Prop.remove_seed_captured_vars_block tenv block_captured prop in let prop'' = Prop.prop_rename_fav_with_existentials tenv prop' in let _ : Prop.normal Prop.t = Abs.abstract_junk ~original_prop:prop caller_pname tenv prop'' in () + (** Apply function [f] to the expression at position [offlist] in [strexp]. If not found, expand [strexp] and apply [f] to [None]. The routine should maintain the invariant that strexp and typ correspond to @@ -108,27 +112,27 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty L.d_ln () in match (offlist, strexp, typ.Typ.desc) with - | [], Sil.Eexp (e, inst_curr), _ - -> let inst_is_uninitialized = function - | Sil.Ialloc - -> (* java allocation initializes with default values *) + | [], Sil.Eexp (e, inst_curr), _ -> + let inst_is_uninitialized = function + | Sil.Ialloc -> + (* java allocation initializes with default values *) !Config.curr_language <> Config.Java - | Sil.Iinitial - -> true - | _ - -> false + | Sil.Iinitial -> + true + | _ -> + false in let is_hidden_field () = match State.get_instr () with - | Some Sil.Load (_, Exp.Lfield (_, fieldname, _), _, _) - -> Typ.Fieldname.is_hidden fieldname - | _ - -> false + | Some Sil.Load (_, Exp.Lfield (_, fieldname, _), _, _) -> + Typ.Fieldname.is_hidden fieldname + | _ -> + false in let inst_new = match inst with - | Sil.Ilookup when inst_is_uninitialized inst_curr && not (is_hidden_field ()) - -> (* we are in a lookup of an uninitialized value *) + | Sil.Ilookup when inst_is_uninitialized inst_curr && not (is_hidden_field ()) -> + (* we are in a lookup of an uninitialized value *) lookup_inst := Some inst_curr ; let alloc_attribute_opt = if Sil.equal_inst inst_curr Sil.Iinitial then None @@ -139,40 +143,41 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty Errdesc.explain_memory_access pname tenv deref_str p (State.get_loc ()) in let exn = Exceptions.Uninitialized_value (err_desc, __POS__) in - Reporting.log_warning_deprecated pname exn ; Sil.update_inst inst_curr inst - | Sil.Ilookup - -> (* a lookup does not change an inst unless it is inst_initial *) + Reporting.log_warning_deprecated pname exn ; + Sil.update_inst inst_curr inst + | Sil.Ilookup -> + (* a lookup does not change an inst unless it is inst_initial *) lookup_inst := Some inst_curr ; inst_curr - | _ - -> Sil.update_inst inst_curr inst + | _ -> + Sil.update_inst inst_curr inst in let e' = f (Some e) in (e', Sil.Eexp (e', inst_new), typ, None) - | [], Sil.Estruct (fesl, inst'), _ - -> if not nullify_struct then (f None, Sil.Estruct (fesl, inst'), typ, None) + | [], Sil.Estruct (fesl, inst'), _ -> + if not nullify_struct then (f None, Sil.Estruct (fesl, inst'), typ, None) else if fp_root then ( pp_error () ; assert false ) else ( L.d_strln "WARNING: struct assignment treated as nondeterministic assignment" ; (f None, Prop.create_strexp_of_type tenv Prop.Fld_init typ None inst, typ, None) ) - | [], Sil.Earray _, _ - -> let offlist' = Sil.Off_index Exp.zero :: offlist in + | [], Sil.Earray _, _ -> + let offlist' = Sil.Off_index Exp.zero :: offlist in apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist' f inst lookup_inst - | (Sil.Off_fld _) :: _, Sil.Earray _, _ - -> let offlist_new = Sil.Off_index Exp.zero :: offlist in + | (Sil.Off_fld _) :: _, Sil.Earray _, _ -> + let offlist_new = Sil.Off_index Exp.zero :: offlist in apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, typ) offlist_new f inst lookup_inst | (Sil.Off_fld (fld, fld_typ)) :: offlist', Sil.Estruct (fsel, inst'), Typ.Tstruct name -> ( match Tenv.lookup tenv name with | Some ({fields} as struct_typ) - -> ( + -> ( let t' = unroll_type tenv typ (Sil.Off_fld (fld, fld_typ)) in match List.find ~f:(fun fse -> Typ.Fieldname.equal fld (fst fse)) fsel with - | Some (_, se') - -> let res_e', res_se', res_t', res_pred_insts_op' = + | Some (_, se') -> + let res_e', res_se', res_t', res_pred_insts_op' = apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, se', t') offlist' f inst lookup_inst in @@ -186,23 +191,23 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty let fields' = List.map ~f:replace_fta fields in ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:fields' name) ; (res_e', res_se, typ, res_pred_insts_op') - | None - -> (* This case should not happen. The rearrangement should + | None -> + (* This case should not happen. The rearrangement should have materialized all the accessed cells. *) pp_error () ; assert false ) - | None - -> pp_error () ; + | None -> + pp_error () ; assert false ) - | (Sil.Off_fld _) :: _, _, _ - -> pp_error () ; + | (Sil.Off_fld _) :: _, _, _ -> + pp_error () ; assert false | (Sil.Off_index idx) :: offlist', Sil.Earray (len, esel, inst1), Typ.Tarray (t', len', stride') - -> ( + -> ( let nidx = Prop.exp_normalize_prop tenv p idx in match List.find ~f:(fun ese -> Prover.check_equal tenv p nidx (fst ese)) esel with - | Some (idx_ese', se') - -> let res_e', res_se', res_t', res_pred_insts_op' = + | Some (idx_ese', se') -> + let res_e', res_se', res_t', res_pred_insts_op' = apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, se', t') offlist' f inst lookup_inst in @@ -212,19 +217,20 @@ let rec apply_offlist pdesc tenv p fp_root nullify_struct (root_lexp, strexp, ty let res_se = Sil.Earray (len, List.map ~f:replace_ese esel, inst1) in let res_t = Typ.mk ~default:typ (Tarray (res_t', len', stride')) in (res_e', res_se, res_t, res_pred_insts_op') - | None - -> (* return a nondeterministic value if the index is not found after rearrangement *) + | None -> + (* return a nondeterministic value if the index is not found after rearrangement *) L.d_str "apply_offlist: index " ; Sil.d_exp idx ; L.d_strln " not materialized -- returning nondeterministic value" ; let res_e' = Exp.Var (Ident.create_fresh Ident.kprimed) in (res_e', strexp, typ, None) ) - | (Sil.Off_index _) :: _, _, _ - -> (* This case should not happen. The rearrangement should + | (Sil.Off_index _) :: _, _, _ -> + (* This case should not happen. The rearrangement should have materialized all the accessed cells. *) pp_error () ; raise (Exceptions.Internal_error (Localise.verbatim_desc "Array out of bounds in Symexec")) + (** Given [lexp |-> se: typ], if the location [offlist] exists in [se], function [ptsto_lookup p (lexp, se, typ) offlist id] returns a tuple. The first component of the tuple is an expression at position [offlist] in [se]. @@ -252,6 +258,7 @@ let ptsto_lookup pdesc tenv p (lexp, se, sizeof) offlist id = let ptsto' = Prop.mk_ptsto tenv lexp se' (Exp.Sizeof {sizeof with typ= typ'}) in (e', ptsto', pred_insts_op', lookup_uninitialized) + (** [ptsto_update p (lexp,se,typ) offlist exp] takes [lexp |-> se: typ], and updates [se] by replacing the expression at [offlist] with [exp]. Then, it returns @@ -275,22 +282,25 @@ let ptsto_update pdesc tenv p (lexp, se, sizeof) offlist exp = let ptsto' = Prop.mk_ptsto tenv lexp se' (Exp.Sizeof {sizeof with typ= typ'}) in (ptsto', pred_insts_op') + let update_iter iter pi sigma = let iter' = Prop.prop_iter_update_current_by_list iter sigma in List.fold ~f:(Prop.prop_iter_add_atom false) ~init:iter' pi + (** Precondition: se should not include hpara_psto that could mean nonempty heaps. *) let rec execute_nullify_se = function - | Sil.Eexp _ - -> Sil.Eexp (Exp.zero, Sil.inst_nullify) - | Sil.Estruct (fsel, _) - -> let fsel' = List.map ~f:(fun (fld, se) -> (fld, execute_nullify_se se)) fsel in + | Sil.Eexp _ -> + Sil.Eexp (Exp.zero, Sil.inst_nullify) + | Sil.Estruct (fsel, _) -> + let fsel' = List.map ~f:(fun (fld, se) -> (fld, execute_nullify_se se)) fsel in Sil.Estruct (fsel', Sil.inst_nullify) - | Sil.Earray (len, esel, _) - -> let esel' = List.map ~f:(fun (idx, se) -> (idx, execute_nullify_se se)) esel in + | Sil.Earray (len, esel, _) -> + let esel' = List.map ~f:(fun (idx, se) -> (idx, execute_nullify_se se)) esel in Sil.Earray (len, esel', Sil.inst_nullify) + (** Do pruning for conditional [if (e1 != e2) ] if [positive] is true and [(if (e1 == e2)] if [positive] is false *) let prune_ne tenv ~positive e1 e2 prop = @@ -304,6 +314,7 @@ let prune_ne tenv ~positive e1 e2 prop = if Prover.check_inconsistency tenv new_prop then Propset.empty else Propset.singleton tenv new_prop + (** Do pruning for conditional "if ([e1] CMP [e2])" if [positive] is true and "if (!([e1] CMP [e2]))" if [positive] is false, where CMP is "<" if [is_strict] is true and "<=" if [is_strict] is false. @@ -332,50 +343,52 @@ let prune_ineq tenv ~is_strict ~positive prop e1 e2 = let prop_with_ineq = Prop.conjoin_eq tenv ~footprint prune_cond Exp.one prop in Propset.singleton tenv prop_with_ineq + let rec prune tenv ~positive condition prop = match Prop.exp_normalize_prop ~destructive:true tenv prop condition with - | Exp.Var _ | Exp.Lvar _ - -> prune_ne tenv ~positive condition Exp.zero prop - | Exp.Const Const.Cint i when IntLit.iszero i - -> if positive then Propset.empty else Propset.singleton tenv prop - | Exp.Const (Const.Cint _ | Const.Cstr _ | Const.Cclass _) | Exp.Sizeof _ - -> if positive then Propset.singleton tenv prop else Propset.empty - | Exp.Const _ - -> assert false - | Exp.Cast (_, condition') - -> prune tenv ~positive condition' prop - | Exp.UnOp (Unop.LNot, condition', _) - -> prune tenv ~positive:(not positive) condition' prop - | Exp.UnOp _ - -> assert false - | Exp.BinOp (Binop.Eq, e, Exp.Const Const.Cint i) when IntLit.iszero i && not (IntLit.isnull i) - -> prune tenv ~positive:(not positive) e prop - | Exp.BinOp (Binop.Eq, Exp.Const Const.Cint i, e) when IntLit.iszero i && not (IntLit.isnull i) - -> prune tenv ~positive:(not positive) e prop - | Exp.BinOp (Binop.Eq, e1, e2) - -> prune_ne tenv ~positive:(not positive) e1 e2 prop - | Exp.BinOp (Binop.Ne, e, Exp.Const Const.Cint i) when IntLit.iszero i && not (IntLit.isnull i) - -> prune tenv ~positive e prop - | Exp.BinOp (Binop.Ne, Exp.Const Const.Cint i, e) when IntLit.iszero i && not (IntLit.isnull i) - -> prune tenv ~positive e prop - | Exp.BinOp (Binop.Ne, e1, e2) - -> prune_ne tenv ~positive e1 e2 prop - | Exp.BinOp (Binop.Ge, e2, e1) | Exp.BinOp (Binop.Le, e1, e2) - -> prune_ineq tenv ~is_strict:false ~positive prop e1 e2 - | Exp.BinOp (Binop.Gt, e2, e1) | Exp.BinOp (Binop.Lt, e1, e2) - -> prune_ineq tenv ~is_strict:true ~positive prop e1 e2 - | Exp.BinOp (Binop.LAnd, condition1, condition2) - -> let pruner = if positive then prune_inter tenv else prune_union tenv in + | Exp.Var _ | Exp.Lvar _ -> + prune_ne tenv ~positive condition Exp.zero prop + | Exp.Const Const.Cint i when IntLit.iszero i -> + if positive then Propset.empty else Propset.singleton tenv prop + | Exp.Const (Const.Cint _ | Const.Cstr _ | Const.Cclass _) | Exp.Sizeof _ -> + if positive then Propset.singleton tenv prop else Propset.empty + | Exp.Const _ -> + assert false + | Exp.Cast (_, condition') -> + prune tenv ~positive condition' prop + | Exp.UnOp (Unop.LNot, condition', _) -> + prune tenv ~positive:(not positive) condition' prop + | Exp.UnOp _ -> + assert false + | Exp.BinOp (Binop.Eq, e, Exp.Const Const.Cint i) when IntLit.iszero i && not (IntLit.isnull i) -> + prune tenv ~positive:(not positive) e prop + | Exp.BinOp (Binop.Eq, Exp.Const Const.Cint i, e) when IntLit.iszero i && not (IntLit.isnull i) -> + prune tenv ~positive:(not positive) e prop + | Exp.BinOp (Binop.Eq, e1, e2) -> + prune_ne tenv ~positive:(not positive) e1 e2 prop + | Exp.BinOp (Binop.Ne, e, Exp.Const Const.Cint i) when IntLit.iszero i && not (IntLit.isnull i) -> + prune tenv ~positive e prop + | Exp.BinOp (Binop.Ne, Exp.Const Const.Cint i, e) when IntLit.iszero i && not (IntLit.isnull i) -> + prune tenv ~positive e prop + | Exp.BinOp (Binop.Ne, e1, e2) -> + prune_ne tenv ~positive e1 e2 prop + | Exp.BinOp (Binop.Ge, e2, e1) | Exp.BinOp (Binop.Le, e1, e2) -> + prune_ineq tenv ~is_strict:false ~positive prop e1 e2 + | Exp.BinOp (Binop.Gt, e2, e1) | Exp.BinOp (Binop.Lt, e1, e2) -> + prune_ineq tenv ~is_strict:true ~positive prop e1 e2 + | Exp.BinOp (Binop.LAnd, condition1, condition2) -> + let pruner = if positive then prune_inter tenv else prune_union tenv in pruner ~positive condition1 condition2 prop - | Exp.BinOp (Binop.LOr, condition1, condition2) - -> let pruner = if positive then prune_union tenv else prune_inter tenv in + | Exp.BinOp (Binop.LOr, condition1, condition2) -> + let pruner = if positive then prune_union tenv else prune_inter tenv in pruner ~positive condition1 condition2 prop - | Exp.BinOp _ | Exp.Lfield _ | Exp.Lindex _ - -> prune_ne tenv ~positive condition Exp.zero prop - | Exp.Exn _ - -> assert false - | Exp.Closure _ - -> assert false + | Exp.BinOp _ | Exp.Lfield _ | Exp.Lindex _ -> + prune_ne tenv ~positive condition Exp.zero prop + | Exp.Exn _ -> + assert false + | Exp.Closure _ -> + assert false + and prune_inter tenv ~positive condition1 condition2 prop = let res = ref Propset.empty in @@ -383,15 +396,18 @@ and prune_inter tenv ~positive condition1 condition2 prop = let do_p p = res := Propset.union (prune tenv ~positive condition2 p) !res in Propset.iter do_p pset1 ; !res + and prune_union tenv ~positive condition1 condition2 prop = let pset1 = prune tenv ~positive condition1 prop in let pset2 = prune tenv ~positive condition2 prop in Propset.union pset1 pset2 + let dangerous_functions = let dangerous_list = ["gets"] in ref (List.map ~f:Typ.Procname.from_string_c_fun dangerous_list) + let check_inherently_dangerous_function caller_pname callee_pname = if List.exists ~f:(Typ.Procname.equal callee_pname) !dangerous_functions then let exn = @@ -400,6 +416,7 @@ let check_inherently_dangerous_function caller_pname callee_pname = in Reporting.log_warning_deprecated caller_pname exn + let reason_to_skip callee_summary : string option = let attributes = callee_summary.Specs.attributes in if attributes.ProcAttributes.is_abstract then Some "abstract method" @@ -408,6 +425,7 @@ let reason_to_skip callee_summary : string option = Some "empty list of specs" else None + (** In case of constant string dereference, return the result immediately *) let check_constant_string_dereference lexp = let string_lookup s n = @@ -418,37 +436,41 @@ let check_constant_string_dereference lexp = Exp.int (IntLit.of_int c) in match lexp with - | Exp.BinOp (Binop.PlusPI, Exp.Const Const.Cstr s, e) | Exp.Lindex (Exp.Const Const.Cstr s, e) - -> let value = + | Exp.BinOp (Binop.PlusPI, Exp.Const Const.Cstr s, e) | Exp.Lindex (Exp.Const Const.Cstr s, e) -> + let value = match e with | Exp.Const Const.Cint n - when IntLit.geq n IntLit.zero && IntLit.leq n (IntLit.of_int (String.length s)) - -> string_lookup s n - | _ - -> Exp.get_undefined false + when IntLit.geq n IntLit.zero && IntLit.leq n (IntLit.of_int (String.length s)) -> + string_lookup s n + | _ -> + Exp.get_undefined false in Some value - | Exp.Const Const.Cstr s - -> Some (string_lookup s IntLit.zero) - | _ - -> None + | Exp.Const Const.Cstr s -> + Some (string_lookup s IntLit.zero) + | _ -> + None + (** Normalize an expression and check for arithmetic problems *) let check_arith_norm_exp tenv pname exp prop = match Attribute.find_arithmetic_problem tenv (State.get_path_pos ()) prop exp with - | Some Attribute.Div0 div, prop' - -> let desc = Errdesc.explain_divide_by_zero tenv div (State.get_node ()) (State.get_loc ()) in + | Some Attribute.Div0 div, prop' -> + let desc = Errdesc.explain_divide_by_zero tenv div (State.get_node ()) (State.get_loc ()) in let exn = Exceptions.Divide_by_zero (desc, __POS__) in - Reporting.log_warning_deprecated pname exn ; (Prop.exp_normalize_prop tenv prop exp, prop') - | Some Attribute.UminusUnsigned (e, typ), prop' - -> let desc = + Reporting.log_warning_deprecated pname exn ; + (Prop.exp_normalize_prop tenv prop exp, prop') + | Some Attribute.UminusUnsigned (e, typ), prop' -> + let desc = Errdesc.explain_unary_minus_applied_to_unsigned_expression tenv e typ (State.get_node ()) (State.get_loc ()) in let exn = Exceptions.Unary_minus_applied_to_unsigned_expression (desc, __POS__) in - Reporting.log_warning_deprecated pname exn ; (Prop.exp_normalize_prop tenv prop exp, prop') - | None, prop' - -> (Prop.exp_normalize_prop tenv prop exp, prop') + Reporting.log_warning_deprecated pname exn ; + (Prop.exp_normalize_prop tenv prop exp, prop') + | None, prop' -> + (Prop.exp_normalize_prop tenv prop exp, prop') + (** Check if [cond] is testing for NULL a pointer already dereferenced *) let check_already_dereferenced tenv pname cond prop = @@ -458,14 +480,14 @@ let check_already_dereferenced tenv pname cond prop = prop.Prop.sigma in let rec is_check_zero = function - | Exp.Var id - -> Some id - | Exp.UnOp (Unop.LNot, e, _) - -> is_check_zero e + | Exp.Var id -> + Some id + | Exp.UnOp (Unop.LNot, e, _) -> + is_check_zero e | Exp.BinOp ((Binop.Eq | Binop.Ne), Exp.Const Const.Cint i, Exp.Var id) | Exp.BinOp ((Binop.Eq | Binop.Ne), Exp.Var id, Exp.Const Const.Cint i) - when IntLit.iszero i - -> Some id + when IntLit.iszero i -> + Some id (* These two patterns appear frequently in Prune nodes *) | Exp.BinOp ( (Binop.Eq | Binop.Ne) @@ -475,10 +497,10 @@ let check_already_dereferenced tenv pname cond prop = ( (Binop.Eq | Binop.Ne) , Exp.BinOp (Binop.Eq, Exp.Const Const.Cint i, Exp.Var id) , Exp.Const Const.Cint j ) - when IntLit.iszero i && IntLit.iszero j - -> Some id - | _ - -> None + when IntLit.iszero i && IntLit.iszero j -> + Some id + | _ -> + None in let dereferenced_line = match is_check_zero cond with @@ -486,42 +508,45 @@ let check_already_dereferenced tenv pname cond prop = match find_hpred (Prop.exp_normalize_prop tenv prop (Exp.Var id)) with | Some Sil.Hpointsto (_, se, _) -> ( match Tabulation.find_dereference_without_null_check_in_sexp se with - | Some n - -> Some (id, n) - | None - -> None ) - | _ - -> None ) - | None - -> None + | Some n -> + Some (id, n) + | None -> + None ) + | _ -> + None ) + | None -> + None in match dereferenced_line with - | Some (id, (n, _)) - -> let desc = + | Some (id, (n, _)) -> + let desc = Errdesc.explain_null_test_after_dereference tenv (Exp.Var id) (State.get_node ()) n (State.get_loc ()) in let exn = Exceptions.Null_test_after_dereference (desc, __POS__) in Reporting.log_warning_deprecated pname exn - | None - -> () + | None -> + () + (** Check whether symbolic execution de-allocated a stack variable or a constant string, raising an exception in that case *) let check_deallocate_static_memory prop_after = let check_deallocated_attribute = function | Sil.Apred (Aresource ({ra_kind= Rrelease} as ra), [(Lvar pv)]) - when Pvar.is_local pv || Pvar.is_global pv - -> let freed_desc = Errdesc.explain_deallocate_stack_var pv ra in + when Pvar.is_local pv || Pvar.is_global pv -> + let freed_desc = Errdesc.explain_deallocate_stack_var pv ra in raise (Exceptions.Deallocate_stack_variable freed_desc) - | Sil.Apred (Aresource ({ra_kind= Rrelease} as ra), [(Const Cstr s)]) - -> let freed_desc = Errdesc.explain_deallocate_constant_string s ra in + | Sil.Apred (Aresource ({ra_kind= Rrelease} as ra), [(Const Cstr s)]) -> + let freed_desc = Errdesc.explain_deallocate_constant_string s ra in raise (Exceptions.Deallocate_static_memory freed_desc) - | _ - -> () + | _ -> + () in let exp_att_list = Attribute.get_all prop_after in - List.iter ~f:check_deallocated_attribute exp_att_list ; prop_after + List.iter ~f:check_deallocated_attribute exp_att_list ; + prop_after + let method_exists right_proc_name methods = if Config.curr_language_is Config.Java then @@ -531,10 +556,11 @@ let method_exists right_proc_name methods = the method has been called directly somewhere. It can still be that this is not the case but we have a model for the method. *) match Attributes.load right_proc_name with - | Some attrs - -> attrs.ProcAttributes.is_defined - | None - -> Specs.summary_exists_in_models right_proc_name + | Some attrs -> + attrs.ProcAttributes.is_defined + | None -> + Specs.summary_exists_in_models right_proc_name + let resolve_method tenv class_name proc_name = let found_class = @@ -544,63 +570,65 @@ let resolve_method tenv class_name proc_name = let right_proc_name = Typ.Procname.replace_class proc_name class_name in match Tenv.lookup tenv class_name with | Some {methods; supers} when Typ.Name.is_class class_name - -> ( + -> ( if method_exists right_proc_name methods then Some right_proc_name else match supers with - | super_classname :: _ - -> if not (Typ.Name.Set.mem super_classname !visited) then resolve super_classname + | super_classname :: _ -> + if not (Typ.Name.Set.mem super_classname !visited) then resolve super_classname else None - | _ - -> None ) - | _ - -> None + | _ -> + None ) + | _ -> + None in resolve class_name in match found_class with - | None - -> Logging.d_strln ("Couldn't find method in the hierarchy of type " ^ Typ.Name.name class_name) ; + | None -> + Logging.d_strln ("Couldn't find method in the hierarchy of type " ^ Typ.Name.name class_name) ; proc_name - | Some proc_name - -> proc_name + | Some proc_name -> + proc_name + let resolve_typename prop receiver_exp = let typexp_opt = let rec loop = function - | [] - -> None - | (Sil.Hpointsto (e, _, typexp)) :: _ when Exp.equal e receiver_exp - -> Some typexp - | _ :: hpreds - -> loop hpreds + | [] -> + None + | (Sil.Hpointsto (e, _, typexp)) :: _ when Exp.equal e receiver_exp -> + Some typexp + | _ :: hpreds -> + loop hpreds in loop prop.Prop.sigma in match typexp_opt with Some Exp.Sizeof {typ= {desc= Tstruct name}} -> Some name | _ -> None + (** If the dynamic type of the receiver actual T_actual is a subtype of the receiver type T_formal in the signature of [pname], resolve [pname] to T_actual.[pname]. *) let resolve_virtual_pname tenv prop actuals callee_pname call_flags : Typ.Procname.t list = let resolve receiver_exp pname prop = match resolve_typename prop receiver_exp with - | Some class_name - -> resolve_method tenv class_name pname - | None - -> pname + | Some class_name -> + resolve_method tenv class_name pname + | None -> + pname in let get_receiver_typ pname fallback_typ = match pname with | Typ.Procname.Java pname_java - -> ( + -> ( let name = Typ.Procname.java_get_class_type_name pname_java in match Tenv.lookup tenv name with - | Some _ - -> Typ.mk (Typ.Tptr (Typ.mk (Tstruct name), Pk_pointer)) - | None - -> fallback_typ ) - | _ - -> fallback_typ + | Some _ -> + Typ.mk (Typ.Tptr (Typ.mk (Tstruct name), Pk_pointer)) + | None -> + fallback_typ ) + | _ -> + fallback_typ in let receiver_types_equal pname actual_receiver_typ = (* the type of the receiver according to the function signature *) @@ -613,11 +641,11 @@ let resolve_virtual_pname tenv prop actuals callee_pname call_flags : Typ.Procna else called_pname in match actuals with - | _ when not (call_flags.CallFlags.cf_virtual || call_flags.CallFlags.cf_interface) - -> (* if this is not a virtual or interface call, there's no need for resolution *) + | _ when not (call_flags.CallFlags.cf_virtual || call_flags.CallFlags.cf_interface) -> + (* if this is not a virtual or interface call, there's no need for resolution *) [callee_pname] | (receiver_exp, actual_receiver_typ) :: _ - -> ( + -> ( if !Config.curr_language <> Config.Java then (* default mode for Obj-C/C++/Java virtual calls: resolution only *) [do_resolve callee_pname receiver_exp actual_receiver_typ] @@ -647,16 +675,17 @@ let resolve_virtual_pname tenv prop actuals callee_pname call_flags : Typ.Procna | target :: _ when call_flags.CallFlags.cf_interface && receiver_types_equal callee_pname actual_receiver_typ - && Typ.Procname.equal resolved_target callee_pname - -> (* "production mode" of dynamic dispatch for Java: unsound, but faster. the handling + && Typ.Procname.equal resolved_target callee_pname -> + (* "production mode" of dynamic dispatch for Java: unsound, but faster. the handling is restricted to interfaces: if we can't resolve an interface call, we pick the first implementation of the interface and call it *) [target] - | _ - -> (* default mode for Java virtual calls: resolution only *) + | _ -> + (* default mode for Java virtual calls: resolution only *) [resolved_target] ) - | _ - -> L.(die InternalError) "A virtual call must have a receiver" + | _ -> + L.(die InternalError) "A virtual call must have a receiver" + (** Resolve the name of the procedure to call based on the type of the arguments *) let resolve_java_pname tenv prop args pname_java call_flags : Typ.Procname.java = @@ -665,11 +694,12 @@ let resolve_java_pname tenv prop args pname_java call_flags : Typ.Procname.java List.fold2_exn ~f:(fun accu (arg_exp, _) name -> match resolve_typename prop arg_exp with - | Some class_name - -> Typ.Procname.split_classname (Typ.Name.name class_name) :: accu - | None - -> name :: accu) - ~init:[] args (Typ.Procname.java_get_parameters resolved_pname_java) + | Some class_name -> + Typ.Procname.split_classname (Typ.Name.name class_name) :: accu + | None -> + name :: accu) + ~init:[] args + (Typ.Procname.java_get_parameters resolved_pname_java) |> List.rev in Typ.Procname.java_replace_parameters resolved_pname_java resolved_params @@ -679,33 +709,34 @@ let resolve_java_pname tenv prop args pname_java call_flags : Typ.Procname.java and parameters = Typ.Procname.java_get_parameters pname_java in let match_parameters args = Int.equal (List.length args) (List.length parameters) in match args with - | [] - -> (pname_java, []) - | (first_arg, _) :: other_args when call_flags.CallFlags.cf_virtual - -> let resolved = + | [] -> + (pname_java, []) + | (first_arg, _) :: other_args when call_flags.CallFlags.cf_virtual -> + let resolved = match resolve_typename prop first_arg with | Some class_name -> ( match resolve_method tenv class_name pname with - | Typ.Procname.Java resolved_pname_java - -> resolved_pname_java - | _ - -> pname_java ) - | None - -> pname_java + | Typ.Procname.Java resolved_pname_java -> + resolved_pname_java + | _ -> + pname_java ) + | None -> + pname_java in (resolved, other_args) | _ :: other_args - when match_parameters other_args (* Non-virtual call, e.g. constructors or private methods *) - -> (pname_java, other_args) - | args when match_parameters args (* Static call *) - -> (pname_java, args) - | args - -> L.(die InternalError) + when match_parameters other_args (* Non-virtual call, e.g. constructors or private methods *) -> + (pname_java, other_args) + | args when match_parameters args (* Static call *) -> + (pname_java, args) + | args -> + L.(die InternalError) "Call mismatch: method %a has %i paramters but is called with %i arguments@." Typ.Procname.pp pname (List.length parameters) (List.length args) in resolve_from_args resolved_pname_java other_args + (** Resolve the procedure name and run the analysis of the resolved procedure if not already analyzed *) let resolve_and_analyze tenv caller_pdesc prop args callee_proc_name call_flags @@ -720,10 +751,10 @@ let resolve_and_analyze tenv caller_pdesc prop args callee_proc_name call_flags let analyze specialized_pdesc = Ondemand.analyze_proc_desc caller_pdesc specialized_pdesc in let resolved_proc_desc_option = match Ondemand.get_proc_desc resolved_pname with - | Some resolved_proc_desc - -> Some resolved_proc_desc - | None - -> Option.map + | Some resolved_proc_desc -> + Some resolved_proc_desc + | None -> + Option.map ~f:(fun callee_proc_desc -> Cfg.specialize_types callee_proc_desc resolved_pname args) (Ondemand.get_proc_desc callee_proc_name) @@ -732,51 +763,55 @@ let resolve_and_analyze tenv caller_pdesc prop args callee_proc_name call_flags in let resolved_pname = match callee_proc_name with - | Typ.Procname.Java callee_proc_name_java - -> Typ.Procname.Java (resolve_java_pname tenv prop args callee_proc_name_java call_flags) - | _ - -> callee_proc_name + | Typ.Procname.Java callee_proc_name_java -> + Typ.Procname.Java (resolve_java_pname tenv prop args callee_proc_name_java call_flags) + | _ -> + callee_proc_name in (resolved_pname, analyze_ondemand resolved_pname) + (** recognize calls to the constructor java.net.URL and splits the argument string to be only the protocol. *) let call_constructor_url_update_args pname actual_params = let url_pname = Typ.Procname.Java - (Typ.Procname.java (Typ.Name.Java.from_string "java.net.URL") None "" - [(Some "java.lang", "String")] Typ.Procname.Non_Static) + (Typ.Procname.java + (Typ.Name.Java.from_string "java.net.URL") + None "" [(Some "java.lang", "String")] Typ.Procname.Non_Static) in if Typ.Procname.equal url_pname pname then match actual_params with | [this; (Exp.Const Const.Cstr s, atype)] - -> ( + -> ( let parts = Str.split (Str.regexp_string "://") s in match parts with - | frst :: _ - -> if String.equal frst "http" || String.equal frst "ftp" || String.equal frst "https" + | frst :: _ -> + if String.equal frst "http" || String.equal frst "ftp" || String.equal frst "https" || String.equal frst "mailto" || String.equal frst "jar" then [this; (Exp.Const (Const.Cstr frst), atype)] else actual_params - | _ - -> actual_params ) - | [this; (_, atype)] - -> [this; (Exp.Const (Const.Cstr "file"), atype)] - | _ - -> actual_params + | _ -> + actual_params ) + | [this; (_, atype)] -> + [this; (Exp.Const (Const.Cstr "file"), atype)] + | _ -> + actual_params else actual_params + let receiver_self receiver prop = List.exists ~f:(fun hpred -> match hpred with - | Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (e, _), _) - -> Exp.equal e receiver && Pvar.is_seed pv + | Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (e, _), _) -> + Exp.equal e receiver && Pvar.is_seed pv && Mangled.equal (Pvar.get_name pv) (Mangled.from_string "self") - | _ - -> false) + | _ -> + false) prop.Prop.sigma + (* When current ObjC method is an initializer and the method call is also an initializer, and the receiver is self, i.e. the call is [super init], then we want to assume that it can return null, regardless of code or annotations, so that the next statement should be @@ -787,16 +822,17 @@ let force_objc_init_return_nil pdesc callee_pname tenv ret_id pre path receiver && Typ.Procname.is_constructor current_pname then match ret_id with - | Some (ret_id, _) - -> let propset = prune_ne tenv ~positive:false (Exp.Var ret_id) Exp.zero pre in + | Some (ret_id, _) -> + let propset = prune_ne tenv ~positive:false (Exp.Var ret_id) Exp.zero pre in if Propset.is_empty propset then [] else let prop = List.hd_exn (Propset.to_proplist propset) in [(prop, path)] - | _ - -> [] + | _ -> + [] else [] + (* This method is used to handle the special semantics of ObjC instance method calls. *) (* res = [obj foo] *) (* 1. We know that obj is null, then we return null *) @@ -810,31 +846,31 @@ let handle_objc_instance_method_call_or_skip pdesc tenv actual_pars path callee_ in let receiver = match actual_pars with - | (e, _) :: _ - -> e - | _ - -> raise + | (e, _) :: _ -> + e + | _ -> + raise (Exceptions.Internal_error (Localise.verbatim_desc "In Objective-C instance method call there should be a receiver.")) in let is_receiver_null = match actual_pars with - | (e, _) :: _ when Exp.equal e Exp.zero || Option.is_some (Attribute.get_objc_null tenv pre e) - -> true - | _ - -> false + | (e, _) :: _ when Exp.equal e Exp.zero || Option.is_some (Attribute.get_objc_null tenv pre e) -> + true + | _ -> + false in let add_objc_null_attribute_or_nullify_result prop = match ret_id with | Some (ret_id, _) -> ( match Attribute.find_equal_formal_path tenv receiver prop with - | Some vfs - -> Attribute.add_or_replace tenv prop (Apred (Aobjc_null, [Exp.Var ret_id; vfs])) - | None - -> Prop.conjoin_eq tenv (Exp.Var ret_id) Exp.zero prop ) - | _ - -> prop + | Some vfs -> + Attribute.add_or_replace tenv prop (Apred (Aobjc_null, [Exp.Var ret_id; vfs])) + | None -> + Prop.conjoin_eq tenv (Exp.Var ret_id) Exp.zero prop ) + | _ -> + prop in if is_receiver_null then (* objective-c instance method with a null receiver just return objc_null(res). *) @@ -849,8 +885,8 @@ let handle_objc_instance_method_call_or_skip pdesc tenv actual_pars path callee_ [(add_objc_null_attribute_or_nullify_result pre, path)] else match force_objc_init_return_nil pdesc callee_pname tenv ret_id pre path receiver with - | [] - -> if !Config.footprint && Option.is_none (Attribute.get_undef tenv pre receiver) + | [] -> + if !Config.footprint && Option.is_none (Attribute.get_undef tenv pre receiver) && not (Rearrange.is_only_pt_by_fld_or_param_nonnull pdesc tenv pre receiver) then let res_null = @@ -866,8 +902,9 @@ let handle_objc_instance_method_call_or_skip pdesc tenv actual_pars path callee_ List.append res_null (res ()) else res () (* Not known if receiver = 0 and not footprint. Standard tabulation *) - | res_null - -> List.append res_null (res ()) + | res_null -> + List.append res_null (res ()) + (* This method handles ObjC instance method calls, in particular the fact that calling a method *) (* with nil returns nil. The exec_call function is either standard call execution or execution *) @@ -877,6 +914,7 @@ let handle_objc_instance_method_call actual_pars actual_params pre tenv ret_id p let res () = exec_call tenv ret_id pdesc callee_pname loc actual_params pre path in handle_objc_instance_method_call_or_skip pdesc tenv actual_pars path callee_pname pre ret_id res + let normalize_params tenv pdesc prop actual_params = let norm_arg (p, args) (e, t) = let e', p' = check_arith_norm_exp tenv pdesc e p in @@ -885,6 +923,7 @@ let normalize_params tenv pdesc prop actual_params = let prop, args = List.fold ~f:norm_arg ~init:(prop, []) actual_params in (prop, List.rev args) + let add_strexp_to_footprint tenv strexp abduced_pv typ prop = let abduced_lvar = Exp.Lvar abduced_pv in let lvar_pt_fpvar = @@ -896,6 +935,7 @@ let add_strexp_to_footprint tenv strexp abduced_pv typ prop = let sigma_fp = prop.Prop.sigma_fp in Prop.normalize tenv (Prop.set prop ~sigma_fp:(lvar_pt_fpvar :: sigma_fp)) + let add_to_footprint tenv abduced_pv typ prop = let fresh_fp_var = Exp.Var (Ident.create_fresh Ident.kfootprint) in let prop' = @@ -903,6 +943,7 @@ let add_to_footprint tenv abduced_pv typ prop = in (prop', fresh_fp_var) + (* the current abduction mechanism treats struct values differently than all other types. abduction on struct values adds a a struct whose fields are initialized to fresh footprint vars to the footprint. regular abduction just adds a fresh footprint value of the correct type to the @@ -912,6 +953,7 @@ let add_struct_value_to_footprint tenv abduced_pv typ prop = let prop' = add_strexp_to_footprint tenv struct_strexp abduced_pv typ prop in (prop', struct_strexp) + let add_constraints_on_retval tenv pdesc prop ret_exp ~has_nonnull_annot typ callee_pname callee_loc = if Typ.Procname.is_infer_undefined callee_pname then prop @@ -924,19 +966,19 @@ let add_constraints_on_retval tenv pdesc prop ret_exp ~has_nonnull_annot typ cal List.find_map ~f:(fun hpred -> match hpred with - | Sil.Hpointsto (Exp.Lvar pv, _, exp) when Pvar.equal pv abduced_ret_pv - -> Some exp - | _ - -> None) + | Sil.Hpointsto (Exp.Lvar pv, _, exp) when Pvar.equal pv abduced_ret_pv -> + Some exp + | _ -> + None) p.Prop.sigma_fp in (* find an hpred [abduced] |-> A in [prop] and add [exp] = A to prop *) let bind_exp_to_abduced_val exp_to_bind abduced prop = let bind_exp prop = function - | Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (rhs, _), _) when Pvar.equal pv abduced - -> Prop.conjoin_eq tenv exp_to_bind rhs prop - | _ - -> prop + | Sil.Hpointsto (Exp.Lvar pv, Sil.Eexp (rhs, _), _) when Pvar.equal pv abduced -> + Prop.conjoin_eq tenv exp_to_bind rhs prop + | _ -> + prop in List.fold ~f:bind_exp ~init:prop prop.Prop.sigma in @@ -956,11 +998,11 @@ let add_constraints_on_retval tenv pdesc prop ret_exp ~has_nonnull_annot typ cal in if !Config.footprint then match lookup_abduced_expression prop abduced_ret_pv with - | None - -> let p, fp_var = add_to_footprint tenv abduced_ret_pv typ prop in + | None -> + let p, fp_var = add_to_footprint tenv abduced_ret_pv typ prop in Prop.conjoin_eq tenv ~footprint:true ret_exp fp_var p - | Some exp - -> Prop.conjoin_eq tenv ~footprint:true ret_exp exp prop + | Some exp -> + Prop.conjoin_eq tenv ~footprint:true ret_exp exp prop else (* bind return id to the abduced value pointed to by the pvar we introduced *) bind_exp_to_abduced_val ret_exp abduced_ret_pv prop @@ -968,13 +1010,14 @@ let add_constraints_on_retval tenv pdesc prop ret_exp ~has_nonnull_annot typ cal add_ret_non_null ret_exp typ prop_with_abduced_var else add_ret_non_null ret_exp typ prop + let execute_load ?(report_deref_errors= true) pname pdesc tenv id rhs_exp typ loc prop_ = let execute_load_ acc_in iter = let iter_ren = Prop.prop_iter_make_id_primed tenv id iter in let prop_ren = Prop.prop_iter_to_prop tenv iter_ren in match Prop.prop_iter_current tenv iter_ren with | Sil.Hpointsto (lexp, strexp, Exp.Sizeof sizeof_data), offlist - -> ( + -> ( let contents, new_ptsto, pred_insts_op, lookup_uninitialized = ptsto_lookup pdesc tenv prop_ren (lexp, strexp, sizeof_data) offlist id in @@ -991,15 +1034,15 @@ let execute_load ?(report_deref_errors= true) pname pdesc tenv id rhs_exp typ lo prop'' :: acc in match pred_insts_op with - | None - -> update acc_in ([], []) - | Some pred_insts - -> List.rev (List.fold ~f:update ~init:acc_in pred_insts) ) - | Sil.Hpointsto _, _ - -> Errdesc.warning_err loc "no offset access in execute_load -- treating as skip@." ; + | None -> + update acc_in ([], []) + | Some pred_insts -> + List.rev (List.fold ~f:update ~init:acc_in pred_insts) ) + | Sil.Hpointsto _, _ -> + Errdesc.warning_err loc "no offset access in execute_load -- treating as skip@." ; Prop.prop_iter_to_prop tenv iter_ren :: acc_in - | _ - -> (* The implementation of this case means that we + | _ -> + (* The implementation of this case means that we ignore this dereferencing operator. When the analyzer treats numerical information and arrays more precisely later, we should change the implementation here. *) @@ -1009,8 +1052,8 @@ let execute_load ?(report_deref_errors= true) pname pdesc tenv id rhs_exp typ lo let n_rhs_exp, prop = check_arith_norm_exp tenv pname rhs_exp prop_ in let n_rhs_exp' = Prop.exp_collapse_consecutive_indices_prop typ n_rhs_exp in match check_constant_string_dereference n_rhs_exp' with - | Some value - -> [Prop.conjoin_eq tenv (Exp.Var id) value prop] + | Some value -> + [Prop.conjoin_eq tenv (Exp.Var id) value prop] | None -> try let iter_list = @@ -1028,22 +1071,24 @@ let execute_load ?(report_deref_errors= true) pname pdesc tenv id rhs_exp typ lo let undef = Exp.get_undefined false in [Prop.conjoin_eq tenv (Exp.Var id) undef prop_] + let load_ret_annots pname = match Attributes.load pname with - | Some attrs - -> let ret_annots, _ = attrs.ProcAttributes.method_annotation in + | Some attrs -> + let ret_annots, _ = attrs.ProcAttributes.method_annotation in ret_annots - | None - -> Annot.Item.empty + | None -> + Annot.Item.empty + let execute_store ?(report_deref_errors= true) pname pdesc tenv lhs_exp typ rhs_exp loc prop_ = let execute_store_ pdesc tenv rhs_exp acc_in iter = let lexp, strexp, sizeof, offlist = match Prop.prop_iter_current tenv iter with - | Sil.Hpointsto (lexp, strexp, Exp.Sizeof sizeof), offlist - -> (lexp, strexp, sizeof, offlist) - | _ - -> assert false + | Sil.Hpointsto (lexp, strexp, Exp.Sizeof sizeof), offlist -> + (lexp, strexp, sizeof, offlist) + | _ -> + assert false in let p = Prop.prop_iter_to_prop tenv iter in let new_ptsto, pred_insts_op = @@ -1056,10 +1101,10 @@ let execute_store ?(report_deref_errors= true) pname pdesc tenv lhs_exp typ rhs_ prop' :: acc in match pred_insts_op with - | None - -> update acc_in ([], []) - | Some pred_insts - -> List.fold ~f:update ~init:acc_in pred_insts + | None -> + update acc_in ([], []) + | Some pred_insts -> + List.fold ~f:update ~init:acc_in pred_insts in try let n_lhs_exp, prop_' = check_arith_norm_exp tenv pname lhs_exp prop_ in @@ -1070,6 +1115,7 @@ let execute_store ?(report_deref_errors= true) pname pdesc tenv lhs_exp typ rhs_ List.rev (List.fold ~f:(execute_store_ pdesc tenv n_rhs_exp) ~init:[] iter_list) with Rearrange.ARRAY_ACCESS -> if Int.equal Config.array_level 0 then assert false else [prop_] + (** Execute [instr] with a symbolic heap [prop].*) let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path : (Prop.normal Prop.t * Paths.Path.t) list = @@ -1086,21 +1132,21 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path in let instr = match _instr with - | Sil.Call (ret, exp, par, loc, call_flags) - -> let exp' = Prop.exp_normalize_prop tenv prop_ exp in + | Sil.Call (ret, exp, par, loc, call_flags) -> + let exp' = Prop.exp_normalize_prop tenv prop_ exp in let instr' = match exp' with - | Exp.Closure c - -> let proc_exp = Exp.Const (Const.Cfun c.name) in + | Exp.Closure c -> + let proc_exp = Exp.Const (Const.Cfun c.name) in let proc_exp' = Prop.exp_normalize_prop tenv prop_ proc_exp in let par' = List.map ~f:(fun (id_exp, _, typ) -> (id_exp, typ)) c.captured_vars in Sil.Call (ret, proc_exp', par' @ par, loc, call_flags) - | _ - -> Sil.Call (ret, exp', par, loc, call_flags) + | _ -> + Sil.Call (ret, exp', par, loc, call_flags) in instr' - | _ - -> _instr + | _ -> + _instr in let skip_call ?(is_objc_instance_method= false) ~reason prop path callee_pname ret_annots loc ret_id ret_typ_opt actual_args = @@ -1111,10 +1157,10 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path ( "Undefined function " ^ Typ.Procname.to_string callee_pname ^ ", returning undefined value." ) ; ( match Specs.get_summary current_pname with - | None - -> () - | Some summary - -> Specs.CallStats.trace summary.Specs.stats.Specs.call_stats callee_pname loc + | None -> + () + | Some summary -> + Specs.CallStats.trace summary.Specs.stats.Specs.call_stats callee_pname loc Specs.CallStats.CR_skip !Config.footprint ) ; unknown_or_scan_call ~is_scan:false ~reason ret_typ_opt ret_annots (Builtin. @@ -1137,39 +1183,39 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path {Builtin.pdesc= current_pdesc; instr; tenv; prop_; path; ret_id; args; proc_name; loc} in match instr with - | Sil.Load (id, rhs_exp, typ, loc) - -> execute_load current_pname current_pdesc tenv id rhs_exp typ loc prop_ |> ret_old_path - | Sil.Store (lhs_exp, typ, rhs_exp, loc) - -> execute_store current_pname current_pdesc tenv lhs_exp typ rhs_exp loc prop_ |> ret_old_path - | Sil.Prune (cond, loc, true_branch, ik) - -> let prop__ = Attribute.nullify_exp_with_objc_null tenv prop_ cond in + | Sil.Load (id, rhs_exp, typ, loc) -> + execute_load current_pname current_pdesc tenv id rhs_exp typ loc prop_ |> ret_old_path + | Sil.Store (lhs_exp, typ, rhs_exp, loc) -> + execute_store current_pname current_pdesc tenv lhs_exp typ rhs_exp loc prop_ |> ret_old_path + | Sil.Prune (cond, loc, true_branch, ik) -> + let prop__ = Attribute.nullify_exp_with_objc_null tenv prop_ cond in let check_condition_always_true_false () = if !Config.curr_language <> Config.Clang || Config.report_condition_always_true_in_clang then let report_condition_always_true_false i = let skip_loop = match ik with - | Sil.Ik_while | Sil.Ik_for - -> not (IntLit.iszero i) (* skip wile(1) and for (;1;) *) - | Sil.Ik_dowhile - -> true (* skip do..while *) - | Sil.Ik_land_lor - -> true (* skip subpart of a condition obtained from compilation of && and || *) - | _ - -> false + | Sil.Ik_while | Sil.Ik_for -> + not (IntLit.iszero i) (* skip wile(1) and for (;1;) *) + | Sil.Ik_dowhile -> + true (* skip do..while *) + | Sil.Ik_land_lor -> + true (* skip subpart of a condition obtained from compilation of && and || *) + | _ -> + false in true_branch && not skip_loop in match Prop.exp_normalize_prop tenv Prop.prop_emp cond with - | Exp.Const Const.Cint i when report_condition_always_true_false i - -> let node = State.get_node () in + | Exp.Const Const.Cint i when report_condition_always_true_false i -> + let node = State.get_node () in let desc = Errdesc.explain_condition_always_true_false tenv i cond node loc in let exn = Exceptions.Condition_always_true_false (desc, not (IntLit.iszero i), __POS__) in Reporting.log_warning_deprecated current_pname exn - | _ - -> () + | _ -> + () in if not (Config.tracing || Typ.Procname.is_java current_pname) then check_already_dereferenced tenv current_pname cond prop__ ; @@ -1178,12 +1224,12 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path ret_old_path (Propset.to_proplist (prune tenv ~positive:true n_cond prop)) | Sil.Call (ret_id, Exp.Const Const.Cfun callee_pname, actual_params, loc, call_flags) -> ( match Builtin.get callee_pname with - | Some exec_builtin - -> exec_builtin (call_args prop_ callee_pname actual_params ret_id loc) + | Some exec_builtin -> + exec_builtin (call_args prop_ callee_pname actual_params ret_id loc) | None -> match callee_pname with | Java callee_pname_java when Config.(equal_dynamic_dispatch dynamic_dispatch Lazy) - -> ( + -> ( let norm_prop, norm_args' = normalize_params tenv current_pname prop_ actual_params in let norm_args = call_constructor_url_update_args callee_pname norm_args' in let exec_skip_call ~reason skipped_pname ret_annots ret_type = @@ -1194,21 +1240,21 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path resolve_and_analyze tenv current_pdesc norm_prop norm_args callee_pname call_flags in match resolved_summary_opt with - | None - -> let ret_typ = Typ.java_proc_return_typ callee_pname_java in + | None -> + let ret_typ = Typ.java_proc_return_typ callee_pname_java in let ret_annots = load_ret_annots callee_pname in exec_skip_call ~reason:"unknown method" resolved_pname ret_annots ret_typ | Some resolved_summary -> match reason_to_skip resolved_summary with - | None - -> proc_call resolved_summary (call_args prop_ callee_pname norm_args ret_id loc) - | Some reason - -> let proc_attrs = resolved_summary.Specs.attributes in + | None -> + proc_call resolved_summary (call_args prop_ callee_pname norm_args ret_id loc) + | Some reason -> + let proc_attrs = resolved_summary.Specs.attributes in let ret_annots, _ = proc_attrs.ProcAttributes.method_annotation in exec_skip_call ~reason resolved_pname ret_annots proc_attrs.ProcAttributes.ret_type ) - | Java callee_pname_java - -> let norm_prop, norm_args = normalize_params tenv current_pname prop_ actual_params in + | Java callee_pname_java -> + let norm_prop, norm_args = normalize_params tenv current_pname prop_ actual_params in let url_handled_args = call_constructor_url_update_args callee_pname norm_args in let resolved_pnames = resolve_virtual_pname tenv norm_prop url_handled_args callee_pname call_flags @@ -1219,30 +1265,30 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path url_handled_args in match Ondemand.analyze_proc_name current_pdesc pname with - | None - -> let ret_typ = Typ.java_proc_return_typ callee_pname_java in + | None -> + let ret_typ = Typ.java_proc_return_typ callee_pname_java in let ret_annots = load_ret_annots callee_pname in exec_skip_call ~reason:"unknown method" ret_annots ret_typ | Some callee_summary -> match reason_to_skip callee_summary with - | None - -> let handled_args = call_args norm_prop pname url_handled_args ret_id loc in + | None -> + let handled_args = call_args norm_prop pname url_handled_args ret_id loc in proc_call callee_summary handled_args - | Some reason - -> let proc_attrs = callee_summary.Specs.attributes in + | Some reason -> + let proc_attrs = callee_summary.Specs.attributes in let ret_annots, _ = proc_attrs.ProcAttributes.method_annotation in exec_skip_call ~reason ret_annots proc_attrs.ProcAttributes.ret_type in List.fold ~f:(fun acc pname -> exec_one_pname pname @ acc) ~init:[] resolved_pnames - | _ - -> (* Generic fun call with known name *) + | _ -> + (* Generic fun call with known name *) let prop_r, n_actual_params = normalize_params tenv current_pname prop_ actual_params in let resolved_pname = match resolve_virtual_pname tenv prop_r n_actual_params callee_pname call_flags with - | resolved_pname :: _ - -> resolved_pname - | [] - -> callee_pname + | resolved_pname :: _ -> + resolved_pname + | [] -> + callee_pname in let resolved_summary_opt = Ondemand.analyze_proc_name current_pdesc resolved_pname in let callee_pdesc_opt = Ondemand.get_proc_desc resolved_pname in @@ -1262,56 +1308,57 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path let attrs_opt = let attr_opt = Option.map ~f:Procdesc.get_attributes callee_pdesc_opt in match (attr_opt, resolved_pname) with - | Some attrs, Typ.Procname.ObjC_Cpp _ - -> Some attrs - | None, Typ.Procname.ObjC_Cpp _ - -> Attributes.load resolved_pname - | _ - -> None + | Some attrs, Typ.Procname.ObjC_Cpp _ -> + Some attrs + | None, Typ.Procname.ObjC_Cpp _ -> + Attributes.load resolved_pname + | _ -> + None in let objc_property_accessor_ret_typ_opt = match attrs_opt with | Some attrs -> ( match attrs.ProcAttributes.objc_accessor with - | Some objc_accessor - -> Some (objc_accessor, attrs.ProcAttributes.ret_type) - | None - -> None ) - | None - -> None + | Some objc_accessor -> + Some (objc_accessor, attrs.ProcAttributes.ret_type) + | None -> + None ) + | None -> + None in match objc_property_accessor_ret_typ_opt with - | Some (objc_property_accessor, ret_typ) - -> handle_objc_instance_method_call n_actual_params n_actual_params prop tenv ret_id + | Some (objc_property_accessor, ret_typ) -> + handle_objc_instance_method_call n_actual_params n_actual_params prop tenv ret_id current_pdesc callee_pname loc path (sym_exec_objc_accessor objc_property_accessor ret_typ) - | None - -> let ret_annots = + | None -> + let ret_annots = match resolved_summary_opt with - | Some summ - -> let ret_annots, _ = + | Some summ -> + let ret_annots, _ = summ.Specs.attributes.ProcAttributes.method_annotation in ret_annots - | None - -> load_ret_annots resolved_pname + | None -> + load_ret_annots resolved_pname in let is_objc_instance_method = match attrs_opt with - | Some attrs - -> attrs.ProcAttributes.is_objc_instance_method - | None - -> false + | Some attrs -> + attrs.ProcAttributes.is_objc_instance_method + | None -> + false in skip_call ~is_objc_instance_method ~reason:"function or method not found" prop path resolved_pname ret_annots loc ret_id ret_typ_opt n_actual_params else - proc_call (Option.value_exn resolved_summary_opt) + proc_call + (Option.value_exn resolved_summary_opt) (call_args prop resolved_pname n_actual_params ret_id loc) in List.concat_map ~f:do_call sentinel_result ) - | Sil.Call (ret_id, fun_exp, actual_params, loc, call_flags) - -> (* Call via function pointer *) + | Sil.Call (ret_id, fun_exp, actual_params, loc, call_flags) -> + (* Call via function pointer *) let prop_r, n_actual_params = normalize_params tenv current_pname prop_ actual_params in if call_flags.CallFlags.cf_is_objc_block && not (Rearrange.is_only_pt_by_fld_or_param_nonnull current_pdesc tenv prop_r fun_exp) @@ -1340,7 +1387,7 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path ; proc_name= callee_pname ; loc }) ) | Sil.Nullify (pvar, _) - -> ( + -> ( let eprop = Prop.expose prop_ in match List.partition_tf @@ -1348,21 +1395,21 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path | Sil.Hpointsto (Exp.Lvar pvar', _, _) -> Pvar.equal pvar pvar' | _ -> false) eprop.Prop.sigma with - | [(Sil.Hpointsto (e, se, typ))], sigma' - -> let sigma'' = + | [(Sil.Hpointsto (e, se, typ))], sigma' -> + let sigma'' = let se' = execute_nullify_se se in Sil.Hpointsto (e, se', typ) :: sigma' in let eprop_res = Prop.set eprop ~sigma:sigma'' in ret_old_path [Prop.normalize tenv eprop_res] - | [], _ - -> ret_old_path [prop_] - | _ - -> L.internal_error "Pvar %a appears on the LHS of >1 heap predicate!@." (Pvar.pp Pp.text) + | [], _ -> + ret_old_path [prop_] + | _ -> + L.internal_error "Pvar %a appears on the LHS of >1 heap predicate!@." (Pvar.pp Pp.text) pvar ; assert false ) - | Sil.Abstract _ - -> let node = State.get_node () in + | Sil.Abstract _ -> + let node = State.get_node () in let blocks_nullified = get_blocks_nullified node in List.iter ~f:(check_block_retain_cycle tenv current_pname prop_) blocks_nullified ; if Prover.check_inconsistency tenv prop_ then ret_old_path [] @@ -1370,15 +1417,16 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path ret_old_path [ Abs.remove_redundant_array_elements current_pname tenv (Abs.abstract current_pname tenv prop_) ] - | Sil.Remove_temps (temps, _) - -> ret_old_path [Prop.exist_quantify tenv (Sil.fav_from_list temps) prop_] - | Sil.Declare_locals (ptl, _) - -> let sigma_locals = + | Sil.Remove_temps (temps, _) -> + ret_old_path [Prop.exist_quantify tenv (Sil.fav_from_list temps) prop_] + | Sil.Declare_locals (ptl, _) -> + let sigma_locals = let add_None (x, typ) = (x, Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.exact}, None) in let sigma_locals () = - List.map ~f:(Prop.mk_ptsto_lvar tenv Prop.Fld_init Sil.inst_initial) + List.map + ~f:(Prop.mk_ptsto_lvar tenv Prop.Fld_init Sil.inst_initial) (List.map ~f:add_None ptl) in Config.run_in_re_execution_mode (* no footprint vars for locals *) @@ -1388,11 +1436,13 @@ let rec sym_exec tenv current_pdesc _instr (prop_: Prop.normal Prop.t) path let prop' = Prop.normalize tenv (Prop.set prop_ ~sigma:sigma') in ret_old_path [prop'] + and diverge prop path = State.add_diverging_states (Paths.PathSet.from_renamed_list [(prop, path)]) ; (* diverge *) [] + (** Symbolic execution of a sequence of instructions. If errors occur and [mask_errors] is true, just treat as skip. *) and instrs ?(mask_errors= false) tenv pdesc instrs ppl = @@ -1414,23 +1464,24 @@ and instrs ?(mask_errors= false) tenv pdesc instrs ppl = let f plist instr = List.concat_map ~f:(exe_instr instr) plist in List.fold ~f ~init:ppl instrs + and add_constraints_on_actuals_by_ref tenv prop actuals_by_ref callee_pname callee_loc = let add_actual_by_ref_to_footprint prop (actual, actual_typ, actual_index) = let abduced = match actual with - | Exp.Lvar _ | Exp.Var _ - -> Pvar.mk_abduced_ref_param callee_pname actual_index callee_loc - | _ - -> L.(die InternalError) "Unexpected variable expression %a" Exp.pp actual + | Exp.Lvar _ | Exp.Var _ -> + Pvar.mk_abduced_ref_param callee_pname actual_index callee_loc + | _ -> + L.(die InternalError) "Unexpected variable expression %a" Exp.pp actual in let already_has_abduced_retval p = List.exists ~f:(fun hpred -> match hpred with - | Sil.Hpointsto (Exp.Lvar pv, _, _) - -> Pvar.equal pv abduced - | _ - -> false) + | Sil.Hpointsto (Exp.Lvar pv, _, _) -> + Pvar.equal pv abduced + | _ -> + false) p.Prop.sigma_fp in (* prevent introducing multiple abduced retvals for a single call site in a loop *) @@ -1438,25 +1489,25 @@ and add_constraints_on_actuals_by_ref tenv prop actuals_by_ref callee_pname call else if !Config.footprint then let prop', abduced_strexp = match actual_typ.Typ.desc with - | Typ.Tptr (({desc= Tstruct _} as typ), _) - -> (* for struct types passed by reference, do abduction on the fields of the + | Typ.Tptr (({desc= Tstruct _} as typ), _) -> + (* for struct types passed by reference, do abduction on the fields of the struct *) add_struct_value_to_footprint tenv abduced typ prop - | Typ.Tptr (typ, _) - -> (* for pointer types passed by reference, do abduction directly on the pointer *) + | Typ.Tptr (typ, _) -> + (* for pointer types passed by reference, do abduction directly on the pointer *) let prop', fresh_fp_var = add_to_footprint tenv abduced typ prop in (prop', Sil.Eexp (fresh_fp_var, Sil.Inone)) - | _ - -> L.(die InternalError) + | _ -> + L.(die InternalError) "No need for abduction on non-pointer type %s" (Typ.to_string actual_typ) in let filtered_sigma = List.map ~f:(function - | Sil.Hpointsto (lhs, _, typ_exp) when Exp.equal lhs actual - -> Sil.Hpointsto (lhs, abduced_strexp, typ_exp) - | hpred - -> hpred) + | Sil.Hpointsto (lhs, _, typ_exp) when Exp.equal lhs actual -> + Sil.Hpointsto (lhs, abduced_strexp, typ_exp) + | hpred -> + hpred) prop'.Prop.sigma in Prop.normalize tenv (Prop.set prop' ~sigma:filtered_sigma) @@ -1474,30 +1525,31 @@ and add_constraints_on_actuals_by_ref tenv prop actuals_by_ref callee_pname call List.fold ~f:(fun p hpred -> match hpred with - | Sil.Hpointsto (Exp.Lvar pv, rhs, texp) when Pvar.equal pv abduced - -> let new_hpred = Sil.Hpointsto (actual, rhs, texp) in + | Sil.Hpointsto (Exp.Lvar pv, rhs, texp) when Pvar.equal pv abduced -> + let new_hpred = Sil.Hpointsto (actual, rhs, texp) in Prop.normalize tenv (Prop.set p ~sigma:(new_hpred :: prop'.Prop.sigma)) - | _ - -> p) + | _ -> + p) ~init:prop' prop'.Prop.sigma in let non_const_actuals_by_ref = let is_not_const (e, _, i) = match Attributes.load callee_pname with - | Some attrs - -> let is_const = List.mem ~equal:Int.equal attrs.ProcAttributes.const_formals i in + | Some attrs -> + let is_const = List.mem ~equal:Int.equal attrs.ProcAttributes.const_formals i in if is_const then ( L.d_str (Printf.sprintf "Not havocing const argument number %d: " i) ; Sil.d_exp e ; L.d_ln () ) ; not is_const - | None - -> true + | None -> + true in List.filter ~f:is_not_const actuals_by_ref in List.fold ~f:add_actual_by_ref_to_footprint ~init:prop non_const_actuals_by_ref + (** execute a call for an unknown or scan function *) and unknown_or_scan_call ~is_scan ~reason ret_type_option ret_annots {Builtin.tenv; pdesc; prop_= pre; path; ret_id; args; proc_name= callee_pname; loc; instr} = @@ -1505,48 +1557,48 @@ and unknown_or_scan_call ~is_scan ~reason ret_type_option ret_annots let do_exp p (e, _) = let do_attribute q atom = match atom with - | Sil.Apred ((Aresource {ra_res= Rfile} as res), _) - -> Attribute.remove_for_attr tenv q res - | _ - -> q + | Sil.Apred ((Aresource {ra_res= Rfile} as res), _) -> + Attribute.remove_for_attr tenv q res + | _ -> + q in List.fold ~f:do_attribute ~init:p (Attribute.get_for_exp tenv p e) in let filtered_args = match (args, instr) with - | _ :: other_args, Sil.Call (_, _, _, _, {CallFlags.cf_virtual}) when cf_virtual - -> (* Do not remove the file attribute on the reciver for virtual calls *) + | _ :: other_args, Sil.Call (_, _, _, _, {CallFlags.cf_virtual}) when cf_virtual -> + (* Do not remove the file attribute on the reciver for virtual calls *) other_args - | _ - -> args + | _ -> + args in List.fold ~f:do_exp ~init:prop filtered_args in let should_abduce_param_value pname = let open Typ.Procname in match pname with - | Java _ - -> (* FIXME (T19882766): we need to disable this for Java because it breaks too many tests *) + | Java _ -> + (* FIXME (T19882766): we need to disable this for Java because it breaks too many tests *) false - | ObjC_Cpp _ - -> (* FIXME: we need to work around a frontend hack for std::shared_ptr + | ObjC_Cpp _ -> + (* FIXME: we need to work around a frontend hack for std::shared_ptr * to silent some of the uninitialization warnings *) if String.is_suffix ~suffix:"_std__shared_ptr" (Typ.Procname.to_string callee_pname) then false else true - | _ - -> true + | _ -> + true in let actuals_by_ref = List.filter_mapi ~f:(fun i actual -> match actual with - | (Exp.Lvar _ as e), ({Typ.desc= Tptr _} as t) - -> Some (e, t, i) - | (Exp.Var _ as e), ({Typ.desc= Tptr _} as t) when should_abduce_param_value callee_pname - -> Some (e, t, i) - | _ - -> None) + | (Exp.Lvar _ as e), ({Typ.desc= Tptr _} as t) -> + Some (e, t, i) + | (Exp.Var _ as e), ({Typ.desc= Tptr _} as t) when should_abduce_param_value callee_pname -> + Some (e, t, i) + | _ -> + None) args in let has_nonnull_annot = Annotations.ia_is_nonnull ret_annots in @@ -1555,12 +1607,12 @@ and unknown_or_scan_call ~is_scan ~reason ret_type_option ret_annots let pre_1 = if Typ.Procname.is_java callee_pname then remove_file_attribute pre else pre in let pre_2 = match (ret_id, ret_type_option) with - | Some (ret_id, _), Some ret_typ - -> (* TODO(jjb): Should this use the type of ret_id, or ret_type from the procedure type? *) + | Some (ret_id, _), Some ret_typ -> + (* TODO(jjb): Should this use the type of ret_id, or ret_type from the procedure type? *) add_constraints_on_retval tenv pdesc pre_1 (Exp.Var ret_id) ret_typ ~has_nonnull_annot callee_pname loc - | _ - -> pre_1 + | _ -> + pre_1 in add_constraints_on_actuals_by_ref tenv pre_2 actuals_by_ref callee_pname loc in @@ -1583,6 +1635,7 @@ and unknown_or_scan_call ~is_scan ~reason ret_type_option ret_annots let skip_path = Paths.Path.add_skipped_call path callee_pname reason callee_loc_opt in [(prop_with_undef_attr, skip_path)] + and check_variadic_sentinel ?(fails_on_nil= false) n_formals (sentinel, null_pos) {Builtin.pdesc; tenv; prop_; path; args; proc_name; loc} = (* from clang's lib/Sema/SemaExpr.cpp: *) @@ -1617,20 +1670,22 @@ and check_variadic_sentinel ?(fails_on_nil= false) n_formals (sentinel, null_pos (* error on the first premature nil argument *) List.fold ~f:check_allocated ~init:[(prop_, path)] non_terminal_argsi + and check_variadic_sentinel_if_present ({Builtin.prop_; path; proc_name} as builtin_args) = match Specs.proc_resolve_attributes proc_name with - | None - -> [(prop_, path)] + | None -> + [(prop_, path)] | Some callee_attributes -> match PredSymb.get_sentinel_func_attribute_value callee_attributes.ProcAttributes.func_attributes with - | None - -> [(prop_, path)] - | Some sentinel_arg - -> let formals = callee_attributes.ProcAttributes.formals in + | None -> + [(prop_, path)] + | Some sentinel_arg -> + let formals = callee_attributes.ProcAttributes.formals in check_variadic_sentinel (List.length formals) sentinel_arg builtin_args + and sym_exec_objc_getter field ret_typ tenv ret_id pdesc pname loc args prop = let field_name, _, _ = field in L.d_strln @@ -1639,14 +1694,15 @@ and sym_exec_objc_getter field ret_typ tenv ret_id pdesc pname loc args prop = let ret_id = match ret_id with Some (ret_id, _) -> ret_id | None -> assert false in match args with | [ ( lexp - , ( {Typ.desc= Tstruct struct_name} as typ - | {desc= Tptr (({desc= Tstruct struct_name} as typ), _)} ) ) ] - -> Tenv.add_field tenv struct_name field ; + , ( ({Typ.desc= Tstruct struct_name} as typ) + | {desc= Tptr (({desc= Tstruct struct_name} as typ), _)} ) ) ] -> + Tenv.add_field tenv struct_name field ; let field_access_exp = Exp.Lfield (lexp, field_name, typ) in execute_load ~report_deref_errors:false pname pdesc tenv ret_id field_access_exp ret_typ loc prop - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + and sym_exec_objc_setter field _ tenv _ pdesc pname loc args prop = let field_name, _, _ = field in @@ -1655,30 +1711,32 @@ and sym_exec_objc_setter field _ tenv _ pdesc pname loc args prop = ^ Typ.Fieldname.to_string field_name ^ "." ) ; match args with | ( lexp1 - , ( {Typ.desc= Tstruct struct_name} as typ1 + , ( ({Typ.desc= Tstruct struct_name} as typ1) | {Typ.desc= Tptr (({Typ.desc= Tstruct struct_name} as typ1), _)} ) ) - :: (lexp2, typ2) :: _ - -> Tenv.add_field tenv struct_name field ; + :: (lexp2, typ2) :: _ -> + Tenv.add_field tenv struct_name field ; let field_access_exp = Exp.Lfield (lexp1, field_name, typ1) in execute_store ~report_deref_errors:false pname pdesc tenv field_access_exp typ2 lexp2 loc prop - | _ - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ -> + raise (Exceptions.Wrong_argument_number __POS__) + and sym_exec_objc_accessor property_accesor ret_typ tenv ret_id pdesc _ loc args prop path : Builtin.ret_typ = let f_accessor = match property_accesor with - | ProcAttributes.Objc_getter field - -> sym_exec_objc_getter field - | ProcAttributes.Objc_setter field - -> sym_exec_objc_setter field + | ProcAttributes.Objc_getter field -> + sym_exec_objc_getter field + | ProcAttributes.Objc_setter field -> + sym_exec_objc_setter field in (* we want to execute in the context of the current procedure, not in the context of callee_pname, since this is the procname of the setter/getter method *) let cur_pname = Procdesc.get_proc_name pdesc in f_accessor ret_typ tenv ret_id pdesc cur_pname loc args prop |> List.map ~f:(fun p -> (p, path)) + (** Perform symbolic execution for a function call *) and proc_call callee_summary {Builtin.pdesc; tenv; prop_= pre; path; ret_id; args= actual_pars; loc} = @@ -1688,12 +1746,12 @@ and proc_call callee_summary let formal_types = List.map ~f:snd (Specs.get_formals callee_summary) in let rec comb actual_pars formal_types = match (actual_pars, formal_types) with - | [], [] - -> actual_pars - | (e, t_e) :: etl', _ :: tl' - -> (e, t_e) :: comb etl' tl' - | _, [] - -> Errdesc.warning_err (State.get_loc ()) + | [], [] -> + actual_pars + | (e, t_e) :: etl', _ :: tl' -> + (e, t_e) :: comb etl' tl' + | _, [] -> + Errdesc.warning_err (State.get_loc ()) "likely use of variable-arguments function, or function prototype missing@." ; L.d_warning "likely use of variable-arguments function, or function prototype missing" ; L.d_ln () ; @@ -1704,8 +1762,8 @@ and proc_call callee_summary Typ.d_list formal_types ; L.d_ln () ; actual_pars - | [], _ - -> L.d_str ("**** ERROR: Procedure " ^ Typ.Procname.to_string callee_pname) ; + | [], _ -> + L.d_str ("**** ERROR: Procedure " ^ Typ.Procname.to_string callee_pname) ; L.d_strln " mismatch in the number of parameters ****" ; L.d_str "actual parameters: " ; Sil.d_exp_list (List.map ~f:fst actual_pars) ; @@ -1727,12 +1785,14 @@ and proc_call callee_summary && (Specs.get_attributes callee_summary).ProcAttributes.is_objc_instance_method then handle_objc_instance_method_call actual_pars actual_params pre tenv ret_id pdesc callee_pname - loc path (Tabulation.exe_function_call callee_summary) + loc path + (Tabulation.exe_function_call callee_summary) else (* non-objective-c method call. Standard tabulation *) Tabulation.exe_function_call callee_summary tenv ret_id pdesc callee_pname loc actual_params pre path + (** perform symbolic execution for a single prop, and check for junk *) and sym_exec_wrapper handle_exn tenv proc_cfg instr ((prop: Prop.normal Prop.t), path) : Paths.PathSet.t = @@ -1780,12 +1840,12 @@ and sym_exec_wrapper handle_exn tenv proc_cfg instr ((prop: Prop.normal Prop.t), in let curr_node = State.get_node () in match ProcCfg.Exceptional.kind curr_node with - | Procdesc.Node.Prune_node _ when not (node_has_abstraction curr_node) - -> (* don't check for leaks in prune nodes, unless there is abstraction anyway,*) + | Procdesc.Node.Prune_node _ when not (node_has_abstraction curr_node) -> + (* don't check for leaks in prune nodes, unless there is abstraction anyway,*) (* but force them into either branch *) p' - | _ - -> check_deallocate_static_memory (Abs.abstract_junk ~original_prop:p pname tenv p') + | _ -> + check_deallocate_static_memory (Abs.abstract_junk ~original_prop:p pname tenv p') in L.d_str "Instruction " ; Sil.d_instr instr ; @@ -1816,6 +1876,7 @@ and sym_exec_wrapper handle_exn tenv proc_cfg instr ((prop: Prop.normal Prop.t), (* calls State.mark_instr_fail *) Paths.PathSet.empty + (** {2 Lifted Abstract Transfer Functions} *) let node handle_exn tenv proc_cfg (node: ProcCfg.Exceptional.node) (pset: Paths.PathSet.t) @@ -1840,3 +1901,4 @@ let node handle_exn tenv proc_cfg (node: ProcCfg.Exceptional.node) (pset: Paths. Paths.PathSet.fold (exe_instr_prop instr) pset Paths.PathSet.empty in List.fold ~f:exe_instr_pset ~init:pset (ProcCfg.Exceptional.instrs node) + diff --git a/infer/src/backend/tabulation.ml b/infer/src/backend/tabulation.ml index fbfe1f30e..414833eb2 100644 --- a/infer/src/backend/tabulation.ml +++ b/infer/src/backend/tabulation.ml @@ -64,6 +64,7 @@ let print_results tenv actual_pre results = Propset.d actual_pre (Propset.from_proplist tenv results) ; L.d_strln "***** END RESULTS FUNCTION CALL *******" + (***************) (** Rename the variables in the spec. *) @@ -73,10 +74,10 @@ let spec_rename_vars pname spec = Prop.prop_expmap f p in let jprop_add_callee_suffix = function - | Specs.Jprop.Prop (n, p) - -> Specs.Jprop.Prop (n, prop_add_callee_suffix p) - | Specs.Jprop.Joined (n, p, jp1, jp2) - -> Specs.Jprop.Joined (n, prop_add_callee_suffix p, jp1, jp2) + | Specs.Jprop.Prop (n, p) -> + Specs.Jprop.Prop (n, prop_add_callee_suffix p) + | Specs.Jprop.Joined (n, p, jp1, jp2) -> + Specs.Jprop.Joined (n, prop_add_callee_suffix p, jp1, jp2) in let fav = Sil.fav_new () in Specs.Jprop.fav_add fav spec.Specs.pre ; @@ -90,6 +91,7 @@ let spec_rename_vars pname spec = let posts'' = List.map ~f:(fun (p, path) -> (prop_add_callee_suffix p, path)) posts' in {Specs.pre= pre''; Specs.posts= posts''; Specs.visited= spec.Specs.visited} + (** Find and number the specs for [proc_name], after renaming their vars, and also return the parameters *) let spec_find_rename trace_call summary : (int * Prop.exposed Specs.spec) list * Pvar.t list = @@ -113,6 +115,7 @@ let spec_find_rename trace_call summary : (int * Prop.exposed Specs.spec) list * (Exceptions.Precondition_not_found (Localise.verbatim_desc (Typ.Procname.to_string proc_name), __POS__)) + (** Process a splitting coming straight from a call to the prover: change the instantiating substitution so that it returns primed vars, except for vars occurring in the missing part, where it returns @@ -121,7 +124,8 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_ frame_typ missing_typ = let hpred_has_only_footprint_vars hpred = let fav = Sil.fav_new () in - Sil.hpred_fav_add fav hpred ; Sil.fav_for_all fav Ident.is_footprint + Sil.hpred_fav_add fav hpred ; + Sil.fav_for_all fav Ident.is_footprint in let sub = Sil.sub_join sub1 sub2 in let sub1_inverse = @@ -153,13 +157,13 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_ let fav_missing_fld = Prop.sigma_fav (Prop.sigma_sub (`Exp sub) missing_fld) in let map_var_to_pre_var_or_fresh id = match Sil.exp_sub (`Exp sub1_inverse) (Exp.Var id) with - | Exp.Var id' - -> if Sil.fav_mem fav_actual_pre id' || Ident.is_path id' + | Exp.Var id' -> + if Sil.fav_mem fav_actual_pre id' || Ident.is_path id' (* a path id represents a position in the pre *) then Exp.Var id' else Exp.Var (Ident.create_fresh Ident.kprimed) - | _ - -> assert false + | _ -> + assert false in let sub_list = Sil.sub_to_list sub in let fav_sub_list = @@ -229,12 +233,15 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_ false ) else match hpred with - | Sil.Hpointsto (Exp.Var _, _, _) - -> true - | Sil.Hpointsto (Exp.Lvar pvar, _, _) - -> Pvar.is_global pvar - | _ - -> L.d_warning "Missing fields in complex pred: " ; Sil.d_hpred hpred ; L.d_ln () ; false + | Sil.Hpointsto (Exp.Var _, _, _) -> + true + | Sil.Hpointsto (Exp.Lvar pvar, _, _) -> + Pvar.is_global pvar + | _ -> + L.d_warning "Missing fields in complex pred: " ; + Sil.d_hpred hpred ; + L.d_ln () ; + false in List.filter ~f:filter sigma in @@ -248,37 +255,41 @@ let process_splitting actual_pre sub1 sub2 frame missing_pi missing_sigma frame_ ; frame_typ= norm_frame_typ ; missing_typ= norm_missing_typ } + (** Check whether an inst represents a dereference without null check, and return the line number and path position *) let find_dereference_without_null_check_in_inst = function - | Sil.Iupdate (Some true, _, n, pos) | Sil.Irearrange (Some true, _, n, pos) - -> Some (n, pos) - | _ - -> None + | Sil.Iupdate (Some true, _, n, pos) | Sil.Irearrange (Some true, _, n, pos) -> + Some (n, pos) + | _ -> + None + (** Check whether a sexp contains a dereference without null check, and return the line number and path position *) let rec find_dereference_without_null_check_in_sexp = function - | Sil.Eexp (_, inst) - -> find_dereference_without_null_check_in_inst inst - | Sil.Estruct (fsel, inst) - -> let res = find_dereference_without_null_check_in_inst inst in + | Sil.Eexp (_, inst) -> + find_dereference_without_null_check_in_inst inst + | Sil.Estruct (fsel, inst) -> + let res = find_dereference_without_null_check_in_inst inst in if is_none res then find_dereference_without_null_check_in_sexp_list (List.map ~f:snd fsel) else res - | Sil.Earray (_, esel, inst) - -> let res = find_dereference_without_null_check_in_inst inst in + | Sil.Earray (_, esel, inst) -> + let res = find_dereference_without_null_check_in_inst inst in if is_none res then find_dereference_without_null_check_in_sexp_list (List.map ~f:snd esel) else res + and find_dereference_without_null_check_in_sexp_list = function - | [] - -> None + | [] -> + None | se :: sel -> match find_dereference_without_null_check_in_sexp se with - | None - -> find_dereference_without_null_check_in_sexp_list sel - | Some x - -> Some x + | None -> + find_dereference_without_null_check_in_sexp_list sel + | Some x -> + Some x + (** Check dereferences implicit in the spec pre. In case of dereference error, return [Some(deref_error, description)], otherwise [None] *) @@ -302,20 +313,20 @@ let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre fo let deref_no_null_check_pos = if Exp.equal e_sub Exp.zero then match find_dereference_without_null_check_in_sexp sexp with - | Some (_, pos) - -> Some pos - | None - -> None + | Some (_, pos) -> + Some pos + | None -> + None else None in if deref_no_null_check_pos <> None then (* only report a dereference null error if we know there was a dereference without null check *) match deref_no_null_check_pos with - | Some pos - -> Some (Deref_null pos, desc true (Localise.deref_str_null (Some callee_pname))) - | None - -> assert false + | Some pos -> + Some (Deref_null pos, desc true (Localise.deref_str_null (Some callee_pname))) + | None -> + assert false else if (* Check if the dereferenced expr has the dangling uninitialized attribute. *) (* In that case it raise a dangling pointer dereference *) Attribute.has_dangling_uninit tenv spec_pre e @@ -324,20 +335,20 @@ let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre fo Some (Deref_minusone, desc true (Localise.deref_str_dangling None)) else match Attribute.get_resource tenv actual_pre e_sub with - | Some Apred (Aresource ({ra_kind= Rrelease} as ra), _) - -> Some (Deref_freed ra, desc true (Localise.deref_str_freed ra)) + | Some Apred (Aresource ({ra_kind= Rrelease} as ra), _) -> + Some (Deref_freed ra, desc true (Localise.deref_str_freed ra)) | _ -> match Attribute.get_undef tenv actual_pre e_sub with - | Some Apred (Aundef (s, _, loc, pos), _) - -> Some (Deref_undef (s, loc, pos), desc false (Localise.deref_str_undef (s, loc))) - | _ - -> None + | Some Apred (Aundef (s, _, loc, pos), _) -> + Some (Deref_undef (s, loc, pos), desc false (Localise.deref_str_undef (s, loc))) + | _ -> + None in let check_hpred = function - | Sil.Hpointsto (lexp, se, _) - -> check_dereference (Exp.root_of_lexp lexp) se - | _ - -> None + | Sil.Hpointsto (lexp, se, _) -> + check_dereference (Exp.root_of_lexp lexp) se + | _ -> + None in let deref_err_list = List.fold @@ -346,8 +357,8 @@ let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre fo ~init:[] spec_pre.Prop.sigma in match deref_err_list with - | [] - -> None + | [] -> + None | deref_err :: _ -> match (* Prefer to report Deref_null over other kinds of deref errors. this @@ -359,10 +370,11 @@ let check_dereferences caller_pname tenv callee_pname actual_pre sub spec_pre fo ~f:(fun err -> match err with Deref_null _, _ -> true | _ -> false) deref_err_list with - | Some x - -> Some x - | None - -> Some deref_err + | Some x -> + Some x + | None -> + Some deref_err + let post_process_sigma tenv (sigma: Sil.hpred list) loc : Sil.hpred list = let map_inst inst = Sil.inst_new_loc loc inst in @@ -370,12 +382,13 @@ let post_process_sigma tenv (sigma: Sil.hpred list) loc : Sil.hpred list = (* update the location of instrumentations *) List.map ~f:(fun hpred -> do_hpred (Prover.expand_hpred_pointer tenv false hpred)) sigma + (** check for interprocedural path errors in the post *) let check_path_errors_in_post tenv caller_pname post post_path = let check_attr atom = match atom with - | Sil.Apred (Adiv0 path_pos, [e]) - -> if Prover.check_zero tenv e then + | Sil.Apred (Adiv0 path_pos, [e]) -> + if Prover.check_zero tenv e then let desc = Errdesc.explain_divide_by_zero tenv e (State.get_node ()) (State.get_loc ()) in @@ -388,11 +401,12 @@ let check_path_errors_in_post tenv caller_pname post post_path = State.set_path new_path path_pos_opt ; let exn = Exceptions.Divide_by_zero (desc, __POS__) in Reporting.log_warning_deprecated caller_pname exn - | _ - -> () + | _ -> + () in List.iter ~f:check_attr (Attribute.get_all post) + (** Post process the instantiated post after the function call so that x.f |-> se becomes x |-> \{ f: se \}. Also, update any Aresource attributes to refer to the caller *) @@ -400,147 +414,156 @@ let post_process_post tenv caller_pname callee_pname loc actual_pre ((post: Prop.exposed Prop.t), post_path) = let actual_pre_has_freed_attribute e = match Attribute.get_resource tenv actual_pre e with - | Some Apred (Aresource {ra_kind= Rrelease}, _) - -> true - | _ - -> false + | Some Apred (Aresource {ra_kind= Rrelease}, _) -> + true + | _ -> + false in let atom_update_alloc_attribute = function | Sil.Apred (Aresource ra, [e]) when not ( PredSymb.equal_res_act_kind ra.ra_kind PredSymb.Rrelease - && actual_pre_has_freed_attribute e ) - -> (* unless it was already freed before the call *) + && actual_pre_has_freed_attribute e ) -> + (* unless it was already freed before the call *) let vpath, _ = Errdesc.vpath_find tenv post e in let ra' = {ra with ra_pname= callee_pname; ra_loc= loc; ra_vpath= vpath} in Sil.Apred (Aresource ra', [e]) - | a - -> a + | a -> + a in let prop' = Prop.set post ~sigma:(post_process_sigma tenv post.Prop.sigma loc) in let pi' = List.map ~f:atom_update_alloc_attribute prop'.Prop.pi in (* update alloc attributes to refer to the caller *) let post' = Prop.set prop' ~pi:pi' in - check_path_errors_in_post tenv caller_pname post' post_path ; (post', post_path) + check_path_errors_in_post tenv caller_pname post' post_path ; + (post', post_path) + let hpred_lhs_compare hpred1 hpred2 = match (hpred1, hpred2) with - | Sil.Hpointsto (e1, _, _), Sil.Hpointsto (e2, _, _) - -> Exp.compare e1 e2 - | Sil.Hpointsto _, _ - -> -1 - | _, Sil.Hpointsto _ - -> 1 - | hpred1, hpred2 - -> Sil.compare_hpred hpred1 hpred2 + | Sil.Hpointsto (e1, _, _), Sil.Hpointsto (e2, _, _) -> + Exp.compare e1 e2 + | Sil.Hpointsto _, _ -> + -1 + | _, Sil.Hpointsto _ -> + 1 + | hpred1, hpred2 -> + Sil.compare_hpred hpred1 hpred2 + (** set the inst everywhere in a sexp *) let rec sexp_set_inst inst = function - | Sil.Eexp (e, _) - -> Sil.Eexp (e, inst) - | Sil.Estruct (fsel, _) - -> Sil.Estruct (List.map ~f:(fun (f, se) -> (f, sexp_set_inst inst se)) fsel, inst) - | Sil.Earray (len, esel, _) - -> Sil.Earray (len, List.map ~f:(fun (e, se) -> (e, sexp_set_inst inst se)) esel, inst) + | Sil.Eexp (e, _) -> + Sil.Eexp (e, inst) + | Sil.Estruct (fsel, _) -> + Sil.Estruct (List.map ~f:(fun (f, se) -> (f, sexp_set_inst inst se)) fsel, inst) + | Sil.Earray (len, esel, _) -> + Sil.Earray (len, List.map ~f:(fun (e, se) -> (e, sexp_set_inst inst se)) esel, inst) + let rec fsel_star_fld fsel1 fsel2 = match (fsel1, fsel2) with - | [], fsel2 - -> fsel2 - | fsel1, [] - -> fsel1 + | [], fsel2 -> + fsel2 + | fsel1, [] -> + fsel1 | (f1, se1) :: fsel1', (f2, se2) :: fsel2' -> match Typ.Fieldname.compare f1 f2 with - | 0 - -> (f1, sexp_star_fld se1 se2) :: fsel_star_fld fsel1' fsel2' - | n when n < 0 - -> (f1, se1) :: fsel_star_fld fsel1' fsel2 - | _ - -> (f2, se2) :: fsel_star_fld fsel1 fsel2' + | 0 -> + (f1, sexp_star_fld se1 se2) :: fsel_star_fld fsel1' fsel2' + | n when n < 0 -> + (f1, se1) :: fsel_star_fld fsel1' fsel2 + | _ -> + (f2, se2) :: fsel_star_fld fsel1 fsel2' + and array_content_star se1 se2 = try sexp_star_fld se1 se2 with exn when SymOp.exn_not_failure exn -> se1 + (* let postcondition override *) and esel_star_fld esel1 esel2 = match (esel1, esel2) with - | [], esel2 - -> (* don't know whether element is read or written in fun call with array *) + | [], esel2 -> + (* don't know whether element is read or written in fun call with array *) List.map ~f:(fun (e, se) -> (e, sexp_set_inst Sil.Inone se)) esel2 - | esel1, [] - -> esel1 + | esel1, [] -> + esel1 | (e1, se1) :: esel1', (e2, se2) :: esel2' -> match Exp.compare e1 e2 with - | 0 - -> (e1, array_content_star se1 se2) :: esel_star_fld esel1' esel2' - | n when n < 0 - -> (e1, se1) :: esel_star_fld esel1' esel2 - | _ - -> let se2' = sexp_set_inst Sil.Inone se2 in + | 0 -> + (e1, array_content_star se1 se2) :: esel_star_fld esel1' esel2' + | n when n < 0 -> + (e1, se1) :: esel_star_fld esel1' esel2 + | _ -> + let se2' = sexp_set_inst Sil.Inone se2 in (* don't know whether element is read or written in fun call with array *) - (e2, se2') - :: esel_star_fld esel1 esel2' + (e2, se2') :: esel_star_fld esel1 esel2' + and sexp_star_fld se1 se2 : Sil.strexp = (* L.d_str "sexp_star_fld "; Sil.d_sexp se1; L.d_str " "; Sil.d_sexp se2; L.d_ln (); *) match (se1, se2) with - | Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, inst2) - -> Sil.Estruct (fsel_star_fld fsel1 fsel2, inst2) - | Sil.Earray (len1, esel1, _), Sil.Earray (_, esel2, inst2) - -> Sil.Earray (len1, esel_star_fld esel1 esel2, inst2) - | Sil.Eexp (_, inst1), Sil.Earray (len2, esel2, _) - -> let esel1 = [(Exp.zero, se1)] in + | Sil.Estruct (fsel1, _), Sil.Estruct (fsel2, inst2) -> + Sil.Estruct (fsel_star_fld fsel1 fsel2, inst2) + | Sil.Earray (len1, esel1, _), Sil.Earray (_, esel2, inst2) -> + Sil.Earray (len1, esel_star_fld esel1 esel2, inst2) + | Sil.Eexp (_, inst1), Sil.Earray (len2, esel2, _) -> + let esel1 = [(Exp.zero, se1)] in Sil.Earray (len2, esel_star_fld esel1 esel2, inst1) - | _ - -> L.d_str "cannot star " ; + | _ -> + L.d_str "cannot star " ; Sil.d_sexp se1 ; L.d_str " and " ; Sil.d_sexp se2 ; L.d_ln () ; assert false + let texp_star tenv texp1 texp2 = let rec ftal_sub ftal1 ftal2 = match (ftal1, ftal2) with - | [], _ - -> true - | _, [] - -> false + | [], _ -> + true + | _, [] -> + false | (f1, _, _) :: ftal1', (f2, _, _) :: ftal2' -> match Typ.Fieldname.compare f1 f2 with - | n when n < 0 - -> false - | 0 - -> ftal_sub ftal1' ftal2' - | _ - -> ftal_sub ftal1 ftal2' + | n when n < 0 -> + false + | 0 -> + ftal_sub ftal1' ftal2' + | _ -> + ftal_sub ftal1 ftal2' in let typ_star (t1: Typ.t) (t2: Typ.t) = match (t1.desc, t2.desc) with | Tstruct name1, Tstruct name2 when Typ.Name.is_same_type name1 name2 -> ( match (Tenv.lookup tenv name1, Tenv.lookup tenv name2) with - | Some {fields= fields1}, Some {fields= fields2} when ftal_sub fields1 fields2 - -> t2 - | _ - -> t1 ) - | _ - -> t1 + | Some {fields= fields1}, Some {fields= fields2} when ftal_sub fields1 fields2 -> + t2 + | _ -> + t1 ) + | _ -> + t1 in match (texp1, texp2) with - | Exp.Sizeof ({typ= t1; subtype= st1} as sizeof1), Exp.Sizeof {typ= t2; subtype= st2} - -> Exp.Sizeof {sizeof1 with typ= typ_star t1 t2; subtype= Subtype.join st1 st2} - | _ - -> texp1 + | Exp.Sizeof ({typ= t1; subtype= st1} as sizeof1), Exp.Sizeof {typ= t2; subtype= st2} -> + Exp.Sizeof {sizeof1 with typ= typ_star t1 t2; subtype= Subtype.join st1 st2} + | _ -> + texp1 + let hpred_star_fld tenv (hpred1: Sil.hpred) (hpred2: Sil.hpred) : Sil.hpred = match (hpred1, hpred2) with - | Sil.Hpointsto (e1, se1, t1), Sil.Hpointsto (_, se2, t2) - -> (* L.d_str "hpred_star_fld t1: "; Sil.d_texp_full t1; L.d_str " t2: "; Sil.d_texp_full t2; + | Sil.Hpointsto (e1, se1, t1), Sil.Hpointsto (_, se2, t2) -> + (* L.d_str "hpred_star_fld t1: "; Sil.d_texp_full t1; L.d_str " t2: "; Sil.d_texp_full t2; L.d_str " se1: "; Sil.d_sexp se1; L.d_str " se2: "; Sil.d_sexp se2; L.d_ln (); *) Sil.Hpointsto (e1, sexp_star_fld se1 se2, texp_star tenv t1 t2) - | _ - -> assert false + | _ -> + assert false + (** Implementation of [*] for the field-splitting model *) let sigma_star_fld tenv (sigma1: Sil.hpred list) (sigma2: Sil.hpred list) : Sil.hpred list = @@ -549,18 +572,18 @@ let sigma_star_fld tenv (sigma1: Sil.hpred list) (sigma2: Sil.hpred list) : Sil. (* L.out "@.@. computing %a@.STAR @.%a@.@." pp_sigma sigma1 pp_sigma sigma2; *) let rec star sg1 sg2 : Sil.hpred list = match (sg1, sg2) with - | [], _ - -> [] - | sigma1, [] - -> sigma1 + | [], _ -> + [] + | sigma1, [] -> + sigma1 | hpred1 :: sigma1', hpred2 :: sigma2' -> match hpred_lhs_compare hpred1 hpred2 with - | 0 - -> hpred_star_fld tenv hpred1 hpred2 :: star sigma1' sigma2' - | n when n < 0 - -> hpred1 :: star sigma1' sg2 - | _ - -> star sg1 sigma2' + | 0 -> + hpred_star_fld tenv hpred1 hpred2 :: star sigma1' sigma2' + | n when n < 0 -> + hpred1 :: star sigma1' sg2 + | _ -> + star sg1 sigma2' in try star sigma1 sigma2 with exn when SymOp.exn_not_failure exn -> @@ -571,15 +594,18 @@ let sigma_star_fld tenv (sigma1: Sil.hpred list) (sigma2: Sil.hpred list) : Sil. L.d_ln () ; raise (Exceptions.Cannot_star __POS__) + let hpred_typing_lhs_compare hpred1 (e2, _) = match hpred1 with Sil.Hpointsto (e1, _, _) -> Exp.compare e1 e2 | _ -> -1 + let hpred_star_typing (hpred1: Sil.hpred) (_, te2) : Sil.hpred = match hpred1 with - | Sil.Hpointsto (e1, se1, _) - -> Sil.Hpointsto (e1, se1, te2) - | _ - -> assert false + | Sil.Hpointsto (e1, se1, _) -> + Sil.Hpointsto (e1, se1, te2) + | _ -> + assert false + (** Implementation of [*] between predicates and typings *) let sigma_star_typ (sigma1: Sil.hpred list) (typings2: (Exp.t * Exp.t) list) : Sil.hpred list = @@ -588,18 +614,18 @@ let sigma_star_typ (sigma1: Sil.hpred list) (typings2: (Exp.t * Exp.t) list) : S let typings2 = List.stable_sort ~cmp:typing_lhs_compare typings2 in let rec star sg1 typ2 : Sil.hpred list = match (sg1, typ2) with - | [], _ - -> [] - | sigma1, [] - -> sigma1 + | [], _ -> + [] + | sigma1, [] -> + sigma1 | hpred1 :: sigma1', typing2 :: typings2' -> match hpred_typing_lhs_compare hpred1 typing2 with - | 0 - -> hpred_star_typing hpred1 typing2 :: star sigma1' typings2' - | n when n < 0 - -> hpred1 :: star sigma1' typ2 - | _ - -> star sg1 typings2' + | 0 -> + hpred_star_typing hpred1 typing2 :: star sigma1' typings2' + | n when n < 0 -> + hpred1 :: star sigma1' typ2 + | _ -> + star sg1 typings2' in try star sigma1 typings2 with exn when SymOp.exn_not_failure exn -> @@ -610,6 +636,7 @@ let sigma_star_typ (sigma1: Sil.hpred list) (typings2: (Exp.t * Exp.t) list) : S L.d_ln () ; raise (Exceptions.Cannot_star __POS__) + (** [prop_footprint_add_pi_sigma_starfld_sigma prop pi sigma missing_fld] extends the footprint of [prop] with [pi,sigma] and extends the fields of |-> with [missing_fld] *) @@ -617,18 +644,18 @@ let prop_footprint_add_pi_sigma_starfld_sigma tenv (prop: 'a Prop.t) pi_new sigm missing_typ : Prop.normal Prop.t option = let rec extend_sigma current_sigma new_sigma = match new_sigma with - | [] - -> Some current_sigma - | hpred :: new_sigma' - -> (* TODO (t4893479): make this check less angelic *) + | [] -> + Some current_sigma + | hpred :: new_sigma' -> + (* TODO (t4893479): make this check less angelic *) extend_sigma (hpred :: current_sigma) new_sigma' in let rec extend_pi current_pi new_pi = match new_pi with - | [] - -> current_pi - | a :: new_pi' - -> let fav = Prop.pi_fav [a] in + | [] -> + current_pi + | a :: new_pi' -> + let fav = Prop.pi_fav [a] in if Sil.fav_exists fav (fun id -> not (Ident.is_footprint id)) then ( L.d_warning "dropping atom with non-footprint variable" ; L.d_ln () ; @@ -639,25 +666,27 @@ let prop_footprint_add_pi_sigma_starfld_sigma tenv (prop: 'a Prop.t) pi_new sigm in let pi_fp' = extend_pi prop.Prop.pi_fp pi_new in match extend_sigma prop.Prop.sigma_fp sigma_new with - | None - -> None - | Some sigma' - -> let sigma_fp' = sigma_star_fld tenv sigma' missing_fld in + | None -> + None + | Some sigma' -> + let sigma_fp' = sigma_star_fld tenv sigma' missing_fld in let sigma_fp'' = sigma_star_typ sigma_fp' missing_typ in let pi' = pi_new @ prop.Prop.pi in Some (Prop.normalize tenv (Prop.set prop ~pi:pi' ~pi_fp:pi_fp' ~sigma_fp:sigma_fp'')) + (** Check if the attribute change is a mismatch between a kind of allocation and a different kind of deallocation *) let check_attr_dealloc_mismatch att_old att_new = match (att_old, att_new) with | ( PredSymb.Aresource ({ra_kind= Racquire; ra_res= Rmemory mk_old} as ra_old) , PredSymb.Aresource ({ra_kind= Rrelease; ra_res= Rmemory mk_new} as ra_new) ) - when PredSymb.compare_mem_kind mk_old mk_new <> 0 - -> let desc = Errdesc.explain_allocation_mismatch ra_old ra_new in + when PredSymb.compare_mem_kind mk_old mk_new <> 0 -> + let desc = Errdesc.explain_allocation_mismatch ra_old ra_new in raise (Exceptions.Deallocation_mismatch (desc, __POS__)) - | _ - -> () + | _ -> + () + (** [prop_copy_footprint p1 p2] copies the footprint and pure part of [p1] into [p2] *) let prop_copy_footprint_pure tenv p1 p2 = @@ -674,6 +703,7 @@ let prop_copy_footprint_pure tenv p1 p2 = in List.fold ~f:replace_attr ~init:(Prop.normalize tenv res_noattr) pi2_attr + (** check if an expression is an exception *) let exp_is_exn = function Exp.Exn _ -> true | _ -> false @@ -681,68 +711,73 @@ let exp_is_exn = function Exp.Exn _ -> true | _ -> false let prop_is_exn pname prop = let ret_pvar = Exp.Lvar (Pvar.get_ret_pvar pname) in let is_exn = function - | Sil.Hpointsto (e1, Sil.Eexp (e2, _), _) when Exp.equal e1 ret_pvar - -> exp_is_exn e2 - | _ - -> false + | Sil.Hpointsto (e1, Sil.Eexp (e2, _), _) when Exp.equal e1 ret_pvar -> + exp_is_exn e2 + | _ -> + false in List.exists ~f:is_exn prop.Prop.sigma + (** when prop is an exception, return the exception name *) let prop_get_exn_name pname prop = let ret_pvar = Exp.Lvar (Pvar.get_ret_pvar pname) in let rec search_exn e = function - | [] - -> None - | (Sil.Hpointsto (e1, _, Sizeof {typ= {desc= Tstruct name}})) :: _ when Exp.equal e1 e - -> Some name - | _ :: tl - -> search_exn e tl + | [] -> + None + | (Sil.Hpointsto (e1, _, Sizeof {typ= {desc= Tstruct name}})) :: _ when Exp.equal e1 e -> + Some name + | _ :: tl -> + search_exn e tl in let rec find_exn_name hpreds = function - | [] - -> None - | (Sil.Hpointsto (e1, Sil.Eexp (Exp.Exn e2, _), _)) :: _ when Exp.equal e1 ret_pvar - -> search_exn e2 hpreds - | _ :: tl - -> find_exn_name hpreds tl + | [] -> + None + | (Sil.Hpointsto (e1, Sil.Eexp (Exp.Exn e2, _), _)) :: _ when Exp.equal e1 ret_pvar -> + search_exn e2 hpreds + | _ :: tl -> + find_exn_name hpreds tl in let hpreds = prop.Prop.sigma in find_exn_name hpreds hpreds + (** search in prop for some assignment of global errors *) let lookup_custom_errors prop = let rec search_error = function - | [] - -> None + | [] -> + None | (Sil.Hpointsto (Exp.Lvar var, Sil.Eexp (Exp.Const Const.Cstr error_str, _), _)) :: _ - when Pvar.equal var Sil.custom_error - -> Some error_str - | _ :: tl - -> search_error tl + when Pvar.equal var Sil.custom_error -> + Some error_str + | _ :: tl -> + search_error tl in search_error prop.Prop.sigma + (** set a prop to an exception sexp *) let prop_set_exn tenv pname prop se_exn = let ret_pvar = Exp.Lvar (Pvar.get_ret_pvar pname) in let map_hpred = function - | Sil.Hpointsto (e, _, t) when Exp.equal e ret_pvar - -> Sil.Hpointsto (e, se_exn, t) - | hpred - -> hpred + | Sil.Hpointsto (e, _, t) when Exp.equal e ret_pvar -> + Sil.Hpointsto (e, se_exn, t) + | hpred -> + hpred in let sigma' = List.map ~f:map_hpred prop.Prop.sigma in Prop.normalize tenv (Prop.set prop ~sigma:sigma') + (** Include a subtrace for a procedure call if the callee is not a model. *) let include_subtrace callee_pname = match Specs.proc_resolve_attributes callee_pname with - | Some attrs - -> not attrs.ProcAttributes.is_model + | Some attrs -> + not attrs.ProcAttributes.is_model && SourceFile.is_under_project_root attrs.ProcAttributes.loc.Location.file - | None - -> false + | None -> + false + (** combine the spec's post with a splitting and actual precondition *) let combine tenv ret_id (posts: ('a Prop.t * Paths.Path.t) list) actual_pre path_pre split @@ -779,7 +814,9 @@ let combine tenv ret_id (posts: ('a Prop.t * Paths.Path.t) list) actual_pre path Prop.d_sigma split.missing_fld ; L.d_ln () ; if split.missing_typ <> [] then ( - L.d_strln "Missing typ:" ; Prover.d_typings split.missing_typ ; L.d_ln () ) ; + L.d_strln "Missing typ:" ; + Prover.d_typings split.missing_typ ; + L.d_ln () ) ; L.d_strln "Instantiated frame:" ; Prop.d_sigma split.frame ; L.d_ln () ; @@ -799,20 +836,20 @@ let combine tenv ret_id (posts: ('a Prop.t * Paths.Path.t) list) actual_pre path let handle_null_case_analysis sigma = let id_assigned_to_null id = let filter = function - | Sil.Aeq (Exp.Var id', Exp.Const Const.Cint i) - -> Ident.equal id id' && IntLit.isnull i - | _ - -> false + | Sil.Aeq (Exp.Var id', Exp.Const Const.Cint i) -> + Ident.equal id id' && IntLit.isnull i + | _ -> + false in List.exists ~f:filter split.missing_pi in let f (e, inst_opt) = match (e, inst_opt) with - | Exp.Var id, Some inst when id_assigned_to_null id - -> let inst' = Sil.inst_set_null_case_flag inst in + | Exp.Var id, Some inst when id_assigned_to_null id -> + let inst' = Sil.inst_set_null_case_flag inst in (e, Some inst') - | _ - -> (e, inst_opt) + | _ -> + (e, inst_opt) in Sil.hpred_list_expmap f sigma in @@ -828,46 +865,46 @@ let combine tenv ret_id (posts: ('a Prop.t * Paths.Path.t) list) actual_pre path Exp.Lvar (Pvar.to_callee callee_pname (Pvar.get_ret_pvar callee_pname)) in match Prop.prop_iter_create post_p2 with - | None - -> post_p2 - | Some iter - -> let filter = function - | Sil.Hpointsto (e, _, _) when Exp.equal e callee_ret_pvar - -> Some () - | _ - -> None + | None -> + post_p2 + | Some iter -> + let filter = function + | Sil.Hpointsto (e, _, _) when Exp.equal e callee_ret_pvar -> + Some () + | _ -> + None in match Prop.prop_iter_find iter filter with - | None - -> post_p2 + | None -> + post_p2 | Some iter' -> match (fst (Prop.prop_iter_current tenv iter'), ret_id) with - | Sil.Hpointsto (_, Sil.Eexp (e', inst), _), _ when exp_is_exn e' - -> (* resuls is an exception: set in caller *) + | Sil.Hpointsto (_, Sil.Eexp (e', inst), _), _ when exp_is_exn e' -> + (* resuls is an exception: set in caller *) let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in prop_set_exn tenv caller_pname p (Sil.Eexp (e', inst)) - | Sil.Hpointsto (_, Sil.Eexp (e', _), _), Some (id, _) - -> let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in + | Sil.Hpointsto (_, Sil.Eexp (e', _), _), Some (id, _) -> + let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in Prop.conjoin_eq tenv e' (Exp.Var id) p | Sil.Hpointsto (_, Sil.Estruct (ftl, _), _), _ - when Int.equal (List.length ftl) (if is_none ret_id then 0 else 1) - -> (* TODO(jjb): Is this case dead? *) + when Int.equal (List.length ftl) (if is_none ret_id then 0 else 1) -> + (* TODO(jjb): Is this case dead? *) let rec do_ftl_ids p = function - | [], None - -> p - | (_, Sil.Eexp (e', _)) :: ftl', Some (ret_id, _) - -> let p' = Prop.conjoin_eq tenv e' (Exp.Var ret_id) p in + | [], None -> + p + | (_, Sil.Eexp (e', _)) :: ftl', Some (ret_id, _) -> + let p' = Prop.conjoin_eq tenv e' (Exp.Var ret_id) p in do_ftl_ids p' (ftl', None) - | _ - -> p + | _ -> + p in let p = Prop.prop_iter_remove_curr_then_to_prop tenv iter' in do_ftl_ids p (ftl, ret_id) - | Sil.Hpointsto _, _ - -> (* returning nothing or unexpected sexp, turning into nondet *) + | Sil.Hpointsto _, _ -> + (* returning nothing or unexpected sexp, turning into nondet *) Prop.prop_iter_remove_curr_then_to_prop tenv iter' - | _ - -> assert false + | _ -> + assert false in let post_p4 = if !Config.footprint then @@ -887,6 +924,7 @@ let combine tenv ret_id (posts: ('a Prop.t * Paths.Path.t) list) actual_pre path print_results tenv actual_pre (List.map ~f:fst results) ; Some results + (** Construct the actual precondition: add to the current state a copy of the (callee's) formal parameters instantiated with the actual parameters. *) @@ -894,10 +932,10 @@ let mk_actual_precondition tenv prop actual_params formal_params = let formals_actuals = let rec comb fpars apars = match (fpars, apars) with - | f :: fpars', a :: apars' - -> (f, a) :: comb fpars' apars' - | [], _ - -> ( if apars <> [] then + | f :: fpars', a :: apars' -> + (f, a) :: comb fpars' apars' + | [], _ -> + ( if apars <> [] then let str = "more actual pars than formal pars in fun call (" ^ string_of_int (List.length actual_params) ^ " vs " @@ -905,8 +943,8 @@ let mk_actual_precondition tenv prop actual_params formal_params = in L.d_warning str ; L.d_ln () ) ; [] - | _ :: _, [] - -> raise (Exceptions.Wrong_argument_number __POS__) + | _ :: _, [] -> + raise (Exceptions.Wrong_argument_number __POS__) in comb formal_params actual_params in @@ -918,6 +956,7 @@ let mk_actual_precondition tenv prop actual_params formal_params = let actual_pre = Prop.prop_sigma_star prop instantiated_formals in Prop.normalize tenv actual_pre + let mk_posts tenv ret_id_opt prop callee_pname posts = if is_none ret_id_opt then posts else @@ -929,20 +968,20 @@ let mk_posts tenv ret_id_opt prop callee_pname posts = let last_call_ret_non_null = List.exists ~f:(function - | Sil.Apred (Aretval (pname, _), [exp]) when Typ.Procname.equal callee_pname pname - -> Prover.check_disequal tenv prop exp Exp.zero - | _ - -> false) + | Sil.Apred (Aretval (pname, _), [exp]) when Typ.Procname.equal callee_pname pname -> + Prover.check_disequal tenv prop exp Exp.zero + | _ -> + false) (Attribute.get_all prop) in if last_call_ret_non_null then let returns_null prop = List.exists ~f:(function - | Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp (e, _), _) when Pvar.is_return pvar - -> Prover.check_equal tenv (Prop.normalize tenv prop) e Exp.zero - | _ - -> false) + | Sil.Hpointsto (Exp.Lvar pvar, Sil.Eexp (e, _), _) when Pvar.is_return pvar -> + Prover.check_equal tenv (Prop.normalize tenv prop) e Exp.zero + | _ -> + false) prop.Prop.sigma in List.filter ~f:(fun (prop, _) -> not (returns_null prop)) posts @@ -952,15 +991,17 @@ let mk_posts tenv ret_id_opt prop callee_pname posts = mk_getter_idempotent posts else posts + (** Check if actual_pre * missing_footprint |- false *) let inconsistent_actualpre_missing tenv actual_pre split_opt = match split_opt with - | Some split - -> let prop' = Prop.normalize tenv (Prop.prop_sigma_star actual_pre split.missing_sigma) in + | Some split -> + let prop' = Prop.normalize tenv (Prop.prop_sigma_star actual_pre split.missing_sigma) in let prop'' = List.fold ~f:(Prop.prop_atom_and tenv) ~init:prop' split.missing_pi in Prover.check_inconsistency tenv prop'' - | None - -> false + | None -> + false + let class_cast_exn tenv pname_opt texp1 texp2 exp ml_loc = let desc = @@ -969,28 +1010,32 @@ let class_cast_exn tenv pname_opt texp1 texp2 exp ml_loc = in Exceptions.Class_cast_exception (desc, ml_loc) + let create_cast_exception tenv ml_loc pname_opt texp1 texp2 exp = class_cast_exn tenv pname_opt texp1 texp2 exp ml_loc + let get_check_exn tenv check callee_pname loc ml_loc = match check with - | Prover.Bounds_check - -> let desc = Localise.desc_precondition_not_met (Some Localise.Pnm_bounds) callee_pname loc in + | Prover.Bounds_check -> + let desc = Localise.desc_precondition_not_met (Some Localise.Pnm_bounds) callee_pname loc in Exceptions.Precondition_not_met (desc, ml_loc) - | Prover.Class_cast_check (texp1, texp2, exp) - -> class_cast_exn tenv (Some callee_pname) texp1 texp2 exp ml_loc + | Prover.Class_cast_check (texp1, texp2, exp) -> + class_cast_exn tenv (Some callee_pname) texp1 texp2 exp ml_loc + let check_uninitialize_dangling_deref caller_pname tenv callee_pname actual_pre sub formal_params props = List.iter ~f:(fun (p, _) -> match check_dereferences caller_pname tenv callee_pname actual_pre sub p formal_params with - | Some (Deref_undef_exp, desc) - -> raise (Exceptions.Dangling_pointer_dereference (Some PredSymb.DAuninit, desc, __POS__)) - | _ - -> ()) + | Some (Deref_undef_exp, desc) -> + raise (Exceptions.Dangling_pointer_dereference (Some PredSymb.DAuninit, desc, __POS__)) + | _ -> + ()) props + (** Perform symbolic execution for a single spec *) let exe_spec tenv ret_id_opt (n, nspecs) caller_pdesc callee_pname loc prop path_pre (spec: Prop.exposed Specs.spec) actual_params formal_params : abduction_res = @@ -1012,8 +1057,8 @@ let exe_spec tenv ret_id_opt (n, nspecs) caller_pdesc callee_pname loc prop path SymOp.pay () ; (* pay one symop *) match Prover.check_implication_for_footprint caller_pname tenv actual_pre spec_pre with - | Prover.ImplFail checks - -> Invalid_res (Prover_checks checks) + | Prover.ImplFail checks -> + Invalid_res (Prover_checks checks) | Prover.ImplOK ( checks , sub1 @@ -1024,8 +1069,8 @@ let exe_spec tenv ret_id_opt (n, nspecs) caller_pdesc callee_pname loc prop path , frame_fld , missing_fld , frame_typ - , missing_typ ) - -> let log_check_exn check = + , missing_typ ) -> + let log_check_exn check = let exn = get_check_exn tenv check callee_pname loc __POS__ in Reporting.log_warning_deprecated caller_pname exn in @@ -1037,10 +1082,10 @@ let exe_spec tenv ret_id_opt (n, nspecs) caller_pdesc callee_pname loc prop path match combine tenv ret_id_opt posts actual_pre path_pre split caller_pdesc callee_pname loc with - | None - -> Invalid_res Cannot_combine - | Some results - -> (* After combining we check that we have not added + | None -> + Invalid_res Cannot_combine + | Some results -> + (* After combining we check that we have not added a points-to of initialized variables.*) check_uninitialize_dangling_deref caller_pname tenv callee_pname actual_pre split.sub formal_params results ; @@ -1061,27 +1106,27 @@ let exe_spec tenv ret_id_opt (n, nspecs) caller_pdesc callee_pname loc prop path check_dereferences caller_pname tenv callee_pname subbed_pre (`Exp sub2) spec_pre formal_params with - | Some (Deref_undef _, _) - -> let split = do_split () in + | Some (Deref_undef _, _) -> + let split = do_split () in report_valid_res split - | Some (deref_error, desc) - -> let rec join_paths = function - | [] - -> None + | Some (deref_error, desc) -> + let rec join_paths = function + | [] -> + None | (_, p) :: l -> match join_paths l with None -> Some p | Some p' -> Some (Paths.Path.join p p') in let pjoin = join_paths posts in (* join the paths from the posts *) Invalid_res (Dereference_error (deref_error, desc, pjoin)) - | None - -> let split = do_split () in + | None -> + let split = do_split () in (* check if a missing_fld hpred is from a dyn language (ObjC) *) let hpred_missing_objc_class = function - | Sil.Hpointsto (_, Sil.Estruct (_, _), Exp.Sizeof {typ}) - -> Typ.is_objc_class typ - | _ - -> false + | Sil.Hpointsto (_, Sil.Estruct (_, _), Exp.Sizeof {typ}) -> + Typ.is_objc_class typ + | _ -> + false in (* missing fields minus hidden fields *) let missing_fld_not_objc_class = @@ -1095,18 +1140,20 @@ let exe_spec tenv ret_id_opt (n, nspecs) caller_pdesc callee_pname loc prop path Invalid_res Missing_fld_not_empty ) else report_valid_res split + let remove_constant_string_class tenv prop = let filter = function - | Sil.Hpointsto (Exp.Const (Const.Cstr _ | Const.Cclass _), _, _) - -> false - | _ - -> true + | Sil.Hpointsto (Exp.Const (Const.Cstr _ | Const.Cclass _), _, _) -> + false + | _ -> + true in let sigma = List.filter ~f:filter prop.Prop.sigma in let sigmafp = List.filter ~f:filter prop.Prop.sigma_fp in let prop' = Prop.set prop ~sigma ~sigma_fp:sigmafp in Prop.normalize tenv prop' + (** existentially quantify the path identifier generated by the prover to keep track of expansions of lhs paths and remove pointsto's whose lhs is a constant string *) @@ -1116,6 +1163,7 @@ let quantify_path_idents_remove_constant_strings tenv (prop: Prop.normal Prop.t) Sil.fav_filter_ident fav Ident.is_path ; remove_constant_string_class tenv (Prop.exist_quantify tenv fav prop) + (** Strengthen the footprint by adding pure facts from the current part *) let prop_pure_to_footprint tenv (p: 'a Prop.t) : Prop.normal Prop.t = let is_footprint_atom_not_attribute a = @@ -1134,6 +1182,7 @@ let prop_pure_to_footprint tenv (p: 'a Prop.t) : Prop.normal Prop.t = in Prop.normalize tenv (Prop.set p ~pi_fp:filtered_pi_fp) + (** post-process the raw result of a function call *) let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc results = let filter_valid_res = function Invalid_res _ -> false | Valid_res _ -> true in @@ -1161,14 +1210,14 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re (* no valid results where actual pre and missing are consistent *) match deref_errors with | error :: _ - -> ( + -> ( (* dereference error detected *) let extend_path path_opt path_pos_opt = match path_opt with - | None - -> () - | Some path_post - -> let old_path, _ = State.get_path () in + | None -> + () + | Some path_post -> + let old_path, _ = State.get_path () in let new_path = Paths.Path.add_call (include_subtrace callee_pname) old_path callee_pname path_post @@ -1176,18 +1225,18 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re State.set_path new_path path_pos_opt in match error with - | Dereference_error (Deref_minusone, desc, path_opt) - -> trace_call Specs.CallStats.CR_not_met ; + | Dereference_error (Deref_minusone, desc, path_opt) -> + trace_call Specs.CallStats.CR_not_met ; extend_path path_opt None ; raise (Exceptions.Dangling_pointer_dereference (Some PredSymb.DAminusone, desc, __POS__)) - | Dereference_error (Deref_undef_exp, desc, path_opt) - -> trace_call Specs.CallStats.CR_not_met ; + | Dereference_error (Deref_undef_exp, desc, path_opt) -> + trace_call Specs.CallStats.CR_not_met ; extend_path path_opt None ; raise (Exceptions.Dangling_pointer_dereference (Some PredSymb.DAuninit, desc, __POS__)) - | Dereference_error (Deref_null pos, desc, path_opt) - -> trace_call Specs.CallStats.CR_not_met ; + | Dereference_error (Deref_null pos, desc, path_opt) -> + trace_call Specs.CallStats.CR_not_met ; extend_path path_opt (Some pos) ; if Localise.is_parameter_not_null_checked_desc desc then raise (Exceptions.Parameter_not_null_checked (desc, __POS__)) @@ -1198,30 +1247,30 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re else if Localise.is_empty_vector_access_desc desc then raise (Exceptions.Empty_vector_access (desc, __POS__)) else raise (Exceptions.Null_dereference (desc, __POS__)) - | Dereference_error (Deref_freed _, desc, path_opt) - -> trace_call Specs.CallStats.CR_not_met ; + | Dereference_error (Deref_freed _, desc, path_opt) -> + trace_call Specs.CallStats.CR_not_met ; extend_path path_opt None ; raise (Exceptions.Use_after_free (desc, __POS__)) - | Dereference_error (Deref_undef (_, _, pos), desc, path_opt) - -> trace_call Specs.CallStats.CR_not_met ; + | Dereference_error (Deref_undef (_, _, pos), desc, path_opt) -> + trace_call Specs.CallStats.CR_not_met ; extend_path path_opt (Some pos) ; raise (Exceptions.Skip_pointer_dereference (desc, __POS__)) - | Prover_checks _ | Cannot_combine | Missing_sigma_not_empty | Missing_fld_not_empty - -> trace_call Specs.CallStats.CR_not_met ; + | Prover_checks _ | Cannot_combine | Missing_sigma_not_empty | Missing_fld_not_empty -> + trace_call Specs.CallStats.CR_not_met ; assert false ) - | [] - -> (* no dereference error detected *) + | [] -> + (* no dereference error detected *) let desc = if List.exists ~f:(function Cannot_combine -> true | _ -> false) invalid_res then call_desc (Some Localise.Pnm_dangling) else if List.exists ~f:(function - | Prover_checks (check :: _) - -> trace_call Specs.CallStats.CR_not_met ; + | Prover_checks (check :: _) -> + trace_call Specs.CallStats.CR_not_met ; let exn = get_check_exn tenv check callee_pname loc __POS__ in raise exn - | _ - -> false) + | _ -> + false) invalid_res then call_desc (Some Localise.Pnm_bounds) else call_desc None @@ -1257,11 +1306,11 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re Prover.find_minimum_pure_cover tenv (List.map ~f:(fun vr -> (vr.vr_pi, vr.vr_cons_res)) valid_res_miss_pi) with - | None - -> trace_call Specs.CallStats.CR_not_met ; + | None -> + trace_call Specs.CallStats.CR_not_met ; raise (Exceptions.Precondition_not_met (call_desc None, __POS__)) - | Some cover - -> L.d_strln "Found minimum cover" ; + | Some cover -> + L.d_strln "Found minimum cover" ; List.iter ~f:print_pi (List.map ~f:fst cover) ; List.concat_map ~f:snd cover ) in @@ -1275,26 +1324,27 @@ let exe_call_postprocess tenv ret_id trace_call callee_pname callee_attrs loc re let returns_nullable ret_annot = Annotations.ia_is_nullable ret_annot in let should_add_ret_attr _ = let is_likely_getter = function - | Typ.Procname.Java pn_java - -> Int.equal (List.length (Typ.Procname.java_get_parameters pn_java)) 0 - | _ - -> false + | Typ.Procname.Java pn_java -> + Int.equal (List.length (Typ.Procname.java_get_parameters pn_java)) 0 + | _ -> + false in Config.idempotent_getters && Config.curr_language_is Config.Java && is_likely_getter callee_pname || returns_nullable ret_annot in match ret_id with - | Some (ret_id, _) when should_add_ret_attr () - -> (* add attribute to remember what function call a return id came from *) + | Some (ret_id, _) when should_add_ret_attr () -> + (* add attribute to remember what function call a return id came from *) let ret_var = Exp.Var ret_id in let mark_id_as_retval (p, path) = let att_retval = PredSymb.Aretval (callee_pname, ret_annot) in (Attribute.add tenv p att_retval [ret_var], path) in List.map ~f:mark_id_as_retval res - | _ - -> res + | _ -> + res + (** Execute the function call and return the list of results with return value *) let exe_function_call callee_summary tenv ret_id_opt caller_pdesc callee_pname loc actual_params @@ -1319,3 +1369,4 @@ let exe_function_call callee_summary tenv ret_id_opt caller_pdesc callee_pname l in let results = List.map ~f:exe_one_spec spec_list in exe_call_postprocess tenv ret_id_opt trace_call callee_pname callee_attrs loc results + diff --git a/infer/src/backend/timeout.ml b/infer/src/backend/timeout.ml index 27b8f43f3..ed1a5dc7e 100644 --- a/infer/src/backend/timeout.ml +++ b/infer/src/backend/timeout.ml @@ -26,48 +26,59 @@ module GlobalState = struct let pop () = match !stack with - | top_status :: l - -> stack := l ; + | top_status :: l -> + stack := l ; Some top_status - | [] - -> None + | [] -> + None + let push status = stack := status :: !stack end let set_alarm nsecs = match Config.os_type with - | Config.Unix | Config.Cygwin - -> ignore + | Config.Unix | Config.Cygwin -> + ignore (Unix.setitimer Unix.ITIMER_REAL { Unix.it_interval= 3.0 ; (* try again after 3 seconds if the signal is lost *) Unix.it_value= nsecs }) - | Config.Win32 - -> SymOp.set_wallclock_alarm nsecs + | Config.Win32 -> + SymOp.set_wallclock_alarm nsecs + let unset_alarm () = match Config.os_type with - | Config.Unix | Config.Cygwin - -> set_alarm 0.0 - | Config.Win32 - -> SymOp.unset_wallclock_alarm () + | Config.Unix | Config.Cygwin -> + set_alarm 0.0 + | Config.Win32 -> + SymOp.unset_wallclock_alarm () + let get_seconds_remaining () = match Config.os_type with - | Config.Unix | Config.Cygwin - -> (Unix.getitimer Unix.ITIMER_REAL).Unix.it_value - | Config.Win32 - -> SymOp.get_remaining_wallclock_time () + | Config.Unix | Config.Cygwin -> + (Unix.getitimer Unix.ITIMER_REAL).Unix.it_value + | Config.Win32 -> + SymOp.get_remaining_wallclock_time () + let get_current_status ~keep_symop_total = let seconds_remaining = get_seconds_remaining () in let symop_state = SymOp.save_state ~keep_symop_total in {seconds_remaining; symop_state} -let set_status status = SymOp.restore_state status.symop_state ; set_alarm status.seconds_remaining -let timeout_action _ = unset_alarm () ; raise (SymOp.Analysis_failure_exe FKtimeout) +let set_status status = + SymOp.restore_state status.symop_state ; + set_alarm status.seconds_remaining + + +let timeout_action _ = + unset_alarm () ; + raise (SymOp.Analysis_failure_exe FKtimeout) + let () = (* Can't use Core since it wraps signal handlers and alarms with catch-all exception handlers that @@ -75,24 +86,27 @@ let () = let module Gc = Caml.Gc in let module Sys = Caml.Sys in match Config.os_type with - | Config.Unix | Config.Cygwin - -> Sys.set_signal Sys.sigvtalrm (Sys.Signal_handle timeout_action) ; + | Config.Unix | Config.Cygwin -> + Sys.set_signal Sys.sigvtalrm (Sys.Signal_handle timeout_action) ; Sys.set_signal Sys.sigalrm (Sys.Signal_handle timeout_action) - | Config.Win32 - -> SymOp.set_wallclock_timeout_handler timeout_action ; + | Config.Win32 -> + SymOp.set_wallclock_timeout_handler timeout_action ; (* use the Gc alarm for periodic timeout checks *) ignore (Gc.create_alarm SymOp.check_wallclock_alarm) + let unwind () = unset_alarm () ; SymOp.unset_alarm () ; GlobalState.pop () let suspend_existing_timeout ~keep_symop_total = let current_status = get_current_status ~keep_symop_total in unset_alarm () ; GlobalState.push current_status + let resume_previous_timeout () = let status_opt = unwind () in Option.iter ~f:set_status status_opt + let exe_timeout f x = let suspend_existing_timeout_and_start_new_one () = suspend_existing_timeout ~keep_symop_total:true ; @@ -101,9 +115,13 @@ let exe_timeout f x = in try SymOp.try_finally - ~f:(fun () -> suspend_existing_timeout_and_start_new_one () ; f x ; None) + ~f:(fun () -> + suspend_existing_timeout_and_start_new_one () ; + f x ; + None) ~finally:resume_previous_timeout with SymOp.Analysis_failure_exe kind -> L.progressbar_timeout_event kind ; Errdesc.warning_err (State.get_loc ()) "TIMEOUT: %a@." SymOp.pp_failure_kind kind ; Some kind + diff --git a/infer/src/base/CommandDoc.ml b/infer/src/base/CommandDoc.ml index 765565335..9258c5fef 100644 --- a/infer/src/base/CommandDoc.ml +++ b/infer/src/base/CommandDoc.ml @@ -48,6 +48,7 @@ let mk_command_doc ~see_also:see_also_commands ?environment:environment_opt ?fil ~date:Version.man_pages_last_modify_date ~synopsis:[`Pre synopsis] ~environment ~files ~see_also + let analyze = mk_command_doc ~title:"Infer Analysis" ~short_description:"analyze the files captured by infer" ~synopsis:{|$(b,infer) $(b,analyze) $(i,[options]) @@ -55,6 +56,7 @@ $(b,infer) $(i,[options])|} ~description:[`P "Analyze the files captured in the project results directory and report."] ~see_also:CLOpt.([Report; Run]) + let capture = mk_command_doc ~title:"Infer Compilation Capture" ~short_description:"capture source files for later analysis" @@ -76,6 +78,7 @@ $(b,infer) $(b,capture) $(i,[--no-xcpretty]) $(i,[options]) $(b,--) $(b,xcodebui ] ~see_also:CLOpt.([Analyze; Compile; Run]) + let compile = mk_command_doc ~title:"Infer Project Compilation" ~short_description:"compile project from within the infer environment" @@ -103,6 +106,7 @@ let compile = ] ~see_also:CLOpt.([Capture]) + let diff = mk_command_doc ~title:"Infer Differential Analysis of a Project" ~short_description:"Report the difference between two versions of a project" @@ -110,6 +114,7 @@ let diff = ~description:[`P "EXPERIMENTAL AND IN NO WAY READY TO USE"] ~see_also:CLOpt.([ReportDiff; Run]) + let explore = mk_command_doc ~title:"Infer Explore" ~short_description:"explore the error traces in infer reports" @@ -120,6 +125,7 @@ let explore = ] ~see_also:CLOpt.([Report; Run]) + let infer = mk_command_doc ~title:"Infer Static Analyzer" ~short_description:"static analysis for Java and C/C++/Objective-C/Objective-C++" @@ -199,6 +205,7 @@ $(b,infer) $(i,[options])|} }|} ] ~see_also:CLOpt.all_commands "infer" + let report = mk_command_doc ~title:"Infer Reporting" ~short_description:"compute and manipulate infer results" ~synopsis:"$(b,infer) $(b,report) $(i,[options]) [$(i,file.specs)...]" @@ -210,6 +217,7 @@ let report = ] ~see_also:CLOpt.([ReportDiff; Run]) + let reportdiff = mk_command_doc ~title:"Infer Report Difference" ~short_description:"compute the differences between two infer reports" @@ -229,6 +237,7 @@ let reportdiff = ; `P "All three files follow the same format as normal infer reports." ] ~see_also:CLOpt.([Report]) + let run = mk_command_doc ~title:"Infer Analysis of a Project" ~short_description:"capture source files, analyze, and report" @@ -242,6 +251,7 @@ $(b,infer) $(i,[options]) $(b,--) $(i,compile command)|} $(b,infer) $(b,analyze) $(i,[options])|} ] ~see_also:CLOpt.([Analyze; Capture; Report]) + let command_to_data = let mk cmd mk_doc = let name = CLOpt.name_of_command cmd in @@ -258,5 +268,7 @@ let command_to_data = ; mk ReportDiff reportdiff ; mk Run run ] + let data_of_command command = List.Assoc.find_exn ~equal:CLOpt.equal_command command_to_data command + diff --git a/infer/src/base/CommandLineOption.ml b/infer/src/base/CommandLineOption.ml index fab8c55c8..0b17a5fd3 100644 --- a/infer/src/base/CommandLineOption.ml +++ b/infer/src/base/CommandLineOption.ml @@ -24,11 +24,13 @@ let is_env_var_set v = Option.value (Option.map (Sys.getenv v) ~f:(( = ) "1")) ~ options are relative. *) let init_work_dir, is_originator = match Sys.getenv "INFER_CWD" with - | Some dir - -> (dir, false) - | None - -> let real_cwd = Utils.realpath (Sys.getcwd ()) in - Unix.putenv ~key:"INFER_CWD" ~data:real_cwd ; (real_cwd, true) + | Some dir -> + (dir, false) + | None -> + let real_cwd = Utils.realpath (Sys.getcwd ()) in + Unix.putenv ~key:"INFER_CWD" ~data:real_cwd ; + (real_cwd, true) + let strict_mode_env_var = "INFER_STRICT_MODE" @@ -39,6 +41,7 @@ let warnf = else if not is_originator then fun fmt -> F.ifprintf F.err_formatter fmt else F.eprintf + (** This is the subset of Arg.spec that we actually use. What's important is that all these specs call back functions. We use this to mark deprecated arguments. What's not important is that, eg, Arg.Float is missing. *) @@ -49,14 +52,15 @@ type spec = | Rest of (string -> unit) let to_arg_spec = function - | Unit f - -> Arg.Unit f - | String f - -> Arg.String f - | Symbol (symbols, f) - -> Arg.Symbol (symbols, f) - | Rest f - -> Arg.Rest f + | Unit f -> + Arg.Unit f + | String f -> + Arg.String f + | Symbol (symbols, f) -> + Arg.Symbol (symbols, f) + | Rest f -> + Arg.Rest f + let to_arg_spec_triple (x, spec, y) = (x, to_arg_spec spec, y) @@ -75,15 +79,16 @@ type anon_arg_action = let anon_arg_action_of_parse_mode parse_mode = let parse_subcommands, parse_argfiles, on_unknown = match parse_mode with - | InferCommand - -> (true, true, `Reject) - | Javac - -> (false, true, `Skip) - | NoParse - -> (false, false, `Skip) + | InferCommand -> + (true, true, `Reject) + | Javac -> + (false, true, `Skip) + | NoParse -> + (false, false, `Skip) in {parse_subcommands; parse_argfiles; on_unknown} + (* NOTE: All variants must be also added to `all_commands` below *) type command = | Analyze @@ -110,6 +115,7 @@ let command_to_name = ; (ReportDiff, "reportdiff") ; (Run, "run") ] + let all_commands = List.map ~f:fst command_to_name let name_of_command = List.Assoc.find_exn ~equal:equal_command command_to_name @@ -122,6 +128,7 @@ let command_of_exe_name exe_name = List.find_map command_to_name ~f:(fun (cmd, name) -> if String.equal exe_name (exe_name_of_command_name name) then Some cmd else None ) + type command_doc = { title: Cmdliner.Manpage.title ; manual_before_options: Cmdliner.Manpage.block list @@ -140,54 +147,58 @@ type desc = let dashdash ?short long = match (long, short) with - | "", (None | Some "") | "--", _ - -> long - | "", Some short - -> "-" ^ short - | _ - -> "--" ^ long + | "", (None | Some "") | "--", _ -> + long + | "", Some short -> + "-" ^ short + | _ -> + "--" ^ long + let xdesc {long; short; spec} = let key long short = match (long, short) with - | "", "" - -> "" - | "--", _ - -> "--" - | "", _ - -> "-" ^ short - | _ - -> "--" ^ long + | "", "" -> + "" + | "--", _ -> + "--" + | "", _ -> + "-" ^ short + | _ -> + "--" ^ long in let xspec = match spec with (* translate Symbol to String for better formatting of --help messages *) - | Symbol (symbols, action) - -> String + | Symbol (symbols, action) -> + String (fun arg -> if List.mem ~equal:String.equal symbols arg then action arg else raise (Arg.Bad (F.sprintf "wrong argument '%s'; option '%s' expects one of: %s" arg - (dashdash ~short long) (String.concat ~sep:" | " symbols)))) - | _ - -> spec + (dashdash ~short long) + (String.concat ~sep:" | " symbols)))) + | _ -> + spec in (* Arg doesn't need to know anything about documentation since we generate our own *) (key long short, xspec, "") + let check_no_duplicates desc_list = let rec check_for_duplicates_ = function - | [] | [_] - -> true - | (x, _, _) :: (y, _, _) :: _ when x <> "" && x = y - -> L.(die InternalError) "Multiple definitions of command line option: %s" x - | _ :: tl - -> check_for_duplicates_ tl + | [] | [_] -> + true + | (x, _, _) :: (y, _, _) :: _ when x <> "" && x = y -> + L.(die InternalError) "Multiple definitions of command line option: %s" x + | _ :: tl -> + check_for_duplicates_ tl in check_for_duplicates_ (List.sort ~cmp:(fun (x, _, _) (y, _, _) -> String.compare x y) desc_list) + let parse_mode_desc_lists = List.map ~f:(fun parse_mode -> (parse_mode, ref [])) all_parse_modes module SectionMap = Caml.Map.Make (struct @@ -205,11 +216,13 @@ module SectionMap = Caml.Map.Make (struct -1 else (* reverse order *) String.compare s2 s1 + end) let help_sections_desc_lists = List.map all_commands ~f:(fun command -> (command, ref SectionMap.empty)) + let visible_descs_list = ref [] let hidden_descs_list = ref [] @@ -236,16 +249,16 @@ let add parse_mode sections desc = let oxford_comma l = let rec aux acc l = match (l, acc) with - | [], _ - -> assert false - | [x], [] - -> x - | [x; y], [] - -> Printf.sprintf "%s and %s" x y - | [x; y], acc - -> Printf.sprintf "%s, %s, and %s" (String.concat ~sep:", " (List.rev acc)) x y - | x :: tl, acc - -> aux (x :: acc) tl + | [], _ -> + assert false + | [x], [] -> + x + | [x; y], [] -> + Printf.sprintf "%s and %s" x y + | [x; y], acc -> + Printf.sprintf "%s, %s, and %s" (String.concat ~sep:", " (List.rev acc)) x y + | x :: tl, acc -> + aux (x :: acc) tl in aux [] l in @@ -263,26 +276,27 @@ let add parse_mode sections desc = visible_descs_list := desc_infer :: !visible_descs_list ; () + let deprecate_desc parse_mode ~long ~short ~deprecated desc = let warn () = match parse_mode with - | Javac | NoParse - -> () - | InferCommand - -> warnf "WARNING: '-%s' is deprecated. Use '--%s'%s instead.@." deprecated long + | Javac | NoParse -> + () + | InferCommand -> + warnf "WARNING: '-%s' is deprecated. Use '--%s'%s instead.@." deprecated long (if short = "" then "" else Printf.sprintf " or '-%s'" short) in let warn_then_f f x = warn () ; f x in let deprecated_spec = match desc.spec with - | Unit f - -> Unit (warn_then_f f) - | String f - -> String (warn_then_f f) - | Symbol (symbols, f) - -> Symbol (symbols, warn_then_f f) - | Rest _ as spec - -> spec + | Unit f -> + Unit (warn_then_f f) + | String f -> + String (warn_then_f f) + | Symbol (symbols, f) -> + Symbol (symbols, warn_then_f f) + | Rest _ as spec -> + spec in let deprecated_decode_json ~inferconfig_dir j = warnf "WARNING: in .inferconfig: '%s' is deprecated. Use '%s' instead." deprecated long ; @@ -295,6 +309,7 @@ let deprecate_desc parse_mode ~long ~short ~deprecated desc = ; spec= deprecated_spec ; decode_json= deprecated_decode_json } + let mk ?(deprecated= []) ?(parse_mode= InferCommand) ?(in_help= []) ~long ?short:short0 ~default ~meta doc ~default_to_string ~decode_json ~mk_setter ~mk_spec = let variable = ref default in @@ -323,6 +338,7 @@ let mk ?(deprecated= []) ?(parse_mode= InferCommand) ?(in_help= []) ~long ?short deprecate_desc parse_mode ~long ~short ~deprecated desc |> add parse_mode [] ) ; variable + (* begin parsing state *) (* arguments passed to Arg.parse_argv_dynamic, susceptible to be modified on the fly when parsing *) let args_to_parse : string array ref = ref (Array.of_list []) @@ -359,9 +375,11 @@ let path_json_decoder ~long ~inferconfig_dir json = in [dashdash long; abs_path] + let list_json_decoder json_decoder ~inferconfig_dir json = List.concat (YBU.convert_each (json_decoder ~inferconfig_dir) json) + let mk_set var value ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "") doc = let setter () = var := value in ignore @@ -369,6 +387,7 @@ let mk_set var value ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= ~default_to_string:(fun () -> "") ~decode_json:(string_json_decoder ~long) ~mk_setter:(fun _ _ -> setter ()) ~mk_spec:(fun _ -> Unit setter )) + let mk_with_reset value ~reset_doc ?deprecated ~long ?parse_mode mk = let var = mk () in if not (String.equal "" long) then @@ -377,6 +396,7 @@ let mk_with_reset value ~reset_doc ?deprecated ~long ?parse_mode mk = mk_set var value ?deprecated ~long:(long ^ "-reset") ?parse_mode reset_doc ; var + let reset_doc_opt ~long = Printf.sprintf "Cancel the effect of $(b,%s)." (dashdash long) let reset_doc_list ~long = Printf.sprintf "Set $(b,%s) to the empty list." (dashdash long) @@ -393,6 +413,7 @@ let mk_option ?(default= None) ?(default_to_string= fun _ -> "") ~f ?(mk_reset= mk_with_reset None ~reset_doc ~long ?parse_mode mk else mk () + let mk_bool ?(deprecated_no= []) ?(default= false) ?(f= fun b -> b) ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "") doc0 = let nolong = @@ -407,10 +428,10 @@ let mk_bool ?(deprecated_no= []) ?(default= false) ?(f= fun b -> b) ?(deprecated in let doc long short = match short with - | Some short - -> doc0 ^ " (Conversely: $(b,--" ^ long ^ ") | $(b,-" ^ String.of_char short ^ "))" - | None - -> doc0 ^ " (Conversely: $(b,--" ^ long ^ "))" + | Some short -> + doc0 ^ " (Conversely: $(b,--" ^ long ^ ") | $(b,-" ^ String.of_char short ^ "))" + | None -> + doc0 ^ " (Conversely: $(b,--" ^ long ^ "))" in let doc, nodoc = if String.equal doc0 "" then ("", "") @@ -435,6 +456,7 @@ let mk_bool ?(deprecated_no= []) ?(default= false) ?(f= fun b -> b) ?(deprecated ~mk_spec) ; var + let mk_bool_group ?(deprecated_no= []) ?(default= false) ?f:(f0 = Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?meta doc children no_children = let f b = @@ -444,34 +466,40 @@ let mk_bool_group ?(deprecated_no= []) ?(default= false) ?f:(f0 = Fn.id) ?(depre in mk_bool ~deprecated ~deprecated_no ~default ~long ?short ~f ?parse_mode ?in_help ?meta doc + let mk_int ~default ?(f= Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "int") doc = mk ~deprecated ~long ?short ~default ?parse_mode ?in_help ~meta doc ~default_to_string:string_of_int ~mk_setter:(fun var str -> var := f (int_of_string str)) ~decode_json:(string_json_decoder ~long) ~mk_spec:(fun set -> String set ) + let mk_int_opt ?default ?f:(f0 = Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "int") doc = let default_to_string = function Some f -> string_of_int f | None -> "" in let f s = Some (f0 (int_of_string s)) in mk_option ~deprecated ~long ?short ~default ~default_to_string ~f ?parse_mode ?in_help ~meta doc + let mk_float ~default ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "float") doc = mk ~deprecated ~long ?short ~default ?parse_mode ?in_help ~meta doc ~default_to_string:string_of_float ~mk_setter:(fun var str -> var := float_of_string str) ~decode_json:(string_json_decoder ~long) ~mk_spec:(fun set -> String set ) + let mk_float_opt ?default ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "float") doc = let default_to_string = function Some f -> string_of_float f | None -> "" in let f s = Some (float_of_string s) in mk_option ~deprecated ~long ?short ~default ~default_to_string ~f ?parse_mode ?in_help ~meta doc + let mk_string ~default ?(f= fun s -> s) ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "string") doc = mk ~deprecated ~long ?short ~default ?parse_mode ?in_help ~meta doc ~default_to_string:(fun s -> s) ~mk_setter:(fun var str -> var := f str) ~decode_json:(string_json_decoder ~long) ~mk_spec:(fun set -> String set ) + let mk_string_opt ?default ?(f= fun s -> s) ?mk_reset ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "string") doc = let default_to_string = function Some s -> s | None -> "" in @@ -479,6 +507,7 @@ let mk_string_opt ?default ?(f= fun s -> s) ?mk_reset ?(deprecated= []) ~long ?s mk_option ~deprecated ~long ?short ~default ~default_to_string ~f ?mk_reset ?parse_mode ?in_help ~meta doc + let mk_string_list ?(default= []) ?(f= fun s -> s) ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "string") doc = let mk () = @@ -490,6 +519,7 @@ let mk_string_list ?(default= []) ?(f= fun s -> s) ?(deprecated= []) ~long ?shor let reset_doc = reset_doc_list ~long in mk_with_reset [] ~reset_doc ~long ?parse_mode mk + let normalize_path_in_args_being_parsed ?(f= Fn.id) ~is_anon_arg str = if Filename.is_relative str then (* Replace relative paths with absolute ones on the fly in the args being parsed. This assumes @@ -502,6 +532,7 @@ let normalize_path_in_args_being_parsed ?(f= Fn.id) ~is_anon_arg str = abs_path else str + let mk_path_helper ~setter ~default_to_string ~default ~deprecated ~long ~short ~parse_mode ~in_help ~meta ~decode_json doc = mk ~deprecated ~long ?short ~default ?parse_mode ?in_help ~meta doc ~decode_json @@ -510,6 +541,7 @@ let mk_path_helper ~setter ~default_to_string ~default ~deprecated ~long ~short let abs_path = normalize_path_in_args_being_parsed ~is_anon_arg:false str in setter var abs_path) ~mk_spec:(fun set -> String set ) + let mk_path ~default ?(f= Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "path") = mk_path_helper @@ -518,6 +550,7 @@ let mk_path ~default ?(f= Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_ ~default_to_string:(fun s -> s) ~default ~deprecated ~long ~short ~parse_mode ~in_help ~meta + let mk_path_opt ?default ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "path") doc = let mk () = mk_path_helper @@ -529,6 +562,7 @@ let mk_path_opt ?default ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(m let reset_doc = reset_doc_opt ~long in mk_with_reset None ~reset_doc ~long ?parse_mode mk + let mk_path_list ?(default= []) ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "path") doc = let mk () = @@ -541,10 +575,12 @@ let mk_path_list ?(default= []) ?(deprecated= []) ~long ?short ?parse_mode ?in_h let reset_doc = reset_doc_list ~long in mk_with_reset [] ~reset_doc ~long ?parse_mode mk + let mk_symbols_meta symbols = let strings = List.map ~f:fst symbols in Printf.sprintf "{ %s }" (String.concat ~sep:" | " strings) + let mk_symbol ~default ~symbols ~eq ?(f= Fn.id) ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?meta doc = let strings = List.map ~f:fst symbols in @@ -556,6 +592,7 @@ let mk_symbol ~default ~symbols ~eq ?(f= Fn.id) ?(deprecated= []) ~long ?short ? ~default_to_string:(fun s -> to_string s) ~mk_setter:(fun var str -> var := of_string str |> f) ~decode_json:(string_json_decoder ~long) ~mk_spec:(fun set -> Symbol (strings, set) ) + let mk_symbol_opt ~symbols ?(f= Fn.id) ?(mk_reset= true) ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?meta doc = let strings = List.map ~f:fst symbols in @@ -571,6 +608,7 @@ let mk_symbol_opt ~symbols ?(f= Fn.id) ?(mk_reset= true) ?(deprecated= []) ~long mk_with_reset None ~reset_doc ~long ?parse_mode mk else mk () + let mk_symbol_seq ?(default= []) ~symbols ~eq ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?meta doc = let sym_to_str = List.map ~f:(fun (x, y) -> (y, x)) symbols in @@ -584,6 +622,7 @@ let mk_symbol_seq ?(default= []) ~symbols ~eq ?(deprecated= []) ~long ?short ?pa [dashdash long; String.concat ~sep:"," (YBU.convert_each YBU.to_string json)]) ~mk_spec: (fun set -> String set ) + let mk_set_from_json ~default ~default_to_string ~f ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "json") doc = mk ~deprecated ~long ?short ?parse_mode ?in_help ~meta doc ~default ~default_to_string @@ -591,6 +630,7 @@ let mk_set_from_json ~default ~default_to_string ~f ?(deprecated= []) ~long ?sho ~decode_json:(fun ~inferconfig_dir:_ json -> [dashdash long; Yojson.Basic.to_string json]) ~mk_spec:(fun set -> String set ) + let mk_json ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "json") doc = mk ~deprecated ~long ?short ?parse_mode ?in_help ~meta doc ~default:(`List []) ~default_to_string:Yojson.Basic.to_string @@ -598,6 +638,7 @@ let mk_json ?(deprecated= []) ~long ?short ?parse_mode ?in_help ?(meta= "json") ~decode_json:(fun ~inferconfig_dir:_ json -> [dashdash long; Yojson.Basic.to_string json]) ~mk_spec:(fun set -> String set ) + (** [mk_anon] always return the same ref. Anonymous arguments are only accepted if [parse_action_accept_unknown_args] is true. *) let mk_anon () = rev_anon_args @@ -609,6 +650,7 @@ let mk_rest ?(parse_mode= InferCommand) ?(in_help= []) doc = {long= "--"; short= ""; meta= ""; doc; spec; decode_json= (fun ~inferconfig_dir:_ _ -> [])} ; rest + let normalize_desc_list speclist = let norm k = let remove_no s = @@ -623,19 +665,20 @@ let normalize_desc_list speclist = in let compare_specs {long= x} {long= y} = match (x, y) with - | "--", "--" - -> 0 - | "--", _ - -> 1 - | _, "--" - -> -1 - | _ - -> let lower_norm s = String.lowercase @@ norm s in + | "--", "--" -> + 0 + | "--", _ -> + 1 + | _, "--" -> + -1 + | _ -> + let lower_norm s = String.lowercase @@ norm s in String.compare (lower_norm x) (lower_norm y) in let sort speclist = List.sort ~cmp:compare_specs speclist in sort speclist + let mk_command_doc ~title ~section ~version ~date ~short_description ~synopsis ~description ?options ?exit_status ?environment ?files ?notes ?bugs ?examples ~see_also command_str = let add_if section blocks = @@ -644,7 +687,7 @@ let mk_command_doc ~title ~section ~version ~date ~short_description ~synopsis ~ let manual_before_options = [ `S Cmdliner.Manpage.s_name ; (* the format of the following line is mandated by man(7) *) - `Pre (Printf.sprintf "%s - %s" command_str short_description) + `Pre (Printf.sprintf "%s - %s" command_str short_description) ; `S Cmdliner.Manpage.s_synopsis ; `Blocks synopsis ; `S Cmdliner.Manpage.s_description @@ -669,6 +712,7 @@ let mk_command_doc ~title ~section ~version ~date ~short_description ~synopsis ~ in command_doc + let set_curr_speclist_for_parse_mode ~usage parse_mode = let curr_usage status = prerr_endline (String.concat_array ~sep:" " !args_to_parse) ; @@ -694,15 +738,18 @@ let set_curr_speclist_for_parse_mode ~usage parse_mode = assert (check_no_duplicates !curr_speclist) ; curr_usage + let select_parse_mode ~usage parse_mode = let print_usage = set_curr_speclist_for_parse_mode ~usage parse_mode in anon_arg_action := anon_arg_action_of_parse_mode parse_mode ; print_usage + let string_of_command command = let _, s, _ = List.Assoc.find_exn !subcommands ~equal:equal_command command in s + let mk_rest_actions ?(parse_mode= InferCommand) ?(in_help= []) doc ~usage decode_action = let rest = ref [] in let spec = @@ -715,6 +762,7 @@ let mk_rest_actions ?(parse_mode= InferCommand) ?(in_help= []) doc ~usage decode {long= "--"; short= ""; meta= ""; doc; spec; decode_json= (fun ~inferconfig_dir:_ _ -> [])} ; rest + let mk_subcommand command ?on_unknown_arg:(on_unknown = `Reject) ~name ?deprecated_long ?parse_mode ?in_help command_doc = let switch () = @@ -722,19 +770,20 @@ let mk_subcommand command ?on_unknown_arg:(on_unknown = `Reject) ~name ?deprecat anon_arg_action := {(!anon_arg_action) with on_unknown} in ( match deprecated_long with - | Some long - -> ignore + | Some long -> + ignore (mk ~long ~default:() ?parse_mode ?in_help ~meta:"" "" ~default_to_string:(fun () -> "") ~decode_json:(fun ~inferconfig_dir:_ _ -> raise (Arg.Bad ("Bad option in config file: " ^ long))) ~mk_setter:(fun _ _ -> warnf "WARNING: '%s' is deprecated. Please use '%s' instead.@\n" (dashdash long) name ; switch ()) ~mk_spec:(fun set -> Unit (fun () -> set "") )) - | None - -> () ) ; + | None -> + () ) ; subcommands := (command, (command_doc, name, in_help)) :: !subcommands ; subcommand_actions := (name, switch) :: !subcommand_actions + (* drop well-balanced first and last characters in [s] that satisfy the [drop] predicate; for instance, [lrstrip ~drop:(function | 'a' | 'x' -> true | _ -> false) "xaabax"] returns "ab" *) let rec lrstrip ~drop s = @@ -746,17 +795,19 @@ let rec lrstrip ~drop s = lrstrip ~drop (String.slice s 1 (n - 1)) else s + let args_from_argfile arg = let abs_fname = let fname = String.slice arg 1 (String.length arg) in normalize_path_in_args_being_parsed ~f:(fun s -> "@" ^ s) ~is_anon_arg:true fname in match In_channel.read_lines abs_fname with - | lines - -> let strip = lrstrip ~drop:(function '"' | '\'' -> true | _ -> false) in + | lines -> + let strip = lrstrip ~drop:(function '"' | '\'' -> true | _ -> false) in List.map ~f:strip lines - | exception e - -> raise (Arg.Bad ("Error reading argument file '" ^ abs_fname ^ "': " ^ Exn.to_string e)) + | exception e -> + raise (Arg.Bad ("Error reading argument file '" ^ abs_fname ^ "': " ^ Exn.to_string e)) + exception SubArguments of string list @@ -769,29 +820,31 @@ let anon_fun arg = then let command_switch = List.Assoc.find_exn !subcommand_actions ~equal:String.equal arg in match (!curr_command, is_originator) with - | None, _ | Some _, false - -> command_switch () - | Some command, true - -> raise + | None, _ | Some _, false -> + command_switch () + | Some command, true -> + raise (Arg.Bad (Printf.sprintf "More than one subcommand specified: '%s', '%s'" (string_of_command command) arg)) else match !anon_arg_action.on_unknown with - | `Add - -> rev_anon_args := arg :: !rev_anon_args - | `Skip - -> () - | `Reject - -> raise (Arg.Bad (Printf.sprintf "Unexpected anonymous argument: '%s'" arg)) + | `Add -> + rev_anon_args := arg :: !rev_anon_args + | `Skip -> + () + | `Reject -> + raise (Arg.Bad (Printf.sprintf "Unexpected anonymous argument: '%s'" arg)) + let decode_inferconfig_to_argv path = let json = match Utils.read_json_file path with - | Ok json - -> json - | Error msg - -> warnf "WARNING: Could not read or parse Infer config in %s:@\n%s@." path msg ; `Assoc [] + | Ok json -> + json + | Error msg -> + warnf "WARNING: Could not read or parse Infer config in %s:@\n%s@." path msg ; + `Assoc [] in let desc_list = List.Assoc.find_exn ~equal:equal_parse_mode parse_mode_desc_lists InferCommand in let json_config = YBU.to_assoc json in @@ -808,15 +861,17 @@ let decode_inferconfig_to_argv path = in decode_json ~inferconfig_dir json_val @ result with - | Not_found - -> warnf "WARNING: while reading config file %s:@\nUnknown option %s@." path key ; result - | YBU.Type_error (msg, json) - -> warnf "WARNING: while reading config file %s:@\nIll-formed value %s for option %s: %s@." + | Not_found -> + warnf "WARNING: while reading config file %s:@\nUnknown option %s@." path key ; + result + | YBU.Type_error (msg, json) -> + warnf "WARNING: while reading config file %s:@\nIll-formed value %s for option %s: %s@." path (Yojson.Basic.to_string json) key msg ; result in List.fold ~f:one_config_item ~init:[] json_config + (** separator of argv elements when encoded into environment variables *) let env_var_sep = '^' @@ -831,19 +886,22 @@ let encode_argv_to_env argv = false)) argv) + let decode_env_to_argv env = String.split ~on:env_var_sep env |> List.filter ~f:(Fn.non String.is_empty) + (** [prefix_before_rest (prefix @ ["--" :: rest])] is [prefix] where "--" is not in [prefix]. *) let rev_prefix_before_rest args = let rec rev_prefix_before_rest_ rev_keep = function - | [] | "--" :: _ - -> rev_keep - | keep :: args - -> rev_prefix_before_rest_ (keep :: rev_keep) args + | [] | "--" :: _ -> + rev_keep + | keep :: args -> + rev_prefix_before_rest_ (keep :: rev_keep) args in rev_prefix_before_rest_ [] args + (** environment variable use to pass arguments from parent to child processes *) let args_env_var = "INFER_ARGS" @@ -867,8 +925,8 @@ let parse_args ~usage initial_action ?initial_command args = try Arg.parse_argv_dynamic ~current:arg_being_parsed !args_to_parse curr_speclist anon_fun usage with - | SubArguments args - -> (* stop parsing the current arguments and parse [args] for a while *) + | SubArguments args -> + (* stop parsing the current arguments and parse [args] for a while *) let saved_args = !args_to_parse in let saved_current = !arg_being_parsed in args_to_parse := Array.of_list (exe_name :: args) ; @@ -878,18 +936,19 @@ let parse_args ~usage initial_action ?initial_command args = args_to_parse := saved_args ; arg_being_parsed := saved_current ; parse_loop () - | Arg.Bad usage_msg - -> if !anon_arg_action.on_unknown <> `Reject && is_unknown usage_msg then ( + | Arg.Bad usage_msg -> + if !anon_arg_action.on_unknown <> `Reject && is_unknown usage_msg then ( anon_fun !args_to_parse.(!arg_being_parsed) ; parse_loop () ) else Pervasives.(prerr_string usage_msg ; exit 1) - | Arg.Help _ - -> (* we handle --help by ourselves and error on -help, so Arg has no way to raise Help + | Arg.Help _ -> + (* we handle --help by ourselves and error on -help, so Arg has no way to raise Help anymore *) assert false in parse_loop () ; curr_usage + let parse ?config_file ~usage action initial_command = let env_args = decode_env_to_argv (Option.value (Sys.getenv args_env_var) ~default:"") in let inferconfig_args = @@ -921,7 +980,8 @@ let parse ?config_file ~usage action initial_command = let curr_usage = let cl_args = match Array.to_list Sys.argv with _ :: tl -> tl | [] -> [] in let curr_usage = parse_args ~usage action ?initial_command cl_args in - add_parsed_args_to_args_to_export () ; curr_usage + add_parsed_args_to_args_to_export () ; + curr_usage in let to_export = let argv_to_export = decode_env_to_argv !args_to_export in @@ -935,7 +995,9 @@ let parse ?config_file ~usage action initial_command = "@" ^ file else "" in - Unix.putenv ~key:args_env_var ~data:to_export ; (!curr_command, curr_usage) + Unix.putenv ~key:args_env_var ~data:to_export ; + (!curr_command, curr_usage) + let wrap_line indent_string wrap_length line0 = let line = indent_string ^ line0 in @@ -965,17 +1027,18 @@ let wrap_line indent_string wrap_length line0 = let rev_lines, _, line, _ = List.fold ~f:add_word_to_paragraph ~init:([], false, "", 0) words in List.rev (line :: rev_lines) + let show_manual ?internal_section format default_doc command_opt = let command_doc = match command_opt with - | None - -> default_doc + | None -> + default_doc | Some command -> match List.Assoc.find_exn ~equal:equal_command !subcommands command with - | Some command_doc, _, _ - -> command_doc - | None, _, _ - -> L.(die InternalError) "No manual for internal command %s" (string_of_command command) + | Some command_doc, _, _ -> + command_doc + | None, _, _ -> + L.(die InternalError) "No manual for internal command %s" (string_of_command command) in let pp_meta f meta = match meta with "" -> () | meta -> F.fprintf f " $(i,%s)" (Cmdliner.Manpage.escape meta) @@ -1001,21 +1064,21 @@ let show_manual ?internal_section format default_doc command_opt = in let option_blocks = match command_doc.manual_options with - | `Replace blocks - -> `S Cmdliner.Manpage.s_options :: blocks - | `Prepend blocks - -> let hidden = + | `Replace blocks -> + `S Cmdliner.Manpage.s_options :: blocks + | `Prepend blocks -> + let hidden = match internal_section with - | Some section - -> `S section + | Some section -> + `S section :: `P "Use at your own risk." - :: List.concat_map ~f:block_of_desc (normalize_desc_list !hidden_descs_list) - | None - -> [] + :: List.concat_map ~f:block_of_desc (normalize_desc_list !hidden_descs_list) + | None -> + [] in match command_opt with - | Some command - -> let sections = + | Some command -> + let sections = List.Assoc.find_exn ~equal:equal_command help_sections_desc_lists command in SectionMap.fold @@ -1024,8 +1087,8 @@ let show_manual ?internal_section format default_doc command_opt = :: (if String.equal section Cmdliner.Manpage.s_options then blocks else []) @ List.concat_map ~f:block_of_desc (normalize_desc_list descs) @ result) !sections hidden - | None - -> `S Cmdliner.Manpage.s_options :: blocks + | None -> + `S Cmdliner.Manpage.s_options :: blocks @ List.concat_map ~f:block_of_desc (normalize_desc_list !visible_descs_list) @ hidden in let blocks = @@ -1035,3 +1098,4 @@ let show_manual ?internal_section format default_doc command_opt = in Cmdliner.Manpage.print format Format.std_formatter (command_doc.title, blocks) ; () + diff --git a/infer/src/base/Config.ml b/infer/src/base/Config.ml index 5763cd5b6..4a2184cb4 100644 --- a/infer/src/base/Config.ml +++ b/infer/src/base/Config.ml @@ -38,12 +38,15 @@ let string_to_analyzer = ; ("crashcontext", Crashcontext) ; ("linters", Linters) ] + let string_of_analyzer a = List.find_exn ~f:(fun (_, a') -> equal_analyzer a a') string_to_analyzer |> fst + let clang_frontend_action_symbols = [("lint", `Lint); ("capture", `Capture); ("lint_and_capture", `Lint_and_capture)] + type language = Clang | Java | Python [@@deriving compare] let equal_language = [%compare.equal : language] @@ -58,6 +61,7 @@ let ml_bucket_symbols = ; ("cpp", `MLeak_cpp) ; ("unknown_origin", `MLeak_unknown) ] + let issues_fields_symbols = [ ("bug_class", `Issue_field_bug_class) ; ("kind", `Issue_field_kind) @@ -79,6 +83,7 @@ let issues_fields_symbols = ; ( "qualifier_contains_potential_exception_note" , `Issue_field_qualifier_contains_potential_exception_note ) ] + type os_type = Unix | Win32 | Cygwin type compilation_database_dependencies = @@ -132,13 +137,16 @@ let build_system_exe_assoc = ; (BPython, "python") ; (BXcode, "xcodebuild") ] + let build_system_of_exe_name name = try List.Assoc.find_exn ~equal:String.equal (List.Assoc.inverse build_system_exe_assoc) name with Not_found -> L.(die InternalError) "Unsupported build command %s" name + let string_of_build_system build_system = List.Assoc.find_exn ~equal:equal_build_system build_system_exe_assoc build_system + (** Constant configuration values *) let anonymous_block_num_sep = "______" @@ -327,6 +335,7 @@ let std_whitelisted_cpp_methods = ; "std::operator>=" ; "std::swap" ] + let libstdcxx_whitelisted_cpp_methods = [ "__gnu_cxx::operator!=" ; "__gnu_cxx::operator<" @@ -337,6 +346,7 @@ let libstdcxx_whitelisted_cpp_methods = ; "__gnu_cxx::operator+" ; "__gnu_cxx::operator-" ] + let libcxx_whitelisted_cpp_methods = [] let other_whitelisted_cpp_methods = ["google::CheckNotNull"] @@ -348,6 +358,7 @@ let whitelisted_cpp_methods = ; libcxx_whitelisted_cpp_methods ; other_whitelisted_cpp_methods ] + (* Whitelists for C++ library classes *) let std_whitelisted_cpp_classes = @@ -364,17 +375,20 @@ let std_whitelisted_cpp_classes = ; "std::pair" ; "std::reverse_iterator" ] + let libstdcxx_whitelisted_cpp_classes = (* libstdc++ internal support class for std::get *) [ "__gnu_cxx::__normal_iterator" (* libstdc++ internal name of vector iterator *) ; "std::__pair_get" ] + let libcxx_whitelisted_cpp_classes = (* libc++ internal support class for std::get *) [ "std::__less" ; "std::__wrap_iter" (* libc++ internal name of vector iterator *) ; "std::__get_pair" ] + let other_whitelisted_cpp_classes = [] let whitelisted_cpp_classes = @@ -384,6 +398,7 @@ let whitelisted_cpp_classes = ; libcxx_whitelisted_cpp_classes ; other_whitelisted_cpp_classes ] + type dynamic_dispatch = NoDynamicDispatch | Interface | Sound | Lazy [@@deriving compare] let equal_dynamic_dispatch = [%compare.equal : dynamic_dispatch] @@ -391,14 +406,17 @@ let equal_dynamic_dispatch = [%compare.equal : dynamic_dispatch] let string_to_dynamic_dispatch = [("none", NoDynamicDispatch); ("interface", Interface); ("sound", Sound); ("lazy", Lazy)] + let string_of_dynamic_dispatch ddp = List.find_exn ~f:(fun (_, ddp') -> equal_dynamic_dispatch ddp ddp') string_to_dynamic_dispatch |> fst + let pp_version fmt () = F.fprintf fmt "Infer version %s@\nCopyright 2009 - present Facebook. All Rights Reserved." Version.versionString + let version_string = F.asprintf "%a" pp_version () (** System call configuration values *) @@ -409,26 +427,30 @@ let initial_analysis_time = Unix.time () let clang_exe_aliases = [ (* this must be kept in sync with the clang-like symlinks in [wrappers_dir] (see below) *) - "c++" + "c++" ; "cc" ; "clang" ; "clang++" ; "g++" ; "gcc" ] + let exe_basename = (* Sys.executable_name tries to do clever things which we must avoid, use argv[0] instead *) Filename.basename Sys.argv.(0) + let infer_is_clang = List.mem ~equal:String.equal clang_exe_aliases exe_basename let initial_command = match CLOpt.command_of_exe_name exe_basename with Some _ as command -> command | None -> None + let bin_dir = (* Resolve symlinks to get to the real executable, which is located in [bin_dir]. *) Filename.dirname (Utils.realpath Sys.executable_name) + let lib_dir = bin_dir ^/ Filename.parent_dir_name ^/ "lib" let etc_dir = bin_dir ^/ Filename.parent_dir_name ^/ "etc" @@ -443,6 +465,7 @@ let models_src_dir = let dir = bin_dir ^/ Filename.parent_dir_name ^/ "models" in Utils.filename_to_absolute ~root dir + (* Normalize the path *) let relative_cpp_extra_include_dir = "cpp" ^/ "include" @@ -464,6 +487,7 @@ let ncpu = |> fst with _ -> 1 + let os_type = match Sys.os_type with "Win32" -> Win32 | "Cygwin" -> Cygwin | _ -> Unix (** Resolve relative paths passed as command line options, i.e., with respect to the working @@ -487,18 +511,21 @@ let startup_action = else if infer_is_clang then NoParse else InferCommand + let exe_usage = let exe_command_name = match initial_command with - | Some command - -> Some (CLOpt.name_of_command command) - | None - -> None + | Some command -> + Some (CLOpt.name_of_command command) + | None -> + None in Printf.sprintf "%s\nUsage: infer %s [options]\nSee `infer%s --help` for more information." - version_string (Option.value ~default:"command" exe_command_name) + version_string + (Option.value ~default:"command" exe_command_name) (Option.value_map ~default:"" ~f:(( ^ ) " ") exe_command_name) + (** Command Line options *) (* HOWTO define a new command line and config file option. @@ -536,10 +563,10 @@ let disable_all_checkers () = List.iter !all_checkers ~f:(fun (var, _, _, _) -> let () = let on_unknown_arg_from_command (cmd: CLOpt.command) = match cmd with - | Report - -> `Add - | Analyze | Capture | Compile | Diff | Explore | ReportDiff | Run - -> `Reject + | Report -> + `Add + | Analyze | Capture | Compile | Diff | Explore | ReportDiff | Run -> + `Reject in (* make sure we generate doc for all the commands we know about *) List.iter CLOpt.all_commands ~f:(fun cmd -> @@ -548,6 +575,7 @@ let () = let deprecated_long = if CLOpt.(equal_command ReportDiff) cmd then Some "diff" else None in CLOpt.mk_subcommand cmd ~name ?deprecated_long ~on_unknown_arg (Some command_doc) ) + let abs_struct = CLOpt.mk_int ~deprecated:["absstruct"] ~long:"abs-struct" ~default:1 ~meta:"int" {|Specify abstraction level for fields of structs: @@ -555,6 +583,7 @@ let abs_struct = - 1 = forget some fields during matching (and so lseg abstraction) |} + and abs_val = CLOpt.mk_int ~deprecated:["absval"] ~long:"abs-val" ~default:2 ~meta:"int" {|Specify abstraction level for expressions: @@ -563,13 +592,16 @@ and abs_val = - 2 = 1 + abstract constant integer values during join |} + and allow_leak = CLOpt.mk_bool ~deprecated:["leak"] ~long:"allow-leak" "Forget leaked memory during abstraction" + and allow_specs_cleanup = CLOpt.mk_bool ~deprecated:["allow_specs_cleanup"] ~long:"allow-specs-cleanup" ~default:true "Allow to remove existing specs before running analysis when it's not incremental" + and ( analysis_blacklist_files_containing_options , analysis_path_regex_blacklist_options , analysis_path_regex_whitelist_options @@ -585,8 +617,8 @@ and ( analysis_blacklist_files_containing_options List.find_map !config_vars ~f:(fun (a, v) -> if equal_analyzer a analyzer then Some v else None ) in - (** if the analyzer already has a variable associated to it, make the new name update the same - variable *) + (* if the analyzer already has a variable associated to it, make the new name update the same + variable *) let mirror opt = Option.iter source_of_truth ~f:(fun var -> var := opt :: !var) ; opt @@ -594,10 +626,10 @@ and ( analysis_blacklist_files_containing_options (* empty doc to hide the options from --help since there are many redundant ones *) let var = CLOpt.mk_string_list ~deprecated ~long ~meta ~f:mirror "" in match source_of_truth with - | Some var - -> (* if the analyzer already has a variable associated to it, use it *) var - | None - -> (* record the variable associated to the analyzer if this is the first time we see this + | Some var -> + (* if the analyzer already has a variable associated to it, use it *) var + | None -> + (* record the variable associated to the analyzer if this is the first time we see this analyzer *) config_vars := (analyzer, var) :: !config_vars ; var @@ -624,23 +656,24 @@ and ( analysis_blacklist_files_containing_options , mk_filtering_options ~suffix:"suppress-errors" ~deprecated_suffix:["suppress_errors"] ~help:"do not report a type of errors" ~meta:"error_name" ) + and analysis_stops = CLOpt.mk_bool ~deprecated:["analysis_stops"] ~long:"analysis-stops" "Issue a warning when the analysis stops" + and analyzer = let () = - match BiAbduction - with - | (* NOTE: if compilation fails here, it means you have added a new analyzer without updating the + match BiAbduction with + (* NOTE: if compilation fails here, it means you have added a new analyzer without updating the documentation of this option *) - BiAbduction + | BiAbduction | CaptureOnly | CompileOnly | Checkers | Crashcontext - | Linters - -> () + | Linters -> + () in CLOpt.mk_symbol_opt ~deprecated:["analyzer"] ~long:"analyzer" ~short:'a' ~in_help:CLOpt.([(Analyze, manual_generic); (Run, manual_generic)]) @@ -653,8 +686,8 @@ and analyzer = - $(b,compile): similar to specifying the $(b,compile) subcommand (DEPRECATED) - $(b,crashcontext): experimental (see $(b,--crashcontext))|} ~f:(function - | CaptureOnly | CompileOnly as x - -> let analyzer_str = + | CaptureOnly | CompileOnly as x -> + let analyzer_str = List.find_map_exn string_to_analyzer ~f:(fun (s, y) -> if equal_analyzer x y then Some s else None ) in @@ -662,14 +695,16 @@ and analyzer = "WARNING: The analyzer '%s' is deprecated, use the '%s' subcommand instead:@\n@\n infer %s ..." analyzer_str analyzer_str analyzer_str ; x - | _ as x - -> x) + | _ as x -> + x) ~symbols:string_to_analyzer + and android_harness = CLOpt.mk_bool ~deprecated:["harness"] ~long:"android-harness" "(Experimental) Create harness to detect issues involving the Android lifecycle" + and ( annotation_reachability , biabduction , bufferoverrun @@ -787,6 +822,7 @@ and ( annotation_reachability , suggest_nullable , uninit ) + and annotation_reachability_custom_pairs = CLOpt.mk_json ~long:"annotation-reachability-custom-pairs" ~in_help:CLOpt.([(Analyze, manual_java)]) @@ -794,11 +830,13 @@ and annotation_reachability_custom_pairs = Example format: for custom annotations com.my.annotation.{Source1,Source2,Sink1} { "sources" : ["Source1", "Source2"], "sink" : "Sink1" }|} + and append_buck_flavors = CLOpt.mk_string_list ~long:"append-buck-flavors" ~in_help:CLOpt.([(Capture, manual_buck_flavors)]) "Additional Buck flavors to append to targets discovered by the $(b,--buck-compilation-database) option." + and array_level = CLOpt.mk_int ~deprecated:["arraylevel"] ~long:"array-level" ~default:0 ~meta:"int" {|Level of treating the array indexing and pointer arithmetic: @@ -807,20 +845,24 @@ and array_level = - 2 = assumes that all heap dereferences via array indexing and pointer arithmetic are correct |} + and ast_file = CLOpt.mk_path_opt ~deprecated:["ast"] ~long:"ast-file" ~meta:"file" "AST file for the translation" + and blacklist = CLOpt.mk_string_opt ~deprecated:["-blacklist-regex"; "-blacklist"] ~long:"buck-blacklist" ~in_help:CLOpt.([(Run, manual_buck_flavors); (Capture, manual_buck_flavors)]) ~meta:"regex" "Skip analysis of files matched by the specified regular expression" + and bootclasspath = CLOpt.mk_string_opt ~long:"bootclasspath" ~in_help:CLOpt.([(Capture, manual_java)]) "Specify the Java bootclasspath" + (** Automatically set when running from within Buck *) and buck = CLOpt.mk_bool ~long:"buck" "" @@ -829,39 +871,46 @@ and buck_build_args = ~in_help:CLOpt.([(Capture, manual_buck_flavors)]) "Pass values as command-line arguments to invocations of $(i,`buck build`)" + and buck_compilation_database_depth = CLOpt.mk_int_opt ~long:"buck-compilation-database-depth" ~in_help:CLOpt.([(Capture, manual_buck_compilation_db)]) "Depth of dependencies used by the $(b,--buck-compilation-database deps) option. By default, all recursive dependencies are captured." ~meta:"int" + and buck_compilation_database = CLOpt.mk_symbol_opt ~long:"buck-compilation-database" ~deprecated:["-use-compilation-database"] ~in_help:CLOpt.([(Capture, manual_buck_compilation_db)]) "Buck integration using the compilation database, with or without dependencies." ~symbols:[("no-deps", `NoDeps); ("deps", `DepsTmp)] + and buck_out = CLOpt.mk_path_opt ~long:"buck-out" ~in_help:CLOpt.([(Capture, manual_buck_java)]) ~meta:"dir" "Specify the root directory of buck-out" + and calls_csv = CLOpt.mk_path_opt ~deprecated:["calls"] ~long:"calls-csv" ~in_help:CLOpt.([(Report, manual_generic)]) ~meta:"file" "Write individual calls in CSV format to $(i,file)" + and changed_files_index = CLOpt.mk_path_opt ~long:"changed-files-index" ~in_help:CLOpt.([(Analyze, manual_generic); (Diff, manual_generic)]) ~meta:"file" "Specify the file containing the list of source files from which reactive analysis should start. Source files should be specified relative to project root or be absolute" + and clang_biniou_file = CLOpt.mk_path_opt ~long:"clang-biniou-file" ~in_help:CLOpt.([(Capture, manual_clang)]) ~meta:"file" "Specify a file containing the AST of the program, in biniou format" + and clang_compilation_dbs = ref [] and clang_frontend_action = @@ -870,37 +919,44 @@ and clang_frontend_action = "Specify whether the clang frontend should capture or lint or both." ~symbols:clang_frontend_action_symbols + and clang_include_to_override_regex = CLOpt.mk_string_opt ~long:"clang-include-to-override-regex" ~deprecated:["-clang-include-to-override"] ~meta:"dir_OCaml_regex" "Use this option in the uncommon case where the normal compilation process overrides the location of internal compiler headers. This option should specify regular expression with the path to those headers so that infer can use its own clang internal headers instead." + and clang_ignore_regex = CLOpt.mk_string_opt ~long:"clang-ignore-regex" ~meta:"dir_OCaml_regex" "The files in this regex will be ignored in the compilation process and an empty file will be passed to clang instead. This is to be used with the buck flavour infer-capture-all to work around missing generated files." + and classpath = CLOpt.mk_string_opt ~long:"classpath" "Specify the Java classpath" and cluster = CLOpt.mk_path_opt ~deprecated:["cluster"] ~long:"cluster" ~meta:"file" "Specify a .cluster file to be analyzed" + and compilation_database = CLOpt.mk_path_list ~long:"compilation-database" ~deprecated:["-clang-compilation-db-files"] ~in_help:CLOpt.([(Capture, manual_clang)]) "File that contain compilation commands (can be specified multiple times)" + and compilation_database_escaped = CLOpt.mk_path_list ~long:"compilation-database-escaped" ~deprecated:["-clang-compilation-db-files-escaped"] ~in_help:CLOpt.([(Capture, manual_clang)]) "File that contain compilation commands where all entries are escaped for the shell, eg coming from Xcode (can be specified multiple times)" + and compute_analytics = CLOpt.mk_bool ~long:"compute-analytics" ~default:false ~in_help:CLOpt.([(Capture, manual_clang); (Run, manual_clang)]) "Emit analytics as info-level issues, like component kit line count and component kit file cyclomatic complexity" + (** Continue the capture for reactive mode: If a procedure was changed beforehand, keep the changed marking. *) and continue = @@ -908,12 +964,14 @@ and continue = ~in_help:CLOpt.([(Analyze, manual_generic)]) "Continue the capture for the reactive analysis, increasing the changed files/procedures. (If a procedure was changed beforehand, keep the changed marking.)" + and current_to_previous_script = CLOpt.mk_string_opt ~long:"current-to-previous-script" ~in_help:CLOpt.([(Diff, manual_generic)]) ~meta:"shell" "Specify a script to checkout a previous version of the project to compare against, assuming we are on the current version already." + and cxx, cxx_infer_headers = let cxx_infer_headers = CLOpt.mk_bool ~long:"cxx-infer-headers" ~default:true @@ -927,6 +985,7 @@ and cxx, cxx_infer_headers = in (cxx, cxx_infer_headers) + and ( bo_debug , developer_mode , debug @@ -1088,22 +1147,26 @@ and ( bo_debug , write_html_whitelist_regex , write_dotty ) + and dependencies = CLOpt.mk_bool ~deprecated:["dependencies"] ~long:"dependencies" ~in_help:CLOpt.([(Capture, manual_java)]) "Translate all the dependencies during the capture. The classes in the given jar file will be translated. No sources needed." + and differential_filter_files = CLOpt.mk_string_opt ~long:"differential-filter-files" ~in_help:CLOpt.([(Report, manual_generic)]) "Specify the file containing the list of source files for which a differential report is desired. Source files should be specified relative to project root or be absolute" + and differential_filter_set = CLOpt.mk_symbol_seq ~long:"differential-filter-set" ~eq:PVariant.( = ) "Specify which set of the differential results is filtered with the modified files provided through the $(b,--differential-modified-files) argument. By default it is applied to all sets ($(b,introduced), $(b,fixed), and $(b,preexisting))" ~symbols:[("introduced", `Introduced); ("fixed", `Fixed); ("preexisting", `Preexisting)] ~default:[`Introduced; `Fixed; `Preexisting] + and () = let mk b ?deprecated ~long ?default doc = let _ : string list ref = @@ -1130,54 +1193,68 @@ and () = mk true ~long:"enable-issue-type" ~deprecated:["enable_checks"; "-enable-checks"] "Show reports coming from this type of issue. By default, all issue types are enabled except the ones listed in $(b,--disable-issue-type). Note that enabling issue types does not make the corresponding checker run; see individual checker options to turn them on or off." + and dotty_cfg_libs = CLOpt.mk_bool ~deprecated:["dotty_no_cfg_libs"] ~long:"dotty-cfg-libs" ~default:true "Print the cfg of the code coming from the libraries" + and dump_duplicate_symbols = CLOpt.mk_bool ~long:"dump-duplicate-symbols" ~in_help:CLOpt.([(Capture, manual_clang)]) "Dump all symbols with the same name that are defined in more than one file." + and dynamic_dispatch = CLOpt.mk_symbol_opt ~long:"dynamic-dispatch" "Specify treatment of dynamic dispatch in Java code: 'none' treats dynamic dispatch as a call to unknown code, 'lazy' follows the JVM semantics and creates procedure descriptions during symbolic execution using the type information found in the abstract state; 'sound' is significantly more computationally expensive" ~symbols:string_to_dynamic_dispatch + and eradicate_condition_redundant = CLOpt.mk_bool ~long:"eradicate-condition-redundant" "Condition redundant warnings" + and eradicate_field_not_mutable = CLOpt.mk_bool ~long:"eradicate-field-not-mutable" "Field not mutable warnings" + and eradicate_field_over_annotated = CLOpt.mk_bool ~long:"eradicate-field-over-annotated" "Field over-annotated warnings" + and eradicate_optional_present = CLOpt.mk_bool ~long:"eradicate-optional-present" "Check for @Present annotations" + and eradicate_propagate_return_nullable = CLOpt.mk_bool ~long:"eradicate-propagate-return-nullable" "Propagation of nullable to the return value" + and eradicate_return_over_annotated = CLOpt.mk_bool ~long:"eradicate-return-over-annotated" "Return over-annotated warning" + and eradicate_debug = CLOpt.mk_bool ~long:"eradicate-debug" "Print debug info when errors are found" + and eradicate_verbose = CLOpt.mk_bool ~long:"eradicate-verbose" "Print initial and final typestates" + and fail_on_bug = CLOpt.mk_bool ~deprecated:["-fail-on-bug"] ~long:"fail-on-issue" ~default:false ~in_help:CLOpt.([(Run, manual_generic)]) (Printf.sprintf "Exit with error code %d if Infer found something to report" fail_on_issue_exit_code) + and fcp_apple_clang = CLOpt.mk_path_opt ~long:"fcp-apple-clang" ~meta:"path" "Specify the path to Apple Clang" + and fcp_syntax_only = CLOpt.mk_bool ~long:"fcp-syntax-only" "Skip creation of object files" and file_renamings = @@ -1185,14 +1262,17 @@ and file_renamings = ~in_help:CLOpt.([(ReportDiff, manual_generic)]) "JSON with a list of file renamings to use while computing differential reports" + and filter_paths = CLOpt.mk_bool ~long:"filter-paths" ~default:true "Filters specified in .inferconfig" + and flavors = CLOpt.mk_bool ~deprecated:["-use-flavors"] ~long:"flavors" ~in_help:CLOpt.([(Capture, manual_buck_flavors)]) "Buck integration using Buck flavors (clang only), eg $(i,`infer --flavors -- buck build //foo:bar#infer`)" + and force_delete_results_dir = CLOpt.mk_bool ~long:"force-delete-results-dir" ~default:false ~in_help: @@ -1203,6 +1283,7 @@ and force_delete_results_dir = ; (Run, manual_generic) ])) "Do not refuse to delete the results directory if it doesn't look like an infer results directory." + and force_integration = CLOpt.mk_symbol_opt ~long:"force-integration" ~meta:"command" ~symbols:(List.Assoc.inverse build_system_exe_assoc) @@ -1212,32 +1293,38 @@ and force_integration = ( List.map build_system_exe_assoc ~f:(fun (_, s) -> Printf.sprintf "$(i,%s)" s) |> String.concat ~sep:", " )) + and from_json_report = CLOpt.mk_path_opt ~long:"from-json-report" ~in_help:CLOpt.([(Report, manual_generic)]) ~meta:"report.json" "Load analysis results from a report file (default is to load the results from the specs files generated by the analysis)." + and frontend_stats = CLOpt.mk_bool ~deprecated:["fs"] ~deprecated_no:["nfs"] ~long:"frontend-stats" "Output statistics about the capture phase to *.o.astlog (clang only)" + and gen_previous_build_command_script = CLOpt.mk_string_opt ~long:"gen-previous-build-command-script" ~in_help:CLOpt.([(Diff, manual_generic)]) ~meta:"shell" "Specify a script that outputs the build command to capture in the previous version of the project. The script should output the command on stdout. For example \"echo make\"." + and generated_classes = CLOpt.mk_path_opt ~long:"generated-classes" ~in_help:CLOpt.([(Capture, manual_java)]) "Specify where to load the generated class files" + and headers = CLOpt.mk_bool ~deprecated:["headers"; "hd"] ~deprecated_no:["no_headers"; "nhd"] ~long:"headers" ~in_help:CLOpt.([(Capture, manual_clang)]) "Analyze code in header files" + and help = let var = ref `None in CLOpt.mk_set var `Help ~long:"help" @@ -1248,6 +1335,7 @@ and help = (Printf.sprintf "Show this manual with all internal options in the %s section" manual_internal) ; var + and help_format = CLOpt.mk_symbol ~long:"help-format" ~symbols:[("auto", `Auto); ("groff", `Groff); ("pager", `Pager); ("plain", `Plain)] @@ -1255,36 +1343,44 @@ and help_format = ~in_help:(List.map CLOpt.all_commands ~f:(fun command -> (command, manual_generic))) "Show this help in the specified format. $(b,auto) sets the format to $(b,plain) if the environment variable $(b,TERM) is \"dumb\" or undefined, and to $(b,pager) otherwise." + and html = CLOpt.mk_bool ~long:"html" ~in_help:CLOpt.([(Explore, manual_generic)]) "Generate html report." + and icfg_dotty_outfile = CLOpt.mk_path_opt ~long:"icfg-dotty-outfile" ~meta:"path" "If set, specifies path where .dot file should be written, it overrides the path for all other options that would generate icfg file otherwise" + and ignore_trivial_traces = CLOpt.mk_bool ~long:"ignore-trivial-traces" ~default:true "Ignore traces whose length is at most 1" + and infer_cache = CLOpt.mk_path_opt ~deprecated:["infer_cache"; "-infer_cache"] ~long:"infer-cache" ~meta:"dir" "Select a directory to contain the infer cache (Buck and Java only)" + and iphoneos_target_sdk_version = CLOpt.mk_string_opt ~long:"iphoneos-target-sdk-version" ~in_help:CLOpt.([(Capture, manual_clang_linters)]) "Specify the target SDK version to use for iphoneos" + and iphoneos_target_sdk_version_path_regex = CLOpt.mk_string_list ~long:"iphoneos-target-sdk-version-path-regex" ~in_help:CLOpt.([(Capture, manual_clang_linters)]) "To pass a specific target SDK version to use for iphoneos in a particular path, with the format path:version (can be specified multiple times)" + and issues_csv = CLOpt.mk_path_opt ~deprecated:["bugs"] ~long:"issues-csv" ~in_help:CLOpt.([(Report, manual_generic)]) ~meta:"file" "Write a list of issues in CSV format to $(i,file)" + and issues_fields = CLOpt.mk_symbol_seq ~long:"issues-fields" ~in_help:CLOpt.([(Report, manual_generic)]) @@ -1296,30 +1392,36 @@ and issues_fields = ; `Issue_field_bug_trace ] ~symbols:issues_fields_symbols ~eq:PVariant.( = ) "Fields to emit with $(b,--issues-tests)" + and issues_tests = CLOpt.mk_path_opt ~long:"issues-tests" ~in_help:CLOpt.([(Report, manual_generic)]) ~meta:"file" "Write a list of issues in a format suitable for tests to $(i,file)" + and issues_txt = CLOpt.mk_path_opt ~deprecated:["bugs_txt"] ~long:"issues-txt" ~in_help:CLOpt.([(Report, manual_generic)]) ~meta:"file" "Write a list of issues in text format to $(i,file) (default: infer-out/bugs.txt)" + and iterations = CLOpt.mk_int ~deprecated:["iterations"] ~long:"iterations" ~default:1 ~meta:"int" "Specify the maximum number of operations for each function, expressed as a multiple of symbolic operations and a multiple of seconds of elapsed time" + and java_jar_compiler = CLOpt.mk_path_opt ~long:"java-jar-compiler" ~in_help:CLOpt.([(Capture, manual_java)]) ~meta:"path" "Specify the Java compiler jar used to generate the bytecode" + and jobs = CLOpt.mk_int ~deprecated:["-multicore"] ~long:"jobs" ~short:'j' ~default:ncpu ~in_help:CLOpt.([(Analyze, manual_generic)]) ~meta:"int" "Run the specified number of analysis jobs simultaneously" + and join_cond = CLOpt.mk_int ~deprecated:["join_cond"] ~long:"join-cond" ~default:1 ~meta:"int" {|Set the strength of the final information-loss check used by the join: @@ -1327,24 +1429,29 @@ and join_cond = - 1 = use the least aggressive join for preconditions |} + and latex = CLOpt.mk_path_opt ~deprecated:["latex"] ~long:"latex" ~meta:"file" "Write a latex report of the analysis results to a file" + and log_file = CLOpt.mk_string ~deprecated:["out_file"; "-out-file"] ~long:"log-file" ~meta:"file" ~default:"logs" "Specify the file to use for logging" + and linter = CLOpt.mk_string_opt ~long:"linter" ~in_help:CLOpt.([(Capture, manual_clang_linters)]) "From the linters available, only run this one linter. (Useful together with $(b,--linters-developer-mode))" + and linters_def_file = CLOpt.mk_path_list ~default:[] ~long:"linters-def-file" ~in_help:CLOpt.([(Capture, manual_clang_linters)]) ~meta:"file" "Specify the file containing linters definition (e.g. 'linters.al')" + and linters_def_folder = let linters_def_folder = CLOpt.mk_path_list ~default:[] ~long:"linters-def-folder" @@ -1357,33 +1464,39 @@ and linters_def_folder = in linters_def_folder + and linters_doc_url = CLOpt.mk_string_list ~long:"linters-doc-url" ~in_help:CLOpt.([(Capture, manual_clang_linters)]) "Specify custom documentation URL for some linter that overrides the default one. Useful if your project has specific ways of fixing a lint error that is not true in general or public info. Format: linter_name:doc_url." + and linters_ignore_clang_failures = CLOpt.mk_bool ~long:"linters-ignore-clang-failures" ~in_help:CLOpt.([(Capture, manual_clang_linters)]) ~default:false "Continue linting files even if some compilation fails." + and linters_validate_syntax_only = CLOpt.mk_bool ~long:"linters-validate-syntax-only" ~in_help:CLOpt.([(Capture, manual_clang_linters)]) ~default:false "Validate syntax of AL files, then emit possible errors in JSON format to stdout" + and load_average = CLOpt.mk_float_opt ~long:"load-average" ~short:'l' ~in_help:CLOpt.([(Capture, manual_generic)]) ~meta:"float" "Do not start new parallel jobs if the load average is greater than that specified (Buck and make only)" + and load_results = CLOpt.mk_path_opt ~deprecated:["load_results"] ~long:"load-results" ~in_help:CLOpt.([(Report, manual_generic)]) ~meta:"file.iar" "Load analysis results from Infer Analysis Results file file.iar" + (** name of the makefile to create with clusters and dependencies *) and makefile = CLOpt.mk_path ~deprecated:["makefile"] ~long:"makefile" ~default:"" ~meta:"file" "" @@ -1391,16 +1504,19 @@ and margin = CLOpt.mk_int ~deprecated:["set_pp_margin"] ~long:"margin" ~default:100 ~meta:"int" "Set right margin for the pretty printing functions" + and max_nesting = CLOpt.mk_int_opt ~long:"max-nesting" ~in_help:CLOpt.([(Explore, manual_generic)]) "Level of nested procedure calls to show. Trace elements beyond the maximum nesting level are skipped. If omitted, all levels are shown." + and merge = CLOpt.mk_bool ~deprecated:["merge"] ~long:"merge" ~in_help:CLOpt.([(Analyze, manual_buck_flavors)]) "Merge the captured results directories specified in the dependency file" + and ml_buckets = CLOpt.mk_symbol_seq ~deprecated:["ml_buckets"; "-ml_buckets"] ~long:"ml-buckets" ~default:[`MLeak_cf] @@ -1413,35 +1529,43 @@ and ml_buckets = |} ~symbols:ml_bucket_symbols ~eq:PVariant.( = ) + and modified_targets = CLOpt.mk_path_opt ~deprecated:["modified_targets"] ~long:"modified-targets" ~meta:"file" "Read the file of Buck targets modified since the last analysis" + and monitor_prop_size = CLOpt.mk_bool ~deprecated:["monitor_prop_size"] ~long:"monitor-prop-size" "Monitor size of props, and print every time the current max is exceeded" + and nelseg = CLOpt.mk_bool ~deprecated:["nelseg"] ~long:"nelseg" "Use only nonempty lsegs" and nullable_annotation = CLOpt.mk_string_opt ~long:"nullable-annotation-name" "Specify custom nullable annotation name" + (* TODO: document *) and objc_memory_model = CLOpt.mk_bool ~deprecated:["objcm"] ~long:"objc-memory-model" "Use ObjC memory model" + and only_footprint = CLOpt.mk_bool ~deprecated:["only_footprint"] ~long:"only-footprint" "Skip the re-execution phase" + and only_show = CLOpt.mk_bool ~long:"only-show" ~in_help:CLOpt.([(Explore, manual_generic)]) "Show the list of reports and exit" + and passthroughs = CLOpt.mk_bool ~long:"passthroughs" ~default:false "In error traces, show intermediate steps that propagate data. When false, error traces are shorter and show only direct flow via souces/sinks" + and patterns_modeled_expensive = let long = "modeled-expensive" in ( long @@ -1449,12 +1573,14 @@ and patterns_modeled_expensive = "Matcher or list of matchers for methods that should be considered expensive by the performance critical checker." ) + and patterns_never_returning_null = let long = "never-returning-null" in ( long , CLOpt.mk_json ~deprecated:["never_returning_null"] ~long "Matcher or list of matchers for functions that never return $(i,null)." ) + and patterns_skip_implementation = let long = "skip-implementation" in ( long @@ -1462,62 +1588,75 @@ and patterns_skip_implementation = "Matcher or list of matchers for names of files where we only want to translate the method declaration, skipping the body of the methods (Java only)." ) + and patterns_skip_translation = let long = "skip-translation" in ( long , CLOpt.mk_json ~deprecated:["skip_translation"] ~long "Matcher or list of matchers for names of files that should not be analyzed at all." ) + and per_procedure_parallelism = CLOpt.mk_bool ~long:"per-procedure-parallelism" ~default:true "Perform analysis with per-procedure parallelism. Java is not supported." + and pmd_xml = CLOpt.mk_bool ~long:"pmd-xml" ~in_help:CLOpt.([(Run, manual_generic)]) "Output issues in (PMD) XML format" + and precondition_stats = CLOpt.mk_bool ~deprecated:["precondition_stats"] ~long:"precondition-stats" "Print stats about preconditions to standard output" + and previous_to_current_script = CLOpt.mk_string_opt ~long:"previous-to-current-script" ~in_help:CLOpt.([(Diff, manual_generic)]) ~meta:"shell" "Specify a script to checkout the current version of the project. The project is supposed to already be at that current version when running $(b,infer diff); the script is used after having analyzed the current and previous versions of the project, to restore the project to the current version." + and print_active_checkers = CLOpt.mk_bool ~long:"print-active-checkers" ~in_help:CLOpt.([(Analyze, manual_generic)]) "Print the active checkers before starting the analysis" + and print_builtins = CLOpt.mk_bool ~deprecated:["print_builtins"] ~long:"print-builtins" "Print the builtin functions and exit" + and print_using_diff = CLOpt.mk_bool ~deprecated_no:["noprintdiff"] ~long:"print-using-diff" ~default:true "Highlight the difference w.r.t. the previous prop when printing symbolic execution debug info" + and procedures_per_process = CLOpt.mk_int ~long:"procedures-per-process" ~default:1000 ~meta:"int" "Specify the number of procedures to analyze per process when using $(b,--per-procedure-parallelism). If 0 is specified, each file is divided into $(b,--jobs) groups of procedures." + and procs_csv = CLOpt.mk_path_opt ~deprecated:["procs"] ~long:"procs-csv" ~meta:"file" "Write statistics for each procedure in CSV format to a file" + and procs_xml = CLOpt.mk_path_opt ~deprecated:["procs_xml"] ~long:"procs-xml" ~meta:"file" "Write statistics for each procedure in XML format to a file (as a path relative to $(b,--results-dir))" + and progress_bar = CLOpt.mk_bool ~deprecated:["pb"] ~deprecated_no:["no_progress_bar"; "npb"] ~short:'p' ~long:"progress-bar" ~default:true ~in_help:CLOpt.([(Run, manual_generic)]) "Show a progress bar" + and project_root = CLOpt.mk_path ~deprecated:["project_root"; "-project_root"; "pr"] ~long:"project-root" ~short:'C' ~default:CLOpt.init_work_dir @@ -1529,50 +1668,60 @@ and project_root = ; (Report, manual_generic) ])) ~meta:"dir" "Specify the root directory of the project" + and quandary_endpoints = CLOpt.mk_json ~long:"quandary-endpoints" ~in_help:CLOpt.([(Analyze, manual_quandary)]) "Specify endpoint classes for Quandary" + and quandary_sanitizers = CLOpt.mk_json ~long:"quandary-sanitizers" ~in_help:CLOpt.([(Analyze, manual_quandary)]) "Specify custom sanitizers for Quandary" + and quandary_sources = CLOpt.mk_json ~long:"quandary-sources" ~in_help:CLOpt.([(Analyze, manual_quandary)]) "Specify custom sources for Quandary" + and quandary_sinks = CLOpt.mk_json ~long:"quandary-sinks" ~in_help:CLOpt.([(Analyze, manual_quandary)]) "Specify custom sinks for Quandary" + and quiet = CLOpt.mk_bool ~long:"quiet" ~short:'q' ~default:false ~in_help:CLOpt.([(Analyze, manual_generic); (Report, manual_generic)]) "Do not print specs on standard output (default: only print for the $(b,report) command)" + and reactive = CLOpt.mk_bool ~deprecated:["reactive"] ~long:"reactive" ~short:'r' ~in_help:CLOpt.([(Analyze, manual_generic)]) "Reactive mode: the analysis starts from the files captured since the $(i,infer) command started" + and reactive_capture = CLOpt.mk_bool ~long:"reactive-capture" "Compile source files only when required by analyzer (clang only)" + and report = CLOpt.mk_bool ~long:"report" ~default:true ~in_help:CLOpt.([(Analyze, manual_generic); (Run, manual_generic)]) "Run the reporting phase once the analysis has completed" + and report_current = CLOpt.mk_path_opt ~long:"report-current" ~in_help:CLOpt.([(ReportDiff, manual_generic)]) "report of the latest revision" + and report_custom_error = CLOpt.mk_bool ~long:"report-custom-error" "" and report_formatter = @@ -1582,6 +1731,7 @@ and report_formatter = ~symbols:[("none", `No_formatter); ("phabricator", `Phabricator_formatter)] ~eq:PVariant.( = ) "Which formatter to use when emitting the report" + and report_hook = CLOpt.mk_string_opt ~long:"report-hook" ~in_help:CLOpt.([(Analyze, manual_generic); (Run, manual_generic)]) @@ -1589,17 +1739,20 @@ and report_hook = ~meta:"script" "Specify a script to be executed after the analysis results are written. This script will be passed $(b,--issues-csv), $(b,--issues-json), $(b,--issues-txt), $(b,--issues-xml), $(b,--project-root), and $(b,--results-dir)." + and report_previous = CLOpt.mk_path_opt ~long:"report-previous" ~in_help:CLOpt.([(ReportDiff, manual_generic)]) "Report of the base revision to use for comparison" + and rest = CLOpt.mk_rest_actions ~in_help:CLOpt.([(Capture, manual_generic); (Run, manual_generic)]) "Stop argument processing, use remaining arguments as a build command" ~usage:exe_usage (fun build_exe -> match Filename.basename build_exe with "java" | "javac" -> CLOpt.Javac | _ -> CLOpt.NoParse ) + and results_dir = CLOpt.mk_path ~deprecated:["results_dir"; "-out"] ~long:"results-dir" ~short:'o' ~default:(CLOpt.init_work_dir ^/ "infer-out") @@ -1612,51 +1765,61 @@ and results_dir = ; (Report, manual_generic) ])) ~meta:"dir" "Write results and internal files in the specified directory" + and save_results = CLOpt.mk_path_opt ~deprecated:["save_results"] ~long:"save-results" ~in_help:CLOpt.([(Report, manual_generic)]) ~meta:"file.iar" "Save analysis results to Infer Analysis Results file file.iar" + and seconds_per_iteration = CLOpt.mk_float_opt ~deprecated:["seconds_per_iteration"] ~long:"seconds-per-iteration" ~meta:"float" "Set the number of seconds per iteration (see $(b,--iterations))" + and select = CLOpt.mk_int_opt ~long:"select" ~meta:"N" ~in_help:CLOpt.([(Explore, manual_generic)]) "Select bug number $(i,N). If omitted, prompt for input." + and siof_safe_methods = CLOpt.mk_string_list ~long:"siof-safe-methods" ~in_help:CLOpt.([(Analyze, manual_siof)]) "Methods that are SIOF-safe; \"foo::bar\" will match \"foo::bar()\", \"foo::bar()\", etc. (can be specified multiple times)" + and skip_analysis_in_path = CLOpt.mk_string_list ~deprecated:["-skip-clang-analysis-in-path"] ~long:"skip-analysis-in-path" ~in_help:CLOpt.([(Capture, manual_generic); (Run, manual_generic)]) ~meta:"path_prefix_OCaml_regex" "Ignore files whose path matches the given prefix (can be specified multiple times)" + and skip_analysis_in_path_skips_compilation = CLOpt.mk_bool ~long:"skip-analysis-in-path-skips-compilation" ~in_help:CLOpt.([(Report, manual_generic)]) ~default:false "Whether paths in --skip-analysis-in-path should be compiled or not" + and skip_duplicated_types = CLOpt.mk_bool ~long:"skip-duplicated-types" ~default:true ~in_help:CLOpt.([(ReportDiff, manual_generic)]) "Skip fixed-then-introduced duplicated types while computing differential reports" + and skip_translation_headers = CLOpt.mk_string_list ~deprecated:["skip_translation_headers"] ~long:"skip-translation-headers" ~in_help:CLOpt.([(Capture, manual_clang)]) ~meta:"path_prefix" "Ignore headers whose path matches the given prefix" + and source_preview = CLOpt.mk_bool ~long:"source-preview" ~default:true ~in_help:CLOpt.([(Explore, manual_generic)]) "print code excerpts around trace elements" + and sources = CLOpt.mk_string_list ~long:"sources" "Specify the list of source files" and sourcepath = CLOpt.mk_string_opt ~long:"sourcepath" "Specify the sourcepath" @@ -1668,6 +1831,7 @@ and spec_abs_level = - 1 = filter out redundant posts implied by other posts |} + and specs_library = let specs_library = CLOpt.mk_path_list ~deprecated:["lib"] ~long:"specs-library" ~short:'L' ~meta:"dir|jar" @@ -1678,10 +1842,10 @@ and specs_library = absolute *) let read_specs_dir_list_file fname = match Utils.read_file (resolve fname) with - | Ok pathlist - -> pathlist - | Error error - -> L.(die UserError) "cannot read file '%s' from cwd '%s': %s" fname (Sys.getcwd ()) error + | Ok pathlist -> + pathlist + | Error error -> + L.(die UserError) "cannot read file '%s' from cwd '%s': %s" fname (Sys.getcwd ()) error in (* Add the newline-separated directories listed in to the list of directories to be searched for .spec files *) @@ -1695,77 +1859,93 @@ and specs_library = in specs_library + and stacktrace = CLOpt.mk_path_opt ~deprecated:["st"] ~long:"stacktrace" ~in_help:CLOpt.([(Analyze, manual_crashcontext)]) ~meta:"file" "File path containing a json-encoded Java crash stacktrace. Used to guide the analysis (only with '-a crashcontext'). See tests/codetoanalyze/java/crashcontext/*.json for examples of the expected format." + and stacktraces_dir = CLOpt.mk_path_opt ~long:"stacktraces-dir" ~in_help:CLOpt.([(Analyze, manual_crashcontext)]) ~meta:"dir" "Directory path containing multiple json-encoded Java crash stacktraces. Used to guide the analysis (only with '-a crashcontext'). See tests/codetoanalyze/java/crashcontext/*.json for examples of the expected format." + and stats_report = CLOpt.mk_path_opt ~long:"stats-report" ~meta:"file" "Write a report of the analysis results to a file" + and subtype_multirange = CLOpt.mk_bool ~deprecated:["subtype_multirange"] ~long:"subtype-multirange" ~default:true "Use the multirange subtyping domain" + and svg = CLOpt.mk_bool ~deprecated:["svg"] ~long:"svg" "Generate .dot and .svg files from specs" and symops_per_iteration = CLOpt.mk_int_opt ~deprecated:["symops_per_iteration"] ~long:"symops-per-iteration" ~meta:"int" "Set the number of symbolic operations per iteration (see $(b,--iterations))" + and test_filtering = CLOpt.mk_bool ~deprecated:["test_filtering"] ~long:"test-filtering" "List all the files Infer can report on (should be called from the root of the project)" + and testing_mode = CLOpt.mk_bool ~deprecated:["testing_mode"; "-testing_mode"; "tm"] ~deprecated_no:["ntm"] ~long:"testing-mode" "Mode for testing, where no headers are translated, and dot files are created (clang only)" + and threadsafe_aliases = CLOpt.mk_json ~long:"threadsafe-aliases" ~in_help:CLOpt.([(Analyze, manual_racerd)]) "Specify custom annotations that should be considered aliases of @ThreadSafe" + and trace_join = CLOpt.mk_bool ~deprecated:["trace_join"] ~long:"trace-join" "Detailed tracing information during prop join operations" + and trace_ondemand = CLOpt.mk_bool ~long:"trace-ondemand" "" and trace_rearrange = CLOpt.mk_bool ~deprecated:["trace_rearrange"] ~long:"trace-rearrange" "Detailed tracing information during prop re-arrangement operations" + and tracing = CLOpt.mk_bool ~deprecated:["tracing"] ~long:"tracing" "Report error traces for runtime exceptions (Java only): generate preconditions for runtimeexceptions in Java and report errors for public methods which throw runtime exceptions" + and tv_limit = CLOpt.mk_int ~long:"tv-limit" ~default:100 ~meta:"int" "The maximum number of traces to submit to Traceview" + and type_size = CLOpt.mk_bool ~deprecated:["type_size"] ~long:"type-size" "Consider the size of types during analysis, e.g. cannot use an int pointer to write to a char" + and unsafe_malloc = CLOpt.mk_bool ~long:"unsafe-malloc" ~in_help:CLOpt.([(Analyze, manual_clang)]) "Assume that malloc(3) never returns null." + (** Set the path to the javac verbose output *) and verbose_out = CLOpt.mk_path ~deprecated:["verbose_out"] ~long:"verbose-out" ~default:"" ~meta:"file" "" + and version = let var = ref `None in CLOpt.mk_set var `Full ~deprecated:["version"] ~long:"version" @@ -1777,9 +1957,11 @@ and version = CLOpt.mk_set var `Vcs ~long:"version-vcs" "Print version control system commit and exit" ; var + and whole_seconds = CLOpt.mk_bool ~deprecated:["whole_seconds"] ~long:"whole-seconds" "Print whole seconds only" + (** visit mode for the worklist: 0 depth - fist visit 1 bias towards exit node @@ -1793,20 +1975,24 @@ and worklist_mode = "nodes visited fewer times are analyzed first" ; var + and xcode_developer_dir = CLOpt.mk_path_opt ~long:"xcode-developer-dir" ~in_help:CLOpt.([(Capture, manual_buck_flavors)]) ~meta:"XCODE_DEVELOPER_DIR" "Specify the path to Xcode developer directory" + and xcpretty = CLOpt.mk_bool ~long:"xcpretty" ~default:true ~in_help:CLOpt.([(Capture, manual_clang)]) "Infer will use xcpretty together with xcodebuild to analyze an iOS app. xcpretty just needs to be in the path, infer command is still just $(i,`infer -- `). (Recommended)" + and xml_specs = CLOpt.mk_bool ~deprecated:["xml"] ~long:"xml-specs" "Export specs into XML files file1.xml ... filen.xml" + (* The "rest" args must appear after "--" on the command line, and hence after other args, so they are allowed to refer to the other arg variables. *) @@ -1821,6 +2007,7 @@ let javac_classes_out = classes_out) "" + and _ = CLOpt.mk_string_opt ~parse_mode:CLOpt.Javac ~deprecated:["classpath"; "cp"] ~long:"" ~f:(fun classpath -> @@ -1832,6 +2019,7 @@ and _ = classpath) "" + and () = CLOpt.mk_set ~parse_mode:CLOpt.Javac version ~deprecated:["version"] ~long:"" `Javac "" (** Parse Command Line Args *) @@ -1839,32 +2027,33 @@ and () = CLOpt.mk_set ~parse_mode:CLOpt.Javac version ~deprecated:["version"] ~l let inferconfig_file = let rec find dir = match Sys.file_exists ~follow_symlinks:false (dir ^/ CommandDoc.inferconfig_file) with - | `Yes - -> Some dir - | `No | `Unknown - -> let parent = Filename.dirname dir in + | `Yes -> + Some dir + | `No | `Unknown -> + let parent = Filename.dirname dir in let is_root = String.equal dir parent in if is_root then None else find parent in match Sys.getenv CommandDoc.inferconfig_env_var with - | Some env_path - -> (* make sure the path makes sense in children infer processes *) + | Some env_path -> + (* make sure the path makes sense in children infer processes *) Some ( if Filename.is_relative env_path then Utils.filename_to_absolute ~root:CLOpt.init_work_dir env_path else env_path ) - | None - -> find (Sys.getcwd ()) |> Option.map ~f:(fun dir -> dir ^/ CommandDoc.inferconfig_file) + | None -> + find (Sys.getcwd ()) |> Option.map ~f:(fun dir -> dir ^/ CommandDoc.inferconfig_file) + let post_parsing_initialization command_opt = if CommandLineOption.is_originator then Unix.putenv ~key:infer_top_results_dir_env_var ~data:!results_dir ; ( match !version with - | `Full when !buck - -> (* Buck reads stderr in some versions, stdout in others *) + | `Full when !buck -> + (* Buck reads stderr in some versions, stdout in others *) print_endline version_string ; prerr_endline version_string - | `Javac when !buck - -> (* print buck key *) + | `Javac when !buck -> + (* print buck key *) let javac_version = let javac_args = if infer_is_javac then @@ -1884,31 +2073,31 @@ let post_parsing_initialization command_opt = in let infer_version = match inferconfig_file with - | Some inferconfig - -> Printf.sprintf "version %s/inferconfig %s" Version.commit + | Some inferconfig -> + Printf.sprintf "version %s/inferconfig %s" Version.commit (Digest.to_hex (Digest.file inferconfig)) - | None - -> Version.commit + | None -> + Version.commit in F.printf "%s/%s/%s@." javac_version analyzer_name infer_version ; F.eprintf "%s/%s/%s@." javac_version analyzer_name infer_version - | `Full - -> print_endline version_string - | `Javac - -> (* javac prints version on stderr *) prerr_endline version_string - | `Json - -> print_endline Version.versionJson - | `Vcs - -> print_endline Version.commit - | `None - -> () ) ; + | `Full -> + print_endline version_string + | `Javac -> + (* javac prints version on stderr *) prerr_endline version_string + | `Json -> + print_endline Version.versionJson + | `Vcs -> + print_endline Version.commit + | `None -> + () ) ; ( match !help with - | `Help - -> CLOpt.show_manual !help_format CommandDoc.infer command_opt - | `HelpFull - -> CLOpt.show_manual ~internal_section:manual_internal !help_format CommandDoc.infer command_opt - | `None - -> () ) ; + | `Help -> + CLOpt.show_manual !help_format CommandDoc.infer command_opt + | `HelpFull -> + CLOpt.show_manual ~internal_section:manual_internal !help_format CommandDoc.infer command_opt + | `None -> + () ) ; if !version <> `None || !help <> `None then Pervasives.exit 0 ; let uncaught_exception_handler exn raw_backtrace = let should_print_backtrace_default = @@ -1923,18 +2112,18 @@ let post_parsing_initialization command_opt = Out_channel.newline stderr in match exn with - | Failure msg - -> error "ERROR: " msg - | L.InferExternalError msg - -> error "External Error: " msg - | L.InferInternalError msg - -> error "Internal Error: " msg - | L.InferUserError msg - -> error "Usage Error: " msg - | L.InferExit _ - -> () - | _ - -> error "Uncaught error: " (Exn.to_string exn) + | Failure msg -> + error "ERROR: " msg + | L.InferExternalError msg -> + error "External Error: " msg + | L.InferInternalError msg -> + error "Internal Error: " msg + | L.InferUserError msg -> + error "Usage Error: " msg + | L.InferExit _ -> + () + | _ -> + error "Uncaught error: " (Exn.to_string exn) in if should_print_backtrace_default || !developer_mode then ( Out_channel.newline stderr ; @@ -1976,24 +2165,25 @@ let post_parsing_initialization command_opt = if !default_linters then linters_def_file := linters_def_default_file :: !linters_def_file ; ( if Option.is_none !analyzer then match (command_opt : CLOpt.command option) with - | Some Compile - -> analyzer := Some CompileOnly - | Some Capture - -> analyzer := Some CaptureOnly - | _ - -> () ) ; + | Some Compile -> + analyzer := Some CompileOnly + | Some Capture -> + analyzer := Some CaptureOnly + | _ -> + () ) ; ( match !analyzer with - | Some BiAbduction - -> disable_all_checkers () ; + | Some BiAbduction -> + disable_all_checkers () ; (* technically the biabduction checker doesn't run in this mode, but this gives an easy way to test if the biabduction *analysis* is active *) biabduction := true - | Some Crashcontext - -> disable_all_checkers () ; + | Some Crashcontext -> + disable_all_checkers () ; crashcontext := true - | Some (CaptureOnly | Checkers | CompileOnly | Linters) | None - -> () ) ; + | Some (CaptureOnly | Checkers | CompileOnly | Linters) | None -> + () ) ; Option.value ~default:CLOpt.Run command_opt + let command, parse_args_and_return_usage_exit = let command_opt, usage_exit = CLOpt.parse ?config_file:inferconfig_file ~usage:exe_usage startup_action initial_command @@ -2001,6 +2191,7 @@ let command, parse_args_and_return_usage_exit = let command = post_parsing_initialization command_opt in (command, usage_exit) + let print_usage_exit () = parse_args_and_return_usage_exit 1 type iphoneos_target_sdk_version_path_regex = {path: Str.regexp; version: string} @@ -2008,29 +2199,31 @@ type iphoneos_target_sdk_version_path_regex = {path: Str.regexp; version: string let process_iphoneos_target_sdk_version_path_regex args = let process_iphoneos_target_sdk_version_path_regex arg : iphoneos_target_sdk_version_path_regex = match String.rsplit2 ~on:':' arg with - | Some (path, version) - -> {path= Str.regexp path; version} - | None - -> L.(die UserError) + | Some (path, version) -> + {path= Str.regexp path; version} + | None -> + L.(die UserError) "Incorrect format for the option iphoneos-target-sdk_version-path-regex. The correct format is path:version but got %s" arg in List.map ~f:process_iphoneos_target_sdk_version_path_regex args + type linter_doc_url = {linter: string; doc_url: string} let process_linters_doc_url args = let linters_doc_url arg = match String.lsplit2 ~on:':' arg with - | Some (linter, doc_url) - -> {linter; doc_url} - | None - -> L.(die UserError) + | Some (linter, doc_url) -> + {linter; doc_url} + | None -> + L.(die UserError) "Incorrect format for the option linters-doc-url. The correct format is linter:doc_url but got %s" arg in List.map ~f:linters_doc_url args + (** Freeze initialized configuration values *) let anon_args = !anon_args @@ -2046,15 +2239,19 @@ and allow_specs_cleanup = !allow_specs_cleanup and analysis_path_regex_whitelist_options = List.map ~f:(fun (a, b) -> (a, !b)) analysis_path_regex_whitelist_options + and analysis_path_regex_blacklist_options = List.map ~f:(fun (a, b) -> (a, !b)) analysis_path_regex_blacklist_options + and analysis_blacklist_files_containing_options = List.map ~f:(fun (a, b) -> (a, !b)) analysis_blacklist_files_containing_options + and analysis_suppress_errors_options = List.map ~f:(fun (a, b) -> (a, !b)) analysis_suppress_errors_options + and analysis_stops = !analysis_stops and annotation_reachability = !annotation_reachability @@ -2083,12 +2280,13 @@ and buck_cache_mode = !buck && not !debug and buck_compilation_database = match !buck_compilation_database with - | Some `DepsTmp - -> Some (Deps !buck_compilation_database_depth) - | Some `NoDeps - -> Some NoDeps - | None - -> None + | Some `DepsTmp -> + Some (Deps !buck_compilation_database_depth) + | Some `NoDeps -> + Some NoDeps + | None -> + None + and buck_out = !buck_out @@ -2213,6 +2411,7 @@ and iphoneos_target_sdk_version = !iphoneos_target_sdk_version and iphoneos_target_sdk_version_path_regex = process_iphoneos_target_sdk_version_path_regex !iphoneos_target_sdk_version_path_regex + and issues_csv = !issues_csv and issues_fields = !issues_fields @@ -2254,6 +2453,7 @@ and liveness = !liveness and load_average = match !load_average with None when !buck -> Some (float_of_int ncpu) | _ -> !load_average + and load_analysis_results = !load_results and log_file = !log_file @@ -2290,21 +2490,13 @@ and only_show = !only_show and passthroughs = !passthroughs -and patterns_modeled_expensive = - match patterns_modeled_expensive - with k, r -> (k, !r) +and patterns_modeled_expensive = match patterns_modeled_expensive with k, r -> (k, !r) -and patterns_never_returning_null = - match patterns_never_returning_null - with k, r -> (k, !r) +and patterns_never_returning_null = match patterns_never_returning_null with k, r -> (k, !r) -and patterns_skip_implementation = - match patterns_skip_implementation - with k, r -> (k, !r) +and patterns_skip_implementation = match patterns_skip_implementation with k, r -> (k, !r) -and patterns_skip_translation = - match patterns_skip_translation - with k, r -> (k, !r) +and patterns_skip_translation = match patterns_skip_translation with k, r -> (k, !r) and per_procedure_parallelism = !per_procedure_parallelism @@ -2463,33 +2655,38 @@ and xml_specs = !xml_specs let analysis_path_regex_whitelist analyzer = List.Assoc.find_exn ~equal:equal_analyzer analysis_path_regex_whitelist_options analyzer + and analysis_path_regex_blacklist analyzer = List.Assoc.find_exn ~equal:equal_analyzer analysis_path_regex_blacklist_options analyzer + and analysis_blacklist_files_containing analyzer = List.Assoc.find_exn ~equal:equal_analyzer analysis_blacklist_files_containing_options analyzer + and analysis_suppress_errors analyzer = List.Assoc.find_exn ~equal:equal_analyzer analysis_suppress_errors_options analyzer + let captured_dir = results_dir ^/ captured_dir_name let clang_frontend_do_capture, clang_frontend_do_lint = match !clang_frontend_action with - | Some `Lint - -> (false, true) (* no capture, lint *) - | Some `Capture - -> (true, false) (* capture, no lint *) - | Some `Lint_and_capture - -> (true, true) (* capture, lint *) + | Some `Lint -> + (false, true) (* no capture, lint *) + | Some `Capture -> + (true, false) (* capture, no lint *) + | Some `Lint_and_capture -> + (true, true) (* capture, lint *) | None -> match !analyzer with - | Some Linters - -> (false, true) (* no capture, lint *) - | Some BiAbduction | Some Checkers - -> (true, false) (* capture, no lint *) - | _ - -> (* capture, lint *) (true, true) + | Some Linters -> + (false, true) (* no capture, lint *) + | Some BiAbduction | Some Checkers -> + (true, false) (* capture, no lint *) + | _ -> + (* capture, lint *) (true, true) + let analyzer = match !analyzer with Some a -> a | None -> Checkers @@ -2498,47 +2695,51 @@ let clang_frontend_action_string = ( (if clang_frontend_do_capture then ["translating"] else []) @ if clang_frontend_do_lint then ["linting"] else [] ) + let dynamic_dispatch = let default_mode = match analyzer with - | BiAbduction - -> Lazy - | Checkers when biabduction - -> Lazy - | Checkers when quandary - -> Sound - | _ - -> NoDynamicDispatch + | BiAbduction -> + Lazy + | Checkers when biabduction -> + Lazy + | Checkers when quandary -> + Sound + | _ -> + NoDynamicDispatch in Option.value ~default:default_mode !dynamic_dispatch + let specs_library = match infer_cache with - | Some cache_dir when use_jar_cache - -> let add_spec_lib specs_library filename = + | Some cache_dir when use_jar_cache -> + let add_spec_lib specs_library filename = let basename = Filename.basename filename in let key = basename ^ Utils.string_crc_hex32 filename in let key_dir = cache_dir ^/ key in let extract_specs dest_dir filename = if Filename.check_suffix filename ".jar" then match Unix.mkdir dest_dir ~perm:0o700 with - | exception Unix.Unix_error _ - -> () - | () - -> let zip_channel = Zip.open_in filename in + | exception Unix.Unix_error _ -> + () + | () -> + let zip_channel = Zip.open_in filename in let entries = Zip.entries zip_channel in let extract_entry (entry: Zip.entry) = let dest_file = dest_dir ^/ Filename.basename entry.filename in if Filename.check_suffix entry.filename specs_files_suffix then Zip.copy_entry_to_file zip_channel entry dest_file in - List.iter ~f:extract_entry entries ; Zip.close_in zip_channel + List.iter ~f:extract_entry entries ; + Zip.close_in zip_channel in extract_specs key_dir filename ; key_dir :: specs_library in List.fold ~f:add_spec_lib ~init:[] !specs_library - | _ - -> !specs_library + | _ -> + !specs_library + (** Global variables *) @@ -2551,6 +2752,7 @@ let set_reference_and_call_function reference value f x = f x) ~finally:restore + (** Current Objective-C Automatic Reference Counting (ARC) mode *) let arc_mode = ref false diff --git a/infer/src/base/DB.ml b/infer/src/base/DB.ml index a191301fc..2f36c098e 100644 --- a/infer/src/base/DB.ml +++ b/infer/src/base/DB.ml @@ -30,6 +30,7 @@ let append_crc_cutoff ?(key= "") ?(crc_only= false) name = in if crc_only then crc_str else Printf.sprintf "%s%c%s" name_up_to_cutoff crc_token crc_str + (* Lengh of .crc part: 32 characters of digest, plus 1 character of crc_token *) let dot_crc_len = 1 + 32 @@ -38,10 +39,11 @@ let strip_crc str = String.slice str 0 (-dot_crc_len) let string_crc_has_extension ~ext name_crc = let name = strip_crc name_crc in match Filename.split_extension name with - | _, Some ext' - -> String.equal ext ext' - | _, None - -> false + | _, Some ext' -> + String.equal ext ext' + | _, None -> + false + let curr_source_file_encoding = `Enc_crc @@ -49,15 +51,16 @@ let curr_source_file_encoding = `Enc_crc let source_file_encoding source_file = let source_file_s = SourceFile.to_string source_file in match curr_source_file_encoding with - | `Enc_base - -> Filename.basename source_file_s - | `Enc_path_with_underscores - -> Escape.escape_path source_file_s - | `Enc_crc - -> let base = Filename.basename source_file_s in + | `Enc_base -> + Filename.basename source_file_s + | `Enc_path_with_underscores -> + Escape.escape_path source_file_s + | `Enc_crc -> + let base = Filename.basename source_file_s in let dir = Filename.dirname source_file_s in append_crc_cutoff ~key:dir base + (** {2 Source Dirs} *) (** source directory: the directory inside the results dir corresponding to a source file *) @@ -74,10 +77,12 @@ let source_dir_get_internal_file source_dir extension = let fname = source_dir_name ^ extension in Filename.concat source_dir fname + (** get the source directory corresponding to a source file *) let source_dir_from_source_file source_file = Filename.concat Config.captured_dir (source_file_encoding source_file) + (** Find the source directories in the results dir *) let find_source_dirs () = let source_dirs = ref [] in @@ -97,6 +102,7 @@ let find_source_dirs () = files_in_results_dir ; List.rev !source_dirs + (** {2 Filename} *) type filename = string [@@deriving compare] @@ -132,10 +138,12 @@ let file_modified_time ?(symlink= false) fname = stat.Unix.st_mtime with Unix.Unix_error _ -> L.(die InternalError) "File %s does not exist." fname + let filename_create_dir fname = let dirname = Filename.dirname fname in if Sys.file_exists dirname <> `Yes then Utils.create_dir dirname + let read_whole_file fd = In_channel.input_all (Unix.in_channel_of_descr fd) (** Update the file contents with the update function provided. @@ -158,11 +166,13 @@ let update_file_with_lock dir fname update = let str = update buf in let i = Unix.write fd ~buf:str ~pos:0 ~len:(String.length str) in if Int.equal i (String.length str) then ( - Unix.lockf fd ~mode:Unix.F_ULOCK ~len:0L ; Unix.close fd ) + Unix.lockf fd ~mode:Unix.F_ULOCK ~len:0L ; + Unix.close fd ) else ( L.internal_error "@\nsave_with_lock: fail on path: %s@." path ; assert false ) + (** Read a file using a lock to allow write attempts in parallel. *) let read_file_with_lock dir fname = let path = Filename.concat dir fname in @@ -171,10 +181,13 @@ let read_file_with_lock dir fname = try Unix.lockf fd ~mode:Unix.F_RLOCK ~len:0L ; let buf = read_whole_file fd in - Unix.lockf fd ~mode:Unix.F_ULOCK ~len:0L ; Unix.close fd ; Some buf + Unix.lockf fd ~mode:Unix.F_ULOCK ~len:0L ; + Unix.close fd ; + Some buf with Unix.Unix_error _ -> L.(die ExternalError) "read_file_with_lock: Unix error" with Unix.Unix_error _ -> None + (** {2 Results Directory} *) module Results_dir = struct @@ -190,28 +203,30 @@ module Results_dir = struct let filename_from_base base path = let rec f = function - | [] - -> base - | name :: names - -> Filename.concat (f names) + | [] -> + base + | name :: names -> + Filename.concat (f names) (if String.equal name ".." then Filename.parent_dir_name else name) in f (List.rev path) + (** convert a path to a filename *) let path_to_filename pk path = let base = match pk with - | Abs_root - -> Config.results_dir - | Abs_source_dir source - -> let dir = source_dir_from_source_file source in + | Abs_root -> + Config.results_dir + | Abs_source_dir source -> + let dir = source_dir_from_source_file source in source_dir_to_string dir - | Rel - -> Filename.current_dir_name + | Rel -> + Filename.current_dir_name in filename_from_base base path + (** directory of spec files *) let specs_dir = path_to_filename Abs_root [Config.specs_dir_name] @@ -223,44 +238,49 @@ module Results_dir = struct Utils.create_dir (path_to_filename Abs_root [Config.captured_dir_name]) ; Utils.create_dir (path_to_filename (Abs_source_dir source) []) + let clean_specs_dir () = Utils.create_dir specs_dir ; (* create dir just in case it doesn't exist to avoid errors *) let files_to_remove = Array.map ~f:(Filename.concat specs_dir) (Sys.readdir specs_dir) in Array.iter ~f:Sys.remove files_to_remove + (** create a file at the given path, creating any missing directories *) let create_file pk path = let rec create = function - | [] - -> let fname = path_to_filename pk [] in + | [] -> + let fname = path_to_filename pk [] in Utils.create_dir fname ; fname - | name :: names - -> let new_path = Filename.concat (create names) name in + | name :: names -> + let new_path = Filename.concat (create names) name in Utils.create_dir new_path ; new_path in let filename, dir_path = match List.rev path with - | filename :: dir_path - -> (filename, dir_path) - | [] - -> L.(die InternalError) "create_path" + | filename :: dir_path -> + (filename, dir_path) + | [] -> + L.(die InternalError) "create_path" in let full_fname = Filename.concat (create dir_path) filename in Unix.openfile full_fname ~mode:Unix.([O_WRONLY; O_CREAT; O_TRUNC]) ~perm:0o777 + end let global_tenv_fname = let basename = Config.global_tenv_filename in filename_concat Config.captured_dir basename + let is_source_file path = List.exists ~f:(fun ext -> Filename.check_suffix path ext) Config.source_file_extentions + let infer_start_time = - ( lazy - (file_modified_time (Results_dir.path_to_filename Results_dir.Abs_root [Config.start_filename])) - ) + lazy + (file_modified_time (Results_dir.path_to_filename Results_dir.Abs_root [Config.start_filename])) + (** Return whether filename was updated after analysis started. File doesn't have to exist *) let file_was_updated_after_start fname = @@ -270,12 +290,14 @@ let file_was_updated_after_start fname = else (* since file doesn't exist, it wasn't modified *) false + (** Mark a file as updated by changing its timestamps to be one second in the future. This guarantees that it appears updated after start. *) let mark_file_updated fname = let near_future = Unix.gettimeofday () +. 1. in Unix.utimes fname ~access:near_future ~modif:near_future + (** Fold over all file paths recursively under [dir] which match [p]. *) let fold_paths_matching ~dir ~p ~init ~f = let rec paths path_list dir = @@ -287,6 +309,7 @@ let fold_paths_matching ~dir ~p ~init ~f = in paths init dir + (** Return all absolute paths recursively under root_dir, matching the given matcher function p *) let paths_matching dir p = fold_paths_matching ~dir ~p ~init:[] ~f:(fun x xs -> x :: xs) diff --git a/infer/src/base/Die.ml b/infer/src/base/Die.ml index 8c65f0c28..54aec3beb 100644 --- a/infer/src/base/Die.ml +++ b/infer/src/base/Die.ml @@ -21,25 +21,27 @@ exception InferExit of int let raise_error error ~msg = match error with - | ExternalError - -> raise (InferExternalError msg) - | InternalError - -> raise (InferInternalError msg) - | UserError - -> raise (InferUserError msg) + | ExternalError -> + raise (InferExternalError msg) + | InternalError -> + raise (InferInternalError msg) + | UserError -> + raise (InferUserError msg) + let die error fmt = F.kasprintf (fun msg -> raise_error error ~msg) fmt let exit exitcode = raise (InferExit exitcode) let exit_code_of_exception = function - | InferUserError _ - -> 1 - | InferExternalError _ - -> 3 - | InferInternalError _ - -> 4 - | InferExit exitcode - -> exitcode - | _ - -> (* exit code 2 is used by the OCaml runtime in cases of uncaught exceptions *) 2 + | InferUserError _ -> + 1 + | InferExternalError _ -> + 3 + | InferInternalError _ -> + 4 + | InferExit exitcode -> + exitcode + | _ -> + (* exit code 2 is used by the OCaml runtime in cases of uncaught exceptions *) 2 + diff --git a/infer/src/base/Die.mli b/infer/src/base/Die.mli index a1b445c36..502345dce 100644 --- a/infer/src/base/Die.mli +++ b/infer/src/base/Die.mli @@ -17,9 +17,8 @@ exception InferInternalError of string exception InferUserError of string -exception - InferExit of - int(** This can be used to avoid scattering exit invocations all over the codebase *) +exception InferExit of int + (** This can be used to avoid scattering exit invocations all over the codebase *) (** kind of error for [die], with similar semantics as [Logging.{external,internal,user}_error] *) type error = ExternalError | InternalError | UserError diff --git a/infer/src/base/Epilogues.ml b/infer/src/base/Epilogues.ml index f01ac2905..ea1b8d73f 100644 --- a/infer/src/base/Epilogues.ml +++ b/infer/src/base/Epilogues.ml @@ -12,14 +12,16 @@ module F = Format (* Run the epilogues when we get SIGINT (Control-C). We do not want to mask SIGINT unless at least one epilogue has been registered, so make this value lazy. *) let activate_run_epilogues_on_signal = - ( lazy - (let run_epilogues_on_signal s = - F.eprintf "*** %s: Caught %s, time to die@." (Filename.basename Sys.executable_name) - (Signal.to_string s) ; - (* Epilogues are registered with [at_exit] so exiting will make them run. *) - Pervasives.exit 0 - in - Signal.Expert.handle Signal.int run_epilogues_on_signal) ) + lazy + (let run_epilogues_on_signal s = + F.eprintf "*** %s: Caught %s, time to die@." + (Filename.basename Sys.executable_name) + (Signal.to_string s) ; + (* Epilogues are registered with [at_exit] so exiting will make them run. *) + Pervasives.exit 0 + in + Signal.Expert.handle Signal.int run_epilogues_on_signal) + let register ~f desc = let f_no_exn () = @@ -33,3 +35,4 @@ let register ~f desc = Pervasives.at_exit f_no_exn ; (* Register signal masking. *) Lazy.force activate_run_epilogues_on_signal + diff --git a/infer/src/base/Escape.ml b/infer/src/base/Escape.ml index 6b56169fd..4725bdc06 100644 --- a/infer/src/base/Escape.ml +++ b/infer/src/base/Escape.ml @@ -26,99 +26,106 @@ let escape_map map_fun s = else (* not escaping anything, so don't waste memory on a copy of the string *) s + let escape_csv s = let map = function - | '"' - -> Some "\"\"" - | c when Char.to_int c > 127 - -> Some "?" (* non-ascii character: escape *) - | _ - -> None + | '"' -> + Some "\"\"" + | c when Char.to_int c > 127 -> + Some "?" (* non-ascii character: escape *) + | _ -> + None in escape_map map s + let escape_xml s = let map = function - | '"' - -> (* on next line to avoid bad indentation *) + | '"' -> + (* on next line to avoid bad indentation *) Some """ - | '>' - -> Some ">" - | '<' - -> Some "<" - | '&' - -> Some "&" - | '%' - -> Some "%" - | c when Char.to_int c > 127 - -> (* non-ascii character: escape *) + | '>' -> + Some ">" + | '<' -> + Some "<" + | '&' -> + Some "&" + | '%' -> + Some "%" + | c when Char.to_int c > 127 -> + (* non-ascii character: escape *) Some ("&#" ^ string_of_int (Char.to_int c) ^ ";") - | _ - -> None + | _ -> + None in escape_map map s + let escape_url s = let map = function - | '!' - -> Some "%21" - | '#' - -> Some "%23" - | '$' - -> Some "%24" - | '&' - -> Some "%26" - | '\'' - -> Some "%27" - | '(' - -> Some "%28" - | ')' - -> Some "%29" - | '*' - -> Some "%2A" - | '+' - -> Some "%2B" - | ',' - -> Some "%2C" - | '/' - -> Some "%2F" - | ':' - -> Some "%3A" - | ';' - -> Some "%3B" - | '=' - -> Some "%3D" - | '?' - -> Some "%3F" - | '@' - -> Some "%40" - | '[' - -> Some "%5B" - | ']' - -> Some "%5D" - | _ - -> None + | '!' -> + Some "%21" + | '#' -> + Some "%23" + | '$' -> + Some "%24" + | '&' -> + Some "%26" + | '\'' -> + Some "%27" + | '(' -> + Some "%28" + | ')' -> + Some "%29" + | '*' -> + Some "%2A" + | '+' -> + Some "%2B" + | ',' -> + Some "%2C" + | '/' -> + Some "%2F" + | ':' -> + Some "%3A" + | ';' -> + Some "%3B" + | '=' -> + Some "%3D" + | '?' -> + Some "%3F" + | '@' -> + Some "%40" + | '[' -> + Some "%5B" + | ']' -> + Some "%5D" + | _ -> + None in escape_map map s + let escape_dotty s = let map = function '"' -> Some "\\\"" | '\\' -> Some "\\\\" | _ -> None in escape_map map s + let escape_path s = let map = function - | c - -> if String.equal (Char.escaped c) Filename.dir_sep then Some "_" else None + | c -> + if String.equal (Char.escaped c) Filename.dir_sep then Some "_" else None in escape_map map s + (* Python 2 sucks at utf8 so do not write unicode file names to disk as Python may need to see them *) let escape_filename s = let map = function - | c when Char.to_int c > 127 - -> Some "?" (* non-ascii character: escape *) - | _ - -> None + | c when Char.to_int c > 127 -> + Some "?" (* non-ascii character: escape *) + | _ -> + None in escape_map map s + diff --git a/infer/src/base/IssueType.ml b/infer/src/base/IssueType.ml index 6805f291e..51c04abb3 100644 --- a/infer/src/base/IssueType.ml +++ b/infer/src/base/IssueType.ml @@ -41,6 +41,7 @@ end = struct String.lowercase s |> String.split ~on:'_' |> List.map ~f:String.capitalize |> String.concat ~sep:" " |> String.strip + let set_enabled issue b = issue.enabled <- b (** avoid creating new issue types. The idea is that there are three types of issue types: @@ -66,6 +67,7 @@ end = struct all_issues := IssueSet.add issue !all_issues ; issue + let all_issues () = IssueSet.elements !all_issues end @@ -151,55 +153,71 @@ let empty_vector_access = from_string "EMPTY_VECTOR_ACCESS" let eradicate_condition_redundant = from_string "ERADICATE_CONDITION_REDUNDANT" ~hum:"Condition Redundant" + let eradicate_condition_redundant_nonnull = from_string "ERADICATE_CONDITION_REDUNDANT_NONNULL" ~hum:"Condition Redundant Non-Null" + let eradicate_field_not_initialized = from_string "ERADICATE_FIELD_NOT_INITIALIZED" ~hum:"Field Not Initialized" + let eradicate_field_not_mutable = from_string "ERADICATE_FIELD_NOT_MUTABLE" ~hum:"Field Not Mutable" + let eradicate_field_not_nullable = from_string "ERADICATE_FIELD_NOT_NULLABLE" ~hum:"Field Not Nullable" + let eradicate_field_over_annotated = from_string "ERADICATE_FIELD_OVER_ANNOTATED" ~hum:"Field Over Annotated" + let eradicate_field_value_absent = from_string "ERADICATE_FIELD_VALUE_ABSENT" ~hum:"Field Value Absent" + let eradicate_inconsistent_subclass_parameter_annotation = from_string "ERADICATE_INCONSISTENT_SUBCLASS_PARAMETER_ANNOTATION" ~hum:"Inconsistent Subclass Parameter Annotation" + let eradicate_inconsistent_subclass_return_annotation = from_string "ERADICATE_INCONSISTENT_SUBCLASS_RETURN_ANNOTATION" ~hum:"Inconsistent Subclass Return Annotation" + let eradicate_null_field_access = from_string "ERADICATE_NULL_FIELD_ACCESS" ~hum:"Null Field Access" + let eradicate_null_method_call = from_string "ERADICATE_NULL_METHOD_CALL" ~hum:"Null Method Call" let eradicate_parameter_not_nullable = from_string "ERADICATE_PARAMETER_NOT_NULLABLE" ~hum:"Parameter Not Nullable" + let eradicate_parameter_value_absent = from_string "ERADICATE_PARAMETER_VALUE_ABSENT" ~hum:"Parameter Value Absent" + let eradicate_return_not_nullable = from_string "ERADICATE_RETURN_NOT_NULLABLE" ~hum:"Return Not Nullable" + let eradicate_return_over_annotated = from_string "ERADICATE_RETURN_OVER_ANNOTATED" ~hum:"Return Over Annotated" + let eradicate_return_value_not_present = from_string "ERADICATE_RETURN_VALUE_NOT_PRESENT" ~hum:"Return Value Not Present" + let eradicate_value_not_present = from_string "ERADICATE_VALUE_NOT_PRESENT" ~hum:"Value Not Present" + let failure_exe = from_string "Failure_exe" let field_should_be_nullable = from_string "FIELD_SHOULD_BE_NULLABLE" @@ -210,6 +228,7 @@ let field_not_null_checked = from_string "IVAR_NOT_NULL_CHECKED" let _global_variable_initialized_with_function_or_method_call = from_string ~enabled:false "GLOBAL_VARIABLE_INITIALIZED_WITH_FUNCTION_OR_METHOD_CALL" + let inherently_dangerous_function = from_string "INHERENTLY_DANGEROUS_FUNCTION" let interface_not_thread_safe = from_string "INTERFACE_NOT_THREAD_SAFE" @@ -267,11 +286,13 @@ let static_initialization_order_fiasco = from_string "STATIC_INITIALIZATION_ORDE let symexec_memory_error = from_string "Symexec_memory_error" ~hum:"Symbolic Execution Memory Error" + let thread_safety_violation = from_string "THREAD_SAFETY_VIOLATION" let unary_minus_applied_to_unsigned_expression = from_string ~enabled:false "UNARY_MINUS_APPLIED_TO_UNSIGNED_EXPRESSION" + let uninitialized_value = from_string ~enabled:false "UNINITIALIZED_VALUE" let unknown_proc = from_string "Unknown_proc" ~hum:"Unknown Procedure" diff --git a/infer/src/base/Latex.ml b/infer/src/base/Latex.ml index 8b1869af9..ce0885448 100644 --- a/infer/src/base/Latex.ml +++ b/infer/src/base/Latex.ml @@ -27,29 +27,32 @@ let convert_string s = String.iter ~f s ; !s' else s + (** Print a string in the given style, after converting it into latex-friendly format *) let pp_string style f s = let converted = convert_string s in match style with - | Boldface - -> F.fprintf f "\\textbf{%s}" converted - | Roman - -> F.fprintf f "\\textrm{%s}" converted - | Italics - -> F.fprintf f "\\textit{%s}" converted + | Boldface -> + F.fprintf f "\\textbf{%s}" converted + | Roman -> + F.fprintf f "\\textrm{%s}" converted + | Italics -> + F.fprintf f "\\textit{%s}" converted + let color_to_string (c: Pp.color) = match c with - | Black - -> "black" - | Blue - -> "blue" - | Green - -> "green" - | Orange - -> "orange" - | Red - -> "red" + | Black -> + "black" + | Blue -> + "blue" + | Green -> + "green" + | Orange -> + "orange" + | Red -> + "red" + (** Print color command *) let pp_color f color = F.fprintf f "\\color{%s}" (color_to_string color) @@ -61,6 +64,7 @@ let pp_begin f (author, title, table_of_contents) = "\\documentclass{article}@\n\\usepackage{hyperref}@\n\\usepackage{color}@\n\\author{%s}@\n\\title{%s}@\n\\begin{document}@\n\\maketitle@\n%a" author title pp_toc () + (** Epilogue for a latex file *) let pp_end f () = F.fprintf f "\\end{document}@\n" diff --git a/infer/src/base/Logging.ml b/infer/src/base/Logging.ml index 6c003a967..e743aada5 100644 --- a/infer/src/base/Logging.ml +++ b/infer/src/base/Logging.ml @@ -22,7 +22,9 @@ let copy_formatter f = let out_string, flush = F.pp_get_formatter_output_functions f () in let out_funs = F.pp_get_formatter_out_functions f () in let new_f = F.make_formatter out_string flush in - F.pp_set_formatter_out_functions new_f out_funs ; new_f + F.pp_set_formatter_out_functions new_f out_funs ; + new_f + (* Return a formatter that multiplexes to [fmt1] and [fmt2]. *) let dup_formatter fmt1 fmt2 = @@ -36,6 +38,7 @@ let dup_formatter fmt1 fmt2 = ; out_spaces= (fun n -> out_funs1.out_spaces n ; out_funs2.out_spaces n) } ; f + (* can be set up to emit to a file later on, but can also be left as-is and logging will only happen on the console *) let log_file = ref (F.err_formatter, `Console) @@ -69,7 +72,10 @@ let mk_file_formatter category0 = prev_category := prefix ; out_functions_orig.out_string prefix 0 (String.length prefix) ) in - let out_string s p n = print_prefix_if_newline () ; out_functions_orig.out_string s p n in + let out_string s p n = + print_prefix_if_newline () ; + out_functions_orig.out_string s p n + in let out_newline () = print_prefix_if_newline () ; out_functions_orig.out_newline () ; @@ -77,38 +83,41 @@ let mk_file_formatter category0 = in let out_spaces n = print_prefix_if_newline () ; out_functions_orig.out_spaces n in F.pp_set_formatter_out_functions f - {F.out_string= out_string; out_flush= out_functions_orig.out_flush; out_newline; out_spaces} ; + {F.out_string; out_flush= out_functions_orig.out_flush; out_newline; out_spaces} ; f + let register_formatter = let all_prefixes = ref [] in fun ?(use_stdout= false) prefix -> all_prefixes := prefix :: !all_prefixes ; (* lazy so that we get a chance to register all prefixes before computing their max length for alignment purposes *) - ( lazy - (let max_prefix = List.map ~f:String.length !all_prefixes |> List.fold_left ~f:max ~init:0 in - let fill = - let n = max_prefix - String.length prefix in - String.make n ' ' - in - let justified_prefix = fill ^ prefix in - let mk_formatters () = - let file = mk_file_formatter justified_prefix in - let console_file = - let console = if use_stdout then F.std_formatter else F.err_formatter in - dup_formatter console file + lazy + (let max_prefix = List.map ~f:String.length !all_prefixes |> List.fold_left ~f:max ~init:0 in + let fill = + let n = max_prefix - String.length prefix in + String.make n ' ' + in + let justified_prefix = fill ^ prefix in + let mk_formatters () = + let file = mk_file_formatter justified_prefix in + let console_file = + let console = if use_stdout then F.std_formatter else F.err_formatter in + dup_formatter console file + in + {file; console_file} in - {file; console_file} - in - let formatters = mk_formatters () in - let formatters_ref = ref formatters in - logging_formatters := ((formatters_ref, mk_formatters), formatters) :: !logging_formatters ; - formatters_ref) ) + let formatters = mk_formatters () in + let formatters_ref = ref formatters in + logging_formatters := ((formatters_ref, mk_formatters), formatters) :: !logging_formatters ; + formatters_ref) + let flush_formatters {file; console_file} = F.pp_print_flush file () ; F.pp_print_flush console_file () + let reset_formatters () = let refresh_formatter ((formatters_ref, mk_formatters), formatters) = (* flush to be nice *) @@ -124,6 +133,7 @@ let reset_formatters () = if not !is_newline then F.pp_print_newline (fst !log_file) () ; is_newline := true + let close_logs () = let close_fmt (_, formatters) = flush_formatters formatters in List.iter ~f:close_fmt !logging_formatters ; @@ -131,19 +141,21 @@ let close_logs () = F.pp_print_flush fmt () ; match chan with `Console -> () | `Channel c -> Out_channel.close c + let () = Epilogues.register ~f:close_logs "flushing logs and closing log file" let log ~to_console ?(to_file= true) (lazy formatters) = match (to_console, to_file) with - | false, false - -> F.ifprintf F.std_formatter - | true, _ when not Config.print_logs - -> F.fprintf !formatters.console_file - | _ - -> (* to_console might be true, but in that case so is Config.print_logs so do not print to + | false, false -> + F.ifprintf F.std_formatter + | true, _ when not Config.print_logs -> + F.fprintf !formatters.console_file + | _ -> + (* to_console might be true, but in that case so is Config.print_logs so do not print to stderr because it will get logs from the log file already *) F.fprintf !formatters.file + let debug_file_fmts = register_formatter "debug" let environment_info_file_fmts = register_formatter "environment" @@ -173,6 +185,7 @@ let progress_bar text = ~to_console:(Config.show_progress_bar && not Config.quiet) ~to_file:true progress_file_fmts "%s@?" text + let progressbar_file () = progress_bar Config.log_analysis_file let progressbar_procedure () = progress_bar Config.log_analysis_procedure @@ -180,14 +193,15 @@ let progressbar_procedure () = progress_bar Config.log_analysis_procedure let progressbar_timeout_event failure_kind = if Config.stats_mode || Config.debug_mode then match failure_kind with - | SymOp.FKtimeout - -> progress_bar Config.log_analysis_wallclock_timeout - | SymOp.FKsymops_timeout _ - -> progress_bar Config.log_analysis_symops_timeout - | SymOp.FKrecursion_timeout _ - -> progress_bar Config.log_analysis_recursion_timeout - | SymOp.FKcrash msg - -> progress_bar (Printf.sprintf "%s(%s)" Config.log_analysis_crash msg) + | SymOp.FKtimeout -> + progress_bar Config.log_analysis_wallclock_timeout + | SymOp.FKsymops_timeout _ -> + progress_bar Config.log_analysis_symops_timeout + | SymOp.FKrecursion_timeout _ -> + progress_bar Config.log_analysis_recursion_timeout + | SymOp.FKcrash msg -> + progress_bar (Printf.sprintf "%s(%s)" Config.log_analysis_crash msg) + let user_warning fmt = log ~to_console:(not Config.quiet) user_warning_file_fmts fmt @@ -198,6 +212,7 @@ type debug_level = Quiet | Medium | Verbose [@@deriving compare] let debug_level_of_int n = if n <= 0 then Quiet else if Int.equal n 1 then Medium else (* >= 2 *) Verbose + let analysis_debug_level = debug_level_of_int Config.debug_level_analysis let bufferoverrun_debug_level = debug_level_of_int Config.bo_debug @@ -213,20 +228,21 @@ type debug_kind = Analysis | BufferOverrun | Capture | Linters | MergeCapture let debug kind level fmt = let base_level = match kind with - | Analysis - -> analysis_debug_level - | BufferOverrun - -> bufferoverrun_debug_level - | Capture - -> capture_debug_level - | Linters - -> linters_debug_level - | MergeCapture - -> mergecapture_debug_level + | Analysis -> + analysis_debug_level + | BufferOverrun -> + bufferoverrun_debug_level + | Capture -> + capture_debug_level + | Linters -> + linters_debug_level + | MergeCapture -> + mergecapture_debug_level in let to_file = compare_debug_level level base_level <= 0 in log ~to_console:false ~to_file debug_file_fmts fmt + let result fmt = log ~to_console:true result_file_fmts fmt let environment_info fmt = log ~to_console:false environment_info_file_fmts fmt @@ -250,26 +266,29 @@ let pp_ml_loc_opt fmt ml_loc_opt = if Config.developer_mode then match ml_loc_opt with None -> () | Some ml_loc -> F.fprintf fmt "(%a)" pp_ml_loc ml_loc + let log_of_kind error fmt = match error with - | UserError - -> log ~to_console:false user_error_file_fmts fmt - | ExternalError - -> log ~to_console:false external_error_file_fmts fmt - | InternalError - -> log ~to_console:false internal_error_file_fmts fmt + | UserError -> + log ~to_console:false user_error_file_fmts fmt + | ExternalError -> + log ~to_console:false external_error_file_fmts fmt + | InternalError -> + log ~to_console:false internal_error_file_fmts fmt + let die error msg = F.kasprintf (fun msg -> log_of_kind error "%s@\n" msg ; raise_error error ~msg) msg + (* create new channel from the log file, and dumps the contents of the temporary log buffer there *) let setup_log_file () = match !log_file with - | _, `Channel _ - -> (* already set up *) + | _, `Channel _ -> + (* already set up *) () - | _, `Console - -> let fmt, chan, preexisting_logfile = + | _, `Console -> + let fmt, chan, preexisting_logfile = let results_dir = (* if invoked in a sub-dir (e.g., in Buck integrations), log inside the original log file *) @@ -293,6 +312,7 @@ let setup_log_file () = phase "============================================================@\n= New infer execution begins@\n============================================================" + (** type of printable elements *) type print_type = | PTatom @@ -347,6 +367,7 @@ let add_print_action pact = if Config.write_html then delayed_actions := pact :: !delayed_actions else if not Config.only_cheap_debug then !printer_hook (fst !log_file) pact + (** reset the delayed print actions *) let reset_delayed_prints () = delayed_actions := [] @@ -386,6 +407,7 @@ let d_indent indent = for _ = 1 to indent do s := " " ^ !s done ; if indent <> 0 then add_print_action (PTstr, Obj.repr !s) + (** dump command to increase the indentation level *) let d_increase_indent (indent: int) = add_print_action (PTincrease_indent, Obj.repr indent) diff --git a/infer/src/base/MarkupFormatter.ml b/infer/src/base/MarkupFormatter.ml index 95f2e13de..6274ba0bf 100644 --- a/infer/src/base/MarkupFormatter.ml +++ b/infer/src/base/MarkupFormatter.ml @@ -37,6 +37,7 @@ end = struct ; wrap_bold= wrap_simple ; pp_bold= pp_simple ; bold_to_string= Fn.id } + end module PhabricatorFormatter : sig @@ -71,14 +72,16 @@ end = struct ; wrap_bold ; pp_bold ; bold_to_string } + end let formatter = match Config.report_formatter with - | `No_formatter - -> NoFormatter.formatter - | `Phabricator_formatter - -> PhabricatorFormatter.formatter + | `No_formatter -> + NoFormatter.formatter + | `Phabricator_formatter -> + PhabricatorFormatter.formatter + let wrap_monospaced = formatter.wrap_monospaced diff --git a/infer/src/base/MergeResults.ml b/infer/src/base/MergeResults.ml index c924976ae..b73f91c5b 100644 --- a/infer/src/base/MergeResults.ml +++ b/infer/src/base/MergeResults.ml @@ -32,9 +32,11 @@ WHERE OR (main_attr_kind = attr_kind AND main_source_file < source_file) |} in - SqliteUtils.sqlite_unit_step ~log:(Printf.sprintf "copying contents of database '%s'" db_file) + SqliteUtils.sqlite_unit_step + ~log:(Printf.sprintf "copying contents of database '%s'" db_file) copy_stmt + let merge ~db_file = (* no need to wrap all the individual table merges in a single transaction (to batch writes) because we open the table with synchronous=OFF *) @@ -48,21 +50,23 @@ let merge ~db_file = (Sqlite3.exec main_db "DETACH attached") ; () + let merge_buck_flavors_results infer_deps_file = let one_line line = match String.split ~on:'\t' line with - | [_; _; target_results_dir] - -> let infer_out_src = + | [_; _; target_results_dir] -> + let infer_out_src = if Filename.is_relative target_results_dir then Filename.dirname (Config.project_root ^/ "buck-out") ^/ target_results_dir else target_results_dir in merge ~db_file:(infer_out_src ^/ ResultsDir.database_filename) - | _ - -> assert false + | _ -> + assert false in match Utils.read_file infer_deps_file with - | Ok lines - -> List.iter ~f:one_line lines - | Error error - -> L.internal_error "Couldn't read deps file '%s': %s" infer_deps_file error + | Ok lines -> + List.iter ~f:one_line lines + | Error error -> + L.internal_error "Couldn't read deps file '%s': %s" infer_deps_file error + diff --git a/infer/src/base/Multilinks.ml b/infer/src/base/Multilinks.ml index 362109a74..cde9226f8 100644 --- a/infer/src/base/Multilinks.ml +++ b/infer/src/base/Multilinks.ml @@ -28,16 +28,17 @@ let reset_cache () = String.Table.clear multilink_files_cache let read ~dir : t option = let multilink_fname = Filename.concat dir multilink_file_name in match Utils.read_file multilink_fname with - | Error _ - -> None - | Ok lines - -> let links = create () in + | Error _ -> + None + | Ok lines -> + let links = create () in List.iter ~f:(fun line -> String.Table.set links ~key:(Filename.basename line) ~data:line) lines ; String.Table.set multilink_files_cache ~key:dir ~data:links ; Some links + (* Write a multilink file in the given directory *) let write multilinks ~dir = let fname = Filename.concat dir multilink_file_name in @@ -47,10 +48,12 @@ let write multilinks ~dir = multilinks ; Out_channel.close outc + let lookup ~dir = try Some (String.Table.find_exn multilink_files_cache dir) with Not_found -> read ~dir + let resolve fname = let fname_s = DB.filename_to_string fname in if Sys.file_exists fname_s = `Yes then fname @@ -58,8 +61,9 @@ let resolve fname = let base = Filename.basename fname_s in let dir = Filename.dirname fname_s in match lookup ~dir with - | None - -> fname + | None -> + fname | Some links -> try DB.filename_from_string (String.Table.find_exn links base) with Not_found -> fname + diff --git a/infer/src/base/Pp.ml b/infer/src/base/Pp.ml index 461a155d8..a9ad6a812 100644 --- a/infer/src/base/Pp.ml +++ b/infer/src/base/Pp.ml @@ -59,11 +59,13 @@ let text = ; color= Black ; obj_sub= None } + (** Default html print environment *) let html color = { text with kind= HTML; cmap_norm= colormap_from_color color; cmap_foot= colormap_from_color color; color } + (** Default latex print environment *) let latex color = { opt= SIM_DEFAULT @@ -74,11 +76,13 @@ let latex color = ; color ; obj_sub= None } + (** Extend the normal colormap for the given object with the given color *) let extend_colormap pe (x: Obj.t) (c: color) = let colormap (y: Obj.t) = if phys_equal x y then c else pe.cmap_norm y in {pe with cmap_norm= colormap} + (** Set the object substitution, which is supposed to preserve the type. Currently only used for a map from (identifier) expressions to the program var containing them *) let set_obj_sub pe (sub: 'a -> 'a) = @@ -88,30 +92,32 @@ let set_obj_sub pe (sub: 'a -> 'a) = in {pe with obj_sub= Some new_obj_sub} + (** Reset the object substitution, so that no substitution takes place *) let reset_obj_sub pe = {pe with obj_sub= None} (** string representation of colors *) let color_string = function - | Black - -> "color_black" - | Blue - -> "color_blue" - | Green - -> "color_green" - | Orange - -> "color_orange" - | Red - -> "color_red" + | Black -> + "color_black" + | Blue -> + "color_blue" + | Green -> + "color_green" + | Orange -> + "color_orange" + | Red -> + "color_red" + let seq ?(print_env= text) ?sep:(sep_text = " ") ?(sep_html= sep_text) ?(sep_latex= sep_text) pp = let rec aux f = function - | [] - -> () - | [x] - -> F.fprintf f "%a" pp x - | x :: l - -> let sep = + | [] -> + () + | [x] -> + F.fprintf f "%a" pp x + | x :: l -> + let sep = match print_env.kind with TEXT -> sep_text | HTML -> sep_html | LATEX -> sep_latex in if print_env.break_lines then F.fprintf f "%a%s@ %a" pp x sep aux l @@ -119,6 +125,7 @@ let seq ?(print_env= text) ?sep:(sep_text = " ") ?(sep_html= sep_text) ?(sep_lat in aux + let comma_seq ?print_env pp f l = seq ?print_env ~sep:"," pp f l let semicolon_seq ?print_env pp f l = seq ?print_env ~sep:";" pp f l @@ -131,6 +138,7 @@ let current_time f () = F.fprintf f "%02d/%02d/%4d %02d:%02d" tm.Unix.tm_mday tm.Unix.tm_mon (tm.Unix.tm_year + 1900) tm.Unix.tm_hour tm.Unix.tm_min + (** Print the time in seconds elapsed since the beginning of the execution of the current command. *) let elapsed_time fmt () = Mtime.Span.pp fmt (Mtime_clock.elapsed ()) @@ -147,8 +155,10 @@ let pp_argfile fmt fname = F.fprintf fmt " /Contents of '%s'@\n" fname with exn -> F.fprintf fmt " Error reading file '%s':@\n %a@\n" fname Exn.pp exn + let cli_args fmt args = F.fprintf fmt "%a@\n%a" (seq ~sep:(String.of_char CLOpt.env_var_sep) string) args (seq ~sep:"\n" pp_argfile) (List.filter_map ~f:(String.chop_prefix ~prefix:"@") args) + diff --git a/infer/src/base/PrettyPrintable.ml b/infer/src/base/PrettyPrintable.ml index ec5ab5c38..046b4f664 100644 --- a/infer/src/base/PrettyPrintable.ml +++ b/infer/src/base/PrettyPrintable.ml @@ -36,15 +36,17 @@ end let pp_collection ~pp_item fmt c = let rec pp_list fmt = function - | [] - -> () - | [item] - -> F.fprintf fmt "@[%a@] " pp_item item - | item :: items - -> F.fprintf fmt "@[%a,@]@ " pp_item item ; pp_list fmt items + | [] -> + () + | [item] -> + F.fprintf fmt "@[%a@] " pp_item item + | item :: items -> + F.fprintf fmt "@[%a,@]@ " pp_item item ; + pp_list fmt items in F.fprintf fmt "@[{ %a}@]" pp_list c + module MakePPSet (Ord : PrintableOrderedType) = struct include Caml.Set.Make (Ord) @@ -61,4 +63,5 @@ module MakePPMap (Ord : PrintableOrderedType) = struct let pp ~pp_value fmt m = let pp_item fmt (k, v) = F.fprintf fmt "%a -> %a" Ord.pp k pp_value v in pp_collection ~pp_item fmt (bindings m) + end diff --git a/infer/src/base/Process.ml b/infer/src/base/Process.ml index 1c0199c06..7f119b15f 100644 --- a/infer/src/base/Process.ml +++ b/infer/src/base/Process.ml @@ -20,25 +20,27 @@ let print_error_and_exit ?(exit_code= 1) fmt = L.exit exit_code) F.str_formatter fmt + (** Given a command to be executed, create a process to execute this command, and wait for it to terminate. The standard out and error are not redirected. If the command fails to execute, print an error message and exit. *) let create_process_and_wait ~prog ~args = Unix.fork_exec ~prog ~argv:(prog :: args) () |> Unix.waitpid |> function - | Ok () - -> () - | Error _ as status - -> L.(die ExternalError) + | Ok () -> + () + | Error _ as status -> + L.(die ExternalError) "Error executing: %s@\n%s@\n" (String.concat ~sep:" " (prog :: args)) (Unix.Exit_or_signal.to_string_hum status) + let pipeline ~producer_prog ~producer_args ~consumer_prog ~consumer_args = let pipe_in, pipe_out = Unix.pipe () in match Unix.fork () with - | `In_the_child - -> (* redirect producer's stdout to pipe_out *) + | `In_the_child -> + (* redirect producer's stdout to pipe_out *) Unix.dup2 ~src:pipe_out ~dst:Unix.stdout ; (* close producer's copy of pipe ends *) Unix.close pipe_out ; @@ -47,19 +49,20 @@ let pipeline ~producer_prog ~producer_args ~consumer_prog ~consumer_args = never_returns (Unix.exec ~prog:producer_prog ~argv:producer_args ()) | `In_the_parent producer_pid -> match Unix.fork () with - | `In_the_child - -> (* redirect consumer's stdin to pipe_in *) + | `In_the_child -> + (* redirect consumer's stdin to pipe_in *) Unix.dup2 ~src:pipe_in ~dst:Unix.stdin ; (* close consumer's copy of pipe ends *) Unix.close pipe_out ; Unix.close pipe_in ; (* exec consumer *) never_returns (Unix.exec ~prog:consumer_prog ~argv:consumer_args ()) - | `In_the_parent consumer_pid - -> (* close parent's copy of pipe ends *) + | `In_the_parent consumer_pid -> + (* close parent's copy of pipe ends *) Unix.close pipe_out ; Unix.close pipe_in ; (* wait for children *) let producer_status = Unix.waitpid producer_pid in let consumer_status = Unix.waitpid consumer_pid in (producer_status, consumer_status) + diff --git a/infer/src/base/ProcessPool.ml b/infer/src/base/ProcessPool.ml index 885355ea6..44b4944e9 100644 --- a/infer/src/base/ProcessPool.ml +++ b/infer/src/base/ProcessPool.ml @@ -23,13 +23,14 @@ let decr counter = counter.num_processes <- counter.num_processes - 1 let wait counter = match Unix.wait `Any with - | _, Ok _ - -> decr counter - | _, Error _ when Config.keep_going - -> (* Proceed past the failure when keep going mode is on *) + | _, Ok _ -> decr counter - | _, (Error _ as status) - -> raise (Execution_error (Unix.Exit_or_signal.to_string_hum status)) + | _, Error _ when Config.keep_going -> + (* Proceed past the failure when keep going mode is on *) + decr counter + | _, (Error _ as status) -> + raise (Execution_error (Unix.Exit_or_signal.to_string_hum status)) + let wait_all counter = for _ = 1 to counter.num_processes do wait counter done @@ -37,10 +38,11 @@ let should_wait counter = counter.num_processes >= counter.jobs let start_child ~f ~pool x = match Unix.fork () with - | `In_the_child - -> in_child := true ; + | `In_the_child -> + in_child := true ; f x ; Pervasives.exit 0 - | `In_the_parent _pid - -> incr pool ; + | `In_the_parent _pid -> + incr pool ; if should_wait pool then wait pool + diff --git a/infer/src/base/ProcessPool.mli b/infer/src/base/ProcessPool.mli index 1426e0521..11920a519 100644 --- a/infer/src/base/ProcessPool.mli +++ b/infer/src/base/ProcessPool.mli @@ -12,7 +12,7 @@ open! IStd (** Pool of processes to execute in parallel up to a number of jobs. *) type t -exception Execution_error of string(** Infer process execution failure *) +exception Execution_error of string (** Infer process execution failure *) val create : jobs:int -> t (** Create a new pool of processes *) diff --git a/infer/src/base/ResultsDir.ml b/infer/src/base/ResultsDir.ml index a0c875ab2..a5a98792e 100644 --- a/infer/src/base/ResultsDir.ml +++ b/infer/src/base/ResultsDir.ml @@ -19,6 +19,7 @@ let database_fullpath = Config.results_dir ^/ database_filename let results_dir_dir_markers = List.map ~f:(Filename.concat Config.results_dir) [Config.captured_dir_name; Config.specs_dir_name] + let is_results_dir ~check_correct_version () = let not_found = ref "" in let has_all_markers = @@ -34,6 +35,7 @@ let is_results_dir ~check_correct_version () = in Result.ok_if_true has_all_markers ~error:(Printf.sprintf "'%s' not found" !not_found) + let remove_results_dir () = (* Look if file exists, it may not be a directory but that will be caught by the call to [is_results_dir]. If it's an empty directory, leave it alone. This allows users to create a temporary directory for the infer results without infer removing it to recreate it, which could be racy. *) if Sys.file_exists Config.results_dir = `Yes && not (Utils.directory_is_empty Config.results_dir) @@ -45,6 +47,7 @@ let remove_results_dir () = Config.results_dir err Config.results_dir ) ; Utils.rmtree Config.results_dir ) + let create_attributes_table db = (* it would be nice to use "WITHOUT ROWID" here but ancient versions of sqlite do not support it *) @@ -57,6 +60,7 @@ CREATE TABLE IF NOT EXISTS attributes , source_file TEXT NOT NULL , proc_attributes BLOB NOT NULL )|} + let create_db () = let temp_db = Filename.temp_file ~in_dir:Config.results_dir database_filename ".tmp" in let db = Sqlite3.db_open ~mutex:`FULL temp_db in @@ -69,6 +73,7 @@ let create_db () = try Sys.rename temp_db database_fullpath with Sys_error _ -> (* lost the race, doesn't matter *) () + let new_db_callbacks = ref [] let on_new_database_connection ~f = new_db_callbacks := f :: !new_db_callbacks @@ -82,10 +87,12 @@ let do_db_close db = close_db_callbacks := [] ; SqliteUtils.db_close db + let db_close () = Option.iter !database ~f:do_db_close ; database := None + let new_database_connection () = db_close () ; let db = Sqlite3.db_open ~mode:`NO_CREATE ~cache:`PRIVATE ~mutex:`FULL database_fullpath in @@ -95,6 +102,7 @@ let new_database_connection () = database := Some db ; List.iter ~f:(fun callback -> callback db) !new_db_callbacks + let () = Epilogues.register "closing results database" ~f:db_close let create_results_dir () = @@ -104,6 +112,7 @@ let create_results_dir () = new_database_connection () ; List.iter ~f:Unix.mkdir_p results_dir_dir_markers + let assert_results_dir advice = Result.iter_error (is_results_dir ~check_correct_version:true ()) ~f:(fun err -> L.(die UserError) @@ -111,6 +120,7 @@ let assert_results_dir advice = L.setup_log_file () ; new_database_connection () + let get_database () = Option.value_exn !database let reset_attributes_table () = @@ -118,17 +128,22 @@ let reset_attributes_table () = SqliteUtils.exec db ~log:"drop attributes table" ~stmt:"DROP TABLE attributes" ; create_attributes_table db + let delete_capture_and_analysis_data () = reset_attributes_table () ; let dirs_to_delete = List.map ~f:(Filename.concat Config.results_dir) Config.([captured_dir_name; specs_dir_name]) in - List.iter ~f:Utils.rmtree dirs_to_delete ; List.iter ~f:Unix.mkdir_p dirs_to_delete ; () + List.iter ~f:Utils.rmtree dirs_to_delete ; + List.iter ~f:Unix.mkdir_p dirs_to_delete ; + () + let db_canonicalize () = let db = get_database () in SqliteUtils.exec db ~log:"running VACUUM" ~stmt:"VACUUM" + let register_statement stmt_fmt = let k stmt0 = let stmt_ref = ref None in @@ -145,12 +160,13 @@ let register_statement stmt_fmt = on_new_database_connection ~f:new_statement ; fun () -> match !stmt_ref with - | None - -> L.(die InternalError) "database not initialized" - | Some stmt - -> Sqlite3.reset stmt |> SqliteUtils.check_sqlite_error ~log:"reset prepared statement" ; + | None -> + L.(die InternalError) "database not initialized" + | Some stmt -> + Sqlite3.reset stmt |> SqliteUtils.check_sqlite_error ~log:"reset prepared statement" ; Sqlite3.clear_bindings stmt |> SqliteUtils.check_sqlite_error ~log:"clear bindings of prepared statement" ; stmt in Printf.ksprintf k stmt_fmt + diff --git a/infer/src/base/ResultsDir.mli b/infer/src/base/ResultsDir.mli index 53920e884..d670e09b9 100644 --- a/infer/src/base/ResultsDir.mli +++ b/infer/src/base/ResultsDir.mli @@ -39,7 +39,7 @@ val db_canonicalize : unit -> unit val db_close : unit -> unit (** close the current connection to the database *) -val register_statement : ('a, unit, string, (unit -> Sqlite3.stmt)) Base.format4 -> 'a +val register_statement : ('a, unit, string, unit -> Sqlite3.stmt) Base.format4 -> 'a (** Return a function unit -> Sqlite3.stmt that can be called (once the DB has been initialized) to get the prepared statement corresponding to the current DB connection. Use this to prepare statements only once per DB connection. diff --git a/infer/src/base/Serialization.ml b/infer/src/base/Serialization.ml index a4e6effa3..c93d8683d 100644 --- a/infer/src/base/Serialization.ml +++ b/infer/src/base/Serialization.ml @@ -34,6 +34,7 @@ module Key = struct , 579094948 , 972393003 , 852343110 ) + end (** version of the binary files, to be incremented for each change *) @@ -50,6 +51,7 @@ let retry_exception ~timeout ~catch_exn ~f x = in retry () + type 'a write_command = Replace of 'a | Update of ('a option -> 'a) let create_serializer (key: Key.t) : 'a serializer = @@ -75,22 +77,22 @@ let create_serializer (key: Key.t) : 'a serializer = let read_from_file (fname: DB.filename) : 'a option = let fname_str = DB.filename_to_string fname in match In_channel.create ~binary:true fname_str with - | exception Sys_error _ - -> None - | inc - -> let read () = + | exception Sys_error _ -> + None + | inc -> + let read () = try In_channel.seek inc 0L ; read_data (Marshal.from_channel inc) fname_str with Sys_error _ -> None in let catch_exn = function - | End_of_file - -> true - | Failure _ - -> true (* handle input_value: truncated object *) - | _ - -> false + | End_of_file -> + true + | Failure _ -> + true (* handle input_value: truncated object *) + | _ -> + false in (* Retry to read for 1 second in case of end of file, *) (* which indicates that another process is writing the same file. *) @@ -115,10 +117,10 @@ let create_serializer (key: Key.t) : 'a serializer = Utils.write_file_with_locking fname_str_lock ~delete:true ~f:(fun _outc -> let data_to_write : 'a = match cmd with - | Replace data - -> data - | Update upd - -> let old_data_opt = + | Replace data -> + data + | Update upd -> + let old_data_opt = if DB.file_exists fname then (* Because of locking, this should be the latest data written by any writer, and can be used for updating *) @@ -138,6 +140,7 @@ let create_serializer (key: Key.t) : 'a serializer = let update_file ~f (fname: DB.filename) = execute_write_command_with_lock fname (Update f) in {read_from_string; read_from_file; update_file; write_to_file} + let read_from_string s = s.read_from_string let read_from_file s = s.read_from_file diff --git a/infer/src/base/SourceFile.ml b/infer/src/base/SourceFile.ml index d63251c4d..f0956dd91 100644 --- a/infer/src/base/SourceFile.ml +++ b/infer/src/base/SourceFile.ml @@ -15,6 +15,7 @@ let count_newlines (path: string) : int = let f file = In_channel.fold_lines file ~init:0 ~f:(fun i _ -> i + 1) in In_channel.with_file path ~f + type t = | Invalid of string (* ML function of origin *) @@ -48,75 +49,83 @@ let from_abs_path ?(warn_on_error= true) fname = let project_root_real = Utils.realpath ~warn_on_error Config.project_root in let models_dir_real = Config.models_src_dir in match Utils.filename_to_relative ~root:project_root_real fname_real with - | Some path - -> RelativeProjectRoot path + | Some path -> + RelativeProjectRoot path | None -> match Utils.filename_to_relative ~root:models_dir_real fname_real with - | Some path - -> RelativeInferModel path - | None - -> Absolute fname_real + | Some path -> + RelativeInferModel path + | None -> + Absolute fname_real + (* fname_real is absolute already *) let to_string fname = match fname with - | Invalid origin - -> "DUMMY from " ^ origin - | RelativeInferModel path - -> "INFER_MODEL/" ^ path - | RelativeProjectRoot path | Absolute path - -> path + | Invalid origin -> + "DUMMY from " ^ origin + | RelativeInferModel path -> + "INFER_MODEL/" ^ path + | RelativeProjectRoot path | Absolute path -> + path + let pp fmt fname = Format.fprintf fmt "%s" (to_string fname) (* Checking if the path exists may be needed only in some cases, hence the flag check_exists *) let to_abs_path fname = match fname with - | Invalid origin - -> L.(die InternalError) "cannot be called with Invalid source file originating in %s" origin - | RelativeProjectRoot path - -> Filename.concat Config.project_root path - | RelativeInferModel path - -> Filename.concat Config.models_src_dir path - | Absolute path - -> path + | Invalid origin -> + L.(die InternalError) "cannot be called with Invalid source file originating in %s" origin + | RelativeProjectRoot path -> + Filename.concat Config.project_root path + | RelativeInferModel path -> + Filename.concat Config.models_src_dir path + | Absolute path -> + path + let line_count source_file = let abs_path = to_abs_path source_file in count_newlines abs_path + let to_rel_path fname = match fname with RelativeProjectRoot path -> path | _ -> to_abs_path fname + let invalid origin = Invalid origin let is_invalid = function Invalid _ -> true | _ -> false let is_infer_model source_file = match source_file with - | Invalid origin - -> L.(die InternalError) "cannot be called with Invalid source file from %s" origin - | RelativeProjectRoot _ | Absolute _ - -> false - | RelativeInferModel _ - -> true + | Invalid origin -> + L.(die InternalError) "cannot be called with Invalid source file from %s" origin + | RelativeProjectRoot _ | Absolute _ -> + false + | RelativeInferModel _ -> + true + (** Returns true if the file is a C++ model *) let is_cpp_model file = match file with - | RelativeInferModel path - -> String.is_prefix ~prefix:Config.relative_cpp_models_dir path - | _ - -> false + | RelativeInferModel path -> + String.is_prefix ~prefix:Config.relative_cpp_models_dir path + | _ -> + false + let is_under_project_root = function - | Invalid origin - -> L.(die InternalError) "cannot be called with Invalid source file from %s" origin - | RelativeProjectRoot _ - -> true - | Absolute _ | RelativeInferModel _ - -> false + | Invalid origin -> + L.(die InternalError) "cannot be called with Invalid source file from %s" origin + | RelativeProjectRoot _ -> + true + | Absolute _ | RelativeInferModel _ -> + false + let exists_cache = String.Table.create ~size:256 () @@ -124,7 +133,9 @@ let path_exists abs_path = try String.Table.find_exn exists_cache abs_path with Not_found -> let result = Sys.file_exists abs_path = `Yes in - String.Table.set exists_cache ~key:abs_path ~data:result ; result + String.Table.set exists_cache ~key:abs_path ~data:result ; + result + let of_header ?(warn_on_error= true) header_file = let abs_path = to_abs_path header_file in @@ -133,30 +144,33 @@ let of_header ?(warn_on_error= true) header_file = let file_no_ext, ext_opt = Filename.split_extension abs_path in let file_opt = match ext_opt with - | Some ext when List.mem ~equal:String.equal header_exts ext - -> let possible_files = List.map ~f:(fun ext -> file_no_ext ^ "." ^ ext) source_exts in + | Some ext when List.mem ~equal:String.equal header_exts ext -> + let possible_files = List.map ~f:(fun ext -> file_no_ext ^ "." ^ ext) source_exts in List.find ~f:path_exists possible_files - | _ - -> None + | _ -> + None in Option.map ~f:(from_abs_path ~warn_on_error) file_opt + let create ?(warn_on_error= true) path = if Filename.is_relative path then (* sources in changed-files-index may be specified relative to project root *) RelativeProjectRoot path else from_abs_path ~warn_on_error path + let changed_sources_from_changed_files changed_files = List.fold changed_files ~init:Set.empty ~f:(fun changed_files_set line -> let source_file = create line in let changed_files' = Set.add source_file changed_files_set in (* Add source corresponding to changed header if it exists *) match of_header source_file with - | Some src - -> Set.add src changed_files' - | None - -> changed_files' ) + | Some src -> + Set.add src changed_files' + | None -> + changed_files' ) + module UNSAFE = struct let from_string str = if Filename.is_relative str then RelativeProjectRoot str else Absolute str diff --git a/infer/src/base/SqliteUtils.ml b/infer/src/base/SqliteUtils.ml index 408b7aff1..6fba6256d 100644 --- a/infer/src/base/SqliteUtils.ml +++ b/infer/src/base/SqliteUtils.ml @@ -14,55 +14,62 @@ exception Error of string let error ~fatal fmt = (if fatal then Format.kasprintf (fun err -> raise (Error err)) else L.internal_error) fmt + let check_sqlite_error ?(fatal= false) ~log rc = match (rc : Sqlite3.Rc.t) with - | OK | ROW - -> () - | _ as err - -> error ~fatal "%s: %s" log (Sqlite3.Rc.to_string err) + | OK | ROW -> + () + | _ as err -> + error ~fatal "%s: %s" log (Sqlite3.Rc.to_string err) + let exec db ~log ~stmt = (* Call [check_sqlite_error] with [fatal:true] and catch exceptions to rewrite the error message. This avoids allocating the error string when not needed. *) try check_sqlite_error ~fatal:true ~log (Sqlite3.exec db stmt) with Error err -> error ~fatal:true "exec: %s" err + let finalize ~log stmt = try check_sqlite_error ~fatal:true ~log (Sqlite3.finalize stmt) with - | Error err - -> error ~fatal:true "finalize: %s" err - | Sqlite3.Error err - -> error ~fatal:true "finalize: %s: %s" log err + | Error err -> + error ~fatal:true "finalize: %s" err + | Sqlite3.Error err -> + error ~fatal:true "finalize: %s: %s" log err + let sqlite_result_rev_list_step ?finalize:(do_finalize = true) ~log stmt = let rec aux rev_results = match Sqlite3.step stmt with - | Sqlite3.Rc.ROW - -> (* the operation returned a result, get it *) + | Sqlite3.Rc.ROW -> + (* the operation returned a result, get it *) let value = Some (Sqlite3.column stmt 0) in aux (value :: rev_results) - | DONE - -> rev_results - | err - -> L.die InternalError "%s: %s" log (Sqlite3.Rc.to_string err) + | DONE -> + rev_results + | err -> + L.die InternalError "%s: %s" log (Sqlite3.Rc.to_string err) in if do_finalize then protect ~finally:(fun () -> finalize ~log stmt) ~f:(fun () -> aux []) else aux [] + let sqlite_result_step ?finalize ~log stmt = match sqlite_result_rev_list_step ?finalize ~log stmt with - | [] - -> None - | [x] - -> x - | l - -> L.die InternalError "%s: zero or one result expected, got %d instead" log (List.length l) + | [] -> + None + | [x] -> + x + | l -> + L.die InternalError "%s: zero or one result expected, got %d instead" log (List.length l) + let sqlite_unit_step ?finalize ~log stmt = match sqlite_result_rev_list_step ?finalize ~log stmt with - | [] - -> () - | l - -> L.die InternalError "%s: exactly zero result expected, got %d instead" log (List.length l) + | [] -> + () + | l -> + L.die InternalError "%s: exactly zero result expected, got %d instead" log (List.length l) + let db_close db = if not (Sqlite3.db_close db) then @@ -71,3 +78,4 @@ let db_close db = (Printf.sprintf "closing: %s (%s)" (Sqlite3.errcode db |> Sqlite3.Rc.to_string) (Sqlite3.errmsg db))) + diff --git a/infer/src/base/SqliteUtils.mli b/infer/src/base/SqliteUtils.mli index be9458c9c..23fa34266 100644 --- a/infer/src/base/SqliteUtils.mli +++ b/infer/src/base/SqliteUtils.mli @@ -9,9 +9,8 @@ open! IStd -exception - Error of - string(** The functions in this module tend to raise more often than their counterparts in [Sqlite3]. In particular, they may raise if the [Sqlite3.Rc.t] result of certain operations is unexpected. *) +exception Error of string + (** The functions in this module tend to raise more often than their counterparts in [Sqlite3]. In particular, they may raise if the [Sqlite3.Rc.t] result of certain operations is unexpected. *) val check_sqlite_error : ?fatal:bool -> log:string -> Sqlite3.Rc.t -> unit (** Assert that the result is either [Sqlite3.Rc.OK]. If [row_is_ok] then [Sqlite3.Rc.ROW] is also accepted. If the result is not valid, then if [fatal] is set raise [Error], otherwise log the error and proceed. *) diff --git a/infer/src/base/StatisticsToolbox.ml b/infer/src/base/StatisticsToolbox.ml index 1d7d207b4..de88b3102 100644 --- a/infer/src/base/StatisticsToolbox.ml +++ b/infer/src/base/StatisticsToolbox.ml @@ -29,6 +29,7 @@ let to_json s = ; ("max", `Float s.max) ; ("count", `Int s.count) ] + let from_json json = let open! Yojson.Basic.Util in { sum= json |> member "sum" |> to_float @@ -40,6 +41,7 @@ let from_json json = ; max= json |> member "max" |> to_float ; count= json |> member "count" |> to_int } + let compute_statistics values = let num_elements = List.length values in let sum = List.fold ~f:(fun acc v -> acc +. v) ~init:0.0 values in @@ -67,3 +69,4 @@ let compute_statistics values = ; p75= percentile 0.75 ; max= percentile 1.0 ; count= num_elements } + diff --git a/infer/src/base/SymOp.ml b/infer/src/base/SymOp.ml index 1d6bf6c20..72d6e1a41 100644 --- a/infer/src/base/SymOp.ml +++ b/infer/src/base/SymOp.ml @@ -19,20 +19,21 @@ type failure_kind = | FKrecursion_timeout of int (** max recursion level exceeded *) | FKcrash of string (** uncaught exception or failed assertion *) -exception Analysis_failure_exe of failure_kind(** failure that prevented analysis from finishing *) +exception Analysis_failure_exe of failure_kind + (** failure that prevented analysis from finishing *) let exn_not_failure = function Analysis_failure_exe _ -> false | _ -> true let try_finally ~f ~finally = match f () with - | r - -> finally () ; r - | exception (Analysis_failure_exe _ as f_exn) - -> reraise_after f_exn ~f:(fun () -> + | r -> + finally () ; r + | exception (Analysis_failure_exe _ as f_exn) -> + reraise_after f_exn ~f:(fun () -> try finally () with _ -> (* swallow in favor of the original exception *) () ) - | exception f_exn - -> reraise_after f_exn ~f:(fun () -> + | exception f_exn -> + reraise_after f_exn ~f:(fun () -> try finally () with | finally_exn @@ -40,15 +41,17 @@ let try_finally ~f ~finally = match finally_exn with Analysis_failure_exe _ -> false | _ -> true -> () ) + let pp_failure_kind fmt = function - | FKtimeout - -> F.fprintf fmt "TIMEOUT" - | FKsymops_timeout symops - -> F.fprintf fmt "SYMOPS TIMEOUT (%d)" symops - | FKrecursion_timeout level - -> F.fprintf fmt "RECURSION TIMEOUT(%d)" level - | FKcrash msg - -> F.fprintf fmt "CRASH (%s)" msg + | FKtimeout -> + F.fprintf fmt "TIMEOUT" + | FKsymops_timeout symops -> + F.fprintf fmt "SYMOPS TIMEOUT (%d)" symops + | FKrecursion_timeout level -> + F.fprintf fmt "RECURSION TIMEOUT(%d)" level + | FKcrash msg -> + F.fprintf fmt "CRASH (%s)" msg + (** Count the number of symbolic operations *) @@ -57,10 +60,12 @@ let timeout_seconds = ref (Option.map Config.seconds_per_iteration ~f:(fun sec -> sec *. float_of_int Config.iterations)) + (** Timeout in SymOps *) let timeout_symops = ref (Option.map Config.symops_per_iteration ~f:(fun symops -> symops * Config.iterations)) + let get_timeout_seconds () = !timeout_seconds (** Internal state of the module *) @@ -93,6 +98,7 @@ let save_state ~keep_symop_total = gs := new_state ; old_state + (** handler for the wallclock timeout *) let wallclock_timeout_handler = ref None @@ -108,18 +114,20 @@ let unset_wallclock_alarm () = !gs.last_wallclock <- None (** if the wallclock alarm has expired, raise a timeout exception *) let check_wallclock_alarm () = match (!gs.last_wallclock, !wallclock_timeout_handler) with - | Some alarm_time, Some handler when Unix.gettimeofday () >= alarm_time - -> unset_wallclock_alarm () ; handler () - | _ - -> () + | Some alarm_time, Some handler when Unix.gettimeofday () >= alarm_time -> + unset_wallclock_alarm () ; handler () + | _ -> + () + (** Return the time remaining before the wallclock alarm expires *) let get_remaining_wallclock_time () = match !gs.last_wallclock with - | Some alarm_time - -> max 0.0 (alarm_time -. Unix.gettimeofday ()) - | None - -> 0.0 + | Some alarm_time -> + max 0.0 (alarm_time -. Unix.gettimeofday ()) + | None -> + 0.0 + (** Return the total number of symop's since the beginning *) let get_total () = !(!gs.symop_total) @@ -132,12 +140,13 @@ let pay () = !gs.symop_count <- !gs.symop_count + 1 ; !gs.symop_total := !(!gs.symop_total) + 1 ; ( match !timeout_symops with - | Some symops when !gs.symop_count > symops && !gs.alarm_active - -> raise (Analysis_failure_exe (FKsymops_timeout !gs.symop_count)) - | _ - -> () ) ; + | Some symops when !gs.symop_count > symops && !gs.alarm_active -> + raise (Analysis_failure_exe (FKsymops_timeout !gs.symop_count)) + | _ -> + () ) ; check_wallclock_alarm () + (** Reset the counter *) let reset_count () = !gs.symop_count <- 0 @@ -146,5 +155,6 @@ let set_alarm () = reset_count () ; !gs.alarm_active <- true + (** De-activate the alarm *) let unset_alarm () = !gs.alarm_active <- false diff --git a/infer/src/base/SymOp.mli b/infer/src/base/SymOp.mli index 7991b4504..c31a9f222 100644 --- a/infer/src/base/SymOp.mli +++ b/infer/src/base/SymOp.mli @@ -61,7 +61,7 @@ type failure_kind = | FKrecursion_timeout of int (** max recursion level exceeded *) | FKcrash of string (** uncaught exception or failed assertion *) -exception Analysis_failure_exe of failure_kind(** Timeout exception *) +exception Analysis_failure_exe of failure_kind (** Timeout exception *) val exn_not_failure : exn -> bool (** check that the exception is not a timeout exception *) diff --git a/infer/src/base/Utils.ml b/infer/src/base/Utils.ml index c9edc2a74..8b8478e0f 100644 --- a/infer/src/base/Utils.ml +++ b/infer/src/base/Utils.ml @@ -30,11 +30,12 @@ let read_file fname = done ; assert false with - | End_of_file - -> cleanup () ; + | End_of_file -> + cleanup () ; Ok (List.rev !res) - | Sys_error error - -> cleanup () ; Error error + | Sys_error error -> + cleanup () ; Error error + (** copy a source file, return the number of lines, or None in case of error *) let copy_file fname_from fname_to = @@ -52,14 +53,17 @@ let copy_file fname_from fname_to = cout_ref := Some cout ; while true do let line = In_channel.input_line_exn cin in - Out_channel.output_string cout line ; Out_channel.output_char cout '\n' ; incr res + Out_channel.output_string cout line ; + Out_channel.output_char cout '\n' ; + incr res done ; assert false with - | End_of_file - -> cleanup () ; Some !res - | Sys_error _ - -> cleanup () ; None + | End_of_file -> + cleanup () ; Some !res + | Sys_error _ -> + cleanup () ; None + (** type for files used for printing *) type outfile = @@ -73,7 +77,10 @@ let create_outfile fname = let out_c = Out_channel.create fname in let fmt = F.formatter_of_out_channel out_c in Some {fname; out_c; fmt} - with Sys_error _ -> F.fprintf F.err_formatter "error: cannot create file %s@." fname ; None + with Sys_error _ -> + F.fprintf F.err_formatter "error: cannot create file %s@." fname ; + None + (** operate on an outfile reference if it is not None *) let do_outf outf_opt f = match outf_opt with None -> () | Some outf -> f outf @@ -85,37 +92,39 @@ let close_outf outf = Out_channel.close outf.out_c let filename_to_absolute ~root fname = let add_entry rev_done entry = match (entry, rev_done) with - | ".", [] - -> entry :: rev_done (* id on . *) - | ".", _ - -> rev_done (* path/. --> path *) - | "..", ("." | "..") :: _ - -> entry :: rev_done (* id on {.,..}/.. *) - | "..", ["/"] - -> rev_done (* /.. -> / *) - | "..", _ :: rev_done_parent - -> rev_done_parent (* path/dir/.. --> path *) - | _ - -> entry :: rev_done + | ".", [] -> + entry :: rev_done (* id on . *) + | ".", _ -> + rev_done (* path/. --> path *) + | "..", ("." | "..") :: _ -> + entry :: rev_done (* id on {.,..}/.. *) + | "..", ["/"] -> + rev_done (* /.. -> / *) + | "..", _ :: rev_done_parent -> + rev_done_parent (* path/dir/.. --> path *) + | _ -> + entry :: rev_done in let abs_fname = if Filename.is_absolute fname then fname else root ^/ fname in Filename.of_parts (List.rev (List.fold ~f:add_entry ~init:[] (Filename.parts abs_fname))) + (** Convert an absolute filename to one relative to the given directory. *) let filename_to_relative ~root fname = let rec relativize_if_under origin target = match (origin, target) with - | x :: xs, y :: ys when String.equal x y - -> relativize_if_under xs ys - | [], [] - -> Some "." - | [], ys - -> Some (Filename.of_parts ys) - | _ - -> None + | x :: xs, y :: ys when String.equal x y -> + relativize_if_under xs ys + | [], [] -> + Some "." + | [], ys -> + Some (Filename.of_parts ys) + | _ -> + None in relativize_if_under (Filename.parts root) (Filename.parts fname) + let directory_fold f init path = let collect current_dir (accu, dirs) path = let full_path = current_dir ^/ path in @@ -126,14 +135,15 @@ let directory_fold f init path = in let rec loop accu dirs = match dirs with - | [] - -> accu - | d :: tl - -> let new_accu, new_dirs = Array.fold ~f:(collect d) ~init:(accu, tl) (Sys.readdir d) in + | [] -> + accu + | d :: tl -> + let new_accu, new_dirs = Array.fold ~f:(collect d) ~init:(accu, tl) (Sys.readdir d) in loop new_accu new_dirs in if Sys.is_directory path = `Yes then loop init [path] else f init path + let directory_iter f path = let apply current_dir dirs path = let full_path = current_dir ^/ path in @@ -146,14 +156,15 @@ let directory_iter f path = in let rec loop dirs = match dirs with - | [] - -> () - | d :: tl - -> let new_dirs = Array.fold ~f:(apply d) ~init:tl (Sys.readdir d) in + | [] -> + () + | d :: tl -> + let new_dirs = Array.fold ~f:(apply d) ~init:tl (Sys.readdir d) in loop new_dirs in if Sys.is_directory path = `Yes then loop [path] else f path + let directory_is_empty path = Sys.readdir path |> Array.is_empty let string_crc_hex32 s = Digest.to_hex (Digest.string s) @@ -162,6 +173,7 @@ let read_json_file path = try Ok (Yojson.Basic.from_file path) with Sys_error msg | Yojson.Json_error msg -> Error msg + let do_finally_swallow_timeout ~f ~finally = let res = try f () @@ -173,35 +185,42 @@ let do_finally_swallow_timeout ~f ~finally = let res' = finally () in (res, res') + let try_finally_swallow_timeout ~f ~finally = let res, () = do_finally_swallow_timeout ~f ~finally in res + let with_file_in file ~f = let ic = In_channel.create file in let f () = f ic in let finally () = In_channel.close ic in try_finally_swallow_timeout ~f ~finally + let with_file_out file ~f = let oc = Out_channel.create file in let f () = f oc in let finally () = Out_channel.close oc in try_finally_swallow_timeout ~f ~finally + let write_json_to_file destfile json = with_file_out destfile ~f:(fun oc -> Yojson.Basic.pretty_to_channel oc json) + let consume_in chan_in = try while true do In_channel.input_line_exn chan_in |> ignore done with End_of_file -> () + let with_process_in command read = let chan = Unix.open_process_in command in let f () = read chan in let finally () = consume_in chan ; Unix.close_process_in chan in do_finally_swallow_timeout ~f ~finally + let shell_escape_command cmd = let escape arg = (* ends on-going single quote, output single quote inside double quotes, then open a new single @@ -210,6 +229,7 @@ let shell_escape_command cmd = in List.map ~f:escape cmd |> String.concat ~sep:" " + (** Create a directory if it does not exist already. *) let create_dir dir = try @@ -225,28 +245,31 @@ let create_dir dir = in if not created_concurrently then L.(die ExternalError) "cannot create directory '%s'" dir + let realpath_cache = Hashtbl.create 1023 let realpath ?(warn_on_error= true) path = match Hashtbl.find realpath_cache path with | exception Not_found -> ( match Filename.realpath path with - | realpath - -> Hashtbl.add realpath_cache path (Ok realpath) ; realpath - | exception Unix.Unix_error (code, f, arg) - -> if warn_on_error then + | realpath -> + Hashtbl.add realpath_cache path (Ok realpath) ; + realpath + | exception Unix.Unix_error (code, f, arg) -> + if warn_on_error then F.eprintf "WARNING: Failed to resolve file %s with \"%s\" @\n@." arg (Unix.Error.message code) ; (* cache failures as well *) Hashtbl.add realpath_cache path (Error (code, f, arg)) ; raise (Unix.Unix_error (code, f, arg)) ) - | Ok path - -> path - | Error (code, f, arg) - -> raise (Unix.Unix_error (code, f, arg)) + | Ok path -> + path + | Error (code, f, arg) -> + raise (Unix.Unix_error (code, f, arg)) + (* never closed *) -let devnull = (lazy (Unix.openfile "/dev/null" ~mode:[Unix.O_WRONLY])) +let devnull = lazy (Unix.openfile "/dev/null" ~mode:[Unix.O_WRONLY]) let suppress_stderr2 f2 x1 x2 = let restore_stderr src = Unix.dup2 ~src ~dst:Unix.stderr ; Unix.close src in @@ -256,6 +279,7 @@ let suppress_stderr2 f2 x1 x2 = let finally () = restore_stderr orig_stderr in protect ~f ~finally + let compare_versions v1 v2 = let int_list_of_version v = let lv = String.split ~on:'.' v in @@ -269,6 +293,7 @@ let compare_versions v1 v2 = let lv2 = int_list_of_version v2 in [%compare : int list] lv1 lv2 + let write_file_with_locking ?(delete= false) ~f:do_write fname = Unix.with_file ~mode:Unix.([O_WRONLY; O_CREAT]) fname ~f:(fun file_descr -> if Unix.flock file_descr Unix.Flock_command.lock_exclusive then ( @@ -285,26 +310,28 @@ let write_file_with_locking ?(delete= false) ~f:do_write fname = try Unix.unlink fname with Unix.Unix_error _ -> () + let rec rmtree name = match Unix.((lstat name).st_kind) with - | S_DIR - -> let dir = Unix.opendir name in + | S_DIR -> + let dir = Unix.opendir name in let rec rmdir dir = match Unix.readdir_opt dir with - | Some entry - -> if not + | Some entry -> + if not ( String.equal entry Filename.current_dir_name || String.equal entry Filename.parent_dir_name ) then rmtree (name ^/ entry) ; rmdir dir - | None - -> Unix.closedir dir ; Unix.rmdir name + | None -> + Unix.closedir dir ; Unix.rmdir name in rmdir dir - | _ - -> Unix.unlink name - | exception Unix.Unix_error (Unix.ENOENT, _, _) - -> () + | _ -> + Unix.unlink name + | exception Unix.Unix_error (Unix.ENOENT, _, _) -> + () + let without_gc ~f = let stat = Gc.get () in @@ -314,5 +341,7 @@ let without_gc ~f = Gc.set {stat with space_overhead= space_oh} ; res + let yield () = Unix.select ~read:[] ~write:[] ~except:[] ~timeout:(`After Time_ns.Span.min_value) |> ignore + diff --git a/infer/src/base/ZipLib.ml b/infer/src/base/ZipLib.ml index 52fd8a0bc..dd91a5b73 100644 --- a/infer/src/base/ZipLib.ml +++ b/infer/src/base/ZipLib.ml @@ -18,6 +18,7 @@ let get_cache_dir infer_cache zip_filename = let key = basename ^ Utils.string_crc_hex32 zip_filename in Filename.concat infer_cache key + let load_from_cache serializer zip_path cache_dir zip_library = let absolute_path = Filename.concat cache_dir zip_path in let deserialize = Serialization.read_from_file serializer in @@ -30,66 +31,71 @@ let load_from_cache serializer zip_path cache_dir zip_library = DB.filename_from_string to_path in match deserialize (extract absolute_path) with - | Some data - -> Some data - | None - -> None - | exception Not_found - -> None + | Some data -> + Some data + | None -> + None + | exception Not_found -> + None + let load_from_zip serializer zip_path zip_library = let lazy zip_channel = zip_library.zip_channel in let deserialize = Serialization.read_from_string serializer in match deserialize (Zip.read_entry zip_channel (Zip.find_entry zip_channel zip_path)) with - | Some data - -> Some data - | None - -> None - | exception Not_found - -> None + | Some data -> + Some data + | None -> + None + | exception Not_found -> + None + let load_data serializer path zip_library = let zip_path = Filename.concat Config.default_in_zip_results_dir path in match Config.infer_cache with - | None - -> load_from_zip serializer zip_path zip_library - | Some infer_cache - -> let cache_dir = get_cache_dir infer_cache zip_library.zip_filename in + | None -> + load_from_zip serializer zip_path zip_library + | Some infer_cache -> + let cache_dir = get_cache_dir infer_cache zip_library.zip_filename in load_from_cache serializer zip_path cache_dir zip_library + (** list of the zip files to search for specs files *) let zip_libraries = (* delay until load is called, to avoid stating/opening files at init time *) - ( lazy - (let mk_zip_lib models zip_filename = - {models; zip_filename; zip_channel= (lazy (Zip.open_in zip_filename))} - in - let zip_libs = - if Config.use_jar_cache && Config.infer_cache <> None then [] - else - (* Order matters, jar files should appear in the order in which they should be searched for + lazy + (let mk_zip_lib models zip_filename = + {models; zip_filename; zip_channel= lazy (Zip.open_in zip_filename)} + in + let zip_libs = + if Config.use_jar_cache && Config.infer_cache <> None then [] + else + (* Order matters, jar files should appear in the order in which they should be searched for specs files. Config.specs_library is in reverse order of appearance on command line. *) - let add_zip zip_libs fname = - if Filename.check_suffix fname ".jar" then - (* fname is a zip of specs *) - mk_zip_lib false fname :: zip_libs - else (* fname is a dir of specs *) - zip_libs - in - List.fold ~f:add_zip ~init:[] Config.specs_library - in - if Config.biabduction && not Config.models_mode && Sys.file_exists Config.models_jar = `Yes then - mk_zip_lib true Config.models_jar :: zip_libs - else zip_libs) ) + let add_zip zip_libs fname = + if Filename.check_suffix fname ".jar" then + (* fname is a zip of specs *) + mk_zip_lib false fname :: zip_libs + else (* fname is a dir of specs *) + zip_libs + in + List.fold ~f:add_zip ~init:[] Config.specs_library + in + if Config.biabduction && not Config.models_mode && Sys.file_exists Config.models_jar = `Yes + then mk_zip_lib true Config.models_jar :: zip_libs + else zip_libs) + (* Search path in the list of zip libraries and use a cache directory to save already deserialized data *) let load serializer path = let rec loop = function - | [] - -> None - | zip_library :: other_libraries - -> let opt = load_data serializer path zip_library in + | [] -> + None + | zip_library :: other_libraries -> + let opt = load_data serializer path zip_library in if Option.is_some opt then opt else loop other_libraries in loop (Lazy.force zip_libraries) + diff --git a/infer/src/bufferoverrun/absLoc.ml b/infer/src/bufferoverrun/absLoc.ml index 19b556686..274895c1f 100644 --- a/infer/src/bufferoverrun/absLoc.ml +++ b/infer/src/bufferoverrun/absLoc.ml @@ -35,16 +35,17 @@ module Loc = struct let unknown = Allocsite Allocsite.unknown let rec pp fmt = function - | Var v - -> Var.pp F.str_formatter v ; + | Var v -> + Var.pp F.str_formatter v ; let s = F.flush_str_formatter () in if Char.equal s.[0] '&' then F.fprintf fmt "%s" (String.sub s ~pos:1 ~len:(String.length s - 1)) else F.fprintf fmt "%s" s - | Allocsite a - -> Allocsite.pp fmt a - | Field (l, f) - -> F.fprintf fmt "%a.%a" pp l Typ.Fieldname.pp f + | Allocsite a -> + Allocsite.pp fmt a + | Field (l, f) -> + F.fprintf fmt "%a.%a" pp l Typ.Fieldname.pp f + let is_var = function Var _ -> true | _ -> false @@ -61,10 +62,11 @@ module Loc = struct let append_field l f = Field (l, f) let is_return = function - | Var Var.ProgramVar x - -> Mangled.equal (Pvar.get_name x) Ident.name_return - | _ - -> false + | Var Var.ProgramVar x -> + Mangled.equal (Pvar.get_name x) Ident.name_return + | _ -> + false + end module PowLoc = struct @@ -84,5 +86,6 @@ module PowLoc = struct if is_bot ploc then singleton Loc.unknown else fold (fun l -> add (Loc.append_field l fn)) ploc empty + let is_singleton x = Int.equal (cardinal x) 1 end diff --git a/infer/src/bufferoverrun/arrayBlk.ml b/infer/src/bufferoverrun/arrayBlk.ml index 0fbee3308..029b55876 100644 --- a/infer/src/bufferoverrun/arrayBlk.ml +++ b/infer/src/bufferoverrun/arrayBlk.ml @@ -37,6 +37,7 @@ module ArrInfo = struct ; size= Itv.join a1.size a2.size ; stride= Itv.join a1.stride a2.stride } + let widen : prev:t -> next:t -> num_iters:int -> t = fun ~prev ~next ~num_iters -> if phys_equal prev next then next @@ -45,20 +46,24 @@ module ArrInfo = struct ; size= Itv.widen ~prev:prev.size ~next:next.size ~num_iters ; stride= Itv.widen ~prev:prev.stride ~next:next.stride ~num_iters } + let eq : t -> t -> bool = fun a1 a2 -> if phys_equal a1 a2 then true else Itv.eq a1.offset a2.offset && Itv.eq a1.size a2.size && Itv.eq a1.stride a2.stride + let ( <= ) : lhs:t -> rhs:t -> bool = fun ~lhs ~rhs -> if phys_equal lhs rhs then true else Itv.le ~lhs:lhs.offset ~rhs:rhs.offset && Itv.le ~lhs:lhs.size ~rhs:rhs.size && Itv.le ~lhs:lhs.stride ~rhs:rhs.stride + let weak_plus_size : t -> Itv.t -> t = fun arr i -> {arr with size= Itv.join arr.size (Itv.plus i arr.size)} + let plus_offset : t -> Itv.t -> t = fun arr i -> {arr with offset= Itv.plus arr.offset i} let minus_offset : t -> Itv.astate -> t = fun arr i -> {arr with offset= Itv.minus arr.offset i} @@ -69,9 +74,11 @@ module ArrInfo = struct fun arr subst_map -> {arr with offset= Itv.subst arr.offset subst_map; size= Itv.subst arr.size subst_map} + let pp : Format.formatter -> t -> unit = fun fmt arr -> Format.fprintf fmt "offset : %a, size : %a" Itv.pp arr.offset Itv.pp arr.size + let get_symbols : t -> Itv.Symbol.t list = fun arr -> let s1 = Itv.get_symbols arr.offset in @@ -79,20 +86,25 @@ module ArrInfo = struct let s3 = Itv.get_symbols arr.stride in List.concat [s1; s2; s3] + let normalize : t -> t = fun arr -> { offset= Itv.normalize arr.offset ; size= Itv.normalize arr.size ; stride= Itv.normalize arr.stride } + let prune_comp : Binop.t -> t -> t -> t = fun c arr1 arr2 -> {arr1 with offset= Itv.prune_comp c arr1.offset arr2.offset} + let prune_eq : t -> t -> t = fun arr1 arr2 -> {arr1 with offset= Itv.prune_eq arr1.offset arr2.offset} + let prune_ne : t -> t -> t = fun arr1 arr2 -> {arr1 with offset= Itv.prune_ne arr1.offset arr2.offset} + end include AbstractDomain.Map (Allocsite) (ArrInfo) @@ -106,6 +118,7 @@ let is_bot : astate -> bool = is_empty let make : Allocsite.t -> Itv.t -> Itv.t -> Itv.t -> astate = fun a o sz st -> add a (ArrInfo.make (o, sz, st)) bot + let offsetof : astate -> Itv.t = fun a -> fold (fun _ arr -> Itv.join arr.ArrInfo.offset) a Itv.bot let sizeof : astate -> Itv.t = fun a -> fold (fun _ arr -> Itv.join arr.ArrInfo.size) a Itv.bot @@ -117,34 +130,41 @@ let input : string -> astate = fun allocsite -> add allocsite ArrInfo.input empt let weak_plus_size : astate -> Itv.t -> astate = fun arr i -> map (fun a -> ArrInfo.weak_plus_size a i) arr + let plus_offset : astate -> Itv.t -> astate = fun arr i -> map (fun a -> ArrInfo.plus_offset a i) arr + let minus_offset : astate -> Itv.t -> astate = fun arr i -> map (fun a -> ArrInfo.minus_offset a i) arr + let diff : astate -> astate -> Itv.t = fun arr1 arr2 -> let diff_join k a2 acc = match find k arr1 with - | a1 - -> Itv.join acc (ArrInfo.diff a1 a2) - | exception Not_found - -> Itv.top + | a1 -> + Itv.join acc (ArrInfo.diff a1 a2) + | exception Not_found -> + Itv.top in fold diff_join arr2 Itv.bot + let get_pow_loc : astate -> PowLoc.t = fun array -> let pow_loc_of_allocsite k _ acc = PowLoc.add (Loc.of_allocsite k) acc in fold pow_loc_of_allocsite array PowLoc.bot + let subst : astate -> Itv.Bound.t bottom_lifted Itv.SubstMap.t -> astate = fun a subst_map -> map (fun info -> ArrInfo.subst info subst_map) a + let get_symbols : astate -> Itv.Symbol.t list = fun a -> List.concat_map ~f:(fun (_, ai) -> ArrInfo.get_symbols ai) (bindings a) + let normalize : astate -> astate = fun a -> map ArrInfo.normalize a let do_prune : (ArrInfo.t -> ArrInfo.t -> ArrInfo.t) -> astate -> astate -> astate = @@ -154,9 +174,11 @@ let do_prune : (ArrInfo.t -> ArrInfo.t -> ArrInfo.t) -> astate -> astate -> asta if mem k a1 then add k (arr_info_prune (find k a1) v2) a1 else a1 else a1 + let prune_comp : Binop.t -> astate -> astate -> astate = fun c a1 a2 -> do_prune (ArrInfo.prune_comp c) a1 a2 + let prune_eq : astate -> astate -> astate = fun a1 a2 -> do_prune ArrInfo.prune_eq a1 a2 let prune_ne : astate -> astate -> astate = fun a1 a2 -> do_prune ArrInfo.prune_ne a1 a2 diff --git a/infer/src/bufferoverrun/bufferOverrunChecker.ml b/infer/src/bufferoverrun/bufferOverrunChecker.ml index 925927d33..37fbc7647 100644 --- a/infer/src/bufferoverrun/bufferOverrunChecker.ml +++ b/infer/src/bufferoverrun/bufferOverrunChecker.ml @@ -26,6 +26,7 @@ module Summary = Summary.Make (struct let update_payload astate (summary: Specs.summary) = {summary with payload= {summary.payload with buffer_overrun= Some astate}} + let read_payload (summary: Specs.summary) = summary.payload.buffer_overrun end) @@ -38,31 +39,33 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let set_uninitialized node (typ: Typ.t) loc mem = match typ.desc with - | Tint _ | Tfloat _ - -> Dom.Mem.weak_update_heap loc Dom.Val.Itv.top mem - | _ - -> L.(debug BufferOverrun Verbose) + | Tint _ | Tfloat _ -> + Dom.Mem.weak_update_heap loc Dom.Val.Itv.top mem + | _ -> + L.(debug BufferOverrun Verbose) "/!\\ Do not know how to uninitialize type %a at %a@\n" (Typ.pp Pp.text) typ Location.pp (CFG.loc node) ; mem + (* NOTE: heuristic *) let get_malloc_info : Exp.t -> Typ.t * Int.t option * Exp.t = function | Exp.BinOp (Binop.Mult, Exp.Sizeof {typ; nbytes}, length) - | Exp.BinOp (Binop.Mult, length, Exp.Sizeof {typ; nbytes}) - -> (typ, nbytes, length) - | Exp.Sizeof {typ; nbytes} - -> (typ, nbytes, Exp.one) - | x - -> (Typ.mk (Typ.Tint Typ.IChar), Some 1, x) + | Exp.BinOp (Binop.Mult, length, Exp.Sizeof {typ; nbytes}) -> + (typ, nbytes, length) + | Exp.Sizeof {typ; nbytes} -> + (typ, nbytes, Exp.one) + | x -> + (Typ.mk (Typ.Tint Typ.IChar), Some 1, x) + let model_malloc : Typ.Procname.t -> (Ident.t * Typ.t) option -> (Exp.t * Typ.t) list -> CFG.node -> Location.t -> Dom.Mem.astate -> Dom.Mem.astate = fun pname ret params node location mem -> match ret with - | Some (id, _) - -> let typ, stride, length0 = get_malloc_info (List.hd_exn params |> fst) in + | Some (id, _) -> + let typ, stride, length0 = get_malloc_info (List.hd_exn params |> fst) in let length = Sem.eval length0 mem (CFG.loc node) in let traces = TraceSet.add_elem (Trace.ArrDecl location) (Dom.Val.get_traces length) in let v = @@ -71,89 +74,96 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in mem |> Dom.Mem.add_stack (Loc.of_id id) v |> set_uninitialized node typ (Dom.Val.get_array_locs v) - | _ - -> L.(debug BufferOverrun Verbose) + | _ -> + L.(debug BufferOverrun Verbose) "/!\\ Do not know where to model malloc at %a@\n" Location.pp (CFG.loc node) ; mem + let model_realloc : Typ.Procname.t -> (Ident.t * Typ.t) option -> (Exp.t * Typ.t) list -> CFG.node -> Location.t -> Dom.Mem.astate -> Dom.Mem.astate = fun pname ret params node location mem -> model_malloc pname ret (List.tl_exn params) node location mem + let model_min : (Ident.t * Typ.t) option -> (Exp.t * Typ.t) list -> Location.t -> Dom.Mem.astate -> Dom.Mem.astate = fun ret params location mem -> match (ret, params) with - | Some (id, _), [(e1, _); (e2, _)] - -> let i1 = Sem.eval e1 mem location |> Dom.Val.get_itv in + | Some (id, _), [(e1, _); (e2, _)] -> + let i1 = Sem.eval e1 mem location |> Dom.Val.get_itv in let i2 = Sem.eval e2 mem location |> Dom.Val.get_itv in let v = Itv.min_sem i1 i2 |> Dom.Val.of_itv in mem |> Dom.Mem.add_stack (Loc.of_id id) v - | _ - -> mem + | _ -> + mem + let model_by_value value ret mem = match ret with - | Some (id, _) - -> Dom.Mem.add_stack (Loc.of_id id) value mem - | None - -> L.(debug BufferOverrun Verbose) + | Some (id, _) -> + Dom.Mem.add_stack (Loc.of_id id) value mem + | None -> + L.(debug BufferOverrun Verbose) "/!\\ Do not know where to model value %a@\n" Dom.Val.pp value ; mem + let model_infer_print : (Exp.t * Typ.t) list -> Dom.Mem.astate -> Location.t -> Dom.Mem.astate = fun params mem loc -> match params with - | (e, _) :: _ - -> L.(debug BufferOverrun Medium) + | (e, _) :: _ -> + L.(debug BufferOverrun Medium) "@[=== Infer Print === at %a@,%a@]%!" Location.pp loc Dom.Val.pp (Sem.eval e mem loc) ; mem - | _ - -> mem + | _ -> + mem + let model_infer_set_array_length pname node params mem loc = match params with - | [(Exp.Lvar array_pvar, {Typ.desc= Typ.Tarray (typ, _, stride0)}); (length_exp, _)] - -> let length = Sem.eval length_exp mem loc |> Dom.Val.get_itv in + | [(Exp.Lvar array_pvar, {Typ.desc= Typ.Tarray (typ, _, stride0)}); (length_exp, _)] -> + let length = Sem.eval length_exp mem loc |> Dom.Val.get_itv in let stride = Option.map ~f:IntLit.to_int stride0 in let v = Sem.eval_array_alloc pname node typ ?stride Itv.zero length 0 1 in mem |> Dom.Mem.add_stack (Loc.of_pvar array_pvar) v |> set_uninitialized node typ (Dom.Val.get_array_locs v) - | [_; _] - -> L.(die InternalError) "Unexpected type of arguments for __set_array_length()" - | _ - -> L.(die InternalError) "Unexpected number of arguments for __set_array_length()" + | [_; _] -> + L.(die InternalError) "Unexpected type of arguments for __set_array_length()" + | _ -> + L.(die InternalError) "Unexpected number of arguments for __set_array_length()" + let handle_unknown_call : Typ.Procname.t -> (Ident.t * Typ.t) option -> Typ.Procname.t -> (Exp.t * Typ.t) list -> CFG.node -> Dom.Mem.astate -> Location.t -> Dom.Mem.astate = fun pname ret callee_pname params node mem loc -> match Typ.Procname.get_method callee_pname with - | "__inferbo_min" - -> model_min ret params loc mem - | "__exit" | "exit" - -> Bottom - | "fgetc" - -> model_by_value Dom.Val.Itv.m1_255 ret mem - | "infer_print" - -> model_infer_print params mem loc - | "malloc" | "__new_array" - -> model_malloc pname ret params node loc mem - | "realloc" - -> model_realloc pname ret params node loc mem - | "__set_array_length" - -> model_infer_set_array_length pname node params mem loc - | "strlen" - -> model_by_value Dom.Val.Itv.nat ret mem - | proc_name - -> L.(debug BufferOverrun Verbose) + | "__inferbo_min" -> + model_min ret params loc mem + | "__exit" | "exit" -> + Bottom + | "fgetc" -> + model_by_value Dom.Val.Itv.m1_255 ret mem + | "infer_print" -> + model_infer_print params mem loc + | "malloc" | "__new_array" -> + model_malloc pname ret params node loc mem + | "realloc" -> + model_realloc pname ret params node loc mem + | "__set_array_length" -> + model_infer_set_array_length pname node params mem loc + | "strlen" -> + model_by_value Dom.Val.Itv.nat ret mem + | proc_name -> + L.(debug BufferOverrun Verbose) "/!\\ Unknown call to %s at %a@\n" proc_name Location.pp loc ; model_by_value Dom.Val.unknown ret mem |> Dom.Mem.add_heap Loc.unknown Dom.Val.unknown + let rec declare_array : Typ.Procname.t -> CFG.node -> Location.t -> Loc.t -> Typ.t -> length:IntLit.t option -> ?stride:int -> inst_num:int -> dimension:int -> Dom.Mem.astate -> Dom.Mem.astate = @@ -169,11 +179,13 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in let loc = Loc.of_allocsite (Sem.get_allocsite pname node inst_num dimension) in match typ.Typ.desc with - | Typ.Tarray (typ, length, stride) - -> declare_array pname node location loc typ ~length - ?stride:(Option.map ~f:IntLit.to_int stride) ~inst_num ~dimension:(dimension + 1) mem - | _ - -> mem + | Typ.Tarray (typ, length, stride) -> + declare_array pname node location loc typ ~length + ?stride:(Option.map ~f:IntLit.to_int stride) + ~inst_num ~dimension:(dimension + 1) mem + | _ -> + mem + let counter_gen init = let num_ref = ref init in @@ -184,6 +196,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in get_num + let declare_symbolic_val : Typ.Procname.t -> Tenv.t -> CFG.node -> Location.t -> Loc.t -> Typ.typ -> inst_num:int -> new_sym_num:(unit -> int) -> Domain.t -> Domain.t = @@ -195,35 +208,35 @@ module TransferFunctions (CFG : ProcCfg.S) = struct else let depth = depth + 1 in match typ.Typ.desc with - | Typ.Tint ikind - -> let unsigned = Typ.ikind_is_unsigned ikind in + | Typ.Tint ikind -> + let unsigned = Typ.ikind_is_unsigned ikind in let v = Dom.Val.make_sym ~unsigned pname new_sym_num |> Dom.Val.add_trace_elem (Trace.SymAssign location) in Dom.Mem.add_heap loc v mem - | Typ.Tfloat _ - -> let v = + | Typ.Tfloat _ -> + let v = Dom.Val.make_sym pname new_sym_num |> Dom.Val.add_trace_elem (Trace.SymAssign location) in Dom.Mem.add_heap loc v mem - | Typ.Tptr (typ, _) - -> decl_sym_arr ~depth loc location typ mem - | Typ.Tarray (typ, opt_int_lit, _) - -> let opt_size = Option.map ~f:Itv.of_int_lit opt_int_lit in + | Typ.Tptr (typ, _) -> + decl_sym_arr ~depth loc location typ mem + | Typ.Tarray (typ, opt_int_lit, _) -> + let opt_size = Option.map ~f:Itv.of_int_lit opt_int_lit in let opt_offset = Some Itv.zero in decl_sym_arr ~depth loc location typ ~opt_offset ~opt_size mem - | Typ.Tstruct typename - -> let decl_fld mem (fn, typ, _) = + | Typ.Tstruct typename -> + let decl_fld mem (fn, typ, _) = let loc_fld = Loc.append_field loc fn in decl_sym_val ~depth loc_fld typ mem in let decl_flds str = List.fold ~f:decl_fld ~init:mem str.Typ.Struct.fields in let opt_struct = Tenv.lookup tenv typename in Option.value_map opt_struct ~default:mem ~f:decl_flds - | _ - -> if Config.bo_debug >= 3 then + | _ -> + if Config.bo_debug >= 3 then L.(debug BufferOverrun Verbose) "/!\\ decl_fld of unhandled type: %a at %a@." (Typ.pp Pp.text) typ Location.pp (CFG.loc node) ; @@ -245,6 +258,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in decl_sym_val ~depth:0 loc typ mem + let declare_symbolic_parameter : Procdesc.t -> Tenv.t -> CFG.node -> Location.t -> int -> Dom.Mem.astate -> Dom.Mem.astate = fun pdesc tenv node location inst_num mem -> @@ -259,18 +273,20 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in List.fold ~f:add_formal ~init:(mem, inst_num) (Sem.get_formals pdesc) |> fst + let instantiate_ret ret callee_pname callee_exit_mem subst_map mem ret_alias loc = match ret with - | Some (id, _) - -> let ret_loc = Loc.of_pvar (Pvar.get_ret_pvar callee_pname) in + | Some (id, _) -> + let ret_loc = Loc.of_pvar (Pvar.get_ret_pvar callee_pname) in let ret_val = Dom.Mem.find_heap ret_loc callee_exit_mem in let ret_var = Loc.of_var (Var.of_id id) in let add_ret_alias l = Dom.Mem.load_alias id l mem in let mem = Option.value_map ret_alias ~default:mem ~f:add_ret_alias in Dom.Val.subst ret_val subst_map loc |> Dom.Val.add_trace_elem (Trace.Return loc) |> Fn.flip (Dom.Mem.add_stack ret_var) mem - | None - -> mem + | None -> + mem + let instantiate_param tenv pdesc params callee_entry_mem callee_exit_mem subst_map location mem = let formals = Sem.get_formals pdesc in @@ -281,8 +297,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct match typ.Typ.desc with | Typ.Tstruct typename -> ( match Tenv.lookup tenv typename with - | Some str - -> let formal_locs = + | Some str -> + let formal_locs = Dom.Mem.find_heap (Loc.of_pvar (fst formal)) callee_entry_mem |> Dom.Val.get_array_blk |> ArrayBlk.get_pow_loc in @@ -294,10 +310,10 @@ module TransferFunctions (CFG : ProcCfg.S) = struct |> Fn.flip (Dom.Mem.strong_update_heap actual_fields) mem in List.fold ~f:instantiate_fld ~init:mem str.Typ.Struct.fields - | _ - -> mem ) - | _ - -> let formal_locs = + | _ -> + mem ) + | _ -> + let formal_locs = Dom.Mem.find_heap (Loc.of_pvar (fst formal)) callee_entry_mem |> Dom.Val.get_array_blk |> ArrayBlk.get_pow_loc in @@ -305,12 +321,13 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let actual_locs = Dom.Val.get_all_locs actual in Dom.Val.subst v subst_map location |> Fn.flip (Dom.Mem.strong_update_heap actual_locs) mem ) - | _ - -> mem + | _ -> + mem in try List.fold2_exn formals actuals ~init:mem ~f with Invalid_argument _ -> mem + let instantiate_mem : Tenv.t -> (Ident.t * Typ.t) option -> Procdesc.t option -> Typ.Procname.t -> (Exp.t * Typ.t) list -> Dom.Mem.astate -> Dom.Summary.t -> Location.t -> Dom.Mem.astate = @@ -319,14 +336,15 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let callee_exit_mem = Dom.Summary.get_output summary in let callee_ret_alias = Dom.Mem.find_ret_alias callee_exit_mem in match callee_pdesc with - | Some pdesc - -> let subst_map, ret_alias = + | Some pdesc -> + let subst_map, ret_alias = Sem.get_subst_map tenv pdesc params caller_mem callee_entry_mem ~callee_ret_alias loc in instantiate_ret ret callee_pname callee_exit_mem subst_map caller_mem ret_alias loc |> instantiate_param tenv pdesc params callee_entry_mem callee_exit_mem subst_map loc - | None - -> caller_mem + | None -> + caller_mem + let print_debug_info : Sil.instr -> Dom.Mem.astate -> Dom.Mem.astate -> unit = fun instr pre post -> @@ -338,13 +356,14 @@ module TransferFunctions (CFG : ProcCfg.S) = struct L.(debug BufferOverrun Verbose) "@]@\n" ; L.(debug BufferOverrun Verbose) "================================@\n@." + let exec_instr : Dom.Mem.astate -> extras ProcData.t -> CFG.node -> Sil.instr -> Dom.Mem.astate = fun mem {pdesc; tenv; extras} node instr -> let pname = Procdesc.get_proc_name pdesc in let output_mem = match instr with - | Load (id, exp, _, loc) - -> let locs = Sem.eval exp mem loc |> Dom.Val.get_all_locs in + | Load (id, exp, _, loc) -> + let locs = Sem.eval exp mem loc |> Dom.Val.get_all_locs in let v = Dom.Mem.find_heap_set locs mem in if Ident.is_none id then mem else @@ -352,8 +371,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct if PowLoc.is_singleton locs then Dom.Mem.load_simple_alias id (PowLoc.min_elt locs) mem else mem - | Store (exp1, _, exp2, loc) - -> let locs = Sem.eval exp1 mem loc |> Dom.Val.get_all_locs in + | Store (exp1, _, exp2, loc) -> + let locs = Sem.eval exp1 mem loc |> Dom.Val.get_all_locs in let v = Sem.eval exp2 mem loc |> Dom.Val.add_trace_elem (Trace.Assign loc) in let mem = Dom.Mem.update_mem locs v mem in if PowLoc.is_singleton locs then @@ -361,52 +380,54 @@ module TransferFunctions (CFG : ProcCfg.S) = struct match Typ.Procname.get_method pname with | "__inferbo_empty" when Loc.is_return loc_v -> ( match Sem.get_formals pdesc with - | [(formal, _)] - -> let formal_v = Dom.Mem.find_heap (Loc.of_pvar formal) mem in + | [(formal, _)] -> + let formal_v = Dom.Mem.find_heap (Loc.of_pvar formal) mem in Dom.Mem.store_empty_alias formal_v loc_v exp2 mem - | _ - -> assert false ) - | _ - -> Dom.Mem.store_simple_alias loc_v exp2 mem + | _ -> + assert false ) + | _ -> + Dom.Mem.store_simple_alias loc_v exp2 mem else mem - | Prune (exp, loc, _, _) - -> Sem.prune exp loc mem + | Prune (exp, loc, _, _) -> + Sem.prune exp loc mem | Call (ret, Const Cfun callee_pname, params, loc, _) -> ( match Summary.read_summary pdesc callee_pname with - | Some summary - -> let callee = extras callee_pname in + | Some summary -> + let callee = extras callee_pname in instantiate_mem tenv ret callee callee_pname params mem summary loc - | None - -> handle_unknown_call pname ret callee_pname params node mem loc ) - | Declare_locals (locals, location) - -> (* array allocation in stack e.g., int arr[10] *) + | None -> + handle_unknown_call pname ret callee_pname params node mem loc ) + | Declare_locals (locals, location) -> + (* array allocation in stack e.g., int arr[10] *) let try_decl_arr location (mem, inst_num) (pvar, typ) = match typ.Typ.desc with - | Typ.Tarray (typ, length, stride0) - -> let loc = Loc.of_pvar pvar in + | Typ.Tarray (typ, length, stride0) -> + let loc = Loc.of_pvar pvar in let stride = Option.map ~f:IntLit.to_int stride0 in let mem = declare_array pname node location loc typ ~length ?stride ~inst_num ~dimension:1 mem in (mem, inst_num + 1) - | _ - -> (mem, inst_num) + | _ -> + (mem, inst_num) in let mem, inst_num = List.fold ~f:(try_decl_arr location) ~init:(mem, 1) locals in declare_symbolic_parameter pdesc tenv node location inst_num mem - | Call (_, fun_exp, _, loc, _) - -> let () = + | Call (_, fun_exp, _, loc, _) -> + let () = L.(debug BufferOverrun Verbose) "/!\\ Call to non-const function %a at %a" Exp.pp fun_exp Location.pp loc in mem - | Remove_temps (temps, _) - -> Dom.Mem.remove_temps temps mem - | Abstract _ | Nullify _ - -> mem + | Remove_temps (temps, _) -> + Dom.Mem.remove_temps temps mem + | Abstract _ | Nullify _ -> + mem in - print_debug_info instr mem output_mem ; output_mem + print_debug_info instr mem output_mem ; + output_mem + end module Analyzer = AbstractInterpreter.Make (ProcCfg.Normal) (TransferFunctions) @@ -422,13 +443,13 @@ module Report = struct fun pname node exp loc mem cond_set -> let array_access = match exp with - | Exp.Var _ - -> let v = Sem.eval exp mem loc in + | Exp.Var _ -> + let v = Sem.eval exp mem loc in let arr = Dom.Val.get_array_blk v in let arr_traces = Dom.Val.get_traces v in Some (arr, arr_traces, Itv.zero, TraceSet.empty, true) - | Exp.Lindex (e1, e2) - -> let locs = Sem.eval_locs e1 mem loc |> Dom.Val.get_all_locs in + | Exp.Lindex (e1, e2) -> + let locs = Sem.eval_locs e1 mem loc |> Dom.Val.get_all_locs in let v_arr = Dom.Mem.find_set locs mem in let arr = Dom.Val.get_array_blk v_arr in let arr_traces = Dom.Val.get_traces v_arr in @@ -436,8 +457,8 @@ module Report = struct let idx = Dom.Val.get_itv v_idx in let idx_traces = Dom.Val.get_traces v_idx in Some (arr, arr_traces, idx, idx_traces, true) - | Exp.BinOp ((Binop.PlusA as bop), e1, e2) | Exp.BinOp ((Binop.MinusA as bop), e1, e2) - -> let v_arr = Sem.eval e1 mem loc in + | Exp.BinOp ((Binop.PlusA as bop), e1, e2) | Exp.BinOp ((Binop.MinusA as bop), e1, e2) -> + let v_arr = Sem.eval e1 mem loc in let arr = Dom.Val.get_array_blk v_arr in let arr_traces = Dom.Val.get_traces v_arr in let v_idx = Sem.eval e2 mem loc in @@ -445,12 +466,12 @@ module Report = struct let idx_traces = Dom.Val.get_traces v_idx in let is_plus = Binop.equal bop Binop.PlusA in Some (arr, arr_traces, idx, idx_traces, is_plus) - | _ - -> None + | _ -> + None in match array_access with | Some (arr, traces_arr, idx, traces_idx, is_plus) - -> ( + -> ( let site = Sem.get_allocsite pname node 0 0 in let size = ArrayBlk.sizeof arr in let offset = ArrayBlk.offsetof arr in @@ -460,13 +481,14 @@ module Report = struct L.(debug BufferOverrun Verbose) " idx: %a@," Itv.pp idx ; L.(debug BufferOverrun Verbose) "@]@." ; match (size, idx) with - | NonBottom size, NonBottom idx - -> let traces = TraceSet.merge ~traces_arr ~traces_idx loc in + | NonBottom size, NonBottom idx -> + let traces = TraceSet.merge ~traces_arr ~traces_idx loc in PO.ConditionSet.add_bo_safety pname loc site ~size ~idx traces cond_set - | _ - -> cond_set ) - | None - -> cond_set + | _ -> + cond_set ) + | None -> + cond_set + let instantiate_cond : Tenv.t -> Typ.Procname.t -> Procdesc.t option -> (Exp.t * Typ.t) list -> Dom.Mem.astate @@ -475,15 +497,16 @@ module Report = struct let callee_entry_mem = Dom.Summary.get_input summary in let callee_cond = Dom.Summary.get_cond_set summary in match callee_pdesc with - | Some pdesc - -> let subst_map, _ = + | Some pdesc -> + let subst_map, _ = Sem.get_subst_map tenv pdesc params caller_mem callee_entry_mem ~callee_ret_alias:None loc in let pname = Procdesc.get_proc_name pdesc in PO.ConditionSet.subst callee_cond subst_map caller_pname pname loc - | _ - -> callee_cond + | _ -> + callee_cond + let print_debug_info : Sil.instr -> Dom.Mem.astate -> PO.ConditionSet.t -> unit = fun instr pre cond_set -> @@ -494,6 +517,7 @@ module Report = struct L.(debug BufferOverrun Verbose) "@]@\n" ; L.(debug BufferOverrun Verbose) "================================@\n@." + module ExitStatement = struct let successors node = Procdesc.Node.get_succs node @@ -502,15 +526,17 @@ module Report = struct let preds_of_singleton_successor node = match successors node with [succ] -> Some (predecessors succ) | _ -> None + (* last statement in if branch *) (* do we transfer control to a node with multiple predecessors *) let has_multiple_sibling_nodes_and_one_successor node = match preds_of_singleton_successor node with (* we need at least 2 predecessors *) - | Some (_ :: _ :: _) - -> true - | _ - -> false + | Some (_ :: _ :: _) -> + true + | _ -> + false + (* check that we are the last instruction in the current node * and that the current node is followed by a unique successor @@ -525,12 +551,13 @@ module Report = struct match Procdesc.Node.get_succs node with | [succ] -> ( match CFG.instrs succ with - | [] - -> List.is_empty (Procdesc.Node.get_succs succ) - | _ - -> false ) - | _ - -> false + | [] -> + List.is_empty (Procdesc.Node.get_succs succ) + | _ -> + false ) + | _ -> + false + end let rec collect_instrs @@ -538,34 +565,34 @@ module Report = struct -> PO.ConditionSet.t = fun ({pdesc; tenv; extras} as pdata) node instrs mem cond_set -> match instrs with - | [] - -> cond_set - | instr :: rem_instrs - -> let pname = Procdesc.get_proc_name pdesc in + | [] -> + cond_set + | instr :: rem_instrs -> + let pname = Procdesc.get_proc_name pdesc in let cond_set = match instr with - | Sil.Load (_, exp, _, loc) | Sil.Store (exp, _, _, loc) - -> add_condition pname node exp loc mem cond_set + | Sil.Load (_, exp, _, loc) | Sil.Store (exp, _, _, loc) -> + add_condition pname node exp loc mem cond_set | Sil.Call (_, Const Cfun callee_pname, params, loc, _) -> ( match Summary.read_summary pdesc callee_pname with - | Some summary - -> let callee = extras callee_pname in + | Some summary -> + let callee = extras callee_pname in instantiate_cond tenv pname callee params mem summary loc |> PO.ConditionSet.join cond_set - | _ - -> cond_set ) - | _ - -> cond_set + | _ -> + cond_set ) + | _ -> + cond_set in let mem' = Analyzer.TransferFunctions.exec_instr mem pdata node instr in let () = match (mem, mem') with | NonBottom _, Bottom -> ( match instr with - | Sil.Prune (_, _, _, (Ik_land_lor | Ik_bexp)) - -> () - | Sil.Prune (cond, loc, true_branch, _) - -> let i = match cond with Exp.Const Const.Cint i -> i | _ -> IntLit.zero in + | Sil.Prune (_, _, _, (Ik_land_lor | Ik_bexp)) -> + () + | Sil.Prune (cond, loc, true_branch, _) -> + let i = match cond with Exp.Const Const.Cint i -> i | _ -> IntLit.zero in let desc = Errdesc.explain_condition_always_true_false tenv i cond node loc in let exn = Exceptions.Condition_always_true_false (desc, not true_branch, __POS__) @@ -575,72 +602,77 @@ module Report = struct | Sil.Call (_, Const Cfun pname, _, _, _) when String.equal (Typ.Procname.get_method pname) "exit" && ExitStatement.is_last_in_node_and_followed_by_empty_successor node - rem_instrs - -> () + rem_instrs -> + () | Sil.Call (_, Const Cfun pname, _, _, _) when String.equal (Typ.Procname.get_method pname) "exit" - && ExitStatement.has_multiple_sibling_nodes_and_one_successor node - -> () - | _ - -> let loc = Sil.instr_get_loc instr in + && ExitStatement.has_multiple_sibling_nodes_and_one_successor node -> + () + | _ -> + let loc = Sil.instr_get_loc instr in let desc = Errdesc.explain_unreachable_code_after loc in let exn = Exceptions.Unreachable_code_after (desc, __POS__) in Reporting.log_error_deprecated pname ~loc exn ) - | _ - -> () + | _ -> + () in - print_debug_info instr mem' cond_set ; collect_instrs pdata node rem_instrs mem' cond_set + print_debug_info instr mem' cond_set ; + collect_instrs pdata node rem_instrs mem' cond_set + let collect_node : extras ProcData.t -> Analyzer.invariant_map -> PO.ConditionSet.t -> CFG.node -> PO.ConditionSet.t = fun pdata inv_map cond_set node -> match Analyzer.extract_pre (CFG.id node) inv_map with - | Some mem - -> let instrs = CFG.instrs node in + | Some mem -> + let instrs = CFG.instrs node in collect_instrs pdata node instrs mem cond_set - | _ - -> cond_set + | _ -> + cond_set + let collect : extras ProcData.t -> Analyzer.invariant_map -> PO.ConditionSet.t = fun ({pdesc} as pdata) inv_map -> let add_node1 acc node = collect_node pdata inv_map acc node in Procdesc.fold_nodes add_node1 PO.ConditionSet.empty pdesc + let make_err_trace : Trace.t -> string -> Errlog.loc_trace = fun trace desc -> let f elem (trace, depth) = match elem with - | Trace.Assign loc - -> (Errlog.make_trace_element depth loc "Assignment" [] :: trace, depth) - | Trace.ArrDecl loc - -> (Errlog.make_trace_element depth loc "ArrayDeclaration" [] :: trace, depth) - | Trace.Call loc - -> (Errlog.make_trace_element depth loc "Call" [] :: trace, depth + 1) - | Trace.Return loc - -> (Errlog.make_trace_element (depth - 1) loc "Return" [] :: trace, depth - 1) - | Trace.SymAssign _ - -> (trace, depth) - | Trace.ArrAccess loc - -> (Errlog.make_trace_element depth loc ("ArrayAccess: " ^ desc) [] :: trace, depth) + | Trace.Assign loc -> + (Errlog.make_trace_element depth loc "Assignment" [] :: trace, depth) + | Trace.ArrDecl loc -> + (Errlog.make_trace_element depth loc "ArrayDeclaration" [] :: trace, depth) + | Trace.Call loc -> + (Errlog.make_trace_element depth loc "Call" [] :: trace, depth + 1) + | Trace.Return loc -> + (Errlog.make_trace_element (depth - 1) loc "Return" [] :: trace, depth - 1) + | Trace.SymAssign _ -> + (trace, depth) + | Trace.ArrAccess loc -> + (Errlog.make_trace_element depth loc ("ArrayAccess: " ^ desc) [] :: trace, depth) in List.fold_right ~f ~init:([], 0) trace.trace |> fst |> List.rev + let report_error : Procdesc.t -> PO.ConditionSet.t -> unit = fun pdesc conds -> let pname = Procdesc.get_proc_name pdesc in let report1 cond trace = let alarm = PO.Condition.check cond in match alarm with - | None - -> () - | Some issue_type - -> let caller_pname, loc = + | None -> + () + | Some issue_type -> + let caller_pname, loc = match PO.ConditionTrace.get_cond_trace trace with - | PO.ConditionTrace.Inter (caller_pname, _, loc) - -> (caller_pname, loc) - | PO.ConditionTrace.Intra pname - -> (pname, PO.ConditionTrace.get_location trace) + | PO.ConditionTrace.Inter (caller_pname, _, loc) -> + (caller_pname, loc) + | PO.ConditionTrace.Intra pname -> + (pname, PO.ConditionTrace.get_location trace) in if Typ.Procname.equal pname caller_pname then let description = PO.description cond trace in @@ -648,14 +680,15 @@ module Report = struct let exn = Exceptions.Checkers (issue_type.IssueType.unique_id, error_desc) in let trace = match TraceSet.choose_shortest trace.PO.ConditionTrace.val_traces with - | trace - -> make_err_trace trace description - | exception _ - -> [Errlog.make_trace_element 0 loc description []] + | trace -> + make_err_trace trace description + | exception _ -> + [Errlog.make_trace_element 0 loc description []] in Reporting.log_error_deprecated pname ~loc ~ltr:trace exn in PO.ConditionSet.iter conds ~f:report1 + end let compute_post : Analyzer.TransferFunctions.extras ProcData.t -> Summary.payload option = @@ -674,24 +707,27 @@ let compute_post : Analyzer.TransferFunctions.extras ProcData.t -> Summary.paylo let cond_set = Report.collect pdata inv_map in Report.report_error pdesc cond_set ; match (entry_mem, exit_mem) with - | Some entry_mem, Some exit_mem - -> Some (entry_mem, exit_mem, cond_set) - | _ - -> None + | Some entry_mem, Some exit_mem -> + Some (entry_mem, exit_mem, cond_set) + | _ -> + None + let print_summary : Typ.Procname.t -> Dom.Summary.t -> unit = fun proc_name s -> L.(debug BufferOverrun Medium) "@\n@[Summary of %a :@,%a@]@." Typ.Procname.pp proc_name Dom.Summary.pp_summary s + let checker : Callbacks.proc_callback_args -> Specs.summary = fun {proc_desc; tenv; summary; get_proc_desc} -> let proc_name = Specs.get_proc_name summary in let proc_data = ProcData.make proc_desc tenv get_proc_desc in if not (Procdesc.did_preanalysis proc_desc) then Preanal.do_liveness proc_desc tenv ; match compute_post proc_data with - | Some post - -> if Config.bo_debug >= 1 then print_summary proc_name post ; + | Some post -> + if Config.bo_debug >= 1 then print_summary proc_name post ; Summary.update_summary post summary - | None - -> summary + | None -> + summary + diff --git a/infer/src/bufferoverrun/bufferOverrunDomain.ml b/infer/src/bufferoverrun/bufferOverrunDomain.ml index 67a5e638f..2e09b54eb 100644 --- a/infer/src/bufferoverrun/bufferOverrunDomain.ml +++ b/infer/src/bufferoverrun/bufferOverrunDomain.ml @@ -39,6 +39,7 @@ module Val = struct F.fprintf fmt "(%a, %a, %a, %a)" Itv.pp x.itv PowLoc.pp x.powloc ArrayBlk.pp x.arrayblk TraceSet.pp x.traces + let unknown : t = {bot with itv= Itv.top; powloc= PowLoc.unknown; arrayblk= ArrayBlk.unknown} let ( <= ) ~lhs ~rhs = @@ -46,6 +47,7 @@ module Val = struct else Itv.( <= ) ~lhs:lhs.itv ~rhs:rhs.itv && PowLoc.( <= ) ~lhs:lhs.powloc ~rhs:rhs.powloc && ArrayBlk.( <= ) ~lhs:lhs.arrayblk ~rhs:rhs.arrayblk + let widen ~prev ~next ~num_iters = if phys_equal prev next then prev else @@ -54,6 +56,7 @@ module Val = struct ; arrayblk= ArrayBlk.widen ~prev:prev.arrayblk ~next:next.arrayblk ~num_iters ; traces= TraceSet.join prev.traces next.traces } + let join : t -> t -> t = fun x y -> if phys_equal x y then x @@ -63,6 +66,7 @@ module Val = struct ; arrayblk= ArrayBlk.join x.arrayblk y.arrayblk ; traces= TraceSet.join x.traces y.traces } + let rec joins : t list -> t = function [] -> bot | [a] -> a | a :: b -> join a (joins b) let get_itv : t -> Itv.t = fun x -> x.itv @@ -95,6 +99,7 @@ module Val = struct fun ?(unsigned= false) pname new_sym_num -> {bot with itv= Itv.make_sym ~unsigned pname new_sym_num} + let unknown_bit : t -> t = fun x -> {x with itv= Itv.top} let neg : t -> t = fun x -> {x with itv= Itv.neg x.itv} @@ -104,12 +109,14 @@ module Val = struct let lift_itv : (Itv.t -> Itv.t -> Itv.t) -> t -> t -> t = fun f x y -> {bot with itv= f x.itv y.itv} + let has_pointer : t -> bool = fun x -> not (PowLoc.is_bot x.powloc && ArrayBlk.is_bot x.arrayblk) let lift_cmp_itv : (Itv.t -> Itv.t -> Itv.t) -> t -> t -> t = fun f x y -> if has_pointer x || has_pointer y then {bot with itv= Itv.unknown_bool} else lift_itv f x y + let plus : t -> t -> t = fun x y -> { x with @@ -117,18 +124,22 @@ module Val = struct ; arrayblk= ArrayBlk.plus_offset x.arrayblk y.itv ; traces= TraceSet.join x.traces y.traces } + let minus : t -> t -> t = fun x y -> let n = Itv.join (Itv.minus x.itv y.itv) (ArrayBlk.diff x.arrayblk y.arrayblk) in let a = ArrayBlk.minus_offset x.arrayblk y.itv in {bot with itv= n; arrayblk= a; traces= TraceSet.join x.traces y.traces} + let mult : t -> t -> t = fun x y -> {(lift_itv Itv.mult x y) with traces= TraceSet.join x.traces y.traces} + let div : t -> t -> t = fun x y -> {(lift_itv Itv.div x y) with traces= TraceSet.join x.traces y.traces} + let mod_sem : t -> t -> t = lift_itv Itv.mod_sem let shiftlt : t -> t -> t = lift_itv Itv.shiftlt @@ -162,11 +173,13 @@ module Val = struct ; arrayblk= g x.arrayblk y.arrayblk ; traces= TraceSet.join x.traces y.traces } + let prune_zero : t -> t = lift_prune1 Itv.prune_zero let prune_comp : Binop.t -> t -> t -> t = fun c -> lift_prune2 (Itv.prune_comp c) (ArrayBlk.prune_comp c) + let prune_eq : t -> t -> t = lift_prune2 Itv.prune_eq ArrayBlk.prune_eq let prune_ne : t -> t -> t = lift_prune2 Itv.prune_ne ArrayBlk.prune_eq @@ -174,6 +187,7 @@ module Val = struct let lift_pi : (ArrayBlk.astate -> Itv.t -> ArrayBlk.astate) -> t -> t -> t = fun f x y -> {bot with arrayblk= f x.arrayblk y.itv; traces= TraceSet.join x.traces y.traces} + let plus_pi : t -> t -> t = fun x y -> lift_pi ArrayBlk.plus_offset x y let minus_pi : t -> t -> t = fun x y -> lift_pi ArrayBlk.minus_offset x y @@ -187,12 +201,15 @@ module Val = struct else {bot with itv= ArrayBlk.diff x.arrayblk y.arrayblk; traces= TraceSet.join x.traces y.traces} + let get_symbols : t -> Itv.Symbol.t list = fun x -> List.append (Itv.get_symbols x.itv) (ArrayBlk.get_symbols x.arrayblk) + let normalize : t -> t = fun x -> {x with itv= Itv.normalize x.itv; arrayblk= ArrayBlk.normalize x.arrayblk} + let subst : t -> Itv.Bound.t bottom_lifted Itv.SubstMap.t * TraceSet.t Itv.SubstMap.t -> Location.t -> t = @@ -209,6 +226,7 @@ module Val = struct {x with itv= Itv.subst x.itv bound_map; arrayblk= ArrayBlk.subst x.arrayblk bound_map; traces} |> normalize + (* normalize bottom *) let add_trace_elem : Trace.elem -> t -> t = @@ -216,14 +234,17 @@ module Val = struct let traces = TraceSet.add_elem elem x.traces in {x with traces} + let add_trace_elem_last : Trace.elem -> t -> t = fun elem x -> let traces = TraceSet.add_elem_last elem x.traces in {x with traces} + let pp_summary : F.formatter -> t -> unit = fun fmt x -> F.fprintf fmt "(%a, %a)" Itv.pp x.itv ArrayBlk.pp x.arrayblk + module Itv = struct let nat = of_itv Itv.nat @@ -245,17 +266,21 @@ module Stack = struct try find l m with Not_found -> Val.bot + let find_set : PowLoc.t -> astate -> Val.t = fun locs mem -> let find_join loc acc = Val.join acc (find loc mem) in PowLoc.fold find_join locs Val.bot + let strong_update : PowLoc.t -> Val.astate -> astate -> astate = fun locs v mem -> PowLoc.fold (fun x -> add x v) locs mem + let weak_update : PowLoc.t -> Val.astate -> astate -> astate = fun locs v mem -> PowLoc.fold (fun x -> add x (Val.join v (find x mem))) locs mem + let pp_summary : F.formatter -> astate -> unit = fun fmt mem -> let pp_not_logical_var k v = @@ -263,6 +288,7 @@ module Stack = struct in iter pp_not_logical_var mem + let remove_temps : Ident.t list -> astate -> astate = fun temps mem -> let remove_temp mem temp = @@ -270,6 +296,7 @@ module Stack = struct remove temp_loc mem in List.fold temps ~init:mem ~f:remove_temp + end module Heap = struct @@ -281,12 +308,14 @@ module Heap = struct let pp_sep fmt () = F.fprintf fmt ",@," in F.pp_print_list ~pp_sep pp_item fmt c + let pp : pp_value:(F.formatter -> 'a -> unit) -> F.formatter -> 'a t -> unit = fun ~pp_value fmt m -> let pp_item fmt (k, v) = F.fprintf fmt "%a -> %a" Loc.pp k pp_value v in F.fprintf fmt "@[{ " ; pp_collection ~pp_item fmt (bindings m) ; F.fprintf fmt " }@]" + end include AbstractDomain.Map (Loc) (Val) @@ -298,17 +327,21 @@ module Heap = struct try find l m with Not_found -> Val.Itv.top + let find_set : PowLoc.t -> astate -> Val.t = fun locs mem -> let find_join loc acc = Val.join acc (find loc mem) in PowLoc.fold find_join locs Val.bot + let strong_update : PowLoc.t -> Val.t -> astate -> astate = fun locs v mem -> PowLoc.fold (fun x -> add x v) locs mem + let weak_update : PowLoc.t -> Val.t -> astate -> astate = fun locs v mem -> PowLoc.fold (fun x -> add x (Val.join v (find x mem))) locs mem + let pp_summary : F.formatter -> astate -> unit = fun fmt mem -> let pp_map fmt (k, v) = F.fprintf fmt "%a -> %a" Loc.pp k Val.pp_summary v in @@ -316,13 +349,16 @@ module Heap = struct F.pp_print_list pp_map fmt (bindings mem) ; F.fprintf fmt " }@]" + let get_symbols : astate -> Itv.Symbol.t list = fun mem -> List.concat_map ~f:(fun (_, v) -> Val.get_symbols v) (bindings mem) + let get_return : astate -> Val.t = fun mem -> let mem = filter (fun l _ -> Loc.is_return l) mem in if is_empty mem then Val.bot else snd (choose mem) + end module AliasTarget = struct @@ -371,22 +407,25 @@ module AliasMap = struct in M.for_all is_in_rhs lhs + let join : t -> t -> t = fun x y -> let join_v _ v1_opt v2_opt = match (v1_opt, v2_opt) with - | None, None - -> None - | Some v, None | None, Some v - -> Some v - | Some v1, Some v2 - -> if AliasTarget.equal v1 v2 then Some v1 else assert false + | None, None -> + None + | Some v, None | None, Some v -> + Some v + | Some v1, Some v2 -> + if AliasTarget.equal v1 v2 then Some v1 else assert false in M.merge join_v x y + let widen : prev:t -> next:t -> num_iters:int -> t = fun ~prev ~next ~num_iters:_ -> join prev next + let pp : F.formatter -> t -> unit = fun fmt x -> let pp_sep fmt () = F.fprintf fmt ", @," in @@ -397,20 +436,24 @@ module AliasMap = struct F.fprintf fmt " }@]" ; F.fprintf fmt "@]" + let load : Ident.t -> AliasTarget.t -> t -> t = fun id loc m -> M.add id loc m let store : Loc.t -> Exp.t -> t -> t = fun l _ m -> M.filter (fun _ y -> not (AliasTarget.use l y)) m + let find : Ident.t -> t -> AliasTarget.t option = fun k m -> try Some (M.find k m) with Not_found -> None + let remove_temps : Ident.t list -> t -> t = fun temps m -> let remove_temp m temp = M.remove temp m in List.fold temps ~init:m ~f:remove_temp + end module AliasRet = struct @@ -421,35 +464,39 @@ module AliasRet = struct let ( <= ) : lhs:astate -> rhs:astate -> bool = fun ~lhs ~rhs -> match (lhs, rhs) with - | Bot, _ | _, Top - -> true - | Top, _ | _, Bot - -> false - | L loc1, L loc2 - -> AliasTarget.equal loc1 loc2 + | Bot, _ | _, Top -> + true + | Top, _ | _, Bot -> + false + | L loc1, L loc2 -> + AliasTarget.equal loc1 loc2 + let join : astate -> astate -> astate = fun x y -> match (x, y) with - | Top, _ | _, Top - -> Top - | Bot, a | a, Bot - -> a - | L loc1, L loc2 - -> if AliasTarget.equal loc1 loc2 then x else Top + | Top, _ | _, Top -> + Top + | Bot, a | a, Bot -> + a + | L loc1, L loc2 -> + if AliasTarget.equal loc1 loc2 then x else Top + let widen : prev:astate -> next:astate -> num_iters:int -> astate = fun ~prev ~next ~num_iters:_ -> join prev next + let pp : F.formatter -> astate -> unit = fun fmt x -> match x with - | Top - -> F.fprintf fmt "T" - | L loc - -> AliasTarget.pp fmt loc - | Bot - -> F.fprintf fmt "_|_" + | Top -> + F.fprintf fmt "T" + | L loc -> + AliasTarget.pp fmt loc + | Bot -> + F.fprintf fmt "_|_" + let find : astate -> AliasTarget.t option = fun x -> match x with L loc -> Some loc | _ -> None end @@ -462,6 +509,7 @@ module Alias = struct let lift : (AliasMap.astate -> AliasMap.astate) -> astate -> astate = fun f a -> (f (fst a), snd a) + let lift_v : (AliasMap.astate -> 'a) -> astate -> 'a = fun f a -> f (fst a) let find : Ident.t -> astate -> AliasTarget.t option = fun x -> lift_v (AliasMap.find x) @@ -471,15 +519,17 @@ module Alias = struct let load : Ident.t -> AliasTarget.t -> astate -> astate = fun id loc -> lift (AliasMap.load id loc) + let store_simple : Loc.t -> Exp.t -> astate -> astate = fun loc e a -> let a = lift (AliasMap.store loc e) a in match e with - | Exp.Var l when Loc.is_return loc - -> let update_ret retl = (fst a, AliasRet.L retl) in + | Exp.Var l when Loc.is_return loc -> + let update_ret retl = (fst a, AliasRet.L retl) in Option.value_map (find l a) ~default:a ~f:update_ret - | _ - -> a + | _ -> + a + let store_empty : Val.t -> Loc.t -> Exp.t -> astate -> astate = fun formal loc e a -> @@ -489,8 +539,10 @@ module Alias = struct (fst a, AliasRet.L (AliasTarget.of_empty (PowLoc.min_elt locs))) else a + let remove_temps : Ident.t list -> astate -> astate = fun temps a -> (AliasMap.remove_temps temps (fst a), snd a) + end module MemReach = struct @@ -505,6 +557,7 @@ module MemReach = struct else Stack.( <= ) ~lhs:lhs.stack ~rhs:rhs.stack && Heap.( <= ) ~lhs:lhs.heap ~rhs:rhs.heap && Alias.( <= ) ~lhs:lhs.alias ~rhs:rhs.alias + let widen ~prev ~next ~num_iters = if phys_equal prev next then prev else @@ -512,12 +565,14 @@ module MemReach = struct ; heap= Heap.widen ~prev:prev.heap ~next:next.heap ~num_iters ; alias= Alias.widen ~prev:prev.alias ~next:next.alias ~num_iters } + let join : t -> t -> t = fun x y -> { stack= Stack.join x.stack y.stack ; heap= Heap.join x.heap y.heap ; alias= Alias.join x.alias y.alias } + let pp : F.formatter -> t -> unit = fun fmt x -> F.fprintf fmt "Stack:@;" ; @@ -525,12 +580,14 @@ module MemReach = struct F.fprintf fmt "Heap:@;" ; F.fprintf fmt "%a" Heap.pp x.heap + let pp_summary : F.formatter -> t -> unit = fun fmt x -> F.fprintf fmt "@[Parameters:@," ; F.fprintf fmt "%a" Heap.pp_summary x.heap ; F.fprintf fmt "@]" + let find_stack : Loc.t -> t -> Val.t = fun k m -> Stack.find k m.stack let find_stack_set : PowLoc.t -> t -> Val.t = fun k m -> Stack.find_set k m.stack @@ -542,27 +599,32 @@ module MemReach = struct let find_set : PowLoc.t -> t -> Val.t = fun k m -> Val.join (find_stack_set k m) (find_heap_set k m) + let find_alias : Ident.t -> t -> AliasTarget.t option = fun k m -> Alias.find k m.alias let find_simple_alias : Ident.t -> t -> Loc.t option = fun k m -> match Alias.find k m.alias with - | Some AliasTarget.Simple l - -> Some l - | Some AliasTarget.Empty _ | None - -> None + | Some AliasTarget.Simple l -> + Some l + | Some AliasTarget.Empty _ | None -> + None + let find_ret_alias : t -> AliasTarget.t option = fun m -> Alias.find_ret m.alias let load_alias : Ident.t -> AliasTarget.t -> t -> t = fun id loc m -> {m with alias= Alias.load id loc m.alias} + let store_simple_alias : Loc.t -> Exp.t -> t -> t = fun loc e m -> {m with alias= Alias.store_simple loc e m.alias} + let store_empty_alias : Val.t -> Loc.t -> Exp.t -> t -> t = fun formal loc e m -> {m with alias= Alias.store_empty formal loc e m.alias} + let add_stack : Loc.t -> Val.t -> t -> t = fun k v m -> {m with stack= Stack.add k v m.stack} let add_heap : Loc.t -> Val.t -> t -> t = fun k v m -> {m with heap= Heap.add k v m.heap} @@ -570,15 +632,19 @@ module MemReach = struct let strong_update_stack : PowLoc.t -> Val.t -> t -> t = fun p v m -> {m with stack= Stack.strong_update p v m.stack} + let strong_update_heap : PowLoc.t -> Val.t -> t -> t = fun p v m -> {m with heap= Heap.strong_update p v m.heap} + let weak_update_stack : PowLoc.t -> Val.t -> t -> t = fun p v m -> {m with stack= Stack.weak_update p v m.stack} + let weak_update_heap : PowLoc.t -> Val.t -> t -> t = fun p v m -> {m with heap= Heap.weak_update p v m.heap} + let get_heap_symbols : t -> Itv.Symbol.t list = fun m -> Heap.get_symbols m.heap let get_return : t -> Val.t = fun m -> Heap.get_return m.heap @@ -589,6 +655,7 @@ module MemReach = struct else if Int.equal (PowLoc.cardinal ploc) 1 then Loc.is_var (PowLoc.choose ploc) else false + let update_mem : PowLoc.t -> Val.t -> t -> t = fun ploc v s -> if can_strong_update ploc then strong_update_heap ploc v s @@ -598,9 +665,11 @@ module MemReach = struct in weak_update_heap ploc v s + let remove_temps : Ident.t list -> t -> t = fun temps m -> {m with stack= Stack.remove_temps temps m.stack; alias= Alias.remove_temps temps m.alias} + end module Mem = struct @@ -615,49 +684,60 @@ module Mem = struct let f_lift_default : 'a -> (MemReach.t -> 'a) -> t -> 'a = fun default f m -> match m with Bottom -> default | NonBottom m' -> f m' + let f_lift : (MemReach.t -> MemReach.t) -> t -> t = fun f -> f_lift_default Bottom (fun m' -> NonBottom (f m')) + let pp_summary : F.formatter -> t -> unit = fun fmt m -> match m with - | Bottom - -> F.fprintf fmt "unreachable" - | NonBottom m' - -> MemReach.pp_summary fmt m' + | Bottom -> + F.fprintf fmt "unreachable" + | NonBottom m' -> + MemReach.pp_summary fmt m' + let find_stack : Loc.t -> t -> Val.t = fun k -> f_lift_default Val.bot (MemReach.find_stack k) let find_stack_set : PowLoc.t -> t -> Val.t = fun k -> f_lift_default Val.bot (MemReach.find_stack_set k) + let find_heap : Loc.t -> t -> Val.t = fun k -> f_lift_default Val.bot (MemReach.find_heap k) let find_heap_set : PowLoc.t -> t -> Val.t = fun k -> f_lift_default Val.bot (MemReach.find_heap_set k) + let find_set : PowLoc.t -> t -> Val.t = fun k -> f_lift_default Val.bot (MemReach.find_set k) let find_alias : Ident.t -> t -> AliasTarget.t option = fun k -> f_lift_default None (MemReach.find_alias k) + let find_simple_alias : Ident.t -> t -> Loc.t option = fun k -> f_lift_default None (MemReach.find_simple_alias k) + let find_ret_alias : t -> AliasTarget.t option = f_lift_default None MemReach.find_ret_alias let load_alias : Ident.t -> AliasTarget.t -> t -> t = fun id loc -> f_lift (MemReach.load_alias id loc) + let load_simple_alias : Ident.t -> Loc.t -> t -> t = fun id loc -> load_alias id (AliasTarget.Simple loc) + let store_simple_alias : Loc.t -> Exp.t -> t -> t = fun loc e -> f_lift (MemReach.store_simple_alias loc e) + let store_empty_alias : Val.t -> Loc.t -> Exp.t -> t -> t = fun formal loc e -> f_lift (MemReach.store_empty_alias formal loc e) + let add_stack : Loc.t -> Val.t -> t -> t = fun k v -> f_lift (MemReach.add_stack k v) let add_heap : Loc.t -> Val.t -> t -> t = fun k v -> f_lift (MemReach.add_heap k v) @@ -665,15 +745,19 @@ module Mem = struct let strong_update_stack : PowLoc.t -> Val.t -> t -> t = fun p v -> f_lift (MemReach.strong_update_stack p v) + let strong_update_heap : PowLoc.t -> Val.t -> t -> t = fun p v -> f_lift (MemReach.strong_update_heap p v) + let weak_update_stack : PowLoc.t -> Val.t -> t -> t = fun p v -> f_lift (MemReach.weak_update_stack p v) + let weak_update_heap : PowLoc.t -> Val.t -> t -> t = fun p v -> f_lift (MemReach.weak_update_heap p v) + let get_heap_symbols : t -> Itv.Symbol.t list = f_lift_default [] MemReach.get_heap_symbols let get_return : t -> Val.t = f_lift_default Val.bot MemReach.get_return @@ -705,18 +789,22 @@ module Summary = struct F.pp_print_list ~pp_sep Itv.Symbol.pp fmt (get_symbols s) ; F.fprintf fmt "}@]" + let pp_symbol_map : F.formatter -> t -> unit = fun fmt s -> Mem.pp_summary fmt (get_input s) let pp_return : F.formatter -> t -> unit = fun fmt s -> F.fprintf fmt "Return value: %a" Val.pp_summary (get_return s) + let pp_summary : F.formatter -> t -> unit = fun fmt s -> F.fprintf fmt "%a@,%a@,%a" pp_symbol_map s pp_return s PO.ConditionSet.pp_summary (get_cond_set s) + let pp : F.formatter -> t -> unit = fun fmt (entry_mem, exit_mem, condition_set) -> F.fprintf fmt "%a@,%a@,%a@," Mem.pp entry_mem Mem.pp exit_mem PO.ConditionSet.pp condition_set + end diff --git a/infer/src/bufferoverrun/bufferOverrunProofObligations.ml b/infer/src/bufferoverrun/bufferOverrunProofObligations.ml index f52cead60..2a65810d1 100644 --- a/infer/src/bufferoverrun/bufferOverrunProofObligations.ml +++ b/infer/src/bufferoverrun/bufferOverrunProofObligations.ml @@ -25,66 +25,72 @@ module Condition = struct let size' = ItvPure.make_positive c.size in if phys_equal size' c.size then c else {c with size= size'} + let pp : F.formatter -> t -> unit = fun fmt c -> let c = set_size_pos c in F.fprintf fmt "%a < %a" ItvPure.pp c.idx ItvPure.pp c.size + let pp_description : F.formatter -> t -> unit = fun fmt c -> let c = set_size_pos c in F.fprintf fmt "Offset: %a Size: %a" ItvPure.pp c.idx ItvPure.pp c.size + let make : idx:ItvPure.t -> size:ItvPure.t -> t option = fun ~idx ~size -> if ItvPure.is_invalid idx || ItvPure.is_invalid size then None else Some {idx; size} + let have_similar_bounds {idx= lidx; size= lsiz} {idx= ridx; size= rsiz} = ItvPure.have_similar_bounds lidx ridx && ItvPure.have_similar_bounds lsiz rsiz + let xcompare ~lhs:{idx= lidx; size= lsiz} ~rhs:{idx= ridx; size= rsiz} = let idxcmp = ItvPure.xcompare ~lhs:lidx ~rhs:ridx in let sizcmp = ItvPure.xcompare ~lhs:lsiz ~rhs:rsiz in match (idxcmp, sizcmp) with - | `Equal, `Equal - -> `Equal - | `NotComparable, _ - -> `NotComparable - | `Equal, (`LeftSmallerThanRight | `LeftSubsumesRight) - -> `LeftSubsumesRight - | `Equal, (`RightSmallerThanLeft | `RightSubsumesLeft) - -> `RightSubsumesLeft - | `LeftSubsumesRight, (`Equal | `LeftSubsumesRight) - -> `LeftSubsumesRight - | `RightSubsumesLeft, (`Equal | `RightSubsumesLeft) - -> `RightSubsumesLeft - | (`LeftSmallerThanRight | `RightSmallerThanLeft), _ - -> let lidxpos = ItvPure.le_sem ItvPure.zero lidx in + | `Equal, `Equal -> + `Equal + | `NotComparable, _ -> + `NotComparable + | `Equal, (`LeftSmallerThanRight | `LeftSubsumesRight) -> + `LeftSubsumesRight + | `Equal, (`RightSmallerThanLeft | `RightSubsumesLeft) -> + `RightSubsumesLeft + | `LeftSubsumesRight, (`Equal | `LeftSubsumesRight) -> + `LeftSubsumesRight + | `RightSubsumesLeft, (`Equal | `RightSubsumesLeft) -> + `RightSubsumesLeft + | (`LeftSmallerThanRight | `RightSmallerThanLeft), _ -> + let lidxpos = ItvPure.le_sem ItvPure.zero lidx in let ridxpos = ItvPure.le_sem ItvPure.zero ridx in if not (ItvPure.equal lidxpos ridxpos) then `NotComparable else if ItvPure.is_true lidxpos then (* both idx >= 0 *) match (idxcmp, sizcmp) with - | `LeftSmallerThanRight, (`Equal | `RightSmallerThanLeft | `RightSubsumesLeft) - -> `RightSubsumesLeft - | `RightSmallerThanLeft, (`Equal | `LeftSmallerThanRight | `LeftSubsumesRight) - -> `LeftSubsumesRight - | _ - -> `NotComparable + | `LeftSmallerThanRight, (`Equal | `RightSmallerThanLeft | `RightSubsumesLeft) -> + `RightSubsumesLeft + | `RightSmallerThanLeft, (`Equal | `LeftSmallerThanRight | `LeftSubsumesRight) -> + `LeftSubsumesRight + | _ -> + `NotComparable else if ItvPure.is_false lidxpos then (* both idx < 0, size doesn't matter *) match idxcmp with - | `LeftSmallerThanRight - -> `LeftSubsumesRight - | `RightSmallerThanLeft - -> `RightSubsumesLeft - | `Equal - -> `Equal - | _ - -> `NotComparable + | `LeftSmallerThanRight -> + `LeftSubsumesRight + | `RightSmallerThanLeft -> + `RightSubsumesLeft + | `Equal -> + `Equal + | _ -> + `NotComparable else `NotComparable - | _ - -> `NotComparable + | _ -> + `NotComparable + let filter1 : t -> bool = fun c -> @@ -93,6 +99,7 @@ module Condition = struct || Itv.Bound.eq (ItvPure.lb c.size) Itv.Bound.MInf || ItvPure.is_nat c.idx && ItvPure.is_nat c.size + let filter2 : t -> bool = fun c -> (* basically, alarms involving infinity are filtered *) @@ -115,6 +122,7 @@ module Condition = struct && (* idx non-infty ub > size ub *) Itv.Bound.gt (ItvPure.ub c.idx) (ItvPure.ub c.size) ) + (* check buffer overrun and return its confidence *) let check : t -> IssueType.t option = fun c -> @@ -140,13 +148,15 @@ module Condition = struct else if filter2 c then Some IssueType.buffer_overrun_l4 else Some IssueType.buffer_overrun_l3 + let subst : t -> Itv.Bound.t bottom_lifted Itv.SubstMap.t -> t option = fun c bound_map -> match (ItvPure.subst c.idx bound_map, ItvPure.subst c.size bound_map) with - | NonBottom idx, NonBottom size - -> Some {idx; size} - | _ - -> None + | NonBottom idx, NonBottom size -> + Some {idx; size} + | _ -> + None + end module ConditionTrace = struct @@ -170,22 +180,24 @@ module ConditionTrace = struct if Config.bo_debug <= 1 then F.fprintf fmt "at %a" pp_location ct else match ct.cond_trace with - | Inter (_, pname, loc) - -> let pname = Typ.Procname.to_string pname in + | Inter (_, pname, loc) -> + let pname = Typ.Procname.to_string pname in F.fprintf fmt "at %a by call %s() at %a (%a)" pp_location ct pname Location.pp_file_pos loc ValTraceSet.pp ct.val_traces - | Intra _ - -> F.fprintf fmt "%a (%a)" pp_location ct ValTraceSet.pp ct.val_traces + | Intra _ -> + F.fprintf fmt "%a (%a)" pp_location ct ValTraceSet.pp ct.val_traces + let pp_description : F.formatter -> t -> unit = fun fmt ct -> match ct.cond_trace with | Inter (_, pname, _) - when Config.bo_debug >= 1 || not (SourceFile.is_cpp_model ct.loc.Location.file) - -> F.fprintf fmt " %@ %a by call %a " pp_location ct MF.pp_monospaced + when Config.bo_debug >= 1 || not (SourceFile.is_cpp_model ct.loc.Location.file) -> + F.fprintf fmt " %@ %a by call %a " pp_location ct MF.pp_monospaced (Typ.Procname.to_string pname ^ "()") - | _ - -> () + | _ -> + () + let get_location : t -> Location.t = fun ct -> ct.loc @@ -196,12 +208,15 @@ module ConditionTrace = struct let get_caller_proc_name ct = match ct.cond_trace with Intra pname -> pname | Inter (caller_pname, _, _) -> caller_pname + let make : Typ.Procname.t -> Location.t -> string -> ValTraceSet.t -> t = fun proc_name loc id val_traces -> {proc_name; loc; id; cond_trace= Intra proc_name; val_traces} + let make_call_and_subst ~traces_caller ~caller_pname ~callee_pname loc ct = let val_traces = ValTraceSet.instantiate ~traces_caller ~traces_callee:ct.val_traces loc in {ct with cond_trace= Inter (caller_pname, callee_pname, loc); val_traces} + end module ConditionSet = struct @@ -214,69 +229,74 @@ module ConditionSet = struct let empty = [] let compare_by_location cwt1 cwt2 = - Location.compare (ConditionTrace.get_location cwt1.trace) + Location.compare + (ConditionTrace.get_location cwt1.trace) (ConditionTrace.get_location cwt2.trace) + let try_merge ~existing ~new_ = if Condition.have_similar_bounds existing.cond new_.cond then match Condition.xcompare ~lhs:existing.cond ~rhs:new_.cond with - | `Equal - -> (* keep the first one in the code *) + | `Equal -> + (* keep the first one in the code *) if compare_by_location existing new_ <= 0 then `DoNotAddAndStop else `RemoveExistingAndContinue (* we don't want to remove issues that would end up in a higher bucket, e.g. [a, b] < [c, d] is subsumed by [a, +oo] < [c, d] but the latter is less precise *) - | `LeftSubsumesRight - -> `DoNotAddAndStop - | `RightSubsumesLeft - -> `RemoveExistingAndContinue - | `NotComparable - -> `KeepExistingAndContinue + | `LeftSubsumesRight -> + `DoNotAddAndStop + | `RightSubsumesLeft -> + `RemoveExistingAndContinue + | `NotComparable -> + `KeepExistingAndContinue else `KeepExistingAndContinue + let add_one condset new_ = let rec aux ~new_ acc ~same = function - | [] - -> if same then new_ :: condset else new_ :: acc + | [] -> + if same then new_ :: condset else new_ :: acc | existing :: rest as existings -> match try_merge ~existing ~new_ with - | `DoNotAddAndStop - -> if same then condset else List.rev_append acc existings - | `RemoveExistingAndContinue - -> aux ~new_ acc ~same:false rest - | `KeepExistingAndContinue - -> aux ~new_ (existing :: acc) ~same rest + | `DoNotAddAndStop -> + if same then condset else List.rev_append acc existings + | `RemoveExistingAndContinue -> + aux ~new_ acc ~same:false rest + | `KeepExistingAndContinue -> + aux ~new_ (existing :: acc) ~same rest in aux ~new_ [] ~same:true condset + let join condset1 condset2 = List.fold_left ~f:add_one condset1 ~init:condset2 let add_bo_safety pname loc id ~idx ~size val_traces condset = match Condition.make ~idx ~size with - | None - -> condset - | Some cond - -> let trace = ConditionTrace.make pname loc id val_traces in + | None -> + condset + | Some cond -> + let trace = ConditionTrace.make pname loc id val_traces in let cwt = {cond; trace} in join [cwt] condset + let subst condset (bound_map, trace_map) caller_pname callee_pname loc = let subst_add_cwt condset cwt = match Condition.get_symbols cwt.cond with - | [] - -> add_one condset cwt + | [] -> + add_one condset cwt | symbols -> match Condition.subst cwt.cond bound_map with - | None - -> condset - | Some cond - -> let traces_caller = + | None -> + condset + | Some cond -> + let traces_caller = List.fold symbols ~init:ValTraceSet.empty ~f:(fun val_traces symbol -> match Itv.SubstMap.find symbol trace_map with - | symbol_trace - -> ValTraceSet.join symbol_trace val_traces - | exception Not_found - -> val_traces ) + | symbol_trace -> + ValTraceSet.join symbol_trace val_traces + | exception Not_found -> + val_traces ) in let make_call_and_subst trace = ConditionTrace.make_call_and_subst ~traces_caller ~caller_pname ~callee_pname loc @@ -287,6 +307,7 @@ module ConditionSet = struct in List.fold condset ~f:subst_add_cwt ~init:[] + let iter ~f condset = List.iter condset ~f:(fun cwt -> f cwt.cond cwt.trace) let pp_cwt fmt cwt = F.fprintf fmt "%a %a" Condition.pp cwt.cond ConditionTrace.pp cwt.trace @@ -300,6 +321,7 @@ module ConditionSet = struct F.fprintf fmt " }@]" ; F.fprintf fmt "@]" + let pp : Format.formatter -> t -> unit = fun fmt condset -> let pp_sep fmt () = F.fprintf fmt ", @," in @@ -308,7 +330,9 @@ module ConditionSet = struct F.pp_print_list ~pp_sep pp_cwt fmt condset ; F.fprintf fmt " }@]" ; F.fprintf fmt "@]" + end let description cond trace = F.asprintf "%a%a" Condition.pp_description cond ConditionTrace.pp_description trace + diff --git a/infer/src/bufferoverrun/bufferOverrunSemantics.ml b/infer/src/bufferoverrun/bufferOverrunSemantics.ml index 99a31a646..a6635b8a4 100644 --- a/infer/src/bufferoverrun/bufferOverrunSemantics.ml +++ b/infer/src/bufferoverrun/bufferOverrunSemantics.ml @@ -26,273 +26,286 @@ module Make (CFG : ProcCfg.S) = struct | Const.Cint intlit -> ( try Val.of_int (IntLit.to_int intlit) with _ -> Val.Itv.top ) - | Const.Cfloat f - -> f |> int_of_float |> Val.of_int - | _ - -> Val.Itv.top + | Const.Cfloat f -> + f |> int_of_float |> Val.of_int + | _ -> + Val.Itv.top + (* TODO *) let sizeof_ikind : Typ.ikind -> int = function - | Typ.IChar | Typ.ISChar | Typ.IUChar | Typ.IBool - -> 1 - | Typ.IInt | Typ.IUInt - -> 4 - | Typ.IShort | Typ.IUShort - -> 2 - | Typ.ILong | Typ.IULong - -> 4 - | Typ.ILongLong | Typ.IULongLong - -> 8 - | Typ.I128 | Typ.IU128 - -> 16 + | Typ.IChar | Typ.ISChar | Typ.IUChar | Typ.IBool -> + 1 + | Typ.IInt | Typ.IUInt -> + 4 + | Typ.IShort | Typ.IUShort -> + 2 + | Typ.ILong | Typ.IULong -> + 4 + | Typ.ILongLong | Typ.IULongLong -> + 8 + | Typ.I128 | Typ.IU128 -> + 16 + let sizeof_fkind : Typ.fkind -> int = function - | Typ.FFloat - -> 4 - | Typ.FDouble | Typ.FLongDouble - -> 8 + | Typ.FFloat -> + 4 + | Typ.FDouble | Typ.FLongDouble -> + 8 + (* NOTE: assume 32bit machine *) let rec sizeof (typ: Typ.t) : int = match typ.desc with - | Typ.Tint ikind - -> sizeof_ikind ikind - | Typ.Tfloat fkind - -> sizeof_fkind fkind - | Typ.Tvoid - -> 1 - | Typ.Tptr (_, _) - -> 4 - | Typ.Tstruct _ | Typ.TVar _ - -> 4 (* TODO *) - | Typ.Tarray (_, Some length, Some stride) - -> IntLit.to_int stride * IntLit.to_int length - | Typ.Tarray (typ, Some length, None) - -> sizeof typ * IntLit.to_int length - | _ - -> 4 + | Typ.Tint ikind -> + sizeof_ikind ikind + | Typ.Tfloat fkind -> + sizeof_fkind fkind + | Typ.Tvoid -> + 1 + | Typ.Tptr (_, _) -> + 4 + | Typ.Tstruct _ | Typ.TVar _ -> + 4 (* TODO *) + | Typ.Tarray (_, Some length, Some stride) -> + IntLit.to_int stride * IntLit.to_int length + | Typ.Tarray (typ, Some length, None) -> + sizeof typ * IntLit.to_int length + | _ -> + 4 + let rec must_alias : Exp.t -> Exp.t -> Mem.astate -> bool = fun e1 e2 m -> match (e1, e2) with | Exp.Var x1, Exp.Var x2 -> ( match (Mem.find_alias x1 m, Mem.find_alias x2 m) with - | Some x1', Some x2' - -> AliasTarget.equal x1' x2' - | _, _ - -> false ) - | Exp.UnOp (uop1, e1', _), Exp.UnOp (uop2, e2', _) - -> Unop.equal uop1 uop2 && must_alias e1' e2' m - | Exp.BinOp (bop1, e11, e12), Exp.BinOp (bop2, e21, e22) - -> Binop.equal bop1 bop2 && must_alias e11 e21 m && must_alias e12 e22 m - | Exp.Exn t1, Exp.Exn t2 - -> must_alias t1 t2 m - | Exp.Const c1, Exp.Const c2 - -> Const.equal c1 c2 - | Exp.Cast (t1, e1'), Exp.Cast (t2, e2') - -> Typ.equal t1 t2 && must_alias e1' e2' m - | Exp.Lvar x1, Exp.Lvar x2 - -> Pvar.equal x1 x2 - | Exp.Lfield (e1, fld1, _), Exp.Lfield (e2, fld2, _) - -> must_alias e1 e2 m && Typ.Fieldname.equal fld1 fld2 - | Exp.Lindex (e11, e12), Exp.Lindex (e21, e22) - -> must_alias e11 e21 m && must_alias e12 e22 m - | Exp.Sizeof {nbytes= Some nbytes1}, Exp.Sizeof {nbytes= Some nbytes2} - -> Int.equal nbytes1 nbytes2 + | Some x1', Some x2' -> + AliasTarget.equal x1' x2' + | _, _ -> + false ) + | Exp.UnOp (uop1, e1', _), Exp.UnOp (uop2, e2', _) -> + Unop.equal uop1 uop2 && must_alias e1' e2' m + | Exp.BinOp (bop1, e11, e12), Exp.BinOp (bop2, e21, e22) -> + Binop.equal bop1 bop2 && must_alias e11 e21 m && must_alias e12 e22 m + | Exp.Exn t1, Exp.Exn t2 -> + must_alias t1 t2 m + | Exp.Const c1, Exp.Const c2 -> + Const.equal c1 c2 + | Exp.Cast (t1, e1'), Exp.Cast (t2, e2') -> + Typ.equal t1 t2 && must_alias e1' e2' m + | Exp.Lvar x1, Exp.Lvar x2 -> + Pvar.equal x1 x2 + | Exp.Lfield (e1, fld1, _), Exp.Lfield (e2, fld2, _) -> + must_alias e1 e2 m && Typ.Fieldname.equal fld1 fld2 + | Exp.Lindex (e11, e12), Exp.Lindex (e21, e22) -> + must_alias e11 e21 m && must_alias e12 e22 m + | Exp.Sizeof {nbytes= Some nbytes1}, Exp.Sizeof {nbytes= Some nbytes2} -> + Int.equal nbytes1 nbytes2 | ( Exp.Sizeof {typ= t1; dynamic_length= dynlen1; subtype= subt1} - , Exp.Sizeof {typ= t2; dynamic_length= dynlen2; subtype= subt2} ) - -> Typ.equal t1 t2 && must_alias_opt dynlen1 dynlen2 m + , Exp.Sizeof {typ= t2; dynamic_length= dynlen2; subtype= subt2} ) -> + Typ.equal t1 t2 && must_alias_opt dynlen1 dynlen2 m && Int.equal (Subtype.compare subt1 subt2) 0 - | _, _ - -> false + | _, _ -> + false + and must_alias_opt : Exp.t option -> Exp.t option -> Mem.astate -> bool = fun e1_opt e2_opt m -> match (e1_opt, e2_opt) with - | Some e1, Some e2 - -> must_alias e1 e2 m - | None, None - -> true - | _, _ - -> false + | Some e1, Some e2 -> + must_alias e1 e2 m + | None, None -> + true + | _, _ -> + false + let comp_rev : Binop.t -> Binop.t = function - | Binop.Lt - -> Binop.Gt - | Binop.Gt - -> Binop.Lt - | Binop.Le - -> Binop.Ge - | Binop.Ge - -> Binop.Le - | Binop.Eq - -> Binop.Eq - | Binop.Ne - -> Binop.Ne - | _ - -> assert false + | Binop.Lt -> + Binop.Gt + | Binop.Gt -> + Binop.Lt + | Binop.Le -> + Binop.Ge + | Binop.Ge -> + Binop.Le + | Binop.Eq -> + Binop.Eq + | Binop.Ne -> + Binop.Ne + | _ -> + assert false + let comp_not : Binop.t -> Binop.t = function - | Binop.Lt - -> Binop.Ge - | Binop.Gt - -> Binop.Le - | Binop.Le - -> Binop.Gt - | Binop.Ge - -> Binop.Lt - | Binop.Eq - -> Binop.Ne - | Binop.Ne - -> Binop.Eq - | _ - -> assert false + | Binop.Lt -> + Binop.Ge + | Binop.Gt -> + Binop.Le + | Binop.Le -> + Binop.Gt + | Binop.Ge -> + Binop.Lt + | Binop.Eq -> + Binop.Ne + | Binop.Ne -> + Binop.Eq + | _ -> + assert false + let rec must_alias_cmp : Exp.t -> Mem.astate -> bool = fun e m -> match e with - | Exp.BinOp (Binop.Lt, e1, e2) | Exp.BinOp (Binop.Gt, e1, e2) | Exp.BinOp (Binop.Ne, e1, e2) - -> must_alias e1 e2 m - | Exp.BinOp (Binop.LAnd, e1, e2) - -> must_alias_cmp e1 m || must_alias_cmp e2 m - | Exp.BinOp (Binop.LOr, e1, e2) - -> must_alias_cmp e1 m && must_alias_cmp e2 m - | Exp.UnOp (Unop.LNot, Exp.UnOp (Unop.LNot, e1, _), _) - -> must_alias_cmp e1 m + | Exp.BinOp (Binop.Lt, e1, e2) | Exp.BinOp (Binop.Gt, e1, e2) | Exp.BinOp (Binop.Ne, e1, e2) -> + must_alias e1 e2 m + | Exp.BinOp (Binop.LAnd, e1, e2) -> + must_alias_cmp e1 m || must_alias_cmp e2 m + | Exp.BinOp (Binop.LOr, e1, e2) -> + must_alias_cmp e1 m && must_alias_cmp e2 m + | Exp.UnOp (Unop.LNot, Exp.UnOp (Unop.LNot, e1, _), _) -> + must_alias_cmp e1 m | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Lt as c), e1, e2), _) | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Gt as c), e1, e2), _) | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Le as c), e1, e2), _) | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Ge as c), e1, e2), _) | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Eq as c), e1, e2), _) - | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Ne as c), e1, e2), _) - -> must_alias_cmp (Exp.BinOp (comp_not c, e1, e2)) m - | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.LOr, e1, e2), t) - -> let e1' = Exp.UnOp (Unop.LNot, e1, t) in + | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Ne as c), e1, e2), _) -> + must_alias_cmp (Exp.BinOp (comp_not c, e1, e2)) m + | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.LOr, e1, e2), t) -> + let e1' = Exp.UnOp (Unop.LNot, e1, t) in let e2' = Exp.UnOp (Unop.LNot, e2, t) in must_alias_cmp (Exp.BinOp (Binop.LAnd, e1', e2')) m - | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.LAnd, e1, e2), t) - -> let e1' = Exp.UnOp (Unop.LNot, e1, t) in + | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.LAnd, e1, e2), t) -> + let e1' = Exp.UnOp (Unop.LNot, e1, t) in let e2' = Exp.UnOp (Unop.LNot, e2, t) in must_alias_cmp (Exp.BinOp (Binop.LOr, e1', e2')) m - | _ - -> false + | _ -> + false + let rec eval : Exp.t -> Mem.astate -> Location.t -> Val.t = fun exp mem loc -> if must_alias_cmp exp mem then Val.of_int 0 else match exp with - | Exp.Var id - -> Mem.find_stack (Var.of_id id |> Loc.of_var) mem - | Exp.Lvar pvar - -> let ploc = pvar |> Loc.of_pvar |> PowLoc.singleton in + | Exp.Var id -> + Mem.find_stack (Var.of_id id |> Loc.of_var) mem + | Exp.Lvar pvar -> + let ploc = pvar |> Loc.of_pvar |> PowLoc.singleton in let arr = Mem.find_stack_set ploc mem in ploc |> Val.of_pow_loc |> Val.join arr - | Exp.UnOp (uop, e, _) - -> eval_unop uop e mem loc - | Exp.BinOp (bop, e1, e2) - -> eval_binop bop e1 e2 mem loc - | Exp.Const c - -> eval_const c - | Exp.Cast (_, e) - -> eval e mem loc - | Exp.Lfield (e, fn, _) - -> eval e mem loc |> Val.get_array_locs |> Fn.flip PowLoc.append_field fn + | Exp.UnOp (uop, e, _) -> + eval_unop uop e mem loc + | Exp.BinOp (bop, e1, e2) -> + eval_binop bop e1 e2 mem loc + | Exp.Const c -> + eval_const c + | Exp.Cast (_, e) -> + eval e mem loc + | Exp.Lfield (e, fn, _) -> + eval e mem loc |> Val.get_array_locs |> Fn.flip PowLoc.append_field fn |> Val.of_pow_loc - | Exp.Lindex (e1, _) - -> let arr = eval e1 mem loc |> Val.get_array_blk in + | Exp.Lindex (e1, _) -> + let arr = eval e1 mem loc |> Val.get_array_blk in (* must have array blk *) (* let idx = eval e2 mem loc in *) let ploc = if ArrayBlk.is_bot arr then PowLoc.unknown else ArrayBlk.get_pow_loc arr in (* if nested array, add the array blk *) let arr = Mem.find_heap_set ploc mem in Val.join (Val.of_pow_loc ploc) arr - | Exp.Sizeof {nbytes= Some size} - -> Val.of_int size - | Exp.Sizeof {typ; nbytes= None} - -> Val.of_int (sizeof typ) - | Exp.Exn _ | Exp.Closure _ - -> Val.Itv.top + | Exp.Sizeof {nbytes= Some size} -> + Val.of_int size + | Exp.Sizeof {typ; nbytes= None} -> + Val.of_int (sizeof typ) + | Exp.Exn _ | Exp.Closure _ -> + Val.Itv.top + and eval_unop : Unop.t -> Exp.t -> Mem.astate -> Location.t -> Val.t = fun unop e mem loc -> let v = eval e mem loc in match unop with - | Unop.Neg - -> Val.neg v - | Unop.BNot - -> Val.unknown_bit v - | Unop.LNot - -> Val.lnot v + | Unop.Neg -> + Val.neg v + | Unop.BNot -> + Val.unknown_bit v + | Unop.LNot -> + Val.lnot v + and eval_binop : Binop.t -> Exp.t -> Exp.t -> Mem.astate -> Location.t -> Val.t = fun binop e1 e2 mem loc -> let v1 = eval e1 mem loc in let v2 = eval e2 mem loc in match binop with - | Binop.PlusA - -> Val.join (Val.plus v1 v2) (Val.plus_pi v1 v2) - | Binop.PlusPI - -> Val.plus_pi v1 v2 - | Binop.MinusA - -> Val.joins [Val.minus v1 v2; Val.minus_pi v1 v2; Val.minus_pp v1 v2] - | Binop.MinusPI - -> Val.minus_pi v1 v2 - | Binop.MinusPP - -> Val.minus_pp v1 v2 - | Binop.Mult - -> Val.mult v1 v2 - | Binop.Div - -> Val.div v1 v2 - | Binop.Mod - -> Val.mod_sem v1 v2 - | Binop.Shiftlt - -> Val.shiftlt v1 v2 - | Binop.Shiftrt - -> Val.shiftrt v1 v2 - | Binop.Lt - -> Val.lt_sem v1 v2 - | Binop.Gt - -> Val.gt_sem v1 v2 - | Binop.Le - -> Val.le_sem v1 v2 - | Binop.Ge - -> Val.ge_sem v1 v2 - | Binop.Eq - -> Val.eq_sem v1 v2 - | Binop.Ne - -> Val.ne_sem v1 v2 - | Binop.BAnd | Binop.BXor | Binop.BOr - -> Val.unknown_bit v1 - | Binop.LAnd - -> Val.land_sem v1 v2 - | Binop.LOr - -> Val.lor_sem v1 v2 + | Binop.PlusA -> + Val.join (Val.plus v1 v2) (Val.plus_pi v1 v2) + | Binop.PlusPI -> + Val.plus_pi v1 v2 + | Binop.MinusA -> + Val.joins [Val.minus v1 v2; Val.minus_pi v1 v2; Val.minus_pp v1 v2] + | Binop.MinusPI -> + Val.minus_pi v1 v2 + | Binop.MinusPP -> + Val.minus_pp v1 v2 + | Binop.Mult -> + Val.mult v1 v2 + | Binop.Div -> + Val.div v1 v2 + | Binop.Mod -> + Val.mod_sem v1 v2 + | Binop.Shiftlt -> + Val.shiftlt v1 v2 + | Binop.Shiftrt -> + Val.shiftrt v1 v2 + | Binop.Lt -> + Val.lt_sem v1 v2 + | Binop.Gt -> + Val.gt_sem v1 v2 + | Binop.Le -> + Val.le_sem v1 v2 + | Binop.Ge -> + Val.ge_sem v1 v2 + | Binop.Eq -> + Val.eq_sem v1 v2 + | Binop.Ne -> + Val.ne_sem v1 v2 + | Binop.BAnd | Binop.BXor | Binop.BOr -> + Val.unknown_bit v1 + | Binop.LAnd -> + Val.land_sem v1 v2 + | Binop.LOr -> + Val.lor_sem v1 v2 + let rec eval_locs : Exp.t -> Mem.astate -> Location.t -> Val.t = fun exp mem loc -> match exp with | Exp.Var id -> ( match Mem.find_alias id mem with - | Some AliasTarget.Simple loc - -> PowLoc.singleton loc |> Val.of_pow_loc - | Some AliasTarget.Empty _ | None - -> Val.bot ) - | Exp.Lvar pvar - -> pvar |> Loc.of_pvar |> PowLoc.singleton |> Val.of_pow_loc - | Exp.BinOp (bop, e1, e2) - -> eval_binop bop e1 e2 mem loc - | Exp.Cast (_, e) - -> eval_locs e mem loc - | Exp.Lfield (e, fn, _) - -> eval e mem loc |> Val.get_all_locs |> Fn.flip PowLoc.append_field fn |> Val.of_pow_loc - | Exp.Lindex (e1, e2) - -> let arr = eval e1 mem loc in + | Some AliasTarget.Simple loc -> + PowLoc.singleton loc |> Val.of_pow_loc + | Some AliasTarget.Empty _ | None -> + Val.bot ) + | Exp.Lvar pvar -> + pvar |> Loc.of_pvar |> PowLoc.singleton |> Val.of_pow_loc + | Exp.BinOp (bop, e1, e2) -> + eval_binop bop e1 e2 mem loc + | Exp.Cast (_, e) -> + eval_locs e mem loc + | Exp.Lfield (e, fn, _) -> + eval e mem loc |> Val.get_all_locs |> Fn.flip PowLoc.append_field fn |> Val.of_pow_loc + | Exp.Lindex (e1, e2) -> + let arr = eval e1 mem loc in let idx = eval e2 mem loc in Val.plus_pi arr idx - | Exp.Const _ | Exp.UnOp _ | Exp.Sizeof _ | Exp.Exn _ | Exp.Closure _ - -> Val.bot + | Exp.Const _ | Exp.UnOp _ | Exp.Sizeof _ | Exp.Exn _ | Exp.Closure _ -> + Val.bot + let get_allocsite : Typ.Procname.t -> CFG.node -> int -> int -> string = fun proc_name node inst_num dimension -> @@ -302,6 +315,7 @@ module Make (CFG : ProcCfg.S) = struct let dimension = string_of_int dimension in proc_name ^ "-" ^ node_num ^ "-" ^ inst_num ^ "-" ^ dimension |> Allocsite.make + let eval_array_alloc : Typ.Procname.t -> CFG.node -> Typ.t -> ?stride:int -> Itv.t -> Itv.t -> int -> int -> Val.t = fun pdesc node typ ?stride:stride0 offset size inst_num dimension -> @@ -310,38 +324,40 @@ module Make (CFG : ProcCfg.S) = struct let stride = Itv.of_int int_stride in ArrayBlk.make allocsite offset size stride |> Val.of_array_blk + let prune_unop : Exp.t -> Mem.astate -> Mem.astate = fun e mem -> match e with | Exp.Var x -> ( match Mem.find_alias x mem with - | Some AliasTarget.Simple lv - -> let v = Mem.find_heap lv mem in + | Some AliasTarget.Simple lv -> + let v = Mem.find_heap lv mem in let v' = Val.prune_zero v in Mem.update_mem (PowLoc.singleton lv) v' mem - | Some AliasTarget.Empty lv - -> let v = Mem.find_heap lv mem in + | Some AliasTarget.Empty lv -> + let v = Mem.find_heap lv mem in let itv_v = Itv.prune_eq (Val.get_itv v) Itv.zero in let v' = Val.modify_itv itv_v v in Mem.update_mem (PowLoc.singleton lv) v' mem - | None - -> mem ) + | None -> + mem ) | Exp.UnOp (Unop.LNot, Exp.Var x, _) -> ( match Mem.find_alias x mem with - | Some AliasTarget.Simple lv - -> let v = Mem.find_heap lv mem in + | Some AliasTarget.Simple lv -> + let v = Mem.find_heap lv mem in let itv_v = Itv.prune_eq (Val.get_itv v) Itv.false_sem in let v' = Val.modify_itv itv_v v in Mem.update_mem (PowLoc.singleton lv) v' mem - | Some AliasTarget.Empty lv - -> let v = Mem.find_heap lv mem in + | Some AliasTarget.Empty lv -> + let v = Mem.find_heap lv mem in let itv_v = Itv.prune_comp Binop.Ge (Val.get_itv v) Itv.one in let v' = Val.modify_itv itv_v v in Mem.update_mem (PowLoc.singleton lv) v' mem - | None - -> mem ) - | _ - -> mem + | None -> + mem ) + | _ -> + mem + let prune_binop_left : Exp.t -> Location.t -> Mem.astate -> Mem.astate = fun e loc mem -> @@ -351,30 +367,31 @@ module Make (CFG : ProcCfg.S) = struct | Exp.BinOp ((Binop.Le as comp), Exp.Var x, e') | Exp.BinOp ((Binop.Ge as comp), Exp.Var x, e') -> ( match Mem.find_simple_alias x mem with - | Some lv - -> let v = Mem.find_heap lv mem in + | Some lv -> + let v = Mem.find_heap lv mem in let v' = Val.prune_comp comp v (eval e' mem loc) in Mem.update_mem (PowLoc.singleton lv) v' mem - | None - -> mem ) + | None -> + mem ) | Exp.BinOp (Binop.Eq, Exp.Var x, e') -> ( match Mem.find_simple_alias x mem with - | Some lv - -> let v = Mem.find_heap lv mem in + | Some lv -> + let v = Mem.find_heap lv mem in let v' = Val.prune_eq v (eval e' mem loc) in Mem.update_mem (PowLoc.singleton lv) v' mem - | None - -> mem ) + | None -> + mem ) | Exp.BinOp (Binop.Ne, Exp.Var x, e') -> ( match Mem.find_simple_alias x mem with - | Some lv - -> let v = Mem.find_heap lv mem in + | Some lv -> + let v = Mem.find_heap lv mem in let v' = Val.prune_ne v (eval e' mem loc) in Mem.update_mem (PowLoc.singleton lv) v' mem - | None - -> mem ) - | _ - -> mem + | None -> + mem ) + | _ -> + mem + let prune_binop_right : Exp.t -> Location.t -> Mem.astate -> Mem.astate = fun e loc mem -> @@ -384,17 +401,20 @@ module Make (CFG : ProcCfg.S) = struct | Exp.BinOp ((Binop.Le as c), e', Exp.Var x) | Exp.BinOp ((Binop.Ge as c), e', Exp.Var x) | Exp.BinOp ((Binop.Eq as c), e', Exp.Var x) - | Exp.BinOp ((Binop.Ne as c), e', Exp.Var x) - -> prune_binop_left (Exp.BinOp (comp_rev c, Exp.Var x, e')) loc mem - | _ - -> mem + | Exp.BinOp ((Binop.Ne as c), e', Exp.Var x) -> + prune_binop_left (Exp.BinOp (comp_rev c, Exp.Var x, e')) loc mem + | _ -> + mem + let is_unreachable_constant : Exp.t -> Location.t -> Mem.astate -> bool = fun e loc m -> Val.( <= ) ~lhs:(eval e m loc) ~rhs:(Val.of_int 0) + let prune_unreachable : Exp.t -> Location.t -> Mem.astate -> Mem.astate = fun e loc mem -> if is_unreachable_constant e loc mem then Mem.bot else mem + let rec prune : Exp.t -> Location.t -> Mem.astate -> Mem.astate = fun e loc mem -> let mem = @@ -402,31 +422,33 @@ module Make (CFG : ProcCfg.S) = struct |> prune_binop_right e loc in match e with - | Exp.BinOp (Binop.Ne, e, Exp.Const Const.Cint i) when IntLit.iszero i - -> prune e loc mem - | Exp.BinOp (Binop.Eq, e, Exp.Const Const.Cint i) when IntLit.iszero i - -> prune (Exp.UnOp (Unop.LNot, e, None)) loc mem - | Exp.UnOp (Unop.Neg, Exp.Var x, _) - -> prune (Exp.Var x) loc mem - | Exp.BinOp (Binop.LAnd, e1, e2) - -> mem |> prune e1 loc |> prune e2 loc - | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.LOr, e1, e2), t) - -> mem |> prune (Exp.UnOp (Unop.LNot, e1, t)) loc |> prune (Exp.UnOp (Unop.LNot, e2, t)) loc + | Exp.BinOp (Binop.Ne, e, Exp.Const Const.Cint i) when IntLit.iszero i -> + prune e loc mem + | Exp.BinOp (Binop.Eq, e, Exp.Const Const.Cint i) when IntLit.iszero i -> + prune (Exp.UnOp (Unop.LNot, e, None)) loc mem + | Exp.UnOp (Unop.Neg, Exp.Var x, _) -> + prune (Exp.Var x) loc mem + | Exp.BinOp (Binop.LAnd, e1, e2) -> + mem |> prune e1 loc |> prune e2 loc + | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.LOr, e1, e2), t) -> + mem |> prune (Exp.UnOp (Unop.LNot, e1, t)) loc |> prune (Exp.UnOp (Unop.LNot, e2, t)) loc | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Lt as c), e1, e2), _) | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Gt as c), e1, e2), _) | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Le as c), e1, e2), _) | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Ge as c), e1, e2), _) | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Eq as c), e1, e2), _) - | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Ne as c), e1, e2), _) - -> prune (Exp.BinOp (comp_not c, e1, e2)) loc mem - | _ - -> mem + | Exp.UnOp (Unop.LNot, Exp.BinOp ((Binop.Ne as c), e1, e2), _) -> + prune (Exp.BinOp (comp_not c, e1, e2)) loc mem + | _ -> + mem + let get_formals : Procdesc.t -> (Pvar.t * Typ.t) list = fun pdesc -> let proc_name = Procdesc.get_proc_name pdesc in Procdesc.get_formals pdesc |> List.map ~f:(fun (name, typ) -> (Pvar.mk name proc_name, typ)) + let get_matching_pairs : Tenv.t -> Val.t -> Val.t -> Typ.t -> Mem.astate -> Mem.astate -> callee_ret_alias:AliasTarget.t option @@ -446,20 +468,20 @@ module Make (CFG : ProcCfg.S) = struct let ret_alias = ref None in let add_ret_alias v1 v2 = match callee_ret_alias with - | Some ret_loc - -> if PowLoc.is_singleton v1 && PowLoc.is_singleton v2 + | Some ret_loc -> + if PowLoc.is_singleton v1 && PowLoc.is_singleton v2 && AliasTarget.use (PowLoc.min_elt v1) ret_loc then ret_alias := Some (AliasTarget.replace (PowLoc.min_elt v2) ret_loc) - | None - -> () + | None -> + () in let add_pair_itv itv1 itv2 traces l = let open Itv in if itv1 <> bot && itv1 <> top then - if Itv.eq itv2 bot then (lb itv1, Bottom, TraceSet.empty) - :: (ub itv1, Bottom, TraceSet.empty) :: l - else (lb itv1, NonBottom (lb itv2), traces) - :: (ub itv1, NonBottom (ub itv2), traces) :: l + if Itv.eq itv2 bot then + (lb itv1, Bottom, TraceSet.empty) :: (ub itv1, Bottom, TraceSet.empty) :: l + else + (lb itv1, NonBottom (lb itv2), traces) :: (ub itv1, NonBottom (ub itv2), traces) :: l else l in let add_pair_val v1 v2 pairs = @@ -479,53 +501,56 @@ module Make (CFG : ProcCfg.S) = struct match typ.Typ.desc with | Typ.Tptr ({desc= Tstruct typename}, _) -> ( match Tenv.lookup tenv typename with - | Some str - -> let fns = List.map ~f:get_field_name str.Typ.Struct.fields in + | Some str -> + let fns = List.map ~f:get_field_name str.Typ.Struct.fields in List.fold ~f:(add_pair_field v1 v2) ~init:pairs fns - | _ - -> pairs ) - | Typ.Tptr (_, _) - -> let v1' = deref_ptr v1 callee_mem in + | _ -> + pairs ) + | Typ.Tptr (_, _) -> + let v1' = deref_ptr v1 callee_mem in let v2' = deref_ptr v2 caller_mem in add_pair_val v1' v2' pairs - | _ - -> pairs + | _ -> + pairs in let pairs = [] |> add_pair_val formal actual |> add_pair_ptr typ formal actual in (pairs, !ret_alias) + let subst_map_of_pairs : (Itv.Bound.t * Itv.Bound.t bottom_lifted * TraceSet.t) list -> Itv.Bound.t bottom_lifted Itv.SubstMap.t * TraceSet.t Itv.SubstMap.t = fun pairs -> let add_pair (bound_map, trace_map) (formal, actual, traces) = match formal with - | Itv.Bound.Linear (_, se1) when Itv.SymLinear.is_zero se1 - -> (bound_map, trace_map) - | Itv.Bound.Linear (0, se1) when Itv.SymLinear.cardinal se1 > 0 - -> let symbol, coeff = Itv.SymLinear.min_binding se1 in + | Itv.Bound.Linear (_, se1) when Itv.SymLinear.is_zero se1 -> + (bound_map, trace_map) + | Itv.Bound.Linear (0, se1) when Itv.SymLinear.cardinal se1 > 0 -> + let symbol, coeff = Itv.SymLinear.min_binding se1 in if Int.equal coeff 1 then (Itv.SubstMap.add symbol actual bound_map, Itv.SubstMap.add symbol traces trace_map) else assert false - | Itv.Bound.MinMax (0, Itv.Bound.Plus, Itv.Bound.Max, 0, symbol) - -> (Itv.SubstMap.add symbol actual bound_map, Itv.SubstMap.add symbol traces trace_map) - | _ - -> assert false + | Itv.Bound.MinMax (0, Itv.Bound.Plus, Itv.Bound.Max, 0, symbol) -> + (Itv.SubstMap.add symbol actual bound_map, Itv.SubstMap.add symbol traces trace_map) + | _ -> + assert false in List.fold ~f:add_pair ~init:(Itv.SubstMap.empty, Itv.SubstMap.empty) pairs + let rec list_fold2_def : default:Val.t -> f:('a -> Val.t -> 'b -> 'b) -> 'a list -> Val.t list -> init:'b -> 'b = fun ~default ~f xs ys ~init:acc -> match (xs, ys) with - | [], _ - -> acc - | x :: xs', [] - -> list_fold2_def ~default ~f xs' ys ~init:(f x default acc) - | [x], _ :: _ - -> f x (List.fold ~f:Val.join ~init:Val.bot ys) acc - | x :: xs', y :: ys' - -> list_fold2_def ~default ~f xs' ys' ~init:(f x y acc) + | [], _ -> + acc + | x :: xs', [] -> + list_fold2_def ~default ~f xs' ys ~init:(f x default acc) + | [x], _ :: _ -> + f x (List.fold ~f:Val.join ~init:Val.bot ys) acc + | x :: xs', y :: ys' -> + list_fold2_def ~default ~f xs' ys' ~init:(f x y acc) + let get_subst_map : Tenv.t -> Procdesc.t -> (Exp.t * 'a) list -> Mem.astate -> Mem.astate @@ -546,4 +571,5 @@ module Make (CFG : ProcCfg.S) = struct list_fold2_def ~default:Val.Itv.top ~f:add_pair formals actuals ~init:([], None) in (subst_map_of_pairs pairs, ret_alias) + end diff --git a/infer/src/bufferoverrun/bufferOverrunTrace.ml b/infer/src/bufferoverrun/bufferOverrunTrace.ml index 304246602..5a1e21803 100644 --- a/infer/src/bufferoverrun/bufferOverrunTrace.ml +++ b/infer/src/bufferoverrun/bufferOverrunTrace.ml @@ -35,23 +35,25 @@ module BoTrace = struct let pp_elem : F.formatter -> elem -> unit = fun fmt elem -> match elem with - | Assign loc - -> F.fprintf fmt "Assign (%a)" Location.pp_file_pos loc - | ArrDecl loc - -> F.fprintf fmt "ArrDecl (%a)" Location.pp_file_pos loc - | Call loc - -> F.fprintf fmt "Call (%a)" Location.pp_file_pos loc - | Return loc - -> F.fprintf fmt "Return (%a)" Location.pp_file_pos loc - | SymAssign loc - -> F.fprintf fmt "SymAssign (%a)" Location.pp_file_pos loc - | ArrAccess loc - -> F.fprintf fmt "ArrAccess (%a)" Location.pp_file_pos loc + | Assign loc -> + F.fprintf fmt "Assign (%a)" Location.pp_file_pos loc + | ArrDecl loc -> + F.fprintf fmt "ArrDecl (%a)" Location.pp_file_pos loc + | Call loc -> + F.fprintf fmt "Call (%a)" Location.pp_file_pos loc + | Return loc -> + F.fprintf fmt "Return (%a)" Location.pp_file_pos loc + | SymAssign loc -> + F.fprintf fmt "SymAssign (%a)" Location.pp_file_pos loc + | ArrAccess loc -> + F.fprintf fmt "ArrAccess (%a)" Location.pp_file_pos loc + let pp : F.formatter -> t -> unit = fun fmt t -> let pp_sep fmt () = F.fprintf fmt " :: " in F.pp_print_list ~pp_sep pp_elem fmt t.trace + end module Set = struct @@ -65,14 +67,17 @@ module Set = struct let tx, ty = (min_elt x, min_elt y) in if Pervasives.( <= ) tx.length ty.length then x else y + let choose_shortest set = min_elt set let add_elem elem t = if is_empty t then singleton (BoTrace.singleton elem) else map (BoTrace.add_elem elem) t + let add_elem_last elem t = if is_empty t then singleton (BoTrace.singleton elem) else map (BoTrace.add_elem_last elem) t + let instantiate ~traces_caller ~traces_callee loc = if is_empty traces_caller then map (fun trace_callee -> BoTrace.add_elem_last (BoTrace.Call loc) trace_callee) traces_callee @@ -87,6 +92,7 @@ module Set = struct traces_caller traces) traces_callee empty + let merge ~traces_arr ~traces_idx loc = if is_empty traces_idx then map (fun trace_arr -> BoTrace.add_elem (BoTrace.ArrAccess loc) trace_arr) traces_arr @@ -100,6 +106,7 @@ module Set = struct add new_trace traces) traces_arr traces) traces_idx empty + end include BoTrace diff --git a/infer/src/bufferoverrun/itv.ml b/infer/src/bufferoverrun/itv.ml index 93f2444a5..4ff04fc45 100644 --- a/infer/src/bufferoverrun/itv.ml +++ b/infer/src/bufferoverrun/itv.ml @@ -25,12 +25,14 @@ module Symbol = struct let make : unsigned:bool -> Typ.Procname.t -> int -> t = fun ~unsigned pname id -> {pname; id; unsigned} + let pp : F.formatter -> t -> unit = fun fmt {pname; id; unsigned} -> let symbol_name = if unsigned then "u" else "s" in if Config.bo_debug <= 1 then F.fprintf fmt "%s$%d" symbol_name id else F.fprintf fmt "%s-%s$%d" (Typ.Procname.to_string pname) symbol_name id + let is_unsigned : t -> bool = fun x -> x.unsigned end @@ -44,6 +46,7 @@ module SymLinear = struct fun cond x y -> let merge_function k x y = if cond k x y then None else raise Exit in match merge merge_function x y with _ -> true | exception Exit -> false + end type t = int M.t [@@deriving compare] @@ -71,12 +74,15 @@ module SymLinear = struct try M.find s x with Not_found -> 0 + let is_le_zero : t -> bool = fun x -> M.for_all (fun s v -> Int.equal v 0 || Symbol.is_unsigned s && v <= 0) x + let is_ge_zero : t -> bool = fun x -> M.for_all (fun s v -> Int.equal v 0 || Symbol.is_unsigned s && v >= 0) x + let le : t -> t -> bool = fun x y -> let le_one_pair s v1_opt v2_opt = @@ -85,9 +91,11 @@ module SymLinear = struct in M.for_all2 le_one_pair x y + let make : unsigned:bool -> Typ.Procname.t -> int -> t = fun ~unsigned pname i -> M.add (Symbol.make ~unsigned pname i) 1 empty + let eq : t -> t -> bool = fun x y -> le x y && le y x let pp1 : F.formatter -> Symbol.t * int -> unit = @@ -97,6 +105,7 @@ module SymLinear = struct else if c < 0 then F.fprintf fmt "(%d)x%a" c Symbol.pp s else F.fprintf fmt "%dx%a" c Symbol.pp s + let pp : F.formatter -> t -> unit = fun fmt x -> if M.is_empty x then F.fprintf fmt "empty" @@ -105,6 +114,7 @@ module SymLinear = struct pp1 fmt (s1, c1) ; M.iter (fun s c -> F.fprintf fmt " + %a" pp1 (s, c)) (M.remove s1 x) + let zero : t = M.empty let is_zero : t -> bool = fun x -> M.for_all (fun _ v -> Int.equal v 0) x @@ -114,6 +124,7 @@ module SymLinear = struct assert (n <> 0) ; M.for_all (fun _ v -> Int.equal (v mod n) 0) x + let neg : t -> t = fun x -> M.map ( ~- )x (* Returns (Some n) only when n is not 0. *) @@ -123,30 +134,32 @@ module SymLinear = struct fun x y -> let plus' _ n_opt m_opt = match (n_opt, m_opt) with - | None, None - -> None - | Some v, None | None, Some v - -> is_non_zero v - | Some n, Some m - -> is_non_zero (n + m) + | None, None -> + None + | Some v, None | None, Some v -> + is_non_zero v + | Some n, Some m -> + is_non_zero (n + m) in M.merge plus' x y + let minus : t -> t -> t = fun x y -> let minus' _ n_opt m_opt = match (n_opt, m_opt) with - | None, None - -> None - | Some v, None - -> is_non_zero v - | None, Some v - -> is_non_zero (-v) - | Some n, Some m - -> is_non_zero (n - m) + | None, None -> + None + | Some v, None -> + is_non_zero v + | None, Some v -> + is_non_zero (-v) + | Some n, Some m -> + is_non_zero (n - m) in M.merge minus' x y + let mult_const : t -> int -> t = fun x n -> M.map (( * ) n) x let div_const : t -> int -> t = fun x n -> M.map (( / ) n) x @@ -161,6 +174,7 @@ module SymLinear = struct if Int.equal v coeff then Some k else None else None + let get_one_symbol_opt : t -> Symbol.t option = one_symbol_of_coeff 1 let get_mone_symbol_opt : t -> Symbol.t option = one_symbol_of_coeff (-1) @@ -168,15 +182,19 @@ module SymLinear = struct let get_one_symbol : t -> Symbol.t = fun x -> match get_one_symbol_opt x with Some s -> s | None -> raise Not_one_symbol + let get_mone_symbol : t -> Symbol.t = fun x -> match get_mone_symbol_opt x with Some s -> s | None -> raise Not_one_symbol + let is_one_symbol : t -> bool = fun x -> match get_one_symbol_opt x with Some _ -> true | None -> false + let is_mone_symbol : t -> bool = fun x -> match get_mone_symbol_opt x with Some _ -> true | None -> false + let get_symbols : t -> Symbol.t list = fun x -> List.map ~f:fst (M.bindings x) end @@ -207,25 +225,28 @@ module Bound = struct let pp_sign ~need_plus : F.formatter -> sign_t -> unit = fun fmt -> function Plus -> if need_plus then F.fprintf fmt "+" | Minus -> F.fprintf fmt "-" + let pp_min_max : F.formatter -> min_max_t -> unit = fun fmt -> function Min -> F.fprintf fmt "min" | Max -> F.fprintf fmt "max" + let pp : F.formatter -> t -> unit = fun fmt -> function - | MInf - -> F.fprintf fmt "-oo" - | PInf - -> F.fprintf fmt "+oo" - | Linear (c, x) - -> if SymLinear.is_zero x then F.fprintf fmt "%d" c + | MInf -> + F.fprintf fmt "-oo" + | PInf -> + F.fprintf fmt "+oo" + | Linear (c, x) -> + if SymLinear.is_zero x then F.fprintf fmt "%d" c else if Int.equal c 0 then F.fprintf fmt "%a" SymLinear.pp x else F.fprintf fmt "%a + %d" SymLinear.pp x c - | MinMax (c, sign, m, d, x) - -> if Int.equal c 0 then F.fprintf fmt "%a" (pp_sign ~need_plus:false) sign + | MinMax (c, sign, m, d, x) -> + if Int.equal c 0 then F.fprintf fmt "%a" (pp_sign ~need_plus:false) sign else F.fprintf fmt "%d%a" c (pp_sign ~need_plus:true) sign ; F.fprintf fmt "%a(%d, %a)" pp_min_max m d Symbol.pp x + let of_int : int -> t = fun n -> Linear (n, SymLinear.empty) let minus_one = of_int (-1) @@ -235,39 +256,46 @@ module Bound = struct let of_sym : SymLinear.t -> t = fun s -> Linear (0, s) let is_symbolic : t -> bool = function - | MInf | PInf - -> false - | Linear (_, se) - -> not (SymLinear.is_empty se) - | MinMax _ - -> true + | MInf | PInf -> + false + | Linear (_, se) -> + not (SymLinear.is_empty se) + | MinMax _ -> + true + let opt_lift : ('a -> 'b -> bool) -> 'a option -> 'b option -> bool = fun f a_opt b_opt -> match (a_opt, b_opt) with None, _ | _, None -> false | Some a, Some b -> f a b + let eq_symbol : Symbol.t -> t -> bool = fun s -> function - | Linear (0, se) - -> opt_lift Symbol.eq (SymLinear.get_one_symbol_opt se) (Some s) - | _ - -> false + | Linear (0, se) -> + opt_lift Symbol.eq (SymLinear.get_one_symbol_opt se) (Some s) + | _ -> + false + let lift_get_one_symbol : (SymLinear.t -> Symbol.t option) -> t -> Symbol.t option = fun f -> function Linear (0, se) -> f se | _ -> None + let get_one_symbol_opt : t -> Symbol.t option = lift_get_one_symbol SymLinear.get_one_symbol_opt let get_mone_symbol_opt : t -> Symbol.t option = lift_get_one_symbol SymLinear.get_mone_symbol_opt + let get_one_symbol : t -> Symbol.t = fun x -> match get_one_symbol_opt x with Some s -> s | None -> raise Not_one_symbol + let get_mone_symbol : t -> Symbol.t = fun x -> match get_mone_symbol_opt x with Some s -> s | None -> raise Not_one_symbol + let is_one_symbol : t -> bool = fun x -> get_one_symbol_opt x <> None let is_mone_symbol : t -> bool = fun x -> get_mone_symbol_opt x <> None @@ -279,140 +307,148 @@ module Bound = struct match sign with Plus -> of_int (c + d) | Minus -> of_int (c - d) ) | Max when d <= 0 -> ( match sign with - | Plus - -> Linear (c, SymLinear.singleton s 1) - | Minus - -> Linear (c, SymLinear.singleton s (-1)) ) - | _ - -> MinMax (c, sign, m, d, s) + | Plus -> + Linear (c, SymLinear.singleton s 1) + | Minus -> + Linear (c, SymLinear.singleton s (-1)) ) + | _ -> + MinMax (c, sign, m, d, s) else MinMax (c, sign, m, d, s) + let use_symbol : Symbol.t -> t -> bool = fun s -> function - | PInf | MInf - -> false - | Linear (_, se) - -> SymLinear.find s se <> 0 - | MinMax (_, _, _, _, s') - -> Symbol.eq s s' + | PInf | MInf -> + false + | Linear (_, se) -> + SymLinear.find s se <> 0 + | MinMax (_, _, _, _, s') -> + Symbol.eq s s' + let subst1 : default:t -> t bottom_lifted -> Symbol.t -> t bottom_lifted -> t bottom_lifted = fun ~default x0 s y0 -> match (x0, y0) with - | Bottom, _ - -> x0 - | NonBottom x, _ when eq_symbol s x - -> y0 - | NonBottom x, _ when not (use_symbol s x) - -> x0 - | NonBottom _, Bottom - -> NonBottom default - | NonBottom x, NonBottom y - -> let res = + | Bottom, _ -> + x0 + | NonBottom x, _ when eq_symbol s x -> + y0 + | NonBottom x, _ when not (use_symbol s x) -> + x0 + | NonBottom _, Bottom -> + NonBottom default + | NonBottom x, NonBottom y -> + let res = match (x, y) with - | Linear (c1, se1), Linear (c2, se2) - -> let coeff = SymLinear.find s se1 in + | Linear (c1, se1), Linear (c2, se2) -> + let coeff = SymLinear.find s se1 in let c' = c1 + coeff * c2 in let se1 = SymLinear.add s 0 se1 in let se' = SymLinear.plus se1 (SymLinear.mult_const se2 coeff) in Linear (c', se') - | MinMax (_, Plus, Min, _, _), MInf - -> MInf - | MinMax (_, Minus, Min, _, _), MInf - -> PInf - | MinMax (_, Plus, Max, _, _), PInf - -> PInf - | MinMax (_, Minus, Max, _, _), PInf - -> MInf - | MinMax (c, Plus, Min, d, _), PInf - -> Linear (c + d, SymLinear.zero) - | MinMax (c, Minus, Min, d, _), PInf - -> Linear (c - d, SymLinear.zero) - | MinMax (c, Plus, Max, d, _), MInf - -> Linear (c + d, SymLinear.zero) - | MinMax (c, Minus, Max, d, _), MInf - -> Linear (c - d, SymLinear.zero) - | MinMax (c1, Plus, Min, d1, _), Linear (c2, se) when SymLinear.is_zero se - -> Linear (c1 + min d1 c2, SymLinear.zero) - | MinMax (c1, Minus, Min, d1, _), Linear (c2, se) when SymLinear.is_zero se - -> Linear (c1 - min d1 c2, SymLinear.zero) - | MinMax (c1, Plus, Max, d1, _), Linear (c2, se) when SymLinear.is_zero se - -> Linear (c1 + max d1 c2, SymLinear.zero) - | MinMax (c1, Minus, Max, d1, _), Linear (c2, se) when SymLinear.is_zero se - -> Linear (c1 - max d1 c2, SymLinear.zero) - | MinMax (c, sign, m, d, _), _ when is_one_symbol y - -> mk_MinMax (c, sign, m, d, get_one_symbol y) - | MinMax (c, sign, m, d, _), _ when is_mone_symbol y - -> mk_MinMax (c, neg_sign sign, neg_min_max m, -d, get_mone_symbol y) - | MinMax (c1, Plus, Min, d1, _), MinMax (c2, Plus, Min, d2, s') - -> mk_MinMax (c1 + c2, Plus, Min, min (d1 - c2) d2, s') - | MinMax (c1, Plus, Max, d1, _), MinMax (c2, Plus, Max, d2, s') - -> mk_MinMax (c1 + c2, Plus, Max, max (d1 - c2) d2, s') - | MinMax (c1, Minus, Min, d1, _), MinMax (c2, Plus, Min, d2, s') - -> mk_MinMax (c1 - c2, Minus, Min, min (d1 - c2) d2, s') - | MinMax (c1, Minus, Max, d1, _), MinMax (c2, Plus, Max, d2, s') - -> mk_MinMax (c1 - c2, Minus, Max, max (d1 - c2) d2, s') - | MinMax (c1, Plus, Min, d1, _), MinMax (c2, Minus, Max, d2, s') - -> mk_MinMax (c1 + c2, Minus, Max, max (-d1 + c2) d2, s') - | MinMax (c1, Plus, Max, d1, _), MinMax (c2, Minus, Min, d2, s') - -> mk_MinMax (c1 + c2, Minus, Min, min (-d1 + c2) d2, s') - | MinMax (c1, Minus, Min, d1, _), MinMax (c2, Minus, Max, d2, s') - -> mk_MinMax (c1 - c2, Minus, Max, max (-d1 + c2) d2, s') - | MinMax (c1, Minus, Max, d1, _), MinMax (c2, Minus, Min, d2, s') - -> mk_MinMax (c1 - c2, Minus, Min, min (-d1 + c2) d2, s') - | _ - -> default + | MinMax (_, Plus, Min, _, _), MInf -> + MInf + | MinMax (_, Minus, Min, _, _), MInf -> + PInf + | MinMax (_, Plus, Max, _, _), PInf -> + PInf + | MinMax (_, Minus, Max, _, _), PInf -> + MInf + | MinMax (c, Plus, Min, d, _), PInf -> + Linear (c + d, SymLinear.zero) + | MinMax (c, Minus, Min, d, _), PInf -> + Linear (c - d, SymLinear.zero) + | MinMax (c, Plus, Max, d, _), MInf -> + Linear (c + d, SymLinear.zero) + | MinMax (c, Minus, Max, d, _), MInf -> + Linear (c - d, SymLinear.zero) + | MinMax (c1, Plus, Min, d1, _), Linear (c2, se) when SymLinear.is_zero se -> + Linear (c1 + min d1 c2, SymLinear.zero) + | MinMax (c1, Minus, Min, d1, _), Linear (c2, se) when SymLinear.is_zero se -> + Linear (c1 - min d1 c2, SymLinear.zero) + | MinMax (c1, Plus, Max, d1, _), Linear (c2, se) when SymLinear.is_zero se -> + Linear (c1 + max d1 c2, SymLinear.zero) + | MinMax (c1, Minus, Max, d1, _), Linear (c2, se) when SymLinear.is_zero se -> + Linear (c1 - max d1 c2, SymLinear.zero) + | MinMax (c, sign, m, d, _), _ when is_one_symbol y -> + mk_MinMax (c, sign, m, d, get_one_symbol y) + | MinMax (c, sign, m, d, _), _ when is_mone_symbol y -> + mk_MinMax (c, neg_sign sign, neg_min_max m, -d, get_mone_symbol y) + | MinMax (c1, Plus, Min, d1, _), MinMax (c2, Plus, Min, d2, s') -> + mk_MinMax (c1 + c2, Plus, Min, min (d1 - c2) d2, s') + | MinMax (c1, Plus, Max, d1, _), MinMax (c2, Plus, Max, d2, s') -> + mk_MinMax (c1 + c2, Plus, Max, max (d1 - c2) d2, s') + | MinMax (c1, Minus, Min, d1, _), MinMax (c2, Plus, Min, d2, s') -> + mk_MinMax (c1 - c2, Minus, Min, min (d1 - c2) d2, s') + | MinMax (c1, Minus, Max, d1, _), MinMax (c2, Plus, Max, d2, s') -> + mk_MinMax (c1 - c2, Minus, Max, max (d1 - c2) d2, s') + | MinMax (c1, Plus, Min, d1, _), MinMax (c2, Minus, Max, d2, s') -> + mk_MinMax (c1 + c2, Minus, Max, max (-d1 + c2) d2, s') + | MinMax (c1, Plus, Max, d1, _), MinMax (c2, Minus, Min, d2, s') -> + mk_MinMax (c1 + c2, Minus, Min, min (-d1 + c2) d2, s') + | MinMax (c1, Minus, Min, d1, _), MinMax (c2, Minus, Max, d2, s') -> + mk_MinMax (c1 - c2, Minus, Max, max (-d1 + c2) d2, s') + | MinMax (c1, Minus, Max, d1, _), MinMax (c2, Minus, Min, d2, s') -> + mk_MinMax (c1 - c2, Minus, Min, min (-d1 + c2) d2, s') + | _ -> + default in NonBottom res + let int_ub_of_minmax = function - | MinMax (c, Plus, Min, d, _) - -> Some (c + d) - | MinMax (c, Minus, Max, d, s) when Symbol.is_unsigned s - -> Some (min c (c - d)) - | MinMax (c, Minus, Max, d, _) - -> Some (c - d) - | MinMax _ - -> None - | MInf | PInf | Linear _ - -> assert false + | MinMax (c, Plus, Min, d, _) -> + Some (c + d) + | MinMax (c, Minus, Max, d, s) when Symbol.is_unsigned s -> + Some (min c (c - d)) + | MinMax (c, Minus, Max, d, _) -> + Some (c - d) + | MinMax _ -> + None + | MInf | PInf | Linear _ -> + assert false + let int_lb_of_minmax = function - | MinMax (c, Plus, Max, d, s) when Symbol.is_unsigned s - -> Some (max c (c + d)) - | MinMax (c, Plus, Max, d, _) - -> Some (c + d) - | MinMax (c, Minus, Min, d, _) - -> Some (c - d) - | MinMax _ - -> None - | MInf | PInf | Linear _ - -> assert false + | MinMax (c, Plus, Max, d, s) when Symbol.is_unsigned s -> + Some (max c (c + d)) + | MinMax (c, Plus, Max, d, _) -> + Some (c + d) + | MinMax (c, Minus, Min, d, _) -> + Some (c - d) + | MinMax _ -> + None + | MInf | PInf | Linear _ -> + assert false + let linear_ub_of_minmax = function - | MinMax (c, Plus, Min, _, x) - -> Some (Linear (c, SymLinear.singleton x 1)) - | MinMax (c, Minus, Max, _, x) - -> Some (Linear (c, SymLinear.singleton x (-1))) - | MinMax _ - -> None - | MInf | PInf | Linear _ - -> assert false + | MinMax (c, Plus, Min, _, x) -> + Some (Linear (c, SymLinear.singleton x 1)) + | MinMax (c, Minus, Max, _, x) -> + Some (Linear (c, SymLinear.singleton x (-1))) + | MinMax _ -> + None + | MInf | PInf | Linear _ -> + assert false + let linear_lb_of_minmax = function - | MinMax (c, Plus, Max, _, x) - -> Some (Linear (c, SymLinear.singleton x 1)) - | MinMax (c, Minus, Min, _, x) - -> Some (Linear (c, SymLinear.singleton x (-1))) - | MinMax _ - -> None - | MInf | PInf | Linear _ - -> assert false + | MinMax (c, Plus, Max, _, x) -> + Some (Linear (c, SymLinear.singleton x 1)) + | MinMax (c, Minus, Min, _, x) -> + Some (Linear (c, SymLinear.singleton x (-1))) + | MinMax _ -> + None + | MInf | PInf | Linear _ -> + assert false + let le_minmax_by_int x y = match (int_ub_of_minmax x, int_lb_of_minmax y) with Some n, Some m -> n <= m | _, _ -> false + let le_opt1 le opt_n m = Option.value_map opt_n ~default:false ~f:(fun n -> le n m) let le_opt2 le n opt_m = Option.value_map opt_m ~default:false ~f:(fun m -> le n m) @@ -420,40 +456,42 @@ module Bound = struct let rec le : t -> t -> bool = fun x y -> match (x, y) with - | MInf, _ | _, PInf - -> true - | _, MInf | PInf, _ - -> false - | Linear (c0, x0), Linear (c1, x1) - -> c0 <= c1 && SymLinear.le x0 x1 + | MInf, _ | _, PInf -> + true + | _, MInf | PInf, _ -> + false + | Linear (c0, x0), Linear (c1, x1) -> + c0 <= c1 && SymLinear.le x0 x1 | MinMax (c1, sign1, m1, d1, x1), MinMax (c2, sign2, m2, d2, x2) - when sign_equal sign1 sign2 && min_max_equal m1 m2 - -> c1 <= c2 && Int.equal d1 d2 && Symbol.eq x1 x2 - | MinMax _, MinMax _ when le_minmax_by_int x y - -> true + when sign_equal sign1 sign2 && min_max_equal m1 m2 -> + c1 <= c2 && Int.equal d1 d2 && Symbol.eq x1 x2 + | MinMax _, MinMax _ when le_minmax_by_int x y -> + true | MinMax (c1, Plus, Min, _, x1), MinMax (c2, Plus, Max, _, x2) - | MinMax (c1, Minus, Max, _, x1), MinMax (c2, Minus, Min, _, x2) - -> c1 <= c2 && Symbol.eq x1 x2 - | MinMax _, Linear (c, se) - -> SymLinear.is_ge_zero se && le_opt1 ( <= ) (int_ub_of_minmax x) c + | MinMax (c1, Minus, Max, _, x1), MinMax (c2, Minus, Min, _, x2) -> + c1 <= c2 && Symbol.eq x1 x2 + | MinMax _, Linear (c, se) -> + SymLinear.is_ge_zero se && le_opt1 ( <= ) (int_ub_of_minmax x) c || le_opt1 le (linear_ub_of_minmax x) y - | Linear (c, se), MinMax _ - -> SymLinear.is_le_zero se && le_opt2 ( <= ) c (int_lb_of_minmax y) + | Linear (c, se), MinMax _ -> + SymLinear.is_le_zero se && le_opt2 ( <= ) c (int_lb_of_minmax y) || le_opt2 le x (linear_lb_of_minmax y) - | _, _ - -> false + | _, _ -> + false + let lt : t -> t -> bool = fun x y -> match (x, y) with - | MInf, Linear _ | MInf, MinMax _ | MInf, PInf | Linear _, PInf | MinMax _, PInf - -> true - | Linear (c, x), _ - -> le (Linear (c + 1, x)) y - | MinMax (c, sign, min_max, d, x), _ - -> le (mk_MinMax (c + 1, sign, min_max, d, x)) y - | _, _ - -> false + | MInf, Linear _ | MInf, MinMax _ | MInf, PInf | Linear _, PInf | MinMax _, PInf -> + true + | Linear (c, x), _ -> + le (Linear (c + 1, x)) y + | MinMax (c, sign, min_max, d, x), _ -> + le (mk_MinMax (c + 1, sign, min_max, d, x)) y + | _, _ -> + false + let gt : t -> t -> bool = fun x y -> lt y x @@ -463,24 +501,26 @@ module Bound = struct let ller = le lhs rhs in let rlel = le rhs lhs in match (ller, rlel) with - | true, true - -> `Equal - | true, false - -> `LeftSmallerThanRight - | false, true - -> `RightSmallerThanLeft - | false, false - -> `NotComparable + | true, true -> + `Equal + | true, false -> + `LeftSmallerThanRight + | false, true -> + `RightSmallerThanLeft + | false, false -> + `NotComparable + let remove_max_int : t -> t = fun x -> match x with - | MinMax (c, Plus, Max, _, s) - -> Linear (c, SymLinear.singleton s 1) - | MinMax (c, Minus, Min, _, s) - -> Linear (c, SymLinear.singleton s (-1)) - | _ - -> x + | MinMax (c, Plus, Max, _, s) -> + Linear (c, SymLinear.singleton s 1) + | MinMax (c, Minus, Min, _, s) -> + Linear (c, SymLinear.singleton s (-1)) + | _ -> + x + let rec lb : ?default:t -> t -> t -> t = fun ?(default= MInf) x y -> @@ -488,44 +528,45 @@ module Bound = struct else if le y x then y else match (x, y) with - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_one_symbol x2 - -> mk_MinMax (c2, Plus, Min, c1 - c2, SymLinear.get_one_symbol x2) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_one_symbol x1 && SymLinear.is_zero x2 - -> mk_MinMax (c1, Plus, Min, c2 - c1, SymLinear.get_one_symbol x1) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_mone_symbol x2 - -> mk_MinMax (c2, Minus, Max, c2 - c1, SymLinear.get_mone_symbol x2) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_mone_symbol x1 && SymLinear.is_zero x2 - -> mk_MinMax (c1, Minus, Max, c1 - c2, SymLinear.get_mone_symbol x1) + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_one_symbol x2 -> + mk_MinMax (c2, Plus, Min, c1 - c2, SymLinear.get_one_symbol x2) + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_one_symbol x1 && SymLinear.is_zero x2 -> + mk_MinMax (c1, Plus, Min, c2 - c1, SymLinear.get_one_symbol x1) + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_mone_symbol x2 -> + mk_MinMax (c2, Minus, Max, c2 - c1, SymLinear.get_mone_symbol x2) + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_mone_symbol x1 && SymLinear.is_zero x2 -> + mk_MinMax (c1, Minus, Max, c1 - c2, SymLinear.get_mone_symbol x1) | MinMax (c1, Plus, Min, d1, s), Linear (c2, se) | Linear (c2, se), MinMax (c1, Plus, Min, d1, s) - when SymLinear.is_zero se - -> mk_MinMax (c1, Plus, Min, min d1 (c2 - c1), s) + when SymLinear.is_zero se -> + mk_MinMax (c1, Plus, Min, min d1 (c2 - c1), s) | MinMax (c1, Plus, Max, _, s), Linear (c2, se) | Linear (c2, se), MinMax (c1, Plus, Max, _, s) - when SymLinear.is_zero se - -> mk_MinMax (c1, Plus, Min, c2 - c1, s) + when SymLinear.is_zero se -> + mk_MinMax (c1, Plus, Min, c2 - c1, s) | MinMax (c1, Minus, Min, _, s), Linear (c2, se) | Linear (c2, se), MinMax (c1, Minus, Min, _, s) - when SymLinear.is_zero se - -> mk_MinMax (c1, Minus, Max, c1 - c2, s) + when SymLinear.is_zero se -> + mk_MinMax (c1, Minus, Max, c1 - c2, s) | MinMax (c1, Minus, Max, d1, s), Linear (c2, se) | Linear (c2, se), MinMax (c1, Minus, Max, d1, s) - when SymLinear.is_zero se - -> mk_MinMax (c1, Minus, Max, max d1 (c1 - c2), s) + when SymLinear.is_zero se -> + mk_MinMax (c1, Minus, Max, max d1 (c1 - c2), s) | MinMax (_, Plus, Min, _, _), MinMax (_, Plus, Max, _, _) | MinMax (_, Plus, Min, _, _), MinMax (_, Minus, Min, _, _) | MinMax (_, Minus, Max, _, _), MinMax (_, Plus, Max, _, _) - | MinMax (_, Minus, Max, _, _), MinMax (_, Minus, Min, _, _) - -> lb ~default x (remove_max_int y) + | MinMax (_, Minus, Max, _, _), MinMax (_, Minus, Min, _, _) -> + lb ~default x (remove_max_int y) | MinMax (_, Plus, Max, _, _), MinMax (_, Plus, Min, _, _) | MinMax (_, Minus, Min, _, _), MinMax (_, Plus, Min, _, _) | MinMax (_, Plus, Max, _, _), MinMax (_, Minus, Max, _, _) - | MinMax (_, Minus, Min, _, _), MinMax (_, Minus, Max, _, _) - -> lb ~default (remove_max_int x) y - | MinMax (c1, Plus, Max, d1, _), MinMax (c2, Plus, Max, d2, _) - -> Linear (min (c1 + d1) (c2 + d2), SymLinear.zero) - | _, _ - -> default + | MinMax (_, Minus, Min, _, _), MinMax (_, Minus, Max, _, _) -> + lb ~default (remove_max_int x) y + | MinMax (c1, Plus, Max, d1, _), MinMax (c2, Plus, Max, d2, _) -> + Linear (min (c1 + d1) (c2 + d2), SymLinear.zero) + | _, _ -> + default + let ub : ?default:t -> t -> t -> t = fun ?(default= PInf) x y -> @@ -533,16 +574,17 @@ module Bound = struct else if le y x then x else match (x, y) with - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_one_symbol x2 - -> mk_MinMax (c2, Plus, Max, c1 - c2, SymLinear.get_one_symbol x2) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_one_symbol x1 && SymLinear.is_zero x2 - -> mk_MinMax (c1, Plus, Max, c2 - c1, SymLinear.get_one_symbol x1) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_mone_symbol x2 - -> mk_MinMax (c2, Minus, Min, c2 - c1, SymLinear.get_mone_symbol x2) - | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_mone_symbol x1 && SymLinear.is_zero x2 - -> mk_MinMax (c1, Minus, Min, c1 - c2, SymLinear.get_mone_symbol x1) - | _, _ - -> default + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_one_symbol x2 -> + mk_MinMax (c2, Plus, Max, c1 - c2, SymLinear.get_one_symbol x2) + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_one_symbol x1 && SymLinear.is_zero x2 -> + mk_MinMax (c1, Plus, Max, c2 - c1, SymLinear.get_one_symbol x1) + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_zero x1 && SymLinear.is_mone_symbol x2 -> + mk_MinMax (c2, Minus, Min, c2 - c1, SymLinear.get_mone_symbol x2) + | Linear (c1, x1), Linear (c2, x2) when SymLinear.is_mone_symbol x1 && SymLinear.is_zero x2 -> + mk_MinMax (c1, Minus, Min, c1 - c2, SymLinear.get_mone_symbol x1) + | _, _ -> + default + let widen_l : t -> t -> t = fun x y -> @@ -550,12 +592,14 @@ module Bound = struct else if le x y then x else MInf + let widen_u : t -> t -> t = fun x y -> if equal x MInf || equal y MInf then L.(die InternalError) "Upper bound cannot be -oo." else if le y x then x else PInf + let initial : t = of_int 0 let zero : t = Linear (0, SymLinear.zero) @@ -567,6 +611,7 @@ module Bound = struct let is_some_const : int -> t -> bool = fun c x -> match x with Linear (c', y) -> Int.equal c c' && SymLinear.is_zero y | _ -> false + let is_zero : t -> bool = is_some_const 0 let is_one : t -> bool = is_some_const 1 @@ -574,122 +619,131 @@ module Bound = struct let is_const : t -> int option = fun x -> match x with Linear (c, y) when SymLinear.is_zero y -> Some c | _ -> None + (* substitution symbols in ``x'' with respect to ``map'' *) let subst : default:t -> t -> t bottom_lifted SubstMap.t -> t bottom_lifted = fun ~default x map -> let subst_helper s y x = let y' = match y with - | Bottom - -> Bottom - | NonBottom r - -> NonBottom (if Symbol.is_unsigned s then ub ~default:r zero r else r) + | Bottom -> + Bottom + | NonBottom r -> + NonBottom (if Symbol.is_unsigned s then ub ~default:r zero r else r) in subst1 ~default x s y' in SubstMap.fold subst_helper map (NonBottom x) + let plus_l : t -> t -> t = fun x y -> match (x, y) with - | _, _ when is_zero x - -> y - | _, _ when is_zero y - -> x - | Linear (c1, x1), Linear (c2, x2) - -> Linear (c1 + c2, SymLinear.plus x1 x2) + | _, _ when is_zero x -> + y + | _, _ when is_zero y -> + x + | Linear (c1, x1), Linear (c2, x2) -> + Linear (c1 + c2, SymLinear.plus x1 x2) | MinMax (c1, sign, min_max, d1, x1), Linear (c2, x2) | Linear (c2, x2), MinMax (c1, sign, min_max, d1, x1) - when SymLinear.is_zero x2 - -> mk_MinMax (c1 + c2, sign, min_max, d1, x1) + when SymLinear.is_zero x2 -> + mk_MinMax (c1 + c2, sign, min_max, d1, x1) | MinMax (c1, Plus, Max, d1, _), Linear (c2, x2) - | Linear (c2, x2), MinMax (c1, Plus, Max, d1, _) - -> Linear (c1 + d1 + c2, x2) + | Linear (c2, x2), MinMax (c1, Plus, Max, d1, _) -> + Linear (c1 + d1 + c2, x2) | MinMax (c1, Minus, Min, d1, _), Linear (c2, x2) - | Linear (c2, x2), MinMax (c1, Minus, Min, d1, _) - -> Linear (c1 - d1 + c2, x2) - | _, _ - -> MInf + | Linear (c2, x2), MinMax (c1, Minus, Min, d1, _) -> + Linear (c1 - d1 + c2, x2) + | _, _ -> + MInf + let plus_u : t -> t -> t = fun x y -> match (x, y) with - | _, _ when is_zero x - -> y - | _, _ when is_zero y - -> x - | Linear (c1, x1), Linear (c2, x2) - -> Linear (c1 + c2, SymLinear.plus x1 x2) + | _, _ when is_zero x -> + y + | _, _ when is_zero y -> + x + | Linear (c1, x1), Linear (c2, x2) -> + Linear (c1 + c2, SymLinear.plus x1 x2) | MinMax (c1, sign, min_max, d1, x1), Linear (c2, x2) | Linear (c2, x2), MinMax (c1, sign, min_max, d1, x1) - when SymLinear.is_zero x2 - -> mk_MinMax (c1 + c2, sign, min_max, d1, x1) + when SymLinear.is_zero x2 -> + mk_MinMax (c1 + c2, sign, min_max, d1, x1) | MinMax (c1, Plus, Min, d1, _), Linear (c2, x2) - | Linear (c2, x2), MinMax (c1, Plus, Min, d1, _) - -> Linear (c1 + d1 + c2, x2) + | Linear (c2, x2), MinMax (c1, Plus, Min, d1, _) -> + Linear (c1 + d1 + c2, x2) | MinMax (c1, Minus, Max, d1, _), Linear (c2, x2) - | Linear (c2, x2), MinMax (c1, Minus, Max, d1, _) - -> Linear (c1 - d1 + c2, x2) - | _, _ - -> PInf + | Linear (c2, x2), MinMax (c1, Minus, Max, d1, _) -> + Linear (c1 - d1 + c2, x2) + | _, _ -> + PInf + let mult_const : t -> int -> t option = fun x n -> assert (n <> 0) ; match x with - | MInf - -> Some (if n > 0 then MInf else PInf) - | PInf - -> Some (if n > 0 then PInf else MInf) - | Linear (c, x') - -> Some (Linear (c * n, SymLinear.mult_const x' n)) - | _ - -> None + | MInf -> + Some (if n > 0 then MInf else PInf) + | PInf -> + Some (if n > 0 then PInf else MInf) + | Linear (c, x') -> + Some (Linear (c * n, SymLinear.mult_const x' n)) + | _ -> + None + let div_const : t -> int -> t option = fun x n -> if Int.equal n 0 then Some zero else match x with - | MInf - -> Some (if n > 0 then MInf else PInf) - | PInf - -> Some (if n > 0 then PInf else MInf) - | Linear (c, x') - -> if Int.equal (c mod n) 0 && SymLinear.is_mod_zero x' n then + | MInf -> + Some (if n > 0 then MInf else PInf) + | PInf -> + Some (if n > 0 then PInf else MInf) + | Linear (c, x') -> + if Int.equal (c mod n) 0 && SymLinear.is_mod_zero x' n then Some (Linear (c / n, SymLinear.div_const x' n)) else None - | _ - -> None + | _ -> + None + let neg : t -> t option = function - | MInf - -> Some PInf - | PInf - -> Some MInf - | Linear (c, x) - -> Some (Linear (-c, SymLinear.neg x)) - | MinMax (c, sign, min_max, d, x) - -> Some (mk_MinMax (-c, neg_sign sign, min_max, d, x)) + | MInf -> + Some PInf + | PInf -> + Some MInf + | Linear (c, x) -> + Some (Linear (-c, SymLinear.neg x)) + | MinMax (c, sign, min_max, d, x) -> + Some (mk_MinMax (-c, neg_sign sign, min_max, d, x)) + let get_symbols : t -> Symbol.t list = function - | MInf | PInf - -> [] - | Linear (_, se) - -> SymLinear.get_symbols se - | MinMax (_, _, _, _, s) - -> [s] + | MInf | PInf -> + [] + | Linear (_, se) -> + SymLinear.get_symbols se + | MinMax (_, _, _, _, s) -> + [s] + let are_similar b1 b2 = match (b1, b2) with - | MInf, MInf - -> true - | PInf, PInf - -> true - | (Linear _ | MinMax _), (Linear _ | MinMax _) - -> true - | _ - -> false + | MInf, MInf -> + true + | PInf, PInf -> + true + | (Linear _ | MinMax _), (Linear _ | MinMax _) -> + true + | _ -> + false + let is_not_infty : t -> bool = function MInf | PInf -> false | _ -> true end @@ -712,6 +766,7 @@ module ItvPure = struct fun (l, u) -> match (Bound.is_const l, Bound.is_const u) with Some _, Some _ -> true | _, _ -> false + let have_similar_bounds (l1, u1) (l2, u2) = Bound.are_similar l1 l2 && Bound.are_similar u1 u2 let make : Bound.t -> Bound.t -> t = fun l u -> (l, u) @@ -721,51 +776,56 @@ module ItvPure = struct match (Bound.subst ~default:Bound.MInf (lb x) map, Bound.subst ~default:Bound.PInf (ub x) map) with - | NonBottom l, NonBottom u - -> NonBottom (l, u) - | _ - -> Bottom + | NonBottom l, NonBottom u -> + NonBottom (l, u) + | _ -> + Bottom + let ( <= ) : lhs:t -> rhs:t -> bool = fun ~lhs:(l1, u1) ~rhs:(l2, u2) -> Bound.le l2 l1 && Bound.le u1 u2 + let xcompare ~lhs:(l1, u1) ~rhs:(l2, u2) = let lcmp = Bound.xcompare ~lhs:l1 ~rhs:l2 in let ucmp = Bound.xcompare ~lhs:u1 ~rhs:u2 in match (lcmp, ucmp) with - | `Equal, `Equal - -> `Equal + | `Equal, `Equal -> + `Equal | `NotComparable, _ | _, `NotComparable -> ( match Bound.xcompare ~lhs:u1 ~rhs:l2 with - | `LeftSmallerThanRight - -> `LeftSmallerThanRight + | `LeftSmallerThanRight -> + `LeftSmallerThanRight | u1l2 -> match (Bound.xcompare ~lhs:u2 ~rhs:l1, u1l2) with - | `LeftSmallerThanRight, _ - -> `RightSmallerThanLeft - | `Equal, `Equal - -> `Equal (* weird, though *) - | _, `Equal - -> `LeftSmallerThanRight - | _ - -> `NotComparable ) - | (`LeftSmallerThanRight | `Equal), (`LeftSmallerThanRight | `Equal) - -> `LeftSmallerThanRight - | (`RightSmallerThanLeft | `Equal), (`RightSmallerThanLeft | `Equal) - -> `RightSmallerThanLeft - | `LeftSmallerThanRight, `RightSmallerThanLeft - -> `LeftSubsumesRight - | `RightSmallerThanLeft, `LeftSmallerThanRight - -> `RightSubsumesLeft + | `LeftSmallerThanRight, _ -> + `RightSmallerThanLeft + | `Equal, `Equal -> + `Equal (* weird, though *) + | _, `Equal -> + `LeftSmallerThanRight + | _ -> + `NotComparable ) + | (`LeftSmallerThanRight | `Equal), (`LeftSmallerThanRight | `Equal) -> + `LeftSmallerThanRight + | (`RightSmallerThanLeft | `Equal), (`RightSmallerThanLeft | `Equal) -> + `RightSmallerThanLeft + | `LeftSmallerThanRight, `RightSmallerThanLeft -> + `LeftSubsumesRight + | `RightSmallerThanLeft, `LeftSmallerThanRight -> + `RightSubsumesLeft + let join : t -> t -> t = fun (l1, u1) (l2, u2) -> (Bound.lb l1 l2, Bound.ub u1 u2) let widen : prev:t -> next:t -> num_iters:int -> t = fun ~prev:(l1, u1) ~next:(l2, u2) ~num_iters:_ -> (Bound.widen_l l1 l2, Bound.widen_u u1 u2) + let pp : F.formatter -> t -> unit = fun fmt (l, u) -> F.fprintf fmt "[%a, %a]" Bound.pp l Bound.pp u + let of_bound bound = (bound, bound) let of_int n = of_bound (Bound.of_int n) @@ -773,12 +833,14 @@ module ItvPure = struct let of_int_lit : IntLit.t -> t option = fun s -> match IntLit.to_int s with size -> Some (of_int size) | exception _ -> None + let make_sym : unsigned:bool -> Typ.Procname.t -> (unit -> int) -> t = fun ~unsigned pname new_sym_num -> let lower = Bound.of_sym (SymLinear.make ~unsigned pname (new_sym_num ())) in let upper = Bound.of_sym (SymLinear.make ~unsigned pname (new_sym_num ())) in (lower, upper) + let m1_255 = (Bound.minus_one, Bound._255) let nat = (Bound.zero, Bound.PInf) @@ -804,10 +866,11 @@ module ItvPure = struct let is_const : t -> int option = fun (l, u) -> match (Bound.is_const l, Bound.is_const u) with - | Some n, Some m when Int.equal n m - -> Some n - | _, _ - -> None + | Some n, Some m when Int.equal n m -> + Some n + | _, _ -> + None + let is_one : t -> bool = fun (l, u) -> Bound.is_one l && Bound.is_one u @@ -816,6 +879,7 @@ module ItvPure = struct let is_true : t -> bool = fun (l, u) -> Bound.le (Bound.of_int 1) l || Bound.le u (Bound.of_int (-1)) + let is_false : t -> bool = is_zero let is_symbolic : t -> bool = fun (lb, ub) -> Bound.is_symbolic lb || Bound.is_symbolic ub @@ -830,9 +894,11 @@ module ItvPure = struct let u' = Option.value ~default:Bound.PInf (Bound.neg l) in (l', u') + let lnot : t -> t = fun x -> if is_true x then false_sem else if is_false x then true_sem else unknown_bool + let plus : t -> t -> t = fun (l1, u1) (l2, u2) -> (Bound.plus_l l1 l2, Bound.plus_u u1 u2) let minus : t -> t -> t = fun i1 i2 -> plus i1 (neg i2) @@ -849,6 +915,7 @@ module ItvPure = struct let u' = Option.value ~default:Bound.PInf (Bound.mult_const l n) in (l', u') + (* Returns a correct value only when all coefficients are divided by n without remainder. *) let div_const : t -> int -> t = @@ -863,59 +930,67 @@ module ItvPure = struct let u' = Option.value ~default:Bound.PInf (Bound.div_const l n) in (l', u') + let mult : t -> t -> t = fun x y -> match (is_const x, is_const y) with - | _, Some n - -> mult_const x n - | Some n, _ - -> mult_const y n - | None, None - -> top + | _, Some n -> + mult_const x n + | Some n, _ -> + mult_const y n + | None, None -> + top + let div : t -> t -> t = fun x y -> match is_const y with Some n when n <> 0 -> div_const x n | _ -> top + (* x % [0,0] does nothing. *) let mod_sem : t -> t -> t = fun x y -> match (is_const x, is_const y) with - | _, Some 0 - -> x - | Some n, Some m - -> of_int (n mod m) - | _, Some m - -> let abs_m = abs m in + | _, Some 0 -> + x + | Some n, Some m -> + of_int (n mod m) + | _, Some m -> + let abs_m = abs m in if is_ge_zero x then (Bound.zero, Bound.of_int (abs_m - 1)) else if is_le_zero x then (Bound.of_int (-abs_m + 1), Bound.zero) else (Bound.of_int (-abs_m + 1), Bound.of_int (abs_m - 1)) - | _, None - -> top + | _, None -> + top + (* x << [-1,-1] does nothing. *) let shiftlt : t -> t -> t = fun x y -> match is_const y with Some n -> if n >= 0 then mult_const x (1 lsl n) else x | None -> top + (* x >> [-1,-1] does nothing. *) let shiftrt : t -> t -> t = fun x y -> match is_const y with - | Some n - -> if n >= 0 && n < 63 then div_const x (1 lsl n) else x - | None - -> top + | Some n -> + if n >= 0 && n < 63 then div_const x (1 lsl n) else x + | None -> + top + let lt_sem : t -> t -> t = fun (l1, u1) (l2, u2) -> if Bound.lt u1 l2 then true_sem else if Bound.le u2 l1 then false_sem else unknown_bool + let gt_sem : t -> t -> t = fun x y -> lt_sem y x let le_sem : t -> t -> t = fun (l1, u1) (l2, u2) -> if Bound.le u1 l2 then true_sem else if Bound.lt u2 l1 then false_sem else unknown_bool + let ge_sem : t -> t -> t = fun x y -> le_sem y x let eq_sem : t -> t -> t = @@ -924,83 +999,90 @@ module ItvPure = struct else if Bound.lt u1 l2 || Bound.lt u2 l1 then false_sem else unknown_bool + let ne_sem : t -> t -> t = fun (l1, u1) (l2, u2) -> if Bound.eq l1 u1 && Bound.eq u1 l2 && Bound.eq l2 u2 then false_sem else if Bound.lt u1 l2 || Bound.lt u2 l1 then true_sem else unknown_bool + let land_sem : t -> t -> t = fun x y -> if is_true x && is_true y then true_sem else if is_false x || is_false y then false_sem else unknown_bool + let lor_sem : t -> t -> t = fun x y -> if is_true x || is_true y then true_sem else if is_false x && is_false y then false_sem else unknown_bool + let min_sem : t -> t -> t = fun (l1, u1) (l2, u2) -> (Bound.lb l1 l2, Bound.lb ~default:u1 u1 u2) let is_invalid : t -> bool = function - | Bound.PInf, _ | _, Bound.MInf - -> true - | l, u - -> Bound.lt u l + | Bound.PInf, _ | _, Bound.MInf -> + true + | l, u -> + Bound.lt u l + let prune_le : t -> t -> t = fun x y -> match (x, y) with - | (l1, Bound.PInf), (_, u2) - -> (l1, u2) - | (l1, Bound.Linear (c1, s1)), (_, Bound.Linear (c2, s2)) when SymLinear.eq s1 s2 - -> (l1, Bound.Linear (min c1 c2, s1)) - | (l1, Bound.Linear (c, se)), (_, u) when SymLinear.is_zero se && Bound.is_one_symbol u - -> (l1, Bound.mk_MinMax (0, Bound.Plus, Bound.Min, c, Bound.get_one_symbol u)) - | (l1, u), (_, Bound.Linear (c, se)) when SymLinear.is_zero se && Bound.is_one_symbol u - -> (l1, Bound.mk_MinMax (0, Bound.Plus, Bound.Min, c, Bound.get_one_symbol u)) - | (l1, Bound.Linear (c, se)), (_, u) when SymLinear.is_zero se && Bound.is_mone_symbol u - -> (l1, Bound.mk_MinMax (0, Bound.Minus, Bound.Max, -c, Bound.get_mone_symbol u)) - | (l1, u), (_, Bound.Linear (c, se)) when SymLinear.is_zero se && Bound.is_mone_symbol u - -> (l1, Bound.mk_MinMax (0, Bound.Minus, Bound.Max, -c, Bound.get_mone_symbol u)) + | (l1, Bound.PInf), (_, u2) -> + (l1, u2) + | (l1, Bound.Linear (c1, s1)), (_, Bound.Linear (c2, s2)) when SymLinear.eq s1 s2 -> + (l1, Bound.Linear (min c1 c2, s1)) + | (l1, Bound.Linear (c, se)), (_, u) when SymLinear.is_zero se && Bound.is_one_symbol u -> + (l1, Bound.mk_MinMax (0, Bound.Plus, Bound.Min, c, Bound.get_one_symbol u)) + | (l1, u), (_, Bound.Linear (c, se)) when SymLinear.is_zero se && Bound.is_one_symbol u -> + (l1, Bound.mk_MinMax (0, Bound.Plus, Bound.Min, c, Bound.get_one_symbol u)) + | (l1, Bound.Linear (c, se)), (_, u) when SymLinear.is_zero se && Bound.is_mone_symbol u -> + (l1, Bound.mk_MinMax (0, Bound.Minus, Bound.Max, -c, Bound.get_mone_symbol u)) + | (l1, u), (_, Bound.Linear (c, se)) when SymLinear.is_zero se && Bound.is_mone_symbol u -> + (l1, Bound.mk_MinMax (0, Bound.Minus, Bound.Max, -c, Bound.get_mone_symbol u)) | (l1, Bound.Linear (c1, se)), (_, Bound.MinMax (c2, Bound.Plus, Bound.Min, d2, se')) | (l1, Bound.MinMax (c2, Bound.Plus, Bound.Min, d2, se')), (_, Bound.Linear (c1, se)) - when SymLinear.is_zero se - -> (l1, Bound.mk_MinMax (c2, Bound.Plus, Bound.Min, min (c1 - c2) d2, se')) + when SymLinear.is_zero se -> + (l1, Bound.mk_MinMax (c2, Bound.Plus, Bound.Min, min (c1 - c2) d2, se')) | ( (l1, Bound.MinMax (c1, Bound.Plus, Bound.Min, d1, se1)) , (_, Bound.MinMax (c2, Bound.Plus, Bound.Min, d2, se2)) ) - when Int.equal c1 c2 && Symbol.eq se1 se2 - -> (l1, Bound.mk_MinMax (c1, Bound.Plus, Bound.Min, min d1 d2, se1)) - | _ - -> x + when Int.equal c1 c2 && Symbol.eq se1 se2 -> + (l1, Bound.mk_MinMax (c1, Bound.Plus, Bound.Min, min d1 d2, se1)) + | _ -> + x + let prune_ge : t -> t -> t = fun x y -> match (x, y) with - | (Bound.MInf, u1), (l2, _) - -> (l2, u1) - | (Bound.Linear (c1, s1), u1), (Bound.Linear (c2, s2), _) when SymLinear.eq s1 s2 - -> (Bound.Linear (max c1 c2, s1), u1) - | (Bound.Linear (c, se), u1), (l, _) when SymLinear.is_zero se && Bound.is_one_symbol l - -> (Bound.mk_MinMax (0, Bound.Plus, Bound.Max, c, Bound.get_one_symbol l), u1) - | (l, u1), (Bound.Linear (c, se), _) when SymLinear.is_zero se && Bound.is_one_symbol l - -> (Bound.mk_MinMax (0, Bound.Plus, Bound.Max, c, Bound.get_one_symbol l), u1) - | (Bound.Linear (c, se), u1), (l, _) when SymLinear.is_zero se && Bound.is_mone_symbol l - -> (Bound.mk_MinMax (0, Bound.Minus, Bound.Min, c, Bound.get_mone_symbol l), u1) - | (l, u1), (Bound.Linear (c, se), _) when SymLinear.is_zero se && Bound.is_mone_symbol l - -> (Bound.mk_MinMax (0, Bound.Minus, Bound.Min, c, Bound.get_mone_symbol l), u1) + | (Bound.MInf, u1), (l2, _) -> + (l2, u1) + | (Bound.Linear (c1, s1), u1), (Bound.Linear (c2, s2), _) when SymLinear.eq s1 s2 -> + (Bound.Linear (max c1 c2, s1), u1) + | (Bound.Linear (c, se), u1), (l, _) when SymLinear.is_zero se && Bound.is_one_symbol l -> + (Bound.mk_MinMax (0, Bound.Plus, Bound.Max, c, Bound.get_one_symbol l), u1) + | (l, u1), (Bound.Linear (c, se), _) when SymLinear.is_zero se && Bound.is_one_symbol l -> + (Bound.mk_MinMax (0, Bound.Plus, Bound.Max, c, Bound.get_one_symbol l), u1) + | (Bound.Linear (c, se), u1), (l, _) when SymLinear.is_zero se && Bound.is_mone_symbol l -> + (Bound.mk_MinMax (0, Bound.Minus, Bound.Min, c, Bound.get_mone_symbol l), u1) + | (l, u1), (Bound.Linear (c, se), _) when SymLinear.is_zero se && Bound.is_mone_symbol l -> + (Bound.mk_MinMax (0, Bound.Minus, Bound.Min, c, Bound.get_mone_symbol l), u1) | (Bound.Linear (c1, se), u1), (Bound.MinMax (c2, Bound.Plus, Bound.Max, d2, se'), _) | (Bound.MinMax (c2, Bound.Plus, Bound.Max, d2, se'), u1), (Bound.Linear (c1, se), _) - when SymLinear.is_zero se - -> (Bound.mk_MinMax (c2, Bound.Plus, Bound.Max, max (c1 - c2) d2, se'), u1) + when SymLinear.is_zero se -> + (Bound.mk_MinMax (c2, Bound.Plus, Bound.Max, max (c1 - c2) d2, se'), u1) | ( (Bound.MinMax (c1, Bound.Plus, Bound.Max, d1, se1), u1) , (Bound.MinMax (c2, Bound.Plus, Bound.Max, d2, se2), _) ) - when Int.equal c1 c2 && Symbol.eq se1 se2 - -> (Bound.mk_MinMax (c1, Bound.Plus, Bound.Max, max d1 d2, se1), u1) - | _ - -> x + when Int.equal c1 c2 && Symbol.eq se1 se2 -> + (Bound.mk_MinMax (c1, Bound.Plus, Bound.Max, max d1 d2, se1), u1) + | _ -> + x + let prune_lt : t -> t -> t = fun x y -> prune_le x (minus y one) @@ -1012,6 +1094,7 @@ module ItvPure = struct else if Bound.eq u b then (l, Bound.plus_u u Bound.mone) else (l, u) + let prune_zero : t -> t = fun x -> diff x Bound.zero let prune_comp : Binop.t -> t -> t -> t option = @@ -1020,23 +1103,25 @@ module ItvPure = struct else let x = match c with - | Binop.Le - -> prune_le x y - | Binop.Ge - -> prune_ge x y - | Binop.Lt - -> prune_lt x y - | Binop.Gt - -> prune_gt x y - | _ - -> assert false + | Binop.Le -> + prune_le x y + | Binop.Ge -> + prune_ge x y + | Binop.Lt -> + prune_lt x y + | Binop.Gt -> + prune_gt x y + | _ -> + assert false in if is_invalid x then None else Some x + let prune_eq : t -> t -> t option = fun x y -> match prune_comp Binop.Le x y with None -> None | Some x' -> prune_comp Binop.Ge x' y + let prune_ne : t -> t -> t option = fun x (l, u) -> if is_invalid (l, u) then Some x @@ -1044,11 +1129,14 @@ module ItvPure = struct let x = if Bound.eq l u then diff x l else x in if is_invalid x then None else Some x + let get_symbols : t -> Symbol.t list = fun (l, u) -> List.append (Bound.get_symbols l) (Bound.get_symbols u) + let make_positive : t -> t = - fun (l, u as x) -> if Bound.lt l Bound.zero then (Bound.zero, u) else x + fun ((l, u) as x) -> if Bound.lt l Bound.zero then (Bound.zero, u) else x + let normalize : t -> t option = fun (l, u) -> if is_invalid (l, u) then None else Some (l, u) end @@ -1060,14 +1148,15 @@ type t = astate let compare : t -> t -> int = fun x y -> match (x, y) with - | Bottom, Bottom - -> 0 - | Bottom, _ - -> -1 - | _, Bottom - -> 1 - | NonBottom x, NonBottom y - -> ItvPure.compare_astate x y + | Bottom, Bottom -> + 0 + | Bottom, _ -> + -1 + | _, Bottom -> + 1 + | NonBottom x, NonBottom y -> + ItvPure.compare_astate x y + let equal = [%compare.equal : t] @@ -1078,16 +1167,18 @@ let bot : t = Bottom let top : t = NonBottom ItvPure.top let lb : t -> Bound.t = function - | NonBottom x - -> ItvPure.lb x - | Bottom - -> L.(die InternalError) "lower bound of bottom" + | NonBottom x -> + ItvPure.lb x + | Bottom -> + L.(die InternalError) "lower bound of bottom" + let ub : t -> Bound.t = function - | NonBottom x - -> ItvPure.ub x - | Bottom - -> L.(die InternalError) "upper bound of bottom" + | NonBottom x -> + ItvPure.ub x + | Bottom -> + L.(die InternalError) "upper bound of bottom" + let of_int : int -> astate = fun n -> NonBottom (ItvPure.of_int n) @@ -1095,6 +1186,7 @@ let of_int_lit n = try of_int (IntLit.to_int n) with _ -> top + let is_bot : t -> bool = fun x -> equal x Bottom let is_finite : t -> bool = function NonBottom x -> ItvPure.is_finite x | Bottom -> false @@ -1118,6 +1210,7 @@ let zero = NonBottom ItvPure.zero let make : Bound.t -> Bound.t -> t = fun l u -> if Bound.lt u l then Bottom else NonBottom (ItvPure.make l u) + let is_symbolic : t -> bool = function NonBottom x -> ItvPure.is_symbolic x | Bottom -> false let le : lhs:t -> rhs:t -> bool = ( <= ) @@ -1129,27 +1222,31 @@ let to_string : t -> string = fun x -> pp F.str_formatter x ; F.flush_str_format let lift1 : (ItvPure.t -> ItvPure.t) -> t -> t = fun f -> function Bottom -> Bottom | NonBottom x -> NonBottom (f x) + let lift1_opt : (ItvPure.t -> ItvPure.t option) -> t -> t = fun f -> function | Bottom -> Bottom | NonBottom x -> match f x with None -> Bottom | Some v -> NonBottom v + let lift2 : (ItvPure.t -> ItvPure.t -> ItvPure.t) -> t -> t -> t = fun f x y -> match (x, y) with - | Bottom, _ | _, Bottom - -> Bottom - | NonBottom x, NonBottom y - -> NonBottom (f x y) + | Bottom, _ | _, Bottom -> + Bottom + | NonBottom x, NonBottom y -> + NonBottom (f x y) + let lift2_opt : (ItvPure.t -> ItvPure.t -> ItvPure.t option) -> t -> t -> t = fun f x y -> match (x, y) with - | Bottom, _ | _, Bottom - -> Bottom + | Bottom, _ | _, Bottom -> + Bottom | NonBottom x, NonBottom y -> match f x y with Some v -> NonBottom v | None -> Bottom + let plus : t -> t -> t = lift2 ItvPure.plus let minus : t -> t -> t = lift2 ItvPure.minus @@ -1158,6 +1255,7 @@ let make_sym : ?unsigned:bool -> Typ.Procname.t -> (unit -> int) -> t = fun ?(unsigned= false) pname new_sym_num -> NonBottom (ItvPure.make_sym ~unsigned pname new_sym_num) + let neg : t -> t = lift1 ItvPure.neg let lnot : t -> t = lift1 ItvPure.lnot @@ -1201,10 +1299,12 @@ let prune_ne : t -> t -> t = lift2_opt ItvPure.prune_ne let subst : t -> Bound.t bottom_lifted SubstMap.t -> t = fun x map -> match x with NonBottom x' -> ItvPure.subst x' map | _ -> x + let get_symbols : t -> Symbol.t list = function - | Bottom - -> [] - | NonBottom x - -> ItvPure.get_symbols x + | Bottom -> + [] + | NonBottom x -> + ItvPure.get_symbols x + let normalize : t -> t = lift1_opt ItvPure.normalize diff --git a/infer/src/checkers/BoundedCallTree.ml b/infer/src/checkers/BoundedCallTree.ml index f23a4b3e8..28c664969 100644 --- a/infer/src/checkers/BoundedCallTree.ml +++ b/infer/src/checkers/BoundedCallTree.ml @@ -26,6 +26,7 @@ module SpecSummary = Summary.Make (struct let payload = {summary.payload with Specs.crashcontext_frame= Some frame} in {summary with payload} + let read_payload (summary: Specs.summary) = summary.payload.crashcontext_frame end) @@ -41,22 +42,25 @@ let line_range_of_pdesc pdesc = max acc new_loc.Location.line) start_line pdesc in - {Stacktree_j.start_line= start_line; end_line} + {Stacktree_j.start_line; end_line} + let stacktree_of_pdesc pdesc ?(loc= Procdesc.get_loc pdesc) ?(callees= []) location_type = let procname = Procdesc.get_proc_name pdesc in let frame_loc = Some - { Stacktree_j.location_type= location_type + { Stacktree_j.location_type ; file= SourceFile.to_string loc.Location.file ; line= Some loc.Location.line ; blame_range= [line_range_of_pdesc pdesc] } in {Stacktree_j.method_name= Typ.Procname.to_unique_id procname; location= frame_loc; callees} + let stacktree_stub_of_procname procname = {Stacktree_j.method_name= Typ.Procname.to_unique_id procname; location= None; callees= []} + module TransferFunctions (CFG : ProcCfg.S) = struct module CFG = CFG module Domain = Domain @@ -71,20 +75,21 @@ module TransferFunctions (CFG : ProcCfg.S) = struct match SpecSummary.read_summary pdesc pn with | None -> ( match get_proc_desc pn with - | None - -> stacktree_stub_of_procname pn + | None -> + stacktree_stub_of_procname pn (* This can happen when the callee is in the same cluster/ buck target, but it hasn't been checked yet. So we need both the inter-target lookup (SpecSummary) and the intra-target lookup (using get_proc_desc). *) - | Some callee_pdesc - -> stacktree_of_pdesc callee_pdesc "proc_start" ) - | Some stracktree - -> stracktree) + | Some callee_pdesc -> + stacktree_of_pdesc callee_pdesc "proc_start" ) + | Some stracktree -> + stracktree) procs in stacktree_of_pdesc pdesc ~loc ~callees location_type + let output_json_summary pdesc astate loc location_type get_proc_desc = let caller = Procdesc.get_proc_name pdesc in let stacktree = stacktree_of_astate pdesc astate loc location_type get_proc_desc in @@ -92,48 +97,51 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let suffix = F.sprintf "%s_%d" location_type loc.Location.line in let fname = F.sprintf "%s.%s.json" (Typ.Procname.to_filename caller) suffix in let fpath = Filename.concat dir fname in - Utils.create_dir dir ; Ag_util.Json.to_file Stacktree_j.write_stacktree fpath stacktree + Utils.create_dir dir ; + Ag_util.Json.to_file Stacktree_j.write_stacktree fpath stacktree + let exec_instr astate proc_data _ = function | Sil.Call (_, Const Const.Cfun pn, _, loc, _) - -> ( + -> ( let get_proc_desc = proc_data.ProcData.extras.get_proc_desc in let traces = proc_data.ProcData.extras.stacktraces in let caller = Procdesc.get_proc_name proc_data.ProcData.pdesc in let matches_proc frame = let matches_class pname = match pname with - | Typ.Procname.Java java_proc - -> String.equal frame.Stacktrace.class_str + | Typ.Procname.Java java_proc -> + String.equal frame.Stacktrace.class_str (Typ.Procname.java_get_class_name java_proc) - | Typ.Procname.ObjC_Cpp objc_cpp_prod - -> String.equal frame.Stacktrace.class_str + | Typ.Procname.ObjC_Cpp objc_cpp_prod -> + String.equal frame.Stacktrace.class_str (Typ.Procname.objc_cpp_get_class_name objc_cpp_prod) - | Typ.Procname.C _ - -> true (* Needed for test code. *) - | Typ.Procname.Block _ | Typ.Procname.Linters_dummy_method - -> L.(die InternalError) "Proc type not supported by crashcontext: block" + | Typ.Procname.C _ -> + true (* Needed for test code. *) + | Typ.Procname.Block _ | Typ.Procname.Linters_dummy_method -> + L.(die InternalError) "Proc type not supported by crashcontext: block" in String.equal frame.Stacktrace.method_str (Typ.Procname.get_method caller) && matches_class caller in let all_frames = List.concat (List.map ~f:(fun trace -> trace.Stacktrace.frames) traces) in match List.find ~f:matches_proc all_frames with - | Some frame - -> let new_astate = Domain.add pn astate in + | Some frame -> + let new_astate = Domain.add pn astate in ( if Stacktrace.frame_matches_location frame loc then let pdesc = proc_data.ProcData.pdesc in output_json_summary pdesc new_astate loc "call_site" get_proc_desc ) ; new_astate - | None - -> astate ) - | Sil.Call _ - -> (* We currently ignore calls through function pointers in C and + | None -> + astate ) + | Sil.Call _ -> + (* We currently ignore calls through function pointers in C and other potential special kinds of procedure calls to be added later, e.g. Java reflection. *) astate - | Sil.Load _ | Store _ | Prune _ | Declare_locals _ | Remove_temps _ | Abstract _ | Nullify _ - -> astate + | Sil.Load _ | Store _ | Prune _ | Declare_locals _ | Remove_temps _ | Abstract _ | Nullify _ -> + astate + end module Analyzer = AbstractInterpreter.Make (ProcCfg.Exceptional) (TransferFunctions) @@ -148,27 +156,29 @@ let loaded_stacktraces = in let filenames = match (Config.stacktrace, Config.stacktraces_dir) with - | None, None - -> None - | Some fname, None - -> Some [fname] - | None, Some dir - -> Some (json_files_in_dir dir) - | Some fname, Some dir - -> Some (fname :: json_files_in_dir dir) + | None, None -> + None + | Some fname, None -> + Some [fname] + | None, Some dir -> + Some (json_files_in_dir dir) + | Some fname, Some dir -> + Some (fname :: json_files_in_dir dir) in match filenames with - | None - -> None - | Some files - -> Some (List.map ~f:Stacktrace.of_json_file files) + | None -> + None + | Some files -> + Some (List.map ~f:Stacktrace.of_json_file files) + let checker {Callbacks.proc_desc; tenv; get_proc_desc; summary} : Specs.summary = ( match loaded_stacktraces with - | None - -> L.(die UserError) + | None -> + L.(die UserError) "Missing command line option. Either '--stacktrace stack.json' or '--stacktrace-dir ./dir' must be used when running '-a crashcontext'. This options expects a JSON formated stack trace or a directory containing multiple such traces, respectively. See tests/codetoanalyze/java/crashcontext/*.json for examples of the expected format." - | Some stacktraces - -> let extras = {get_proc_desc; stacktraces} in + | Some stacktraces -> + let extras = {get_proc_desc; stacktraces} in ignore (Analyzer.exec_pdesc (ProcData.make proc_desc tenv extras) ~initial:Domain.empty) ) ; summary + diff --git a/infer/src/checkers/IdAccessPathMapDomain.ml b/infer/src/checkers/IdAccessPathMapDomain.ml index 75aeb9c67..33856a448 100644 --- a/infer/src/checkers/IdAccessPathMapDomain.ml +++ b/infer/src/checkers/IdAccessPathMapDomain.ml @@ -18,14 +18,15 @@ include IdMap let pp fmt astate = IdMap.pp ~pp_value:AccessPath.pp fmt astate let check_invariant ap1 ap2 = function - | Var.ProgramVar pvar when Pvar.is_ssa_frontend_tmp pvar - -> (* Sawja reuses temporary variables which sometimes breaks this invariant *) + | Var.ProgramVar pvar when Pvar.is_ssa_frontend_tmp pvar -> + (* Sawja reuses temporary variables which sometimes breaks this invariant *) () - | id - -> if not (AccessPath.equal ap1 ap2) then + | id -> + if not (AccessPath.equal ap1 ap2) then L.(die InternalError) "Id %a maps to both %a and %a" Var.pp id AccessPath.pp ap1 AccessPath.pp ap2 + let ( <= ) ~lhs ~rhs = if phys_equal lhs rhs then true else @@ -36,21 +37,23 @@ let ( <= ) ~lhs ~rhs = rhs_has) lhs + let join astate1 astate2 = if phys_equal astate1 astate2 then astate1 else IdMap.merge (fun var ap1_opt ap2_opt -> match (ap1_opt, ap2_opt) with - | Some ap1, Some ap2 - -> if Config.debug_exceptions then check_invariant ap1 ap2 var ; + | Some ap1, Some ap2 -> + if Config.debug_exceptions then check_invariant ap1 ap2 var ; ap1_opt - | Some _, None - -> ap1_opt - | None, Some _ - -> ap2_opt - | None, None - -> None) + | Some _, None -> + ap1_opt + | None, Some _ -> + ap2_opt + | None, None -> + None) astate1 astate2 + let widen ~prev ~next ~num_iters:_ = join prev next diff --git a/infer/src/checkers/NullabilityCheck.ml b/infer/src/checkers/NullabilityCheck.ml index 9eb2c0805..2ab711003 100644 --- a/infer/src/checkers/NullabilityCheck.ml +++ b/infer/src/checkers/NullabilityCheck.ml @@ -27,6 +27,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct || attributes.ProcAttributes.is_cpp_instance_method) (Specs.proc_resolve_attributes callee_pname) + let report_nullable_dereference ap call_sites {ProcData.pdesc; extras} loc = let pname = Procdesc.get_proc_name pdesc in let annotation = Localise.nullable_annotation_name pname in @@ -41,8 +42,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let message = Format.asprintf "Variable %a is indirectly annotated with %a (source %a) and is dereferenced without being checked for null" - (MF.wrap_monospaced AccessPath.pp) ap MF.pp_monospaced annotation - (MF.wrap_monospaced CallSite.pp) call_site + (MF.wrap_monospaced AccessPath.pp) + ap MF.pp_monospaced annotation (MF.wrap_monospaced CallSite.pp) call_site in let exn = Exceptions.Checkers (issue_kind, Localise.verbatim_desc message) in let summary = extras in @@ -50,10 +51,10 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let with_origin_site = let callee_pname = CallSite.pname call_site in match Specs.proc_resolve_attributes callee_pname with - | None - -> [] - | Some attributes - -> let description = + | None -> + [] + | Some attributes -> + let description = Format.asprintf "definition of %s" (Typ.Procname.get_method callee_pname) in let trace_element = @@ -78,37 +79,39 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in Reporting.log_error summary ~loc ~ltr:trace exn + let exec_instr (astate: Domain.astate) proc_data _ (instr: HilInstr.t) : Domain.astate = match instr with | Call (Some ret_var, Direct callee_pname, _, _, loc) when Annotations.pname_has_return_annot callee_pname - ~attrs_of_pname:Specs.proc_resolve_attributes Annotations.ia_is_nullable - -> let call_site = CallSite.make callee_pname loc in + ~attrs_of_pname:Specs.proc_resolve_attributes Annotations.ia_is_nullable -> + let call_site = CallSite.make callee_pname loc in Domain.add (ret_var, []) (CallSites.singleton call_site) astate | Call (_, Direct callee_pname, (HilExp.AccessPath receiver) :: _, _, loc) when is_instance_method callee_pname -> ( match Domain.find_opt receiver astate with - | None - -> astate - | Some call_sites - -> report_nullable_dereference receiver call_sites proc_data loc ; + | None -> + astate + | Some call_sites -> + report_nullable_dereference receiver call_sites proc_data loc ; Domain.remove receiver astate ) - | Call (Some ret_var, _, _, _, _) - -> Domain.remove (ret_var, []) astate - | Assign (lhs, _, loc) when Domain.mem lhs astate - -> report_nullable_dereference lhs (Domain.find lhs astate) proc_data loc ; + | Call (Some ret_var, _, _, _, _) -> + Domain.remove (ret_var, []) astate + | Assign (lhs, _, loc) when Domain.mem lhs astate -> + report_nullable_dereference lhs (Domain.find lhs astate) proc_data loc ; + Domain.remove lhs astate + | Assign (lhs, HilExp.AccessPath rhs, _) when Domain.mem rhs astate -> + Domain.add lhs (Domain.find rhs astate) astate + | Assign (lhs, _, _) -> Domain.remove lhs astate - | Assign (lhs, HilExp.AccessPath rhs, _) when Domain.mem rhs astate - -> Domain.add lhs (Domain.find rhs astate) astate - | Assign (lhs, _, _) - -> Domain.remove lhs astate - | Assume (HilExp.AccessPath ap, _, _, _) - -> Domain.remove ap astate + | Assume (HilExp.AccessPath ap, _, _, _) -> + Domain.remove ap astate | Assume (HilExp.BinaryOperator (Binop.Ne, HilExp.AccessPath ap, exp), _, _, _) - when HilExp.is_null_literal exp - -> Domain.remove ap astate - | _ - -> astate + when HilExp.is_null_literal exp -> + Domain.remove ap astate + | _ -> + astate + end module Analyzer = @@ -119,3 +122,4 @@ let checker {Callbacks.summary; proc_desc; tenv} = let proc_data = ProcData.make proc_desc tenv summary in ignore (Analyzer.compute_post proc_data ~initial ~debug:false) ; summary + diff --git a/infer/src/checkers/NullabilityPreanalysis.ml b/infer/src/checkers/NullabilityPreanalysis.ml index 52683cae0..d4ab48fdd 100644 --- a/infer/src/checkers/NullabilityPreanalysis.ml +++ b/infer/src/checkers/NullabilityPreanalysis.ml @@ -17,6 +17,7 @@ module FieldsAssignedInConstructors = AbstractDomain.FiniteSet (struct let pp fmt (fieldname, typ) = F.fprintf fmt "(%a, %a)" Typ.Fieldname.pp fieldname (Typ.pp_full Pp.text) typ + end) module TransferFunctions (CFG : ProcCfg.S) = struct @@ -32,29 +33,33 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let exp = Ident.IdentHash.find ids_map id in Exp.is_null_literal exp with Not_found -> false ) - | _ - -> Exp.is_null_literal exp + | _ -> + Exp.is_null_literal exp + let is_self ids_map id = try match Ident.IdentHash.find ids_map id with Exp.Lvar var -> Pvar.is_self var | _ -> false with Not_found -> false + let exec_instr astate (proc_data: Exp.t Ident.IdentHash.t ProcData.t) _ instr = match instr with - | Sil.Load (id, exp, _, _) - -> Ident.IdentHash.add proc_data.extras id exp ; astate + | Sil.Load (id, exp, _, _) -> + Ident.IdentHash.add proc_data.extras id exp ; + astate | Sil.Store (Exp.Lfield (Exp.Var lhs_id, name, typ), exp_typ, rhs, _) -> ( match exp_typ.Typ.desc with (* block field of a ObjC class *) | Typ.Tptr ({desc= Tfun _}, _) when Typ.is_objc_class typ && is_self proc_data.extras lhs_id && (* lhs is self, rhs is not null *) - not (exp_is_null proc_data.extras rhs) - -> FieldsAssignedInConstructors.add (name, typ) astate - | _ - -> astate ) - | _ - -> astate + not (exp_is_null proc_data.extras rhs) -> + FieldsAssignedInConstructors.add (name, typ) astate + | _ -> + astate ) + | _ -> + astate + end (* Tracks when block variables of ObjC classes have been assigned to in constructors *) @@ -64,29 +69,31 @@ module AnalysisCfg = ProcCfg.Normal let add_annot annot annot_name = ({Annot.class_name= annot_name; parameters= []}, true) :: annot -let add_nonnull_to_selected_field given_field (fieldname, typ, annot as field) = +let add_nonnull_to_selected_field given_field ((fieldname, typ, annot) as field) = if Typ.Fieldname.equal fieldname given_field && not (Annotations.ia_is_nullable annot) then let new_annot = add_annot annot Annotations.nonnull in (fieldname, typ, new_annot) else field + let add_nonnull_to_fields fields tenv = let add_nonnull_to_field (field, typ) = match Typ.name typ with | Some typ_name -> ( match Tenv.lookup tenv typ_name with - | Some {fields; statics; supers; methods; annots} - -> let fields_with_annot = List.map ~f:(add_nonnull_to_selected_field field) fields in + | Some {fields; statics; supers; methods; annots} -> + let fields_with_annot = List.map ~f:(add_nonnull_to_selected_field field) fields in ignore (Tenv.mk_struct tenv ~fields:fields_with_annot ~statics ~supers ~methods ~annots typ_name) - | None - -> () ) - | None - -> () + | None -> + () ) + | None -> + () in FieldsAssignedInConstructors.iter add_nonnull_to_field fields + let analysis cfg tenv = let initial = FieldsAssignedInConstructors.empty in let f domain pdesc = @@ -97,12 +104,13 @@ let analysis cfg tenv = (ProcData.make pdesc tenv (Ident.IdentHash.create 10)) ~initial with - | Some new_domain - -> FieldsAssignedInConstructors.union new_domain domain - | None - -> domain + | Some new_domain -> + FieldsAssignedInConstructors.union new_domain domain + | None -> + domain else domain in let procs = Cfg.get_defined_procs cfg in let fields_assigned_in_constructor = List.fold ~f ~init:initial procs in add_nonnull_to_fields fields_assigned_in_constructor tenv + diff --git a/infer/src/checkers/NullabilitySuggest.ml b/infer/src/checkers/NullabilitySuggest.ml index 7884198b8..3db375833 100644 --- a/infer/src/checkers/NullabilitySuggest.ml +++ b/infer/src/checkers/NullabilitySuggest.ml @@ -27,12 +27,13 @@ module UseDefChain = struct let widen ~prev ~next ~num_iters:_ = join prev next let pp fmt = function - | NullDefAssign (loc, ap) - -> F.fprintf fmt "NullDefAssign(%a, %a)" Location.pp loc AccessPath.pp ap - | NullDefCompare (loc, ap) - -> F.fprintf fmt "NullDefCompare(%a, %a)" Location.pp loc AccessPath.pp ap - | DependsOn (loc, ap) - -> F.fprintf fmt "DependsOn(%a, %a)" Location.pp loc AccessPath.pp ap + | NullDefAssign (loc, ap) -> + F.fprintf fmt "NullDefAssign(%a, %a)" Location.pp loc AccessPath.pp ap + | NullDefCompare (loc, ap) -> + F.fprintf fmt "NullDefCompare(%a, %a)" Location.pp loc AccessPath.pp ap + | DependsOn (loc, ap) -> + F.fprintf fmt "DependsOn(%a, %a)" Location.pp loc AccessPath.pp ap + end module Domain = AbstractDomain.Map (AccessPath) (UseDefChain) @@ -47,56 +48,60 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let is_access_nullable ap proc_data = match AccessPath.get_field_and_annotation ap proc_data.ProcData.tenv with - | Some (_, annot_item) - -> Annotations.ia_is_nullable annot_item - | _ - -> false + | Some (_, annot_item) -> + Annotations.ia_is_nullable annot_item + | _ -> + false + let nullable_usedef_chain_of exp lhs astate loc = match exp with - | HilExp.Constant Cint n when IntLit.isnull n - -> Some (UseDefChain.NullDefAssign (loc, lhs)) + | HilExp.Constant Cint n when IntLit.isnull n -> + Some (UseDefChain.NullDefAssign (loc, lhs)) | HilExp.AccessPath ap -> ( try match Domain.find ap astate with - | UseDefChain.NullDefCompare _ - -> (* Stop NullDefCompare from propagating here because we want to prevent + | UseDefChain.NullDefCompare _ -> + (* Stop NullDefCompare from propagating here because we want to prevent * the checker from suggesting @Nullable on y in the following case: * if (x == null) ... else { y = x; } *) None - | _ - -> Some (UseDefChain.DependsOn (loc, ap)) + | _ -> + Some (UseDefChain.DependsOn (loc, ap)) with Not_found -> None ) - | _ - -> None + | _ -> + None + let extract_null_compare_expr = function | HilExp.BinaryOperator ((Eq | Ne), HilExp.AccessPath ap, exp) - | HilExp.BinaryOperator ((Eq | Ne), exp, HilExp.AccessPath ap) - -> Option.some_if (HilExp.is_null_literal exp) ap - | _ - -> None + | HilExp.BinaryOperator ((Eq | Ne), exp, HilExp.AccessPath ap) -> + Option.some_if (HilExp.is_null_literal exp) ap + | _ -> + None + let exec_instr (astate: Domain.astate) proc_data _ (instr: HilInstr.t) = match instr with | Assume (expr, _, _, loc) -> ( match extract_null_compare_expr expr with - | Some ap when not (is_access_nullable ap proc_data) - -> let udchain = UseDefChain.NullDefCompare (loc, ap) in + | Some ap when not (is_access_nullable ap proc_data) -> + let udchain = UseDefChain.NullDefCompare (loc, ap) in Domain.add ap udchain astate - | _ - -> astate ) - | Call _ - -> (* For now we just assume the callee always return non-null *) + | _ -> + astate ) + | Call _ -> + (* For now we just assume the callee always return non-null *) astate - | Assign (lhs, rhs, loc) - -> if not (is_access_nullable lhs proc_data) then + | Assign (lhs, rhs, loc) -> + if not (is_access_nullable lhs proc_data) then match nullable_usedef_chain_of rhs lhs astate loc with - | Some udchain - -> Domain.add lhs udchain astate - | None - -> astate + | Some udchain -> + Domain.add lhs udchain astate + | None -> + astate else astate + end module Analyzer = @@ -105,21 +110,21 @@ module Analyzer = let make_error_trace astate ap ud = let name_of ap = match AccessPath.get_last_access ap with - | Some AccessPath.FieldAccess field_name - -> "Field " ^ Typ.Fieldname.to_flat_string field_name - | Some AccessPath.ArrayAccess _ - -> "Some array element" - | None - -> "Variable" + | Some AccessPath.FieldAccess field_name -> + "Field " ^ Typ.Fieldname.to_flat_string field_name + | Some AccessPath.ArrayAccess _ -> + "Some array element" + | None -> + "Variable" in let open UseDefChain in let rec error_trace_impl depth ap = function - | NullDefAssign (loc, src) - -> let msg = F.sprintf "%s is assigned null here" (name_of src) in + | NullDefAssign (loc, src) -> + let msg = F.sprintf "%s is assigned null here" (name_of src) in let ltr = [Errlog.make_trace_element depth loc msg []] in Some (loc, ltr) - | NullDefCompare (loc, src) - -> let msg = F.sprintf "%s is compared to null here" (name_of src) in + | NullDefCompare (loc, src) -> + let msg = F.sprintf "%s is compared to null here" (name_of src) in let ltr = [Errlog.make_trace_element depth loc msg []] in Some (loc, ltr) | DependsOn (loc, dep) -> @@ -133,40 +138,43 @@ let make_error_trace astate ap ud = in error_trace_impl 0 ap ud + let pretty_field_name proc_data field_name = match Procdesc.get_proc_name proc_data.ProcData.pdesc with - | Typ.Procname.Java jproc_name - -> let proc_class_name = Typ.Procname.java_get_class_name jproc_name in + | Typ.Procname.Java jproc_name -> + let proc_class_name = Typ.Procname.java_get_class_name jproc_name in let field_class_name = Typ.Fieldname.java_get_class field_name in if String.equal proc_class_name field_class_name then Typ.Fieldname.to_flat_string field_name else Typ.Fieldname.to_simplified_string field_name - | _ - -> (* This format is subject to change once this checker gets to run on C/Cpp/ObjC *) + | _ -> + (* This format is subject to change once this checker gets to run on C/Cpp/ObjC *) Typ.Fieldname.to_string field_name + let checker {Callbacks.summary; proc_desc; tenv} = let annotation = Localise.nullable_annotation_name (Procdesc.get_proc_name proc_desc) in let report astate (proc_data: extras ProcData.t) = let report_access_path ap udchain = let issue_kind = IssueType.field_should_be_nullable.unique_id in match AccessPath.get_field_and_annotation ap proc_data.tenv with - | Some (field_name, _) when Typ.Fieldname.Java.is_captured_parameter field_name - -> (* Skip reporting when field comes from generated code *) + | Some (field_name, _) when Typ.Fieldname.Java.is_captured_parameter field_name -> + (* Skip reporting when field comes from generated code *) () | Some (field_name, _) - -> ( + -> ( let message = F.asprintf "Field %a should be annotated with %a" MF.pp_monospaced - (pretty_field_name proc_data field_name) MF.pp_monospaced annotation + (pretty_field_name proc_data field_name) + MF.pp_monospaced annotation in let exn = Exceptions.Checkers (issue_kind, Localise.verbatim_desc message) in match make_error_trace astate ap udchain with - | Some (loc, ltr) - -> Reporting.log_warning summary ~loc ~ltr exn - | None - -> Reporting.log_warning summary exn ) - | _ - -> () + | Some (loc, ltr) -> + Reporting.log_warning summary ~loc ~ltr exn + | None -> + Reporting.log_warning summary exn ) + | _ -> + () in Domain.iter report_access_path astate in @@ -179,7 +187,8 @@ let checker {Callbacks.summary; proc_desc; tenv} = let initial = (Domain.empty, IdAccessPathMapDomain.empty) in let proc_data = ProcData.make_default proc_desc tenv in match Analyzer.compute_post proc_data ~initial ~debug:false with - | Some (post, _) - -> report post proc_data ; summary - | None - -> L.(die InternalError) "Analyzer failed to compute post for %a" Typ.Procname.pp proc_name + | Some (post, _) -> + report post proc_data ; summary + | None -> + L.(die InternalError) "Analyzer failed to compute post for %a" Typ.Procname.pp proc_name + diff --git a/infer/src/checkers/SimpleChecker.ml b/infer/src/checkers/SimpleChecker.ml index ea337e750..52f6c6160 100644 --- a/infer/src/checkers/SimpleChecker.ml +++ b/infer/src/checkers/SimpleChecker.ml @@ -59,6 +59,7 @@ module Make (Spec : Spec) : S = struct L.(die InternalError) "Stopping analysis after 1000 iterations without convergence. Make sure your domain is finite height." else widen ~prev ~next ~num_iters + end module TransferFunctions (CFG : ProcCfg.S) = struct @@ -74,6 +75,7 @@ module Make (Spec : Spec) : S = struct (fun astate acc -> Domain.add (Spec.exec_instr astate instr node_kind pname proc_data.ProcData.tenv) acc) astate_set Domain.empty + end module Analyzer = AbstractInterpreter.Make (ProcCfg.Exceptional) (TransferFunctions) @@ -97,5 +99,7 @@ module Make (Spec : Spec) : S = struct let inv_map = Analyzer.exec_pdesc (ProcData.make_default proc_desc tenv) ~initial:Domain.empty in - Analyzer.InvariantMap.iter do_reporting inv_map ; summary + Analyzer.InvariantMap.iter do_reporting inv_map ; + summary + end diff --git a/infer/src/checkers/Sink.ml b/infer/src/checkers/Sink.ml index 48256caa7..f6b79e2c9 100644 --- a/infer/src/checkers/Sink.ml +++ b/infer/src/checkers/Sink.ml @@ -40,10 +40,11 @@ module Make (Kind : Kind) = struct let get site actuals tenv = match Kind.get (CallSite.pname site) actuals tenv with - | Some (kind, indexes) - -> Some {kind; site; indexes} - | None - -> None + | Some (kind, indexes) -> + Some {kind; site; indexes} + | None -> + None + let with_callsite t callee_site = {t with site= callee_site} diff --git a/infer/src/checkers/SinkTrace.ml b/infer/src/checkers/SinkTrace.ml index 73d5bf0cf..86634c51d 100644 --- a/infer/src/checkers/SinkTrace.ml +++ b/infer/src/checkers/SinkTrace.ml @@ -51,14 +51,17 @@ module Make (TraceElem : TraceElem.S) = struct let dummy_source = () in of_source dummy_source + let get_reportable_sink_paths t ~trace_of_pname = List.map ~f:(fun (passthroughs, _, sinks) -> (passthroughs, sinks)) (get_reportable_paths t ~trace_of_pname) + let to_sink_loc_trace ?desc_of_sink ?sink_should_nest (passthroughs, sinks) = to_loc_trace ?desc_of_sink ?sink_should_nest (passthroughs, [], sinks) + let with_callsite t call_site = List.fold ~f:(fun t_acc sink -> @@ -67,22 +70,26 @@ module Make (TraceElem : TraceElem.S) = struct ~init:empty (Sinks.elements (sinks t)) + let of_sink sink = let sinks = Sinks.add sink Sinks.empty in update_sinks empty sinks + let get_reportable_sink_path sink ~trace_of_pname = match get_reportable_sink_paths (of_sink sink) ~trace_of_pname with - | [] - -> None - | [report] - -> Some report - | _ - -> L.(die InternalError) "Should not get >1 report for 1 sink" + | [] -> + None + | [report] -> + Some report + | _ -> + L.(die InternalError) "Should not get >1 report for 1 sink" + let pp fmt t = let pp_passthroughs_if_not_empty fmt p = if not (Passthroughs.is_empty p) then F.fprintf fmt " via %a" Passthroughs.pp p in F.fprintf fmt "%a%a" Sinks.pp (sinks t) pp_passthroughs_if_not_empty (passthroughs t) + end diff --git a/infer/src/checkers/Siof.ml b/infer/src/checkers/Siof.ml index 54e5c92b7..73960c39c 100644 --- a/infer/src/checkers/Siof.ml +++ b/infer/src/checkers/Siof.ml @@ -19,6 +19,7 @@ let methods_whitelist = QualifiedCppName.Match.of_fuzzy_qual_names Config.siof_s let is_whitelisted (pname: Typ.Procname.t) = Typ.Procname.get_qualifiers pname |> QualifiedCppName.Match.match_qualifiers methods_whitelist + type siof_model = { qual_name: string (** (fuzzy) name of the method, eg "std::ios_base::Init::Init" *) ; initialized_globals: string list @@ -38,6 +39,7 @@ let standard_streams = ; "std::cout" ; "std::wcout" ] + let models = List.map ~f:parse_siof_model [("std::ios_base::Init::Init", standard_streams)] let is_modelled = @@ -47,12 +49,14 @@ let is_modelled = fun pname -> Typ.Procname.get_qualifiers pname |> QualifiedCppName.Match.match_qualifiers models_matcher + module Summary = Summary.Make (struct type payload = SiofDomain.astate let update_payload astate (summary: Specs.summary) = {summary with payload= {summary.payload with siof= Some astate}} + let read_payload (summary: Specs.summary) = summary.payload.siof end) @@ -65,12 +69,13 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let is_compile_time_constructed pdesc pv = let init_pname = Pvar.get_initializer_pname pv in match Option.bind init_pname ~f:(Summary.read_summary pdesc) with - | Some (Bottom, _) - -> (* we analyzed the initializer for this global and found that it doesn't require any runtime + | Some (Bottom, _) -> + (* we analyzed the initializer for this global and found that it doesn't require any runtime initialization so cannot participate in SIOF *) true - | _ - -> false + | _ -> + false + let get_globals pdesc e = let is_dangerous_global pv = @@ -79,6 +84,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in Exp.get_vars e |> snd |> List.filter ~f:is_dangerous_global |> GlobalVarSet.of_list + let filter_global_accesses initialized = let initialized_matcher = Domain.VarNames.elements initialized |> QualifiedCppName.Match.of_fuzzy_qual_names @@ -88,6 +94,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct QualifiedCppName.of_qual_string (Pvar.to_string gvar) |> Fn.non (QualifiedCppName.Match.match_qualifiers initialized_matcher) ) + let add_globals astate loc globals = if GlobalVarSet.is_empty globals then astate else @@ -106,20 +113,22 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in (NonBottom trace_with_non_init_globals, snd astate) + let add_actuals_globals astate0 pdesc call_loc actuals = List.fold_left actuals ~init:astate0 ~f:(fun astate (e, _) -> get_globals pdesc e |> add_globals astate call_loc ) + let at_least_nonbottom = Domain.join (NonBottom SiofTrace.empty, Domain.VarNames.empty) let exec_instr astate {ProcData.pdesc} _ (instr: Sil.instr) = match instr with - | Load (_, exp, _, loc) | Store (_, _, exp, loc) | Prune (exp, loc, _, _) - -> get_globals pdesc exp |> add_globals astate loc - | Call (_, Const Cfun callee_pname, _, _, _) when is_whitelisted callee_pname - -> at_least_nonbottom astate - | Call (_, Const Cfun callee_pname, _, _, _) when is_modelled callee_pname - -> let init = + | Load (_, exp, _, loc) | Store (_, _, exp, loc) | Prune (exp, loc, _, _) -> + get_globals pdesc exp |> add_globals astate loc + | Call (_, Const Cfun callee_pname, _, _, _) when is_whitelisted callee_pname -> + at_least_nonbottom astate + | Call (_, Const Cfun callee_pname, _, _, _) when is_modelled callee_pname -> + let init = List.find_map_exn models ~f:(fun {qual_name; initialized_globals} -> if QualifiedCppName.Match.of_fuzzy_qual_names [qual_name] |> Fn.flip QualifiedCppName.Match.match_qualifiers @@ -130,13 +139,13 @@ module TransferFunctions (CFG : ProcCfg.S) = struct Domain.join astate (NonBottom SiofTrace.empty, Domain.VarNames.of_list init) | Call (_, Const Cfun callee_pname, _ :: actuals_without_self, loc, _) when Typ.Procname.is_c_method callee_pname && Typ.Procname.is_constructor callee_pname - && Typ.Procname.is_constexpr callee_pname - -> add_actuals_globals astate pdesc loc actuals_without_self - | Call (_, Const Cfun callee_pname, actuals, loc, _) - -> let callee_astate = + && Typ.Procname.is_constexpr callee_pname -> + add_actuals_globals astate pdesc loc actuals_without_self + | Call (_, Const Cfun callee_pname, actuals, loc, _) -> + let callee_astate = match Summary.read_summary pdesc callee_pname with - | Some (NonBottom trace, initialized_by_callee) - -> let already_initialized = snd astate in + | Some (NonBottom trace, initialized_by_callee) -> + let already_initialized = snd astate in let dangerous_accesses = SiofTrace.sinks trace |> SiofTrace.Sinks.filter (fun sink -> @@ -150,48 +159,50 @@ module TransferFunctions (CFG : ProcCfg.S) = struct dangerous_accesses in (NonBottom (SiofTrace.update_sinks trace sinks), initialized_by_callee) - | Some (Bottom, _ as callee_astate) - -> callee_astate - | None - -> (Bottom, Domain.VarNames.empty) + | Some ((Bottom, _) as callee_astate) -> + callee_astate + | None -> + (Bottom, Domain.VarNames.empty) in add_actuals_globals astate pdesc loc actuals |> Domain.join callee_astate |> (* make sure it's not Bottom: we made a function call so this needs initialization *) at_least_nonbottom - | Call (_, _, actuals, loc, _) - -> add_actuals_globals astate pdesc loc actuals + | Call (_, _, actuals, loc, _) -> + add_actuals_globals astate pdesc loc actuals |> (* make sure it's not Bottom: we made a function call so this needs initialization *) at_least_nonbottom - | Declare_locals _ | Remove_temps _ | Abstract _ | Nullify _ - -> astate + | Declare_locals _ | Remove_temps _ | Abstract _ | Nullify _ -> + astate + end module Analyzer = AbstractInterpreter.Make (ProcCfg.Normal) (TransferFunctions) let is_foreign tu_opt v = match (Pvar.get_translation_unit v, tu_opt) with - | TUFile v_tu, Some current_tu - -> not (SourceFile.equal current_tu v_tu) - | TUExtern, Some _ - -> true - | _, None - -> L.(die InternalError) "cannot be called with translation unit set to None" + | TUFile v_tu, Some current_tu -> + not (SourceFile.equal current_tu v_tu) + | TUExtern, Some _ -> + true + | _, None -> + L.(die InternalError) "cannot be called with translation unit set to None" + let report_siof summary trace pdesc gname loc = let trace_of_pname pname = match Summary.read_summary pdesc pname with - | Some (NonBottom summary, _) - -> summary - | _ - -> SiofTrace.empty + | Some (NonBottom summary, _) -> + summary + | _ -> + SiofTrace.empty in - let report_one_path (_, path as trace) = + let report_one_path ((_, path) as trace) = let description = match path with - | [] - -> assert false - | (final_sink, _) :: _ - -> F.asprintf + | [] -> + assert false + | (final_sink, _) :: _ -> + F.asprintf "Initializer of %s accesses global variable from a different translation unit: %a" gname GlobalVar.pp (SiofTrace.Sink.kind final_sink) in @@ -204,10 +215,11 @@ let report_siof summary trace pdesc gname loc = if Config.filtering then List.hd reportable_paths |> Option.iter ~f:report_one_path else List.iter ~f:report_one_path reportable_paths + let siof_check pdesc gname (summary: Specs.summary) = match summary.payload.siof with - | Some (NonBottom post, _) - -> let attrs = Procdesc.get_attributes pdesc in + | Some (NonBottom post, _) -> + let attrs = Procdesc.get_attributes pdesc in let tu_opt = let attrs = Procdesc.get_attributes pdesc in attrs.ProcAttributes.translation_unit @@ -218,10 +230,12 @@ let siof_check pdesc gname (summary: Specs.summary) = (SiofTrace.sinks post) in if not (SiofTrace.Sinks.is_empty foreign_sinks) then - report_siof summary (SiofTrace.update_sinks post foreign_sinks) pdesc gname - attrs.ProcAttributes.loc - | Some (Bottom, _) | None - -> () + report_siof summary + (SiofTrace.update_sinks post foreign_sinks) + pdesc gname attrs.ProcAttributes.loc + | Some (Bottom, _) | None -> + () + let checker {Callbacks.proc_desc; tenv; summary; get_procs_in_file} : Specs.summary = let standard_streams_initialized_in_tu = @@ -232,7 +246,8 @@ let checker {Callbacks.proc_desc; tenv; summary; get_procs_in_file} : Specs.summ ( Pvar.mk_global (Mangled.from_string (* infer's C++ headers define this global variable in *) - "__infer_translation_unit_init_streams") (TUFile tu) + "__infer_translation_unit_init_streams") + (TUFile tu) |> Pvar.get_initializer_pname ) in get_procs_in_file (Procdesc.get_proc_name proc_desc) @@ -249,14 +264,15 @@ let checker {Callbacks.proc_desc; tenv; summary; get_procs_in_file} : Specs.summ in let updated_summary = match Analyzer.compute_post proc_data ~initial with - | Some post - -> Summary.update_summary post summary - | None - -> summary + | Some post -> + Summary.update_summary post summary + | None -> + summary in ( match Typ.Procname.get_global_name_of_initializer (Procdesc.get_proc_name proc_desc) with - | Some gname - -> siof_check proc_desc gname updated_summary - | None - -> () ) ; + | Some gname -> + siof_check proc_desc gname updated_summary + | None -> + () ) ; updated_summary + diff --git a/infer/src/checkers/SiofTrace.ml b/infer/src/checkers/SiofTrace.ml index a6b719c7f..50e57bcb6 100644 --- a/infer/src/checkers/SiofTrace.ml +++ b/infer/src/checkers/SiofTrace.ml @@ -20,6 +20,7 @@ module GlobalVar = struct let pp fmt v = F.fprintf fmt "%a|%a" Mangled.pp (Pvar.get_name v) Pvar.pp_translation_unit (Pvar.get_translation_unit v) + end module GlobalVarSet = PrettyPrintable.MakePPSet (GlobalVar) @@ -43,6 +44,7 @@ module TraceElem = struct Kind.pp (snd kind) ; match fst kind with `Call -> F.fprintf fmt " via call to %a" CallSite.pp site | `Access -> () + module Set = PrettyPrintable.MakePPSet (struct (* Don't use nonrec due to https://github.com/janestreet/ppx_compare/issues/2 *) (* type nonrec t = t [@@deriving compare]; *) @@ -60,6 +62,7 @@ let make_access kind loc = let site = CallSite.make Typ.Procname.empty_block loc in {TraceElem.kind= (`Access, kind); site} + let is_intraprocedural_access {TraceElem.kind= kind, _} = kind = `Access let trace_of_error loc gname path = @@ -74,3 +77,4 @@ let trace_of_error loc gname path = Errlog.make_trace_element 0 loc (Format.asprintf "initialization of %s" gname) [] in trace_elem_of_global :: to_sink_loc_trace ~desc_of_sink ~sink_should_nest path + diff --git a/infer/src/checkers/Source.ml b/infer/src/checkers/Source.ml index 1d2283e70..9b2ed673b 100644 --- a/infer/src/checkers/Source.ml +++ b/infer/src/checkers/Source.ml @@ -14,6 +14,7 @@ let all_formals_untainted pdesc = let make_untainted (name, typ) = (name, typ, None) in List.map ~f:make_untainted (Procdesc.get_formals pdesc) + module type Kind = sig include TraceElem.Kind @@ -47,11 +48,12 @@ module Make (Kind : Kind) = struct let get site actuals tenv = match Kind.get (CallSite.pname site) actuals tenv with - | Some (kind, index) - -> let source = make kind site in + | Some (kind, index) -> + let source = make kind site in Some {source; index} - | None - -> None + | None -> + None + let get_tainted_formals pdesc tenv = let site = CallSite.make (Procdesc.get_proc_name pdesc) (Procdesc.get_loc pdesc) in @@ -60,6 +62,7 @@ module Make (Kind : Kind) = struct (name, typ, Option.map kind_opt ~f:(fun kind -> make kind site))) (Kind.get_tainted_formals pdesc tenv) + let pp fmt s = F.fprintf fmt "%a(%a)" Kind.pp s.kind CallSite.pp s.site let with_callsite t callee_site = {t with site= callee_site} @@ -91,6 +94,7 @@ module Dummy = struct let get_tainted_formals pdesc _ = List.map ~f:(fun (name, typ) -> (name, typ, None)) (Procdesc.get_formals pdesc) + module Kind = struct type nonrec t = t diff --git a/infer/src/checkers/Stacktrace.ml b/infer/src/checkers/Stacktrace.ml index d8d3c294e..22d5529d4 100644 --- a/infer/src/checkers/Stacktrace.ml +++ b/infer/src/checkers/Stacktrace.ml @@ -49,6 +49,7 @@ let frame_matches_location frame_obj loc = in matches_file && matches_line + let parse_stack_frame frame_str = (* separate the qualified method name and the parenthesized text/line number*) ignore (Str.string_match frame_regexp frame_str 0) ; @@ -74,30 +75,33 @@ let parse_stack_frame frame_str = in make_frame class_str method_str file_str line_num + let parse_exception_line exception_line = ignore (Str.string_match exception_regexp exception_line 0) ; let exception_name = Str.matched_group 2 exception_line in exception_name + let of_string s = let lines = Str.split new_line_regexp s in match lines with - | exception_line :: trace - -> let exception_name = parse_exception_line exception_line in + | exception_line :: trace -> + let exception_name = parse_exception_line exception_line in let parsed = List.map ~f:parse_stack_frame trace in make exception_name parsed - | [] - -> L.(die UserError) "Empty stack trace" + | [] -> + L.(die UserError) "Empty stack trace" + let of_json filename json = let exception_name_key = "exception_type" in let frames_key = "stack_trace" in let extract_json_member key = match Yojson.Basic.Util.member key json with - | `Null - -> L.(die UserError) "Missing key in supplied JSON data: %s (in file %s)" key filename - | item - -> item + | `Null -> + L.(die UserError) "Missing key in supplied JSON data: %s (in file %s)" key filename + | item -> + item in let exception_name = Yojson.Basic.Util.to_string (extract_json_member exception_name_key) in let frames = @@ -107,8 +111,10 @@ let of_json filename json = in make exception_name frames + let of_json_file filename = try of_json filename (Yojson.Basic.from_file filename) with Sys_error msg | Yojson.Json_error msg -> L.(die UserError) "Could not read or parse the supplied JSON stacktrace file %s :@\n %s" filename msg + diff --git a/infer/src/checkers/Trace.ml b/infer/src/checkers/Trace.ml index 68b69ea4f..65e9a016c 100644 --- a/infer/src/checkers/Trace.ml +++ b/infer/src/checkers/Trace.ml @@ -145,16 +145,17 @@ module Expander (TraceElem : TraceElem.S) = struct in (* arbitrarily pick one elem and explore it further *) match matching_elems with - | callee_elem :: _ - -> (* TODO: pick the shortest path to a sink here instead (t14242809) *) + | callee_elem :: _ -> + (* TODO: pick the shortest path to a sink here instead (t14242809) *) let filtered_passthroughs = filter_passthroughs caller_elem_site (TraceElem.call_site callee_elem) passthroughs in expand_ callee_elem ((elem, filtered_passthroughs) :: elems_passthroughs_acc, seen_acc') - | _ - -> ((elem, Passthrough.Set.empty) :: elems_passthroughs_acc, seen_acc') + | _ -> + ((elem, Passthrough.Set.empty) :: elems_passthroughs_acc, seen_acc') in fst (expand_ elem0 ([], CallSite.Set.empty)) + end module Make (Spec : Spec) = struct @@ -174,6 +175,7 @@ module Make (Spec : Spec) = struct else Known.( <= ) ~lhs:lhs.known ~rhs:rhs.known && Footprint.( <= ) ~lhs:lhs.footprint ~rhs:rhs.footprint + let join astate1 astate2 = if phys_equal astate1 astate2 then astate1 else @@ -181,6 +183,7 @@ module Make (Spec : Spec) = struct let footprint = Footprint.join astate1.footprint astate2.footprint in {known; footprint} + let widen ~prev ~next ~num_iters = if phys_equal prev next then prev else @@ -188,12 +191,14 @@ module Make (Spec : Spec) = struct let footprint = Footprint.widen ~prev:prev.footprint ~next:next.footprint ~num_iters in {known; footprint} + let pp fmt {known; footprint} = if Known.is_empty known then if Footprint.is_empty footprint then F.fprintf fmt "{}" else F.fprintf fmt "Footprint(%a)" Footprint.pp footprint else F.fprintf fmt "%a + Footprint(%a)" Known.pp known Footprint.pp footprint + let empty = {known= Known.empty; footprint= Footprint.empty} let is_empty {known; footprint} = Known.is_empty known && Footprint.BaseMap.is_empty footprint @@ -202,23 +207,27 @@ module Make (Spec : Spec) = struct let footprint = Footprint.add_trace access_path true Footprint.empty in {empty with footprint} + let of_source source = let known = Known.singleton source in {empty with known} + let add source astate = let known = Known.add source astate.known in {astate with known} + let get_footprint_indexes {footprint} = Footprint.BaseMap.fold (fun base _ acc -> match AccessPath.Abs.get_footprint_index_base base with - | Some footprint_index - -> IntSet.add footprint_index acc - | None - -> acc) + | Some footprint_index -> + IntSet.add footprint_index acc + | None -> + acc) footprint IntSet.empty + end module Sinks = Sink.Set @@ -252,11 +261,13 @@ module Make (Spec : Spec) = struct (* empty sources implies empty sinks and passthroughs *) F.fprintf fmt "%a ~> %a%a" Sources.pp sources pp_sinks sinks pp_passthroughs passthroughs + let get_path_source_call_site = function - | Known source - -> Source.call_site source - | Footprint _ - -> CallSite.dummy + | Known source -> + Source.call_site source + | Footprint _ -> + CallSite.dummy + let sources t = t.sources @@ -268,15 +279,16 @@ module Make (Spec : Spec) = struct (* sources empty => sinks empty and passthroughs empty *) Sources.is_empty t.sources + let get_reports ?cur_site t = if Sinks.is_empty t.sinks || Sources.is_empty t.sources then [] else let should_report_at_site source sink = match cur_site with - | None - -> true - | Some call_site - -> (* report when: (1) [cur_site] introduces the sink, and (2) [cur_site] does not also + | None -> + true + | Some call_site -> + (* report when: (1) [cur_site] introduces the sink, and (2) [cur_site] does not also introduce the source. otherwise, we'll report paths that don't respect control flow. *) CallSite.equal call_site (Sink.call_site sink) @@ -294,11 +306,13 @@ module Make (Spec : Spec) = struct let report_sources source acc = report_source source t.sinks acc in Sources.Known.fold report_sources t.sources.known [] + let pp_path_source fmt = function - | Known source - -> Source.pp fmt source - | Footprint access_path - -> AccessPath.Abs.pp fmt access_path + | Known source -> + Source.pp fmt source + | Footprint access_path -> + AccessPath.Abs.pp fmt access_path + let pp_path cur_pname fmt (cur_passthroughs, sources_passthroughs, sinks_passthroughs) = let pp_passthroughs fmt passthroughs = @@ -320,6 +334,7 @@ module Make (Spec : Spec) = struct original_source Sink.pp final_sink pp_sources sources_passthroughs Typ.Procname.pp cur_pname pp_passthroughs cur_passthroughs pp_sinks (List.rev sinks_passthroughs) + type passthrough_kind = | Source (** passthroughs of a source *) | Sink (** passthroughs of a sink *) @@ -333,19 +348,19 @@ module Make (Spec : Spec) = struct let between_start_and_end passthrough = let passthrough_line = line_number (Passthrough.site passthrough) in match passthrough_kind with - | Source - -> passthrough_line >= end_line - | Sink - -> passthrough_line <= end_line - | Top_level - -> passthrough_line >= start_line && passthrough_line <= end_line + | Source -> + passthrough_line >= end_line + | Sink -> + passthrough_line <= end_line + | Top_level -> + passthrough_line >= start_line && passthrough_line <= end_line in Passthrough.Set.filter between_start_and_end passthroughs in let expand_path path_source sink = match path_source with - | Known source - -> let sources_of_pname pname = + | Known source -> + let sources_of_pname pname = let trace = trace_of_pname pname in (Sources.Known.elements (sources trace).known, passthroughs trace) in @@ -365,8 +380,8 @@ module Make (Spec : Spec) = struct ~filter_passthroughs in (sources_passthroughs, sinks_passthroughs) - | Footprint _ - -> ([], []) + | Footprint _ -> + ([], []) in List.map ~f:(fun (path_source, sink, passthroughs) -> @@ -374,24 +389,25 @@ module Make (Spec : Spec) = struct let filtered_passthroughs = let source_site = match path_source with - | Known source - -> Source.call_site source - | Footprint _ - -> Option.value ~default:CallSite.dummy cur_site + | Known source -> + Source.call_site source + | Footprint _ -> + Option.value ~default:CallSite.dummy cur_site in filter_passthroughs_ Top_level source_site (Sink.call_site sink) passthroughs in (filtered_passthroughs, sources_passthroughs, sinks_passthroughs)) (get_reports ?cur_site t) + let to_loc_trace ?(desc_of_source= function - | Known source - -> let callsite = Source.call_site source in + | Known source -> + let callsite = Source.call_site source in Format.asprintf "return from %a" Typ.Procname.pp (CallSite.pname callsite) - | Footprint access_path - -> Format.asprintf "read from %a" AccessPath.Abs.pp access_path) + | Footprint access_path -> + Format.asprintf "read from %a" AccessPath.Abs.pp access_path) ?(source_should_nest= fun _ -> true) ?(desc_of_sink= fun sink -> let callsite = Sink.call_site sink in @@ -418,7 +434,7 @@ module Make (Spec : Spec) = struct in let get_nesting should_nest elems start_nesting = let level = ref start_nesting in - let get_nesting_ (elem, _ as pair) = + let get_nesting_ ((elem, _) as pair) = if should_nest elem then incr level ; (pair, !level) in @@ -450,27 +466,33 @@ module Make (Spec : Spec) = struct ~f:(fun acc source -> trace_elems_of_source source acc) ~init:trace_prefix sources_with_level + let of_sources sources = let passthroughs = Passthroughs.empty in let sinks = Sinks.empty in {sources; passthroughs; sinks} + let of_source source = let sources = Sources.of_source source in of_sources sources + let of_footprint access_path = let sources = Sources.of_footprint access_path in of_sources sources + let add_source source t = let sources = Sources.add source t.sources in {t with sources} + let add_sink sink t = let sinks = Sinks.add sink t.sinks in {t with sinks} + let update_sources t sources = {t with sources} let update_sinks t sinks = {t with sinks} @@ -492,7 +514,7 @@ module Make (Spec : Spec) = struct (Sources.Known.elements non_footprint_callee_sources) |> Sources.Known.of_list |> Sources.Known.union caller_trace.sources.known in - {caller_trace.sources with Sources.known= known} + {caller_trace.sources with Sources.known} in let sinks = if Sinks.subset callee_trace.sinks caller_trace.sinks then caller_trace.sinks @@ -512,17 +534,20 @@ module Make (Spec : Spec) = struct in {sources; sinks; passthroughs} + let empty = let sources = Sources.empty in let sinks = Sinks.empty in let passthroughs = Passthroughs.empty in {sources; sinks; passthroughs} + let ( <= ) ~lhs ~rhs = phys_equal lhs rhs || Sources.( <= ) ~lhs:lhs.sources ~rhs:rhs.sources && Sinks.subset lhs.sinks rhs.sinks && Passthroughs.subset lhs.passthroughs rhs.passthroughs + let join t1 t2 = if phys_equal t1 t2 then t1 else @@ -531,6 +556,7 @@ module Make (Spec : Spec) = struct let passthroughs = Passthroughs.union t1.passthroughs t2.passthroughs in {sources; sinks; passthroughs} + let widen ~prev ~next ~num_iters = if phys_equal prev next then prev else @@ -538,4 +564,5 @@ module Make (Spec : Spec) = struct let sinks = Sinks.union prev.sinks next.sinks in let passthroughs = Passthroughs.union prev.passthroughs next.passthroughs in {sources; sinks; passthroughs} + end diff --git a/infer/src/checkers/accessPath.ml b/infer/src/checkers/accessPath.ml index ff92b4c78..a6a836e6b 100644 --- a/infer/src/checkers/accessPath.ml +++ b/infer/src/checkers/accessPath.ml @@ -32,50 +32,57 @@ module Raw = struct let pp_base fmt (pvar, _) = Var.pp fmt pvar let rec pp_access fmt = function - | FieldAccess field_name - -> Typ.Fieldname.pp fmt field_name - | ArrayAccess (_, []) - -> F.fprintf fmt "[_]" - | ArrayAccess (_, index_aps) - -> F.fprintf fmt "[%a]" (PrettyPrintable.pp_collection ~pp_item:pp) index_aps + | FieldAccess field_name -> + Typ.Fieldname.pp fmt field_name + | ArrayAccess (_, []) -> + F.fprintf fmt "[_]" + | ArrayAccess (_, index_aps) -> + F.fprintf fmt "[%a]" (PrettyPrintable.pp_collection ~pp_item:pp) index_aps + and pp_access_list fmt accesses = let pp_sep _ _ = F.fprintf fmt "." in F.pp_print_list ~pp_sep pp_access fmt accesses + and pp fmt = function - | base, [] - -> pp_base fmt base - | base, accesses - -> F.fprintf fmt "%a.%a" pp_base base pp_access_list accesses + | base, [] -> + pp_base fmt base + | base, accesses -> + F.fprintf fmt "%a.%a" pp_base base pp_access_list accesses + let equal = [%compare.equal : t] let truncate = function - | base, [] | base, [_] - -> (base, []) - | base, accesses - -> (base, List.rev (List.tl_exn (List.rev accesses))) + | base, [] | base, [_] -> + (base, []) + | base, accesses -> + (base, List.rev (List.tl_exn (List.rev accesses))) + let lookup_field_type_annot tenv base_typ field_name = let lookup = Tenv.lookup tenv in Typ.Struct.get_field_type_and_annotation ~lookup field_name base_typ + (* Get the type of an access, or None if the type cannot be determined *) let get_access_type tenv base_typ = function - | FieldAccess field_name - -> Option.map (lookup_field_type_annot tenv base_typ field_name) ~f:fst - | ArrayAccess (array_typ, _) - -> Some array_typ + | FieldAccess field_name -> + Option.map (lookup_field_type_annot tenv base_typ field_name) ~f:fst + | ArrayAccess (array_typ, _) -> + Some array_typ + (* For field access, get the field name and the annotation associated with it * Return None if given an array access, or if the info cannot be obtained *) let get_access_field_annot tenv base_typ = function - | FieldAccess field_name - -> Option.map (lookup_field_type_annot tenv base_typ field_name) ~f:(fun (_, annot) -> + | FieldAccess field_name -> + Option.map (lookup_field_type_annot tenv base_typ field_name) ~f:(fun (_, annot) -> (field_name, annot) ) - | ArrayAccess _ - -> None + | ArrayAccess _ -> + None + (* Extract the last access of the given access path together with its base type. * Here the base type is defined to be the declaring class of the last accessed field, @@ -86,36 +93,39 @@ module Raw = struct * - for x, the base type of the last access is type(x) *) let last_access_info ((_, base_typ), accesses) tenv = let rec last_access_info_impl tenv base_typ = function - | [] - -> (Some base_typ, None) - | [last_access] - -> (Some base_typ, Some last_access) + | [] -> + (Some base_typ, None) + | [last_access] -> + (Some base_typ, Some last_access) | curr_access :: rest -> match get_access_type tenv base_typ curr_access with - | Some access_typ - -> last_access_info_impl tenv access_typ rest - | None - -> (None, None) + | Some access_typ -> + last_access_info_impl tenv access_typ rest + | None -> + (None, None) in last_access_info_impl tenv base_typ accesses + let get_last_access (_, accesses) = List.last accesses let get_field_and_annotation ap tenv = match last_access_info ap tenv with - | Some base_typ, Some access - -> get_access_field_annot tenv base_typ access - | _ - -> None + | Some base_typ, Some access -> + get_access_field_annot tenv base_typ access + | _ -> + None + let get_typ ap tenv = match last_access_info ap tenv with - | (Some _ as typ), None - -> typ - | Some base_typ, Some access - -> get_access_type tenv base_typ access - | _ - -> None + | (Some _ as typ), None -> + typ + | Some base_typ, Some access -> + get_access_type tenv base_typ access + | _ -> + None + let base_of_pvar pvar typ = (Var.of_pvar pvar, typ) @@ -131,48 +141,50 @@ module Raw = struct match exp with | Exp.Var id -> ( match f_resolve_id (Var.of_id id) with - | Some (base, base_accesses) - -> (base, base_accesses @ accesses) :: acc - | None - -> (base_of_id id typ, accesses) :: acc ) + | Some (base, base_accesses) -> + (base, base_accesses @ accesses) :: acc + | None -> + (base_of_id id typ, accesses) :: acc ) | Exp.Lvar pvar when Pvar.is_ssa_frontend_tmp pvar -> ( match f_resolve_id (Var.of_pvar pvar) with - | Some (base, base_accesses) - -> (base, base_accesses @ accesses) :: acc - | None - -> (base_of_pvar pvar typ, accesses) :: acc ) - | Exp.Lvar pvar - -> (base_of_pvar pvar typ, accesses) :: acc - | Exp.Lfield (root_exp, fld, root_exp_typ) - -> let field_access = FieldAccess fld in + | Some (base, base_accesses) -> + (base, base_accesses @ accesses) :: acc + | None -> + (base_of_pvar pvar typ, accesses) :: acc ) + | Exp.Lvar pvar -> + (base_of_pvar pvar typ, accesses) :: acc + | Exp.Lfield (root_exp, fld, root_exp_typ) -> + let field_access = FieldAccess fld in of_exp_ root_exp root_exp_typ (field_access :: accesses) acc - | Exp.Lindex (root_exp, index_exp) - -> let index_access_paths = + | Exp.Lindex (root_exp, index_exp) -> + let index_access_paths = if include_array_indexes then of_exp_ index_exp typ [] [] else [] in let array_access = ArrayAccess (typ, index_access_paths) in let array_typ = Typ.mk (Tarray (typ, None, None)) in of_exp_ root_exp array_typ (array_access :: accesses) acc - | Exp.Cast (cast_typ, cast_exp) - -> of_exp_ cast_exp cast_typ [] acc - | Exp.UnOp (_, unop_exp, _) - -> of_exp_ unop_exp typ [] acc - | Exp.Exn exn_exp - -> of_exp_ exn_exp typ [] acc - | Exp.BinOp (_, exp1, exp2) - -> of_exp_ exp1 typ [] acc |> of_exp_ exp2 typ [] - | Exp.Const _ | Closure _ | Sizeof _ - -> (* trying to make access path from an invalid expression *) + | Exp.Cast (cast_typ, cast_exp) -> + of_exp_ cast_exp cast_typ [] acc + | Exp.UnOp (_, unop_exp, _) -> + of_exp_ unop_exp typ [] acc + | Exp.Exn exn_exp -> + of_exp_ exn_exp typ [] acc + | Exp.BinOp (_, exp1, exp2) -> + of_exp_ exp1 typ [] acc |> of_exp_ exp2 typ [] + | Exp.Const _ | Closure _ | Sizeof _ -> + (* trying to make access path from an invalid expression *) acc in of_exp_ exp0 typ0 [] [] + let of_lhs_exp ~include_array_indexes lhs_exp typ ~(f_resolve_id: Var.t -> t option) = match of_exp ~include_array_indexes lhs_exp typ ~f_resolve_id with - | [lhs_ap] - -> Some lhs_ap - | _ - -> None + | [lhs_ap] -> + Some lhs_ap + | _ -> + None + let append (base, old_accesses) new_accesses = (base, old_accesses @ new_accesses) @@ -180,15 +192,17 @@ module Raw = struct if phys_equal path1 path2 then true else match (path1, path2) with - | [], _ - -> true - | _, [] - -> false - | access1 :: p1, access2 :: p2 - -> equal_access access1 access2 && is_prefix_path p1 p2 - - let is_prefix (base1, path1 as ap1) (base2, path2 as ap2) = + | [], _ -> + true + | _, [] -> + false + | access1 :: p1, access2 :: p2 -> + equal_access access1 access2 && is_prefix_path p1 p2 + + + let is_prefix ((base1, path1) as ap1) ((base2, path2) as ap2) = if phys_equal ap1 ap2 then true else equal_base base1 base2 && is_prefix_path path1 path2 + end module Abs = struct @@ -201,42 +215,48 @@ module Abs = struct let extract = function Exact ap | Abstracted ap -> ap let with_base base = function - | Exact (_, accesses) - -> Exact (base, accesses) - | Abstracted (_, accesses) - -> Abstracted (base, accesses) + | Exact (_, accesses) -> + Exact (base, accesses) + | Abstracted (_, accesses) -> + Abstracted (base, accesses) + let to_footprint formal_index access_path = let _, base_typ = fst (extract access_path) in with_base (Var.of_formal_index formal_index, base_typ) access_path + let get_footprint_index_base base = match base with - | Var.LogicalVar id, _ when Ident.is_footprint id - -> Some (Ident.get_stamp id) - | _ - -> None + | Var.LogicalVar id, _ when Ident.is_footprint id -> + Some (Ident.get_stamp id) + | _ -> + None + let get_footprint_index access_path = let base, _ = extract access_path in get_footprint_index_base base + let is_exact = function Exact _ -> true | Abstracted _ -> false let ( <= ) ~lhs ~rhs = match (lhs, rhs) with - | Abstracted _, Exact _ - -> false - | Exact lhs_ap, Exact rhs_ap - -> Raw.equal lhs_ap rhs_ap - | (Exact lhs_ap | Abstracted lhs_ap), Abstracted rhs_ap - -> Raw.is_prefix rhs_ap lhs_ap + | Abstracted _, Exact _ -> + false + | Exact lhs_ap, Exact rhs_ap -> + Raw.equal lhs_ap rhs_ap + | (Exact lhs_ap | Abstracted lhs_ap), Abstracted rhs_ap -> + Raw.is_prefix rhs_ap lhs_ap + let pp fmt = function - | Exact access_path - -> Raw.pp fmt access_path - | Abstracted access_path - -> F.fprintf fmt "%a*" Raw.pp access_path + | Exact access_path -> + Raw.pp fmt access_path + | Abstracted access_path -> + F.fprintf fmt "%a*" Raw.pp access_path + end include Raw diff --git a/infer/src/checkers/accessPathDomains.ml b/infer/src/checkers/accessPathDomains.ml index 683e786c2..f91302402 100644 --- a/infer/src/checkers/accessPathDomains.ml +++ b/infer/src/checkers/accessPathDomains.ml @@ -32,6 +32,7 @@ module Set = struct aps)) aps + let add = APSet.add let of_list = APSet.of_list @@ -40,18 +41,21 @@ module Set = struct APSet.mem ap aps || APSet.exists (fun other_ap -> AccessPath.Abs.( <= ) ~lhs:ap ~rhs:other_ap) aps + let mem_fuzzy ap aps = let has_overlap ap1 ap2 = AccessPath.Abs.( <= ) ~lhs:ap1 ~rhs:ap2 || AccessPath.Abs.( <= ) ~lhs:ap2 ~rhs:ap1 in APSet.mem ap aps || APSet.exists (has_overlap ap) aps + let ( <= ) ~lhs ~rhs = if phys_equal lhs rhs then true else let rhs_contains lhs_ap = mem lhs_ap rhs in APSet.subset lhs rhs || APSet.for_all rhs_contains lhs + let join aps1 aps2 = if phys_equal aps1 aps2 then aps1 else APSet.union aps1 aps2 let widen ~prev ~next ~num_iters:_ = @@ -59,11 +63,12 @@ module Set = struct else let abstract_access_path ap aps = match ap with - | AccessPath.Abs.Exact exact_ap - -> APSet.add (AccessPath.Abs.Abstracted exact_ap) aps - | AccessPath.Abs.Abstracted _ - -> APSet.add ap aps + | AccessPath.Abs.Exact exact_ap -> + APSet.add (AccessPath.Abs.Abstracted exact_ap) aps + | AccessPath.Abs.Abstracted _ -> + APSet.add ap aps in let diff_aps = APSet.diff next prev in APSet.fold abstract_access_path diff_aps APSet.empty |> join prev + end diff --git a/infer/src/checkers/accessTree.ml b/infer/src/checkers/accessTree.ml index aedbf5fc1..0bf3b99cd 100644 --- a/infer/src/checkers/accessTree.ml +++ b/infer/src/checkers/accessTree.ml @@ -77,11 +77,12 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct let compare a1 a2 = match (a1, a2) with - | AccessPath.ArrayAccess (t1, _), AccessPath.ArrayAccess (t2, _) - -> (* ignore indexes *) + | AccessPath.ArrayAccess (t1, _), AccessPath.ArrayAccess (t2, _) -> + (* ignore indexes *) Typ.compare t1 t2 - | _ - -> AccessPath.compare_access a1 a2 + | _ -> + AccessPath.compare_access a1 a2 + let pp = AccessPath.pp_access end) @@ -117,10 +118,11 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct let rec node_depth (_, tree) = 1 + tree_depth tree and tree_depth = function - | Star - -> 0 - | Subtree node_map - -> AccessMap.fold (fun _ node acc -> max_depth node acc) node_map 0 + | Star -> + 0 + | Subtree node_map -> + AccessMap.fold (fun _ node acc -> max_depth node acc) node_map 0 + and max_depth node max_depth_acc = Int.max (node_depth node) max_depth_acc @@ -129,28 +131,30 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct let make_access_node base_trace access trace = make_node base_trace (AccessMap.singleton access (make_normal_leaf trace)) + (** find all of the traces in the subtree and join them with [orig_trace] *) let rec join_all_traces ?(join_traces= TraceDomain.join) orig_trace = function - | Subtree subtree - -> let join_all_traces_ orig_trace tree = + | Subtree subtree -> + let join_all_traces_ orig_trace tree = let node_join_traces _ (trace, node) trace_acc = join_all_traces (join_traces trace_acc trace) node in AccessMap.fold node_join_traces tree orig_trace in join_all_traces_ orig_trace subtree - | Star - -> orig_trace + | Star -> + orig_trace + let get_node ap tree = let rec accesses_get_node access_list trace tree = match (access_list, tree) with - | _, Star - -> (trace, Star) - | [], (Subtree _ as tree) - -> (trace, tree) - | access :: accesses, Subtree subtree - -> let access_trace, access_subtree = AccessMap.find access subtree in + | _, Star -> + (trace, Star) + | [], (Subtree _ as tree) -> + (trace, tree) + | access :: accesses, Subtree subtree -> + let access_trace, access_subtree = AccessMap.find access subtree in accesses_get_node accesses access_trace access_subtree in let get_node_ base accesses tree = @@ -159,34 +163,36 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct in let base, accesses = AccessPath.Abs.extract ap in match get_node_ base accesses tree with - | trace, subtree - -> if AccessPath.Abs.is_exact ap then Some (trace, subtree) + | trace, subtree -> + if AccessPath.Abs.is_exact ap then Some (trace, subtree) else (* input query was [ap]*, and [trace] is the trace associated with [ap]. get the traces associated with the children of [ap] in [tree] and join them with [trace] *) Some (join_all_traces trace subtree, subtree) - | exception Not_found - -> None + | exception Not_found -> + None + let get_trace ap tree = Option.map ~f:fst (get_node ap tree) - let rec access_tree_lteq (lhs_trace, lhs_tree as lhs) (rhs_trace, rhs_tree as rhs) = + let rec access_tree_lteq ((lhs_trace, lhs_tree) as lhs) ((rhs_trace, rhs_tree) as rhs) = if phys_equal lhs rhs then true else TraceDomain.( <= ) ~lhs:lhs_trace ~rhs:rhs_trace && match (lhs_tree, rhs_tree) with - | Subtree lhs_subtree, Subtree rhs_subtree - -> AccessMap.for_all + | Subtree lhs_subtree, Subtree rhs_subtree -> + AccessMap.for_all (fun k lhs_v -> try let rhs_v = AccessMap.find k rhs_subtree in access_tree_lteq lhs_v rhs_v with Not_found -> false) lhs_subtree - | _, Star - -> true - | Star, Subtree _ - -> false + | _, Star -> + true + | Star, Subtree _ -> + false + let ( <= ) ~lhs ~rhs = if phys_equal lhs rhs then true @@ -199,15 +205,16 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct with Not_found -> false) lhs - let node_join_ f_node_merge f_trace_merge (trace1, tree1 as node1) (trace2, tree2 as node2) = + + let node_join_ f_node_merge f_trace_merge ((trace1, tree1) as node1) ((trace2, tree2) as node2) = if phys_equal node1 node2 then node1 else let trace' = f_trace_merge trace1 trace2 in (* note: this is much-uglified by address equality optimization checks. skip to the else cases for the actual semantics *) match (tree1, tree2) with - | Subtree subtree1, Subtree subtree2 - -> let tree' = AccessMap.merge (fun _ v1 v2 -> f_node_merge v1 v2) subtree1 subtree2 in + | Subtree subtree1, Subtree subtree2 -> + let tree' = AccessMap.merge (fun _ v1 v2 -> f_node_merge v1 v2) subtree1 subtree2 in if AccessMap.cardinal tree' > Config.max_width then (* too big; create a star insted *) let trace'' = join_all_traces trace' (Subtree tree') in @@ -215,35 +222,37 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct else if phys_equal trace' trace1 && phys_equal tree' subtree1 then node1 else if phys_equal trace' trace2 && phys_equal tree' subtree2 then node2 else (trace', Subtree tree') - | Star, t - -> (* vacuum up all the traces associated with the subtree t and join them with trace' *) + | Star, t -> + (* vacuum up all the traces associated with the subtree t and join them with trace' *) let trace'' = join_all_traces trace' t in if phys_equal trace'' trace1 then node1 else (trace'', Star) - | t, Star - -> (* same as above, but kind-of duplicated to allow address equality optimization *) + | t, Star -> + (* same as above, but kind-of duplicated to allow address equality optimization *) let trace'' = join_all_traces trace' t in if phys_equal trace'' trace2 then node2 else (trace'', Star) + let rec node_join node1 node2 = node_join_ node_merge TraceDomain.join node1 node2 and node_merge node1_opt node2_opt = match (node1_opt, node2_opt) with - | Some node1, Some node2 - -> let joined_node = node_join node1 node2 in + | Some node1, Some node2 -> + let joined_node = node_join node1 node2 in if phys_equal joined_node node1 then node1_opt else if phys_equal joined_node node2 then node2_opt else Some joined_node - | None, node_opt | node_opt, None - -> node_opt + | None, node_opt | node_opt, None -> + node_opt + (* truncate [node] to a tree of depth <= [depth]. [depth] must be positive *) - let node_depth_truncate (_, tree as node) depth = - let rec node_depth_truncate_ depth (trace, tree as node) = + let node_depth_truncate ((_, tree) as node) depth = + let rec node_depth_truncate_ depth ((trace, tree) as node) = match tree with - | Star - -> node - | Subtree subtree - -> if Int.( <= ) depth 0 then + | Star -> + node + | Subtree subtree -> + if Int.( <= ) depth 0 then let trace' = join_all_traces trace tree in make_starred_leaf trace' else @@ -254,30 +263,31 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct else (* already short enough; don't bother truncating *) node + (* helper for [add_access]. [last_trace] is the trace associated with [tree] in the parent. *) let access_tree_add_trace ~node_to_add ~seen_array_access ~is_exact accesses node = let rec access_tree_add_trace_ ~seen_array_access accesses node depth = match (accesses, node) with | [], (trace, tree) -> ( match (is_exact, seen_array_access) with - | true, false - -> (* adding x.f, do strong update on both subtree and its traces *) + | true, false -> + (* adding x.f, do strong update on both subtree and its traces *) node_depth_truncate node_to_add (Config.max_depth - depth) - | true, true - -> (* adding x[_], do weak update on subtree and on its immediate trace. note : [node] + | true, true -> + (* adding x[_], do weak update on subtree and on its immediate trace. note : [node] already satisfies the depth invariant because it's already in the tree; no need to truncate it. *) let truncated_node = node_depth_truncate node_to_add (Config.max_depth - depth) in node_join truncated_node node - | _ - -> (* adding x.f* or x[_]*, join with traces of subtree and replace it with * *) + | _ -> + (* adding x.f* or x[_]*, join with traces of subtree and replace it with * *) let node_trace, node_tree = node_to_add in let trace' = join_all_traces (TraceDomain.join trace node_trace) tree in make_starred_leaf (join_all_traces trace' node_tree) ) - | _, (_, Star) - -> node_join node_to_add node - | access :: accesses, (trace, Subtree subtree) - -> let depth' = depth + 1 in + | _, (_, Star) -> + node_join node_to_add node + | access :: accesses, (trace, Subtree subtree) -> + let depth' = depth + 1 in let access_node' = if depth' >= Config.max_depth then access_tree_add_trace_ ~seen_array_access accesses empty_starred_leaf depth' @@ -294,10 +304,10 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct seen_array_access || match access with - | AccessPath.ArrayAccess _ - -> true - | AccessPath.FieldAccess _ - -> false + | AccessPath.ArrayAccess _ -> + true + | AccessPath.FieldAccess _ -> + false in access_tree_add_trace_ ~seen_array_access accesses access_node depth' in @@ -308,6 +318,7 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct in access_tree_add_trace_ ~seen_array_access accesses node 1 + let add_node ap node_to_add tree = let base, accesses = AccessPath.Abs.extract ap in let is_exact = AccessPath.Abs.is_exact ap in @@ -322,34 +333,41 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct in BaseMap.add base base_node' tree + let add_trace ap trace tree = add_node ap (make_normal_leaf trace) tree let join tree1 tree2 = if phys_equal tree1 tree2 then tree1 else BaseMap.merge (fun _ n1 n2 -> node_merge n1 n2) tree1 tree2 + let rec access_map_fold_ f base accesses m acc = AccessMap.fold (fun access node acc -> node_fold_ f base (accesses @ [access]) node acc) m acc - and node_fold_ f base accesses (_, tree as node) acc = + + and node_fold_ f base accesses ((_, tree) as node) acc = let cur_ap_raw = (base, accesses) in match tree with - | Subtree access_map - -> let acc' = f acc (AccessPath.Abs.Exact cur_ap_raw) node in + | Subtree access_map -> + let acc' = f acc (AccessPath.Abs.Exact cur_ap_raw) node in access_map_fold_ f base accesses access_map acc' - | Star - -> f acc (AccessPath.Abs.Abstracted cur_ap_raw) node + | Star -> + f acc (AccessPath.Abs.Abstracted cur_ap_raw) node + let node_fold (f: 'a -> AccessPath.Abs.t -> node -> 'a) base node acc = node_fold_ f base [] node acc + let fold (f: 'a -> AccessPath.Abs.t -> node -> 'a) tree acc_ = BaseMap.fold (fun base node acc -> node_fold f base node acc) tree acc_ + let trace_fold (f: 'a -> AccessPath.Abs.t -> TraceDomain.astate -> 'a) = let f_ acc ap (trace, _) = f acc ap trace in fold f_ + (* try for a bit to reach a fixed point before widening aggressively *) let joins_before_widen = 3 @@ -359,36 +377,37 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct else let trace_widen prev next = TraceDomain.widen ~prev ~next ~num_iters in (* turn [node] into a starred node by vacuuming up its sub-traces *) - let node_add_stars (trace, tree as node) = + let node_add_stars ((trace, tree) as node) = match tree with - | Subtree _ - -> let trace' = join_all_traces ~join_traces:trace_widen trace tree in + | Subtree _ -> + let trace' = join_all_traces ~join_traces:trace_widen trace tree in make_starred_leaf trace' - | Star - -> node + | Star -> + node in let rec node_widen prev_node_opt next_node_opt = match (prev_node_opt, next_node_opt) with - | Some prev_node, Some next_node - -> let widened_node = node_join_ node_widen trace_widen prev_node next_node in + | Some prev_node, Some next_node -> + let widened_node = node_join_ node_widen trace_widen prev_node next_node in if phys_equal widened_node prev_node then prev_node_opt else if phys_equal widened_node next_node then next_node_opt else Some widened_node - | None, Some next_node - -> let widened_node = node_add_stars next_node in + | None, Some next_node -> + let widened_node = node_add_stars next_node in if phys_equal widened_node next_node then next_node_opt else Some widened_node - | Some _, None | None, None - -> prev_node_opt + | Some _, None | None, None -> + prev_node_opt in BaseMap.merge (fun _ prev_node next_node -> node_widen prev_node next_node) prev next + let rec pp_node fmt (trace, subtree) = let pp_subtree fmt tree = match tree with - | Subtree access_map - -> AccessMap.pp ~pp_value:pp_node fmt access_map - | Star - -> F.fprintf fmt "*" + | Subtree access_map -> + AccessMap.pp ~pp_value:pp_node fmt access_map + | Star -> + F.fprintf fmt "*" in if not (TraceDomain.is_empty trace) then if not (is_empty_tree subtree) then @@ -396,6 +415,7 @@ module Make (TraceDomain : AbstractDomain.WithBottom) (Config : Config) = struct else F.fprintf fmt "%a" TraceDomain.pp trace else F.fprintf fmt "%a" pp_subtree subtree + let pp fmt base_tree = BaseMap.pp ~pp_value:pp_node fmt base_tree end @@ -406,4 +426,5 @@ module PathSet (Config : Config) = struct let pp fmt tree = let collect_path acc access_path (is_mem, _) = if is_mem then access_path :: acc else acc in fold collect_path tree [] |> PrettyPrintable.pp_collection ~pp_item:AccessPath.Abs.pp fmt + end diff --git a/infer/src/checkers/addressTaken.ml b/infer/src/checkers/addressTaken.ml index 25aebdfe6..36aa045a6 100644 --- a/infer/src/checkers/addressTaken.ml +++ b/infer/src/checkers/addressTaken.ml @@ -23,32 +23,34 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let rec add_address_taken_pvars exp astate = match exp with - | Exp.Lvar pvar - -> Domain.add pvar astate - | Exp.Cast (_, e) | UnOp (_, e, _) | Lfield (e, _, _) - -> add_address_taken_pvars e astate - | Exp.BinOp (_, e1, e2) | Lindex (e1, e2) - -> add_address_taken_pvars e1 astate |> add_address_taken_pvars e2 + | Exp.Lvar pvar -> + Domain.add pvar astate + | Exp.Cast (_, e) | UnOp (_, e, _) | Lfield (e, _, _) -> + add_address_taken_pvars e astate + | Exp.BinOp (_, e1, e2) | Lindex (e1, e2) -> + add_address_taken_pvars e1 astate |> add_address_taken_pvars e2 | Exp.Exn _ | Exp.Closure _ | Exp.Const (Cint _ | Cfun _ | Cstr _ | Cfloat _ | Cclass _) | Exp.Var _ - | Exp.Sizeof _ - -> astate + | Exp.Sizeof _ -> + astate + let exec_instr astate _ _ = function - | Sil.Store (_, {desc= Tptr _}, rhs_exp, _) - -> add_address_taken_pvars rhs_exp astate - | Sil.Call (_, _, actuals, _, _) - -> let add_actual_by_ref astate_acc = function - | actual_exp, {Typ.desc= Tptr _} - -> add_address_taken_pvars actual_exp astate_acc - | _ - -> astate_acc + | Sil.Store (_, {desc= Tptr _}, rhs_exp, _) -> + add_address_taken_pvars rhs_exp astate + | Sil.Call (_, _, actuals, _, _) -> + let add_actual_by_ref astate_acc = function + | actual_exp, {Typ.desc= Tptr _} -> + add_address_taken_pvars actual_exp astate_acc + | _ -> + astate_acc in List.fold ~f:add_actual_by_ref ~init:astate actuals - | Sil.Store _ | Load _ | Prune _ | Nullify _ | Abstract _ | Remove_temps _ | Declare_locals _ - -> astate + | Sil.Store _ | Load _ | Prune _ | Nullify _ | Abstract _ | Remove_temps _ | Declare_locals _ -> + astate + end module Analyzer = AbstractInterpreter.Make (ProcCfg.Exceptional) (TransferFunctions) diff --git a/infer/src/checkers/annotationReachability.ml b/infer/src/checkers/annotationReachability.ml index 05840bde3..e3ea2a602 100644 --- a/infer/src/checkers/annotationReachability.ml +++ b/infer/src/checkers/annotationReachability.ml @@ -20,12 +20,12 @@ module Domain = struct module TrackingDomain = AbstractDomain.BottomLifted (TrackingVar) include AbstractDomain.Pair (AnnotReachabilityDomain) (TrackingDomain) - let add_call_site annot sink call_site (annot_map, previous_vstate as astate) = + let add_call_site annot sink call_site ((annot_map, previous_vstate) as astate) = match previous_vstate with - | Bottom - -> astate - | NonBottom _ - -> let sink_map = + | Bottom -> + astate + | NonBottom _ -> + let sink_map = try AnnotReachabilityDomain.find annot annot_map with Not_found -> AnnotReachabilityDomain.SinkMap.empty in @@ -38,24 +38,28 @@ module Domain = struct if phys_equal sink_map' sink_map then astate else (AnnotReachabilityDomain.add annot sink_map' annot_map, previous_vstate) + let stop_tracking ((annot_map, _): astate) = (annot_map, Bottom) - let add_tracking_var var (annot_map, previous_vstate as astate) = + let add_tracking_var var ((annot_map, previous_vstate) as astate) = match previous_vstate with - | Bottom - -> astate - | NonBottom vars - -> (annot_map, NonBottom (TrackingVar.add var vars)) + | Bottom -> + astate + | NonBottom vars -> + (annot_map, NonBottom (TrackingVar.add var vars)) + - let remove_tracking_var var (annot_map, previous_vstate as astate) = + let remove_tracking_var var ((annot_map, previous_vstate) as astate) = match previous_vstate with - | Bottom - -> astate - | NonBottom vars - -> (annot_map, NonBottom (TrackingVar.remove var vars)) + | Bottom -> + astate + | NonBottom vars -> + (annot_map, NonBottom (TrackingVar.remove var vars)) + let is_tracked_var var (_, vstate) = match vstate with Bottom -> false | NonBottom vars -> TrackingVar.mem var vars + end module Summary = Summary.Make (struct @@ -64,6 +68,7 @@ module Summary = Summary.Make (struct let update_payload annot_map (summary: Specs.summary) = {summary with payload= {summary.payload with annot_map= Some annot_map}} + let read_payload (summary: Specs.summary) = summary.payload.annot_map end) @@ -82,8 +87,8 @@ let expensive_overrides_unexpensive = "CHECKERS_EXPENSIVE_OVERRIDES_UNANNOTATED" let annotation_reachability_error = "CHECKERS_ANNOTATION_REACHABILITY_ERROR" let is_modeled_expensive tenv = function - | Typ.Procname.Java proc_name_java as proc_name - -> not (BuiltinDecl.is_declared proc_name) + | Typ.Procname.Java proc_name_java as proc_name -> + not (BuiltinDecl.is_declared proc_name) && let is_subclass = let classname = @@ -92,28 +97,32 @@ let is_modeled_expensive tenv = function PatternMatch.is_subtype_of_str tenv classname in Inferconfig.modeled_expensive_matcher is_subclass proc_name - | _ - -> false + | _ -> + false + let is_allocator tenv pname = match pname with - | Typ.Procname.Java pname_java - -> let is_throwable () = + | Typ.Procname.Java pname_java -> + let is_throwable () = let class_name = Typ.Name.Java.from_string (Typ.Procname.java_get_class_name pname_java) in PatternMatch.is_throwable tenv class_name in Typ.Procname.is_constructor pname && not (BuiltinDecl.is_declared pname) && not (is_throwable ()) - | _ - -> false + | _ -> + false + let check_attributes check tenv pname = PatternMatch.check_class_attributes check tenv pname || Annotations.pname_has_return_annot pname ~attrs_of_pname:Specs.proc_resolve_attributes check + let method_overrides is_annotated tenv pname = PatternMatch.override_exists (fun pn -> is_annotated tenv pn) tenv pname + let method_has_annot annot tenv pname = let has_annot ia = Annotations.ia_ends_with ia annot.Annot.class_name in if Annotations.annot_ends_with annot dummy_constructor_annot then is_allocator tenv pname @@ -121,6 +130,7 @@ let method_has_annot annot tenv pname = check_attributes has_annot tenv pname || is_modeled_expensive tenv pname else check_attributes has_annot tenv pname + let method_overrides_annot annot tenv pname = method_overrides (method_has_annot annot) tenv pname let lookup_annotation_calls caller_pdesc annot pname = @@ -128,13 +138,15 @@ let lookup_annotation_calls caller_pdesc annot pname = | Some {Specs.payload= {Specs.annot_map= Some annot_map}} -> ( try AnnotReachabilityDomain.find annot annot_map with Not_found -> AnnotReachabilityDomain.SinkMap.empty ) - | _ - -> AnnotReachabilityDomain.SinkMap.empty + | _ -> + AnnotReachabilityDomain.SinkMap.empty + let update_trace loc trace = if Location.equal loc Location.dummy then trace else Errlog.make_trace_element 0 loc "" [] :: trace + let string_of_pname = Typ.Procname.to_simplified_string ~withclass:true let report_allocation_stack src_annot summary fst_call_loc trace stack_str constructor_pname @@ -144,13 +156,14 @@ let report_allocation_stack src_annot summary fst_call_loc trace stack_str const let constr_str = string_of_pname constructor_pname in let description = Format.asprintf "Method %a annotated with %a allocates %a via %a" MF.pp_monospaced - (Typ.Procname.to_simplified_string pname) MF.pp_monospaced ("@" ^ src_annot) MF.pp_monospaced - constr_str MF.pp_monospaced + (Typ.Procname.to_simplified_string pname) + MF.pp_monospaced ("@" ^ src_annot) MF.pp_monospaced constr_str MF.pp_monospaced (stack_str ^ "new " ^ constr_str) in let exn = Exceptions.Checkers (allocates_memory, Localise.verbatim_desc description) in Reporting.log_error summary ~loc:fst_call_loc ~ltr:final_trace exn + let report_annotation_stack src_annot snk_annot src_summary loc trace stack_str snk_pname call_loc = let src_pname = Specs.get_proc_name src_summary in if String.equal snk_annot dummy_constructor_annot then @@ -160,9 +173,10 @@ let report_annotation_stack src_annot snk_annot src_summary loc trace stack_str let exp_pname_str = string_of_pname snk_pname in let description = Format.asprintf "Method %a annotated with %a calls %a where %a is annotated with %a" - MF.pp_monospaced (Typ.Procname.to_simplified_string src_pname) MF.pp_monospaced - ("@" ^ src_annot) MF.pp_monospaced (stack_str ^ exp_pname_str) MF.pp_monospaced - exp_pname_str MF.pp_monospaced ("@" ^ snk_annot) + MF.pp_monospaced + (Typ.Procname.to_simplified_string src_pname) + MF.pp_monospaced ("@" ^ src_annot) MF.pp_monospaced (stack_str ^ exp_pname_str) + MF.pp_monospaced exp_pname_str MF.pp_monospaced ("@" ^ snk_annot) in let msg = if String.equal src_annot Annotations.performance_critical then calls_expensive_method @@ -171,14 +185,15 @@ let report_annotation_stack src_annot snk_annot src_summary loc trace stack_str let exn = Exceptions.Checkers (msg, Localise.verbatim_desc description) in Reporting.log_error src_summary ~loc ~ltr:final_trace exn + let report_call_stack summary end_of_stack lookup_next_calls report call_site sink_map = (* TODO: stop using this; we can use the call site instead *) let lookup_location pname = match Specs.get_summary pname with - | None - -> Location.dummy - | Some summary - -> summary.Specs.attributes.ProcAttributes.loc + | None -> + Location.dummy + | Some summary -> + summary.Specs.attributes.ProcAttributes.loc in let rec loop fst_call_loc visited_pnames (trace, stack_str) (callee_pname, call_loc) = if end_of_stack callee_pname then @@ -191,7 +206,7 @@ let report_call_stack summary end_of_stack lookup_next_calls report call_site si let new_trace = update_trace call_loc trace |> update_trace callee_def_loc in let unseen_callees, updated_callees = AnnotReachabilityDomain.SinkMap.fold - (fun _ call_sites (unseen, visited as accu) -> + (fun _ call_sites ((unseen, visited) as accu) -> try let call_site = AnnotReachabilityDomain.CallSites.min_elt call_sites in let p = CallSite.pname call_site in @@ -214,13 +229,16 @@ let report_call_stack summary end_of_stack lookup_next_calls report call_site si with Not_found -> ()) sink_map + let report_src_snk_path {Callbacks.proc_desc; tenv; summary} sink_map snk_annot src_annot = let proc_name = Procdesc.get_proc_name proc_desc in let loc = Procdesc.get_loc proc_desc in if method_overrides_annot src_annot tenv proc_name then let f_report = report_annotation_stack src_annot.Annot.class_name snk_annot.Annot.class_name in report_call_stack summary (method_has_annot snk_annot tenv) - (lookup_annotation_calls proc_desc snk_annot) f_report (CallSite.make proc_name loc) sink_map + (lookup_annotation_calls proc_desc snk_annot) + f_report (CallSite.make proc_name loc) sink_map + let report_src_snk_paths proc_data annot_map src_annot_list snk_annot = try @@ -228,6 +246,7 @@ let report_src_snk_paths proc_data annot_map src_annot_list snk_annot = List.iter ~f:(report_src_snk_path proc_data sink_map snk_annot) src_annot_list with Not_found -> () + (* New implementation starts here *) let annotation_of_str annot_str = {Annot.class_name= annot_str; parameters= []} @@ -261,6 +280,7 @@ module StandardAnnotationSpec = struct ; report= (fun proc_data annot_map -> report_src_snk_paths proc_data annot_map src_annots snk_annot) } + end module NoAllocationAnnotationSpec = struct @@ -278,6 +298,7 @@ module NoAllocationAnnotationSpec = struct ; report= (fun proc_data annot_map -> report_src_snk_paths proc_data annot_map [no_allocation_annot] constructor_annot) } + end module ExpensiveAnnotationSpec = struct @@ -295,14 +316,18 @@ module ExpensiveAnnotationSpec = struct if not (method_is_expensive tenv overridden_pname) then let description = Format.asprintf "Method %a overrides unannotated method %a and cannot be annotated with %a" - MF.pp_monospaced (Typ.Procname.to_string proc_name) MF.pp_monospaced - (Typ.Procname.to_string overridden_pname) MF.pp_monospaced ("@" ^ Annotations.expensive) + MF.pp_monospaced + (Typ.Procname.to_string proc_name) + MF.pp_monospaced + (Typ.Procname.to_string overridden_pname) + MF.pp_monospaced ("@" ^ Annotations.expensive) in let exn = Exceptions.Checkers (expensive_overrides_unexpensive, Localise.verbatim_desc description) in Reporting.log_error summary ~loc exn + let spec = let open AnnotationSpec in { source_predicate= is_expensive @@ -318,38 +343,41 @@ module ExpensiveAnnotationSpec = struct if is_expensive tenv proc_name then PatternMatch.override_iter (check_expensive_subtyping_rules proc_data) tenv proc_name ; report_src_snk_paths proc_data astate [performance_critical_annot] expensive_annot) } + end (* parse user-defined specs from .inferconfig *) let parse_user_defined_specs = function - | `List user_specs - -> let parse_user_spec json = + | `List user_specs -> + let parse_user_spec json = let open Yojson.Basic in let sources = Util.member "sources" json |> Util.to_list |> List.map ~f:Util.to_string in let sinks = Util.member "sink" json |> Util.to_string in (sources, sinks) in List.map ~f:parse_user_spec user_specs - | _ - -> [] + | _ -> + [] + let annot_specs = let user_defined_specs = let specs = parse_user_defined_specs Config.annotation_reachability_custom_pairs in List.map specs ~f:(fun (src_annots, snk_annot) -> - StandardAnnotationSpec.from_annotations (List.map ~f:annotation_of_str src_annots) + StandardAnnotationSpec.from_annotations + (List.map ~f:annotation_of_str src_annots) (annotation_of_str snk_annot) ) in ExpensiveAnnotationSpec.spec :: NoAllocationAnnotationSpec.spec - :: StandardAnnotationSpec.from_annotations - [ annotation_of_str Annotations.any_thread - ; annotation_of_str Annotations.for_non_ui_thread ] - (annotation_of_str Annotations.ui_thread) - :: StandardAnnotationSpec.from_annotations - [annotation_of_str Annotations.ui_thread; annotation_of_str Annotations.for_ui_thread] - (annotation_of_str Annotations.for_non_ui_thread) - :: user_defined_specs + :: StandardAnnotationSpec.from_annotations + [annotation_of_str Annotations.any_thread; annotation_of_str Annotations.for_non_ui_thread] + (annotation_of_str Annotations.ui_thread) + :: StandardAnnotationSpec.from_annotations + [annotation_of_str Annotations.ui_thread; annotation_of_str Annotations.for_ui_thread] + (annotation_of_str Annotations.for_non_ui_thread) + :: user_defined_specs + module TransferFunctions (CFG : ProcCfg.S) = struct module CFG = CFG @@ -362,26 +390,29 @@ module TransferFunctions (CFG : ProcCfg.S) = struct rarely to not affect the performances *) let is_unlikely pname = match pname with - | Typ.Procname.Java java_pname - -> String.equal (Typ.Procname.java_get_method java_pname) "unlikely" - | _ - -> false + | Typ.Procname.Java java_pname -> + String.equal (Typ.Procname.java_get_method java_pname) "unlikely" + | _ -> + false + let is_tracking_exp astate = function - | Exp.Var id - -> Domain.is_tracked_var (Var.of_id id) astate - | Exp.Lvar pvar - -> Domain.is_tracked_var (Var.of_pvar pvar) astate - | _ - -> false + | Exp.Var id -> + Domain.is_tracked_var (Var.of_id id) astate + | Exp.Lvar pvar -> + Domain.is_tracked_var (Var.of_pvar pvar) astate + | _ -> + false + let prunes_tracking_var astate = function - | Exp.BinOp (Binop.Eq, lhs, rhs) when is_tracking_exp astate lhs - -> Exp.equal rhs Exp.one - | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.Eq, lhs, rhs), _) when is_tracking_exp astate lhs - -> Exp.equal rhs Exp.zero - | _ - -> false + | Exp.BinOp (Binop.Eq, lhs, rhs) when is_tracking_exp astate lhs -> + Exp.equal rhs Exp.one + | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.Eq, lhs, rhs), _) when is_tracking_exp astate lhs -> + Exp.equal rhs Exp.zero + | _ -> + false + let check_call tenv callee_pname caller_pname call_site astate = List.fold ~init:astate @@ -392,12 +423,13 @@ module TransferFunctions (CFG : ProcCfg.S) = struct else astate) annot_specs + let merge_callee_map call_site pdesc callee_pname astate = match Summary.read_summary pdesc callee_pname with - | None - -> astate - | Some callee_call_map - -> let add_call_site annot sink calls astate = + | None -> + astate + | Some callee_call_map -> + let add_call_site annot sink calls astate = if AnnotReachabilityDomain.CallSites.is_empty calls then astate else Domain.add_call_site annot sink call_site astate in @@ -406,26 +438,28 @@ module TransferFunctions (CFG : ProcCfg.S) = struct AnnotReachabilityDomain.SinkMap.fold (add_call_site annot) sink_map astate) callee_call_map astate + let exec_instr astate {ProcData.pdesc; tenv} _ = function - | Sil.Call (Some (id, _), Const Cfun callee_pname, _, _, _) when is_unlikely callee_pname - -> Domain.add_tracking_var (Var.of_id id) astate - | Sil.Call (_, Const Cfun callee_pname, _, call_loc, _) - -> let caller_pname = Procdesc.get_proc_name pdesc in + | Sil.Call (Some (id, _), Const Cfun callee_pname, _, _, _) when is_unlikely callee_pname -> + Domain.add_tracking_var (Var.of_id id) astate + | Sil.Call (_, Const Cfun callee_pname, _, call_loc, _) -> + let caller_pname = Procdesc.get_proc_name pdesc in let call_site = CallSite.make callee_pname call_loc in check_call tenv callee_pname caller_pname call_site astate |> merge_callee_map call_site pdesc callee_pname - | Sil.Load (id, exp, _, _) when is_tracking_exp astate exp - -> Domain.add_tracking_var (Var.of_id id) astate - | Sil.Store (Exp.Lvar pvar, _, exp, _) when is_tracking_exp astate exp - -> Domain.add_tracking_var (Var.of_pvar pvar) astate - | Sil.Store (Exp.Lvar pvar, _, _, _) - -> Domain.remove_tracking_var (Var.of_pvar pvar) astate - | Sil.Prune (exp, _, _, _) when prunes_tracking_var astate exp - -> Domain.stop_tracking astate - | Sil.Call (None, _, _, _, _) - -> L.(die InternalError) "Expecting a return identifier" - | _ - -> astate + | Sil.Load (id, exp, _, _) when is_tracking_exp astate exp -> + Domain.add_tracking_var (Var.of_id id) astate + | Sil.Store (Exp.Lvar pvar, _, exp, _) when is_tracking_exp astate exp -> + Domain.add_tracking_var (Var.of_pvar pvar) astate + | Sil.Store (Exp.Lvar pvar, _, _, _) -> + Domain.remove_tracking_var (Var.of_pvar pvar) astate + | Sil.Prune (exp, _, _, _) when prunes_tracking_var astate exp -> + Domain.stop_tracking astate + | Sil.Call (None, _, _, _, _) -> + L.(die InternalError) "Expecting a return identifier" + | _ -> + astate + end module Analyzer = AbstractInterpreter.Make (ProcCfg.Exceptional) (TransferFunctions) @@ -434,8 +468,9 @@ let checker ({Callbacks.proc_desc; tenv; summary} as callback) : Specs.summary = let initial = (AnnotReachabilityDomain.empty, NonBottom Domain.TrackingVar.empty) in let proc_data = ProcData.make_default proc_desc tenv in match Analyzer.compute_post proc_data ~initial with - | Some (annot_map, _) - -> List.iter annot_specs ~f:(fun (spec: AnnotationSpec.t) -> spec.report callback annot_map) ; + | Some (annot_map, _) -> + List.iter annot_specs ~f:(fun (spec: AnnotationSpec.t) -> spec.report callback annot_map) ; Summary.update_summary annot_map summary - | None - -> summary + | None -> + summary + diff --git a/infer/src/checkers/annotations.ml b/infer/src/checkers/annotations.ml index da65cec47..c1ab1ce3e 100644 --- a/infer/src/checkers/annotations.ml +++ b/infer/src/checkers/annotations.ml @@ -114,18 +114,21 @@ let volatile = "volatile" let ia_has_annotation_with (ia: Annot.Item.t) (predicate: Annot.t -> bool) : bool = List.exists ~f:(fun (a, _) -> predicate a) ia + let ma_has_annotation_with ((ia, ial): Annot.Method.t) (predicate: Annot.t -> bool) : bool = let has_annot a = ia_has_annotation_with a predicate in has_annot ia || List.exists ~f:has_annot ial + (** [annot_ends_with annot ann_name] returns true if the class name of [annot], without the package, is equal to [ann_name] *) let annot_ends_with annot ann_name = match String.rsplit2 annot.Annot.class_name ~on:'.' with - | None - -> String.equal annot.Annot.class_name ann_name - | Some (_, annot_class_name) - -> String.equal annot_class_name ann_name + | None -> + String.equal annot.Annot.class_name ann_name + | Some (_, annot_class_name) -> + String.equal annot_class_name ann_name + let class_name_matches s ((annot: Annot.t), _) = String.equal s annot.class_name @@ -139,22 +142,26 @@ let pdesc_has_parameter_annot pdesc predicate = let _, param_annotations = (Procdesc.get_attributes pdesc).ProcAttributes.method_annotation in List.exists ~f:predicate param_annotations + let pdesc_get_return_annot pdesc = fst (Procdesc.get_attributes pdesc).ProcAttributes.method_annotation + let pdesc_has_return_annot pdesc predicate = predicate (pdesc_get_return_annot pdesc) let pdesc_return_annot_ends_with pdesc annot = pdesc_has_return_annot pdesc (fun ia -> ia_ends_with ia annot) + (* note: we would use Specs.proc_resolve_attributes directly instead of requiring [attrs_of_pname], but doing so creates a circular dependency *) let pname_has_return_annot pname ~attrs_of_pname predicate = match attrs_of_pname pname with - | Some attributes - -> predicate (fst attributes.ProcAttributes.method_annotation) - | None - -> false + | Some attributes -> + predicate (fst attributes.ProcAttributes.method_annotation) + | None -> + false + let field_has_annot fieldname (struct_typ: Typ.Struct.t) predicate = let fld_has_taint_annot (fname, _, annot) = @@ -163,6 +170,7 @@ let field_has_annot fieldname (struct_typ: Typ.Struct.t) predicate = List.exists ~f:fld_has_taint_annot struct_typ.fields || List.exists ~f:fld_has_taint_annot struct_typ.statics + let struct_typ_has_annot (struct_typ: Typ.Struct.t) predicate = predicate struct_typ.annots let ia_is_final ia = ia_contains ia final @@ -201,6 +209,7 @@ let field_injector_readwrite_list = ; bind_string ; suppress_view_nullability ] + let field_injector_readonly_list = inject :: field_injector_readwrite_list (** Annotations for readonly injectors. @@ -208,11 +217,13 @@ let field_injector_readonly_list = inject :: field_injector_readwrite_list let ia_is_field_injector_readonly ia = List.exists ~f:(ia_ends_with ia) field_injector_readonly_list + (** Annotations for read-write injectors. The injector framework initializes the field and can write null into it. *) let ia_is_field_injector_readwrite ia = List.exists ~f:(ia_ends_with ia) field_injector_readwrite_list + let ia_is_mutable ia = ia_ends_with ia mutable_ let ia_get_strict ia = ia_get ia strict diff --git a/infer/src/checkers/constantPropagation.ml b/infer/src/checkers/constantPropagation.ml index 9d6a053a1..0b5b95610 100644 --- a/infer/src/checkers/constantPropagation.ml +++ b/infer/src/checkers/constantPropagation.ml @@ -17,12 +17,13 @@ let verbose = false (* Merge two constant maps by adding keys as necessary *) let merge_values _ c1_opt c2_opt = match (c1_opt, c2_opt) with - | Some Some c1, Some Some c2 when Const.equal c1 c2 - -> Some (Some c1) - | Some c, None | None, Some c - -> Some c - | _ - -> Some None + | Some Some c1, Some Some c2 when Const.equal c1 c2 -> + Some (Some c1) + | Some c, None | None, Some c -> + Some c + | _ -> + Some None + module ConstantMap = Exp.Map @@ -35,12 +36,15 @@ module ConstantFlow = Dataflow.MakeDF (struct let pp fmt constants = let pp_key fmt = Exp.pp fmt in let print_kv k = function - | Some v - -> Format.fprintf fmt " %a -> %a@." pp_key k (Const.pp Pp.text) v - | _ - -> Format.fprintf fmt " %a -> None@." pp_key k + | Some v -> + Format.fprintf fmt " %a -> %a@." pp_key k (Const.pp Pp.text) v + | _ -> + Format.fprintf fmt " %a -> None@." pp_key k in - Format.fprintf fmt "[@." ; ConstantMap.iter print_kv constants ; Format.fprintf fmt "]@." + Format.fprintf fmt "[@." ; + ConstantMap.iter print_kv constants ; + Format.fprintf fmt "]@." + let join = ConstantMap.merge merge_values @@ -54,36 +58,36 @@ module ConstantFlow = Dataflow.MakeDF (struct in let has_class pn name = match pn with - | Typ.Procname.Java pn_java - -> String.equal (Typ.Procname.java_get_class_name pn_java) name - | _ - -> false + | Typ.Procname.Java pn_java -> + String.equal (Typ.Procname.java_get_class_name pn_java) name + | _ -> + false in let has_method pn name = match pn with - | Typ.Procname.Java pn_java - -> String.equal (Typ.Procname.java_get_method pn_java) name - | _ - -> false + | Typ.Procname.Java pn_java -> + String.equal (Typ.Procname.java_get_method pn_java) name + | _ -> + false in match instr with - | Sil.Load (i, Exp.Lvar p, _, _) - -> (* tmp = var *) + | Sil.Load (i, Exp.Lvar p, _, _) -> + (* tmp = var *) update (Exp.Var i) (ConstantMap.find (Exp.Lvar p) constants) constants - | Sil.Store (Exp.Lvar p, _, Exp.Const c, _) - -> (* var = const *) + | Sil.Store (Exp.Lvar p, _, Exp.Const c, _) -> + (* var = const *) update (Exp.Lvar p) (Some c) constants - | Sil.Store (Exp.Lvar p, _, Exp.Var i, _) - -> (* var = tmp *) + | Sil.Store (Exp.Lvar p, _, Exp.Var i, _) -> + (* var = tmp *) update (Exp.Lvar p) (ConstantMap.find (Exp.Var i) constants) constants (* Handle propagation of string with StringBuilder. Does not handle null case *) | Sil.Call (_, Exp.Const Const.Cfun pn, [(Exp.Var sb, _)], _, _) - when has_class pn "java.lang.StringBuilder" && has_method pn "" - -> (* StringBuilder. *) + when has_class pn "java.lang.StringBuilder" && has_method pn "" -> + (* StringBuilder. *) update (Exp.Var sb) (Some (Const.Cstr "")) constants | Sil.Call (Some (i, _), Exp.Const Const.Cfun pn, [(Exp.Var i1, _)], _, _) - when has_class pn "java.lang.StringBuilder" && has_method pn "toString" - -> (* StringBuilder.toString *) + when has_class pn "java.lang.StringBuilder" && has_method pn "toString" -> + (* StringBuilder.toString *) update (Exp.Var i) (ConstantMap.find (Exp.Var i1) constants) constants | Sil.Call (Some (i, _), Exp.Const Const.Cfun pn, [(Exp.Var i1, _); (Exp.Var i2, _)], _, _) when has_class pn "java.lang.StringBuilder" && has_method pn "append" -> ( @@ -91,16 +95,16 @@ module ConstantFlow = Dataflow.MakeDF (struct (* StringBuilder.append *) (ConstantMap.find (Exp.Var i1) constants, ConstantMap.find (Exp.Var i2) constants) with - | Some Const.Cstr s1, Some Const.Cstr s2 - -> let s = s1 ^ s2 in + | Some Const.Cstr s1, Some Const.Cstr s2 -> + let s = s1 ^ s2 in let u = if String.length s < string_widening_limit then Some (Const.Cstr s) else None in update (Exp.Var i) u constants - | _ - -> constants ) - | _ - -> constants + | _ -> + constants ) + | _ -> + constants with Not_found -> constants in if verbose then ( @@ -112,24 +116,26 @@ module ConstantFlow = Dataflow.MakeDF (struct let constants = List.fold ~f:do_instr ~init:constants (Procdesc.Node.get_instrs node) in if verbose then L.(debug Analysis Verbose) "%a@\n@." pp constants ; ([constants], [constants]) + end) let run tenv proc_desc = let transitions = ConstantFlow.run tenv proc_desc ConstantMap.empty in let get_constants node = match transitions node with - | ConstantFlow.Transition (_, post_states, _) - -> ConstantFlow.join post_states ConstantMap.empty - | ConstantFlow.Dead_state - -> ConstantMap.empty + | ConstantFlow.Transition (_, post_states, _) -> + ConstantFlow.join post_states ConstantMap.empty + | ConstantFlow.Dead_state -> + ConstantMap.empty in get_constants + type const_map = Procdesc.Node.t -> Exp.t -> Const.t option (** Build a const map lazily. *) let build_const_map tenv pdesc = - let const_map = (lazy (run tenv pdesc)) in + let const_map = lazy (run tenv pdesc) in let f node exp = try let map = Lazy.force const_map node in @@ -137,3 +143,4 @@ let build_const_map tenv pdesc = with Not_found -> None in f + diff --git a/infer/src/checkers/dataflow.ml b/infer/src/checkers/dataflow.ml index 342d878e7..be7540eea 100644 --- a/infer/src/checkers/dataflow.ml +++ b/infer/src/checkers/dataflow.ml @@ -54,30 +54,31 @@ let node_throws pdesc node (proc_throws: Typ.Procname.t -> throws) : throws = Pvar.equal pvar ret_pvar in match instr with - | Sil.Store (Exp.Lvar pvar, _, Exp.Exn _, _) when is_return pvar - -> (* assignment to return variable is an artifact of a throw instruction *) + | Sil.Store (Exp.Lvar pvar, _, Exp.Exn _, _) when is_return pvar -> + (* assignment to return variable is an artifact of a throw instruction *) Throws - | Sil.Call (_, Exp.Const Const.Cfun callee_pn, _, _, _) when BuiltinDecl.is_declared callee_pn - -> if Typ.Procname.equal callee_pn BuiltinDecl.__cast then DontKnow else DoesNotThrow - | Sil.Call (_, Exp.Const Const.Cfun callee_pn, _, _, _) - -> proc_throws callee_pn - | _ - -> DoesNotThrow + | Sil.Call (_, Exp.Const Const.Cfun callee_pn, _, _, _) when BuiltinDecl.is_declared callee_pn -> + if Typ.Procname.equal callee_pn BuiltinDecl.__cast then DontKnow else DoesNotThrow + | Sil.Call (_, Exp.Const Const.Cfun callee_pn, _, _, _) -> + proc_throws callee_pn + | _ -> + DoesNotThrow in let res = ref DoesNotThrow in let update_res throws = match (!res, throws) with - | DontKnow, DontKnow - -> res := DontKnow - | Throws, _ | _, Throws - -> res := Throws - | DoesNotThrow, t | t, DoesNotThrow - -> res := t + | DontKnow, DontKnow -> + res := DontKnow + | Throws, _ | _, Throws -> + res := Throws + | DoesNotThrow, t | t, DoesNotThrow -> + res := t in let do_instr instr = update_res (instr_throws instr) in List.iter ~f:do_instr (Procdesc.Node.get_instrs node) ; !res + (** Create an instance of the dataflow algorithm given a state parameter. *) module MakeDF (St : DFStateType) : DF with type state = St.t = struct module S = Procdesc.NodeSet @@ -124,6 +125,7 @@ module MakeDF (St : DFStateType) : DF with type state = St.t = struct H.replace t.post_states node states_succ ; H.replace t.exn_states node states_exn + (** Run the worklist-based dataflow algorithm. *) let run tenv proc_desc state = let t = @@ -155,6 +157,7 @@ module MakeDF (St : DFStateType) : DF with type state = St.t = struct with Not_found -> Dead_state in transitions + end (* MakeDF *) @@ -174,6 +177,7 @@ let callback_test_dataflow {Callbacks.proc_desc; tenv; summary} = L.(debug Analysis Verbose) "visiting node %a with state %d@." Procdesc.Node.pp n s ; ([s + 1], [s + 1]) + let proc_throws _ = DoesNotThrow end) in let transitions = DFCount.run tenv proc_desc 0 in @@ -182,3 +186,4 @@ let callback_test_dataflow {Callbacks.proc_desc; tenv; summary} = in List.iter ~f:do_node (Procdesc.get_nodes proc_desc) ; summary + diff --git a/infer/src/checkers/fragmentRetainsViewChecker.ml b/infer/src/checkers/fragmentRetainsViewChecker.ml index 61ecb5492..97cb52072 100644 --- a/infer/src/checkers/fragmentRetainsViewChecker.ml +++ b/infer/src/checkers/fragmentRetainsViewChecker.ml @@ -21,6 +21,7 @@ let report_error fragment_typ fld fld_typ summary pdesc = let loc = Procdesc.get_loc pdesc in Reporting.log_error summary ~loc exn + let callback_fragment_retains_view_java pname_java {Callbacks.proc_desc; summary; tenv} = (* TODO: complain if onDestroyView is not defined, yet the Fragment has View fields *) (* TODO: handle fields nullified in callees in the same file *) @@ -29,10 +30,10 @@ let callback_fragment_retains_view_java pname_java {Callbacks.proc_desc; summary in let fld_typ_is_view typ = match typ.Typ.desc with - | Typ.Tptr ({desc= Tstruct tname}, _) - -> AndroidFramework.is_view tenv tname - | _ - -> false + | Typ.Tptr ({desc= Tstruct tname}, _) -> + AndroidFramework.is_view tenv tname + | _ -> + false in (* is [fldname] a View type declared by [class_typename]? *) let is_declared_view_typ class_typename (fldname, fld_typ, _) = @@ -42,8 +43,8 @@ let callback_fragment_retains_view_java pname_java {Callbacks.proc_desc; summary if is_on_destroy_view then let class_typename = Typ.Name.Java.from_string (Typ.Procname.java_get_class_name pname_java) in match Tenv.lookup tenv class_typename with - | Some {fields} when AndroidFramework.is_fragment tenv class_typename - -> let declared_view_fields = List.filter ~f:(is_declared_view_typ class_typename) fields in + | Some {fields} when AndroidFramework.is_fragment tenv class_typename -> + let declared_view_fields = List.filter ~f:(is_declared_view_typ class_typename) fields in let fields_nullified = PatternMatch.get_fields_nullified proc_desc in (* report if a field is declared by C, but not nulled out in C.onDestroyView *) List.iter @@ -51,14 +52,16 @@ let callback_fragment_retains_view_java pname_java {Callbacks.proc_desc; summary if not (Typ.Fieldname.Set.mem fname fields_nullified) then report_error (Typ.mk (Tstruct class_typename)) fname fld_typ summary proc_desc) declared_view_fields - | _ - -> () + | _ -> + () + let callback_fragment_retains_view ({Callbacks.summary} as args) : Specs.summary = let proc_name = Specs.get_proc_name summary in ( match proc_name with - | Typ.Procname.Java pname_java - -> callback_fragment_retains_view_java pname_java args - | _ - -> () ) ; + | Typ.Procname.Java pname_java -> + callback_fragment_retains_view_java pname_java args + | _ -> + () ) ; summary + diff --git a/infer/src/checkers/idenv.ml b/infer/src/checkers/idenv.ml index 014e1d0ad..7e1146b5e 100644 --- a/infer/src/checkers/idenv.ml +++ b/infer/src/checkers/idenv.ml @@ -17,33 +17,40 @@ type t = Exp.t Ident.IdentHash.t Lazy.t let create_ proc_desc = let map = Ident.IdentHash.create 1 in let do_instr _ = function Sil.Load (id, e, _, _) -> Ident.IdentHash.add map id e | _ -> () in - Procdesc.iter_instrs do_instr proc_desc ; map + Procdesc.iter_instrs do_instr proc_desc ; + map + (* lazy implementation, only create when used *) let create proc_desc = - let map = (lazy (create_ proc_desc)) in + let map = lazy (create_ proc_desc) in map + let lookup map_ id = let map = Lazy.force map_ in try Some (Ident.IdentHash.find map id) with Not_found -> None + let expand_expr idenv e = match e with Exp.Var id -> ( match lookup idenv id with Some e' -> e' | None -> e ) | _ -> e + let expand_expr_temps idenv node _exp = let exp = expand_expr idenv _exp in match exp with | Exp.Lvar pvar when Pvar.is_frontend_tmp pvar -> ( match Errdesc.find_program_variable_assignment node pvar with - | None - -> exp - | Some (_, id) - -> expand_expr idenv (Exp.Var id) ) - | _ - -> exp + | None -> + exp + | Some (_, id) -> + expand_expr idenv (Exp.Var id) ) + | _ -> + exp + (** Return true if the expression is a temporary variable introduced by the front-end. *) let exp_is_temp idenv e = match expand_expr idenv e with Exp.Lvar pvar -> Pvar.is_frontend_tmp pvar | _ -> false + diff --git a/infer/src/checkers/immutableChecker.ml b/infer/src/checkers/immutableChecker.ml index 519e63ae5..bcd6e5433 100644 --- a/infer/src/checkers/immutableChecker.ml +++ b/infer/src/checkers/immutableChecker.ml @@ -15,7 +15,7 @@ module F = Format let check_immutable_cast tenv curr_pname curr_pdesc typ_expected typ_found_opt loc : unit = match typ_found_opt with | Some typ_found - -> ( + -> ( let casts = [ ("java.util.List", "com.google.common.collect.ImmutableList") ; ("java.util.Map", "com.google.common.collect.ImmutableMap") @@ -30,20 +30,22 @@ let check_immutable_cast tenv curr_pname curr_pdesc typ_expected typ_found_opt l match (PatternMatch.type_get_class_name typ_expected, PatternMatch.type_get_class_name typ_found) with - | Some name_expected, Some name_given - -> if in_casts name_expected name_given then + | Some name_expected, Some name_given -> + if in_casts name_expected name_given then let description = Format.asprintf "Method %s returns %a but the return type is %a. Make sure that users of this method do not try to modify the collection." - (Typ.Procname.to_simplified_string curr_pname) Typ.Name.pp name_given Typ.Name.pp - name_expected + (Typ.Procname.to_simplified_string curr_pname) + Typ.Name.pp name_given Typ.Name.pp name_expected in Checkers.ST.report_error tenv curr_pname curr_pdesc IssueType.checkers_immutable_cast loc description - | _ - -> () ) - | None - -> () + | _ -> + () ) + | None -> + () + let callback_check_immutable_cast ({Callbacks.tenv} as args) = Eradicate.callback_check_return_type (check_immutable_cast tenv) args + diff --git a/infer/src/checkers/liveness.ml b/infer/src/checkers/liveness.ml index b8914e03f..c184108cf 100644 --- a/infer/src/checkers/liveness.ml +++ b/infer/src/checkers/liveness.ml @@ -33,27 +33,29 @@ module TransferFunctions (CFG : ProcCfg.S) = struct ~f:(fun astate_acc pvar -> Domain.add (Var.of_pvar pvar) astate_acc) ~init:astate' pvars + let exec_instr astate _ _ = function - | Sil.Load (lhs_id, rhs_exp, _, _) - -> Domain.remove (Var.of_id lhs_id) astate |> exp_add_live rhs_exp - | Sil.Store (Lvar lhs_pvar, _, rhs_exp, _) - -> let astate' = + | Sil.Load (lhs_id, rhs_exp, _, _) -> + Domain.remove (Var.of_id lhs_id) astate |> exp_add_live rhs_exp + | Sil.Store (Lvar lhs_pvar, _, rhs_exp, _) -> + let astate' = if Pvar.is_global lhs_pvar then astate (* never kill globals *) else Domain.remove (Var.of_pvar lhs_pvar) astate in exp_add_live rhs_exp astate' - | Sil.Store (lhs_exp, _, rhs_exp, _) - -> exp_add_live lhs_exp astate |> exp_add_live rhs_exp - | Sil.Prune (exp, _, _, _) - -> exp_add_live exp astate - | Sil.Call (ret_id, call_exp, params, _, _) - -> Option.value_map + | Sil.Store (lhs_exp, _, rhs_exp, _) -> + exp_add_live lhs_exp astate |> exp_add_live rhs_exp + | Sil.Prune (exp, _, _, _) -> + exp_add_live exp astate + | Sil.Call (ret_id, call_exp, params, _, _) -> + Option.value_map ~f:(fun (ret_id, _) -> Domain.remove (Var.of_id ret_id) astate) ~default:astate ret_id |> exp_add_live call_exp |> fun x -> List.fold_right ~f:exp_add_live (List.map ~f:fst params) ~init:x - | Sil.Declare_locals _ | Remove_temps _ | Abstract _ | Nullify _ - -> astate + | Sil.Declare_locals _ | Remove_temps _ | Abstract _ | Nullify _ -> + astate + end module CFG = ProcCfg.OneInstrPerNode (ProcCfg.Backward (ProcCfg.Exceptional)) @@ -81,26 +83,27 @@ let checker {Callbacks.tenv; summary; proc_desc} : Specs.summary = | Sil.Store (Lvar pvar, _, _, loc) when not ( Pvar.is_frontend_tmp pvar || Pvar.is_return pvar || Pvar.is_global pvar - || Domain.mem (Var.of_pvar pvar) live_vars || is_captured_var pvar ) - -> let issue_id = IssueType.dead_store.unique_id in + || Domain.mem (Var.of_pvar pvar) live_vars || is_captured_var pvar ) -> + let issue_id = IssueType.dead_store.unique_id in let message = F.asprintf "The value written to %a is never used" (Pvar.pp Pp.text) pvar in let ltr = [Errlog.make_trace_element 0 loc "Write of unused value" []] in let exn = Exceptions.Checkers (issue_id, Localise.verbatim_desc message) in Reporting.log_error summary ~loc ~ltr exn - | _ - -> () + | _ -> + () in let report_on_node node = List.iter (CFG.instr_ids node) ~f:(fun (instr, node_id_opt) -> match node_id_opt with | Some node_id -> ( match Analyzer.extract_pre node_id invariant_map with - | Some live_vars - -> report_dead_store live_vars instr - | None - -> () ) - | None - -> () ) + | Some live_vars -> + report_dead_store live_vars instr + | None -> + () ) + | None -> + () ) in List.iter (CFG.nodes cfg) ~f:report_on_node ; summary + diff --git a/infer/src/checkers/printfArgs.ml b/infer/src/checkers/printfArgs.ml index f3c902282..37093fe7f 100644 --- a/infer/src/checkers/printfArgs.ml +++ b/infer/src/checkers/printfArgs.ml @@ -36,51 +36,55 @@ let printf_like_functions = ; fixed_pos= [] ; vararg_pos= Some 3 } ] + let printf_like_function (proc_name: Typ.Procname.t) : printf_signature option = List.find ~f:(fun printf -> String.equal printf.unique_id (Typ.Procname.to_unique_id proc_name)) !printf_like_functions + let default_format_type_name (format_type: string) : string = match format_type with - | "d" | "i" | "u" | "x" | "X" | "o" - -> "java.lang.Integer" - | "a" | "A" | "f" | "F" | "g" | "G" | "e" | "E" - -> "java.lang.Double" - | "c" - -> "java.lang.Character" - | "b" - -> "java.lang.Boolean" - | "s" - -> "java.lang.String" - | "h" | "H" - -> "java.lang.Object" - | _ - -> "unknown" + | "d" | "i" | "u" | "x" | "X" | "o" -> + "java.lang.Integer" + | "a" | "A" | "f" | "F" | "g" | "G" | "e" | "E" -> + "java.lang.Double" + | "c" -> + "java.lang.Character" + | "b" -> + "java.lang.Boolean" + | "s" -> + "java.lang.String" + | "h" | "H" -> + "java.lang.Object" + | _ -> + "unknown" + let format_type_matches_given_type (format_type: string) (given_type: string) : bool = match format_type with - | "d" | "i" | "u" | "x" | "X" | "o" - -> List.mem ~equal:String.equal + | "d" | "i" | "u" | "x" | "X" | "o" -> + List.mem ~equal:String.equal ["java.lang.Integer"; "java.lang.Long"; "java.lang.Short"; "java.lang.Byte"] given_type - | "a" | "A" | "f" | "F" | "g" | "G" | "e" | "E" - -> List.mem ~equal:String.equal ["java.lang.Double"; "java.lang.Float"] given_type - | "c" - -> String.equal given_type "java.lang.Character" - | "b" | "h" | "H" | "s" - -> true (* accepts pretty much anything, even null *) - | _ - -> false + | "a" | "A" | "f" | "F" | "g" | "G" | "e" | "E" -> + List.mem ~equal:String.equal ["java.lang.Double"; "java.lang.Float"] given_type + | "c" -> + String.equal given_type "java.lang.Character" + | "b" | "h" | "H" | "s" -> + true (* accepts pretty much anything, even null *) + | _ -> + false + (* The format string and the nvar for the fixed arguments and the nvar of the varargs array *) let format_arguments (printf: printf_signature) (args: (Exp.t * Typ.t) list) : string option * Exp.t list * Exp.t option = let format_string = match List.nth_exn args printf.format_pos with - | Exp.Const Const.Cstr fmt, _ - -> Some fmt - | _ - -> None + | Exp.Const Const.Cstr fmt, _ -> + Some fmt + | _ -> + None in let fixed_nvars = List.map ~f:(fun i -> fst (List.nth_exn args i)) printf.fixed_pos in let varargs_nvar = @@ -88,6 +92,7 @@ let format_arguments (printf: printf_signature) (args: (Exp.t * Typ.t) list) in (format_string, fixed_nvars, varargs_nvar) + (* Extract type names from format string *) let rec format_string_type_names (fmt_string: string) (start: int) : string list = try @@ -99,6 +104,7 @@ let rec format_string_type_names (fmt_string: string) (start: int) : string list fmt_type :: format_string_type_names fmt_string (Str.match_end ()) with Not_found -> [] + let check_printf_args_ok tenv (node: Procdesc.Node.t) (instr: Sil.instr) (proc_name: Typ.Procname.t) (proc_desc: Procdesc.t) summary : unit = (* Check if format string lines up with arguments *) @@ -106,8 +112,8 @@ let check_printf_args_ok tenv (node: Procdesc.Node.t) (instr: Sil.instr) let instr_name = Typ.Procname.to_simplified_string instr_proc_name in let instr_line = Location.to_string instr_loc in match (fmt_type_names, arg_type_names) with - | ft :: fs, gt :: gs - -> if not (format_type_matches_given_type ft gt) then + | ft :: fs, gt :: gs -> + if not (format_type_matches_given_type ft gt) then let description = Printf.sprintf "%s at line %s: parameter %d is expected to be of type %s but %s was given." @@ -116,10 +122,10 @@ let check_printf_args_ok tenv (node: Procdesc.Node.t) (instr: Sil.instr) let exn = Exceptions.Checkers (description, Localise.verbatim_desc description) in Reporting.log_error summary ~loc:instr_loc exn else check_type_names instr_loc (n_arg + 1) instr_proc_name fs gs - | [], [] - -> () - | _ - -> let description = + | [], [] -> + () + | _ -> + let description = Printf.sprintf "format string arguments don't mach provided arguments in %s at line %s" instr_name instr_line in @@ -129,27 +135,27 @@ let check_printf_args_ok tenv (node: Procdesc.Node.t) (instr: Sil.instr) (* Get the array ivar for a given nvar *) let rec array_ivar instrs nvar = match (instrs, nvar) with - | (Sil.Load (id, Exp.Lvar iv, _, _)) :: _, Exp.Var nid when Ident.equal id nid - -> iv - | _ :: is, _ - -> array_ivar is nvar - | _ - -> raise Not_found + | (Sil.Load (id, Exp.Lvar iv, _, _)) :: _, Exp.Var nid when Ident.equal id nid -> + iv + | _ :: is, _ -> + array_ivar is nvar + | _ -> + raise Not_found in let rec fixed_nvar_type_name instrs nvar = match nvar with | Exp.Var nid -> ( match instrs with - | (Sil.Load (id, Exp.Lvar _, t, _)) :: _ when Ident.equal id nid - -> PatternMatch.get_type_name t - | _ :: is - -> fixed_nvar_type_name is nvar - | _ - -> raise Not_found ) - | Exp.Const c - -> PatternMatch.java_get_const_type_name c - | _ - -> L.(die InternalError) "Could not resolve fixed type name" + | (Sil.Load (id, Exp.Lvar _, t, _)) :: _ when Ident.equal id nid -> + PatternMatch.get_type_name t + | _ :: is -> + fixed_nvar_type_name is nvar + | _ -> + raise Not_found ) + | Exp.Const c -> + PatternMatch.java_get_const_type_name c + | _ -> + L.(die InternalError) "Could not resolve fixed type name" in match instr with | Sil.Call (_, Exp.Const Const.Cfun pn, args, cl, _) -> ( @@ -161,27 +167,29 @@ let check_printf_args_ok tenv (node: Procdesc.Node.t) (instr: Sil.instr) let fixed_nvar_type_names = List.map ~f:(fixed_nvar_type_name instrs) fixed_nvars in let vararg_ivar_type_names = match array_nvar with - | Some nvar - -> let ivar = array_ivar instrs nvar in + | Some nvar -> + let ivar = array_ivar instrs nvar in PatternMatch.get_vararg_type_names tenv node ivar - | None - -> [] + | None -> + [] in match fmt with - | Some fmt - -> check_type_names cl (printf.format_pos + 1) pn (format_string_type_names fmt 0) + | Some fmt -> + check_type_names cl (printf.format_pos + 1) pn (format_string_type_names fmt 0) (fixed_nvar_type_names @ vararg_ivar_type_names) - | None - -> Checkers.ST.report_error tenv proc_name proc_desc IssueType.checkers_printf_args cl + | None -> + Checkers.ST.report_error tenv proc_name proc_desc IssueType.checkers_printf_args cl "Format string must be string literal" with e -> L.internal_error "%s Exception when analyzing %s: %s@." - IssueType.checkers_printf_args.unique_id (Typ.Procname.to_string proc_name) + IssueType.checkers_printf_args.unique_id + (Typ.Procname.to_string proc_name) (Exn.to_string e) ) - | None - -> () ) - | _ - -> () + | None -> + () ) + | _ -> + () + let callback_printf_args {Callbacks.tenv; proc_desc; summary} : Specs.summary = let proc_name = Procdesc.get_proc_name proc_desc in @@ -189,3 +197,4 @@ let callback_printf_args {Callbacks.tenv; proc_desc; summary} : Specs.summary = (fun n i -> check_printf_args_ok tenv n i proc_name proc_desc summary) proc_desc ; summary + diff --git a/infer/src/checkers/registerCheckers.ml b/infer/src/checkers/registerCheckers.ml index 0013e0a71..20dddd164 100644 --- a/infer/src/checkers/registerCheckers.ml +++ b/infer/src/checkers/registerCheckers.ml @@ -82,12 +82,12 @@ let all_checkers = ; { name= "repeated calls" ; active= Config.repeated_calls ; callbacks= [(Procedure RepeatedCallsChecker.callback_check_repeated_calls, Config.Java)] } - ; { name= - "resource leak" - (** toy resource analysis to use in the infer lab, see the lab/ directory *) + (* toy resource analysis to use in the infer lab, see the lab/ directory *) + ; { name= "resource leak" ; active= Config.resource_leak ; callbacks= - [ ( (* the checked-in version is intraprocedural, but the lab asks to make it interprocedural later on *) + [ ( (* the checked-in version is intraprocedural, but the lab asks to make it + interprocedural later on *) Procedure ResourceLeaks.checker , Config.Java ) ] } ; {name= "SIOF"; active= Config.siof; callbacks= [(Procedure Siof.checker, Config.Clang)]} @@ -95,25 +95,28 @@ let all_checkers = ; active= Config.uninit ; callbacks= [(Procedure Uninit.checker, Config.Clang)] } ] + let get_active_checkers () = let filter_checker {active} = active in List.filter ~f:filter_checker all_checkers + let register checkers = let register_one {callbacks} = let register_callback (callback, language) = match callback with - | Procedure procedure_cb - -> Callbacks.register_procedure_callback language procedure_cb - | DynamicDispatch procedure_cb - -> Callbacks.register_procedure_callback ~dynamic_dispath:true language procedure_cb - | Cluster cluster_cb - -> Callbacks.register_cluster_callback language cluster_cb + | Procedure procedure_cb -> + Callbacks.register_procedure_callback language procedure_cb + | DynamicDispatch procedure_cb -> + Callbacks.register_procedure_callback ~dynamic_dispath:true language procedure_cb + | Cluster cluster_cb -> + Callbacks.register_cluster_callback language cluster_cb in List.iter ~f:register_callback callbacks in List.iter ~f:register_one checkers + module LanguageSet = Caml.Set.Make (struct type t = Config.language @@ -129,3 +132,4 @@ let pp_checker fmt {name; callbacks} = F.fprintf fmt "%s (%a)" name (Pp.seq ~sep:", " (Pp.to_string ~f:Config.string_of_language)) langs_of_callbacks + diff --git a/infer/src/checkers/repeatedCallsChecker.ml b/infer/src/checkers/repeatedCallsChecker.ml index c2b241efd..2f0ce0579 100644 --- a/infer/src/checkers/repeatedCallsChecker.ml +++ b/infer/src/checkers/repeatedCallsChecker.ml @@ -18,11 +18,12 @@ module RepeatedCallsExtension : Eradicate.ExtensionT = struct let compare i1 i2 = match (i1, i2) with - | Sil.Call (_, e1, etl1, _, cf1), Sil.Call (_, e2, etl2, _, cf2) - -> (* ignore return ids and call flags *) + | Sil.Call (_, e1, etl1, _, cf1), Sil.Call (_, e2, etl2, _, cf2) -> + (* ignore return ids and call flags *) [%compare : Exp.t * (Exp.t * Typ.t) list * CallFlags.t] (e1, etl1, cf1) (e2, etl2, cf2) - | _ - -> Sil.compare_instr i1 i2 + | _ -> + Sil.compare_instr i1 i2 + end) type extension = InstrSet.t @@ -35,10 +36,12 @@ module RepeatedCallsExtension : Eradicate.ExtensionT = struct let pp_call instr = F.fprintf fmt " %a@\n" (Sil.pp_instr Pp.text) instr in if not (InstrSet.is_empty calls) then ( F.fprintf fmt "Calls:@\n" ; InstrSet.iter pp_call calls ) + let get_old_call instr calls = try Some (InstrSet.find instr calls) with Not_found -> None + let add_call instr calls = if InstrSet.mem instr calls then calls else InstrSet.add instr calls type paths = @@ -59,10 +62,10 @@ module RepeatedCallsExtension : Eradicate.ExtensionT = struct in let do_instr instr = match instr with - | Sil.Call (_, Exp.Const Const.Cfun pn, _, loc, _) when proc_is_new pn - -> found := Some loc - | _ - -> () + | Sil.Call (_, Exp.Const Const.Cfun pn, _, loc, _) when proc_is_new pn -> + found := Some loc + | _ -> + () in List.iter ~f:do_instr (Procdesc.Node.get_instrs node) ; !found @@ -75,12 +78,13 @@ module RepeatedCallsExtension : Eradicate.ExtensionT = struct let join_ paths_ l1o l2o = (* join with left priority *) match (l1o, l2o) with - | None, None - -> None - | Some loc, None | None, Some loc - -> if equal_paths paths_ AllPaths then None else Some loc - | Some loc1, Some _ - -> Some loc1 + | None, None -> + None + | Some loc, None | None, Some loc -> + if equal_paths paths_ AllPaths then None else Some loc + | Some loc1, Some _ -> + Some loc1 + (* left priority *) let join = join_ paths @@ -93,14 +97,16 @@ module RepeatedCallsExtension : Eradicate.ExtensionT = struct in ([lo'], [lo']) + let proc_throws _ = Dataflow.DontKnow end) in let transitions = DFAllocCheck.run tenv pdesc None in match transitions (Procdesc.get_exit_node pdesc) with - | DFAllocCheck.Transition (loc, _, _) - -> loc - | DFAllocCheck.Dead_state - -> None + | DFAllocCheck.Transition (loc, _, _) -> + loc + | DFAllocCheck.Dead_state -> + None + (** Check repeated calls to the same procedure. *) let check_instr tenv get_proc_desc curr_pname curr_pdesc extension instr normalized_etl = @@ -108,49 +114,51 @@ module RepeatedCallsExtension : Eradicate.ExtensionT = struct let arguments_not_temp args = let filter_arg (e, _) = match e with - | Exp.Lvar pvar - -> (* same temporary variable does not imply same value *) + | Exp.Lvar pvar -> + (* same temporary variable does not imply same value *) not (Pvar.is_frontend_tmp pvar) - | _ - -> true + | _ -> + true in List.for_all ~f:filter_arg args in match instr with | Sil.Call ((Some _ as ret_id), Exp.Const Const.Cfun callee_pname, _, loc, call_flags) - when arguments_not_temp normalized_etl - -> let instr_normalized_args = + when arguments_not_temp normalized_etl -> + let instr_normalized_args = Sil.Call (ret_id, Exp.Const (Const.Cfun callee_pname), normalized_etl, loc, call_flags) in let report proc_desc = match get_old_call instr_normalized_args extension with | Some Sil.Call (_, _, _, loc_old, _) -> ( match proc_performs_allocation tenv proc_desc AllPaths with - | Some alloc_loc - -> let description = + | Some alloc_loc -> + let description = Format.asprintf "call to %s seen before on line %d (may allocate at %a:%d)" - (Typ.Procname.to_simplified_string callee_pname) loc_old.Location.line - SourceFile.pp alloc_loc.Location.file alloc_loc.Location.line + (Typ.Procname.to_simplified_string callee_pname) + loc_old.Location.line SourceFile.pp alloc_loc.Location.file + alloc_loc.Location.line in Checkers.ST.report_error tenv curr_pname curr_pdesc IssueType.checkers_repeated_calls loc description - | None - -> () ) - | _ - -> () + | None -> + () ) + | _ -> + () in let () = match get_proc_desc callee_pname with - | None - -> () - | Some proc_desc - -> if Procdesc.is_defined proc_desc then report proc_desc + | None -> + () + | Some proc_desc -> + if Procdesc.is_defined proc_desc then report proc_desc in add_call instr_normalized_args extension - | _ - -> extension + | _ -> + extension - let ext = {TypeState.empty= empty; check_instr; join; pp} + + let ext = {TypeState.empty; check_instr; join; pp} let update_payload _ payload = payload end @@ -164,3 +172,4 @@ let callback_check_repeated_calls callback_args = {TypeCheck.eradicate= false; check_extension= Config.repeated_calls; check_ret_type= []} in MainRepeatedCalls.callback checks callback_args + diff --git a/infer/src/checkers/uninit.ml b/infer/src/checkers/uninit.ml index f2500e644..57bab634a 100644 --- a/infer/src/checkers/uninit.ml +++ b/infer/src/checkers/uninit.ml @@ -25,6 +25,7 @@ module Summary = Summary.Make (struct let update_payload sum (summary: Specs.summary) = {summary with payload= {summary.payload with uninit= Some sum}} + let read_payload (summary: Specs.summary) = summary.payload.uninit end) @@ -38,8 +39,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let exec_instr (astate: Domain.astate) {ProcData.extras} _ (instr: HilInstr.t) = match instr with - | Assign (((lhs_var, _), _), HilExp.AccessPath ((rhs_var, rhs_typ as rhs_base), _), _) - -> let uninit_vars = D.remove lhs_var astate.uninit_vars in + | Assign (((lhs_var, _), _), HilExp.AccessPath (((rhs_var, rhs_typ) as rhs_base), _), _) -> + let uninit_vars = D.remove lhs_var astate.uninit_vars in let prepost = if FormalMap.is_formal rhs_base extras && match rhs_typ.desc with Typ.Tptr _ -> true | _ -> false @@ -50,25 +51,26 @@ module TransferFunctions (CFG : ProcCfg.S) = struct else astate.prepost in {astate with uninit_vars; prepost} - | Assign (((lhs_var, _), _), _, _) - -> let uninit_vars = D.remove lhs_var astate.uninit_vars in + | Assign (((lhs_var, _), _), _, _) -> + let uninit_vars = D.remove lhs_var astate.uninit_vars in {astate with uninit_vars} - | Call (_, _, actuals, _, _) - -> (* in case of intraprocedural only analysis we assume that parameters passed by reference + | Call (_, _, actuals, _, _) -> + (* in case of intraprocedural only analysis we assume that parameters passed by reference to a function will be initialized inside that function *) let uninit_vars = List.fold ~f:(fun acc actual_exp -> match actual_exp with - | HilExp.AccessPath ((actual_var, {Typ.desc= Tptr _}), _) - -> D.remove actual_var acc - | _ - -> acc) + | HilExp.AccessPath ((actual_var, {Typ.desc= Tptr _}), _) -> + D.remove actual_var acc + | _ -> + acc) ~init:astate.uninit_vars actuals in {astate with uninit_vars} - | Assume _ - -> astate + | Assume _ -> + astate + end module CFG = ProcCfg.OneInstrPerNode (ProcCfg.Normal) @@ -101,19 +103,19 @@ let checker {Callbacks.tenv; summary; proc_desc} : Specs.summary = in let zip_actual_formal_params callee_pname actual_params = match Ondemand.get_proc_desc callee_pname with - | Some pdesc - -> let formals, _ = List.unzip (Procdesc.get_formals pdesc) in + | Some pdesc -> + let formals, _ = List.unzip (Procdesc.get_formals pdesc) in let actual, _ = List.unzip actual_params in (List.zip actual formals, actual) - | _ - -> (None, []) + | _ -> + (None, []) in let deref_actual_params callee_pname actual_params deref_formal_params = match zip_actual_formal_params callee_pname actual_params with - | None, _ - -> [] - | Some assoc_actual_formal, _ - -> List.fold + | None, _ -> + [] + | Some assoc_actual_formal, _ -> + List.fold ~f:(fun acc (a, f) -> let fe = Exp.Lvar (Pvar.mk f callee_pname) in if exp_in_set fe deref_formal_params then a :: acc else acc) @@ -129,16 +131,16 @@ let checker {Callbacks.tenv; summary; proc_desc} : Specs.summary = match instr with | Sil.Load (_, Exp.Lvar pv, _, loc) | Sil.Store (_, _, Exp.Lvar pv, loc) - when exp_in_set (Exp.Lvar pv) uninit_vars - -> let message = + when exp_in_set (Exp.Lvar pv) uninit_vars -> + let message = F.asprintf "The value read from %a was never initialized" Exp.pp (Exp.Lvar pv) in report message loc | Sil.Call (_, Exp.Const Const.Cfun callee_pname, actual_params, loc, _) when not intraprocedural_only -> ( match Summary.read_summary proc_desc callee_pname with - | Some {pre= deref_formal_params; post= _} - -> let deref_actual_params = + | Some {pre= deref_formal_params; post= _} -> + let deref_actual_params = deref_actual_params callee_pname actual_params deref_formal_params in List.iter @@ -150,10 +152,10 @@ let checker {Callbacks.tenv; summary; proc_desc} : Specs.summary = in report message loc) actual_params - | _ - -> () ) - | _ - -> () + | _ -> + () ) + | _ -> + () in let report_on_node node = List.iter (CFG.instr_ids node) ~f:(fun (instr, node_id_opt) -> @@ -164,22 +166,23 @@ let checker {Callbacks.tenv; summary; proc_desc} : Specs.summary = ( { RecordDomain.uninit_vars= uninitialized_vars ; RecordDomain.aliased_vars= _ ; RecordDomain.prepost= _ } - , _ ) - -> report_uninit_value uninitialized_vars instr - | None - -> () ) - | None - -> () ) + , _ ) -> + report_uninit_value uninitialized_vars instr + | None -> + () ) + | None -> + () ) in List.iter (CFG.nodes cfg) ~f:report_on_node ; match Analyzer.extract_post (CFG.id (CFG.exit_node cfg)) invariant_map with | Some ( {RecordDomain.uninit_vars= _; RecordDomain.aliased_vars= _; RecordDomain.prepost= pre, post} - , _ ) - -> Summary.update_summary {pre; post} summary - | None - -> if Procdesc.Node.get_succs (Procdesc.get_start_node proc_desc) <> [] then ( + , _ ) -> + Summary.update_summary {pre; post} summary + | None -> + if Procdesc.Node.get_succs (Procdesc.get_start_node proc_desc) <> [] then ( L.internal_error "Uninit analyzer failed to compute post for %a" Typ.Procname.pp (Procdesc.get_proc_name proc_desc) ; summary ) else summary + diff --git a/infer/src/checkers/uninitDomain.ml b/infer/src/checkers/uninitDomain.ml index 746a6978d..afb9bb731 100644 --- a/infer/src/checkers/uninitDomain.ml +++ b/infer/src/checkers/uninitDomain.ml @@ -25,6 +25,7 @@ end let pp_summary fmt {pre; post} = F.fprintf fmt "@\n Pre: %a @\nPost: %a @\n" Domain.pp pre Domain.pp post + module Record (Domain1 : AbstractDomain.S) (Domain2 : AbstractDomain.S) @@ -42,6 +43,7 @@ struct && Domain3.( <= ) ~lhs:(fst lhs_pp) ~rhs:(fst rhs_pp) && Domain3.( <= ) ~lhs:(snd lhs_pp) ~rhs:(snd rhs_pp) + let join ({uninit_vars= uv1; aliased_vars= av1; prepost= pp1} as astate1) ({uninit_vars= uv2; aliased_vars= av2; prepost= pp2} as astate2) = if phys_equal astate1 astate2 then astate1 @@ -50,6 +52,7 @@ struct ; aliased_vars= Domain2.join av1 av2 ; prepost= (Domain3.join (fst pp1) (fst pp2), Domain3.join (snd pp1) (snd pp2)) } + let widen ~prev:({uninit_vars= prev_uv; aliased_vars= prev_av; prepost= prev_pp} as prev) ~next:({uninit_vars= next_uv; aliased_vars= next_av; prepost= next_pp} as next) ~num_iters = if phys_equal prev next then prev @@ -60,7 +63,9 @@ struct ( Domain3.widen ~prev:(fst prev_pp) ~next:(fst next_pp) ~num_iters , Domain3.widen ~prev:(snd prev_pp) ~next:(snd next_pp) ~num_iters ) } + let pp fmt {uninit_vars= uv; aliased_vars= av; prepost= pp} = F.fprintf fmt "@\n uninit_vars: %a @\n aliased_vars: %a @\n prepost: (%a, %a)" Domain1.pp uv Domain2.pp av Domain3.pp (fst pp) Domain3.pp (snd pp) + end diff --git a/infer/src/clang/ALVar.ml b/infer/src/clang/ALVar.ml index 682ff681a..6526b0a14 100644 --- a/infer/src/clang/ALVar.ml +++ b/infer/src/clang/ALVar.ml @@ -29,30 +29,30 @@ type t = alexp [@@deriving compare] let equal = [%compare.equal : t] -let formula_id_to_string fid = - match fid - with Formula_id s -> s +let formula_id_to_string fid = match fid with Formula_id s -> s let alexp_to_string = function - | Const string | Regexp {string} | Var string | FId Formula_id string - -> string + | Const string | Regexp {string} | Var string | FId Formula_id string -> + string + let keyword_to_string k = match k with - | Doc_url - -> "doc_url" - | Message - -> "message" - | Mode - -> "mode" - | Name - -> "name_hum_readable" - | Report_when - -> "report_when" - | Severity - -> "severity" - | Suggestion - -> "suggestion" + | Doc_url -> + "doc_url" + | Message -> + "message" + | Mode -> + "mode" + | Name -> + "name_hum_readable" + | Report_when -> + "report_when" + | Severity -> + "severity" + | Suggestion -> + "suggestion" + let is_report_when_keyword k = match k with Report_when -> true | _ -> false @@ -73,18 +73,20 @@ let str_match_forward container regexp = try Str.search_forward regexp container 0 >= 0 with Not_found -> false + let compare_str_with_alexp s ae = match ae with - | Const s' | Var s' - -> String.equal s s' - | Regexp {regexp} - -> str_match_forward s (Lazy.force regexp) - | _ - -> L.(debug Linters Medium) + | Const s' | Var s' -> + String.equal s s' + | Regexp {regexp} -> + str_match_forward s (Lazy.force regexp) + | _ -> + L.(debug Linters Medium) "[WARNING]: ALVAR expression '%s' is not a constant, variable, or regexp@\n" (alexp_to_string ae) ; false + module FormulaIdMap = Caml.Map.Make (struct type t = formula_id [@@deriving compare] end) diff --git a/infer/src/clang/CLintersContext.ml b/infer/src/clang/CLintersContext.ml index 9e2408bf1..f0db5c16a 100644 --- a/infer/src/clang/CLintersContext.ml +++ b/infer/src/clang/CLintersContext.ml @@ -39,10 +39,13 @@ let empty translation_unit_context = ; if_context= None ; in_for_loop_declaration= false } + let add_parent_method decl_opt parent_methods = match decl_opt with Some decl -> decl :: parent_methods | None -> parent_methods + let update_current_method context decl = { context with current_method= Some decl ; parent_methods= add_parent_method context.current_method context.parent_methods } + diff --git a/infer/src/clang/CProcname.ml b/infer/src/clang/CProcname.ml index 586c8c5f5..a70f452f5 100644 --- a/infer/src/clang/CProcname.ml +++ b/infer/src/clang/CProcname.ml @@ -16,100 +16,104 @@ let rec get_mangled_method_name function_decl_info method_decl_info = work. *) let open Clang_ast_t in match method_decl_info.xmdi_overriden_methods with - | [] - -> function_decl_info.fdi_mangled_name - | base1_dr :: _ - -> let base1 = + | [] -> + function_decl_info.fdi_mangled_name + | base1_dr :: _ -> + let base1 = match CAst_utils.get_decl base1_dr.dr_decl_pointer with Some b -> b | _ -> assert false in match base1 with | CXXMethodDecl (_, _, _, fdi, mdi) | CXXConstructorDecl (_, _, _, fdi, mdi) | CXXConversionDecl (_, _, _, fdi, mdi) - | CXXDestructorDecl (_, _, _, fdi, mdi) - -> get_mangled_method_name fdi mdi - | _ - -> assert false + | CXXDestructorDecl (_, _, _, fdi, mdi) -> + get_mangled_method_name fdi mdi + | _ -> + assert false + let get_template_info tenv (fdi: Clang_ast_t.function_decl_info) = match fdi.fdi_template_specialization with - | Some spec_info - -> Typ.Template + | Some spec_info -> + Typ.Template {mangled= fdi.fdi_mangled_name; args= CType_decl.get_template_args tenv spec_info} - | None - -> Typ.NoTemplate + | None -> + Typ.NoTemplate + let is_decl_info_generic_model {Clang_ast_t.di_attributes} = let f = function | Clang_ast_t.AnnotateAttr {ai_parameters= [_; name; _]} - when String.equal name "__infer_generic_model" - -> true - | _ - -> false + when String.equal name "__infer_generic_model" -> + true + | _ -> + false in List.exists ~f di_attributes + let mk_c_function translation_unit_context ?tenv name function_decl_info_opt = let file = match function_decl_info_opt with | Some (decl_info, function_decl_info) -> ( match function_decl_info.Clang_ast_t.fdi_storage_class with - | Some "static" - -> let file_opt = + | Some "static" -> + let file_opt = (fst decl_info.Clang_ast_t.di_source_range).Clang_ast_t.sl_file |> Option.map ~f:SourceFile.from_abs_path in let file_to_hex src = SourceFile.to_string src |> Utils.string_crc_hex32 in Option.value_map ~f:file_to_hex ~default:"" file_opt - | _ - -> "" ) - | None - -> "" + | _ -> + "" ) + | None -> + "" in let mangled_opt = match function_decl_info_opt with - | Some (_, function_decl_info) - -> function_decl_info.Clang_ast_t.fdi_mangled_name - | _ - -> None + | Some (_, function_decl_info) -> + function_decl_info.Clang_ast_t.fdi_mangled_name + | _ -> + None in let mangled_name = match mangled_opt with - | Some m when CGeneral_utils.is_cpp_translation translation_unit_context - -> m - | _ - -> "" + | Some m when CGeneral_utils.is_cpp_translation translation_unit_context -> + m + | _ -> + "" in let template_info, is_generic_model = match (function_decl_info_opt, tenv) with - | Some (decl_info, function_decl_info), Some t - -> (get_template_info t function_decl_info, is_decl_info_generic_model decl_info) - | _ - -> (Typ.NoTemplate, false) + | Some (decl_info, function_decl_info), Some t -> + (get_template_info t function_decl_info, is_decl_info_generic_model decl_info) + | _ -> + (Typ.NoTemplate, false) in let mangled = file ^ mangled_name in if String.is_empty mangled then Typ.Procname.from_string_c_fun (QualifiedCppName.to_qual_string name) else Typ.Procname.C (Typ.Procname.c name mangled template_info ~is_generic_model) + let mk_cpp_method ?tenv class_name method_name ?meth_decl mangled = let open Clang_ast_t in let method_kind = match meth_decl with - | Some Clang_ast_t.CXXConstructorDecl (_, _, _, _, {xmdi_is_constexpr}) - -> Typ.Procname.CPPConstructor (mangled, xmdi_is_constexpr) - | Some Clang_ast_t.CXXDestructorDecl _ - -> Typ.Procname.CPPDestructor mangled - | _ - -> Typ.Procname.CPPMethod mangled + | Some Clang_ast_t.CXXConstructorDecl (_, _, _, _, {xmdi_is_constexpr}) -> + Typ.Procname.CPPConstructor (mangled, xmdi_is_constexpr) + | Some Clang_ast_t.CXXDestructorDecl _ -> + Typ.Procname.CPPDestructor mangled + | _ -> + Typ.Procname.CPPMethod mangled in let template_info, is_generic_model = match meth_decl with | Some CXXMethodDecl (di, _, _, fdi, _) | Some CXXConstructorDecl (di, _, _, fdi, _) | Some CXXConversionDecl (di, _, _, fdi, _) - | Some CXXDestructorDecl (di, _, _, fdi, _) - -> let templ_info = + | Some CXXDestructorDecl (di, _, _, fdi, _) -> + let templ_info = match tenv with Some t -> get_template_info t fdi | None -> Typ.NoTemplate in let is_gen_model = @@ -120,21 +124,24 @@ let mk_cpp_method ?tenv class_name method_name ?meth_decl mangled = |> Option.value_map ~f:is_decl_info_generic_model ~default:false in (templ_info, is_gen_model) - | _ - -> (Typ.NoTemplate, false) + | _ -> + (Typ.NoTemplate, false) in Typ.Procname.ObjC_Cpp (Typ.Procname.objc_cpp class_name method_name method_kind template_info ~is_generic_model) + let mk_objc_method class_typename method_name method_kind = Typ.Procname.ObjC_Cpp (Typ.Procname.objc_cpp class_typename method_name method_kind Typ.NoTemplate ~is_generic_model:false) + let block_procname_with_index defining_proc i = Config.anonymous_block_prefix ^ Typ.Procname.to_string defining_proc ^ Config.anonymous_block_num_sep ^ string_of_int i + (* Global counter for anonymous block*) let block_counter = ref 0 @@ -142,34 +149,41 @@ let get_next_block_pvar defining_proc = let name = block_procname_with_index defining_proc (!block_counter + 1) in Pvar.mk_tmp name defining_proc + let reset_block_counter () = block_counter := 0 let get_fresh_block_index () = block_counter := !block_counter + 1 ; !block_counter + let mk_fresh_block_procname defining_proc = let name = block_procname_with_index defining_proc (get_fresh_block_index ()) in Typ.Procname.mangled_objc_block name + let get_class_typename ?tenv method_decl_info = let class_ptr = Option.value_exn method_decl_info.Clang_ast_t.di_parent_pointer in match CAst_utils.get_decl class_ptr with - | Some class_decl - -> CType_decl.get_record_typename ?tenv class_decl - | None - -> assert false + | Some class_decl -> + CType_decl.get_record_typename ?tenv class_decl + | None -> + assert false + module NoAstDecl = struct let c_function_of_string translation_unit_context tenv name = let qual_name = QualifiedCppName.of_qual_string name in mk_c_function translation_unit_context ~tenv qual_name None + let cpp_method_of_string tenv class_name method_name = mk_cpp_method ~tenv class_name method_name None + let objc_method_of_string_kind class_name method_name method_kind = mk_objc_method class_name method_name method_kind + end let objc_method_procname ?tenv decl_info method_name mdi = @@ -178,44 +192,47 @@ let objc_method_procname ?tenv decl_info method_name mdi = let method_kind = Typ.Procname.objc_method_kind_of_bool is_instance in mk_objc_method class_typename method_name method_kind + let from_decl translation_unit_context ?tenv meth_decl = let open Clang_ast_t in match meth_decl with - | FunctionDecl (decl_info, name_info, _, fdi) - -> let name = CAst_utils.get_qualified_name name_info in + | FunctionDecl (decl_info, name_info, _, fdi) -> + let name = CAst_utils.get_qualified_name name_info in let function_info = Some (decl_info, fdi) in mk_c_function translation_unit_context ?tenv name function_info | CXXMethodDecl (decl_info, name_info, _, fdi, mdi) | CXXConstructorDecl (decl_info, name_info, _, fdi, mdi) | CXXConversionDecl (decl_info, name_info, _, fdi, mdi) - | CXXDestructorDecl (decl_info, name_info, _, fdi, mdi) - -> let mangled = get_mangled_method_name fdi mdi in + | CXXDestructorDecl (decl_info, name_info, _, fdi, mdi) -> + let mangled = get_mangled_method_name fdi mdi in let method_name = CAst_utils.get_unqualified_name name_info in let class_typename = get_class_typename ?tenv decl_info in mk_cpp_method ?tenv class_typename method_name ~meth_decl mangled - | ObjCMethodDecl (decl_info, name_info, mdi) - -> objc_method_procname ?tenv decl_info name_info.Clang_ast_t.ni_name mdi - | BlockDecl _ - -> let name = + | ObjCMethodDecl (decl_info, name_info, mdi) -> + objc_method_procname ?tenv decl_info name_info.Clang_ast_t.ni_name mdi + | BlockDecl _ -> + let name = Config.anonymous_block_prefix ^ Config.anonymous_block_num_sep ^ string_of_int (get_fresh_block_index ()) in Typ.Procname.mangled_objc_block name - | _ - -> Logging.die InternalError "Expected method decl, but got %s." + | _ -> + Logging.die InternalError "Expected method decl, but got %s." (Clang_ast_proj.get_decl_kind_string meth_decl) + let from_decl_for_linters translation_unit_context method_decl = let open Clang_ast_t in match method_decl with - | ObjCMethodDecl (decl_info, name_info, mdi) - -> let method_name = + | ObjCMethodDecl (decl_info, name_info, mdi) -> + let method_name = match String.split ~on:':' name_info.Clang_ast_t.ni_name with - | hd :: _ - -> hd - | _ - -> name_info.Clang_ast_t.ni_name + | hd :: _ -> + hd + | _ -> + name_info.Clang_ast_t.ni_name in objc_method_procname decl_info method_name mdi - | _ - -> from_decl translation_unit_context method_decl + | _ -> + from_decl translation_unit_context method_decl + diff --git a/infer/src/clang/CTLExceptions.ml b/infer/src/clang/CTLExceptions.ml index ee7ddf239..81138df5a 100644 --- a/infer/src/clang/CTLExceptions.ml +++ b/infer/src/clang/CTLExceptions.ml @@ -16,20 +16,24 @@ exception ALFileException of exc_info let hum_string_of_exc_info exc_info = Format.sprintf "%s at %s:%d" exc_info.description exc_info.filename exc_info.line + let create_exc_info description lexbuf = let pos = lexbuf.Lexing.lex_curr_p in {description; filename= pos.pos_fname; line= pos.pos_lnum} + let json_of_exc_info exc_info = `Assoc [ ("description", `String exc_info.description) ; ("filename", `String exc_info.filename) ; ("line", `Int exc_info.line) ] + let () = Caml.Printexc.register_printer (fun exc -> match exc with - | ALFileException exc_info - -> Some (Format.sprintf "ALFileException: %s" (hum_string_of_exc_info exc_info)) - | _ - -> None ) + | ALFileException exc_info -> + Some (Format.sprintf "ALFileException: %s" (hum_string_of_exc_info exc_info)) + | _ -> + None ) + diff --git a/infer/src/clang/CTLExceptions.mli b/infer/src/clang/CTLExceptions.mli index b19138b23..aeb012528 100644 --- a/infer/src/clang/CTLExceptions.mli +++ b/infer/src/clang/CTLExceptions.mli @@ -7,15 +7,13 @@ * of patent rights can be found in the PATENTS file in the same directory. *) -exception - ALParserInvariantViolationException of - string(** Raised when the parser encounters a violation of a certain invariant *) +exception ALParserInvariantViolationException of string + (** Raised when the parser encounters a violation of a certain invariant *) type exc_info -exception - ALFileException of - exc_info(** Raised when any exception from the lexer/parser of AL is caught, to include source-location info *) +exception ALFileException of exc_info + (** Raised when any exception from the lexer/parser of AL is caught, to include source-location info *) val create_exc_info : string -> Lexing.lexbuf -> exc_info diff --git a/infer/src/clang/CTLParserHelper.ml b/infer/src/clang/CTLParserHelper.ml index 7a790c726..315904a33 100644 --- a/infer/src/clang/CTLParserHelper.ml +++ b/infer/src/clang/CTLParserHelper.ml @@ -14,15 +14,16 @@ open Lexing let parse_al_file fname channel = let parse_with_error lexbuf = try Some (Ctl_parser.al_file token lexbuf) with - | CTLExceptions.ALParserInvariantViolationException s - -> raise CTLExceptions.(ALFileException (create_exc_info s lexbuf)) - | SyntaxError _ | Ctl_parser.Error - -> raise CTLExceptions.(ALFileException (create_exc_info "SYNTAX ERROR" lexbuf)) + | CTLExceptions.ALParserInvariantViolationException s -> + raise CTLExceptions.(ALFileException (create_exc_info s lexbuf)) + | SyntaxError _ | Ctl_parser.Error -> + raise CTLExceptions.(ALFileException (create_exc_info "SYNTAX ERROR" lexbuf)) in let lexbuf = Lexing.from_channel channel in lexbuf.lex_curr_p <- {lexbuf.lex_curr_p with pos_fname= fname} ; parse_with_error lexbuf + let validate_al_files () = let validate_al_file fname = try @@ -31,7 +32,8 @@ let validate_al_files () = with CTLExceptions.ALFileException exc_info -> Some (CTLExceptions.json_of_exc_info exc_info) in match List.filter_map ~f:validate_al_file Config.linters_def_file with - | [] - -> Ok () - | _ as errors - -> Error (Yojson.Basic.to_string (`List errors)) + | [] -> + Ok () + | _ as errors -> + Error (Yojson.Basic.to_string (`List errors)) + diff --git a/infer/src/clang/CType.ml b/infer/src/clang/CType.ml index 605384e62..c6e72af77 100644 --- a/infer/src/clang/CType.ml +++ b/infer/src/clang/CType.ml @@ -18,69 +18,76 @@ let add_pointer_to_typ typ = Typ.mk (Tptr (typ, Typ.Pk_pointer)) let remove_pointer_to_typ typ = match typ.Typ.desc with Typ.Tptr (typ, Typ.Pk_pointer) -> typ | _ -> typ + let objc_classname_of_type typ = match typ.Typ.desc with - | Typ.Tstruct name - -> name - | Typ.Tfun _ - -> Typ.Name.Objc.from_string CFrontend_config.objc_object - | _ - -> L.(debug Capture Verbose) + | Typ.Tstruct name -> + name + | Typ.Tfun _ -> + Typ.Name.Objc.from_string CFrontend_config.objc_object + | _ -> + L.(debug Capture Verbose) "Classname of type cannot be extracted in type %s" (Typ.to_string typ) ; Typ.Name.Objc.from_string "undefined" + let is_class typ = match typ.Typ.desc with - | Typ.Tptr ({desc= Tstruct name}, _) - -> String.equal (Typ.Name.name name) CFrontend_config.objc_class - | _ - -> false + | Typ.Tptr ({desc= Tstruct name}, _) -> + String.equal (Typ.Name.name name) CFrontend_config.objc_class + | _ -> + false + let rec return_type_of_function_qual_type (qual_type: Clang_ast_t.qual_type) = let open Clang_ast_t in match CAst_utils.get_type qual_type.qt_type_ptr with | Some FunctionProtoType (_, function_type_info, _) - | Some FunctionNoProtoType (_, function_type_info) - -> function_type_info.Clang_ast_t.fti_return_type - | Some BlockPointerType (_, in_qual) - -> return_type_of_function_qual_type in_qual - | Some _ - -> L.(debug Capture Verbose) + | Some FunctionNoProtoType (_, function_type_info) -> + function_type_info.Clang_ast_t.fti_return_type + | Some BlockPointerType (_, in_qual) -> + return_type_of_function_qual_type in_qual + | Some _ -> + L.(debug Capture Verbose) "Warning: Type pointer %s is not a function type." (Clang_ast_extend.type_ptr_to_string qual_type.qt_type_ptr) ; {qual_type with qt_type_ptr= Clang_ast_extend.ErrorType} - | None - -> L.(debug Capture Verbose) + | None -> + L.(debug Capture Verbose) "Warning: Type pointer %s not found." (Clang_ast_extend.type_ptr_to_string qual_type.qt_type_ptr) ; {qual_type with qt_type_ptr= Clang_ast_extend.ErrorType} + let return_type_of_function_type qual_type = return_type_of_function_qual_type qual_type let is_block_type {Clang_ast_t.qt_type_ptr} = let open Clang_ast_t in match CAst_utils.get_desugared_type qt_type_ptr with - | Some BlockPointerType _ - -> true - | _ - -> false + | Some BlockPointerType _ -> + true + | _ -> + false + let is_reference_type {Clang_ast_t.qt_type_ptr} = match CAst_utils.get_desugared_type qt_type_ptr with - | Some Clang_ast_t.LValueReferenceType _ - -> true - | Some Clang_ast_t.RValueReferenceType _ - -> true - | _ - -> false + | Some Clang_ast_t.LValueReferenceType _ -> + true + | Some Clang_ast_t.RValueReferenceType _ -> + true + | _ -> + false + (* To be called with strings of format "*" *) let get_name_from_type_pointer custom_type_pointer = match Str.split (Str.regexp "*") custom_type_pointer with - | [pointer_type_info; class_name] - -> (pointer_type_info, class_name) - | _ - -> assert false + | [pointer_type_info; class_name] -> + (pointer_type_info, class_name) + | _ -> + assert false + (* let rec get_type_list nn ll = diff --git a/infer/src/clang/CType_decl.ml b/infer/src/clang/CType_decl.ml index a3a6f97ad..2f23ec545 100644 --- a/infer/src/clang/CType_decl.ml +++ b/infer/src/clang/CType_decl.ml @@ -17,44 +17,49 @@ let add_predefined_objc_types tenv = ignore (Tenv.mk_struct tenv (CType_to_sil_type.get_builtin_objc_typename `ObjCClass)) ; ignore (Tenv.mk_struct tenv (CType_to_sil_type.get_builtin_objc_typename `ObjCId)) + let add_predefined_types tenv = add_predefined_objc_types tenv let create_c_record_typename (tag_kind: Clang_ast_t.tag_kind) = match tag_kind with - | `TTK_Struct | `TTK_Interface | `TTK_Enum - -> Typ.Name.C.from_qual_name - | `TTK_Union - -> Typ.Name.C.union_from_qual_name - | `TTK_Class - -> Typ.Name.Cpp.from_qual_name Typ.NoTemplate + | `TTK_Struct | `TTK_Interface | `TTK_Enum -> + Typ.Name.C.from_qual_name + | `TTK_Union -> + Typ.Name.C.union_from_qual_name + | `TTK_Class -> + Typ.Name.Cpp.from_qual_name Typ.NoTemplate + let get_class_template_name = function - | Clang_ast_t.ClassTemplateDecl (_, name_info, _) - -> CAst_utils.get_qualified_name name_info - | _ - -> assert false + | Clang_ast_t.ClassTemplateDecl (_, name_info, _) -> + CAst_utils.get_qualified_name name_info + | _ -> + assert false + let get_superclass_decls decl = let open Clang_ast_t in match decl with | CXXRecordDecl (_, _, _, _, _, _, _, cxx_rec_info) - | ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, cxx_rec_info, _, _) - -> (* there is no concept of virtual inheritance in the backend right now *) + | ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, cxx_rec_info, _, _) -> + (* there is no concept of virtual inheritance in the backend right now *) let base_ptr = cxx_rec_info.Clang_ast_t.xrdi_bases @ cxx_rec_info.Clang_ast_t.xrdi_vbases in let get_decl_or_fail typ_ptr = match CAst_utils.get_decl_from_typ_ptr typ_ptr with - | Some decl - -> decl - | None - -> assert false + | Some decl -> + decl + | None -> + assert false in List.map ~f:get_decl_or_fail base_ptr - | _ - -> [] + | _ -> + [] + let translate_as_type_ptr_matcher = QualifiedCppName.Match.of_fuzzy_qual_names ["infer_traits::TranslateAsType"] + let get_translate_as_friend_decl decl_list = let is_translate_as_friend_name (_, name_info) = let qual_name = CAst_utils.get_qualified_name name_info in @@ -62,28 +67,29 @@ let get_translate_as_friend_decl decl_list = in let get_friend_decl_opt (decl: Clang_ast_t.decl) = match decl with - | FriendDecl (_, `Type type_ptr) - -> CAst_utils.get_decl_from_typ_ptr type_ptr - | _ - -> None + | FriendDecl (_, `Type type_ptr) -> + CAst_utils.get_decl_from_typ_ptr type_ptr + | _ -> + None in let is_translate_as_friend_decl decl = match get_friend_decl_opt decl with - | Some decl - -> let named_decl_tuple_opt = Clang_ast_proj.get_named_decl_tuple decl in + | Some decl -> + let named_decl_tuple_opt = Clang_ast_proj.get_named_decl_tuple decl in Option.value_map ~f:is_translate_as_friend_name ~default:false named_decl_tuple_opt - | None - -> false + | None -> + false in match get_friend_decl_opt (List.find_exn ~f:is_translate_as_friend_decl decl_list) with | Some Clang_ast_t.ClassTemplateSpecializationDecl - (_, _, _, _, _, _, _, _, _, {tsi_specialization_args= [(`Type t_ptr)]}) - -> Some t_ptr - | _ - -> None - | exception Not_found - -> None + (_, _, _, _, _, _, _, _, _, {tsi_specialization_args= [(`Type t_ptr)]}) -> + Some t_ptr + | _ -> + None + | exception Not_found -> + None + let get_record_definition decl = let open Clang_ast_t in @@ -92,10 +98,11 @@ let get_record_definition decl = (_, _, _, _, _, _, {rdi_is_complete_definition; rdi_definition_ptr}, _, _, _) | CXXRecordDecl (_, _, _, _, _, _, {rdi_is_complete_definition; rdi_definition_ptr}, _) | RecordDecl (_, _, _, _, _, _, {rdi_is_complete_definition; rdi_definition_ptr}) - when not rdi_is_complete_definition && rdi_definition_ptr <> 0 - -> CAst_utils.get_decl rdi_definition_ptr |> Option.value ~default:decl - | _ - -> decl + when not rdi_is_complete_definition && rdi_definition_ptr <> 0 -> + CAst_utils.get_decl rdi_definition_ptr |> Option.value ~default:decl + | _ -> + decl + let rec get_struct_fields tenv decl = let open Clang_ast_t in @@ -103,65 +110,70 @@ let rec get_struct_fields tenv decl = match decl with | ClassTemplateSpecializationDecl (_, _, _, decl_list, _, _, _, _, _, _) | CXXRecordDecl (_, _, _, decl_list, _, _, _, _) - | RecordDecl (_, _, _, decl_list, _, _, _) - -> decl_list - | _ - -> [] + | RecordDecl (_, _, _, decl_list, _, _, _) -> + decl_list + | _ -> + [] in let class_tname = get_record_typename ~tenv decl in let do_one_decl decl = match decl with - | FieldDecl (_, {ni_name}, qt, _) - -> let id = CGeneral_utils.mk_class_field_name class_tname ni_name in + | FieldDecl (_, {ni_name}, qt, _) -> + let id = CGeneral_utils.mk_class_field_name class_tname ni_name in let typ = qual_type_to_sil_type tenv qt in let annotation_items = CAst_utils.sil_annot_of_type qt in [(id, typ, annotation_items)] - | _ - -> [] + | _ -> + [] in let base_decls = get_superclass_decls decl in let base_class_fields = List.map ~f:(get_struct_fields tenv) base_decls in List.concat (base_class_fields @ List.map ~f:do_one_decl decl_list) + (* For a record declaration it returns/constructs the type *) and get_record_declaration_type tenv decl = let definition_decl = get_record_definition decl in match get_record_custom_type tenv definition_decl with - | Some t - -> t.Typ.desc - | None - -> get_record_struct_type tenv definition_decl + | Some t -> + t.Typ.desc + | None -> + get_record_struct_type tenv definition_decl + and get_record_custom_type tenv definition_decl = let result = get_record_friend_decl_type tenv definition_decl in let result = if Option.is_none result then get_record_as_typevar definition_decl else result in result + and get_record_friend_decl_type tenv definition_decl = let open Clang_ast_t in match definition_decl with | ClassTemplateSpecializationDecl (_, _, _, decl_list, _, _, _, _, _, _) - | CXXRecordDecl (_, _, _, decl_list, _, _, _, _) - -> Option.map ~f:(qual_type_to_sil_type tenv) (get_translate_as_friend_decl decl_list) - | _ - -> None + | CXXRecordDecl (_, _, _, decl_list, _, _, _, _) -> + Option.map ~f:(qual_type_to_sil_type tenv) (get_translate_as_friend_decl decl_list) + | _ -> + None + and get_record_as_typevar (definition_decl: Clang_ast_t.decl) = let open Clang_ast_t in match definition_decl with - | CXXRecordDecl (decl_info, name_info, _, _, _, _, _, _) - -> let is_infer_typevar = function - | AnnotateAttr {ai_parameters= [_; name; _]} when String.equal name "__infer_type_var" - -> true - | _ - -> false + | CXXRecordDecl (decl_info, name_info, _, _, _, _, _, _) -> + let is_infer_typevar = function + | AnnotateAttr {ai_parameters= [_; name; _]} when String.equal name "__infer_type_var" -> + true + | _ -> + false in if List.exists ~f:is_infer_typevar decl_info.di_attributes then let tname = CAst_utils.get_qualified_name name_info |> QualifiedCppName.to_qual_string in Some (Typ.mk (TVar tname)) else None - | _ - -> None + | _ -> + None + (* We need to take the name out of the type as the struct can be anonymous If tenv is not passed, then template instantiaion information may be incorrect, @@ -170,38 +182,39 @@ and get_record_typename ?tenv decl = let open Clang_ast_t in let linters_mode = match tenv with Some _ -> false | None -> true in match (decl, tenv) with - | RecordDecl (_, name_info, _, _, _, tag_kind, _), _ - -> CAst_utils.get_qualified_name ~linters_mode name_info |> create_c_record_typename tag_kind - | ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, _, mangling, spec_info), Some tenv - -> let tname = + | RecordDecl (_, name_info, _, _, _, tag_kind, _), _ -> + CAst_utils.get_qualified_name ~linters_mode name_info |> create_c_record_typename tag_kind + | ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, _, mangling, spec_info), Some tenv -> + let tname = match CAst_utils.get_decl spec_info.tsi_template_decl with - | Some dec - -> get_class_template_name dec - | None - -> assert false + | Some dec -> + get_class_template_name dec + | None -> + assert false in let args = get_template_args tenv spec_info in let mangled = if String.equal "" mangling then None else Some mangling in Typ.Name.Cpp.from_qual_name (Typ.Template {mangled; args}) tname | CXXRecordDecl (_, name_info, _, _, _, _, _, _), _ - | ClassTemplateSpecializationDecl (_, name_info, _, _, _, _, _, _, _, _), _ - -> (* we use Typ.CppClass for C++ because we expect Typ.CppClass from *) + | ClassTemplateSpecializationDecl (_, name_info, _, _, _, _, _, _, _, _), _ -> + (* we use Typ.CppClass for C++ because we expect Typ.CppClass from *) (* types that have methods. And in C++ struct/class/union can have methods *) Typ.Name.Cpp.from_qual_name Typ.NoTemplate (CAst_utils.get_qualified_name ~linters_mode name_info) | ObjCInterfaceDecl (_, name_info, _, _, _), _ | ObjCImplementationDecl (_, name_info, _, _, _), _ - | ObjCProtocolDecl (_, name_info, _, _, _), _ - -> CAst_utils.get_qualified_name name_info |> Typ.Name.Objc.from_qual_name + | ObjCProtocolDecl (_, name_info, _, _, _), _ -> + CAst_utils.get_qualified_name name_info |> Typ.Name.Objc.from_qual_name | ObjCCategoryDecl (_, _, _, _, {odi_class_interface= Some {dr_name}}), _ | ObjCCategoryImplDecl (_, _, _, _, {ocidi_class_interface= Some {dr_name}}), _ -> ( match dr_name with - | Some name_info - -> CAst_utils.get_qualified_name name_info |> Typ.Name.Objc.from_qual_name - | None - -> assert false ) - | _ - -> assert false + | Some name_info -> + CAst_utils.get_qualified_name name_info |> Typ.Name.Objc.from_qual_name + | None -> + assert false ) + | _ -> + assert false + (** fetches list of superclasses for C++ classes *) and get_superclass_list_cpp tenv decl = @@ -209,20 +222,21 @@ and get_superclass_list_cpp tenv decl = let get_super_field super_decl = get_record_typename ~tenv super_decl in List.map ~f:get_super_field base_decls + and get_record_struct_type tenv definition_decl : Typ.desc = let open Clang_ast_t in match definition_decl with | ClassTemplateSpecializationDecl (_, _, type_ptr, _, _, _, record_decl_info, _, _, _) | CXXRecordDecl (_, _, type_ptr, _, _, _, record_decl_info, _) | RecordDecl (_, _, type_ptr, _, _, _, record_decl_info) - -> ( + -> ( let sil_typename = get_record_typename ~tenv definition_decl in let sil_desc = Typ.Tstruct sil_typename in match Tenv.lookup tenv sil_typename with - | Some _ - -> sil_desc (* just reuse what is already in tenv *) - | None - -> let is_translatable_definition = + | Some _ -> + sil_desc (* just reuse what is already in tenv *) + | None -> + let is_translatable_definition = let open Clang_ast_t in record_decl_info.rdi_is_complete_definition && not record_decl_info.rdi_is_dependent_type @@ -254,66 +268,73 @@ and get_record_struct_type tenv definition_decl : Typ.desc = ignore (Tenv.mk_struct tenv ~fields:extra_fields sil_typename) ; CAst_utils.update_sil_types_map type_ptr sil_desc ; sil_desc ) ) - | _ - -> assert false + | _ -> + assert false + and add_types_from_decl_to_tenv tenv decl = let open Clang_ast_t in match decl with - | ClassTemplateSpecializationDecl _ | CXXRecordDecl _ | RecordDecl _ - -> get_record_declaration_type tenv decl - | ObjCInterfaceDecl _ - -> ObjcInterface_decl.interface_declaration qual_type_to_sil_type tenv decl - | ObjCImplementationDecl _ - -> ObjcInterface_decl.interface_impl_declaration qual_type_to_sil_type tenv decl - | ObjCProtocolDecl _ - -> ObjcProtocol_decl.protocol_decl qual_type_to_sil_type tenv decl - | ObjCCategoryDecl _ - -> ObjcCategory_decl.category_decl qual_type_to_sil_type tenv decl - | ObjCCategoryImplDecl _ - -> ObjcCategory_decl.category_impl_decl qual_type_to_sil_type tenv decl - | EnumDecl _ - -> CEnum_decl.enum_decl decl - | _ - -> assert false + | ClassTemplateSpecializationDecl _ | CXXRecordDecl _ | RecordDecl _ -> + get_record_declaration_type tenv decl + | ObjCInterfaceDecl _ -> + ObjcInterface_decl.interface_declaration qual_type_to_sil_type tenv decl + | ObjCImplementationDecl _ -> + ObjcInterface_decl.interface_impl_declaration qual_type_to_sil_type tenv decl + | ObjCProtocolDecl _ -> + ObjcProtocol_decl.protocol_decl qual_type_to_sil_type tenv decl + | ObjCCategoryDecl _ -> + ObjcCategory_decl.category_decl qual_type_to_sil_type tenv decl + | ObjCCategoryImplDecl _ -> + ObjcCategory_decl.category_impl_decl qual_type_to_sil_type tenv decl + | EnumDecl _ -> + CEnum_decl.enum_decl decl + | _ -> + assert false + and get_template_args tenv (tsi: Clang_ast_t.template_specialization_info) = let rec aux = function - | `Type qual_type - -> [Typ.TType (qual_type_to_sil_type tenv qual_type)] - | `Expression | `TemplateExpansion | `Template | `Declaration _ - -> [Typ.TOpaque] + | `Type qual_type -> + [Typ.TType (qual_type_to_sil_type tenv qual_type)] + | `Expression | `TemplateExpansion | `Template | `Declaration _ -> + [Typ.TOpaque] | `Integral i -> ( match Int64.of_string i with x -> [Typ.TInt x] | exception Failure _ -> [Typ.TOpaque] ) - | `Null - -> [Typ.TNull] - | `NullPtr - -> [Typ.TNullPtr] - | `Pack p - -> List.concat_map ~f:aux p + | `Null -> + [Typ.TNull] + | `NullPtr -> + [Typ.TNullPtr] + | `Pack p -> + List.concat_map ~f:aux p in List.concat_map ~f:aux tsi.tsi_specialization_args + and qual_type_to_sil_type tenv qual_type = CType_to_sil_type.qual_type_to_sil_type add_types_from_decl_to_tenv tenv qual_type + let get_type_from_expr_info ei tenv = let qt = ei.Clang_ast_t.ei_qual_type in qual_type_to_sil_type tenv qt + let class_from_pointer_type tenv qual_type = match (qual_type_to_sil_type tenv qual_type).Typ.desc with - | Tptr ({desc= Tstruct typename}, _) - -> typename - | _ - -> assert false + | Tptr ({desc= Tstruct typename}, _) -> + typename + | _ -> + assert false + let get_class_type_np tenv expr_info obj_c_message_expr_info = let qt = match obj_c_message_expr_info.Clang_ast_t.omei_receiver_kind with - | `Class qt - -> qt - | _ - -> expr_info.Clang_ast_t.ei_qual_type + | `Class qt -> + qt + | _ -> + expr_info.Clang_ast_t.ei_qual_type in qual_type_to_sil_type tenv qt + diff --git a/infer/src/clang/Capture.ml b/infer/src/clang/Capture.ml index a3e429534..dd22b2ff6 100644 --- a/infer/src/clang/Capture.ml +++ b/infer/src/clang/Capture.ml @@ -18,9 +18,11 @@ let debug_mode = Config.debug_mode || Config.frontend_stats let validate_decl_from_file fname = Ag_util.Biniou.from_file ~len:CFrontend_config.biniou_buffer_size Clang_ast_b.read_decl fname + let validate_decl_from_channel chan = Ag_util.Biniou.from_channel ~len:CFrontend_config.biniou_buffer_size Clang_ast_b.read_decl chan + let register_perf_stats_report source_file = let stats_dir = Filename.concat Config.results_dir Config.frontend_stats_dir_name in let abbrev_source_file = DB.source_file_encoding source_file in @@ -28,6 +30,7 @@ let register_perf_stats_report source_file = Unix.mkdir_p stats_dir ; PerfStats.register_report_at_exit (Filename.concat stats_dir stats_file) + let init_global_state_for_capture_and_linters source_file = L.(debug Capture Medium) "Processing %s" (Filename.basename (SourceFile.to_abs_path source_file)) ; if Config.developer_mode then register_perf_stats_report source_file ; @@ -35,6 +38,7 @@ let init_global_state_for_capture_and_linters source_file = if Config.clang_frontend_do_capture then DB.Results_dir.init source_file ; CFrontend_config.reset_global_state () + let run_clang_frontend ast_source = let init_time = Mtime_clock.counter () in let print_elapsed () = @@ -42,40 +46,40 @@ let run_clang_frontend ast_source = in let ast_decl = match ast_source with - | `File path - -> validate_decl_from_file path - | `Pipe chan - -> validate_decl_from_channel chan + | `File path -> + validate_decl_from_file path + | `Pipe chan -> + validate_decl_from_channel chan in let trans_unit_ctx = match ast_decl with - | Clang_ast_t.TranslationUnitDecl (_, _, _, info) - -> Config.arc_mode := info.Clang_ast_t.tudi_arc_enabled ; + | Clang_ast_t.TranslationUnitDecl (_, _, _, info) -> + Config.arc_mode := info.Clang_ast_t.tudi_arc_enabled ; let source_file = SourceFile.from_abs_path info.Clang_ast_t.tudi_input_path in init_global_state_for_capture_and_linters source_file ; let lang = match info.Clang_ast_t.tudi_input_kind with - | `IK_C - -> CFrontend_config.C - | `IK_CXX - -> CFrontend_config.CPP - | `IK_ObjC - -> CFrontend_config.ObjC - | `IK_ObjCXX - -> CFrontend_config.ObjCPP - | _ - -> assert false + | `IK_C -> + CFrontend_config.C + | `IK_CXX -> + CFrontend_config.CPP + | `IK_ObjC -> + CFrontend_config.ObjC + | `IK_ObjCXX -> + CFrontend_config.ObjCPP + | _ -> + assert false in - {CFrontend_config.source_file= source_file; lang} - | _ - -> assert false + {CFrontend_config.source_file; lang} + | _ -> + assert false in let pp_ast_filename fmt ast_source = match ast_source with - | `File path - -> Format.fprintf fmt "%s" path - | `Pipe _ - -> Format.fprintf fmt "stdin of %a" SourceFile.pp trans_unit_ctx.CFrontend_config.source_file + | `File path -> + Format.fprintf fmt "%s" path + | `Pipe _ -> + Format.fprintf fmt "stdin of %a" SourceFile.pp trans_unit_ctx.CFrontend_config.source_file in ClangPointers.populate_all_tables ast_decl ; L.(debug Capture Quiet) "Clang frontend action is %s@\n" Config.clang_frontend_action_string ; @@ -89,12 +93,14 @@ let run_clang_frontend ast_source = ast_source ; print_elapsed () + let run_and_validate_clang_frontend ast_source = try run_clang_frontend ast_source with exc -> reraise_if exc ~f:(fun () -> not Config.keep_going) ; L.internal_error "ERROR RUNNING CAPTURE: %a@\n%s@\n" Exn.pp exc (Printexc.get_backtrace ()) + let run_clang clang_command read = let exit_with_error exit_code = L.external_error "Error: the following clang command did not run successfully:@\n %s@\n%!" @@ -103,13 +109,14 @@ let run_clang clang_command read = in (* NOTE: exceptions will propagate through without exiting here *) match Utils.with_process_in clang_command read with - | res, Ok () - -> res - | _, Error `Exit_non_zero n - -> (* exit with the same error code as clang in case of compilation failure *) + | res, Ok () -> + res + | _, Error `Exit_non_zero n -> + (* exit with the same error code as clang in case of compilation failure *) exit_with_error n - | _ - -> exit_with_error 1 + | _ -> + exit_with_error 1 + let run_plugin_and_frontend source_path frontend clang_args = let clang_command = ClangCommand.command_to_run (ClangCommand.with_plugin_args clang_args) in @@ -128,6 +135,7 @@ let run_plugin_and_frontend source_path frontend clang_args = Out_channel.close debug_script_out ) ; run_clang clang_command frontend + let cc1_capture clang_cmd = let source_path = let root = Unix.getcwd () in @@ -150,13 +158,14 @@ let cc1_capture clang_cmd = () ) else match Config.clang_biniou_file with - | Some fname - -> run_and_validate_clang_frontend (`File fname) - | None - -> run_plugin_and_frontend source_path + | Some fname -> + run_and_validate_clang_frontend (`File fname) + | None -> + run_plugin_and_frontend source_path (fun chan_in -> run_and_validate_clang_frontend (`Pipe chan_in)) clang_cmd + let capture clang_cmd = if ClangCommand.can_attach_ast_exporter clang_cmd then (* this command compiles some code; replace the invocation of clang with our own clang and @@ -169,3 +178,4 @@ let capture clang_cmd = let command_to_run = ClangCommand.command_to_run clang_cmd in L.(debug Capture Quiet) "Running non-cc command without capture: %s@\n" command_to_run ; run_clang command_to_run Utils.consume_in + diff --git a/infer/src/clang/CiOSVersionNumbers.ml b/infer/src/clang/CiOSVersionNumbers.ml index 726fdc94e..68ce8a2b3 100644 --- a/infer/src/clang/CiOSVersionNumbers.ml +++ b/infer/src/clang/CiOSVersionNumbers.ml @@ -45,37 +45,41 @@ let version_numbers : t list = ; (1348.0, "10.0") ; (1348.22, "10.2") ] + let sort_versions versions = let compare (version_float1, _) (version_float2, _) = Float.compare version_float1 version_float2 in List.sort ~cmp:compare versions + let version_of number_s : human_readable_version option = let epsilon = 0.001 in let rec version_of_aux version_numbers number = match version_numbers with - | (version_n, version_s) :: (next_version_n, next_version_s) :: rest - -> if number -. version_n < epsilon && number -. version_n > ~-.epsilon then Some version_s + | (version_n, version_s) :: (next_version_n, next_version_s) :: rest -> + if number -. version_n < epsilon && number -. version_n > ~-.epsilon then Some version_s else if number >= version_n +. epsilon && number <= next_version_n -. epsilon then Some next_version_s else version_of_aux ((next_version_n, next_version_s) :: rest) number - | [(version_n, version_s)] - -> if number >= version_n then Some version_s else None - | [] - -> None + | [(version_n, version_s)] -> + if number >= version_n then Some version_s else None + | [] -> + None in let number_opt = try Some (float_of_string number_s) with Failure _ -> None in match number_opt with - | None - -> None - | Some number - -> version_of_aux (sort_versions version_numbers) number + | None -> + None + | Some number -> + version_of_aux (sort_versions version_numbers) number + let pp_diff_of_version_opt fmt (expected, actual) = let option_to_string opt = Option.value ~default:"" opt in Format.fprintf fmt "Expected: [%s] Found: [%s]" (option_to_string expected) (option_to_string actual) + diff --git a/infer/src/clang/ClangCommand.ml b/infer/src/clang/ClangCommand.ml index f3314a73e..451451c3a 100644 --- a/infer/src/clang/ClangCommand.ml +++ b/infer/src/clang/ClangCommand.ml @@ -16,6 +16,7 @@ let fcp_dir = Config.bin_dir ^/ Filename.parent_dir_name ^/ Filename.parent_dir_name ^/ "facebook-clang-plugins" + (** path of the plugin to load in clang *) let plugin_path = fcp_dir ^/ "libtooling" ^/ "build" ^/ "FacebookClangPlugin.dylib" @@ -37,6 +38,7 @@ let value_of_argv_option argv opt_name = ~init:("", None) argv |> snd + let value_of_option {orig_argv} = value_of_argv_option orig_argv let has_flag {orig_argv} flag = List.exists ~f:(String.equal flag) orig_argv @@ -44,17 +46,19 @@ let has_flag {orig_argv} flag = List.exists ~f:(String.equal flag) orig_argv let can_attach_ast_exporter cmd = let is_supported_language cmd = match value_of_option cmd "-x" with - | None - -> L.external_warning "malformed -cc1 command has no \"-x\" flag!" ; false - | Some lang when String.is_prefix ~prefix:"assembler" lang - -> false - | Some _ - -> true + | None -> + L.external_warning "malformed -cc1 command has no \"-x\" flag!" ; + false + | Some lang when String.is_prefix ~prefix:"assembler" lang -> + false + | Some _ -> + true in (* -Eonly is -cc1 flag that gets produced by 'clang -M -### ...' *) let is_preprocessor_only cmd = has_flag cmd "-E" || has_flag cmd "-Eonly" in has_flag cmd "-cc1" && is_supported_language cmd && not (is_preprocessor_only cmd) + let argv_cons a b = a :: b let argv_do_if cond action x = if cond then action x else x @@ -63,25 +67,27 @@ let file_arg_cmd_sanitizer cmd = let file = ClangQuotes.mk_arg_file "clang_command_" cmd.quoting_style cmd.argv in {cmd with argv= [Format.sprintf "@%s" file]} + let include_override_regex = Option.map ~f:Str.regexp Config.clang_include_to_override_regex let filter_and_replace_unsupported_args ?(replace_option_arg= fun _ s -> s) ?(blacklisted_flags= []) ?(blacklisted_flags_with_arg= []) ?(post_args= []) args = let rec aux (prev, res_rev) args = match args with - | [] - -> (* return non-reversed list *) + | [] -> + (* return non-reversed list *) List.rev_append res_rev post_args - | flag :: tl when List.mem ~equal:String.equal blacklisted_flags flag - -> aux (flag, res_rev) tl - | flag1 :: flag2 :: tl when List.mem ~equal:String.equal blacklisted_flags_with_arg flag1 - -> aux (flag2, res_rev) tl - | arg :: tl - -> let res_rev' = replace_option_arg prev arg :: res_rev in + | flag :: tl when List.mem ~equal:String.equal blacklisted_flags flag -> + aux (flag, res_rev) tl + | flag1 :: flag2 :: tl when List.mem ~equal:String.equal blacklisted_flags_with_arg flag1 -> + aux (flag2, res_rev) tl + | arg :: tl -> + let res_rev' = replace_option_arg prev arg :: res_rev in aux (arg, res_rev') tl in aux ("", []) args + (* Work around various path or library issues occurring when one tries to substitute Apple's version of clang with a different version. Also mitigate version discrepancies in clang's fatal warnings. *) @@ -102,15 +108,15 @@ let clang_cc1_cmd_sanitizer cmd = then "/dev/null" else if String.equal option "-isystem" then match include_override_regex with - | Some regexp when Str.string_match regexp arg 0 - -> fcp_dir ^/ "clang" ^/ "install" ^/ "lib" ^/ "clang" ^/ "5.0.0" ^/ "include" - | _ - -> arg + | Some regexp when Str.string_match regexp arg 0 -> + fcp_dir ^/ "clang" ^/ "install" ^/ "lib" ^/ "clang" ^/ "5.0.0" ^/ "include" + | _ -> + arg else arg in let args_defines = if Config.bufferoverrun then ["-D__INFER_BUFFEROVERRUN"] else [] in let post_args_rev = - [] |> List.rev_append ["-include"; (Config.lib_dir ^/ "clang_wrappers" ^/ "global_defines.h")] + [] |> List.rev_append ["-include"; Config.lib_dir ^/ "clang_wrappers" ^/ "global_defines.h"] |> List.rev_append args_defines |> (* Never error on warnings. Clang is often more strict than Apple's version. These arguments are appended at the end to override previous opposite settings. How it's done: suppress @@ -124,12 +130,14 @@ let clang_cc1_cmd_sanitizer cmd = in file_arg_cmd_sanitizer {cmd with argv= clang_arguments} + let mk quoting_style ~prog ~args = (* Some arguments break the compiler so they need to be removed even before the normalization step *) let blacklisted_flags_with_arg = ["-index-store-path"] in let sanitized_args = filter_and_replace_unsupported_args ~blacklisted_flags_with_arg args in {exec= prog; orig_argv= sanitized_args; argv= sanitized_args; quoting_style} + let command_to_run cmd = let mk_cmd normalizer = let {exec; argv; quoting_style} = normalizer cmd in @@ -144,6 +152,7 @@ let command_to_run cmd = else (* other commands such as `ld` do not support argument files *) mk_cmd (fun x -> x) + let with_exec exec args = {args with exec} let with_plugin_args args = @@ -161,14 +170,14 @@ let with_plugin_args args = YojsonASTExporter plugin are used. Since the -plugin argument disables the generation of .o files, we invoke apple clang again to generate the expected artifacts. This will keep xcodebuild plus all the sub-steps happy. *) - (if has_flag args "-fmodules" then "-plugin" else "-add-plugin") + (if has_flag args "-fmodules" then "-plugin" else "-add-plugin") ; plugin_name ; plugin_arg_flag ; "-" ; plugin_arg_flag ; "PREPEND_CURRENT_DIR=1" ; plugin_arg_flag - ; ("MAX_STRING_SIZE=" ^ string_of_int CFrontend_config.biniou_buffer_size) ] + ; "MAX_STRING_SIZE=" ^ string_of_int CFrontend_config.biniou_buffer_size ] in (* add -O0 option to avoid compiler obfuscation of AST *) let args_after_rev = @@ -176,6 +185,7 @@ let with_plugin_args args = in {args with argv= List.rev_append args_before_rev (args.argv @ List.rev args_after_rev)} + let prepend_arg arg clang_args = {clang_args with argv= arg :: clang_args.argv} let prepend_args args clang_args = {clang_args with argv= args @ clang_args.argv} diff --git a/infer/src/clang/ClangPointers.ml b/infer/src/clang/ClangPointers.ml index a9a6ca1e2..96023c932 100644 --- a/infer/src/clang/ClangPointers.ml +++ b/infer/src/clang/ClangPointers.ml @@ -32,40 +32,46 @@ let visit_ast ?(visit_decl= empty_v) ?(visit_stmt= empty_v) ?(visit_type= empty_ Clang_ast_visit.type_visitor := visit_type ; Clang_ast_visit.source_location_visitor := visit_src_loc ; match Clang_ast_v.validate_decl [] top_decl (* visit *) with - | None - -> () - | Some error - -> L.(die InternalError) - "visiting the clang AST failed with error %s" (Ag_util.Validation.string_of_error error) + | None -> + () + | Some error -> + L.(die InternalError) + "visiting the clang AST failed with error %s" + (Ag_util.Validation.string_of_error error) + let get_ptr_from_node node = match node with - | `DeclNode decl - -> let decl_info = Clang_ast_proj.get_decl_tuple decl in + | `DeclNode decl -> + let decl_info = Clang_ast_proj.get_decl_tuple decl in decl_info.Clang_ast_t.di_pointer - | `StmtNode stmt - -> let stmt_info, _ = Clang_ast_proj.get_stmt_tuple stmt in + | `StmtNode stmt -> + let stmt_info, _ = Clang_ast_proj.get_stmt_tuple stmt in stmt_info.Clang_ast_t.si_pointer - | `TypeNode c_type - -> let type_info = Clang_ast_proj.get_type_tuple c_type in + | `TypeNode c_type -> + let type_info = Clang_ast_proj.get_type_tuple c_type in type_info.Clang_ast_t.ti_pointer + let get_val_from_node node = match node with `DeclNode decl -> decl | `StmtNode stmt -> stmt | `TypeNode c_type -> c_type + let add_node_to_cache node cache = let key = get_ptr_from_node node in let data = get_val_from_node node in Int.Table.set cache ~key ~data + let process_decl _ decl = add_node_to_cache (`DeclNode decl) pointer_decl_table ; match decl with - | Clang_ast_t.ObjCPropertyDecl (_, _, {opdi_ivar_decl= Some decl_ref}) - -> let ivar_pointer = decl_ref.Clang_ast_t.dr_decl_pointer in + | Clang_ast_t.ObjCPropertyDecl (_, _, {opdi_ivar_decl= Some decl_ref}) -> + let ivar_pointer = decl_ref.Clang_ast_t.dr_decl_pointer in Int.Table.set ivar_to_property_table ~key:ivar_pointer ~data:decl - | _ - -> () + | _ -> + () + let add_stmt_to_cache _ stmt = add_node_to_cache (`StmtNode stmt) pointer_stmt_table @@ -81,6 +87,7 @@ let mutate_sloc sloc file line column = sloc.sl_line <- line ; sloc.sl_column <- column + let reset_sloc sloc = mutate_sloc sloc None None None let complete_source_location _ source_loc = @@ -88,7 +95,9 @@ let complete_source_location _ source_loc = let file = get_sloc source_loc.sl_file previous_sloc.sl_file in let line = get_sloc source_loc.sl_line previous_sloc.sl_line in let column = get_sloc source_loc.sl_column previous_sloc.sl_column in - mutate_sloc source_loc file line column ; mutate_sloc previous_sloc file line column + mutate_sloc source_loc file line column ; + mutate_sloc previous_sloc file line column + let reset_cache () = Int.Table.clear pointer_decl_table ; @@ -97,9 +106,11 @@ let reset_cache () = Int.Table.clear ivar_to_property_table ; reset_sloc previous_sloc + (* This function is not thread-safe *) let populate_all_tables top_decl = reset_cache () ; (* populate caches *) visit_ast ~visit_decl:process_decl ~visit_stmt:add_stmt_to_cache ~visit_type:add_type_to_cache ~visit_src_loc:complete_source_location top_decl + diff --git a/infer/src/clang/ClangWrapper.ml b/infer/src/clang/ClangWrapper.ml index b3ffb4b80..55332c2f7 100644 --- a/infer/src/clang/ClangWrapper.ml +++ b/infer/src/clang/ClangWrapper.ml @@ -29,26 +29,27 @@ let check_for_existing_file args = let all_args = List.map ~f:String.strip all_args_ in let rec check_for_existing_file_arg args = match args with - | [] - -> () - | option :: rest - -> if String.equal option "-c" then + | [] -> + () + | option :: rest -> + if String.equal option "-c" then match (* infer-capture-all flavour of buck produces path to generated file that doesn't exist. Create empty file empty file and pass that to clang. This is to enable compilation to continue *) (clang_ignore_regex, List.hd rest) with - | Some regexp, Some arg - -> if Str.string_match regexp arg 0 && Sys.file_exists arg <> `Yes then ( + | Some regexp, Some arg -> + if Str.string_match regexp arg 0 && Sys.file_exists arg <> `Yes then ( Unix.mkdir_p (Filename.dirname arg) ; let file = Unix.openfile ~mode:[Unix.O_CREAT; Unix.O_RDONLY] arg in Unix.close file ) - | _ - -> () + | _ -> + () else check_for_existing_file_arg rest in check_for_existing_file_arg all_args + (** Given a list of arguments for clang [args], return a list of new commands to run according to the results of `clang -### [args]`. *) let normalize ~prog ~args : action_item list = @@ -82,10 +83,10 @@ let normalize ~prog ~args : action_item list = "\"" ^ line ^ " \"" |> (* split by whitespace *) Str.split (Str.regexp_string "\" \"") with - | prog :: args - -> ClangCommand.mk ClangQuotes.EscapedDoubleQuotes ~prog ~args - | [] - -> L.(die InternalError) "ClangWrapper: argv cannot be empty" ) + | prog :: args -> + ClangCommand.mk ClangQuotes.EscapedDoubleQuotes ~prog ~args + | [] -> + L.(die InternalError) "ClangWrapper: argv cannot be empty" ) else if Str.string_match (Str.regexp "clang[^ :]*: warning: ") line 0 then ClangWarning line else ClangError line in @@ -108,17 +109,19 @@ let normalize ~prog ~args : action_item list = normalized_commands := List.rev !normalized_commands ; !normalized_commands + let exec_action_item = function - | ClangError error - -> (* An error in the output of `clang -### ...`. Outputs the error and fail. This is because + | ClangError error -> + (* An error in the output of `clang -### ...`. Outputs the error and fail. This is because `clang -###` pretty much never fails, but warns of failures on stderr instead. *) L.(die UserError) "Failed to execute compilation command. Output:@\n%s@\n*** Infer needs a working compilation command to run." error - | ClangWarning warning - -> L.external_warning "%s@\n" warning - | Command clang_cmd - -> Capture.capture clang_cmd + | ClangWarning warning -> + L.external_warning "%s@\n" warning + | Command clang_cmd -> + Capture.capture clang_cmd + let exe ~prog ~args = let xx_suffix = match String.is_suffix ~suffix:"++" prog with true -> "++" | false -> "" in @@ -130,11 +133,12 @@ let exe ~prog ~args = generate precompiled headers compatible with Apple's clang. *) let prog, should_run_original_command = match Config.fcp_apple_clang with - | Some bin - -> let bin_xx = bin ^ xx_suffix in - L.(debug Capture Medium) "Will run Apple clang %s" bin_xx ; (bin_xx, true) - | None - -> (clang_xx, false) + | Some bin -> + let bin_xx = bin ^ xx_suffix in + L.(debug Capture Medium) "Will run Apple clang %s" bin_xx ; + (bin_xx, true) + | None -> + (clang_xx, false) in List.iter ~f:exec_action_item commands ; if List.is_empty commands || should_run_original_command then ( @@ -151,3 +155,4 @@ let exe ~prog ~args = "WARNING: `clang -### ` returned an empty set of commands to run and no error. Will run the original command directly:@\n %s@\n" (String.concat ~sep:" " @@ prog :: args) ; Process.create_process_and_wait ~prog ~args ) + diff --git a/infer/src/clang/ComponentKit.ml b/infer/src/clang/ComponentKit.ml index f685cdc1f..c5aa9199f 100644 --- a/infer/src/clang/ComponentKit.ml +++ b/infer/src/clang/ComponentKit.ml @@ -13,42 +13,48 @@ module MF = MarkupFormatter let get_source_range an = match an with - | Ctl_parser_types.Decl decl - -> let decl_info = Clang_ast_proj.get_decl_tuple decl in + | Ctl_parser_types.Decl decl -> + let decl_info = Clang_ast_proj.get_decl_tuple decl in decl_info.Clang_ast_t.di_source_range - | Ctl_parser_types.Stmt stmt - -> let stmt_info, _ = Clang_ast_proj.get_stmt_tuple stmt in + | Ctl_parser_types.Stmt stmt -> + let stmt_info, _ = Clang_ast_proj.get_stmt_tuple stmt in stmt_info.Clang_ast_t.si_source_range + let is_in_main_file translation_unit_context an = let file_opt = (fst (get_source_range an)).Clang_ast_t.sl_file in match file_opt with - | None - -> false - | Some source_file - -> SourceFile.equal (SourceFile.from_abs_path source_file) + | None -> + false + | Some source_file -> + SourceFile.equal + (SourceFile.from_abs_path source_file) translation_unit_context.CFrontend_config.source_file + let is_ck_context (context: CLintersContext.context) an = context.is_ck_translation_unit && is_in_main_file context.translation_unit_context an && CGeneral_utils.is_objc_extension context.translation_unit_context + (** Recursively go up the inheritance hierarchy of a given ObjCInterfaceDecl. (Returns false on decls other than that one.) *) let is_component_or_controller_if decl = let open CFrontend_config in CAst_utils.is_objc_if_descendant decl [ckcomponent_cl; ckcomponentcontroller_cl] + (** True if it's an objc class impl that extends from CKComponent or CKComponentController, false otherwise *) let rec is_component_or_controller_descendant_impl decl = match decl with - | Clang_ast_t.ObjCImplementationDecl _ - -> is_component_or_controller_if (CAst_utils.get_super_if (Some decl)) - | Clang_ast_t.LinkageSpecDecl (_, decl_list, _) - -> contains_ck_impl decl_list - | _ - -> false + | Clang_ast_t.ObjCImplementationDecl _ -> + is_component_or_controller_if (CAst_utils.get_super_if (Some decl)) + | Clang_ast_t.LinkageSpecDecl (_, decl_list, _) -> + contains_ck_impl decl_list + | _ -> + false + (** Returns true if the passed-in list of decls contains an ObjCImplementationDecl of a descendant of CKComponent or @@ -58,6 +64,7 @@ let rec is_component_or_controller_descendant_impl decl = and contains_ck_impl decl_list = List.exists ~f:is_component_or_controller_descendant_impl decl_list + (** An easy way to fix the component kit best practice http://componentkit.org/docs/avoid-local-variables.html @@ -86,14 +93,14 @@ let mutable_local_vars_advice context an = let rec get_referenced_type (qual_type: Clang_ast_t.qual_type) : Clang_ast_t.decl option = let typ_opt = CAst_utils.get_desugared_type qual_type.qt_type_ptr in match (typ_opt : Clang_ast_t.c_type option) with - | Some ObjCInterfaceType (_, decl_ptr) | Some RecordType (_, decl_ptr) - -> CAst_utils.get_decl decl_ptr + | Some ObjCInterfaceType (_, decl_ptr) | Some RecordType (_, decl_ptr) -> + CAst_utils.get_decl decl_ptr | Some PointerType (_, inner_qual_type) | Some ObjCObjectPointerType (_, inner_qual_type) - | Some LValueReferenceType (_, inner_qual_type) - -> get_referenced_type inner_qual_type - | _ - -> None + | Some LValueReferenceType (_, inner_qual_type) -> + get_referenced_type inner_qual_type + | _ -> + None in let is_of_whitelisted_type qual_type = let cpp_whitelist = @@ -105,21 +112,21 @@ let mutable_local_vars_advice context an = in let objc_whitelist = ["NSError"] in match get_referenced_type qual_type with - | Some CXXRecordDecl (_, ndi, _, _, _, _, _, _) - -> List.mem ~equal:String.equal cpp_whitelist ndi.ni_name - | Some ObjCInterfaceDecl (_, ndi, _, _, _) - -> List.mem ~equal:String.equal objc_whitelist ndi.ni_name - | _ - -> false + | Some CXXRecordDecl (_, ndi, _, _, _, _, _, _) -> + List.mem ~equal:String.equal cpp_whitelist ndi.ni_name + | Some ObjCInterfaceDecl (_, ndi, _, _, _) -> + List.mem ~equal:String.equal objc_whitelist ndi.ni_name + | _ -> + false in match an with - | Ctl_parser_types.Decl (Clang_ast_t.VarDecl (decl_info, named_decl_info, qual_type, _) as decl) - -> let is_const_ref = + | Ctl_parser_types.Decl (Clang_ast_t.VarDecl (decl_info, named_decl_info, qual_type, _) as decl) -> + let is_const_ref = match CAst_utils.get_type qual_type.qt_type_ptr with - | Some LValueReferenceType (_, {Clang_ast_t.qt_is_const}) - -> qt_is_const - | _ - -> false + | Some LValueReferenceType (_, {Clang_ast_t.qt_is_const}) -> + qt_is_const + | _ -> + false in let is_const = qual_type.qt_is_const || is_const_ref in let condition = @@ -142,8 +149,9 @@ let mutable_local_vars_advice context an = ; doc_url= None ; loc= CFrontend_checkers.location_from_dinfo context decl_info } else None - | _ - -> None + | _ -> + None + (* Should only be called with a VarDecl *) @@ -157,8 +165,8 @@ let component_factory_function_advice context an = in match an with | Ctl_parser_types.Decl - Clang_ast_t.FunctionDecl (decl_info, _, (qual_type: Clang_ast_t.qual_type), _) - -> let objc_interface = CAst_utils.qual_type_to_objc_interface qual_type in + Clang_ast_t.FunctionDecl (decl_info, _, (qual_type: Clang_ast_t.qual_type), _) -> + let objc_interface = CAst_utils.qual_type_to_objc_interface qual_type in let condition = is_ck_context context an && is_component_if objc_interface in if condition then Some @@ -173,8 +181,9 @@ let component_factory_function_advice context an = ; doc_url= None ; loc= CFrontend_checkers.location_from_dinfo context decl_info } else None - | _ - -> None + | _ -> + None + (* Should only be called with FunctionDecl *) @@ -184,14 +193,14 @@ let component_factory_function_advice context an = let component_with_unconventional_superclass_advice context an = let check_interface if_decl = match if_decl with - | Clang_ast_t.ObjCInterfaceDecl (_, _, _, _, _) - -> if is_component_or_controller_if (Some if_decl) then + | Clang_ast_t.ObjCInterfaceDecl (_, _, _, _, _) -> + if is_component_or_controller_if (Some if_decl) then let superclass_name = match CAst_utils.get_super_if (Some if_decl) with - | Some Clang_ast_t.ObjCInterfaceDecl (_, named_decl_info, _, _, _) - -> Some named_decl_info.ni_name - | _ - -> None + | Some Clang_ast_t.ObjCInterfaceDecl (_, named_decl_info, _, _, _) -> + Some named_decl_info.ni_name + | _ -> + None in let has_conventional_superclass = let open CFrontend_config in @@ -203,10 +212,10 @@ let component_with_unconventional_superclass_advice context an = ; "CKCompositeComponent" ; "CKStatefulViewComponent" ; "CKStatefulViewComponentController" - ; "NTNativeTemplateComponent" ] name - -> true - | _ - -> false + ; "NTNativeTemplateComponent" ] name -> + true + | _ -> + false in let condition = is_component_or_controller_if (Some if_decl) && not has_conventional_superclass @@ -223,19 +232,20 @@ let component_with_unconventional_superclass_advice context an = ; loc= CFrontend_checkers.location_from_decl context if_decl } else None else None - | _ - -> assert false + | _ -> + assert false in match an with - | Ctl_parser_types.Decl Clang_ast_t.ObjCImplementationDecl (_, _, _, _, impl_decl_info) - -> let if_decl_opt = + | Ctl_parser_types.Decl Clang_ast_t.ObjCImplementationDecl (_, _, _, _, impl_decl_info) -> + let if_decl_opt = CAst_utils.get_decl_opt_with_decl_ref impl_decl_info.oidi_class_interface in if Option.is_some if_decl_opt && is_ck_context context an then check_interface (Option.value_exn if_decl_opt) else None - | _ - -> None + | _ -> + None + (** Components should only have one factory method. @@ -256,20 +266,20 @@ let component_with_multiple_factory_methods_advice context an = in let is_available_factory_method if_decl (decl: Clang_ast_t.decl) = match decl with - | ObjCMethodDecl (decl_info, _, _) - -> let unavailable_attrs = + | ObjCMethodDecl (decl_info, _, _) -> + let unavailable_attrs = List.filter ~f:is_unavailable_attr decl_info.Clang_ast_t.di_attributes in let is_available = List.is_empty unavailable_attrs in CAst_utils.is_objc_factory_method ~class_decl:if_decl ~method_decl:(Some decl) && is_available - | _ - -> false + | _ -> + false in let check_interface if_decl = match if_decl with - | Clang_ast_t.ObjCInterfaceDecl (_, _, decls, _, _) - -> let factory_methods = List.filter ~f:(is_available_factory_method (Some if_decl)) decls in + | Clang_ast_t.ObjCInterfaceDecl (_, _, decls, _, _) -> + let factory_methods = List.filter ~f:(is_available_factory_method (Some if_decl)) decls in List.map ~f:(fun meth_decl -> { CIssue.id= "COMPONENT_WITH_MULTIPLE_FACTORY_METHODS" @@ -283,43 +293,46 @@ let component_with_multiple_factory_methods_advice context an = ; doc_url= None ; loc= CFrontend_checkers.location_from_decl context meth_decl }) (List.drop factory_methods 1) - | _ - -> assert false + | _ -> + assert false in match an with | Ctl_parser_types.Decl Clang_ast_t.ObjCImplementationDecl (_, _, _, _, impl_decl_info) - -> ( + -> ( let if_decl_opt = CAst_utils.get_decl_opt_with_decl_ref impl_decl_info.oidi_class_interface in match if_decl_opt with Some d when is_ck_context context an -> check_interface d | _ -> [] ) - | _ - -> [] + | _ -> + [] + let in_ck_class (context: CLintersContext.context) = Option.value_map ~f:is_component_or_controller_descendant_impl ~default:false context.current_objc_class && CGeneral_utils.is_objc_extension context.translation_unit_context + let is_in_factory_method (context: CLintersContext.context) = let interface_decl_opt = match context.current_objc_class with - | Some ObjCImplementationDecl (_, _, _, _, impl_decl_info) - -> CAst_utils.get_decl_opt_with_decl_ref impl_decl_info.oidi_class_interface - | _ - -> None + | Some ObjCImplementationDecl (_, _, _, _, impl_decl_info) -> + CAst_utils.get_decl_opt_with_decl_ref impl_decl_info.oidi_class_interface + | _ -> + None in let methods_to_check = match context.current_method with - | Some current_method - -> current_method :: context.parent_methods - | None - -> context.parent_methods + | Some current_method -> + current_method :: context.parent_methods + | None -> + context.parent_methods in List.exists methods_to_check ~f:(fun method_decl -> CAst_utils.is_objc_factory_method ~class_decl:interface_decl_opt ~method_decl:(Some method_decl) ) + (** Components shouldn't have side-effects in its initializer. http://componentkit.org/docs/no-side-effects.html @@ -335,21 +348,21 @@ let rec _component_initializer_with_side_effects_advice (context: CLintersContex in_ck_class context && is_in_factory_method context && match context.current_objc_class with - | Some d - -> is_in_main_file context.translation_unit_context (Ctl_parser_types.Decl d) - | None - -> false + | Some d -> + is_in_main_file context.translation_unit_context (Ctl_parser_types.Decl d) + | None -> + false in if condition then match call_stmt with - | Clang_ast_t.ImplicitCastExpr (_, stmt :: _, _, _) - -> _component_initializer_with_side_effects_advice context stmt + | Clang_ast_t.ImplicitCastExpr (_, stmt :: _, _, _) -> + _component_initializer_with_side_effects_advice context stmt | Clang_ast_t.DeclRefExpr (_, _, _, decl_ref_expr_info) - -> ( + -> ( let refs = [decl_ref_expr_info.drti_decl_ref; decl_ref_expr_info.drti_found_decl_ref] in match List.find_map ~f:CAst_utils.name_of_decl_ref_opt refs with - | Some "dispatch_after" | Some "dispatch_async" | Some "dispatch_sync" - -> Some + | Some "dispatch_after" | Some "dispatch_async" | Some "dispatch_sync" -> + Some { CIssue.id= "COMPONENT_INITIALIZER_WITH_SIDE_EFFECTS" ; name= None ; severity= Exceptions.Kadvice @@ -359,18 +372,20 @@ let rec _component_initializer_with_side_effects_advice (context: CLintersContex Some "Your +new method should not modify any global variables or global state." ; doc_url= None ; loc= CFrontend_checkers.location_from_stmt context call_stmt } - | _ - -> None ) - | _ - -> None + | _ -> + None ) + | _ -> + None else None + let component_initializer_with_side_effects_advice (context: CLintersContext.context) an = match an with - | Ctl_parser_types.Stmt CallExpr (_, called_func_stmt :: _, _) - -> _component_initializer_with_side_effects_advice context called_func_stmt - | _ - -> None + | Ctl_parser_types.Stmt CallExpr (_, called_func_stmt :: _, _) -> + _component_initializer_with_side_effects_advice context called_func_stmt + | _ -> + None + (* only to be called in CallExpr *) @@ -381,8 +396,8 @@ let component_initializer_with_side_effects_advice (context: CLintersContext.con let component_file_line_count_info (context: CLintersContext.context) dec = let condition = Config.compute_analytics && context.is_ck_translation_unit in match dec with - | Ctl_parser_types.Decl Clang_ast_t.TranslationUnitDecl _ when condition - -> let source_file = context.translation_unit_context.CFrontend_config.source_file in + | Ctl_parser_types.Decl Clang_ast_t.TranslationUnitDecl _ when condition -> + let source_file = context.translation_unit_context.CFrontend_config.source_file in let line_count = SourceFile.line_count source_file in List.map ~f:(fun i -> @@ -395,8 +410,9 @@ let component_file_line_count_info (context: CLintersContext.context) dec = ; doc_url= None ; loc= {Location.line= i; Location.col= 0; Location.file= source_file} }) (List.range 1 line_count ~start:`inclusive ~stop:`inclusive) - | _ - -> [] + | _ -> + [] + (** Computes a component file's cyclomatic complexity. @@ -415,27 +431,27 @@ let component_file_cyclomatic_complexity_info (context: CLintersContext.context) | Clang_ast_t.CaseStmt _ | Clang_ast_t.ObjCAtCatchStmt _ | Clang_ast_t.CXXCatchStmt _ - | Clang_ast_t.ConditionalOperator _ - -> true - | Clang_ast_t.BinaryOperator (_, _, _, boi) - -> List.mem ~equal:( = ) [`LAnd; `LOr] boi.Clang_ast_t.boi_kind - | _ - -> false + | Clang_ast_t.ConditionalOperator _ -> + true + | Clang_ast_t.BinaryOperator (_, _, _, boi) -> + List.mem ~equal:( = ) [`LAnd; `LOr] boi.Clang_ast_t.boi_kind + | _ -> + false in let cyclo_loc_opt an = match an with | Ctl_parser_types.Stmt stmt - when Config.compute_analytics && is_cyclo_stmt stmt && is_ck_context context an - -> Some (CFrontend_checkers.location_from_stmt context stmt) + when Config.compute_analytics && is_cyclo_stmt stmt && is_ck_context context an -> + Some (CFrontend_checkers.location_from_stmt context stmt) | Ctl_parser_types.Decl (Clang_ast_t.TranslationUnitDecl _ as d) - when Config.compute_analytics && context.is_ck_translation_unit - -> Some (CFrontend_checkers.location_from_decl context d) - | _ - -> None + when Config.compute_analytics && context.is_ck_translation_unit -> + Some (CFrontend_checkers.location_from_decl context d) + | _ -> + None in match cyclo_loc_opt an with - | Some loc - -> Some + | Some loc -> + Some { CIssue.id= "COMPONENT_FILE_CYCLOMATIC_COMPLEXITY" ; name= None ; severity= Exceptions.Kinfo @@ -444,5 +460,6 @@ let component_file_cyclomatic_complexity_info (context: CLintersContext.context) ; suggestion= None ; doc_url= None ; loc } - | _ - -> None + | _ -> + None + diff --git a/infer/src/clang/ast_expressions.ml b/infer/src/clang/ast_expressions.ml index 8a4914a2b..574e2d07d 100644 --- a/infer/src/clang/ast_expressions.ml +++ b/infer/src/clang/ast_expressions.ml @@ -16,16 +16,20 @@ let dummy_source_range () = let dummy_source_loc = {Clang_ast_t.sl_file= None; sl_line= None; sl_column= None} in (dummy_source_loc, dummy_source_loc) + let dummy_stmt_info () = {Clang_ast_t.si_pointer= CAst_utils.get_fresh_pointer (); si_source_range= dummy_source_range ()} + (* given a stmt_info return the same stmt_info with a fresh pointer *) let fresh_stmt_info stmt_info = {stmt_info with Clang_ast_t.si_pointer= CAst_utils.get_fresh_pointer ()} + let fresh_decl_info decl_info = {decl_info with Clang_ast_t.di_pointer= CAst_utils.get_fresh_pointer ()} + let empty_decl_info = { Clang_ast_t.di_pointer= CAst_utils.get_invalid_pointer () ; di_parent_pointer= None @@ -40,6 +44,7 @@ let empty_decl_info = ; di_full_comment= None ; di_access= `None } + let empty_var_decl_info = { Clang_ast_t.vdi_storage_class= None ; vdi_tls_kind= `Tls_none @@ -51,16 +56,19 @@ let empty_var_decl_info = ; vdi_init_expr= None ; vdi_parm_index_in_function= None } + let stmt_info_with_fresh_pointer stmt_info = { Clang_ast_t.si_pointer= CAst_utils.get_fresh_pointer () ; si_source_range= stmt_info.Clang_ast_t.si_source_range } + let create_qual_type ?(quals= Typ.mk_type_quals ()) qt_type_ptr = - { Clang_ast_t.qt_type_ptr= qt_type_ptr + { Clang_ast_t.qt_type_ptr ; qt_is_const= Typ.is_const quals ; qt_is_volatile= Typ.is_volatile quals ; qt_is_restrict= Typ.is_restrict quals } + let builtin_to_qual_type kind = create_qual_type (Clang_ast_extend.Builtin kind) let create_pointer_qual_type ?quals typ = create_qual_type ?quals (Clang_ast_extend.PointerOf typ) @@ -68,6 +76,7 @@ let create_pointer_qual_type ?quals typ = create_qual_type ?quals (Clang_ast_ext let create_reference_qual_type ?quals typ = create_qual_type ?quals (Clang_ast_extend.ReferenceOf typ) + (* We translate function types as the return type of the function *) let function_type_ptr return_type = return_type @@ -94,9 +103,11 @@ let create_void_void_type = function_type_ptr create_void_type let create_class_qual_type ?quals typename = create_qual_type ?quals (Clang_ast_extend.ClassType typename) + let make_objc_class_qual_type class_name = create_class_qual_type (Typ.Name.Objc.from_string class_name) + let create_integer_literal n = let stmt_info = dummy_stmt_info () in let expr_info = @@ -105,6 +116,7 @@ let create_integer_literal n = let integer_literal_info = {Clang_ast_t.ili_is_signed= true; ili_bitwidth= 32; ili_value= n} in Clang_ast_t.IntegerLiteral (stmt_info, [], expr_info, integer_literal_info) + let create_cstyle_cast_expr stmt_info stmts qt = let expr_info = { Clang_ast_t.ei_qual_type= create_void_star_type @@ -114,6 +126,7 @@ let create_cstyle_cast_expr stmt_info stmts qt = let cast_expr = {Clang_ast_t.cei_cast_kind= `NullToPointer; cei_base_path= []} in Clang_ast_t.CStyleCastExpr (stmt_info, stmts, expr_info, cast_expr, qt) + let create_parent_expr stmt_info stmts = let expr_info = { Clang_ast_t.ei_qual_type= create_void_star_type @@ -122,6 +135,7 @@ let create_parent_expr stmt_info stmts = in Clang_ast_t.ParenExpr (stmt_info, stmts, expr_info) + let create_implicit_cast_expr stmt_info stmts typ cast_kind = let expr_info = {Clang_ast_t.ei_qual_type= typ; ei_value_kind= `RValue; ei_object_kind= `Ordinary} @@ -129,24 +143,29 @@ let create_implicit_cast_expr stmt_info stmts typ cast_kind = let cast_expr_info = {Clang_ast_t.cei_cast_kind= cast_kind; cei_base_path= []} in Clang_ast_t.ImplicitCastExpr (stmt_info, stmts, expr_info, cast_expr_info) + let create_nil stmt_info = let integer_literal = create_integer_literal "0" in let cstyle_cast_expr = create_cstyle_cast_expr stmt_info [integer_literal] create_int_type in let paren_expr = create_parent_expr stmt_info [cstyle_cast_expr] in create_implicit_cast_expr stmt_info [paren_expr] create_id_type `NullToPointer + let dummy_stmt () = let pointer = CAst_utils.get_fresh_pointer () in let source_range = dummy_source_range () in Clang_ast_t.NullStmt ({Clang_ast_t.si_pointer= pointer; si_source_range= source_range}, []) + let make_stmt_info di = { Clang_ast_t.si_pointer= di.Clang_ast_t.di_pointer ; si_source_range= di.Clang_ast_t.di_source_range } + let make_expr_info qt vk objc_kind = {Clang_ast_t.ei_qual_type= qt; ei_value_kind= vk; ei_object_kind= objc_kind} + let make_expr_info_with_objc_kind qt objc_kind = make_expr_info qt `LValue objc_kind let make_decl_ref_exp stmt_info expr_info drei = @@ -156,18 +175,21 @@ let make_decl_ref_exp stmt_info expr_info drei = in Clang_ast_t.DeclRefExpr (stmt_info, [], expr_info, drei) + let make_obj_c_message_expr_info_instance sel = { Clang_ast_t.omei_selector= sel ; omei_receiver_kind= `Instance ; omei_is_definition_found= false ; omei_decl_pointer= None (* TODO look into it *) } + let make_obj_c_message_expr_info_class selector tname pointer = { Clang_ast_t.omei_selector= selector ; omei_receiver_kind= `Class (create_class_qual_type tname) ; omei_is_definition_found= false ; omei_decl_pointer= pointer } + let make_decl_ref k decl_ptr name is_hidden qt_opt = { Clang_ast_t.dr_kind= k ; dr_decl_pointer= decl_ptr @@ -175,27 +197,34 @@ let make_decl_ref k decl_ptr name is_hidden qt_opt = ; dr_is_hidden= is_hidden ; dr_qual_type= qt_opt } + let make_decl_ref_qt k decl_ptr name is_hidden qt = make_decl_ref k decl_ptr name is_hidden (Some qt) + let make_decl_ref_no_qt k decl_ptr name is_hidden = make_decl_ref k decl_ptr name is_hidden None let make_decl_ref_invalid k name is_hidden qt = make_decl_ref k (CAst_utils.get_invalid_pointer ()) name is_hidden (Some qt) + let make_decl_ref_expr_info decl_ref = {Clang_ast_t.drti_decl_ref= Some decl_ref; drti_found_decl_ref= None} + let make_expr_info qt = {Clang_ast_t.ei_qual_type= qt; ei_value_kind= `LValue; ei_object_kind= `ObjCProperty} + let make_general_expr_info qt vk ok = {Clang_ast_t.ei_qual_type= qt; ei_value_kind= vk; ei_object_kind= ok} + let make_ObjCBoolLiteralExpr stmt_info value = let ei = make_expr_info create_BOOL_type in Clang_ast_t.ObjCBoolLiteralExpr (fresh_stmt_info stmt_info, [], ei, value) + let make_message_expr param_qt selector decl_ref_exp stmt_info add_cast = let stmt_info = stmt_info_with_fresh_pointer stmt_info in let parameters = @@ -210,15 +239,17 @@ let make_message_expr param_qt selector decl_ref_exp stmt_info add_cast = let expr_info = make_expr_info_with_objc_kind param_qt `ObjCProperty in Clang_ast_t.ObjCMessageExpr (stmt_info, parameters, expr_info, obj_c_message_expr_info) + let make_binary_stmt stmt1 stmt2 stmt_info expr_info boi = let stmt_info = stmt_info_with_fresh_pointer stmt_info in Clang_ast_t.BinaryOperator (stmt_info, [stmt1; stmt2], expr_info, boi) + let make_next_object_exp stmt_info item items = let var_decl_ref, var_type = match item with - | Clang_ast_t.DeclStmt (_, _, [(Clang_ast_t.VarDecl (di, name_info, var_qual_type, _))]) - -> let decl_ptr = di.Clang_ast_t.di_pointer in + | Clang_ast_t.DeclStmt (_, _, [(Clang_ast_t.VarDecl (di, name_info, var_qual_type, _))]) -> + let decl_ptr = di.Clang_ast_t.di_pointer in let decl_ref = make_decl_ref_qt `Var decl_ptr name_info false var_qual_type in let stmt_info_var = { Clang_ast_t.si_pointer= di.Clang_ast_t.di_pointer @@ -227,9 +258,10 @@ let make_next_object_exp stmt_info item items = let expr_info = make_expr_info_with_objc_kind var_qual_type `ObjCProperty in let decl_ref_expr_info = make_decl_ref_expr_info decl_ref in (Clang_ast_t.DeclRefExpr (stmt_info_var, [], expr_info, decl_ref_expr_info), var_qual_type) - | _ - -> CFrontend_config.incorrect_assumption "unexpected item %a" - (Pp.to_string ~f:Clang_ast_j.string_of_stmt) item + | _ -> + CFrontend_config.incorrect_assumption "unexpected item %a" + (Pp.to_string ~f:Clang_ast_j.string_of_stmt) + item in let message_call = make_message_expr create_id_type CFrontend_config.next_object items stmt_info false @@ -243,47 +275,51 @@ let make_next_object_exp stmt_info item items = let loop_cond = make_binary_stmt cast nil_exp stmt_info expr_info boi' in (assignment, loop_cond) + (* 1. dispatch_once(v,block_def) is transformed as: block_def() *) (* 2. dispatch_once(v,block_var) is transformed as n$1 = *&block_var; n$2=n$1() *) let translate_dispatch_function stmt_info stmt_list n = let open Clang_ast_t in match stmt_list with - | _ :: args_stmts - -> let expr_info_call = make_general_expr_info create_void_star_type `XValue `Ordinary in + | _ :: args_stmts -> + let expr_info_call = make_general_expr_info create_void_star_type `XValue `Ordinary in let arg_stmt = try List.nth_exn args_stmts n with Failure _ -> assert false in CallExpr (stmt_info, [arg_stmt], expr_info_call) - | _ - -> assert false + | _ -> + assert false + (* Create declaration statement: qt vname = iexp *) let make_DeclStmt stmt_info di qt vname old_vdi iexp = let init_expr_opt, init_expr_l = match iexp with - | Some iexp' - -> let ie = create_implicit_cast_expr stmt_info [iexp'] qt `IntegralCast in + | Some iexp' -> + let ie = create_implicit_cast_expr stmt_info [iexp'] qt `IntegralCast in (Some ie, [ie]) - | None - -> (None, []) + | None -> + (None, []) in let var_decl_info = {old_vdi with Clang_ast_t.vdi_init_expr= init_expr_opt} in let di = fresh_decl_info di in let var_decl = Clang_ast_t.VarDecl (di, vname, qt, var_decl_info) in Clang_ast_t.DeclStmt (stmt_info, init_expr_l, [var_decl]) + let build_OpaqueValueExpr si source_expr ei = let opaque_value_expr_info = {Clang_ast_t.ovei_source_expr= Some source_expr} in Clang_ast_t.OpaqueValueExpr (si, [], ei, opaque_value_expr_info) + let pseudo_object_qt = make_objc_class_qual_type CFrontend_config.pseudo_object_type (* Create expression PseudoObjectExpr for 'o.m' *) let build_PseudoObjectExpr qt_m o_cast_decl_ref_exp mname = match o_cast_decl_ref_exp with - | Clang_ast_t.ImplicitCastExpr (si, _, ei, _) - -> let ove = build_OpaqueValueExpr si o_cast_decl_ref_exp ei in + | Clang_ast_t.ImplicitCastExpr (si, _, ei, _) -> + let ove = build_OpaqueValueExpr si o_cast_decl_ref_exp ei in let ei_opre = make_expr_info pseudo_object_qt in let count_name = CAst_utils.make_name_decl CFrontend_config.count in let pointer = si.Clang_ast_t.si_pointer in @@ -300,8 +336,9 @@ let build_PseudoObjectExpr qt_m o_cast_decl_ref_exp mname = let ome = make_message_expr qt_m mname o_cast_decl_ref_exp si false in let poe_ei = make_general_expr_info qt_m `LValue `Ordinary in Clang_ast_t.PseudoObjectExpr (si, [opre; ove; ome], poe_ei) - | _ - -> assert false + | _ -> + assert false + let create_call stmt_info decl_pointer function_name qt parameters = let expr_info_call = @@ -318,6 +355,7 @@ let create_call stmt_info decl_pointer function_name qt parameters = in Clang_ast_t.CallExpr (stmt_info, cast :: parameters, expr_info_call) + (* For a of type NSArray* Translate [a enumerateObjectsUsingBlock:^(id object, NSUInteger idx, BOOL * stop) { body_block @@ -344,17 +382,17 @@ let create_call stmt_info decl_pointer function_name qt parameters = let translate_block_enumerate block_name stmt_info stmt_list ei = let rec get_name_pointers lp = match lp with - | [] - -> [] - | (Clang_ast_t.ParmVarDecl (di, name, qt, _)) :: lp' - -> (name.Clang_ast_t.ni_name, di.Clang_ast_t.di_pointer, qt) :: get_name_pointers lp' - | _ - -> assert false + | [] -> + [] + | (Clang_ast_t.ParmVarDecl (di, name, qt, _)) :: lp' -> + (name.Clang_ast_t.ni_name, di.Clang_ast_t.di_pointer, qt) :: get_name_pointers lp' + | _ -> + assert false in let build_idx_decl pidx = match pidx with - | Clang_ast_t.ParmVarDecl (di_idx, name_idx, qt_idx, vdi) - -> let zero = create_integer_literal "0" in + | Clang_ast_t.ParmVarDecl (di_idx, name_idx, qt_idx, vdi) -> + let zero = create_integer_literal "0" in (* qt_idx idx = 0; *) let idx_decl_stmt = make_DeclStmt (fresh_stmt_info stmt_info) di_idx qt_idx name_idx vdi (Some zero) @@ -369,8 +407,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = `LValueToRValue in (idx_decl_stmt, idx_decl_ref_exp, idx_cast, qt_idx) - | _ - -> assert false + | _ -> + assert false in let cast_expr decl_ref qt = let ei = make_expr_info qt in @@ -381,8 +419,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = (* build statement BOOL *stop = malloc(sizeof(BOOL)); *) let build_stop pstop = match pstop with - | Clang_ast_t.ParmVarDecl (di, name, qt, vdi) - -> let qt_fun = create_void_unsigned_long_type in + | Clang_ast_t.ParmVarDecl (di, name, qt, vdi) -> + let qt_fun = create_void_unsigned_long_type in let type_opt = Some create_BOOL_type in let parameter = Clang_ast_t.UnaryExprOrTypeTraitExpr @@ -399,14 +437,14 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = create_implicit_cast_expr (fresh_stmt_info stmt_info) [malloc] qt `BitCast in make_DeclStmt (fresh_stmt_info stmt_info) di qt name vdi (Some init_exp) - | _ - -> assert false + | _ -> + assert false in (* BOOL *stop =NO; *) let stop_equal_no pstop = match pstop with - | Clang_ast_t.ParmVarDecl (di, name, qt, _) - -> let decl_ref = make_decl_ref_qt `Var di.Clang_ast_t.di_pointer name false qt in + | Clang_ast_t.ParmVarDecl (di, name, qt, _) -> + let decl_ref = make_decl_ref_qt `Var di.Clang_ast_t.di_pointer name false qt in let cast = cast_expr decl_ref qt in let postfix_deref = {Clang_ast_t.uoi_kind= `Deref; uoi_is_postfix= true} in let lhs = @@ -415,14 +453,14 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = let bool_NO = make_ObjCBoolLiteralExpr stmt_info 0 in let assign = {Clang_ast_t.boi_kind= `Assign} in Clang_ast_t.BinaryOperator (fresh_stmt_info stmt_info, [lhs; bool_NO], ei, assign) - | _ - -> assert false + | _ -> + assert false in (* build statement free(stop); *) let free_stop pstop = match pstop with - | Clang_ast_t.ParmVarDecl (di, name, qt, _) - -> let qt_fun = create_void_void_type in + | Clang_ast_t.ParmVarDecl (di, name, qt, _) -> + let qt_fun = create_void_void_type in let decl_ref = make_decl_ref_qt `Var di.Clang_ast_t.di_pointer name false qt in let cast = cast_expr decl_ref qt in let free_name = CAst_utils.make_name_decl CFrontend_config.free in @@ -432,8 +470,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = in let pointer = di.Clang_ast_t.di_pointer in create_call (fresh_stmt_info stmt_info) pointer free_name qt_fun [parameter] - | _ - -> assert false + | _ -> + assert false in (* idx let poe_ei = make_general_expr_info qt_obj `RValue `Ordinary in + | ParmVarDecl (di_obj, name_obj, qt_obj, _) -> + let poe_ei = make_general_expr_info qt_obj `RValue `Ordinary in let ei_array = get_ei_from_cast decl_ref_expr_array in let ove_array = build_OpaqueValueExpr (fresh_stmt_info stmt_info) decl_ref_expr_array ei_array @@ -484,8 +522,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = let vdi = {empty_var_decl_info with vdi_init_expr= Some pseudo_obj_expr} in let var_decl = VarDecl (di_obj, name_obj, qt_obj, vdi) in DeclStmt (fresh_stmt_info stmt_info, [pseudo_obj_expr], [var_decl]) - | _ - -> assert false + | _ -> + assert false in (* NSArray *objects = a *) let objects_array_DeclStmt init = @@ -500,32 +538,32 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = in let make_object_cast_decl_ref_expr objects = match objects with - | Clang_ast_t.DeclStmt (si, _, [(Clang_ast_t.VarDecl (_, name, qt, _))]) - -> let decl_ref = make_decl_ref_qt `Var si.Clang_ast_t.si_pointer name false qt in + | Clang_ast_t.DeclStmt (si, _, [(Clang_ast_t.VarDecl (_, name, qt, _))]) -> + let decl_ref = make_decl_ref_qt `Var si.Clang_ast_t.si_pointer name false qt in cast_expr decl_ref qt - | _ - -> assert false + | _ -> + assert false in let build_cast_decl_ref_expr_from_parm p = match p with - | Clang_ast_t.ParmVarDecl (di, name, qt, _) - -> let decl_ref = make_decl_ref_qt `Var di.Clang_ast_t.di_pointer name false qt in + | Clang_ast_t.ParmVarDecl (di, name, qt, _) -> + let decl_ref = make_decl_ref_qt `Var di.Clang_ast_t.di_pointer name false qt in cast_expr decl_ref qt - | _ - -> assert false + | _ -> + assert false in let qual_block_name = CAst_utils.make_name_decl block_name in let make_block_decl be = match be with - | Clang_ast_t.BlockExpr (bsi, _, bei, _) - -> let di = {empty_decl_info with di_pointer= CAst_utils.get_fresh_pointer ()} in + | Clang_ast_t.BlockExpr (bsi, _, bei, _) -> + let di = {empty_decl_info with di_pointer= CAst_utils.get_fresh_pointer ()} in let vdi = {empty_var_decl_info with Clang_ast_t.vdi_init_expr= Some be} in let qt = bei.Clang_ast_t.ei_qual_type in let var_decl = Clang_ast_t.VarDecl (di, qual_block_name, qt, vdi) in ( Clang_ast_t.DeclStmt (bsi, [be], [var_decl]) , [(block_name, di.Clang_ast_t.di_pointer, qt)] ) - | _ - -> assert false + | _ -> + assert false in let make_block_call block_qt object_cast idx_cast stop_cast = let decl_ref = make_decl_ref_invalid `Var qual_block_name false block_qt in @@ -554,8 +592,8 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = in let translate params array_cast_decl_ref_exp block_decl block_qt = match params with - | [pobj; pidx; pstop] - -> let objects_decl, op = objects_array_DeclStmt array_cast_decl_ref_exp in + | [pobj; pidx; pstop] -> + let objects_decl, op = objects_array_DeclStmt array_cast_decl_ref_exp in let decl_stop = build_stop pstop in let assign_stop = stop_equal_no pstop in let objects = make_object_cast_decl_ref_expr objects_decl in @@ -581,34 +619,37 @@ let translate_block_enumerate block_name stmt_info stmt_list ei = ; Clang_ast_t.CompoundStmt (stmt_info, [obj_assignment; call_block; if_stop]) ] ) ; free_stop ] , op ) - | _ - -> (* FIXME(t21762295) this is reachable *) + | _ -> + (* FIXME(t21762295) this is reachable *) CFrontend_config.incorrect_assumption "wrong params in block enumerate translation: %a" (Pp.seq (Pp.to_string ~f:Clang_ast_j.string_of_decl)) params in let open Clang_ast_t in match stmt_list with - | [s; (BlockExpr (_, _, bei, BlockDecl (_, bdi)) as be)] - -> let block_decl, bv = make_block_decl be in + | [s; (BlockExpr (_, _, bei, BlockDecl (_, bdi)) as be)] -> + let block_decl, bv = make_block_decl be in let vars_to_register = get_name_pointers bdi.bdi_parameters in let translated_stmt, op = translate bdi.bdi_parameters s block_decl bei.ei_qual_type in (CompoundStmt (stmt_info, translated_stmt), vars_to_register @ op @ bv) - | _ - -> (* When it is not the method we expect with only one parameter, we don't translate *) + | _ -> + (* When it is not the method we expect with only one parameter, we don't translate *) L.(debug Capture Verbose) "WARNING: Block Enumeration called at %s not translated." (Clang_ast_j.string_of_stmt_info stmt_info) ; (CompoundStmt (stmt_info, stmt_list), []) + (* We translate an expression with a conditional*) (* x <=> x?1:0 *) let trans_with_conditional stmt_info expr_info stmt_list = let stmt_list_cond = stmt_list @ [create_integer_literal "1"] @ [create_integer_literal "0"] in Clang_ast_t.ConditionalOperator (stmt_info, stmt_list_cond, expr_info) + (* We translate the logical negation of an expression with a conditional*) (* !x <=> x?0:1 *) let trans_negation_with_conditional stmt_info expr_info stmt_list = let stmt_list_cond = stmt_list @ [create_integer_literal "0"] @ [create_integer_literal "1"] in Clang_ast_t.ConditionalOperator (stmt_info, stmt_list_cond, expr_info) + diff --git a/infer/src/clang/cArithmetic_trans.ml b/infer/src/clang/cArithmetic_trans.ml index eafb6669a..f1a944cf9 100644 --- a/infer/src/clang/cArithmetic_trans.ml +++ b/infer/src/clang/cArithmetic_trans.ml @@ -29,29 +29,30 @@ let assignment_arc_mode e1 typ e2 loc rhs_owning_method is_e1_decl = Sil.Call (None, bi_retain, [(e, t)], loc, CallFlags.default) in match typ.Typ.desc with - | Typ.Tptr (_, Typ.Pk_pointer) when not rhs_owning_method && not is_e1_decl - -> (* for __strong e1 = e2 the semantics is*) + | Typ.Tptr (_, Typ.Pk_pointer) when not rhs_owning_method && not is_e1_decl -> + (* for __strong e1 = e2 the semantics is*) (* retain(e2); tmp=e1; e1=e2; release(tmp); *) let retain = mk_call retain_pname e2 typ in let id = Ident.create_fresh Ident.knormal in let tmp_assign = Sil.Load (id, e1, typ, loc) in let release = mk_call release_pname (Exp.Var id) typ in (e1, [retain; tmp_assign; assign; release]) - | Typ.Tptr (_, Typ.Pk_pointer) when not rhs_owning_method && is_e1_decl - -> (* for A __strong *e1 = e2 the semantics is*) + | Typ.Tptr (_, Typ.Pk_pointer) when not rhs_owning_method && is_e1_decl -> + (* for A __strong *e1 = e2 the semantics is*) (* retain(e2); e1=e2; *) let retain = mk_call retain_pname e2 typ in (e1, [retain; assign]) - | Typ.Tptr (_, Typ.Pk_objc_weak) | Typ.Tptr (_, Typ.Pk_objc_unsafe_unretained) - -> (e1, [assign]) - | Typ.Tptr (_, Typ.Pk_objc_autoreleasing) - -> (* for __autoreleasing e1 = e2 the semantics is*) + | Typ.Tptr (_, Typ.Pk_objc_weak) | Typ.Tptr (_, Typ.Pk_objc_unsafe_unretained) -> + (e1, [assign]) + | Typ.Tptr (_, Typ.Pk_objc_autoreleasing) -> + (* for __autoreleasing e1 = e2 the semantics is*) (* retain(e2); autorelease(e2); e1=e2; *) let retain = mk_call retain_pname e2 typ in let autorelease = mk_call autorelease_pname e2 typ in (e1, [retain; autorelease; assign]) - | _ - -> (e1, [assign]) + | _ -> + (e1, [assign]) + (* Returns a pair ([binary_expression], instructions) for binary operator representing a *) (* CompoundAssignment. "binary_expression" is returned when we are calculating an expression*) @@ -62,41 +63,42 @@ let compound_assignment_binary_operation_instruction boi e1 typ e2 loc = let instr1 = Sil.Load (id, e1, typ, loc) in let e_res, instr_op = match boi.Clang_ast_t.boi_kind with - | `AddAssign - -> let e1_plus_e2 = Exp.BinOp (Binop.PlusA, Exp.Var id, e2) in + | `AddAssign -> + let e1_plus_e2 = Exp.BinOp (Binop.PlusA, Exp.Var id, e2) in (e1, [Sil.Store (e1, typ, e1_plus_e2, loc)]) - | `SubAssign - -> let e1_sub_e2 = Exp.BinOp (Binop.MinusA, Exp.Var id, e2) in + | `SubAssign -> + let e1_sub_e2 = Exp.BinOp (Binop.MinusA, Exp.Var id, e2) in (e1, [Sil.Store (e1, typ, e1_sub_e2, loc)]) - | `MulAssign - -> let e1_mul_e2 = Exp.BinOp (Binop.Mult, Exp.Var id, e2) in + | `MulAssign -> + let e1_mul_e2 = Exp.BinOp (Binop.Mult, Exp.Var id, e2) in (e1, [Sil.Store (e1, typ, e1_mul_e2, loc)]) - | `DivAssign - -> let e1_div_e2 = Exp.BinOp (Binop.Div, Exp.Var id, e2) in + | `DivAssign -> + let e1_div_e2 = Exp.BinOp (Binop.Div, Exp.Var id, e2) in (e1, [Sil.Store (e1, typ, e1_div_e2, loc)]) - | `ShlAssign - -> let e1_shl_e2 = Exp.BinOp (Binop.Shiftlt, Exp.Var id, e2) in + | `ShlAssign -> + let e1_shl_e2 = Exp.BinOp (Binop.Shiftlt, Exp.Var id, e2) in (e1, [Sil.Store (e1, typ, e1_shl_e2, loc)]) - | `ShrAssign - -> let e1_shr_e2 = Exp.BinOp (Binop.Shiftrt, Exp.Var id, e2) in + | `ShrAssign -> + let e1_shr_e2 = Exp.BinOp (Binop.Shiftrt, Exp.Var id, e2) in (e1, [Sil.Store (e1, typ, e1_shr_e2, loc)]) - | `RemAssign - -> let e1_mod_e2 = Exp.BinOp (Binop.Mod, Exp.Var id, e2) in + | `RemAssign -> + let e1_mod_e2 = Exp.BinOp (Binop.Mod, Exp.Var id, e2) in (e1, [Sil.Store (e1, typ, e1_mod_e2, loc)]) - | `AndAssign - -> let e1_and_e2 = Exp.BinOp (Binop.BAnd, Exp.Var id, e2) in + | `AndAssign -> + let e1_and_e2 = Exp.BinOp (Binop.BAnd, Exp.Var id, e2) in (e1, [Sil.Store (e1, typ, e1_and_e2, loc)]) - | `OrAssign - -> let e1_or_e2 = Exp.BinOp (Binop.BOr, Exp.Var id, e2) in + | `OrAssign -> + let e1_or_e2 = Exp.BinOp (Binop.BOr, Exp.Var id, e2) in (e1, [Sil.Store (e1, typ, e1_or_e2, loc)]) - | `XorAssign - -> let e1_xor_e2 = Exp.BinOp (Binop.BXor, Exp.Var id, e2) in + | `XorAssign -> + let e1_xor_e2 = Exp.BinOp (Binop.BXor, Exp.Var id, e2) in (e1, [Sil.Store (e1, typ, e1_xor_e2, loc)]) - | _ - -> assert false + | _ -> + assert false in (e_res, instr1 :: instr_op) + (* Returns a pair ([binary_expression], instructions). "binary_expression" *) (* is returned when we are calculating an expression "instructions" is not *) (* empty when the binary operator is actually a statement like an *) @@ -104,48 +106,48 @@ let compound_assignment_binary_operation_instruction boi e1 typ e2 loc = let binary_operation_instruction boi e1 typ e2 loc rhs_owning_method = let binop_exp op = Exp.BinOp (op, e1, e2) in match boi.Clang_ast_t.boi_kind with - | `Add - -> (binop_exp Binop.PlusA, []) - | `Mul - -> (binop_exp Binop.Mult, []) - | `Div - -> (binop_exp Binop.Div, []) - | `Rem - -> (binop_exp Binop.Mod, []) - | `Sub - -> (binop_exp Binop.MinusA, []) - | `Shl - -> (binop_exp Binop.Shiftlt, []) - | `Shr - -> (binop_exp Binop.Shiftrt, []) - | `Or - -> (binop_exp Binop.BOr, []) - | `And - -> (binop_exp Binop.BAnd, []) - | `Xor - -> (binop_exp Binop.BXor, []) - | `LT - -> (binop_exp Binop.Lt, []) - | `GT - -> (binop_exp Binop.Gt, []) - | `LE - -> (binop_exp Binop.Le, []) - | `GE - -> (binop_exp Binop.Ge, []) - | `NE - -> (binop_exp Binop.Ne, []) - | `EQ - -> (binop_exp Binop.Eq, []) - | `LAnd - -> (binop_exp Binop.LAnd, []) - | `LOr - -> (binop_exp Binop.LOr, []) - | `Assign - -> if !Config.arc_mode && ObjcInterface_decl.is_pointer_to_objc_class typ then + | `Add -> + (binop_exp Binop.PlusA, []) + | `Mul -> + (binop_exp Binop.Mult, []) + | `Div -> + (binop_exp Binop.Div, []) + | `Rem -> + (binop_exp Binop.Mod, []) + | `Sub -> + (binop_exp Binop.MinusA, []) + | `Shl -> + (binop_exp Binop.Shiftlt, []) + | `Shr -> + (binop_exp Binop.Shiftrt, []) + | `Or -> + (binop_exp Binop.BOr, []) + | `And -> + (binop_exp Binop.BAnd, []) + | `Xor -> + (binop_exp Binop.BXor, []) + | `LT -> + (binop_exp Binop.Lt, []) + | `GT -> + (binop_exp Binop.Gt, []) + | `LE -> + (binop_exp Binop.Le, []) + | `GE -> + (binop_exp Binop.Ge, []) + | `NE -> + (binop_exp Binop.Ne, []) + | `EQ -> + (binop_exp Binop.Eq, []) + | `LAnd -> + (binop_exp Binop.LAnd, []) + | `LOr -> + (binop_exp Binop.LOr, []) + | `Assign -> + if !Config.arc_mode && ObjcInterface_decl.is_pointer_to_objc_class typ then assignment_arc_mode e1 typ e2 loc rhs_owning_method false else (e1, [Sil.Store (e1, typ, e2, loc)]) - | `Comma - -> (e2, []) (* C99 6.5.17-2 *) + | `Comma -> + (e2, []) (* C99 6.5.17-2 *) | `MulAssign | `DivAssign | `RemAssign @@ -155,135 +157,139 @@ let binary_operation_instruction boi e1 typ e2 loc rhs_owning_method = | `ShrAssign | `AndAssign | `XorAssign - | `OrAssign - -> compound_assignment_binary_operation_instruction boi e1 typ e2 loc + | `OrAssign -> + compound_assignment_binary_operation_instruction boi e1 typ e2 loc (* We should not get here. *) (* These should be treated by compound_assignment_binary_operation_instruction*) - | bok - -> L.(debug Capture Medium) + | bok -> + L.(debug Capture Medium) "@\nWARNING: Missing translation for Binary Operator Kind %s. Construct ignored...@\n" (Clang_ast_j.string_of_binary_operator_kind bok) ; (Exp.minus_one, []) + let unary_operation_instruction translation_unit_context uoi e typ loc = let un_exp op = Exp.UnOp (op, e, Some typ) in match uoi.Clang_ast_t.uoi_kind with - | `PostInc - -> let id = Ident.create_fresh Ident.knormal in + | `PostInc -> + let id = Ident.create_fresh Ident.knormal in let instr1 = Sil.Load (id, e, typ, loc) in let e_plus_1 = Exp.BinOp (Binop.PlusA, Exp.Var id, Exp.Const (Const.Cint IntLit.one)) in (Exp.Var id, [instr1; Sil.Store (e, typ, e_plus_1, loc)]) - | `PreInc - -> let id = Ident.create_fresh Ident.knormal in + | `PreInc -> + let id = Ident.create_fresh Ident.knormal in let instr1 = Sil.Load (id, e, typ, loc) in let e_plus_1 = Exp.BinOp (Binop.PlusA, Exp.Var id, Exp.Const (Const.Cint IntLit.one)) in let exp = if CGeneral_utils.is_cpp_translation translation_unit_context then e else e_plus_1 in (exp, [instr1; Sil.Store (e, typ, e_plus_1, loc)]) - | `PostDec - -> let id = Ident.create_fresh Ident.knormal in + | `PostDec -> + let id = Ident.create_fresh Ident.knormal in let instr1 = Sil.Load (id, e, typ, loc) in let e_minus_1 = Exp.BinOp (Binop.MinusA, Exp.Var id, Exp.Const (Const.Cint IntLit.one)) in (Exp.Var id, [instr1; Sil.Store (e, typ, e_minus_1, loc)]) - | `PreDec - -> let id = Ident.create_fresh Ident.knormal in + | `PreDec -> + let id = Ident.create_fresh Ident.knormal in let instr1 = Sil.Load (id, e, typ, loc) in let e_minus_1 = Exp.BinOp (Binop.MinusA, Exp.Var id, Exp.Const (Const.Cint IntLit.one)) in let exp = if CGeneral_utils.is_cpp_translation translation_unit_context then e else e_minus_1 in (exp, [instr1; Sil.Store (e, typ, e_minus_1, loc)]) - | `Not - -> (un_exp Unop.BNot, []) - | `Minus - -> (un_exp Unop.Neg, []) - | `Plus - -> (e, []) - | `LNot - -> (un_exp Unop.LNot, []) - | `Deref - -> (* Actual dereferencing is handled by implicit cast from rvalue to lvalue *) + | `Not -> + (un_exp Unop.BNot, []) + | `Minus -> + (un_exp Unop.Neg, []) + | `Plus -> + (e, []) + | `LNot -> + (un_exp Unop.LNot, []) + | `Deref -> + (* Actual dereferencing is handled by implicit cast from rvalue to lvalue *) (e, []) - | `AddrOf - -> (e, []) - | `Real | `Imag | `Extension | `Coawait - -> let uok = Clang_ast_j.string_of_unary_operator_kind uoi.Clang_ast_t.uoi_kind in + | `AddrOf -> + (e, []) + | `Real | `Imag | `Extension | `Coawait -> + let uok = Clang_ast_j.string_of_unary_operator_kind uoi.Clang_ast_t.uoi_kind in L.(debug Capture Medium) "@\nWARNING: Missing translation for Unary Operator Kind %s. The construct has been ignored...@\n" uok ; (e, []) + let bin_op_to_string boi = match boi.Clang_ast_t.boi_kind with - | `PtrMemD - -> "PtrMemD" - | `PtrMemI - -> "PtrMemI" - | `Mul - -> "Mul" - | `Div - -> "Div" - | `Rem - -> "Rem" - | `Add - -> "Add" - | `Sub - -> "Sub" - | `Shl - -> "Shl" - | `Shr - -> "Shr" - | `LT - -> "LT" - | `GT - -> "GT" - | `LE - -> "LE" - | `GE - -> "GE" - | `EQ - -> "EQ" - | `NE - -> "NE" - | `And - -> "And" - | `Xor - -> "Xor" - | `Or - -> "Or" - | `LAnd - -> "LAnd" - | `LOr - -> "LOr" - | `Assign - -> "Assign" - | `MulAssign - -> "MulAssign" - | `DivAssign - -> "DivAssign" - | `RemAssign - -> "RemAssing" - | `AddAssign - -> "AddAssign" - | `SubAssign - -> "SubAssign" - | `ShlAssign - -> "ShlAssign" - | `ShrAssign - -> "ShrAssign" - | `AndAssign - -> "AndAssign" - | `XorAssign - -> "XorAssign" - | `OrAssign - -> "OrAssign" - | `Comma - -> "Comma" + | `PtrMemD -> + "PtrMemD" + | `PtrMemI -> + "PtrMemI" + | `Mul -> + "Mul" + | `Div -> + "Div" + | `Rem -> + "Rem" + | `Add -> + "Add" + | `Sub -> + "Sub" + | `Shl -> + "Shl" + | `Shr -> + "Shr" + | `LT -> + "LT" + | `GT -> + "GT" + | `LE -> + "LE" + | `GE -> + "GE" + | `EQ -> + "EQ" + | `NE -> + "NE" + | `And -> + "And" + | `Xor -> + "Xor" + | `Or -> + "Or" + | `LAnd -> + "LAnd" + | `LOr -> + "LOr" + | `Assign -> + "Assign" + | `MulAssign -> + "MulAssign" + | `DivAssign -> + "DivAssign" + | `RemAssign -> + "RemAssing" + | `AddAssign -> + "AddAssign" + | `SubAssign -> + "SubAssign" + | `ShlAssign -> + "ShlAssign" + | `ShrAssign -> + "ShrAssign" + | `AndAssign -> + "AndAssign" + | `XorAssign -> + "XorAssign" + | `OrAssign -> + "OrAssign" + | `Comma -> + "Comma" + let sil_const_plus_one const = match const with - | Exp.Const Const.Cint n - -> Exp.Const (Const.Cint (IntLit.add n IntLit.one)) - | _ - -> Exp.BinOp (Binop.PlusA, const, Exp.Const (Const.Cint IntLit.one)) + | Exp.Const Const.Cint n -> + Exp.Const (Const.Cint (IntLit.add n IntLit.one)) + | _ -> + Exp.BinOp (Binop.PlusA, const, Exp.Const (Const.Cint IntLit.one)) + diff --git a/infer/src/clang/cAst_utils.ml b/infer/src/clang/cAst_utils.ml index 873ec0e3c..88dc3e299 100644 --- a/infer/src/clang/cAst_utils.ml +++ b/infer/src/clang/cAst_utils.ml @@ -22,6 +22,7 @@ let sanitize_name = Str.global_replace (Str.regexp "[/ ]") "_" let get_qual_name qual_name_list = List.map ~f:sanitize_name qual_name_list |> QualifiedCppName.of_rev_list + let get_qualified_name ?(linters_mode= false) name_info = if not linters_mode then get_qual_name name_info.Clang_ast_t.ni_qual_name else @@ -33,28 +34,32 @@ let get_qualified_name ?(linters_mode= false) name_info = let qual_names = List.map ~f:replace_template_chars name_info.Clang_ast_t.ni_qual_name in get_qual_name qual_names + let get_unqualified_name name_info = let name = match name_info.Clang_ast_t.ni_qual_name with - | name :: _ - -> name - | [] - -> name_info.Clang_ast_t.ni_name + | name :: _ -> + name + | [] -> + name_info.Clang_ast_t.ni_name in sanitize_name name + let get_class_name_from_member member_name_info = match member_name_info.Clang_ast_t.ni_qual_name with - | _ :: class_qual_list - -> get_qual_name class_qual_list - | [] - -> assert false + | _ :: class_qual_list -> + get_qual_name class_qual_list + | [] -> + assert false + let make_name_decl name = {Clang_ast_t.ni_name= name; ni_qual_name= [name]} let make_qual_name_decl class_name_quals name = {Clang_ast_t.ni_name= name; ni_qual_name= name :: class_name_quals} + let pointer_counter = ref 0 let get_fresh_pointer () = @@ -62,30 +67,36 @@ let get_fresh_pointer () = let internal_pointer = - !pointer_counter in internal_pointer + let get_invalid_pointer () = CFrontend_config.invalid_pointer let type_from_unary_expr_or_type_trait_expr_info info = match info.Clang_ast_t.uttei_qual_type with Some tp -> Some tp | None -> None + let get_decl decl_ptr = Int.Table.find ClangPointers.pointer_decl_table decl_ptr let get_decl_opt decl_ptr_opt = match decl_ptr_opt with Some decl_ptr -> get_decl decl_ptr | None -> None + let get_stmt stmt_ptr = let stmt = Int.Table.find ClangPointers.pointer_stmt_table stmt_ptr in if Option.is_none stmt then L.internal_error "stmt with pointer %d not found@\n" stmt_ptr ; stmt + let get_stmt_opt stmt_ptr_opt = match stmt_ptr_opt with Some stmt_ptr -> get_stmt stmt_ptr | None -> None + let get_decl_opt_with_decl_ref decl_ref_opt = match decl_ref_opt with - | Some decl_ref - -> get_decl decl_ref.Clang_ast_t.dr_decl_pointer - | None - -> None + | Some decl_ref -> + get_decl decl_ref.Clang_ast_t.dr_decl_pointer + | None -> + None + let get_property_of_ivar decl_ptr = Int.Table.find ClangPointers.ivar_to_property_table decl_ptr @@ -93,6 +104,7 @@ let update_sil_types_map type_ptr sil_type = CFrontend_config.sil_types_map := Clang_ast_extend.TypePointerMap.add type_ptr sil_type !CFrontend_config.sil_types_map + let update_enum_map enum_constant_pointer sil_exp = let predecessor_pointer_opt, _ = ClangPointers.Map.find_exn !CFrontend_config.enum_map enum_constant_pointer @@ -102,86 +114,97 @@ let update_enum_map enum_constant_pointer sil_exp = := ClangPointers.Map.add !CFrontend_config.enum_map ~key:enum_constant_pointer ~data:enum_map_value + let add_enum_constant enum_constant_pointer predecessor_pointer_opt = let enum_map_value = (predecessor_pointer_opt, None) in CFrontend_config.enum_map := ClangPointers.Map.add !CFrontend_config.enum_map ~key:enum_constant_pointer ~data:enum_map_value + let get_enum_constant_exp enum_constant_pointer = ClangPointers.Map.find_exn !CFrontend_config.enum_map enum_constant_pointer + let get_type type_ptr = (* There is chance for success only if type_ptr is in fact clang pointer *) match type_ptr with - | Clang_ast_types.TypePtr.Ptr raw_ptr - -> let typ = Int.Table.find ClangPointers.pointer_type_table raw_ptr in + | Clang_ast_types.TypePtr.Ptr raw_ptr -> + let typ = Int.Table.find ClangPointers.pointer_type_table raw_ptr in if Option.is_none typ then L.internal_error "type with pointer %d not found@\n" raw_ptr ; typ - | _ - -> (* otherwise, function fails *) + | _ -> + (* otherwise, function fails *) let type_str = Clang_ast_extend.type_ptr_to_string type_ptr in - L.(debug Capture Medium) "type %s is not clang pointer@\n" type_str ; None + L.(debug Capture Medium) "type %s is not clang pointer@\n" type_str ; + None + let get_desugared_type type_ptr = let typ_opt = get_type type_ptr in match typ_opt with | Some typ - -> ( + -> ( let type_info = Clang_ast_proj.get_type_tuple typ in match type_info.Clang_ast_t.ti_desugared_type with Some ptr -> get_type ptr | _ -> typ_opt ) - | _ - -> typ_opt + | _ -> + typ_opt + let get_decl_from_typ_ptr typ_ptr = let typ_opt = get_desugared_type typ_ptr in let typ = match typ_opt with Some t -> t | _ -> assert false in match (typ : Clang_ast_t.c_type) with - | RecordType (_, decl_ptr) | ObjCInterfaceType (_, decl_ptr) - -> get_decl decl_ptr - | _ - -> None + | RecordType (_, decl_ptr) | ObjCInterfaceType (_, decl_ptr) -> + get_decl decl_ptr + | _ -> + None + let sil_annot_of_type {Clang_ast_t.qt_type_ptr} = let default_visibility = true in let mk_annot annot_name_opt = match annot_name_opt with - | Some annot_name - -> [({Annot.class_name= annot_name; parameters= []}, default_visibility)] - | None - -> Annot.Item.empty + | Some annot_name -> + [({Annot.class_name= annot_name; parameters= []}, default_visibility)] + | None -> + Annot.Item.empty in let annot_name_opt = match get_type qt_type_ptr with - | Some AttributedType (_, attr_info) - -> if attr_info.ati_attr_kind = `Nullable then Some Annotations.nullable + | Some AttributedType (_, attr_info) -> + if attr_info.ati_attr_kind = `Nullable then Some Annotations.nullable else if attr_info.ati_attr_kind = `Nonnull then Some Annotations.nonnull (* other annotations go here *) else None - | _ - -> None + | _ -> + None in mk_annot annot_name_opt + let name_of_typedef_type_info {Clang_ast_t.tti_decl_ptr} = match get_decl tti_decl_ptr with - | Some TypedefDecl (_, name_decl_info, _, _) - -> get_qualified_name name_decl_info - | _ - -> QualifiedCppName.empty + | Some TypedefDecl (_, name_decl_info, _, _) -> + get_qualified_name name_decl_info + | _ -> + QualifiedCppName.empty + let name_opt_of_typedef_qual_type qual_type = match get_type qual_type.Clang_ast_t.qt_type_ptr with - | Some Clang_ast_t.TypedefType (_, typedef_type_info) - -> Some (name_of_typedef_type_info typedef_type_info) - | _ - -> None + | Some Clang_ast_t.TypedefType (_, typedef_type_info) -> + Some (name_of_typedef_type_info typedef_type_info) + | _ -> + None + let string_of_qual_type {Clang_ast_t.qt_type_ptr; qt_is_const} = Printf.sprintf "%s%s" (if qt_is_const then "is_const " else "") (Clang_ast_extend.type_ptr_to_string qt_type_ptr) + let qual_type_of_decl_ptr decl_ptr = { (* This function needs to be in this module - CAst_utils can't depend on Ast_expressions *) @@ -190,21 +213,25 @@ let qual_type_of_decl_ptr decl_ptr = ; qt_is_volatile= false ; qt_is_restrict= false } + let add_type_from_decl_ref qual_type_to_sil_type tenv dr = let qual_type = qual_type_of_decl_ptr dr.Clang_ast_t.dr_decl_pointer in ignore (qual_type_to_sil_type tenv qual_type) + let add_type_from_decl_ref_opt qual_type_to_sil_type tenv decl_ref_opt fail_if_not_found = match decl_ref_opt with (* translate interface first if found *) - | Some dr - -> add_type_from_decl_ref qual_type_to_sil_type tenv dr - | _ - -> if fail_if_not_found then assert false else () + | Some dr -> + add_type_from_decl_ref qual_type_to_sil_type tenv dr + | _ -> + if fail_if_not_found then assert false else () + let add_type_from_decl_ref_list qual_type_to_sil_type tenv decl_ref_list = List.iter ~f:(add_type_from_decl_ref qual_type_to_sil_type tenv) decl_ref_list + let get_function_decl_with_body decl_ptr = let open Clang_ast_t in let decl_opt = get_decl decl_ptr in @@ -214,14 +241,15 @@ let get_function_decl_with_body decl_ptr = | Some CXXMethodDecl (_, _, _, fdecl_info, _) | Some CXXConstructorDecl (_, _, _, fdecl_info, _) | Some CXXConversionDecl (_, _, _, fdecl_info, _) - | Some CXXDestructorDecl (_, _, _, fdecl_info, _) - -> fdecl_info.Clang_ast_t.fdi_decl_ptr_with_body - | _ - -> Some decl_ptr + | Some CXXDestructorDecl (_, _, _, fdecl_info, _) -> + fdecl_info.Clang_ast_t.fdi_decl_ptr_with_body + | _ -> + Some decl_ptr in if [%compare.equal : int option] decl_ptr' (Some decl_ptr) then decl_opt else get_decl_opt decl_ptr' + let get_info_from_decl_ref decl_ref = let name_info = match decl_ref.Clang_ast_t.dr_name with Some ni -> ni | _ -> assert false in let decl_ptr = decl_ref.Clang_ast_t.dr_decl_pointer in @@ -230,6 +258,7 @@ let get_info_from_decl_ref decl_ref = in (name_info, decl_ptr, qual_type) + (* st |= EF (atomic_pred param) *) let rec exists_eventually_st atomic_pred param st = if atomic_pred param st then true @@ -237,35 +266,41 @@ let rec exists_eventually_st atomic_pred param st = let _, st_list = Clang_ast_proj.get_stmt_tuple st in List.exists ~f:(exists_eventually_st atomic_pred param) st_list + let is_syntactically_global_var decl = match decl with - | Clang_ast_t.VarDecl (_, _, _, vdi) - -> vdi.vdi_is_global && not vdi.vdi_is_static_local - | _ - -> false + | Clang_ast_t.VarDecl (_, _, _, vdi) -> + vdi.vdi_is_global && not vdi.vdi_is_static_local + | _ -> + false + let is_static_local_var decl = match decl with Clang_ast_t.VarDecl (_, _, _, vdi) -> vdi.vdi_is_static_local | _ -> false + let is_const_expr_var decl = match decl with Clang_ast_t.VarDecl (_, _, _, vdi) -> vdi.vdi_is_const_expr | _ -> false + let full_name_of_decl_opt decl_opt = match decl_opt with | Some decl -> ( match Clang_ast_proj.get_named_decl_tuple decl with - | Some (_, name_info) - -> get_qualified_name name_info - | None - -> QualifiedCppName.empty ) - | None - -> QualifiedCppName.empty + | Some (_, name_info) -> + get_qualified_name name_info + | None -> + QualifiedCppName.empty ) + | None -> + QualifiedCppName.empty + (* Generates a unique number for each variant of a type. *) let get_tag ast_item = let item_rep = Obj.repr ast_item in if Obj.is_block item_rep then Obj.tag item_rep else -Obj.obj item_rep + (* Generates a key for a statement based on its sub-statements and the statement tag. *) let rec generate_key_stmt stmt = let tag_str = string_of_int (get_tag stmt) in @@ -276,6 +311,7 @@ let rec generate_key_stmt stmt = List.iter ~f:(fun tag -> Buffer.add_string buffer tag) tags ; Buffer.contents buffer + (* Generates a key for a declaration based on its name and the declaration tag. *) let generate_key_decl decl = let buffer = Buffer.create 16 in @@ -284,18 +320,20 @@ let generate_key_decl decl = Buffer.add_string buffer (QualifiedCppName.to_qual_string name) ; Buffer.contents buffer + let rec get_super_if decl = match decl with - | Some Clang_ast_t.ObjCImplementationDecl (_, _, _, _, impl_decl_info) - -> (* Try getting the super ref through the impl info, and fall back to + | Some Clang_ast_t.ObjCImplementationDecl (_, _, _, _, impl_decl_info) -> + (* Try getting the super ref through the impl info, and fall back to getting the if decl first and getting the super ref through it. *) let super_ref = get_decl_opt_with_decl_ref impl_decl_info.oidi_super in if Option.is_some super_ref then super_ref else get_super_if (get_decl_opt_with_decl_ref impl_decl_info.oidi_class_interface) - | Some Clang_ast_t.ObjCInterfaceDecl (_, _, _, _, interface_decl_info) - -> get_decl_opt_with_decl_ref interface_decl_info.otdi_super - | _ - -> None + | Some Clang_ast_t.ObjCInterfaceDecl (_, _, _, _, interface_decl_info) -> + get_decl_opt_with_decl_ref interface_decl_info.otdi_super + | _ -> + None + let get_super_impl impl_decl_info = let objc_interface_decl_current = @@ -304,16 +342,17 @@ let get_super_impl impl_decl_info = let objc_interface_decl_super = get_super_if objc_interface_decl_current in let objc_implementation_decl_super = match objc_interface_decl_super with - | Some ObjCInterfaceDecl (_, _, _, _, interface_decl_info) - -> get_decl_opt_with_decl_ref interface_decl_info.otdi_implementation - | _ - -> None + | Some ObjCInterfaceDecl (_, _, _, _, interface_decl_info) -> + get_decl_opt_with_decl_ref interface_decl_info.otdi_implementation + | _ -> + None in match objc_implementation_decl_super with - | Some ObjCImplementationDecl (_, _, decl_list, _, impl_decl_info) - -> Some (decl_list, impl_decl_info) - | _ - -> None + | Some ObjCImplementationDecl (_, _, decl_list, _, impl_decl_info) -> + Some (decl_list, impl_decl_info) + | _ -> + None + let get_super_ObjCImplementationDecl impl_decl_info = let objc_interface_decl_current = @@ -322,16 +361,18 @@ let get_super_ObjCImplementationDecl impl_decl_info = let objc_interface_decl_super = get_super_if objc_interface_decl_current in let objc_implementation_decl_super = match objc_interface_decl_super with - | Some ObjCInterfaceDecl (_, _, _, _, interface_decl_info) - -> get_decl_opt_with_decl_ref interface_decl_info.otdi_implementation - | _ - -> None + | Some ObjCInterfaceDecl (_, _, _, _, interface_decl_info) -> + get_decl_opt_with_decl_ref interface_decl_info.otdi_implementation + | _ -> + None in objc_implementation_decl_super + let get_impl_decl_info dec = match dec with Clang_ast_t.ObjCImplementationDecl (_, _, _, _, idi) -> Some idi | _ -> None + let default_blacklist = CFrontend_config.([nsobject_cl; nsproxy_cl]) let rec is_objc_if_descendant ?(blacklist= default_blacklist) if_decl ancestors = @@ -341,28 +382,31 @@ let rec is_objc_if_descendant ?(blacklist= default_blacklist) if_decl ancestors L.(die InternalError) "Blacklist and ancestors must be mutually exclusive." else match if_decl with - | Some Clang_ast_t.ObjCInterfaceDecl (_, ndi, _, _, _) - -> let in_list some_list = List.mem ~equal:String.equal some_list ndi.Clang_ast_t.ni_name in + | Some Clang_ast_t.ObjCInterfaceDecl (_, ndi, _, _, _) -> + let in_list some_list = List.mem ~equal:String.equal some_list ndi.Clang_ast_t.ni_name in not (in_list blacklist) && (in_list ancestors || is_objc_if_descendant ~blacklist (get_super_if if_decl) ancestors) - | _ - -> false + | _ -> + false + let rec qual_type_to_objc_interface qual_type = let typ_opt = get_desugared_type qual_type.Clang_ast_t.qt_type_ptr in ctype_to_objc_interface typ_opt + and ctype_to_objc_interface typ_opt = match (typ_opt : Clang_ast_t.c_type option) with - | Some ObjCInterfaceType (_, decl_ptr) - -> get_decl decl_ptr - | Some ObjCObjectPointerType (_, (inner_qual_type: Clang_ast_t.qual_type)) - -> qual_type_to_objc_interface inner_qual_type + | Some ObjCInterfaceType (_, decl_ptr) -> + get_decl decl_ptr + | Some ObjCObjectPointerType (_, (inner_qual_type: Clang_ast_t.qual_type)) -> + qual_type_to_objc_interface inner_qual_type | Some FunctionProtoType (_, function_type_info, _) - | Some FunctionNoProtoType (_, function_type_info) - -> qual_type_to_objc_interface function_type_info.Clang_ast_t.fti_return_type - | _ - -> None + | Some FunctionNoProtoType (_, function_type_info) -> + qual_type_to_objc_interface function_type_info.Clang_ast_t.fti_return_type + | _ -> + None + let qual_type_is_typedef_named qual_type (type_name: string) : bool = let is_decl_name_match decl_opt = @@ -372,56 +416,63 @@ let qual_type_is_typedef_named qual_type (type_name: string) : bool = match tuple_opt with Some (_, ni) -> String.equal type_name ni.ni_name | _ -> false in match get_type qual_type.Clang_ast_t.qt_type_ptr with - | Some TypedefType (_, tti) - -> let decl_opt = get_decl tti.tti_decl_ptr in + | Some TypedefType (_, tti) -> + let decl_opt = get_decl tti.tti_decl_ptr in is_decl_name_match decl_opt - | _ - -> false + | _ -> + false + let if_decl_to_di_pointer_opt if_decl = match if_decl with - | Some Clang_ast_t.ObjCInterfaceDecl (if_decl_info, _, _, _, _) - -> Some if_decl_info.di_pointer - | _ - -> None + | Some Clang_ast_t.ObjCInterfaceDecl (if_decl_info, _, _, _, _) -> + Some if_decl_info.di_pointer + | _ -> + None + let is_instance_type qual_type = match name_opt_of_typedef_qual_type qual_type with - | Some name - -> String.equal (QualifiedCppName.to_qual_string name) "instancetype" - | None - -> false + | Some name -> + String.equal (QualifiedCppName.to_qual_string name) "instancetype" + | None -> + false + let return_type_matches_class_type result_type interface_decl = if is_instance_type result_type then true else let return_type_decl_opt = qual_type_to_objc_interface result_type in [%compare.equal : int option] - (if_decl_to_di_pointer_opt interface_decl) (if_decl_to_di_pointer_opt return_type_decl_opt) + (if_decl_to_di_pointer_opt interface_decl) + (if_decl_to_di_pointer_opt return_type_decl_opt) + let is_objc_factory_method ~class_decl:interface_decl ~method_decl:meth_decl_opt = let open Clang_ast_t in match meth_decl_opt with - | Some ObjCMethodDecl (_, _, omdi) - -> not omdi.omdi_is_instance_method + | Some ObjCMethodDecl (_, _, omdi) -> + not omdi.omdi_is_instance_method && return_type_matches_class_type omdi.omdi_result_type interface_decl - | _ - -> false + | _ -> + false + let name_of_decl_ref_opt (decl_ref_opt: Clang_ast_t.decl_ref option) = match decl_ref_opt with | Some decl_ref -> ( match decl_ref.dr_name with Some named_decl_info -> Some named_decl_info.ni_name | _ -> None ) - | _ - -> None + | _ -> + None + let type_of_decl decl = let open Clang_ast_t in match decl with - | ObjCMethodDecl (_, _, obj_c_method_decl_info) - -> Some obj_c_method_decl_info.omdi_result_type.qt_type_ptr - | ObjCPropertyDecl (_, _, obj_c_property_decl_info) - -> Some obj_c_property_decl_info.opdi_qual_type.qt_type_ptr + | ObjCMethodDecl (_, _, obj_c_method_decl_info) -> + Some obj_c_method_decl_info.omdi_result_type.qt_type_ptr + | ObjCPropertyDecl (_, _, obj_c_property_decl_info) -> + Some obj_c_property_decl_info.opdi_qual_type.qt_type_ptr | EnumDecl (_, _, type_ptr, _, _, _, _) | RecordDecl (_, _, type_ptr, _, _, _, _) | CXXRecordDecl (_, _, type_ptr, _, _, _, _, _) @@ -431,8 +482,8 @@ let type_of_decl decl = | ObjCTypeParamDecl (_, _, type_ptr) | TypeAliasDecl (_, _, type_ptr) | TypedefDecl (_, _, type_ptr, _) - | UnresolvedUsingTypenameDecl (_, _, type_ptr) - -> Some type_ptr + | UnresolvedUsingTypenameDecl (_, _, type_ptr) -> + Some type_ptr | BindingDecl (_, _, qual_type) | FieldDecl (_, _, qual_type, _) | ObjCAtDefsFieldDecl (_, _, qual_type, _) @@ -454,60 +505,67 @@ let type_of_decl decl = | EnumConstantDecl (_, _, qual_type, _) | IndirectFieldDecl (_, _, qual_type, _) | OMPDeclareReductionDecl (_, _, qual_type) - | UnresolvedUsingValueDecl (_, _, qual_type) - -> Some qual_type.qt_type_ptr - | _ - -> None + | UnresolvedUsingValueDecl (_, _, qual_type) -> + Some qual_type.qt_type_ptr + | _ -> + None + let get_record_fields decl = let open Clang_ast_t in match decl with | ClassTemplateSpecializationDecl (_, _, _, decl_list, _, _, _, _, _, _) | CXXRecordDecl (_, _, _, decl_list, _, _, _, _) - | RecordDecl (_, _, _, decl_list, _, _, _) - -> List.filter ~f:(function FieldDecl _ -> true | _ -> false) decl_list - | _ - -> [] + | RecordDecl (_, _, _, decl_list, _, _, _) -> + List.filter ~f:(function FieldDecl _ -> true | _ -> false) decl_list + | _ -> + [] + let get_cxx_base_classes decl = let open Clang_ast_t in match decl with | CXXRecordDecl (_, _, _, _, _, _, _, cxx_record_info) - | ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, cxx_record_info, _, _) - -> cxx_record_info.xrdi_bases - | _ - -> [] + | ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, cxx_record_info, _, _) -> + cxx_record_info.xrdi_bases + | _ -> + [] + let get_cxx_virtual_base_classes decl = let open Clang_ast_t in match decl with | CXXRecordDecl (_, _, _, _, _, _, _, cxx_record_info) - | ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, cxx_record_info, _, _) - -> cxx_record_info.xrdi_transitive_vbases - | _ - -> [] + | ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, cxx_record_info, _, _) -> + cxx_record_info.xrdi_transitive_vbases + | _ -> + [] + let is_std_vector qt = match get_decl_from_typ_ptr qt.Clang_ast_t.qt_type_ptr with | Some decl -> ( match Clang_ast_proj.get_named_decl_tuple decl with - | Some (_, qual_name) - -> String.equal qual_name.ni_name "vector" + | Some (_, qual_name) -> + String.equal qual_name.ni_name "vector" && List.mem ~equal:String.equal qual_name.ni_qual_name "std" - | None - -> false ) - | None - -> false + | None -> + false ) + | None -> + false + let has_block_attribute decl = let open Clang_ast_t in match decl with - | VarDecl (decl_info, _, _, _) - -> let attributes = decl_info.di_attributes in + | VarDecl (decl_info, _, _, _) -> + let attributes = decl_info.di_attributes in List.exists ~f:(fun attr -> match attr with BlocksAttr _ -> true | _ -> false) attributes - | _ - -> false + | _ -> + false + let is_implicit_decl decl = let decl_info = Clang_ast_proj.get_decl_tuple decl in decl_info.Clang_ast_t.di_is_implicit + diff --git a/infer/src/clang/cContext.ml b/infer/src/clang/cContext.ml index 0e771f439..1d4865bb9 100644 --- a/infer/src/clang/cContext.ml +++ b/infer/src/clang/cContext.ml @@ -58,6 +58,7 @@ let create_context translation_unit_context tenv cg cfg procdesc curr_class retu ; label_map= Hashtbl.create 17 ; vars_to_destroy } + let get_cfg context = context.cfg let get_cg context = context.cg @@ -68,66 +69,73 @@ let get_procdesc context = context.procdesc let rec is_objc_method context = match context.outer_context with - | Some outer_context - -> is_objc_method outer_context - | None - -> context.is_objc_method + | Some outer_context -> + is_objc_method outer_context + | None -> + context.is_objc_method + let rec is_objc_instance context = match context.outer_context with - | Some outer_context - -> is_objc_instance outer_context - | None - -> let attrs = Procdesc.get_attributes context.procdesc in + | Some outer_context -> + is_objc_instance outer_context + | None -> + let attrs = Procdesc.get_attributes context.procdesc in attrs.ProcAttributes.is_objc_instance_method + let rec get_curr_class context = match (context.curr_class, context.outer_context) with - | ContextNoCls, Some outer_context - -> get_curr_class outer_context - | _ - -> context.curr_class + | ContextNoCls, Some outer_context -> + get_curr_class outer_context + | _ -> + context.curr_class + let get_curr_class_decl_ptr curr_class = match curr_class with ContextClsDeclPtr ptr -> ptr | _ -> assert false + let get_curr_class_ptr curr_class = let decl_ptr = get_curr_class_decl_ptr curr_class in let get_ptr_from_decl_ref = function - | Some dr - -> dr.Clang_ast_t.dr_decl_pointer - | None - -> assert false + | Some dr -> + dr.Clang_ast_t.dr_decl_pointer + | None -> + assert false in (* Resolve categories to their class names *) match CAst_utils.get_decl decl_ptr with - | Some ObjCCategoryDecl (_, _, _, _, ocdi) - -> get_ptr_from_decl_ref ocdi.odi_class_interface - | Some ObjCCategoryImplDecl (_, _, _, _, ocidi) - -> get_ptr_from_decl_ref ocidi.ocidi_class_interface - | _ - -> decl_ptr + | Some ObjCCategoryDecl (_, _, _, _, ocdi) -> + get_ptr_from_decl_ref ocdi.odi_class_interface + | Some ObjCCategoryImplDecl (_, _, _, _, ocidi) -> + get_ptr_from_decl_ref ocidi.ocidi_class_interface + | _ -> + decl_ptr + let get_curr_class_typename context = let tenv = context.tenv in let curr_class = get_curr_class context in match get_curr_class_ptr curr_class |> CAst_utils.get_decl with - | Some decl - -> CType_decl.get_record_typename ~tenv decl - | None - -> assert false + | Some decl -> + CType_decl.get_record_typename ~tenv decl + | None -> + assert false + let curr_class_to_string curr_class = match curr_class with - | ContextClsDeclPtr ptr - -> "decl_ptr: " ^ string_of_int ptr - | ContextNoCls - -> "no class" + | ContextClsDeclPtr ptr -> + "decl_ptr: " ^ string_of_int ptr + | ContextNoCls -> + "no class" + let add_block_static_var context block_name static_var_typ = match (context.outer_context, static_var_typ) with - | Some outer_context, (static_var, _) when Pvar.is_global static_var - -> let new_static_vars, duplicate = + | Some outer_context, (static_var, _) when Pvar.is_global static_var -> + let new_static_vars, duplicate = try let static_vars = Typ.Procname.Map.find block_name outer_context.blocks_static_vars in if List.mem @@ -142,16 +150,19 @@ let add_block_static_var context block_name static_var_typ = Typ.Procname.Map.add block_name new_static_vars outer_context.blocks_static_vars in outer_context.blocks_static_vars <- blocks_static_vars - | _ - -> () + | _ -> + () + let static_vars_for_block context block_name = try Typ.Procname.Map.find block_name context.blocks_static_vars with Not_found -> [] + let rec get_outer_procname context = match context.outer_context with - | Some outer_context - -> get_outer_procname outer_context - | None - -> Procdesc.get_proc_name context.procdesc + | Some outer_context -> + get_outer_procname outer_context + | None -> + Procdesc.get_proc_name context.procdesc + diff --git a/infer/src/clang/cEnum_decl.ml b/infer/src/clang/cEnum_decl.ml index a50c4e68d..03d78f218 100644 --- a/infer/src/clang/cEnum_decl.ml +++ b/infer/src/clang/cEnum_decl.ml @@ -20,35 +20,40 @@ let add_enum_constant_to_map_if_needed decl_pointer pred_decl_opt = try ignore (CAst_utils.get_enum_constant_exp decl_pointer) ; true - with Not_found -> CAst_utils.add_enum_constant decl_pointer pred_decl_opt ; false + with Not_found -> + CAst_utils.add_enum_constant decl_pointer pred_decl_opt ; + false + (* Add the constants of this enum to the map if they are not in the map yet *) let enum_decl decl = let open Clang_ast_t in let get_constant_decl_ptr decl = match decl with - | EnumConstantDecl (decl_info, _, _, _) - -> decl_info.di_pointer - | _ - -> assert false + | EnumConstantDecl (decl_info, _, _, _) -> + decl_info.di_pointer + | _ -> + assert false in let rec add_enum_constants_to_map decl_list = match decl_list with - | decl :: pred_decl :: rest - -> let decl_pointer = get_constant_decl_ptr decl in + | decl :: pred_decl :: rest -> + let decl_pointer = get_constant_decl_ptr decl in let pred_decl_pointer = get_constant_decl_ptr pred_decl in if not (add_enum_constant_to_map_if_needed decl_pointer (Some pred_decl_pointer)) then add_enum_constants_to_map (pred_decl :: rest) - | [decl] - -> let decl_pointer = get_constant_decl_ptr decl in + | [decl] -> + let decl_pointer = get_constant_decl_ptr decl in ignore (add_enum_constant_to_map_if_needed decl_pointer None) - | _ - -> () + | _ -> + () in match decl with - | EnumDecl (_, _, type_ptr, decl_list, _, _, _) - -> add_enum_constants_to_map (List.rev decl_list) ; + | EnumDecl (_, _, type_ptr, decl_list, _, _, _) -> + add_enum_constants_to_map (List.rev decl_list) ; let sil_desc = Typ.Tint Typ.IInt in - CAst_utils.update_sil_types_map type_ptr sil_desc ; sil_desc - | _ - -> assert false + CAst_utils.update_sil_types_map type_ptr sil_desc ; + sil_desc + | _ -> + assert false + diff --git a/infer/src/clang/cField_decl.ml b/infer/src/clang/cField_decl.ml index 276532e4b..01a7b86f8 100644 --- a/infer/src/clang/cField_decl.ml +++ b/infer/src/clang/cField_decl.ml @@ -19,49 +19,52 @@ let rec get_fields_super_classes tenv super_class = L.(debug Capture Verbose) " ... Getting fields of superclass '%s'@\n" (Typ.Name.to_string super_class) ; match Tenv.lookup tenv super_class with - | None - -> [] - | Some {fields; supers= super_class :: _} - -> let sc_fields = get_fields_super_classes tenv super_class in + | None -> + [] + | Some {fields; supers= super_class :: _} -> + let sc_fields = get_fields_super_classes tenv super_class in CGeneral_utils.append_no_duplicates_fields fields sc_fields - | Some {fields} - -> fields + | Some {fields} -> + fields + let fields_superclass tenv interface_decl_info = match interface_decl_info.Clang_ast_t.otdi_super with | Some dr -> ( match dr.Clang_ast_t.dr_name with - | Some sc - -> let classname = Typ.Name.Objc.from_qual_name (CAst_utils.get_qualified_name sc) in + | Some sc -> + let classname = Typ.Name.Objc.from_qual_name (CAst_utils.get_qualified_name sc) in get_fields_super_classes tenv classname - | _ - -> [] ) - | _ - -> [] + | _ -> + [] ) + | _ -> + [] + let build_sil_field qual_type_to_sil_type tenv class_tname field_name qual_type prop_attributes = let prop_atts = List.map ~f:Clang_ast_j.string_of_property_attribute prop_attributes in let annotation_from_type t = match t.Typ.desc with - | Typ.Tptr (_, Typ.Pk_objc_weak) - -> [Config.weak] - | Typ.Tptr (_, Typ.Pk_objc_unsafe_unretained) - -> [Config.unsafe_unret] - | _ - -> [] + | Typ.Tptr (_, Typ.Pk_objc_weak) -> + [Config.weak] + | Typ.Tptr (_, Typ.Pk_objc_unsafe_unretained) -> + [Config.unsafe_unret] + | _ -> + [] in let fname = CGeneral_utils.mk_class_field_name class_tname field_name.Clang_ast_t.ni_name in let typ = qual_type_to_sil_type tenv qual_type in let item_annotations = match prop_atts with - | [] - -> ({Annot.class_name= Config.ivar_attributes; parameters= annotation_from_type typ}, true) - | _ - -> ({Annot.class_name= Config.property_attributes; parameters= prop_atts}, true) + | [] -> + ({Annot.class_name= Config.ivar_attributes; parameters= annotation_from_type typ}, true) + | _ -> + ({Annot.class_name= Config.property_attributes; parameters= prop_atts}, true) in let item_annotations = item_annotations :: CAst_utils.sil_annot_of_type qual_type in (fname, typ, item_annotations) + (* Given a list of declarations in an interface returns a list of fields *) let rec get_fields qual_type_to_sil_type tenv class_tname decl_list = let open Clang_ast_t in @@ -73,39 +76,42 @@ let rec get_fields qual_type_to_sil_type tenv class_tname decl_list = CGeneral_utils.append_no_duplicates_fields [field_tuple] fields in match decl_list with - | [] - -> [] + | [] -> + [] | (ObjCPropertyDecl (_, _, obj_c_property_decl_info)) :: decl_list' - -> ( + -> ( let ivar_decl_ref = obj_c_property_decl_info.Clang_ast_t.opdi_ivar_decl in match CAst_utils.get_decl_opt_with_decl_ref ivar_decl_ref with - | Some ObjCIvarDecl (_, name_info, qual_type, _, _) - -> let attributes = obj_c_property_decl_info.Clang_ast_t.opdi_property_attributes in + | Some ObjCIvarDecl (_, name_info, qual_type, _, _) -> + let attributes = obj_c_property_decl_info.Clang_ast_t.opdi_property_attributes in add_field name_info qual_type attributes decl_list' - | _ - -> get_fields qual_type_to_sil_type tenv class_tname decl_list' ) - | (ObjCIvarDecl (_, name_info, qual_type, _, _)) :: decl_list' - -> add_field name_info qual_type [] decl_list' - | _ :: decl_list' - -> get_fields qual_type_to_sil_type tenv class_tname decl_list' + | _ -> + get_fields qual_type_to_sil_type tenv class_tname decl_list' ) + | (ObjCIvarDecl (_, name_info, qual_type, _, _)) :: decl_list' -> + add_field name_info qual_type [] decl_list' + | _ :: decl_list' -> + get_fields qual_type_to_sil_type tenv class_tname decl_list' + (* Add potential extra fields defined only in the implementation of the class *) (* to the info given in the interface. Update the tenv accordingly. *) let add_missing_fields tenv class_name missing_fields = let class_tn_name = Typ.Name.Objc.from_qual_name class_name in match Tenv.lookup tenv class_tn_name with - | Some ({fields} as struct_typ) - -> let new_fields = CGeneral_utils.append_no_duplicates_fields fields missing_fields in + | Some ({fields} as struct_typ) -> + let new_fields = CGeneral_utils.append_no_duplicates_fields fields missing_fields in ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:new_fields ~statics:[] class_tn_name) ; L.(debug Capture Verbose) " Updating info for class '%a' in tenv@\n" QualifiedCppName.pp class_name - | _ - -> () + | _ -> + () + let modelled_fields_in_classes = [ ("NSData", "_bytes", Typ.mk (Tptr (Typ.mk Tvoid, Typ.Pk_pointer))) ; ("NSArray", "elementData", Typ.mk (Tint Typ.IInt)) ] + let modelled_field class_name_info = let modelled_field_in_class res (class_name, field_name, typ) = if String.equal class_name class_name_info.Clang_ast_t.ni_name then @@ -115,3 +121,4 @@ let modelled_field class_name_info = else res in List.fold ~f:modelled_field_in_class ~init:[] modelled_fields_in_classes + diff --git a/infer/src/clang/cFrontend.ml b/infer/src/clang/cFrontend.ml index d9b0359a6..aec2d7716 100644 --- a/infer/src/clang/cFrontend.ml +++ b/infer/src/clang/cFrontend.ml @@ -17,8 +17,8 @@ and CFrontend_declImpl : CModule_type.CFrontend = CFrontend_decl.CFrontend_decl_ (* Translates a file by translating the ast into a cfg. *) let compute_icfg trans_unit_ctx tenv ast = match ast with - | Clang_ast_t.TranslationUnitDecl (_, decl_list, _, _) - -> CFrontend_config.global_translation_unit_decls := decl_list ; + | Clang_ast_t.TranslationUnitDecl (_, decl_list, _, _) -> + CFrontend_config.global_translation_unit_decls := decl_list ; L.(debug Capture Verbose) "@\n Start creating icfg@\n" ; let cg = Cg.create trans_unit_ctx.CFrontend_config.source_file in let cfg = Cfg.create_cfg () in @@ -27,8 +27,9 @@ let compute_icfg trans_unit_ctx tenv ast = decl_list ; L.(debug Capture Verbose) "@\n Finished creating icfg@\n" ; (cg, cfg) - | _ - -> assert false + | _ -> + assert false + (* NOTE: Assumes that an AST alsways starts with a TranslationUnitDecl *) @@ -37,6 +38,7 @@ let init_global_state_capture () = CFrontend_config.global_translation_unit_decls := [] ; CProcname.reset_block_counter () + let do_source_file translation_unit_context ast = let tenv = Tenv.create () in CType_decl.add_predefined_types tenv ; @@ -63,7 +65,10 @@ let do_source_file translation_unit_context ast = if Config.stats_mode then Cfg.check_cfg_connectedness cfg ; if Config.stats_mode || Config.debug_mode || Config.testing_mode || Config.frontend_tests || Option.is_some Config.icfg_dotty_outfile - then ( Dotty.print_icfg_dotty source_file cfg ; Cg.save_call_graph_dotty source_file call_graph ) ; + then ( + Dotty.print_icfg_dotty source_file cfg ; + Cg.save_call_graph_dotty source_file call_graph ) ; L.(debug Capture Verbose) "%a" Cfg.pp_proc_signatures cfg ; (* NOTE: nothing should be written to source_dir after this *) DB.mark_file_updated (DB.source_dir_to_string source_dir) + diff --git a/infer/src/clang/cFrontend_checkers.ml b/infer/src/clang/cFrontend_checkers.ml index 4d9b38c13..f0012c532 100644 --- a/infer/src/clang/cFrontend_checkers.ml +++ b/infer/src/clang/cFrontend_checkers.ml @@ -16,132 +16,145 @@ let location_from_stmt lctx stmt = CLocation.get_sil_location_from_range lctx.CLintersContext.translation_unit_context info.Clang_ast_t.si_source_range true + let location_from_dinfo lctx info = CLocation.get_sil_location_from_range lctx.CLintersContext.translation_unit_context info.Clang_ast_t.di_source_range true + let location_from_decl lctx dec = let info = Clang_ast_proj.get_decl_tuple dec in CLocation.get_sil_location_from_range lctx.CLintersContext.translation_unit_context info.Clang_ast_t.di_source_range true + let location_from_an lcxt an = match an with - | Ctl_parser_types.Stmt st - -> location_from_stmt lcxt st - | Ctl_parser_types.Decl d - -> location_from_decl lcxt d + | Ctl_parser_types.Stmt st -> + location_from_stmt lcxt st + | Ctl_parser_types.Decl d -> + location_from_decl lcxt d + let tag_name_of_node an = match an with - | Ctl_parser_types.Stmt stmt - -> Clang_ast_proj.get_stmt_kind_string stmt - | Ctl_parser_types.Decl decl - -> Clang_ast_proj.get_decl_kind_string decl + | Ctl_parser_types.Stmt stmt -> + Clang_ast_proj.get_stmt_kind_string stmt + | Ctl_parser_types.Decl decl -> + Clang_ast_proj.get_decl_kind_string decl + let decl_ref_or_selector_name an = match CTL.next_state_via_transition an CTL.PointerToDecl with - | [(Ctl_parser_types.Decl ObjCMethodDecl _ as decl_an)] - -> "The selector " ^ Ctl_parser_types.ast_node_name decl_an - | [(Ctl_parser_types.Decl _ as decl_an)] - -> "The reference " ^ Ctl_parser_types.ast_node_name decl_an - | _ - -> L.(die ExternalError) + | [(Ctl_parser_types.Decl ObjCMethodDecl _ as decl_an)] -> + "The selector " ^ Ctl_parser_types.ast_node_name decl_an + | [(Ctl_parser_types.Decl _ as decl_an)] -> + "The reference " ^ Ctl_parser_types.ast_node_name decl_an + | _ -> + L.(die ExternalError) "decl_ref_or_selector_name must be called with a DeclRefExpr or an ObjCMessageExpr, but got %s" (tag_name_of_node an) + let iphoneos_target_sdk_version context _ = match CPredicates.iphoneos_target_sdk_version_by_path context with Some f -> f | None -> "0" + let available_ios_sdk an = let open Ctl_parser_types in match CTL.next_state_via_transition an CTL.PointerToDecl with | [(Decl decl)] -> ( match CPredicates.get_available_attr_ios_sdk (Decl decl) with - | Some version - -> version - | None - -> "" ) - | _ - -> L.(die ExternalError) + | Some version -> + version + | None -> + "" ) + | _ -> + L.(die ExternalError) "available_ios_sdk must be called with a DeclRefExpr or an ObjCMessageExpr, but got %s" (tag_name_of_node an) + let class_available_ios_sdk an = match CPredicates.receiver_method_call an with | Some decl -> ( match CPredicates.get_available_attr_ios_sdk (Decl decl) with - | Some version - -> version - | None - -> "" ) - | None - -> L.(die ExternalError) + | Some version -> + version + | None -> + "" ) + | None -> + L.(die ExternalError) "class_available_ios_sdk must be called with ObjCMessageExpr, but got %s" (tag_name_of_node an) + let receiver_method_call an = match CPredicates.receiver_method_call an with - | Some decl - -> Ctl_parser_types.ast_node_name (Ctl_parser_types.Decl decl) - | _ - -> L.(die ExternalError) + | Some decl -> + Ctl_parser_types.ast_node_name (Ctl_parser_types.Decl decl) + | _ -> + L.(die ExternalError) "receiver_method_call must be called with ObjCMessageExpr, but got %s" (tag_name_of_node an) + let ivar_name an = let open Clang_ast_t in match an with | Ctl_parser_types.Stmt ObjCIvarRefExpr (_, _, _, rei) - -> ( + -> ( let dr_ref = rei.ovrei_decl_ref in let ivar_pointer = dr_ref.dr_decl_pointer in match CAst_utils.get_decl ivar_pointer with - | Some ObjCIvarDecl (_, named_decl_info, _, _, _) - -> named_decl_info.Clang_ast_t.ni_name - | _ - -> "" ) - | _ - -> "" + | Some ObjCIvarDecl (_, named_decl_info, _, _, _) -> + named_decl_info.Clang_ast_t.ni_name + | _ -> + "" ) + | _ -> + "" + let cxx_ref_captured_in_block an = let open Ctl_parser_types in let open Clang_ast_t in let capt_refs = match an with - | Decl _ - -> CPredicates.captured_variables_cxx_ref an - | Stmt BlockExpr (_, _, _, d) - -> CPredicates.captured_variables_cxx_ref (Decl d) - | _ - -> [] + | Decl _ -> + CPredicates.captured_variables_cxx_ref an + | Stmt BlockExpr (_, _, _, d) -> + CPredicates.captured_variables_cxx_ref (Decl d) + | _ -> + [] in let var_desc vars var_named_decl_info = vars ^ "'" ^ var_named_decl_info.ni_name ^ "'" in List.fold ~f:var_desc ~init:"" capt_refs + let class_name node = let open Clang_ast_t in let class_name_of_interface_type typ = match typ with | Some ObjCInterfaceType (_, ptr) -> ( match CAst_utils.get_decl ptr with - | Some ObjCInterfaceDecl (_, ndi, _, _, _) - -> ndi.ni_name - | _ - -> "" ) - | _ - -> "" + | Some ObjCInterfaceDecl (_, ndi, _, _, _) -> + ndi.ni_name + | _ -> + "" ) + | _ -> + "" in match CPredicates.get_ast_node_type_ptr node with | Some type_ptr - -> ( + -> ( let typ = CAst_utils.get_desugared_type type_ptr in match typ with - | Some ObjCObjectPointerType (_, {Clang_ast_t.qt_type_ptr}) - -> class_name_of_interface_type (CAst_utils.get_desugared_type qt_type_ptr) - | Some ObjCInterfaceType _ - -> class_name_of_interface_type typ - | _ - -> "" ) - | _ - -> "" + | Some ObjCObjectPointerType (_, {Clang_ast_t.qt_type_ptr}) -> + class_name_of_interface_type (CAst_utils.get_desugared_type qt_type_ptr) + | Some ObjCInterfaceType _ -> + class_name_of_interface_type typ + | _ -> + "" ) + | _ -> + "" + diff --git a/infer/src/clang/cFrontend_checkers_main.ml b/infer/src/clang/cFrontend_checkers_main.ml index dfce3b4b4..6babc782b 100644 --- a/infer/src/clang/cFrontend_checkers_main.ml +++ b/infer/src/clang/cFrontend_checkers_main.ml @@ -21,11 +21,13 @@ let rec parse_import_file import_file channel = { import_files= imports ; global_macros= curr_file_macros ; global_paths= curr_file_paths - ; checkers= _ } - -> already_imported_files := import_file :: !already_imported_files ; + ; checkers= _ } -> + already_imported_files := import_file :: !already_imported_files ; collect_all_macros_and_paths imports curr_file_macros curr_file_paths - | None - -> L.(debug Linters Medium) "No macros or paths found.@\n" ; ([], []) + | None -> + L.(debug Linters Medium) "No macros or paths found.@\n" ; + ([], []) + and collect_all_macros_and_paths imports curr_file_macros curr_file_paths = L.(debug Linters Medium) "#### Start parsing import macros #####@\n" ; @@ -35,6 +37,7 @@ and collect_all_macros_and_paths imports curr_file_macros curr_file_paths = let paths = List.append import_paths curr_file_paths in (macros, paths) + (* Parse import files with macro definitions, and it returns a list of LET clauses *) and parse_imports imports_files = let parse_one_import_file fimport (macros, paths) = @@ -48,14 +51,15 @@ and parse_imports imports_files = in List.fold_right ~f:parse_one_import_file ~init:([], []) imports_files + let parse_ctl_file linters_def_file channel : CFrontend_errors.linter list = match CTLParserHelper.parse_al_file linters_def_file channel with | Some { import_files= imports ; global_macros= curr_file_macros ; global_paths= curr_file_paths - ; checkers= parsed_checkers } - -> already_imported_files := [linters_def_file] ; + ; checkers= parsed_checkers } -> + already_imported_files := [linters_def_file] ; let macros, paths = collect_all_macros_and_paths imports curr_file_macros curr_file_paths in let macros_map = CFrontend_errors.build_macros_map macros in let paths_map = CFrontend_errors.build_paths_map paths in @@ -64,8 +68,10 @@ let parse_ctl_file linters_def_file channel : CFrontend_errors.linter list = L.(debug Linters Medium) "#### Checkers Expanded #####@\n" ; if Config.debug_mode then List.iter ~f:CTL.print_checker exp_checkers ; CFrontend_errors.create_parsed_linters linters_def_file exp_checkers - | None - -> L.(debug Linters Medium) "No linters found.@\n" ; [] + | None -> + L.(debug Linters Medium) "No linters found.@\n" ; + [] + (* Parse the files with linters definitions, and it returns a list of linters *) let parse_ctl_files linters_def_files : CFrontend_errors.linter list = @@ -73,85 +79,92 @@ let parse_ctl_files linters_def_files : CFrontend_errors.linter list = L.(debug Linters Medium) "Loading linters rules from %s@\n" linters_def_file ; let in_channel = In_channel.create linters_def_file in let parsed_linters = parse_ctl_file linters_def_file in_channel in - In_channel.close in_channel ; List.append parsed_linters linters + In_channel.close in_channel ; + List.append parsed_linters linters in List.fold_right ~f:collect_parsed_linters ~init:[] linters_def_files + let rec get_responds_to_selector stmt = let open Clang_ast_t in let responToSelectorMethods = ["respondsToSelector:"; "instancesRespondToSelector:"] in match stmt with | ObjCMessageExpr (_, [_; (ObjCSelectorExpr (_, _, _, method_name))], _, mdi) | ObjCMessageExpr (_, [(ObjCSelectorExpr (_, _, _, method_name))], _, mdi) - when List.mem ~equal:String.equal responToSelectorMethods mdi.Clang_ast_t.omei_selector - -> [method_name] + when List.mem ~equal:String.equal responToSelectorMethods mdi.Clang_ast_t.omei_selector -> + [method_name] | BinaryOperator (_, [stmt1; stmt2], _, bo_info) - when PVariant.( = ) bo_info.Clang_ast_t.boi_kind `LAnd - -> List.append (get_responds_to_selector stmt1) (get_responds_to_selector stmt2) + when PVariant.( = ) bo_info.Clang_ast_t.boi_kind `LAnd -> + List.append (get_responds_to_selector stmt1) (get_responds_to_selector stmt2) | ImplicitCastExpr (_, [stmt], _, _) | ParenExpr (_, [stmt], _) - | ExprWithCleanups (_, [stmt], _, _) - -> get_responds_to_selector stmt - | _ - -> [] + | ExprWithCleanups (_, [stmt], _, _) -> + get_responds_to_selector stmt + | _ -> + [] + let rec is_core_foundation_version_number stmt = let open Clang_ast_t in match stmt with | DeclRefExpr (_, _, _, decl_ref_info) -> ( match decl_ref_info.drti_decl_ref with - | Some decl_ref_info - -> let name_info, _, _ = CAst_utils.get_info_from_decl_ref decl_ref_info in + | Some decl_ref_info -> + let name_info, _, _ = CAst_utils.get_info_from_decl_ref decl_ref_info in String.equal name_info.ni_name "kCFCoreFoundationVersionNumber" - | None - -> false ) - | ImplicitCastExpr (_, [stmt], _, _) - -> is_core_foundation_version_number stmt - | _ - -> false + | None -> + false ) + | ImplicitCastExpr (_, [stmt], _, _) -> + is_core_foundation_version_number stmt + | _ -> + false + let rec current_os_version_constant stmt = let open Clang_ast_t in match stmt with - | FloatingLiteral (_, _, _, number) - -> CiOSVersionNumbers.version_of number - | IntegerLiteral (_, _, _, info) - -> CiOSVersionNumbers.version_of info.ili_value - | ImplicitCastExpr (_, [stmt], _, _) - -> current_os_version_constant stmt - | _ - -> None + | FloatingLiteral (_, _, _, number) -> + CiOSVersionNumbers.version_of number + | IntegerLiteral (_, _, _, info) -> + CiOSVersionNumbers.version_of info.ili_value + | ImplicitCastExpr (_, [stmt], _, _) -> + current_os_version_constant stmt + | _ -> + None + let rec get_current_os_version stmt = let open Clang_ast_t in match stmt with | BinaryOperator (_, [stmt1; stmt2], _, bo_info) - when PVariant.( = ) bo_info.Clang_ast_t.boi_kind `GE && is_core_foundation_version_number stmt1 - -> Option.to_list (current_os_version_constant stmt2) + when PVariant.( = ) bo_info.Clang_ast_t.boi_kind `GE && is_core_foundation_version_number stmt1 -> + Option.to_list (current_os_version_constant stmt2) | BinaryOperator (_, [stmt1; stmt2], _, bo_info) - when PVariant.( = ) bo_info.Clang_ast_t.boi_kind `LE && is_core_foundation_version_number stmt2 - -> Option.to_list (current_os_version_constant stmt1) + when PVariant.( = ) bo_info.Clang_ast_t.boi_kind `LE && is_core_foundation_version_number stmt2 -> + Option.to_list (current_os_version_constant stmt1) | BinaryOperator (_, [stmt1; stmt2], _, bo_info) - when PVariant.( = ) bo_info.Clang_ast_t.boi_kind `LAnd - -> List.append (get_current_os_version stmt1) (get_current_os_version stmt2) + when PVariant.( = ) bo_info.Clang_ast_t.boi_kind `LAnd -> + List.append (get_current_os_version stmt1) (get_current_os_version stmt2) | ImplicitCastExpr (_, [stmt], _, _) | ParenExpr (_, [stmt], _) - | ExprWithCleanups (_, [stmt], _, _) - -> get_current_os_version stmt - | _ - -> [] + | ExprWithCleanups (_, [stmt], _, _) -> + get_current_os_version stmt + | _ -> + [] + let rec get_ios_available_version stmt = let open Clang_ast_t in match stmt with - | ObjCAvailabilityCheckExpr (_, _, _, oacei) - -> oacei.oacei_version + | ObjCAvailabilityCheckExpr (_, _, _, oacei) -> + oacei.oacei_version | ImplicitCastExpr (_, [stmt], _, _) | ParenExpr (_, [stmt], _) - | ExprWithCleanups (_, [stmt], _, _) - -> get_ios_available_version stmt - | _ - -> None + | ExprWithCleanups (_, [stmt], _, _) -> + get_ios_available_version stmt + | _ -> + None + let compute_if_context (context: CLintersContext.context) stmt = let selector = get_responds_to_selector stmt in @@ -159,18 +172,18 @@ let compute_if_context (context: CLintersContext.context) stmt = match (CPredicates.get_selector (Stmt stmt), CPredicates.receiver_class_method_call (Stmt stmt)) with - | Some selector, Some receiver when String.equal selector "class" - -> Option.to_list (CPredicates.declaration_name receiver) - | _ - -> [] + | Some selector, Some receiver when String.equal selector "class" -> + Option.to_list (CPredicates.declaration_name receiver) + | _ -> + [] in let os_version = get_current_os_version stmt in let ios_available_version_opt = Option.to_list (get_ios_available_version stmt) in let os_version = List.append ios_available_version_opt os_version in let within_responds_to_selector_block, within_available_class_block, ios_version_guard = match context.if_context with - | Some if_context - -> let within_responds_to_selector_block = + | Some if_context -> + let within_responds_to_selector_block = List.append selector if_context.within_responds_to_selector_block in let within_available_class_block = @@ -178,13 +191,14 @@ let compute_if_context (context: CLintersContext.context) stmt = in let ios_version_guard = List.append os_version if_context.ios_version_guard in (within_responds_to_selector_block, within_available_class_block, ios_version_guard) - | None - -> (selector, receiver_class_method_call, os_version) + | None -> + (selector, receiver_class_method_call, os_version) in Some ( {within_responds_to_selector_block; within_available_class_block; ios_version_guard} : CLintersContext.if_context ) + let get_method_body_opt decl = let open Clang_ast_t in match decl with @@ -192,19 +206,21 @@ let get_method_body_opt decl = | CXXMethodDecl (_, _, _, fdi, _) | CXXConstructorDecl (_, _, _, fdi, _) | CXXConversionDecl (_, _, _, fdi, _) - | CXXDestructorDecl (_, _, _, fdi, _) - -> fdi.Clang_ast_t.fdi_body - | ObjCMethodDecl (_, _, mdi) - -> mdi.Clang_ast_t.omdi_body - | BlockDecl (_, block_decl_info) - -> block_decl_info.Clang_ast_t.bdi_body - | _ - -> Logging.die InternalError "Should only be called with method, but got %s" + | CXXDestructorDecl (_, _, _, fdi, _) -> + fdi.Clang_ast_t.fdi_body + | ObjCMethodDecl (_, _, mdi) -> + mdi.Clang_ast_t.omdi_body + | BlockDecl (_, block_decl_info) -> + block_decl_info.Clang_ast_t.bdi_body + | _ -> + Logging.die InternalError "Should only be called with method, but got %s" (Clang_ast_proj.get_decl_kind_string decl) + let call_tableaux cxt an map_active = if CFrontend_config.tableaux_evaluation then Tableaux.build_valuation an cxt map_active + let rec do_frontend_checks_stmt (context: CLintersContext.context) (map_act: Tableaux.context_linter_map) stmt = let open Clang_ast_t in @@ -213,12 +229,12 @@ let rec do_frontend_checks_stmt (context: CLintersContext.context) "@\n >>>>>>Visit node %i <<<<<@\n" (Ctl_parser_types.ast_node_pointer an) ; *) let do_all_checks_on_stmts context map_active stmt = ( match stmt with - | DeclStmt (_, _, decl_list) - -> List.iter ~f:(do_frontend_checks_decl context map_active) decl_list - | BlockExpr (_, _, _, decl) - -> List.iter ~f:(do_frontend_checks_decl context map_active) [decl] - | _ - -> () ) ; + | DeclStmt (_, _, decl_list) -> + List.iter ~f:(do_frontend_checks_decl context map_active) decl_list + | BlockExpr (_, _, _, decl) -> + List.iter ~f:(do_frontend_checks_decl context map_active) [decl] + | _ -> + () ) ; do_frontend_checks_stmt context map_active stmt in CFrontend_errors.invoke_set_of_checkers_on_node context an ; @@ -226,28 +242,28 @@ let rec do_frontend_checks_stmt (context: CLintersContext.context) let map_active = Tableaux.update_linter_context_map an map_act in let stmt_context_list = match stmt with - | ObjCAtSynchronizedStmt (_, stmt_list) - -> [({context with CLintersContext.in_synchronized_block= true}, stmt_list)] + | ObjCAtSynchronizedStmt (_, stmt_list) -> + [({context with CLintersContext.in_synchronized_block= true}, stmt_list)] | OpaqueValueExpr (_, lstmt, _, opaque_value_expr_info) -> ( match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with - | Some stmt - -> [(context, lstmt @ [stmt])] - | _ - -> [(context, lstmt)] ) - | IfStmt (_, [stmt1; stmt2; cond_stmt; inside_if_stmt; inside_else_stmt]) - -> let inside_if_stmt_context = + | Some stmt -> + [(context, lstmt @ [stmt])] + | _ -> + [(context, lstmt)] ) + | IfStmt (_, [stmt1; stmt2; cond_stmt; inside_if_stmt; inside_else_stmt]) -> + let inside_if_stmt_context = {context with CLintersContext.if_context= compute_if_context context cond_stmt} in (* distinguish between then and else branch as they need different context *) [ (context, [stmt1; stmt2; cond_stmt; inside_else_stmt]) ; (inside_if_stmt_context, [inside_if_stmt]) ] - | ForStmt (_, stmt1 :: stmts) - -> let inside_for_stmt_decl_context = + | ForStmt (_, stmt1 :: stmts) -> + let inside_for_stmt_decl_context = {context with CLintersContext.in_for_loop_declaration= true} in [(context, stmts); (inside_for_stmt_decl_context, [stmt1])] - | _ - -> [(context, snd (Clang_ast_proj.get_stmt_tuple stmt))] + | _ -> + [(context, snd (Clang_ast_proj.get_stmt_tuple stmt))] in if CFrontend_config.tableaux_evaluation then (* Unlike in the standard algorithm, nodes reachable via transitions @@ -261,6 +277,7 @@ let rec do_frontend_checks_stmt (context: CLintersContext.context) call_tableaux cxt an map_active) stmt_context_list + (* Visit nodes via a transition *) and do_frontend_checks_via_transition context map_active an trans = let succs = CTL.next_state_via_transition an trans in @@ -271,12 +288,13 @@ and do_frontend_checks_via_transition context map_active an trans = (Ctl_parser_types.ast_node_pointer an) (Ctl_parser_types.ast_node_pointer an') CTL.Debug.pp_transition (Some trans) ;*) match an' with - | Ctl_parser_types.Decl d - -> do_frontend_checks_decl context map_active d - | Ctl_parser_types.Stmt st - -> do_frontend_checks_stmt context map_active st) + | Ctl_parser_types.Decl d -> + do_frontend_checks_decl context map_active d + | Ctl_parser_types.Stmt st -> + do_frontend_checks_stmt context map_active st) succs + and do_frontend_checks_decl (context: CLintersContext.context) (map_act: Tableaux.context_linter_map) decl = let open Clang_ast_t in @@ -292,38 +310,40 @@ and do_frontend_checks_decl (context: CLintersContext.context) | CXXConversionDecl _ | CXXDestructorDecl _ | BlockDecl _ - | ObjCMethodDecl _ - -> let context' = CLintersContext.update_current_method context decl in + | ObjCMethodDecl _ -> + let context' = CLintersContext.update_current_method context decl in CFrontend_errors.invoke_set_of_checkers_on_node context' an ; (* We need to visit explicitly nodes reachable via Parameters transitions because they won't be visited during the evaluation of the formula *) do_frontend_checks_via_transition context' map_active an CTL.Parameters ; ( match get_method_body_opt decl with - | Some stmt - -> do_frontend_checks_stmt context' map_active stmt - | None - -> () ) ; + | Some stmt -> + do_frontend_checks_stmt context' map_active stmt + | None -> + () ) ; call_tableaux context' an map_active - | ObjCImplementationDecl (_, _, decls, _, _) | ObjCInterfaceDecl (_, _, decls, _, _) - -> CFrontend_errors.invoke_set_of_checkers_on_node context an ; + | ObjCImplementationDecl (_, _, decls, _, _) | ObjCInterfaceDecl (_, _, decls, _, _) -> + CFrontend_errors.invoke_set_of_checkers_on_node context an ; let context' = {context with current_objc_class= Some decl} in List.iter ~f:(do_frontend_checks_decl context' map_active) decls ; call_tableaux context' an map_active - | _ - -> CFrontend_errors.invoke_set_of_checkers_on_node context an ; + | _ -> + CFrontend_errors.invoke_set_of_checkers_on_node context an ; ( match Clang_ast_proj.get_decl_context_tuple decl with - | Some (decls, _) - -> List.iter ~f:(do_frontend_checks_decl context map_active) decls - | None - -> () ) ; + | Some (decls, _) -> + List.iter ~f:(do_frontend_checks_decl context map_active) decls + | None -> + () ) ; call_tableaux context an map_active + let context_with_ck_set context decl_list = let is_ck = context.CLintersContext.is_ck_translation_unit || ComponentKit.contains_ck_impl decl_list in if is_ck then {context with CLintersContext.is_ck_translation_unit= true} else context + let store_issues source_file = let abbrev_source_file = DB.source_file_encoding source_file in let lint_issues_dir = Config.results_dir ^/ Config.lint_issues_dir_name in @@ -333,28 +353,32 @@ let store_issues source_file = in LintIssues.store_issues lint_issues_file !LintIssues.errLogMap + let find_linters_files () = let rec find_aux init dir_path = let aux base_path files rel_path = let full_path = Filename.concat base_path rel_path in match (Unix.stat full_path).Unix.st_kind with - | Unix.S_REG when String.is_suffix ~suffix:".al" full_path - -> full_path :: files - | Unix.S_DIR - -> find_aux files full_path - | _ - -> files + | Unix.S_REG when String.is_suffix ~suffix:".al" full_path -> + full_path :: files + | Unix.S_DIR -> + find_aux files full_path + | _ -> + files in Sys.fold_dir ~init ~f:(aux dir_path) dir_path in List.concat (List.map ~f:(fun folder -> find_aux [] folder) Config.linters_def_folder) + let linters_files = List.dedup ~compare:String.compare (find_linters_files () @ Config.linters_def_file) + let do_frontend_checks (trans_unit_ctx: CFrontend_config.translation_unit_context) ast = L.(debug Capture Quiet) - "Loading the following linters files: %a@\n" (Pp.comma_seq Format.pp_print_string) + "Loading the following linters files: %a@\n" + (Pp.comma_seq Format.pp_print_string) linters_files ; CTL.create_ctl_evaluation_tracker trans_unit_ctx.source_file ; let parsed_linters = parse_ctl_files linters_files in @@ -371,8 +395,8 @@ let do_frontend_checks (trans_unit_ctx: CFrontend_config.translation_unit_contex CFrontend_errors.pp_linters filtered_parsed_linters ; Tableaux.init_global_nodes_valuation () ; match ast with - | Clang_ast_t.TranslationUnitDecl (_, decl_list, _, _) - -> let context = context_with_ck_set (CLintersContext.empty trans_unit_ctx) decl_list in + | Clang_ast_t.TranslationUnitDecl (_, decl_list, _, _) -> + let context = context_with_ck_set (CLintersContext.empty trans_unit_ctx) decl_list in let allowed_decls = List.filter ~f:(Tableaux.is_decl_allowed context) decl_list in (* We analyze the top level and then all the allowed declarations *) let active_map : Tableaux.context_linter_map = Tableaux.init_active_map () in @@ -384,5 +408,6 @@ let do_frontend_checks (trans_unit_ctx: CFrontend_config.translation_unit_contex (*if CFrontend_config.tableaux_evaluation then ( Tableaux.print_table_size () ; Tableaux.print_global_valuation_map ()) *) - | _ (* NOTE: Assumes that an AST always starts with a TranslationUnitDecl *) - -> assert false + | _ (* NOTE: Assumes that an AST always starts with a TranslationUnitDecl *) -> + assert false + diff --git a/infer/src/clang/cFrontend_config.ml b/infer/src/clang/cFrontend_config.ml index 68b319b14..b6bfe1546 100644 --- a/infer/src/clang/cFrontend_config.ml +++ b/infer/src/clang/cFrontend_config.ml @@ -44,6 +44,7 @@ let biniou_buffer_size = (* the C++ standard suggests that implementation should support string literals up to this length *) 65535 + let block = "block" let builtin_expect = "__builtin_expect" @@ -71,6 +72,7 @@ let clang_bin xx = Config.bin_dir ^/ Filename.parent_dir_name ^/ Filename.parent_dir_name ^/ "facebook-clang-plugins" ^/ "clang" ^/ "install" ^/ "bin" ^/ "clang" ^ xx + let class_method = "class" let class_type = "Class" @@ -179,4 +181,5 @@ let reset_global_state () = log_out := Format.std_formatter ; sil_types_map := Clang_ast_extend.TypePointerMap.empty + let tableaux_evaluation = false diff --git a/infer/src/clang/cFrontend_decl.ml b/infer/src/clang/cFrontend_decl.ml index 06fddc9c1..85b7c9b74 100644 --- a/infer/src/clang/cFrontend_decl.ml +++ b/infer/src/clang/cFrontend_decl.ml @@ -23,20 +23,22 @@ let protect ~f ~recover ~pp_context = (* Always keep going in case of known limitations of the frontend, crash otherwise (by not catching the exception) unless `--keep-going` was passed. Print errors we should fix (t21762295) to the console. *) - | CFrontend_config.Unimplemented msg - -> log_and_recover ~print:false "Unimplemented feature:@\n %s@\n" msg - | CFrontend_config.IncorrectAssumption msg - -> (* FIXME(t21762295): we do not expect this to happen but it does *) + | CFrontend_config.Unimplemented msg -> + log_and_recover ~print:false "Unimplemented feature:@\n %s@\n" msg + | CFrontend_config.IncorrectAssumption msg -> + (* FIXME(t21762295): we do not expect this to happen but it does *) log_and_recover ~print:true "Known incorrect assumption in the frontend: %s@\n" msg - | CTrans_utils.Self.SelfClassException class_name - -> (* FIXME(t21762295): we do not expect this to happen but it does *) + | CTrans_utils.Self.SelfClassException class_name -> + (* FIXME(t21762295): we do not expect this to happen but it does *) log_and_recover ~print:true "Unexpected SelfClassException %a@\n" Typ.Name.pp class_name - | exn - -> let trace = Exn.backtrace () in + | exn -> + let trace = Exn.backtrace () in reraise_if exn ~f:(fun () -> - L.internal_error "%a: %a@\n%!" pp_context () Exn.pp exn ; not Config.keep_going ) ; + L.internal_error "%a: %a@\n%!" pp_context () Exn.pp exn ; + not Config.keep_going ) ; log_and_recover ~print:true "Frontend error: %a@\nBacktrace:@\n%s" Exn.pp exn trace + module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFrontend = struct let model_exists procname = Specs.summary_exists_in_models procname && not Config.models_mode @@ -54,8 +56,8 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron in let f () = match Cfg.find_proc_desc_from_name cfg procname with - | Some procdesc when Procdesc.is_defined procdesc && not (model_exists procname) - -> let vars_to_destroy = CTrans_utils.Scope.compute_vars_to_destroy body in + | Some procdesc when Procdesc.is_defined procdesc && not (model_exists procname) -> + let vars_to_destroy = CTrans_utils.Scope.compute_vars_to_destroy body in let context = CContext.create_context trans_unit_ctx tenv cg cfg procdesc class_decl_opt has_return_param is_objc_method outer_context_opt vars_to_destroy @@ -73,25 +75,26 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron (Procdesc.get_locals procdesc) ; Procdesc.node_set_succs_exn procdesc start_node meth_body_nodes [] ; Cg.add_defined_node (CContext.get_cg context) (Procdesc.get_proc_name procdesc) - | _ - -> () + | _ -> + () in protect ~f ~recover ~pp_context + let function_decl trans_unit_ctx tenv cfg cg func_decl block_data_opt = let captured_vars, outer_context_opt = match block_data_opt with - | Some (outer_context, _, _, captured_vars) - -> (captured_vars, Some outer_context) - | None - -> ([], None) + | Some (outer_context, _, _, captured_vars) -> + (captured_vars, Some outer_context) + | None -> + ([], None) in let ms, body_opt, extra_instrs = CMethod_trans.method_signature_of_decl trans_unit_ctx tenv func_decl block_data_opt in match body_opt with - | Some body - -> (* Only in the case the function declaration has a defined body we create a procdesc *) + | Some body -> + (* Only in the case the function declaration has a defined body we create a procdesc *) let procname = CMethod_signature.ms_get_name ms in let return_param_typ_opt = CMethod_signature.ms_get_return_param_typ ms in if CMethod_trans.create_local_procdesc trans_unit_ctx cfg tenv ms [body] captured_vars @@ -99,8 +102,9 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron then add_method trans_unit_ctx tenv cg cfg CContext.ContextNoCls procname body return_param_typ_opt false outer_context_opt extra_instrs - | None - -> () + | None -> + () + let process_method_decl ?(set_objc_accessor_attr= false) ?(is_destructor= false) trans_unit_ctx tenv cg cfg curr_class meth_decl ~is_objc = @@ -110,8 +114,8 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron let is_instance = CMethod_signature.ms_is_instance ms in let is_objc_inst_method = is_instance && is_objc in match body_opt with - | Some body - -> let procname = CMethod_signature.ms_get_name ms in + | Some body -> + let procname = CMethod_signature.ms_get_name ms in let return_param_typ_opt = CMethod_signature.ms_get_return_param_typ ms in let ms', procname' = if is_destructor then ( @@ -139,54 +143,58 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron then add_method trans_unit_ctx tenv cg cfg curr_class procname' body return_param_typ_opt is_objc None extra_instrs ~is_destructor_wrapper:false - | None - -> if set_objc_accessor_attr then + | None -> + if set_objc_accessor_attr then ignore (CMethod_trans.create_local_procdesc ~set_objc_accessor_attr trans_unit_ctx cfg tenv ms [] [] is_objc_inst_method) + let process_property_implementation trans_unit_ctx tenv cg cfg curr_class obj_c_property_impl_decl_info = let property_decl_opt = obj_c_property_impl_decl_info.Clang_ast_t.opidi_property_decl in match CAst_utils.get_decl_opt_with_decl_ref property_decl_opt with - | Some ObjCPropertyDecl (_, _, obj_c_property_decl_info) - -> let process_accessor pointer = + | Some ObjCPropertyDecl (_, _, obj_c_property_decl_info) -> + let process_accessor pointer = match CAst_utils.get_decl_opt_with_decl_ref pointer with - | Some (ObjCMethodDecl _ as dec) - -> process_method_decl ~set_objc_accessor_attr:true trans_unit_ctx tenv cg cfg + | Some (ObjCMethodDecl _ as dec) -> + process_method_decl ~set_objc_accessor_attr:true trans_unit_ctx tenv cg cfg curr_class dec ~is_objc:true - | _ - -> () + | _ -> + () in process_accessor obj_c_property_decl_info.Clang_ast_t.opdi_getter_method ; process_accessor obj_c_property_decl_info.Clang_ast_t.opdi_setter_method - | _ - -> () + | _ -> + () + let process_one_method_decl trans_unit_ctx tenv cg cfg curr_class dec = let open Clang_ast_t in match dec with - | CXXMethodDecl _ | CXXConstructorDecl _ | CXXConversionDecl _ - -> process_method_decl trans_unit_ctx tenv cg cfg curr_class dec ~is_objc:false - | CXXDestructorDecl _ - -> process_method_decl trans_unit_ctx tenv cg cfg curr_class dec ~is_objc:false + | CXXMethodDecl _ | CXXConstructorDecl _ | CXXConversionDecl _ -> + process_method_decl trans_unit_ctx tenv cg cfg curr_class dec ~is_objc:false + | CXXDestructorDecl _ -> + process_method_decl trans_unit_ctx tenv cg cfg curr_class dec ~is_objc:false ~is_destructor:true - | ObjCMethodDecl _ - -> process_method_decl trans_unit_ctx tenv cg cfg curr_class dec ~is_objc:true - | ObjCPropertyImplDecl (_, obj_c_property_impl_decl_info) - -> process_property_implementation trans_unit_ctx tenv cg cfg curr_class + | ObjCMethodDecl _ -> + process_method_decl trans_unit_ctx tenv cg cfg curr_class dec ~is_objc:true + | ObjCPropertyImplDecl (_, obj_c_property_impl_decl_info) -> + process_property_implementation trans_unit_ctx tenv cg cfg curr_class obj_c_property_impl_decl_info - | EmptyDecl _ | ObjCIvarDecl _ | ObjCPropertyDecl _ - -> () - | _ - -> L.internal_error + | EmptyDecl _ | ObjCIvarDecl _ | ObjCPropertyDecl _ -> + () + | _ -> + L.internal_error "@\nWARNING: found Method Declaration '%s' skipped. NEED TO BE FIXED@\n@\n" (Clang_ast_proj.get_decl_kind_string dec) ; () + let process_methods trans_unit_ctx tenv cg cfg curr_class decl_list = List.iter ~f:(process_one_method_decl trans_unit_ctx tenv cg cfg curr_class) decl_list + (** Given REVERSED list of method qualifiers (method_name::class_name::rest_quals), return whether method should be translated based on method and class whitelists *) let is_whitelisted_cpp_method = @@ -201,11 +209,12 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron QualifiedCppName.Match.match_qualifiers method_matcher qual_name || match QualifiedCppName.extract_last qual_name with - | Some (_, class_qual_name) - -> (* make sure the class name is not empty; in particular, it cannot be a C function *) + | Some (_, class_qual_name) -> + (* make sure the class name is not empty; in particular, it cannot be a C function *) QualifiedCppName.Match.match_qualifiers class_matcher class_qual_name - | None - -> false + | None -> + false + let should_translate_decl trans_unit_ctx (dec: Clang_ast_t.decl) decl_trans_context = let info = Clang_ast_proj.get_decl_tuple dec in @@ -216,17 +225,17 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron | CXXMethodDecl (_, name_info, _, _, _) | CXXConstructorDecl (_, name_info, _, _, _) | CXXConversionDecl (_, name_info, _, _, _) - | CXXDestructorDecl (_, name_info, _, _, _) - -> is_whitelisted_cpp_method (CAst_utils.get_qualified_name name_info) - | _ - -> false + | CXXDestructorDecl (_, name_info, _, _, _) -> + is_whitelisted_cpp_method (CAst_utils.get_qualified_name name_info) + | _ -> + false in let always_translate = match dec with - | VarDecl (_, {ni_name}, _, _) - -> String.is_prefix ni_name ~prefix:"__infer_" - | _ - -> false + | VarDecl (_, {ni_name}, _, _) -> + String.is_prefix ni_name ~prefix:"__infer_" + | _ -> + false in let translate_location = always_translate @@ -239,14 +248,15 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron | CXXMethodDecl (_, name_info, _, _, _) | CXXConstructorDecl (_, name_info, _, _, _) | CXXConversionDecl (_, name_info, _, _, _) - | CXXDestructorDecl (_, name_info, _, _, _) - -> let fun_name = name_info.Clang_ast_t.ni_name in + | CXXDestructorDecl (_, name_info, _, _, _) -> + let fun_name = name_info.Clang_ast_t.ni_name in String.is_prefix ~prefix:"__infer_skip__" fun_name - | _ - -> false + | _ -> + false in not never_translate_decl && translate_location + (* Translate one global declaration *) let rec translate_one_declaration trans_unit_ctx tenv cg cfg decl_trans_context dec = let open Clang_ast_t in @@ -258,27 +268,27 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron ( if should_translate_decl trans_unit_ctx dec decl_trans_context then let dec_ptr = (Clang_ast_proj.get_decl_tuple dec).di_pointer in match dec with - | FunctionDecl (_, _, _, _) - -> function_decl trans_unit_ctx tenv cfg cg dec None - | ObjCInterfaceDecl (_, _, decl_list, _, _) - -> let curr_class = CContext.ContextClsDeclPtr dec_ptr in + | FunctionDecl (_, _, _, _) -> + function_decl trans_unit_ctx tenv cfg cg dec None + | ObjCInterfaceDecl (_, _, decl_list, _, _) -> + let curr_class = CContext.ContextClsDeclPtr dec_ptr in ignore (ObjcInterface_decl.interface_declaration CType_decl.qual_type_to_sil_type tenv dec) ; process_methods trans_unit_ctx tenv cg cfg curr_class decl_list - | ObjCProtocolDecl (_, _, decl_list, _, _) - -> let curr_class = CContext.ContextClsDeclPtr dec_ptr in + | ObjCProtocolDecl (_, _, decl_list, _, _) -> + let curr_class = CContext.ContextClsDeclPtr dec_ptr in ignore (ObjcProtocol_decl.protocol_decl CType_decl.qual_type_to_sil_type tenv dec) ; process_methods trans_unit_ctx tenv cg cfg curr_class decl_list - | ObjCCategoryDecl (_, _, decl_list, _, _) - -> let curr_class = CContext.ContextClsDeclPtr dec_ptr in + | ObjCCategoryDecl (_, _, decl_list, _, _) -> + let curr_class = CContext.ContextClsDeclPtr dec_ptr in ignore (ObjcCategory_decl.category_decl CType_decl.qual_type_to_sil_type tenv dec) ; process_methods trans_unit_ctx tenv cg cfg curr_class decl_list - | ObjCCategoryImplDecl (_, _, decl_list, _, _) - -> let curr_class = CContext.ContextClsDeclPtr dec_ptr in + | ObjCCategoryImplDecl (_, _, decl_list, _, _) -> + let curr_class = CContext.ContextClsDeclPtr dec_ptr in ignore (ObjcCategory_decl.category_impl_decl CType_decl.qual_type_to_sil_type tenv dec) ; process_methods trans_unit_ctx tenv cg cfg curr_class decl_list - | ObjCImplementationDecl (_, _, decl_list, _, _) - -> let curr_class = CContext.ContextClsDeclPtr dec_ptr in + | ObjCImplementationDecl (_, _, decl_list, _, _) -> + let curr_class = CContext.ContextClsDeclPtr dec_ptr in let qual_type_to_sil_type = CType_decl.qual_type_to_sil_type in ignore (ObjcInterface_decl.interface_impl_declaration qual_type_to_sil_type tenv dec) ; process_methods trans_unit_ctx tenv cg cfg curr_class decl_list @@ -286,23 +296,24 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron | CXXConstructorDecl (decl_info, _, _, _, _) | CXXConversionDecl (decl_info, _, _, _, _) | CXXDestructorDecl (decl_info, _, _, _, _) - -> ( + -> ( (* di_parent_pointer has pointer to lexical context such as class.*) let parent_ptr = Option.value_exn decl_info.Clang_ast_t.di_parent_pointer in let class_decl = CAst_utils.get_decl parent_ptr in match class_decl with - | (Some CXXRecordDecl _ | Some ClassTemplateSpecializationDecl _) when Config.cxx - -> let curr_class = CContext.ContextClsDeclPtr parent_ptr in + | (Some CXXRecordDecl _ | Some ClassTemplateSpecializationDecl _) when Config.cxx -> + let curr_class = CContext.ContextClsDeclPtr parent_ptr in process_methods trans_unit_ctx tenv cg cfg curr_class [dec] - | Some dec - -> L.(debug Capture Verbose) - "Methods of %s skipped@\n" (Clang_ast_proj.get_decl_kind_string dec) - | None - -> () ) + | Some dec -> + L.(debug Capture Verbose) + "Methods of %s skipped@\n" + (Clang_ast_proj.get_decl_kind_string dec) + | None -> + () ) | VarDecl (decl_info, named_decl_info, qt, ({vdi_is_global; vdi_init_expr} as vdi)) when String.is_prefix ~prefix:"__infer_" named_decl_info.ni_name - || vdi_is_global && Option.is_some vdi_init_expr - -> (* create a fake procedure that initializes the global variable so that the variable + || vdi_is_global && Option.is_some vdi_init_expr -> + (* create a fake procedure that initializes the global variable so that the variable initializer can be analyzed by the backend (eg, the SIOF checker) *) let procname = (* create the corresponding global variable to get the right pname for its @@ -332,38 +343,40 @@ module CFrontend_decl_funct (T : CModule_type.CTranslation) : CModule_type.CFron | ClassTemplateSpecializationDecl (di, _, _, decl_list, _, _, rdi, _, _, _) | CXXRecordDecl (di, _, _, decl_list, _, _, rdi, _) | RecordDecl (di, _, _, decl_list, _, _, rdi) - when not di.di_is_implicit || rdi.rdi_is_complete_definition - -> let is_method_decl decl = + when not di.di_is_implicit || rdi.rdi_is_complete_definition -> + let is_method_decl decl = match decl with | CXXMethodDecl _ | CXXConstructorDecl _ | CXXConversionDecl _ | CXXDestructorDecl _ - | FunctionTemplateDecl _ - -> true - | _ - -> false + | FunctionTemplateDecl _ -> + true + | _ -> + false in let method_decls, no_method_decls = List.partition_tf ~f:is_method_decl decl_list in List.iter ~f:translate no_method_decls ; protect ~f:(fun () -> ignore (CType_decl.add_types_from_decl_to_tenv tenv dec)) ~recover:Fn.id ~pp_context:(fun fmt () -> F.fprintf fmt "Error adding types from decl '%a'" - (Pp.to_string ~f:Clang_ast_j.string_of_decl) dec ) ; + (Pp.to_string ~f:Clang_ast_j.string_of_decl) + dec ) ; List.iter ~f:translate method_decls - | _ - -> () ) ; + | _ -> + () ) ; match dec with - | EnumDecl _ - -> ignore (CEnum_decl.enum_decl dec) - | LinkageSpecDecl (_, decl_list, _) - -> L.(debug Capture Verbose) "ADDING: LinkageSpecDecl decl list@\n" ; + | EnumDecl _ -> + ignore (CEnum_decl.enum_decl dec) + | LinkageSpecDecl (_, decl_list, _) -> + L.(debug Capture Verbose) "ADDING: LinkageSpecDecl decl list@\n" ; + List.iter ~f:translate decl_list + | NamespaceDecl (_, _, decl_list, _, _) -> List.iter ~f:translate decl_list - | NamespaceDecl (_, _, decl_list, _, _) - -> List.iter ~f:translate decl_list - | ClassTemplateDecl (_, _, template_decl_info) | FunctionTemplateDecl (_, _, template_decl_info) - -> let decl_list = template_decl_info.Clang_ast_t.tdi_specializations in + | ClassTemplateDecl (_, _, template_decl_info) | FunctionTemplateDecl (_, _, template_decl_info) -> + let decl_list = template_decl_info.Clang_ast_t.tdi_specializations in List.iter ~f:translate decl_list - | _ - -> () + | _ -> + () + end diff --git a/infer/src/clang/cFrontend_errors.ml b/infer/src/clang/cFrontend_errors.ml index cfb7f277d..0f25ef0a1 100644 --- a/infer/src/clang/cFrontend_errors.ml +++ b/infer/src/clang/cFrontend_errors.ml @@ -23,13 +23,14 @@ type linter = let filter_parsed_linters_developer parsed_linters = if List.length parsed_linters > 1 && Config.linters_developer_mode then match Config.linter with - | None - -> L.(die UserError) + | None -> + L.(die UserError) "In linters developer mode you should debug only one linter at a time. This is important for debugging the rule. Pass the flag --linter to specify the linter you want to debug." - | Some lint - -> List.filter ~f:(fun (rule: linter) -> String.equal rule.issue_desc.id lint) parsed_linters + | Some lint -> + List.filter ~f:(fun (rule: linter) -> String.equal rule.issue_desc.id lint) parsed_linters else parsed_linters + let filter_parsed_linters_by_path parsed_linters source_file = let filter_parsed_linter_by_path linter = let should_lint paths = @@ -47,16 +48,19 @@ let filter_parsed_linters_by_path parsed_linters source_file = in List.filter ~f:filter_parsed_linter_by_path parsed_linters + let filter_parsed_linters parsed_linters source_file = let linters = filter_parsed_linters_developer parsed_linters in if Config.debug_mode || not Config.filtering then linters (* do not filter by path if in debug or no filtering mode *) else filter_parsed_linters_by_path linters source_file + let pp_linters fmt linters = let pp_linter fmt {issue_desc= {id}} = F.fprintf fmt "%s@\n" id in List.iter ~f:(pp_linter fmt) linters + (* Map a formula id to a triple (visited, parameters, definition). Visited is used during the expansion phase to understand if the formula was already expanded and, if yes we have a cyclic definifion *) @@ -69,6 +73,7 @@ let single_to_multi checker ctx an = let issue_desc_opt = checker ctx an in Option.to_list issue_desc_opt + (* List of checkers on decls *that return 0 or 1 issue* *) let decl_single_checkers_list = [ ComponentKit.component_with_unconventional_superclass_advice @@ -76,17 +81,20 @@ let decl_single_checkers_list = ; ComponentKit.component_factory_function_advice ; ComponentKit.component_file_cyclomatic_complexity_info ] + (* List of checkers on decls *) let decl_checkers_list = ComponentKit.component_with_multiple_factory_methods_advice :: ComponentKit.component_file_line_count_info - :: List.map ~f:single_to_multi decl_single_checkers_list + :: List.map ~f:single_to_multi decl_single_checkers_list + (* List of checkers on stmts *that return 0 or 1 issue* *) let stmt_single_checkers_list = [ ComponentKit.component_file_cyclomatic_complexity_info ; ComponentKit.component_initializer_with_side_effects_advice ] + let stmt_checkers_list = List.map ~f:single_to_multi stmt_single_checkers_list (* List of checkers that will be filled after parsing them from @@ -95,32 +103,33 @@ let parsed_linters = ref [] let evaluate_place_holder context ph an = match ph with - | "%ivar_name%" - -> MF.monospaced_to_string (CFrontend_checkers.ivar_name an) - | "%decl_name%" - -> MF.monospaced_to_string (Ctl_parser_types.ast_node_name an) - | "%cxx_ref_captured_in_block%" - -> MF.monospaced_to_string (CFrontend_checkers.cxx_ref_captured_in_block an) - | "%decl_ref_or_selector_name%" - -> MF.monospaced_to_string (CFrontend_checkers.decl_ref_or_selector_name an) - | "%receiver_method_call%" - -> MF.monospaced_to_string (CFrontend_checkers.receiver_method_call an) - | "%iphoneos_target_sdk_version%" - -> MF.monospaced_to_string (CFrontend_checkers.iphoneos_target_sdk_version context an) - | "%available_ios_sdk%" - -> MF.monospaced_to_string (CFrontend_checkers.available_ios_sdk an) - | "%class_available_ios_sdk%" - -> MF.monospaced_to_string (CFrontend_checkers.class_available_ios_sdk an) - | "%type%" - -> MF.monospaced_to_string (Ctl_parser_types.ast_node_type an) - | "%class_name%" - -> CFrontend_checkers.class_name an - | "%child_type%" - -> MF.monospaced_to_string (Ctl_parser_types.stmt_node_child_type an) - | "%name%" - -> MF.monospaced_to_string (Ctl_parser_types.ast_node_name an) - | _ - -> L.die InternalError "helper function %s is unknown" ph + | "%ivar_name%" -> + MF.monospaced_to_string (CFrontend_checkers.ivar_name an) + | "%decl_name%" -> + MF.monospaced_to_string (Ctl_parser_types.ast_node_name an) + | "%cxx_ref_captured_in_block%" -> + MF.monospaced_to_string (CFrontend_checkers.cxx_ref_captured_in_block an) + | "%decl_ref_or_selector_name%" -> + MF.monospaced_to_string (CFrontend_checkers.decl_ref_or_selector_name an) + | "%receiver_method_call%" -> + MF.monospaced_to_string (CFrontend_checkers.receiver_method_call an) + | "%iphoneos_target_sdk_version%" -> + MF.monospaced_to_string (CFrontend_checkers.iphoneos_target_sdk_version context an) + | "%available_ios_sdk%" -> + MF.monospaced_to_string (CFrontend_checkers.available_ios_sdk an) + | "%class_available_ios_sdk%" -> + MF.monospaced_to_string (CFrontend_checkers.class_available_ios_sdk an) + | "%type%" -> + MF.monospaced_to_string (Ctl_parser_types.ast_node_type an) + | "%class_name%" -> + CFrontend_checkers.class_name an + | "%child_type%" -> + MF.monospaced_to_string (Ctl_parser_types.stmt_node_child_type an) + | "%name%" -> + MF.monospaced_to_string (Ctl_parser_types.ast_node_name an) + | _ -> + L.die InternalError "helper function %s is unknown" ph + (* given a message this function searches for a place-holder identifier, eg %id%. Then it evaluates id and replaces %id% in message @@ -143,43 +152,48 @@ let rec expand_message_string context message an = expand_message_string context message' an with Not_found -> message + let remove_new_lines_and_whitespace message = let words = List.map ~f:String.strip (String.split ~on:'\n' message) in String.concat words ~sep:" " + let string_to_err_kind = function - | "WARNING" - -> Exceptions.Kwarning - | "ERROR" - -> Exceptions.Kerror - | "INFO" - -> Exceptions.Kinfo - | "ADVICE" - -> Exceptions.Kadvice - | "LIKE" - -> Exceptions.Klike - | s - -> L.die InternalError "Severity %s does not exist" s + | "WARNING" -> + Exceptions.Kwarning + | "ERROR" -> + Exceptions.Kerror + | "INFO" -> + Exceptions.Kinfo + | "ADVICE" -> + Exceptions.Kadvice + | "LIKE" -> + Exceptions.Klike + | s -> + L.die InternalError "Severity %s does not exist" s + let string_to_issue_mode m = match m with - | "ON" - -> CIssue.On - | "OFF" - -> CIssue.Off - | s - -> L.die InternalError "Mode %s does not exist. Please specify ON/OFF" s + | "ON" -> + CIssue.On + | "OFF" -> + CIssue.Off + | s -> + L.die InternalError "Mode %s does not exist. Please specify ON/OFF" s + let post_process_linter_definition (linter: linter) = match List.find Config.linters_doc_url ~f:(fun (linter_doc_url: Config.linter_doc_url) -> String.equal linter.issue_desc.id linter_doc_url.linter ) with - | Some linter_doc_url - -> let issue_desc = {linter.issue_desc with doc_url= Some linter_doc_url.doc_url} in + | Some linter_doc_url -> + let issue_desc = {linter.issue_desc with doc_url= Some linter_doc_url.doc_url} in {linter with issue_desc} - | None - -> linter + | None -> + linter + (** Convert a parsed checker in list of linters *) let create_parsed_linters linters_def_file checkers : linter list = @@ -200,26 +214,26 @@ let create_parsed_linters linters_def_file checkers : linter list = let issue_desc, condition, whitelist_paths, blacklist_paths = let process_linter_definitions (issue, cond, wl_paths, bl_paths) description = match description with - | CSet (av, phi) when ALVar.is_report_when_keyword av - -> (issue, phi, wl_paths, bl_paths) - | CDesc (av, msg) when ALVar.is_message_keyword av - -> ({issue with description= msg}, cond, wl_paths, bl_paths) - | CDesc (av, sugg) when ALVar.is_suggestion_keyword av - -> ({issue with suggestion= Some sugg}, cond, wl_paths, bl_paths) - | CDesc (av, sev) when ALVar.is_severity_keyword av - -> ({issue with severity= string_to_err_kind sev}, cond, wl_paths, bl_paths) - | CDesc (av, m) when ALVar.is_mode_keyword av - -> ({issue with mode= string_to_issue_mode m}, cond, wl_paths, bl_paths) - | CDesc (av, doc) when ALVar.is_doc_url_keyword av - -> ({issue with doc_url= Some doc}, cond, wl_paths, bl_paths) - | CDesc (av, name) when ALVar.is_name_keyword av - -> ({issue with name= Some name}, cond, wl_paths, bl_paths) - | CPath (`WhitelistPath, paths) - -> (issue, cond, paths, bl_paths) - | CPath (`BlacklistPath, paths) - -> (issue, cond, wl_paths, paths) - | _ - -> (issue, cond, wl_paths, bl_paths) + | CSet (av, phi) when ALVar.is_report_when_keyword av -> + (issue, phi, wl_paths, bl_paths) + | CDesc (av, msg) when ALVar.is_message_keyword av -> + ({issue with description= msg}, cond, wl_paths, bl_paths) + | CDesc (av, sugg) when ALVar.is_suggestion_keyword av -> + ({issue with suggestion= Some sugg}, cond, wl_paths, bl_paths) + | CDesc (av, sev) when ALVar.is_severity_keyword av -> + ({issue with severity= string_to_err_kind sev}, cond, wl_paths, bl_paths) + | CDesc (av, m) when ALVar.is_mode_keyword av -> + ({issue with mode= string_to_issue_mode m}, cond, wl_paths, bl_paths) + | CDesc (av, doc) when ALVar.is_doc_url_keyword av -> + ({issue with doc_url= Some doc}, cond, wl_paths, bl_paths) + | CDesc (av, name) when ALVar.is_name_keyword av -> + ({issue with name= Some name}, cond, wl_paths, bl_paths) + | CPath (`WhitelistPath, paths) -> + (issue, cond, paths, bl_paths) + | CPath (`BlacklistPath, paths) -> + (issue, cond, wl_paths, paths) + | _ -> + (issue, cond, wl_paths, bl_paths) in List.fold ~f:process_linter_definitions ~init:(dummy_issue, CTL.False, [], []) checker.definitions @@ -234,6 +248,7 @@ let create_parsed_linters linters_def_file checkers : linter list = in List.map ~f:do_one_checker checkers + let rec apply_substitution f sub = let sub_param p = try snd (List.find_exn sub ~f:(fun (a, _) -> ALVar.equal p a)) @@ -242,40 +257,41 @@ let rec apply_substitution f sub = let sub_list_param ps = List.map ps ~f:sub_param in let open CTL in match f with - | True | False - -> f - | Atomic (name, ps) - -> Atomic (name, sub_list_param ps) - | Not f1 - -> Not (apply_substitution f1 sub) - | And (f1, f2) - -> And (apply_substitution f1 sub, apply_substitution f2 sub) - | Or (f1, f2) - -> Or (apply_substitution f1 sub, apply_substitution f2 sub) - | Implies (f1, f2) - -> Implies (apply_substitution f1 sub, apply_substitution f2 sub) - | InNode (node_type_list, f1) - -> InNode (sub_list_param node_type_list, apply_substitution f1 sub) - | AU (trans, f1, f2) - -> AU (trans, apply_substitution f1 sub, apply_substitution f2 sub) - | EU (trans, f1, f2) - -> EU (trans, apply_substitution f1 sub, apply_substitution f2 sub) - | EF (trans, f1) - -> EF (trans, apply_substitution f1 sub) - | AF (trans, f1) - -> AF (trans, apply_substitution f1 sub) - | AG (trans, f1) - -> AG (trans, apply_substitution f1 sub) - | EX (trans, f1) - -> EX (trans, apply_substitution f1 sub) - | AX (trans, f1) - -> AX (trans, apply_substitution f1 sub) - | EH (cl, f1) - -> EH (sub_list_param cl, apply_substitution f1 sub) - | EG (trans, f1) - -> EG (trans, apply_substitution f1 sub) - | ET (ntl, sw, f1) - -> ET (sub_list_param ntl, sw, apply_substitution f1 sub) + | True | False -> + f + | Atomic (name, ps) -> + Atomic (name, sub_list_param ps) + | Not f1 -> + Not (apply_substitution f1 sub) + | And (f1, f2) -> + And (apply_substitution f1 sub, apply_substitution f2 sub) + | Or (f1, f2) -> + Or (apply_substitution f1 sub, apply_substitution f2 sub) + | Implies (f1, f2) -> + Implies (apply_substitution f1 sub, apply_substitution f2 sub) + | InNode (node_type_list, f1) -> + InNode (sub_list_param node_type_list, apply_substitution f1 sub) + | AU (trans, f1, f2) -> + AU (trans, apply_substitution f1 sub, apply_substitution f2 sub) + | EU (trans, f1, f2) -> + EU (trans, apply_substitution f1 sub, apply_substitution f2 sub) + | EF (trans, f1) -> + EF (trans, apply_substitution f1 sub) + | AF (trans, f1) -> + AF (trans, apply_substitution f1 sub) + | AG (trans, f1) -> + AG (trans, apply_substitution f1 sub) + | EX (trans, f1) -> + EX (trans, apply_substitution f1 sub) + | AX (trans, f1) -> + AX (trans, apply_substitution f1 sub) + | EH (cl, f1) -> + EH (sub_list_param cl, apply_substitution f1 sub) + | EG (trans, f1) -> + EG (trans, apply_substitution f1 sub) + | ET (ntl, sw, f1) -> + ET (sub_list_param ntl, sw, apply_substitution f1 sub) + let expand_formula phi _map _error_msg = let fail_with_circular_macro_definition name error_msg = @@ -284,109 +300,114 @@ let expand_formula phi _map _error_msg = let open CTL in let rec expand acc map error_msg = match acc with - | True | False - -> acc + | True | False -> + acc | Atomic ((ALVar.Formula_id name as av), actual_param) - -> ( + -> ( (* it may be a macro *) let error_msg' = error_msg ^ " -Expanding formula identifier '" ^ name ^ "'@\n" in try match ALVar.FormulaIdMap.find av map with - | true, _, _ - -> fail_with_circular_macro_definition name error_msg' + | true, _, _ -> + fail_with_circular_macro_definition name error_msg' | false, fparams, f1 -> (* in this case it should be a defined macro *) match List.zip fparams actual_param with - | Some sub - -> let f1_sub = apply_substitution f1 sub in + | Some sub -> + let f1_sub = apply_substitution f1 sub in let map' = ALVar.FormulaIdMap.add av (true, fparams, f1) map in expand f1_sub map' error_msg' - | None - -> L.(die ExternalError) + | None -> + L.(die ExternalError) "Formula identifier '%s' is not called with the right number of parameters" name with Not_found -> acc (* in this case it should be a predicate *) ) - | Not f1 - -> Not (expand f1 map error_msg) - | And (f1, f2) - -> And (expand f1 map error_msg, expand f2 map error_msg) - | Or (f1, f2) - -> Or (expand f1 map error_msg, expand f2 map error_msg) - | Implies (f1, f2) - -> Implies (expand f1 map error_msg, expand f2 map error_msg) - | InNode (node_type_list, f1) - -> InNode (node_type_list, expand f1 map error_msg) - | AU (trans, f1, f2) - -> AU (trans, expand f1 map error_msg, expand f2 map error_msg) - | EU (trans, f1, f2) - -> EU (trans, expand f1 map error_msg, expand f2 map error_msg) - | EF (trans, f1) - -> EF (trans, expand f1 map error_msg) - | AF (trans, f1) - -> AF (trans, expand f1 map error_msg) - | AG (trans, f1) - -> AG (trans, expand f1 map error_msg) - | EX (trans, f1) - -> EX (trans, expand f1 map error_msg) - | AX (trans, f1) - -> AX (trans, expand f1 map error_msg) - | EH (cl, f1) - -> EH (cl, expand f1 map error_msg) - | EG (trans, f1) - -> EG (trans, expand f1 map error_msg) - | ET (tl, sw, f1) - -> ET (tl, sw, expand f1 map error_msg) + | Not f1 -> + Not (expand f1 map error_msg) + | And (f1, f2) -> + And (expand f1 map error_msg, expand f2 map error_msg) + | Or (f1, f2) -> + Or (expand f1 map error_msg, expand f2 map error_msg) + | Implies (f1, f2) -> + Implies (expand f1 map error_msg, expand f2 map error_msg) + | InNode (node_type_list, f1) -> + InNode (node_type_list, expand f1 map error_msg) + | AU (trans, f1, f2) -> + AU (trans, expand f1 map error_msg, expand f2 map error_msg) + | EU (trans, f1, f2) -> + EU (trans, expand f1 map error_msg, expand f2 map error_msg) + | EF (trans, f1) -> + EF (trans, expand f1 map error_msg) + | AF (trans, f1) -> + AF (trans, expand f1 map error_msg) + | AG (trans, f1) -> + AG (trans, expand f1 map error_msg) + | EX (trans, f1) -> + EX (trans, expand f1 map error_msg) + | AX (trans, f1) -> + AX (trans, expand f1 map error_msg) + | EH (cl, f1) -> + EH (cl, expand f1 map error_msg) + | EG (trans, f1) -> + EG (trans, expand f1 map error_msg) + | ET (tl, sw, f1) -> + ET (tl, sw, expand f1 map error_msg) in expand phi _map _error_msg + let rec expand_path paths path_map = match paths with - | [] - -> [] + | [] -> + [] | (ALVar.Var path_var) :: rest -> ( try let paths = ALVar.VarMap.find path_var path_map in List.append paths (expand_path rest path_map) with Not_found -> L.(die ExternalError) "Path variable %s not found. " path_var ) - | path :: rest - -> path :: expand_path rest path_map + | path :: rest -> + path :: expand_path rest path_map + let _build_macros_map macros init_map = let macros_map = List.fold ~f:(fun map' data -> match data with - | CTL.CLet (key, params, formula) - -> if ALVar.FormulaIdMap.mem key map' then + | CTL.CLet (key, params, formula) -> + if ALVar.FormulaIdMap.mem key map' then L.(die ExternalError) "Macro '%s' has more than one definition." (ALVar.formula_id_to_string key) else ALVar.FormulaIdMap.add key (false, params, formula) map' - | _ - -> map') + | _ -> + map') ~init:init_map macros in macros_map + let build_macros_map macros = let init_map : macros_map = ALVar.FormulaIdMap.empty in _build_macros_map macros init_map + let build_paths_map paths = let build_paths_map_aux paths init_map = let paths_map = List.fold ~f:(fun map' data -> - match data - with path_name, paths -> - if ALVar.VarMap.mem path_name map' then - L.(die ExternalError) "Path '%s' has more than one definition." path_name - else ALVar.VarMap.add path_name paths map') + match data with + | path_name, paths -> + if ALVar.VarMap.mem path_name map' then + L.(die ExternalError) "Path '%s' has more than one definition." path_name + else ALVar.VarMap.add path_name paths map') ~init:init_map paths in paths_map in build_paths_map_aux paths ALVar.VarMap.empty + (* expands use of let defined formula id in checkers with their definition *) let expand_checkers macro_map path_map checkers = let open CTL in @@ -397,30 +418,32 @@ let expand_checkers macro_map path_map checkers = List.fold ~f:(fun defs clause -> match clause with - | CSet (report_when_const, phi) - -> L.(debug Linters Medium) " -Expanding report_when@\n" ; + | CSet (report_when_const, phi) -> + L.(debug Linters Medium) " -Expanding report_when@\n" ; CSet (report_when_const, expand_formula phi map "") :: defs - | CPath (black_or_white_list, paths) - -> L.(debug Linters Medium) " -Expanding path@\n" ; + | CPath (black_or_white_list, paths) -> + L.(debug Linters Medium) " -Expanding path@\n" ; CPath (black_or_white_list, expand_path paths path_map) :: defs - | cl - -> cl :: defs) + | cl -> + cl :: defs) ~init:[] c.definitions in {c with definitions= exp_defs} in List.map ~f:expand_one_checker checkers + let get_err_log translation_unit_context method_decl_opt = let procname = match method_decl_opt with - | Some method_decl - -> CProcname.from_decl_for_linters translation_unit_context method_decl - | None - -> Typ.Procname.Linters_dummy_method + | Some method_decl -> + CProcname.from_decl_for_linters translation_unit_context method_decl + | None -> + Typ.Procname.Linters_dummy_method in LintIssues.get_err_log procname + (** Add a frontend warning with a description desc at location loc to the errlog of a proc desc *) let log_frontend_issue translation_unit_context method_decl_opt (node: Ctl_parser_types.ast_node) (issue_desc: CIssue.issue_desc) linters_def_file = @@ -433,15 +456,16 @@ let log_frontend_issue translation_unit_context method_decl_opt (node: Ctl_parse let err_kind = issue_desc.severity in let key_str = match node with - | Decl dec - -> CAst_utils.generate_key_decl dec - | Stmt st - -> CAst_utils.generate_key_stmt st + | Decl dec -> + CAst_utils.generate_key_decl dec + | Stmt st -> + CAst_utils.generate_key_stmt st in let key = Hashtbl.hash key_str in Reporting.log_issue_from_errlog err_kind errlog exn ~loc:issue_desc.loc ~ltr:trace ~node_id:(0, key) ?linters_def_file ?doc_url:issue_desc.doc_url + let fill_issue_desc_info_and_log context an (issue_desc: CIssue.issue_desc) linters_def_file loc = let process_message message = remove_new_lines_and_whitespace (expand_message_string context message an) @@ -452,6 +476,7 @@ let fill_issue_desc_info_and_log context an (issue_desc: CIssue.issue_desc) lint log_frontend_issue context.CLintersContext.translation_unit_context context.CLintersContext.current_method an issue_desc' linters_def_file + (* Calls the set of hard coded checkers (if any) *) let invoke_set_of_hard_coded_checkers_an context (an: Ctl_parser_types.ast_node) = let checkers = match an with Decl _ -> decl_checkers_list | Stmt _ -> stmt_checkers_list in @@ -465,27 +490,30 @@ let invoke_set_of_hard_coded_checkers_an context (an: Ctl_parser_types.ast_node) issue_desc_list) checkers + (* Calls the set of checkers parsed from files (if any) *) let invoke_set_of_parsed_checkers_an parsed_linters context (an: Ctl_parser_types.ast_node) = List.iter ~f:(fun (linter: linter) -> if CIssue.should_run_check linter.issue_desc.CIssue.mode then match CTL.eval_formula linter.condition an context with - | None - -> () - | Some witness - -> let loc = CFrontend_checkers.location_from_an context witness in + | None -> + () + | Some witness -> + let loc = CFrontend_checkers.location_from_an context witness in fill_issue_desc_info_and_log context witness linter.issue_desc linter.def_file loc) parsed_linters + (* We decouple the hardcoded checkers from the parsed ones *) let invoke_set_of_checkers_on_node context an = ( match an with - | Ctl_parser_types.Decl Clang_ast_t.TranslationUnitDecl _ - -> (* Don't run parsed linters on TranslationUnitDecl node. + | Ctl_parser_types.Decl Clang_ast_t.TranslationUnitDecl _ -> + (* Don't run parsed linters on TranslationUnitDecl node. Because depending on the formula it may give an error at line -1 *) () - | _ - -> if not CFrontend_config.tableaux_evaluation then + | _ -> + if not CFrontend_config.tableaux_evaluation then invoke_set_of_parsed_checkers_an !parsed_linters context an ) ; if Config.default_linters then invoke_set_of_hard_coded_checkers_an context an + diff --git a/infer/src/clang/cGeneral_utils.ml b/infer/src/clang/cGeneral_utils.ml index c557e3e60..3577f6235 100644 --- a/infer/src/clang/cGeneral_utils.ml +++ b/infer/src/clang/cGeneral_utils.ml @@ -18,23 +18,26 @@ type var_info = Clang_ast_t.decl_info * Clang_ast_t.qual_type * Clang_ast_t.var_ let rec swap_elements_list l = match l with - | el1 :: el2 :: rest - -> el2 :: el1 :: swap_elements_list rest - | [] - -> [] - | _ - -> assert false + | el1 :: el2 :: rest -> + el2 :: el1 :: swap_elements_list rest + | [] -> + [] + | _ -> + assert false + let rec string_from_list l = match l with [] -> "" | [item] -> item | item :: l' -> item ^ " " ^ string_from_list l' + let rec append_no_duplicates eq list1 list2 = match list2 with - | el :: rest2 - -> if List.mem ~equal:eq list1 el then append_no_duplicates eq list1 rest2 + | el :: rest2 -> + if List.mem ~equal:eq list1 el then append_no_duplicates eq list1 rest2 else append_no_duplicates eq list1 rest2 @ [el] - | [] - -> list1 + | [] -> + list1 + let append_no_duplicates_csu list1 list2 = append_no_duplicates Typ.Name.equal list1 list2 @@ -42,89 +45,102 @@ let append_no_duplicates_annotations list1 list2 = let eq (annot1, _) (annot2, _) = String.equal annot1.Annot.class_name annot2.Annot.class_name in append_no_duplicates eq list1 list2 + let add_no_duplicates_fields field_tuple l = let rec replace_field field_tuple l found = match (field_tuple, l) with - | (field, typ, annot), (old_field, old_typ, old_annot as old_field_tuple) :: rest - -> let ret_list, ret_found = replace_field field_tuple rest found in + | (field, typ, annot), ((old_field, old_typ, old_annot) as old_field_tuple) :: rest -> + let ret_list, ret_found = replace_field field_tuple rest found in if Typ.Fieldname.equal field old_field && Typ.equal typ old_typ then let annotations = append_no_duplicates_annotations annot old_annot in ((field, typ, annotations) :: ret_list, true) else (old_field_tuple :: ret_list, ret_found) - | _, [] - -> ([], found) + | _, [] -> + ([], found) in let new_list, found = replace_field field_tuple l false in if found then new_list else field_tuple :: l + let rec append_no_duplicates_fields list1 list2 = match list1 with - | field_tuple :: rest - -> let updated_list2 = append_no_duplicates_fields rest list2 in + | field_tuple :: rest -> + let updated_list2 = append_no_duplicates_fields rest list2 in add_no_duplicates_fields field_tuple updated_list2 - | [] - -> list2 + | [] -> + list2 + let rec collect_list_tuples l (a, a1, b, c, d) = match l with - | [] - -> (a, a1, b, c, d) - | (a', a1', b', c', d') :: l' - -> collect_list_tuples l' (a @ a', a1 @ a1', b @ b', c @ c', d @ d') + | [] -> + (a, a1, b, c, d) + | (a', a1', b', c', d') :: l' -> + collect_list_tuples l' (a @ a', a1 @ a1', b @ b', c @ c', d @ d') + let is_static_var var_decl_info = match var_decl_info.Clang_ast_t.vdi_storage_class with - | Some sc - -> String.equal sc CFrontend_config.static - | _ - -> false + | Some sc -> + String.equal sc CFrontend_config.static + | _ -> + false + let rec zip xs ys = match (xs, ys) with [], _ | _, [] -> [] | x :: xs, y :: ys -> (x, y) :: zip xs ys + let list_range i j = let rec aux n acc = if n < i then acc else aux (n - 1) (n :: acc) in aux j [] + let replicate n el = List.map ~f:(fun _ -> el) (list_range 0 (n - 1)) let mk_class_field_name class_tname field_name = Typ.Fieldname.Clang.from_class_name class_tname field_name + let is_cpp_translation translation_unit_context = let lang = translation_unit_context.CFrontend_config.lang in CFrontend_config.equal_clang_lang lang CFrontend_config.CPP || CFrontend_config.equal_clang_lang lang CFrontend_config.ObjCPP + let is_objc_extension translation_unit_context = let lang = translation_unit_context.CFrontend_config.lang in CFrontend_config.equal_clang_lang lang CFrontend_config.ObjC || CFrontend_config.equal_clang_lang lang CFrontend_config.ObjCPP + let get_var_name_mangled name_info var_decl_info = let clang_name = CAst_utils.get_qualified_name name_info |> QualifiedCppName.to_qual_string in let param_idx_opt = var_decl_info.Clang_ast_t.vdi_parm_index_in_function in let name_string = match (clang_name, param_idx_opt) with - | "", Some index - -> "__param_" ^ string_of_int index - | "", None - -> CFrontend_config.incorrect_assumption + | "", Some index -> + "__param_" ^ string_of_int index + | "", None -> + CFrontend_config.incorrect_assumption "Got both empty clang_name and None for param_idx in get_var_name_mangled (%a) (%a)" - (Pp.to_string ~f:Clang_ast_j.string_of_named_decl_info) name_info - (Pp.to_string ~f:Clang_ast_j.string_of_var_decl_info) var_decl_info - | _ - -> clang_name + (Pp.to_string ~f:Clang_ast_j.string_of_named_decl_info) + name_info + (Pp.to_string ~f:Clang_ast_j.string_of_var_decl_info) + var_decl_info + | _ -> + clang_name in let mangled = match param_idx_opt with - | Some index - -> Mangled.mangled name_string (string_of_int index) - | None - -> Mangled.from_string name_string + | Some index -> + Mangled.mangled name_string (string_of_int index) + | None -> + Mangled.from_string name_string in (name_string, mangled) + let mk_sil_global_var {CFrontend_config.source_file} ?(mk_name= fun _ x -> x) named_decl_info var_decl_info qt = let name_string, simple_name = get_var_name_mangled named_decl_info var_decl_info in @@ -132,36 +148,37 @@ let mk_sil_global_var {CFrontend_config.source_file} ?(mk_name= fun _ x -> x) na match (var_decl_info.Clang_ast_t.vdi_storage_class, var_decl_info.Clang_ast_t.vdi_init_expr) with - | Some "extern", None - -> (* some compilers simply disregard "extern" when the global is given some initialisation + | Some "extern", None -> + (* some compilers simply disregard "extern" when the global is given some initialisation code, which is why we make sure that [vdi_init_expr] is None here... *) Pvar.TUExtern - | _ - -> Pvar.TUFile source_file + | _ -> + Pvar.TUFile source_file in let is_constexpr = var_decl_info.Clang_ast_t.vdi_is_const_expr in let is_pod = CAst_utils.get_desugared_type qt.Clang_ast_t.qt_type_ptr |> Option.bind ~f:(function - | Clang_ast_t.RecordType (_, decl_ptr) - -> CAst_utils.get_decl decl_ptr - | _ - -> None ) + | Clang_ast_t.RecordType (_, decl_ptr) -> + CAst_utils.get_decl decl_ptr + | _ -> + None ) |> Option.value_map ~default:true ~f:(function | Clang_ast_t.CXXRecordDecl (_, _, _, _, _, _, _, {xrdi_is_pod}) - | Clang_ast_t.ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, {xrdi_is_pod}, _, _) - -> xrdi_is_pod - | _ - -> true ) + | Clang_ast_t.ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, {xrdi_is_pod}, _, _) -> + xrdi_is_pod + | _ -> + true ) in Pvar.mk_global ~is_constexpr ~is_pod ~is_static_local:var_decl_info.Clang_ast_t.vdi_is_static_local (mk_name name_string simple_name) translation_unit + let mk_sil_var trans_unit_ctx named_decl_info decl_info_qual_type_opt procname outer_procname = match decl_info_qual_type_opt with - | Some (decl_info, qt, var_decl_info, should_be_mangled) - -> let name_string, simple_name = get_var_name_mangled named_decl_info var_decl_info in + | Some (decl_info, qt, var_decl_info, should_be_mangled) -> + let name_string, simple_name = get_var_name_mangled named_decl_info var_decl_info in if var_decl_info.Clang_ast_t.vdi_is_global then let mk_name = if var_decl_info.Clang_ast_t.vdi_is_static_local then @@ -179,8 +196,9 @@ let mk_sil_var trans_unit_ctx named_decl_info decl_info_qual_type_opt procname o let mangled = Utils.string_crc_hex32 line_str in let mangled_name = Mangled.mangled name_string mangled in Pvar.mk mangled_name procname - | None - -> let name_string = + | None -> + let name_string = CAst_utils.get_qualified_name named_decl_info |> QualifiedCppName.to_qual_string in Pvar.mk (Mangled.from_string name_string) procname + diff --git a/infer/src/clang/cIssue.ml b/infer/src/clang/cIssue.ml index 9c6c7d134..4916efaa6 100644 --- a/infer/src/clang/cIssue.ml +++ b/infer/src/clang/cIssue.ml @@ -40,9 +40,11 @@ let pp_issue fmt issue = Format.fprintf fmt " Loc = %s@\n" (Location.to_string issue.loc) ; Format.fprintf fmt "}@\n" + let should_run_check mode = match mode with - | On - -> true - | Off - -> Config.debug_mode || Config.debug_exceptions || not Config.filtering + | On -> + true + | Off -> + Config.debug_mode || Config.debug_exceptions || not Config.filtering + diff --git a/infer/src/clang/cLocation.ml b/infer/src/clang/cLocation.ml index fe6a34abe..dda6c9b83 100644 --- a/infer/src/clang/cLocation.ml +++ b/infer/src/clang/cLocation.ml @@ -21,6 +21,7 @@ let clang_to_sil_location trans_unit_ctx clang_loc = in Location.{line; col; file} + let source_file_in_project source_file = let file_in_project = SourceFile.is_under_project_root source_file in let rel_source_file = SourceFile.to_string source_file in @@ -31,13 +32,15 @@ let source_file_in_project source_file = in file_in_project && not file_should_be_skipped + let should_do_frontend_check trans_unit_ctx (loc_start, _) = match Option.map ~f:SourceFile.from_abs_path loc_start.Clang_ast_t.sl_file with - | Some source_file - -> SourceFile.equal source_file trans_unit_ctx.CFrontend_config.source_file + | Some source_file -> + SourceFile.equal source_file trans_unit_ctx.CFrontend_config.source_file || source_file_in_project source_file && not Config.testing_mode - | None - -> false + | None -> + false + (** We translate by default the instructions in the current file. In C++ development, we also translate the headers that are part of the project. However, in testing mode, we don't want to @@ -46,10 +49,10 @@ let should_do_frontend_check trans_unit_ctx (loc_start, _) = let should_translate trans_unit_ctx (loc_start, loc_end) decl_trans_context ~translate_when_used = let map_file_of pred loc = match Option.map ~f:SourceFile.from_abs_path loc.Clang_ast_t.sl_file with - | Some f - -> pred f - | None - -> false + | Some f -> + pred f + | None -> + false in (* it's not necessary to compare inodes here because both files come from the same context - they are produced by the same invocation of ASTExporter @@ -72,10 +75,12 @@ let should_translate trans_unit_ctx (loc_start, loc_end) decl_trans_context ~tra || Config.cxx && decl_trans_context = `Translation && translate_on_demand && not Config.testing_mode + let should_translate_lib trans_unit_ctx source_range decl_trans_context ~translate_when_used = not Config.no_translate_libs || should_translate trans_unit_ctx source_range decl_trans_context ~translate_when_used + let is_file_blacklisted file = let paths = Config.skip_analysis_in_path in let is_file_blacklisted = @@ -83,11 +88,14 @@ let is_file_blacklisted file = in is_file_blacklisted + let get_sil_location_from_range trans_unit_ctx source_range prefer_first = let sloc1, sloc2 = source_range in let sloc = if not prefer_first then sloc2 else sloc1 in clang_to_sil_location trans_unit_ctx sloc + let get_sil_location stmt_info context = let sloc1, _ = stmt_info.Clang_ast_t.si_source_range in clang_to_sil_location context.CContext.translation_unit_context sloc1 + diff --git a/infer/src/clang/cMethod_signature.ml b/infer/src/clang/cMethod_signature.ml index 22a06fcd4..851adcaf7 100644 --- a/infer/src/clang/cMethod_signature.ml +++ b/infer/src/clang/cMethod_signature.ml @@ -62,11 +62,13 @@ let ms_get_return_param_typ {return_param_typ} = return_param_typ let ms_is_getter {pointer_to_property_opt; args} = Option.is_some pointer_to_property_opt && Int.equal (List.length args) 1 + (* A method is a setter if it has a link to a property and *) (* it has 2 argument (this includes self) *) let ms_is_setter {pointer_to_property_opt; args} = Option.is_some pointer_to_property_opt && Int.equal (List.length args) 2 + let make_ms name args ret_type attributes loc is_instance ?is_cpp_virtual ?is_cpp_nothrow language pointer_to_parent pointer_to_property_opt return_param_typ access = let booloption_to_bool = function Some b -> b | None -> false in @@ -86,6 +88,7 @@ let make_ms name args ret_type attributes loc is_instance ?is_cpp_virtual ?is_cp ; pointer_to_property_opt ; return_param_typ } + let replace_name_ms ms name = {ms with name} let ms_to_string ms = @@ -95,3 +98,4 @@ let ms_to_string ms = ms.args ^ "->" ^ Clang_ast_extend.type_ptr_to_string ms.ret_type.Clang_ast_t.qt_type_ptr ^ " " ^ Clang_ast_j.string_of_source_range ms.loc + diff --git a/infer/src/clang/cMethod_trans.ml b/infer/src/clang/cMethod_trans.ml index 8437ca61a..9848becf0 100644 --- a/infer/src/clang/cMethod_trans.ml +++ b/infer/src/clang/cMethod_trans.ml @@ -36,39 +36,44 @@ type function_method_decl_info = let is_instance_method function_method_decl_info = match function_method_decl_info with - | Func_decl_info _ | Block_decl_info _ - -> false - | Cpp_Meth_decl_info (_, method_decl_info, _, _) - -> not method_decl_info.Clang_ast_t.xmdi_is_static - | ObjC_Meth_decl_info (method_decl_info, _) - -> method_decl_info.Clang_ast_t.omdi_is_instance_method + | Func_decl_info _ | Block_decl_info _ -> + false + | Cpp_Meth_decl_info (_, method_decl_info, _, _) -> + not method_decl_info.Clang_ast_t.xmdi_is_static + | ObjC_Meth_decl_info (method_decl_info, _) -> + method_decl_info.Clang_ast_t.omdi_is_instance_method + let get_original_return_type function_method_decl_info = match function_method_decl_info with - | Func_decl_info (_, typ) | Cpp_Meth_decl_info (_, _, _, typ) | Block_decl_info (_, typ, _) - -> CType.return_type_of_function_type typ - | ObjC_Meth_decl_info (method_decl_info, _) - -> method_decl_info.Clang_ast_t.omdi_result_type + | Func_decl_info (_, typ) | Cpp_Meth_decl_info (_, _, _, typ) | Block_decl_info (_, typ, _) -> + CType.return_type_of_function_type typ + | ObjC_Meth_decl_info (method_decl_info, _) -> + method_decl_info.Clang_ast_t.omdi_result_type + let get_class_param function_method_decl_info = if is_instance_method function_method_decl_info then match function_method_decl_info with - | Cpp_Meth_decl_info (_, _, class_decl_ptr, _) - -> let class_type = CAst_utils.qual_type_of_decl_ptr class_decl_ptr in + | Cpp_Meth_decl_info (_, _, class_decl_ptr, _) -> + let class_type = CAst_utils.qual_type_of_decl_ptr class_decl_ptr in [(Mangled.from_string CFrontend_config.this, class_type)] - | ObjC_Meth_decl_info (_, class_decl_ptr) - -> let class_type = CAst_utils.qual_type_of_decl_ptr class_decl_ptr in + | ObjC_Meth_decl_info (_, class_decl_ptr) -> + let class_type = CAst_utils.qual_type_of_decl_ptr class_decl_ptr in [(Mangled.from_string CFrontend_config.self, class_type)] - | _ - -> [] + | _ -> + [] else [] + let should_add_return_param return_type ~is_objc_method = match return_type.Typ.desc with Tstruct _ -> not is_objc_method | _ -> false + let is_objc_method function_method_decl_info = match function_method_decl_info with ObjC_Meth_decl_info _ -> true | _ -> false + let get_return_param tenv function_method_decl_info = let is_objc_method = is_objc_method function_method_decl_info in let return_qual_type = get_original_return_type function_method_decl_info in @@ -78,39 +83,44 @@ let get_return_param tenv function_method_decl_info = , Ast_expressions.create_pointer_qual_type return_qual_type ) ] else [] + let get_param_decls function_method_decl_info = match function_method_decl_info with - | Func_decl_info (function_decl_info, _) | Cpp_Meth_decl_info (function_decl_info, _, _, _) - -> function_decl_info.Clang_ast_t.fdi_parameters - | ObjC_Meth_decl_info (method_decl_info, _) - -> method_decl_info.Clang_ast_t.omdi_parameters - | Block_decl_info (block_decl_info, _, _) - -> block_decl_info.Clang_ast_t.bdi_parameters + | Func_decl_info (function_decl_info, _) | Cpp_Meth_decl_info (function_decl_info, _, _, _) -> + function_decl_info.Clang_ast_t.fdi_parameters + | ObjC_Meth_decl_info (method_decl_info, _) -> + method_decl_info.Clang_ast_t.omdi_parameters + | Block_decl_info (block_decl_info, _, _) -> + block_decl_info.Clang_ast_t.bdi_parameters + let get_language trans_unit_ctx function_method_decl_info = match function_method_decl_info with - | Func_decl_info (_, _) - -> trans_unit_ctx.CFrontend_config.lang - | Cpp_Meth_decl_info _ - -> CFrontend_config.CPP - | ObjC_Meth_decl_info _ - -> CFrontend_config.ObjC - | Block_decl_info _ - -> CFrontend_config.ObjC + | Func_decl_info (_, _) -> + trans_unit_ctx.CFrontend_config.lang + | Cpp_Meth_decl_info _ -> + CFrontend_config.CPP + | ObjC_Meth_decl_info _ -> + CFrontend_config.ObjC + | Block_decl_info _ -> + CFrontend_config.ObjC + let is_cpp_virtual function_method_decl_info = match function_method_decl_info with - | Cpp_Meth_decl_info (_, mdi, _, _) - -> mdi.Clang_ast_t.xmdi_is_virtual - | _ - -> false + | Cpp_Meth_decl_info (_, mdi, _, _) -> + mdi.Clang_ast_t.xmdi_is_virtual + | _ -> + false + let is_cpp_nothrow function_method_decl_info = match function_method_decl_info with - | Func_decl_info (fdi, _) | Cpp_Meth_decl_info (fdi, _, _, _) - -> fdi.Clang_ast_t.fdi_is_no_throw - | _ - -> false + | Func_decl_info (fdi, _) | Cpp_Meth_decl_info (fdi, _, _, _) -> + fdi.Clang_ast_t.fdi_is_no_throw + | _ -> + false + (** Returns parameters of a function/method. They will have following order: 1. self/this parameter (optional, only for methods) @@ -119,24 +129,25 @@ let is_cpp_nothrow function_method_decl_info = let get_parameters trans_unit_ctx tenv function_method_decl_info = let par_to_ms_par par = match par with - | Clang_ast_t.ParmVarDecl (_, name_info, qt, var_decl_info) - -> let _, mangled = CGeneral_utils.get_var_name_mangled name_info var_decl_info in + | Clang_ast_t.ParmVarDecl (_, name_info, qt, var_decl_info) -> + let _, mangled = CGeneral_utils.get_var_name_mangled name_info var_decl_info in let param_typ = CType_decl.qual_type_to_sil_type tenv qt in let new_qt = match param_typ.Typ.desc with - | Tstruct _ when CGeneral_utils.is_cpp_translation trans_unit_ctx - -> Ast_expressions.create_reference_qual_type qt - | _ - -> qt + | Tstruct _ when CGeneral_utils.is_cpp_translation trans_unit_ctx -> + Ast_expressions.create_reference_qual_type qt + | _ -> + qt in (mangled, new_qt) - | _ - -> assert false + | _ -> + assert false in let pars = List.map ~f:par_to_ms_par (get_param_decls function_method_decl_info) in get_class_param function_method_decl_info @ pars @ get_return_param tenv function_method_decl_info + (** get return type of the function and optionally type of function's return parameter *) let get_return_val_and_param_types tenv function_method_decl_info = let return_qual_type = get_original_return_type function_method_decl_info in @@ -146,6 +157,7 @@ let get_return_val_and_param_types tenv function_method_decl_info = (Ast_expressions.create_void_type, Some (CType.add_pointer_to_typ return_typ)) else (return_qual_type, None) + let build_method_signature trans_unit_ctx tenv decl_info procname function_method_decl_info parent_pointer pointer_to_property_opt = let source_range = decl_info.Clang_ast_t.di_source_range in @@ -161,23 +173,25 @@ let build_method_signature trans_unit_ctx tenv decl_info procname function_metho ~is_cpp_virtual ~is_cpp_nothrow lang parent_pointer pointer_to_property_opt return_param_type_opt access + let get_init_list_instrs method_decl_info = let create_custom_instr construct_instr = `CXXConstructorInit construct_instr in List.map ~f:create_custom_instr method_decl_info.Clang_ast_t.xmdi_cxx_ctor_initializers + let method_signature_of_decl trans_unit_ctx tenv meth_decl block_data_opt = let open Clang_ast_t in match (meth_decl, block_data_opt) with - | FunctionDecl (decl_info, _, qt, fdi), _ - -> let func_decl = Func_decl_info (fdi, qt) in + | FunctionDecl (decl_info, _, qt, fdi), _ -> + let func_decl = Func_decl_info (fdi, qt) in let procname = CProcname.from_decl trans_unit_ctx ~tenv meth_decl in let ms = build_method_signature trans_unit_ctx tenv decl_info procname func_decl None None in (ms, fdi.Clang_ast_t.fdi_body, []) | CXXMethodDecl (decl_info, _, qt, fdi, mdi), _ | CXXConstructorDecl (decl_info, _, qt, fdi, mdi), _ | CXXConversionDecl (decl_info, _, qt, fdi, mdi), _ - | CXXDestructorDecl (decl_info, _, qt, fdi, mdi), _ - -> let procname = CProcname.from_decl trans_unit_ctx ~tenv meth_decl in + | CXXDestructorDecl (decl_info, _, qt, fdi, mdi), _ -> + let procname = CProcname.from_decl trans_unit_ctx ~tenv meth_decl in let parent_ptr = Option.value_exn decl_info.di_parent_pointer in let method_decl = Cpp_Meth_decl_info (fdi, mdi, parent_ptr, qt) in let parent_pointer = decl_info.Clang_ast_t.di_parent_pointer in @@ -188,59 +202,63 @@ let method_signature_of_decl trans_unit_ctx tenv meth_decl block_data_opt = let init_list_instrs = get_init_list_instrs mdi in (* it will be empty for methods *) (ms, fdi.Clang_ast_t.fdi_body, init_list_instrs) - | ObjCMethodDecl (decl_info, _, mdi), _ - -> let procname = CProcname.from_decl trans_unit_ctx ~tenv meth_decl in + | ObjCMethodDecl (decl_info, _, mdi), _ -> + let procname = CProcname.from_decl trans_unit_ctx ~tenv meth_decl in let parent_ptr = Option.value_exn decl_info.di_parent_pointer in let method_decl = ObjC_Meth_decl_info (mdi, parent_ptr) in let parent_pointer = decl_info.Clang_ast_t.di_parent_pointer in let pointer_to_property_opt = match mdi.Clang_ast_t.omdi_property_decl with - | Some decl_ref - -> Some decl_ref.Clang_ast_t.dr_decl_pointer - | None - -> None + | Some decl_ref -> + Some decl_ref.Clang_ast_t.dr_decl_pointer + | None -> + None in let ms = build_method_signature trans_unit_ctx tenv decl_info procname method_decl parent_pointer pointer_to_property_opt in (ms, mdi.omdi_body, []) - | BlockDecl (decl_info, bdi), Some (outer_context, tp, procname, _) - -> let func_decl = Block_decl_info (bdi, tp, outer_context) in + | BlockDecl (decl_info, bdi), Some (outer_context, tp, procname, _) -> + let func_decl = Block_decl_info (bdi, tp, outer_context) in let ms = build_method_signature trans_unit_ctx tenv decl_info procname func_decl None None in (ms, bdi.bdi_body, []) - | _ - -> raise Invalid_declaration + | _ -> + raise Invalid_declaration + let method_signature_of_pointer trans_unit_ctx tenv pointer = try match CAst_utils.get_decl pointer with - | Some meth_decl - -> let ms, _, _ = method_signature_of_decl trans_unit_ctx tenv meth_decl None in + | Some meth_decl -> + let ms, _, _ = method_signature_of_decl trans_unit_ctx tenv meth_decl None in Some ms - | None - -> None + | None -> + None with Invalid_declaration -> None + let get_method_name_from_clang tenv ms_opt = match ms_opt with | Some ms -> ( match CAst_utils.get_decl_opt (CMethod_signature.ms_get_pointer_to_parent ms) with - | Some decl - -> if ObjcProtocol_decl.is_protocol decl then None + | Some decl -> + if ObjcProtocol_decl.is_protocol decl then None else ( ignore (CType_decl.add_types_from_decl_to_tenv tenv decl) ; match ObjcCategory_decl.get_base_class_name_from_category decl with - | Some class_typename - -> let procname = CMethod_signature.ms_get_name ms in + | Some class_typename -> + let procname = CMethod_signature.ms_get_name ms in let new_procname = Typ.Procname.replace_class procname class_typename in - CMethod_signature.ms_set_name ms new_procname ; Some ms - | None - -> Some ms ) - | None - -> Some ms ) - | None - -> None + CMethod_signature.ms_set_name ms new_procname ; + Some ms + | None -> + Some ms ) + | None -> + Some ms ) + | None -> + None + let get_superclass_curr_class_objc context = let open Clang_ast_t in @@ -249,36 +267,37 @@ let get_superclass_curr_class_objc context = decl_ref |> Option.value_map ~f:(fun dr -> dr.dr_name) ~default:None |> Option.map ~f:CAst_utils.get_qualified_name with - | Some name - -> name - | None - -> assert false + | Some name -> + name + | None -> + assert false in let retreive_super_name ptr = match CAst_utils.get_decl ptr with - | Some ObjCInterfaceDecl (_, _, _, _, otdi) - -> super_of_decl_ref_opt otdi.otdi_super + | Some ObjCInterfaceDecl (_, _, _, _, otdi) -> + super_of_decl_ref_opt otdi.otdi_super | Some ObjCImplementationDecl (_, _, _, _, oi) -> ( match oi.Clang_ast_t.oidi_class_interface |> Option.map ~f:(fun dr -> dr.dr_decl_pointer) |> Option.value_map ~f:CAst_utils.get_decl ~default:None with - | Some ObjCInterfaceDecl (_, _, _, _, otdi) - -> super_of_decl_ref_opt otdi.otdi_super - | _ - -> assert false ) - | Some ObjCCategoryDecl (_, _, _, _, ocdi) - -> super_of_decl_ref_opt ocdi.odi_class_interface - | Some ObjCCategoryImplDecl (_, _, _, _, ocidi) - -> super_of_decl_ref_opt ocidi.ocidi_class_interface - | _ - -> assert false + | Some ObjCInterfaceDecl (_, _, _, _, otdi) -> + super_of_decl_ref_opt otdi.otdi_super + | _ -> + assert false ) + | Some ObjCCategoryDecl (_, _, _, _, ocdi) -> + super_of_decl_ref_opt ocdi.odi_class_interface + | Some ObjCCategoryImplDecl (_, _, _, _, ocidi) -> + super_of_decl_ref_opt ocidi.ocidi_class_interface + | _ -> + assert false in match CContext.get_curr_class context with - | CContext.ContextClsDeclPtr ptr - -> Typ.Name.Objc.from_qual_name (retreive_super_name ptr) - | CContext.ContextNoCls - -> assert false + | CContext.ContextClsDeclPtr ptr -> + Typ.Name.Objc.from_qual_name (retreive_super_name ptr) + | CContext.ContextNoCls -> + assert false + (* Gets the class name from a method signature found by clang, if search is successful *) let get_class_name_method_call_from_clang trans_unit_ctx tenv obj_c_message_expr_info = @@ -287,58 +306,63 @@ let get_class_name_method_call_from_clang trans_unit_ctx tenv obj_c_message_expr match method_signature_of_pointer trans_unit_ctx tenv pointer with | Some ms -> ( match CMethod_signature.ms_get_name ms with - | Typ.Procname.ObjC_Cpp objc_cpp - -> Some (Typ.Procname.objc_cpp_get_class_type_name objc_cpp) - | _ - -> None ) - | None - -> None ) - | None - -> None + | Typ.Procname.ObjC_Cpp objc_cpp -> + Some (Typ.Procname.objc_cpp_get_class_type_name objc_cpp) + | _ -> + None ) + | None -> + None ) + | None -> + None + (* Get class name from a method call accorsing to the info given by the receiver kind *) let get_class_name_method_call_from_receiver_kind context obj_c_message_expr_info act_params = match obj_c_message_expr_info.Clang_ast_t.omei_receiver_kind with - | `Class qt - -> let sil_type = CType_decl.qual_type_to_sil_type context.CContext.tenv qt in + | `Class qt -> + let sil_type = CType_decl.qual_type_to_sil_type context.CContext.tenv qt in CType.objc_classname_of_type sil_type | `Instance -> ( match act_params with - | (_, {Typ.desc= Tptr (t, _)}) :: _ | (_, t) :: _ - -> CType.objc_classname_of_type t - | _ - -> assert false ) - | `SuperInstance - -> get_superclass_curr_class_objc context - | `SuperClass - -> get_superclass_curr_class_objc context + | (_, {Typ.desc= Tptr (t, _)}) :: _ | (_, t) :: _ -> + CType.objc_classname_of_type t + | _ -> + assert false ) + | `SuperInstance -> + get_superclass_curr_class_objc context + | `SuperClass -> + get_superclass_curr_class_objc context + let get_objc_method_data obj_c_message_expr_info = let selector = obj_c_message_expr_info.Clang_ast_t.omei_selector in let pointer = obj_c_message_expr_info.Clang_ast_t.omei_decl_pointer in match obj_c_message_expr_info.Clang_ast_t.omei_receiver_kind with - | `Instance - -> (selector, pointer, MCVirtual) - | `SuperInstance - -> (selector, pointer, MCNoVirtual) - | `Class _ | `SuperClass - -> (selector, pointer, MCStatic) + | `Instance -> + (selector, pointer, MCVirtual) + | `SuperInstance -> + (selector, pointer, MCNoVirtual) + | `Class _ | `SuperClass -> + (selector, pointer, MCStatic) + let get_formal_parameters tenv ms = let rec defined_parameters pl = match pl with - | [] - -> [] - | (mangled, qual_type) :: pl' - -> let should_add_pointer name ms = + | [] -> + [] + | (mangled, qual_type) :: pl' -> + let should_add_pointer name ms = let is_objc_self = String.equal name CFrontend_config.self - && CFrontend_config.equal_clang_lang (CMethod_signature.ms_get_lang ms) + && CFrontend_config.equal_clang_lang + (CMethod_signature.ms_get_lang ms) CFrontend_config.ObjC in let is_cxx_this = String.equal name CFrontend_config.this - && CFrontend_config.equal_clang_lang (CMethod_signature.ms_get_lang ms) + && CFrontend_config.equal_clang_lang + (CMethod_signature.ms_get_lang ms) CFrontend_config.CPP in is_objc_self && CMethod_signature.ms_is_instance ms || is_cxx_this @@ -353,39 +377,43 @@ let get_formal_parameters tenv ms = in defined_parameters (CMethod_signature.ms_get_args ms) + let get_return_type tenv ms = let return_type = CMethod_signature.ms_get_ret_type ms in CType_decl.qual_type_to_sil_type tenv return_type + let sil_func_attributes_of_attributes attrs = let rec do_translation acc al = match al with - | [] - -> List.rev acc - | (Clang_ast_t.SentinelAttr attribute_info) :: tl - -> let sentinel, null_pos = + | [] -> + List.rev acc + | (Clang_ast_t.SentinelAttr attribute_info) :: tl -> + let sentinel, null_pos = match attribute_info.Clang_ast_t.ai_parameters with - | [a; b] - -> (int_of_string a, int_of_string b) - | _ - -> assert false + | [a; b] -> + (int_of_string a, int_of_string b) + | _ -> + assert false in do_translation (PredSymb.FA_sentinel (sentinel, null_pos) :: acc) tl - | _ :: tl - -> do_translation acc tl + | _ :: tl -> + do_translation acc tl in do_translation [] attrs + let should_create_procdesc cfg procname defined set_objc_accessor_attr = match Cfg.find_proc_desc_from_name cfg procname with - | Some previous_procdesc - -> let is_defined_previous = Procdesc.is_defined previous_procdesc in + | Some previous_procdesc -> + let is_defined_previous = Procdesc.is_defined previous_procdesc in if (defined || set_objc_accessor_attr) && not is_defined_previous then ( Cfg.remove_proc_desc cfg (Procdesc.get_proc_name previous_procdesc) ; true ) else false - | None - -> true + | None -> + true + let sil_method_annotation_of_args args method_type : Annot.Method.t = let args_types = List.map ~f:snd args in @@ -393,25 +421,27 @@ let sil_method_annotation_of_args args method_type : Annot.Method.t = let retval_annot = CAst_utils.sil_annot_of_type method_type in (retval_annot, param_annots) + let is_pointer_to_const {Clang_ast_t.qt_type_ptr} = match CAst_utils.get_type qt_type_ptr with | Some PointerType (_, {Clang_ast_t.qt_is_const}) | Some ObjCObjectPointerType (_, {Clang_ast_t.qt_is_const}) | Some RValueReferenceType (_, {Clang_ast_t.qt_is_const}) - | Some LValueReferenceType (_, {Clang_ast_t.qt_is_const}) - -> qt_is_const - | _ - -> false + | Some LValueReferenceType (_, {Clang_ast_t.qt_is_const}) -> + qt_is_const + | _ -> + false + let is_value {Clang_ast_t.qt_type_ptr} = match qt_type_ptr with | Clang_ast_extend.Builtin _ (* We rely on the assumption here that Clang_ast_extend.ReferenceOf is only created for pass-by-value structs. *) (* TODO: Create a dedicated variant in Clang_ast_extend for pass-by-val params *) - | Clang_ast_extend.ReferenceOf _ - -> true - | Clang_ast_types.TypePtr.Ptr _ - -> let rec is_value_raw qt_type_ptr = + | Clang_ast_extend.ReferenceOf _ -> + true + | Clang_ast_types.TypePtr.Ptr _ -> + let rec is_value_raw qt_type_ptr = match CAst_utils.get_type qt_type_ptr with | Some BuiltinType _ | Some ComplexType _ @@ -422,16 +452,16 @@ let is_value {Clang_ast_t.qt_type_ptr} = | Some EnumType _ | Some InjectedClassNameType _ | Some ObjCObjectType _ - | Some ObjCInterfaceType _ - -> true + | Some ObjCInterfaceType _ -> + true | Some AdjustedType (_, {Clang_ast_t.qt_type_ptr}) | Some DecayedType (_, {Clang_ast_t.qt_type_ptr}) | Some ParenType (_, {Clang_ast_t.qt_type_ptr}) | Some DecltypeType (_, {Clang_ast_t.qt_type_ptr}) - | Some AtomicType (_, {Clang_ast_t.qt_type_ptr}) - -> is_value_raw qt_type_ptr - | Some TypedefType (_, {Clang_ast_t.tti_child_type}) - -> is_value_raw tti_child_type.Clang_ast_t.qt_type_ptr + | Some AtomicType (_, {Clang_ast_t.qt_type_ptr}) -> + is_value_raw qt_type_ptr + | Some TypedefType (_, {Clang_ast_t.tti_child_type}) -> + is_value_raw tti_child_type.Clang_ast_t.qt_type_ptr (* These types could be value types, and we try our best to resolve them *) | Some AttributedType ({Clang_ast_t.ti_desugared_type}, _) | Some TypeOfExprType {Clang_ast_t.ti_desugared_type} @@ -466,67 +496,71 @@ let is_value {Clang_ast_t.qt_type_ptr} = (* These types I don't know what they are. Be conservative and treat them as non value types *) | Some ObjCTypeParamType _ | Some PipeType _ - | None - -> false + | None -> + false in is_value_raw qt_type_ptr - | _ - -> false + | _ -> + false + (** Returns a list of the indices of expressions in [args] which point to const-typed values. Each index is offset by [shift]. *) let get_const_args_indices ~shift args = let i = ref shift in let rec aux result = function - | [] - -> List.rev result - | (_, qual_type) :: tl - -> incr i ; + | [] -> + List.rev result + | (_, qual_type) :: tl -> + incr i ; if is_pointer_to_const qual_type then aux (!i - 1 :: result) tl else aux result tl in aux [] args + let get_byval_args_indices ~shift args = List.filter_mapi args ~f:(fun index (_, qual_type) -> let index' = index + shift in Option.some_if (is_value qual_type) index' ) + let get_objc_property_accessor tenv ms = let open Clang_ast_t in match CAst_utils.get_decl_opt (CMethod_signature.ms_get_pointer_to_property_opt ms) with | Some ObjCPropertyDecl (_, _, obj_c_property_decl_info) - -> ( + -> ( let ivar_decl_ref = obj_c_property_decl_info.Clang_ast_t.opdi_ivar_decl in match CAst_utils.get_decl_opt_with_decl_ref ivar_decl_ref with | Some ObjCIvarDecl (_, {ni_name}, _, _, _) - -> ( + -> ( let class_tname = match CMethod_signature.ms_get_name ms with - | Typ.Procname.ObjC_Cpp objc_cpp - -> Typ.Procname.objc_cpp_get_class_type_name objc_cpp - | _ - -> assert false + | Typ.Procname.ObjC_Cpp objc_cpp -> + Typ.Procname.objc_cpp_get_class_type_name objc_cpp + | _ -> + assert false in let field_name = CGeneral_utils.mk_class_field_name class_tname ni_name in match Tenv.lookup tenv class_tname with | Some {fields} - -> ( + -> ( let field_opt = List.find ~f:(fun (name, _, _) -> Typ.Fieldname.equal name field_name) fields in match field_opt with - | Some field when CMethod_signature.ms_is_getter ms - -> Some (ProcAttributes.Objc_getter field) - | Some field when CMethod_signature.ms_is_setter ms - -> Some (ProcAttributes.Objc_setter field) - | _ - -> None ) - | None - -> None ) - | _ - -> None ) - | _ - -> None + | Some field when CMethod_signature.ms_is_getter ms -> + Some (ProcAttributes.Objc_getter field) + | Some field when CMethod_signature.ms_is_setter ms -> + Some (ProcAttributes.Objc_setter field) + | _ -> + None ) + | None -> + None ) + | _ -> + None ) + | _ -> + None + (** Creates a procedure description. *) let create_local_procdesc ?(set_objc_accessor_attr= false) trans_unit_ctx cfg tenv ms fbody @@ -546,14 +580,14 @@ let create_local_procdesc ?(set_objc_accessor_attr= false) trans_unit_ctx cfg te let is_cpp_nothrow = CMethod_signature.ms_is_cpp_nothrow ms in let access = match CMethod_signature.ms_get_access ms with - | `None - -> PredSymb.Default - | `Private - -> PredSymb.Private - | `Protected - -> PredSymb.Protected - | `Public - -> PredSymb.Protected + | `None -> + PredSymb.Default + | `Private -> + PredSymb.Private + | `Protected -> + PredSymb.Protected + | `Public -> + PredSymb.Protected in let create_new_procdesc () = let formals = get_formal_parameters tenv ms in @@ -608,65 +642,72 @@ let create_local_procdesc ?(set_objc_accessor_attr= false) trans_unit_ctx cfg te let start_node = Procdesc.create_node procdesc loc_start start_kind [] in let exit_kind = Procdesc.Node.Exit_node proc_name in let exit_node = Procdesc.create_node procdesc loc_exit exit_kind [] in - Procdesc.set_start_node procdesc start_node ; Procdesc.set_exit_node procdesc exit_node ) + Procdesc.set_start_node procdesc start_node ; + Procdesc.set_exit_node procdesc exit_node ) in if should_create_procdesc cfg proc_name defined set_objc_accessor_attr then ( create_new_procdesc () ; true ) else false + (** Create a procdesc for objc methods whose signature cannot be found. *) let create_external_procdesc cfg proc_name is_objc_inst_method type_opt = match Cfg.find_proc_desc_from_name cfg proc_name with - | Some _ - -> () - | None - -> let ret_type, formals = + | Some _ -> + () + | None -> + let ret_type, formals = match type_opt with - | Some (ret_type, arg_types) - -> (ret_type, List.map ~f:(fun typ -> (Mangled.from_string "x", typ)) arg_types) - | None - -> (Typ.mk Typ.Tvoid, []) + | Some (ret_type, arg_types) -> + (ret_type, List.map ~f:(fun typ -> (Mangled.from_string "x", typ)) arg_types) + | None -> + (Typ.mk Typ.Tvoid, []) in let proc_attributes = { (ProcAttributes.default proc_name Config.Clang) with - ProcAttributes.formals= formals; is_objc_instance_method= is_objc_inst_method; ret_type } + ProcAttributes.formals; is_objc_instance_method= is_objc_inst_method; ret_type } in ignore (Cfg.create_proc_desc cfg proc_attributes) + let create_procdesc_with_pointer context pointer class_name_opt name = let open CContext in match method_signature_of_pointer context.translation_unit_context context.tenv pointer with - | Some callee_ms - -> ignore + | Some callee_ms -> + ignore (create_local_procdesc context.translation_unit_context context.cfg context.tenv callee_ms [] [] false) ; CMethod_signature.ms_get_name callee_ms - | None - -> let callee_name = + | None -> + let callee_name = match class_name_opt with - | Some class_name - -> CProcname.NoAstDecl.cpp_method_of_string context.tenv class_name name - | None - -> CProcname.NoAstDecl.c_function_of_string context.translation_unit_context context.tenv + | Some class_name -> + CProcname.NoAstDecl.cpp_method_of_string context.tenv class_name name + | None -> + CProcname.NoAstDecl.c_function_of_string context.translation_unit_context context.tenv name in - create_external_procdesc context.cfg callee_name false None ; callee_name + create_external_procdesc context.cfg callee_name false None ; + callee_name + let get_procname_from_cpp_lambda context dec = match dec with | Clang_ast_t.CXXRecordDecl (_, _, _, _, _, _, _, cxx_rdi) -> ( match cxx_rdi.xrdi_lambda_call_operator with - | Some dr - -> let name_info, decl_ptr, _ = CAst_utils.get_info_from_decl_ref dr in + | Some dr -> + let name_info, decl_ptr, _ = CAst_utils.get_info_from_decl_ref dr in create_procdesc_with_pointer context decl_ptr None name_info.ni_name - | _ - -> assert false ) - | _ - -> assert false + | _ -> + assert false ) + | _ -> + assert false + let get_captures_from_cpp_lambda dec = match dec with - | Clang_ast_t.CXXRecordDecl (_, _, _, _, _, _, _, cxx_rdi) - -> cxx_rdi.xrdi_lambda_captures - | _ - -> assert false + | Clang_ast_t.CXXRecordDecl (_, _, _, _, _, _, _, cxx_rdi) -> + cxx_rdi.xrdi_lambda_captures + | _ -> + assert false + diff --git a/infer/src/clang/cPredicates.ml b/infer/src/clang/cPredicates.ml index aab846829..7f086212d 100644 --- a/infer/src/clang/cPredicates.ml +++ b/infer/src/clang/cPredicates.ml @@ -15,29 +15,31 @@ let parsed_type_map : Ctl_parser_types.abs_ctype String.Map.t ref = ref String.M let rec objc_class_of_pointer_type type_ptr = match CAst_utils.get_type type_ptr with - | Some ObjCInterfaceType (_, decl_ptr) - -> CAst_utils.get_decl decl_ptr - | Some ObjCObjectPointerType (_, inner_qual_type) - -> objc_class_of_pointer_type inner_qual_type.qt_type_ptr + | Some ObjCInterfaceType (_, decl_ptr) -> + CAst_utils.get_decl decl_ptr + | Some ObjCObjectPointerType (_, inner_qual_type) -> + objc_class_of_pointer_type inner_qual_type.qt_type_ptr | Some AttributedType (type_info, _) -> ( match type_info.ti_desugared_type with - | Some type_ptr - -> objc_class_of_pointer_type type_ptr - | None - -> None ) - | _ - -> None + | Some type_ptr -> + objc_class_of_pointer_type type_ptr + | None -> + None ) + | _ -> + None + let receiver_class_method_call an = match an with | Ctl_parser_types.Stmt ObjCMessageExpr (_, _, _, obj_c_message_expr_info) -> ( match obj_c_message_expr_info.omei_receiver_kind with - | `Class qt - -> CAst_utils.get_decl_from_typ_ptr qt.qt_type_ptr - | _ - -> None ) - | _ - -> None + | `Class qt -> + CAst_utils.get_decl_from_typ_ptr qt.qt_type_ptr + | _ -> + None ) + | _ -> + None + let receiver_instance_method_call an = match an with @@ -47,66 +49,72 @@ let receiver_instance_method_call an = match args with | receiver :: _ -> ( match Clang_ast_proj.get_expr_tuple receiver with - | Some (_, _, expr_info) - -> objc_class_of_pointer_type expr_info.ei_qual_type.qt_type_ptr - | None - -> None ) - | [] - -> None ) - | _ - -> None ) - | _ - -> None + | Some (_, _, expr_info) -> + objc_class_of_pointer_type expr_info.ei_qual_type.qt_type_ptr + | None -> + None ) + | [] -> + None ) + | _ -> + None ) + | _ -> + None + let receiver_method_call an = match receiver_class_method_call an with - | Some decl - -> Some decl - | None - -> receiver_instance_method_call an + | Some decl -> + Some decl + | None -> + receiver_instance_method_call an + let declaration_name decl = match Clang_ast_proj.get_named_decl_tuple decl with - | Some (_, ndi) - -> Some ndi.ni_name - | None - -> None + | Some (_, ndi) -> + Some ndi.ni_name + | None -> + None + let get_available_attr_ios_sdk an = let open Clang_ast_t in let rec get_available_attr attrs = match attrs with - | [] - -> None + | [] -> + None | (AvailabilityAttr attr_info) :: rest -> ( match attr_info.ai_parameters with - | "ios" :: version :: _ - -> Some - (String.Search_pattern.replace_all (String.Search_pattern.create "_") ~in_:version - ~with_:".") - | _ - -> get_available_attr rest ) - | _ :: rest - -> get_available_attr rest + | "ios" :: version :: _ -> + Some + (String.Search_pattern.replace_all + (String.Search_pattern.create "_") + ~in_:version ~with_:".") + | _ -> + get_available_attr rest ) + | _ :: rest -> + get_available_attr rest in match an with - | Ctl_parser_types.Decl decl - -> let decl_info = Clang_ast_proj.get_decl_tuple decl in + | Ctl_parser_types.Decl decl -> + let decl_info = Clang_ast_proj.get_decl_tuple decl in get_available_attr decl_info.di_attributes - | _ - -> None + | _ -> + None + let get_ivar_attributes ivar_decl = let open Clang_ast_t in match ivar_decl with | ObjCIvarDecl (ivar_decl_info, _, _, _, _) -> ( match CAst_utils.get_property_of_ivar ivar_decl_info.Clang_ast_t.di_pointer with - | Some ObjCPropertyDecl (_, _, obj_c_property_decl_info) - -> obj_c_property_decl_info.Clang_ast_t.opdi_property_attributes - | _ - -> [] ) - | _ - -> [] + | Some ObjCPropertyDecl (_, _, obj_c_property_decl_info) -> + obj_c_property_decl_info.Clang_ast_t.opdi_property_attributes + | _ -> + [] ) + | _ -> + [] + (* list of cxx references captured by decl *) let captured_variables_cxx_ref an = @@ -118,18 +126,19 @@ let captured_variables_cxx_ref an = | Some ParmVarDecl (_, named_decl_info, qual_type, _) | Some ImplicitParamDecl (_, named_decl_info, qual_type, _) -> ( match CAst_utils.get_desugared_type qual_type.Clang_ast_t.qt_type_ptr with - | Some RValueReferenceType _ | Some LValueReferenceType _ - -> named_decl_info :: reference_captured_vars - | _ - -> reference_captured_vars ) - | _ - -> reference_captured_vars + | Some RValueReferenceType _ | Some LValueReferenceType _ -> + named_decl_info :: reference_captured_vars + | _ -> + reference_captured_vars ) + | _ -> + reference_captured_vars in match an with - | Ctl_parser_types.Decl BlockDecl (_, bdi) - -> List.fold ~f:capture_var_is_cxx_ref ~init:[] bdi.bdi_captured_variables - | _ - -> [] + | Ctl_parser_types.Decl BlockDecl (_, bdi) -> + List.fold ~f:capture_var_is_cxx_ref ~init:[] bdi.bdi_captured_variables + | _ -> + [] + type t = ALVar.formula_id * (* (name, [param1,...,paramK]) *) ALVar.alexp list [@@deriving compare] @@ -138,13 +147,15 @@ let pp_predicate fmt (_name, _arglist) = let arglist = List.map ~f:ALVar.alexp_to_string _arglist in Format.fprintf fmt "%s(%a)" name (Pp.comma_seq Format.pp_print_string) arglist + (* is an objc interface with name expected_name *) let is_objc_interface_named an expected_name = match an with - | Ctl_parser_types.Decl Clang_ast_t.ObjCInterfaceDecl (_, ni, _, _, _) - -> ALVar.compare_str_with_alexp ni.ni_name expected_name - | _ - -> false + | Ctl_parser_types.Decl Clang_ast_t.ObjCInterfaceDecl (_, ni, _, _, _) -> + ALVar.compare_str_with_alexp ni.ni_name expected_name + | _ -> + false + (* checkes whether an object is of a certain class *) let is_object_of_class_named receiver cname = @@ -152,27 +163,30 @@ let is_object_of_class_named receiver cname = match receiver with | PseudoObjectExpr (_, _, ei) | ImplicitCastExpr (_, _, ei, _) | ParenExpr (_, _, ei) -> ( match CAst_utils.qual_type_to_objc_interface ei.ei_qual_type with - | Some interface - -> is_objc_interface_named (Ctl_parser_types.Decl interface) cname - | _ - -> false ) - | _ - -> false + | Some interface -> + is_objc_interface_named (Ctl_parser_types.Decl interface) cname + | _ -> + false ) + | _ -> + false + let get_selector an = match an with - | Ctl_parser_types.Stmt Clang_ast_t.ObjCMessageExpr (_, _, _, omei) - -> Some omei.omei_selector - | _ - -> None + | Ctl_parser_types.Stmt Clang_ast_t.ObjCMessageExpr (_, _, _, omei) -> + Some omei.omei_selector + | _ -> + None + (* an |= call_method(m) where the name must be exactly m *) let call_method an m = match get_selector an with - | Some selector - -> ALVar.compare_str_with_alexp selector m - | _ - -> false + | Some selector -> + ALVar.compare_str_with_alexp selector m + | _ -> + false + let is_receiver_kind_class omei cname = let open Clang_ast_t in @@ -181,132 +195,146 @@ let is_receiver_kind_class omei cname = match CAst_utils.get_desugared_type ptr.Clang_ast_t.qt_type_ptr with | Some ObjCInterfaceType (_, ptr) -> ( match CAst_utils.get_decl ptr with - | Some ObjCInterfaceDecl (_, ndi, _, _, _) - -> ALVar.compare_str_with_alexp ndi.ni_name cname - | _ - -> false ) - | _ - -> false ) - | _ - -> false + | Some ObjCInterfaceDecl (_, ndi, _, _, _) -> + ALVar.compare_str_with_alexp ndi.ni_name cname + | _ -> + false ) + | _ -> + false ) + | _ -> + false + let call_class_method an cname mname = match an with - | Ctl_parser_types.Stmt Clang_ast_t.ObjCMessageExpr (_, _, _, omei) - -> is_receiver_kind_class omei cname && ALVar.compare_str_with_alexp omei.omei_selector mname - | _ - -> false + | Ctl_parser_types.Stmt Clang_ast_t.ObjCMessageExpr (_, _, _, omei) -> + is_receiver_kind_class omei cname && ALVar.compare_str_with_alexp omei.omei_selector mname + | _ -> + false + (* an is a node calling method whose name contains mname of a class whose name contains cname. *) let call_instance_method an cname mname = match an with - | Ctl_parser_types.Stmt Clang_ast_t.ObjCMessageExpr (_, receiver :: _, _, omei) - -> is_object_of_class_named receiver cname + | Ctl_parser_types.Stmt Clang_ast_t.ObjCMessageExpr (_, receiver :: _, _, omei) -> + is_object_of_class_named receiver cname && ALVar.compare_str_with_alexp omei.omei_selector mname - | _ - -> false + | _ -> + false + let is_objc_extension lcxt = CGeneral_utils.is_objc_extension lcxt.CLintersContext.translation_unit_context + let is_syntactically_global_var an = match an with Ctl_parser_types.Decl d -> CAst_utils.is_syntactically_global_var d | _ -> false + let is_const_expr_var an = match an with Ctl_parser_types.Decl d -> CAst_utils.is_const_expr_var d | _ -> false + let decl_ref_name ?kind name st = match st with | Clang_ast_t.DeclRefExpr (_, _, _, drti) -> ( match drti.drti_decl_ref with | Some dr - -> ( + -> ( let ndi, _, _ = CAst_utils.get_info_from_decl_ref dr in let has_right_name = ALVar.compare_str_with_alexp ndi.ni_name name in match kind with - | Some decl_kind - -> has_right_name && PVariant.( = ) dr.Clang_ast_t.dr_kind decl_kind - | None - -> has_right_name ) - | _ - -> false ) - | _ - -> false + | Some decl_kind -> + has_right_name && PVariant.( = ) dr.Clang_ast_t.dr_kind decl_kind + | None -> + has_right_name ) + | _ -> + false ) + | _ -> + false + let declaration_ref_name ?kind an name = match an with Ctl_parser_types.Stmt st -> decl_ref_name ?kind name st | _ -> false + let call_function an name = match an with - | Ctl_parser_types.Stmt st - -> CAst_utils.exists_eventually_st (decl_ref_name ~kind:`Function) name st - | _ - -> false + | Ctl_parser_types.Stmt st -> + CAst_utils.exists_eventually_st (decl_ref_name ~kind:`Function) name st + | _ -> + false + let is_enum_constant an name = match an with - | Ctl_parser_types.Stmt st - -> decl_ref_name ~kind:`EnumConstant name st - | _ - -> false + | Ctl_parser_types.Stmt st -> + decl_ref_name ~kind:`EnumConstant name st + | _ -> + false + let is_enum_constant_of_enum an name = match an with | Ctl_parser_types.Stmt Clang_ast_t.DeclRefExpr (_, _, _, drti) -> ( match drti.drti_decl_ref with | Some dr - -> ( + -> ( let ndi, _, _ = CAst_utils.get_info_from_decl_ref dr in let qual_name = CAst_utils.get_qualified_name ndi in match QualifiedCppName.extract_last qual_name with | Some (_, stripped_qual_name) -> ( match QualifiedCppName.extract_last stripped_qual_name with - | Some (enum_name, _) - -> PVariant.( = ) dr.Clang_ast_t.dr_kind `EnumConstant + | Some (enum_name, _) -> + PVariant.( = ) dr.Clang_ast_t.dr_kind `EnumConstant && ALVar.compare_str_with_alexp enum_name name - | _ - -> false ) - | _ - -> false ) - | _ - -> false ) - | _ - -> false + | _ -> + false ) + | _ -> + false ) + | _ -> + false ) + | _ -> + false + let is_strong_property an = match an with - | Ctl_parser_types.Decl Clang_ast_t.ObjCPropertyDecl (_, _, pdi) - -> ObjcProperty_decl.is_strong_property pdi - | _ - -> false + | Ctl_parser_types.Decl Clang_ast_t.ObjCPropertyDecl (_, _, pdi) -> + ObjcProperty_decl.is_strong_property pdi + | _ -> + false + let is_assign_property an = match an with - | Ctl_parser_types.Decl Clang_ast_t.ObjCPropertyDecl (_, _, pdi) - -> ObjcProperty_decl.is_assign_property pdi - | _ - -> false + | Ctl_parser_types.Decl Clang_ast_t.ObjCPropertyDecl (_, _, pdi) -> + ObjcProperty_decl.is_assign_property pdi + | _ -> + false + let is_property_pointer_type an = let open Clang_ast_t in match an with | Ctl_parser_types.Decl ObjCPropertyDecl (_, _, pdi) -> ( match CAst_utils.get_desugared_type pdi.opdi_qual_type.Clang_ast_t.qt_type_ptr with - | Some MemberPointerType _ | Some ObjCObjectPointerType _ | Some BlockPointerType _ - -> true - | Some TypedefType (_, tti) - -> let typedef_str = + | Some MemberPointerType _ | Some ObjCObjectPointerType _ | Some BlockPointerType _ -> + true + | Some TypedefType (_, tti) -> + let typedef_str = CAst_utils.name_of_typedef_type_info tti |> QualifiedCppName.to_qual_string in String.equal typedef_str CFrontend_config.id_cl - | exception Not_found - -> false - | _ - -> false ) - | _ - -> false + | exception Not_found -> + false + | _ -> + false ) + | _ -> + false + let context_in_synchronized_block context = context.CLintersContext.in_synchronized_block @@ -314,102 +342,113 @@ let context_in_synchronized_block context = context.CLintersContext.in_synchroni let is_ivar_atomic an = match an with | Ctl_parser_types.Stmt Clang_ast_t.ObjCIvarRefExpr (_, _, _, irei) - -> ( + -> ( let dr_ref = irei.Clang_ast_t.ovrei_decl_ref in let ivar_pointer = dr_ref.Clang_ast_t.dr_decl_pointer in match CAst_utils.get_decl ivar_pointer with - | Some d - -> let attributes = get_ivar_attributes d in + | Some d -> + let attributes = get_ivar_attributes d in List.exists ~f:(PVariant.( = ) `Atomic) attributes - | _ - -> false ) - | _ - -> false + | _ -> + false ) + | _ -> + false + let is_method_property_accessor_of_ivar an context = let open Clang_ast_t in match an with | Ctl_parser_types.Stmt ObjCIvarRefExpr (_, _, _, irei) - -> ( + -> ( let dr_ref = irei.Clang_ast_t.ovrei_decl_ref in let ivar_pointer = dr_ref.Clang_ast_t.dr_decl_pointer in match context.CLintersContext.current_method with - | Some ObjCMethodDecl (_, _, mdi) - -> if mdi.omdi_is_property_accessor then + | Some ObjCMethodDecl (_, _, mdi) -> + if mdi.omdi_is_property_accessor then let property_opt = mdi.omdi_property_decl in match CAst_utils.get_decl_opt_with_decl_ref property_opt with | Some ObjCPropertyDecl (_, _, pdi) -> ( match pdi.opdi_ivar_decl with - | Some decl_ref - -> Int.equal decl_ref.dr_decl_pointer ivar_pointer - | None - -> false ) - | _ - -> false + | Some decl_ref -> + Int.equal decl_ref.dr_decl_pointer ivar_pointer + | None -> + false ) + | _ -> + false else false - | _ - -> false ) - | _ - -> false + | _ -> + false ) + | _ -> + false + let get_method_name_from_context context = match context.CLintersContext.current_method with | Some method_decl -> ( match Clang_ast_proj.get_named_decl_tuple method_decl with - | Some (_, mnd) - -> mnd.Clang_ast_t.ni_name - | _ - -> "" ) - | _ - -> "" + | Some (_, mnd) -> + mnd.Clang_ast_t.ni_name + | _ -> + "" ) + | _ -> + "" + let is_objc_constructor context = Typ.Procname.is_objc_constructor (get_method_name_from_context context) + let is_objc_dealloc context = Typ.Procname.is_objc_dealloc (get_method_name_from_context context) let is_in_method context name = let current_method_name = get_method_name_from_context context in ALVar.compare_str_with_alexp current_method_name name + let is_in_objc_method context name = match context.CLintersContext.current_method with - | Some ObjCMethodDecl _ - -> is_in_method context name - | _ - -> false + | Some ObjCMethodDecl _ -> + is_in_method context name + | _ -> + false + let is_in_function context name = match context.CLintersContext.current_method with - | Some FunctionDecl _ - -> is_in_method context name - | _ - -> false + | Some FunctionDecl _ -> + is_in_method context name + | _ -> + false + let is_in_cxx_method context name = match context.CLintersContext.current_method with - | Some CXXMethodDecl _ - -> is_in_method context name - | _ - -> false + | Some CXXMethodDecl _ -> + is_in_method context name + | _ -> + false + let is_in_cxx_constructor context name = match context.CLintersContext.current_method with - | Some CXXConstructorDecl _ - -> is_in_method context name - | _ - -> false + | Some CXXConstructorDecl _ -> + is_in_method context name + | _ -> + false + let is_in_cxx_destructor context name = match context.CLintersContext.current_method with - | Some CXXDestructorDecl _ - -> is_in_method context name - | _ - -> false + | Some CXXDestructorDecl _ -> + is_in_method context name + | _ -> + false + let is_in_block context = match context.CLintersContext.current_method with Some BlockDecl _ -> true | _ -> false + let captures_cxx_references an = List.length (captured_variables_cxx_ref an) > 0 let is_binop_with_kind an alexp_kind = @@ -417,33 +456,36 @@ let is_binop_with_kind an alexp_kind = if not (Clang_ast_proj.is_valid_binop_kind_name str_kind) then L.(die ExternalError) "Binary operator kind '%s' is not valid" str_kind ; match an with - | Ctl_parser_types.Stmt Clang_ast_t.BinaryOperator (_, _, _, boi) - -> ALVar.compare_str_with_alexp (Clang_ast_proj.string_of_binop_kind boi.boi_kind) alexp_kind - | _ - -> false + | Ctl_parser_types.Stmt Clang_ast_t.BinaryOperator (_, _, _, boi) -> + ALVar.compare_str_with_alexp (Clang_ast_proj.string_of_binop_kind boi.boi_kind) alexp_kind + | _ -> + false + let is_unop_with_kind an alexp_kind = let str_kind = ALVar.alexp_to_string alexp_kind in if not (Clang_ast_proj.is_valid_unop_kind_name str_kind) then L.(die ExternalError) "Unary operator kind '%s' is not valid" str_kind ; match an with - | Ctl_parser_types.Stmt Clang_ast_t.UnaryOperator (_, _, _, uoi) - -> ALVar.compare_str_with_alexp (Clang_ast_proj.string_of_unop_kind uoi.uoi_kind) alexp_kind - | _ - -> false + | Ctl_parser_types.Stmt Clang_ast_t.UnaryOperator (_, _, _, uoi) -> + ALVar.compare_str_with_alexp (Clang_ast_proj.string_of_unop_kind uoi.uoi_kind) alexp_kind + | _ -> + false + let has_cast_kind an alexp_kind = match an with - | Ctl_parser_types.Decl _ - -> false - | Ctl_parser_types.Stmt stmt - -> let str_kind = ALVar.alexp_to_string alexp_kind in + | Ctl_parser_types.Decl _ -> + false + | Ctl_parser_types.Stmt stmt -> + let str_kind = ALVar.alexp_to_string alexp_kind in match Clang_ast_proj.get_cast_kind stmt with - | Some cast_kind - -> let cast_kind_str = Clang_ast_proj.string_of_cast_kind cast_kind in + | Some cast_kind -> + let cast_kind_str = Clang_ast_proj.string_of_cast_kind cast_kind in String.equal cast_kind_str str_kind - | None - -> false + | None -> + false + let is_node an nodename = let nodename_str = ALVar.alexp_to_string nodename in @@ -451,68 +493,74 @@ let is_node an nodename = L.(die ExternalError) "Node '%s' is not a valid AST node" nodename_str ; let an_str = match an with - | Ctl_parser_types.Stmt s - -> Clang_ast_proj.get_stmt_kind_string s - | Ctl_parser_types.Decl d - -> Clang_ast_proj.get_decl_kind_string d + | Ctl_parser_types.Stmt s -> + Clang_ast_proj.get_stmt_kind_string s + | Ctl_parser_types.Decl d -> + Clang_ast_proj.get_decl_kind_string d in ALVar.compare_str_with_alexp an_str nodename + let is_ptr_to_objc_class typ class_name = match typ with | Some Clang_ast_t.ObjCObjectPointerType (_, {Clang_ast_t.qt_type_ptr}) -> ( match CAst_utils.get_desugared_type qt_type_ptr with | Some ObjCInterfaceType (_, ptr) -> ( match CAst_utils.get_decl ptr with - | Some ObjCInterfaceDecl (_, ndi, _, _, _) - -> ALVar.compare_str_with_alexp ndi.ni_name class_name - | _ - -> false ) - | _ - -> false ) - | _ - -> false + | Some ObjCInterfaceDecl (_, ndi, _, _, _) -> + ALVar.compare_str_with_alexp ndi.ni_name class_name + | _ -> + false ) + | _ -> + false ) + | _ -> + false + (* node an is of class classname *) let isa an classname = match an with | Ctl_parser_types.Stmt stmt -> ( match Clang_ast_proj.get_expr_tuple stmt with - | Some (_, _, expr_info) - -> let typ = CAst_utils.get_desugared_type expr_info.ei_qual_type.qt_type_ptr in + | Some (_, _, expr_info) -> + let typ = CAst_utils.get_desugared_type expr_info.ei_qual_type.qt_type_ptr in is_ptr_to_objc_class typ classname - | _ - -> false ) - | _ - -> false + | _ -> + false ) + | _ -> + false + (* an is a declaration whose name contains a regexp defined by re *) let declaration_has_name an name = match an with | Ctl_parser_types.Decl d -> ( match Clang_ast_proj.get_named_decl_tuple d with - | Some (_, ndi) - -> ALVar.compare_str_with_alexp ndi.ni_name name - | _ - -> false ) - | _ - -> false + | Some (_, ndi) -> + ALVar.compare_str_with_alexp ndi.ni_name name + | _ -> + false ) + | _ -> + false + (* an is an expression @selector with whose name in the language of re *) let is_at_selector_with_name an re = match an with - | Ctl_parser_types.Stmt ObjCSelectorExpr (_, _, _, s) - -> ALVar.compare_str_with_alexp s re - | _ - -> false + | Ctl_parser_types.Stmt ObjCSelectorExpr (_, _, _, s) -> + ALVar.compare_str_with_alexp s re + | _ -> + false + let is_class an re = match an with | Ctl_parser_types.Decl Clang_ast_t.ObjCInterfaceDecl _ - | Ctl_parser_types.Decl Clang_ast_t.ObjCImplementationDecl _ - -> declaration_has_name an re - | _ - -> false + | Ctl_parser_types.Decl Clang_ast_t.ObjCImplementationDecl _ -> + declaration_has_name an re + | _ -> + false + let iphoneos_target_sdk_version_by_path (cxt: CLintersContext.context) = let source_file = cxt.translation_unit_context.source_file in @@ -522,17 +570,19 @@ let iphoneos_target_sdk_version_by_path (cxt: CLintersContext.context) = ALVar.str_match_forward (SourceFile.to_rel_path source_file) version_path_regex.path ) in match regex_version_opt with - | Some version_by_regex - -> Some version_by_regex.version - | None (* no version by path specified, use default version *) - -> Config.iphoneos_target_sdk_version + | Some version_by_regex -> + Some version_by_regex.version + | None (* no version by path specified, use default version *) -> + Config.iphoneos_target_sdk_version + let iphoneos_target_sdk_version_greater_or_equal (cxt: CLintersContext.context) version = match iphoneos_target_sdk_version_by_path cxt with - | Some target_version - -> Utils.compare_versions target_version version >= 0 - | None - -> false + | Some target_version -> + Utils.compare_versions target_version version >= 0 + | None -> + false + let decl_unavailable_in_supported_ios_sdk (cxt: CLintersContext.context) an = let config_iphoneos_target_sdk_version = iphoneos_target_sdk_version_by_path cxt in @@ -540,27 +590,29 @@ let decl_unavailable_in_supported_ios_sdk (cxt: CLintersContext.context) an = match (config_iphoneos_target_sdk_version, (cxt.if_context : CLintersContext.if_context option)) with - | Some iphoneos_target_sdk_version, Some if_context - -> iphoneos_target_sdk_version :: if_context.ios_version_guard - | Some iphoneos_target_sdk_version, None - -> [iphoneos_target_sdk_version] - | _ - -> [] + | Some iphoneos_target_sdk_version, Some if_context -> + iphoneos_target_sdk_version :: if_context.ios_version_guard + | Some iphoneos_target_sdk_version, None -> + [iphoneos_target_sdk_version] + | _ -> + [] in let max_allowed_version_opt = List.max_elt allowed_os_versions ~cmp:Utils.compare_versions in let available_attr_ios_sdk = get_available_attr_ios_sdk an in match (available_attr_ios_sdk, max_allowed_version_opt) with - | Some available_attr_ios_sdk, Some max_allowed_version - -> Utils.compare_versions available_attr_ios_sdk max_allowed_version > 0 - | _ - -> false + | Some available_attr_ios_sdk, Some max_allowed_version -> + Utils.compare_versions available_attr_ios_sdk max_allowed_version > 0 + | _ -> + false + let class_unavailable_in_supported_ios_sdk (cxt: CLintersContext.context) an = match receiver_method_call an with - | Some decl - -> decl_unavailable_in_supported_ios_sdk cxt (Ctl_parser_types.Decl decl) - | None - -> false + | Some decl -> + decl_unavailable_in_supported_ios_sdk cxt (Ctl_parser_types.Decl decl) + | None -> + false + (* Check whether a type_ptr and a string denote the same type *) let type_ptr_equal_type type_ptr type_str = @@ -568,70 +620,77 @@ let type_ptr_equal_type type_ptr type_str = L.(debug Linters Medium) "Starting parsing type string '%s'@\n" str ; let lexbuf = Lexing.from_string str in try Types_parser.abs_ctype token lexbuf with - | CTLExceptions.ALParserInvariantViolationException s - -> raise + | CTLExceptions.ALParserInvariantViolationException s -> + raise (CTLExceptions.( ALFileException (create_exc_info ("Syntax Error when defining type " ^ s) lexbuf))) - | SyntaxError _ | Types_parser.Error - -> raise CTLExceptions.(ALFileException (create_exc_info "SYNTAX ERROR" lexbuf)) + | SyntaxError _ | Types_parser.Error -> + raise CTLExceptions.(ALFileException (create_exc_info "SYNTAX ERROR" lexbuf)) in let abs_ctype = match String.Map.find !parsed_type_map type_str with - | Some abs_ctype' - -> abs_ctype' - | None - -> let abs_ctype' = parse_type_string type_str in + | Some abs_ctype' -> + abs_ctype' + | None -> + let abs_ctype' = parse_type_string type_str in parsed_type_map := String.Map.add !parsed_type_map ~key:type_str ~data:abs_ctype' ; abs_ctype' in match CAst_utils.get_type type_ptr with - | Some c_type' - -> Ctl_parser_types.c_type_equal c_type' abs_ctype - | _ - -> L.(debug Linters Medium) "Couldn't find type....@\n" ; false + | Some c_type' -> + Ctl_parser_types.c_type_equal c_type' abs_ctype + | _ -> + L.(debug Linters Medium) "Couldn't find type....@\n" ; + false + let get_ast_node_type_ptr an = match an with | Ctl_parser_types.Stmt stmt -> ( match Clang_ast_proj.get_expr_tuple stmt with - | Some (_, _, expr_info) - -> Some expr_info.ei_qual_type.qt_type_ptr - | _ - -> None ) - | Ctl_parser_types.Decl decl - -> CAst_utils.type_of_decl decl + | Some (_, _, expr_info) -> + Some expr_info.ei_qual_type.qt_type_ptr + | _ -> + None ) + | Ctl_parser_types.Decl decl -> + CAst_utils.type_of_decl decl + let has_type an _typ = match (get_ast_node_type_ptr an, _typ) with - | Some pt, ALVar.Const typ - -> type_ptr_equal_type pt typ - | _ - -> false + | Some pt, ALVar.Const typ -> + type_ptr_equal_type pt typ + | _ -> + false + let has_type_const_ptr_to_objc_class node = let open Clang_ast_t in match get_ast_node_type_ptr node with | Some type_ptr -> ( match CAst_utils.get_desugared_type type_ptr with - | Some ObjCObjectPointerType (_, qt) - -> qt.qt_is_const - | _ - -> false ) - | None - -> false + | Some ObjCObjectPointerType (_, qt) -> + qt.qt_is_const + | _ -> + false ) + | None -> + false + let is_decl node = match node with Ctl_parser_types.Decl _ -> true | Ctl_parser_types.Stmt _ -> false + let method_return_type an _typ = L.(debug Linters Verbose) "@\n Executing method_return_type..." ; match (an, _typ) with - | Ctl_parser_types.Decl Clang_ast_t.ObjCMethodDecl (_, _, mdi), ALVar.Const typ - -> L.(debug Linters Verbose) "@\n with parameter `%s`...." typ ; + | Ctl_parser_types.Decl Clang_ast_t.ObjCMethodDecl (_, _, mdi), ALVar.Const typ -> + L.(debug Linters Verbose) "@\n with parameter `%s`...." typ ; let qual_type = mdi.Clang_ast_t.omdi_result_type in type_ptr_equal_type qual_type.Clang_ast_t.qt_type_ptr typ - | _ - -> false + | _ -> + false + let rec check_protocol_hiearachy decls_ptr _prot_name = let open Clang_ast_t in @@ -639,15 +698,15 @@ let rec check_protocol_hiearachy decls_ptr _prot_name = match di_opt with Some di -> ALVar.compare_str_with_alexp di.ni_name _prot_name | _ -> false in match decls_ptr with - | [] - -> false - | pt :: decls' - -> let di, protocols = + | [] -> + false + | pt :: decls' -> + let di, protocols = match CAst_utils.get_decl pt with - | Some ObjCProtocolDecl (_, di, _, _, opcdi) - -> (Some di, opcdi.opcdi_protocols) - | _ - -> (None, []) + | Some ObjCProtocolDecl (_, di, _, _, opcdi) -> + (Some di, opcdi.opcdi_protocols) + | _ -> + (None, []) in if is_this_protocol di || List.exists ~f:(fun dr -> is_this_protocol dr.dr_name) protocols then true @@ -655,55 +714,59 @@ let rec check_protocol_hiearachy decls_ptr _prot_name = let super_prot = List.map ~f:(fun dr -> dr.dr_decl_pointer) protocols in check_protocol_hiearachy (super_prot @ decls') _prot_name + let has_type_subprotocol_of an _prot_name = let open Clang_ast_t in let rec check_subprotocol t = match t with - | Some ObjCObjectPointerType (_, qt) - -> check_subprotocol (CAst_utils.get_type qt.qt_type_ptr) - | Some ObjCObjectType (_, ooti) - -> if List.length ooti.ooti_protocol_decls_ptr > 0 then + | Some ObjCObjectPointerType (_, qt) -> + check_subprotocol (CAst_utils.get_type qt.qt_type_ptr) + | Some ObjCObjectType (_, ooti) -> + if List.length ooti.ooti_protocol_decls_ptr > 0 then check_protocol_hiearachy ooti.ooti_protocol_decls_ptr _prot_name else List.exists ~f:(fun qt -> check_subprotocol (CAst_utils.get_type qt.qt_type_ptr)) ooti.ooti_type_args - | Some ObjCInterfaceType (_, pt) - -> check_protocol_hiearachy [pt] _prot_name - | _ - -> false + | Some ObjCInterfaceType (_, pt) -> + check_protocol_hiearachy [pt] _prot_name + | _ -> + false in match get_ast_node_type_ptr an with - | Some tp - -> check_subprotocol (CAst_utils.get_type tp) - | _ - -> false + | Some tp -> + check_subprotocol (CAst_utils.get_type tp) + | _ -> + false + let within_responds_to_selector_block (cxt: CLintersContext.context) an = let open Clang_ast_t in match an with | Ctl_parser_types.Decl ObjCMethodDecl (_, named_decl_info, _) -> ( match cxt.if_context with - | Some if_context - -> let in_selector_block = if_context.within_responds_to_selector_block in + | Some if_context -> + let in_selector_block = if_context.within_responds_to_selector_block in List.mem ~equal:String.equal in_selector_block named_decl_info.ni_name - | None - -> false ) - | _ - -> false + | None -> + false ) + | _ -> + false + let within_available_class_block (cxt: CLintersContext.context) an = match (receiver_method_call an, cxt.if_context) with | Some receiver, Some if_context - -> ( + -> ( let in_available_class_block = if_context.within_available_class_block in match declaration_name receiver with - | Some receiver_name - -> List.mem ~equal:String.equal in_available_class_block receiver_name - | None - -> false ) - | _ - -> false + | Some receiver_name -> + List.mem ~equal:String.equal in_available_class_block receiver_name + | None -> + false ) + | _ -> + false + let using_namespace an namespace = let open Clang_ast_t in @@ -712,62 +775,67 @@ let using_namespace an namespace = match uddi.uddi_nominated_namespace with | Some dr -> ( match (dr.dr_kind, dr.dr_name) with - | `Namespace, Some ni - -> ALVar.compare_str_with_alexp ni.ni_name namespace - | _ - -> false ) - | None - -> false ) - | _ - -> false + | `Namespace, Some ni -> + ALVar.compare_str_with_alexp ni.ni_name namespace + | _ -> + false ) + | None -> + false ) + | _ -> + false + let rec get_decl_attributes_for_callexpr an = let open Clang_ast_t in let open Ctl_parser_types in match an with - | Stmt CallExpr (_, func :: _, _) - -> get_decl_attributes_for_callexpr (Stmt func) - | Stmt ImplicitCastExpr (_, [stmt], _, _) - -> get_decl_attributes_for_callexpr (Stmt stmt) + | Stmt CallExpr (_, func :: _, _) -> + get_decl_attributes_for_callexpr (Stmt func) + | Stmt ImplicitCastExpr (_, [stmt], _, _) -> + get_decl_attributes_for_callexpr (Stmt stmt) | Stmt DeclRefExpr (_, _, _, drti) -> ( match CAst_utils.get_decl_opt_with_decl_ref drti.drti_decl_ref with - | Some decl - -> let decl_info = Clang_ast_proj.get_decl_tuple decl in + | Some decl -> + let decl_info = Clang_ast_proj.get_decl_tuple decl in decl_info.di_attributes - | None - -> [] ) - | _ - -> [] + | None -> + [] ) + | _ -> + [] + let has_visibility_attribute an visibility = let open Clang_ast_t in let rec has_visibility_attr attrs param = match attrs with - | [] - -> false - | (VisibilityAttr attr_info) :: rest - -> if List.exists ~f:(fun s -> String.equal param (String.strip s)) attr_info.ai_parameters + | [] -> + false + | (VisibilityAttr attr_info) :: rest -> + if List.exists ~f:(fun s -> String.equal param (String.strip s)) attr_info.ai_parameters then true else has_visibility_attr rest param - | _ :: rest - -> has_visibility_attr rest param + | _ :: rest -> + has_visibility_attr rest param in let attributes = get_decl_attributes_for_callexpr an in match visibility with ALVar.Const vis -> has_visibility_attr attributes vis | _ -> false + let has_used_attribute an = let open Clang_ast_t in let attributes = get_decl_attributes_for_callexpr an in List.exists ~f:(fun attr -> match attr with UsedAttr _ -> true | _ -> false) attributes + let has_value an al_exp = let open Clang_ast_t in let open Ctl_parser_types in match an with - | Stmt IntegerLiteral (_, _, _, integer_literal_info) - -> let value = integer_literal_info.Clang_ast_t.ili_value in + | Stmt IntegerLiteral (_, _, _, integer_literal_info) -> + let value = integer_literal_info.Clang_ast_t.ili_value in ALVar.compare_str_with_alexp value al_exp - | Stmt StringLiteral (_, _, _, l) - -> ALVar.compare_str_with_alexp (String.concat ~sep:"" l) al_exp - | _ - -> false + | Stmt StringLiteral (_, _, _, l) -> + ALVar.compare_str_with_alexp (String.concat ~sep:"" l) al_exp + | _ -> + false + diff --git a/infer/src/clang/cTL.ml b/infer/src/clang/cTL.ml index cd126e802..b0315eaf1 100644 --- a/infer/src/clang/cTL.ml +++ b/infer/src/clang/cTL.ml @@ -33,10 +33,11 @@ type transitions = let is_transition_to_successor trans = match trans with - | Body | InitExpr | FieldName _ | Fields | ParameterName _ | ParameterPos _ | Parameters | Cond - -> true - | Super | PointerToDecl | Protocol - -> false + | Body | InitExpr | FieldName _ | Fields | ParameterName _ | ParameterPos _ | Parameters | Cond -> + true + | Super | PointerToDecl | Protocol -> + false + (* In formulas below prefix "E" means "exists a path" @@ -77,8 +78,8 @@ let has_transition phi = | Or (_, _) | Implies (_, _) | InNode (_, _) - | EH (_, _) - -> false + | EH (_, _) -> + false | AX (trans_opt, _) | AF (trans_opt, _) | AG (trans_opt, _) @@ -87,8 +88,9 @@ let has_transition phi = | EF (trans_opt, _) | EG (trans_opt, _) | EU (trans_opt, _, _) - | ET (_, trans_opt, _) - -> Option.is_some trans_opt + | ET (_, trans_opt, _) -> + Option.is_some trans_opt + (* "set" clauses are used for defining mandatory variables that will be used by when reporting issues: eg for defining the condition. @@ -132,80 +134,85 @@ module Debug = struct let pp_transition fmt trans_opt = let pp_aux fmt trans = match trans with - | Body - -> Format.pp_print_string fmt "Body" - | FieldName name - -> Format.pp_print_string fmt ("FieldName " ^ ALVar.alexp_to_string name) - | Fields - -> Format.pp_print_string fmt "Fields" - | InitExpr - -> Format.pp_print_string fmt "InitExpr" - | Super - -> Format.pp_print_string fmt "Super" - | ParameterName name - -> Format.pp_print_string fmt ("ParameterName " ^ ALVar.alexp_to_string name) - | ParameterPos pos - -> Format.pp_print_string fmt ("ParameterPos " ^ ALVar.alexp_to_string pos) - | Parameters - -> Format.pp_print_string fmt "Parameters" - | Cond - -> Format.pp_print_string fmt "Cond" - | Protocol - -> Format.pp_print_string fmt "Protocol" - | PointerToDecl - -> Format.pp_print_string fmt "PointerToDecl" + | Body -> + Format.pp_print_string fmt "Body" + | FieldName name -> + Format.pp_print_string fmt ("FieldName " ^ ALVar.alexp_to_string name) + | Fields -> + Format.pp_print_string fmt "Fields" + | InitExpr -> + Format.pp_print_string fmt "InitExpr" + | Super -> + Format.pp_print_string fmt "Super" + | ParameterName name -> + Format.pp_print_string fmt ("ParameterName " ^ ALVar.alexp_to_string name) + | ParameterPos pos -> + Format.pp_print_string fmt ("ParameterPos " ^ ALVar.alexp_to_string pos) + | Parameters -> + Format.pp_print_string fmt "Parameters" + | Cond -> + Format.pp_print_string fmt "Cond" + | Protocol -> + Format.pp_print_string fmt "Protocol" + | PointerToDecl -> + Format.pp_print_string fmt "PointerToDecl" in match trans_opt with Some trans -> pp_aux fmt trans | None -> Format.pp_print_string fmt "_" + (* a flag to print more or less in the dotty graph *) let full_print = true let rec pp_formula fmt phi = let nodes_to_string nl = List.map ~f:ALVar.alexp_to_string nl in match phi with - | True - -> Format.fprintf fmt "True" - | False - -> Format.fprintf fmt "False" - | Atomic p - -> CPredicates.pp_predicate fmt p - | Not phi - -> if full_print then Format.fprintf fmt "NOT(%a)" pp_formula phi + | True -> + Format.fprintf fmt "True" + | False -> + Format.fprintf fmt "False" + | Atomic p -> + CPredicates.pp_predicate fmt p + | Not phi -> + if full_print then Format.fprintf fmt "NOT(%a)" pp_formula phi else Format.fprintf fmt "NOT(...)" - | And (phi1, phi2) - -> if full_print then Format.fprintf fmt "(%a AND %a)" pp_formula phi1 pp_formula phi2 + | And (phi1, phi2) -> + if full_print then Format.fprintf fmt "(%a AND %a)" pp_formula phi1 pp_formula phi2 else Format.fprintf fmt "(... AND ...)" - | Or (phi1, phi2) - -> if full_print then Format.fprintf fmt "(%a OR %a)" pp_formula phi1 pp_formula phi2 + | Or (phi1, phi2) -> + if full_print then Format.fprintf fmt "(%a OR %a)" pp_formula phi1 pp_formula phi2 else Format.fprintf fmt "(... OR ...)" - | Implies (phi1, phi2) - -> Format.fprintf fmt "(%a ==> %a)" pp_formula phi1 pp_formula phi2 - | InNode (nl, phi) - -> Format.fprintf fmt "IN-NODE %a: (%a)" (Pp.comma_seq Format.pp_print_string) + | Implies (phi1, phi2) -> + Format.fprintf fmt "(%a ==> %a)" pp_formula phi1 pp_formula phi2 + | InNode (nl, phi) -> + Format.fprintf fmt "IN-NODE %a: (%a)" + (Pp.comma_seq Format.pp_print_string) (nodes_to_string nl) pp_formula phi - | AX (trs, phi) - -> Format.fprintf fmt "AX[->%a](%a)" pp_transition trs pp_formula phi - | EX (trs, phi) - -> Format.fprintf fmt "EX[->%a](%a)" pp_transition trs pp_formula phi - | AF (trs, phi) - -> Format.fprintf fmt "AF[->%a](%a)" pp_transition trs pp_formula phi - | EF (trs, phi) - -> Format.fprintf fmt "EF[->%a](%a)" pp_transition trs pp_formula phi - | AG (trs, phi) - -> Format.fprintf fmt "AG[->%a](%a)" pp_transition trs pp_formula phi - | EG (trs, phi) - -> Format.fprintf fmt "EG[->%a](%a)" pp_transition trs pp_formula phi - | AU (trs, phi1, phi2) - -> Format.fprintf fmt "A[->%a][%a UNTIL %a]" pp_transition trs pp_formula phi1 pp_formula phi2 - | EU (trs, phi1, phi2) - -> Format.fprintf fmt "E[->%a][%a UNTIL %a]" pp_transition trs pp_formula phi1 pp_formula phi2 - | EH (arglist, phi) - -> Format.fprintf fmt "EH[%a](%a)" (Pp.comma_seq Format.pp_print_string) + | AX (trs, phi) -> + Format.fprintf fmt "AX[->%a](%a)" pp_transition trs pp_formula phi + | EX (trs, phi) -> + Format.fprintf fmt "EX[->%a](%a)" pp_transition trs pp_formula phi + | AF (trs, phi) -> + Format.fprintf fmt "AF[->%a](%a)" pp_transition trs pp_formula phi + | EF (trs, phi) -> + Format.fprintf fmt "EF[->%a](%a)" pp_transition trs pp_formula phi + | AG (trs, phi) -> + Format.fprintf fmt "AG[->%a](%a)" pp_transition trs pp_formula phi + | EG (trs, phi) -> + Format.fprintf fmt "EG[->%a](%a)" pp_transition trs pp_formula phi + | AU (trs, phi1, phi2) -> + Format.fprintf fmt "A[->%a][%a UNTIL %a]" pp_transition trs pp_formula phi1 pp_formula phi2 + | EU (trs, phi1, phi2) -> + Format.fprintf fmt "E[->%a][%a UNTIL %a]" pp_transition trs pp_formula phi1 pp_formula phi2 + | EH (arglist, phi) -> + Format.fprintf fmt "EH[%a](%a)" + (Pp.comma_seq Format.pp_print_string) (nodes_to_string arglist) pp_formula phi - | ET (arglist, trans, phi) - -> Format.fprintf fmt "ET[%a][%a](%a)" (Pp.comma_seq Format.pp_print_string) + | ET (arglist, trans, phi) -> + Format.fprintf fmt "ET[%a][%a](%a)" + (Pp.comma_seq Format.pp_print_string) (nodes_to_string arglist) pp_transition trans pp_formula phi + let pp_ast ~ast_node_to_highlight ?(prettifier= Fn.id) fmt root = let pp_node_info fmt an = let name = Ctl_parser_types.ast_node_name an in @@ -215,28 +222,28 @@ module Debug = struct in let rec pp_children pp_node wrapper fmt level nodes = match nodes with - | [] - -> () - | node :: nodes - -> pp_node fmt (wrapper node) level "|-" ; + | [] -> + () + | node :: nodes -> + pp_node fmt (wrapper node) level "|-" ; pp_children pp_node wrapper fmt level nodes in let rec pp_ast_aux fmt root level prefix = let get_node_name (an: ast_node) = match an with - | Stmt stmt - -> Clang_ast_proj.get_stmt_kind_string stmt - | Decl decl - -> Clang_ast_proj.get_decl_kind_string decl + | Stmt stmt -> + Clang_ast_proj.get_stmt_kind_string stmt + | Decl decl -> + Clang_ast_proj.get_decl_kind_string decl in let should_highlight = match (root, ast_node_to_highlight) with - | Stmt r, Stmt n - -> phys_equal r n - | Decl r, Decl n - -> phys_equal r n - | _ - -> false + | Stmt r, Stmt n -> + phys_equal r n + | Decl r, Decl n -> + phys_equal r n + | _ -> + false in let node_name = let node_name = get_node_name root in @@ -246,19 +253,19 @@ module Debug = struct let next_level = level + 1 in Format.fprintf fmt "%s%s%s %a@\n" spaces prefix node_name pp_node_info root ; match root with - | Stmt DeclStmt (_, stmts, ([(VarDecl _)] as var_decl)) - -> (* handling special case of DeclStmt with VarDecl: emit the VarDecl node + | Stmt DeclStmt (_, stmts, ([(VarDecl _)] as var_decl)) -> + (* handling special case of DeclStmt with VarDecl: emit the VarDecl node then emit the statements in DeclStmt as children of VarDecl. This is because despite being equal, the statements inside VarDecl and those inside DeclStmt belong to different instances, hence they fail the phys_equal check that should colour them *) pp_children pp_ast_aux (fun n -> Decl n) fmt next_level var_decl ; pp_stmts fmt (next_level + 1) stmts - | Stmt stmt - -> let _, stmts = Clang_ast_proj.get_stmt_tuple stmt in + | Stmt stmt -> + let _, stmts = Clang_ast_proj.get_stmt_tuple stmt in pp_stmts fmt next_level stmts - | Decl decl - -> let decls = + | Decl decl -> + let decls = Clang_ast_proj.get_decl_context_tuple decl |> Option.map ~f:(fun (decls, _) -> decls) |> Option.value ~default:[] in @@ -267,6 +274,7 @@ module Debug = struct and pp_decls fmt level decls = pp_children pp_ast_aux (fun n -> Decl n) fmt level decls in pp_ast_aux fmt root 0 "" + module EvaluationTracker = struct exception Empty_stack of string @@ -299,6 +307,7 @@ module Debug = struct let create_content ast_node phi lcxt = {ast_node; phi; eval_result= Eval_undefined; lcxt; witness= None} + let create source_file = let breakpoint_token = "INFER_BREAKPOINT" in let breakpoint_line = @@ -308,6 +317,7 @@ module Debug = struct in {next_id= 0; eval_stack= Stack.create (); forest= []; breakpoint_line; debugger_active= false} + let explain t ~eval_node ~ast_node_to_display = let line_number an = let line_of_source_range (sr: Clang_ast_t.source_range) = @@ -315,38 +325,38 @@ module Debug = struct loc_info.sl_line in match an with - | Stmt stmt - -> let stmt_info, _ = Clang_ast_proj.get_stmt_tuple stmt in + | Stmt stmt -> + let stmt_info, _ = Clang_ast_proj.get_stmt_tuple stmt in line_of_source_range stmt_info.si_source_range - | Decl decl - -> let decl_info = Clang_ast_proj.get_decl_tuple decl in + | Decl decl -> + let decl_info = Clang_ast_proj.get_decl_tuple decl in line_of_source_range decl_info.di_source_range in let stop_and_explain_step () = let highlight_style = match eval_node.content.eval_result with - | Eval_undefined - -> ANSITerminal.([Bold]) - | Eval_true - -> ANSITerminal.([Bold; green]) - | Eval_false - -> ANSITerminal.([Bold; red]) + | Eval_undefined -> + ANSITerminal.([Bold]) + | Eval_true -> + ANSITerminal.([Bold; green]) + | Eval_false -> + ANSITerminal.([Bold; red]) in let ast_node_to_highlight = eval_node.content.ast_node in let ast_root, is_last_occurrence = match ast_node_to_display with - | Carry_forward n - -> (n, false) - | Last_occurrence n - -> (n, true) + | Carry_forward n -> + (n, false) + | Last_occurrence n -> + (n, true) in let witness_str = match eval_node.content.witness with - | Some witness - -> "\n- witness: " ^ Ctl_parser_types.ast_node_kind witness ^ " " + | Some witness -> + "\n- witness: " ^ Ctl_parser_types.ast_node_kind witness ^ " " ^ Ctl_parser_types.ast_node_name witness - | None - -> "" + | None -> + "" in let ast_str = Format.asprintf "%a %s" @@ -367,25 +377,28 @@ module Debug = struct let quit_token = "q" in L.progress "Press Enter to continue or type %s to quit... @?" quit_token ; match In_channel.input_line_exn In_channel.stdin |> String.lowercase with - | s when String.equal s quit_token - -> L.exit 0 - | _ - -> (* Remove the line at the bottom of terminal with the debug instructions *) + | s when String.equal s quit_token -> + L.exit 0 + | _ -> + (* Remove the line at the bottom of terminal with the debug instructions *) let open ANSITerminal in (* move one line up, as current line is the one generated by pressing enter *) - move_cursor 0 (-1) ; move_bol () ; (* move to the beginning of the line *) - erase Below + move_cursor 0 (-1) ; + move_bol () ; + (* move to the beginning of the line *) + erase Below (* erase what follows the cursor's position *) in match (t.debugger_active, t.breakpoint_line, line_number eval_node.content.ast_node) with - | false, Some break_point_ln, Some ln when ln >= break_point_ln - -> L.progress "Attaching debugger at line %d" ln ; + | false, Some break_point_ln, Some ln when ln >= break_point_ln -> + L.progress "Attaching debugger at line %d" ln ; stop_and_explain_step () ; {t with debugger_active= true} - | true, _, _ - -> stop_and_explain_step () ; t - | _ - -> t + | true, _, _ -> + stop_and_explain_step () ; t + | _ -> + t + let eval_begin t content = let node = {id= t.next_id; content} in @@ -393,12 +406,12 @@ module Debug = struct let subtree' = create_subtree node in let ast_node_from_previous_call = match Stack.top t.eval_stack with - | Some (_, Last_occurrence _) - -> content.ast_node - | Some (_, Carry_forward an) - -> an - | None - -> content.ast_node + | Some (_, Last_occurrence _) -> + content.ast_node + | Some (_, Carry_forward an) -> + an + | None -> + content.ast_node in let ast_node_to_display = if has_transition content.phi then Last_occurrence ast_node_from_previous_call @@ -408,32 +421,35 @@ module Debug = struct let t' = explain t ~eval_node:node ~ast_node_to_display in {t' with next_id= t.next_id + 1} + let eval_end t result = let result_bool = Option.is_some result in let eval_result_of_bool = function true -> Eval_true | false -> Eval_false in if Stack.is_empty t.eval_stack then raise (Empty_stack "Unbalanced number of eval_begin/eval_end invocations") ; let evaluated_tree, eval_node, ast_node_to_display = - match Stack.pop_exn t.eval_stack - with Tree (({id= _; content} as eval_node), children), ast_node_to_display -> - let content' = - {content with eval_result= eval_result_of_bool result_bool; witness= result} - in - let eval_node' = {eval_node with content= content'} in - (Tree (eval_node', children), eval_node', ast_node_to_display) + match Stack.pop_exn t.eval_stack with + | Tree (({id= _; content} as eval_node), children), ast_node_to_display -> + let content' = + {content with eval_result= eval_result_of_bool result_bool; witness= result} + in + let eval_node' = {eval_node with content= content'} in + (Tree (eval_node', children), eval_node', ast_node_to_display) in let t' = explain t ~eval_node ~ast_node_to_display in let forest' = if Stack.is_empty t'.eval_stack then evaluated_tree :: t'.forest else let parent = - match Stack.pop_exn t'.eval_stack - with Tree (node, children), ntd -> (Tree (node, evaluated_tree :: children), ntd) + match Stack.pop_exn t'.eval_stack with + | Tree (node, children), ntd -> + (Tree (node, evaluated_tree :: children), ntd) in Stack.push t'.eval_stack parent ; t'.forest in {t' with forest= forest'} + module DottyPrinter = struct let dotty_of_ctl_evaluation t = let buffer_content buf = @@ -441,14 +457,8 @@ module Debug = struct Buffer.reset buf ; result in let dotty_of_tree cluster_id tree = - let get_root tree = - match tree - with Tree (root, _) -> root - in - let get_children tree = - match tree - with Tree (_, children) -> List.rev children - in + let get_root tree = match tree with Tree (root, _) -> root in + let get_children tree = match tree with Tree (_, children) -> List.rev children in (* shallow: emit dotty about root node and edges to its children *) let shallow_dotty_of_tree tree = let root_node = get_root tree in @@ -460,41 +470,41 @@ module Debug = struct in let color = match root_node.content.eval_result with - | Eval_true - -> "green" - | Eval_false - -> "red" - | _ - -> L.(die InternalError) "Tree is not fully evaluated" + | Eval_true -> + "green" + | Eval_false -> + "red" + | _ -> + L.(die InternalError) "Tree is not fully evaluated" in let label = let string_of_lcxt c = match c.CLintersContext.et_evaluation_node with - | Some s - -> "et_evaluation_node = " ^ s - | _ - -> "et_evaluation_node = NONE" + | Some s -> + "et_evaluation_node = " ^ s + | _ -> + "et_evaluation_node = NONE" in let string_of_ast_node an = match an with - | Stmt stmt - -> Clang_ast_proj.get_stmt_kind_string stmt - | Decl decl - -> Clang_ast_proj.get_decl_kind_string decl + | Stmt stmt -> + Clang_ast_proj.get_stmt_kind_string stmt + | Decl decl -> + Clang_ast_proj.get_decl_kind_string decl in let smart_string_of_formula phi = let num_children = List.length children in match phi with - | And _ when Int.equal num_children 2 - -> "(...) AND (...)" - | Or _ when Int.equal num_children 2 - -> "(...) OR (...)" - | Implies _ when Int.equal num_children 2 - -> "(...) ==> (...)" - | Not _ - -> "NOT(...)" - | _ - -> Format.asprintf "%a" pp_formula phi + | And _ when Int.equal num_children 2 -> + "(...) AND (...)" + | Or _ when Int.equal num_children 2 -> + "(...) OR (...)" + | Implies _ when Int.equal num_children 2 -> + "(...) ==> (...)" + | Not _ -> + "NOT(...)" + | _ -> + Format.asprintf "%a" pp_formula phi in Format.sprintf "(%d)\\n%s\\n%s\\n%s" root_node.id (Escape.escape_dotty (string_of_ast_node root_node.content.ast_node)) @@ -524,6 +534,7 @@ module Debug = struct ~f:(fun cluster_id tree -> Buffer.add_string buf (dotty_of_tree cluster_id tree ^ "\n")) (List.rev t.forest) ; Printf.sprintf "digraph CTL_Evaluation {\n%s\n}\n" (buffer_content buf) + end end end @@ -534,17 +545,17 @@ let print_checker c = List.iter ~f:(fun d -> match d with - | CSet (keyword, phi) - -> let cn_str = ALVar.keyword_to_string keyword in + | CSet (keyword, phi) -> + let cn_str = ALVar.keyword_to_string keyword in L.(debug Linters Medium) " %s= @\n %a@\n@\n" cn_str Debug.pp_formula phi - | CLet (exp, _, phi) - -> let cn_str = ALVar.formula_id_to_string exp in + | CLet (exp, _, phi) -> + let cn_str = ALVar.formula_id_to_string exp in L.(debug Linters Medium) " %s= @\n %a@\n@\n" cn_str Debug.pp_formula phi - | CDesc (keyword, s) - -> let cn_str = ALVar.keyword_to_string keyword in + | CDesc (keyword, s) -> + let cn_str = ALVar.keyword_to_string keyword in L.(debug Linters Medium) " %s= @\n %s@\n@\n" cn_str s - | CPath (paths_keyword, paths) - -> let keyword = + | CPath (paths_keyword, paths) -> + let keyword = match paths_keyword with `WhitelistPath -> "whitelist_path" | _ -> "blacklist_path" in let paths_str = String.concat ~sep:"," (List.map ~f:ALVar.alexp_to_string paths) in @@ -552,49 +563,55 @@ let print_checker c = c.definitions ; L.(debug Linters Medium) "@\n-------------------- @\n" + let ctl_evaluation_tracker = ref None let create_ctl_evaluation_tracker source_file = match (Config.linters_developer_mode, !ctl_evaluation_tracker) with - | true, None - -> ctl_evaluation_tracker := Some (Debug.EvaluationTracker.create source_file) - | true, _ - -> L.(die InternalError) "A CTL evaluation tracker has already been created" - | _ - -> () + | true, None -> + ctl_evaluation_tracker := Some (Debug.EvaluationTracker.create source_file) + | true, _ -> + L.(die InternalError) "A CTL evaluation tracker has already been created" + | _ -> + () + let debug_create_payload ast_node phi lcxt = match !ctl_evaluation_tracker with - | Some _ - -> Some (Debug.EvaluationTracker.create_content ast_node phi lcxt) - | None - -> None + | Some _ -> + Some (Debug.EvaluationTracker.create_content ast_node phi lcxt) + | None -> + None + let debug_eval_begin payload = match (!ctl_evaluation_tracker, payload) with - | Some tracker, Some payload - -> ctl_evaluation_tracker := Some (Debug.EvaluationTracker.eval_begin tracker payload) - | _ - -> () + | Some tracker, Some payload -> + ctl_evaluation_tracker := Some (Debug.EvaluationTracker.eval_begin tracker payload) + | _ -> + () + let debug_eval_end result = match !ctl_evaluation_tracker with - | Some tracker - -> ctl_evaluation_tracker := Some (Debug.EvaluationTracker.eval_end tracker result) - | None - -> () + | Some tracker -> + ctl_evaluation_tracker := Some (Debug.EvaluationTracker.eval_end tracker result) + | None -> + () + let save_dotty_when_in_debug_mode source_file = match !ctl_evaluation_tracker with - | Some tracker - -> let dotty_dir = Config.results_dir ^/ Config.lint_dotty_dir_name in + | Some tracker -> + let dotty_dir = Config.results_dir ^/ Config.lint_dotty_dir_name in Utils.create_dir dotty_dir ; let source_file_basename = Filename.basename (SourceFile.to_abs_path source_file) in let file = dotty_dir ^/ source_file_basename ^ ".dot" in let dotty = Debug.EvaluationTracker.DottyPrinter.dotty_of_ctl_evaluation tracker in Utils.with_file_out file ~f:(fun oc -> Out_channel.output_string oc dotty) - | _ - -> () + | _ -> + () + (* Helper functions *) (* given a decl returns a stmt such that decl--->stmt via label trs *) @@ -602,50 +619,52 @@ let transition_decl_to_stmt d trs = let open Clang_ast_t in let temp_res = match (trs, d) with - | Body, ObjCMethodDecl (_, _, omdi) - -> [omdi.omdi_body] + | Body, ObjCMethodDecl (_, _, omdi) -> + [omdi.omdi_body] | Body, FunctionDecl (_, _, _, fdi) | Body, CXXMethodDecl (_, _, _, fdi, _) | Body, CXXConstructorDecl (_, _, _, fdi, _) | Body, CXXConversionDecl (_, _, _, fdi, _) - | Body, CXXDestructorDecl (_, _, _, fdi, _) - -> [fdi.fdi_body] - | Body, BlockDecl (_, bdi) - -> [bdi.bdi_body] - | InitExpr, VarDecl (_, _, _, vdi) - -> [vdi.vdi_init_expr] + | Body, CXXDestructorDecl (_, _, _, fdi, _) -> + [fdi.fdi_body] + | Body, BlockDecl (_, bdi) -> + [bdi.bdi_body] + | InitExpr, VarDecl (_, _, _, vdi) -> + [vdi.vdi_init_expr] | InitExpr, ObjCIvarDecl (_, _, _, fldi, _) | InitExpr, FieldDecl (_, _, _, fldi) - | InitExpr, ObjCAtDefsFieldDecl (_, _, _, fldi) - -> [fldi.fldi_init_expr] + | InitExpr, ObjCAtDefsFieldDecl (_, _, _, fldi) -> + [fldi.fldi_init_expr] | InitExpr, CXXMethodDecl (_, _, _, _, mdi) | InitExpr, CXXConstructorDecl (_, _, _, _, mdi) | InitExpr, CXXConversionDecl (_, _, _, _, mdi) - | InitExpr, CXXDestructorDecl (_, _, _, _, mdi) - -> List.map ~f:(fun ci -> ci.xci_init_expr) mdi.xmdi_cxx_ctor_initializers - | InitExpr, EnumConstantDecl (_, _, _, ecdi) - -> [ecdi.ecdi_init_expr] - | _, _ - -> [None] + | InitExpr, CXXDestructorDecl (_, _, _, _, mdi) -> + List.map ~f:(fun ci -> ci.xci_init_expr) mdi.xmdi_cxx_ctor_initializers + | InitExpr, EnumConstantDecl (_, _, _, ecdi) -> + [ecdi.ecdi_init_expr] + | _, _ -> + [None] in List.fold ~f:(fun l e -> match e with Some st -> Stmt st :: l | _ -> l) temp_res ~init:[] + let transition_decl_to_decl_via_super d = let decl_opt_to_ast_node_opt d_opt = match d_opt with Some d' -> [Decl d'] | None -> [] in let do_ObjCImplementationDecl d = match CAst_utils.get_impl_decl_info d with - | Some idi - -> decl_opt_to_ast_node_opt (CAst_utils.get_super_ObjCImplementationDecl idi) - | None - -> [] + | Some idi -> + decl_opt_to_ast_node_opt (CAst_utils.get_super_ObjCImplementationDecl idi) + | None -> + [] in match d with - | Clang_ast_t.ObjCImplementationDecl _ - -> do_ObjCImplementationDecl d - | Clang_ast_t.ObjCInterfaceDecl (_, _, _, _, idi) - -> decl_opt_to_ast_node_opt (CAst_utils.get_decl_opt_with_decl_ref idi.otdi_super) - | _ - -> [] + | Clang_ast_t.ObjCImplementationDecl _ -> + do_ObjCImplementationDecl d + | Clang_ast_t.ObjCInterfaceDecl (_, _, _, _, idi) -> + decl_opt_to_ast_node_opt (CAst_utils.get_decl_opt_with_decl_ref idi.otdi_super) + | _ -> + [] + let transition_decl_to_decl_via_protocol d = let open Clang_ast_t in @@ -653,10 +672,11 @@ let transition_decl_to_decl_via_protocol d = match CAst_utils.get_decl dr.dr_decl_pointer with Some d -> Some (Decl d) | None -> None in match d with - | Clang_ast_t.ObjCProtocolDecl (_, _, _, _, opdi) - -> List.filter_map ~f:get_nodes opdi.opcdi_protocols - | _ - -> [] + | Clang_ast_t.ObjCProtocolDecl (_, _, _, _, opdi) -> + List.filter_map ~f:get_nodes opdi.opcdi_protocols + | _ -> + [] + let transition_stmt_to_stmt_via_condition st = let open Clang_ast_t in @@ -664,38 +684,41 @@ let transition_stmt_to_stmt_via_condition st = | IfStmt (_, _ :: _ :: cond :: _) | ConditionalOperator (_, cond :: _, _) | ForStmt (_, [_; _; cond; _; _]) - | WhileStmt (_, [_; cond; _]) - -> [Stmt cond] - | _ - -> [] + | WhileStmt (_, [_; cond; _]) -> + [Stmt cond] + | _ -> + [] + let transition_stmt_to_decl_via_pointer stmt = let open Clang_ast_t in match stmt with | ObjCMessageExpr (_, _, _, obj_c_message_expr_info) -> ( match CAst_utils.get_decl_opt obj_c_message_expr_info.Clang_ast_t.omei_decl_pointer with - | Some decl - -> [Decl decl] - | None - -> [] ) + | Some decl -> + [Decl decl] + | None -> + [] ) | DeclRefExpr (_, _, _, decl_ref_expr_info) -> ( match CAst_utils.get_decl_opt_with_decl_ref decl_ref_expr_info.Clang_ast_t.drti_decl_ref with - | Some decl - -> [Decl decl] - | None - -> [] ) - | _ - -> [] + | Some decl -> + [Decl decl] + | None -> + [] ) + | _ -> + [] + let transition_via_parameters an = let open Clang_ast_t in match an with - | Decl ObjCMethodDecl (_, _, omdi) - -> List.map ~f:(fun d -> Decl d) omdi.omdi_parameters - | Stmt ObjCMessageExpr (_, stmt_list, _, _) - -> List.map ~f:(fun stmt -> Stmt stmt) stmt_list - | _ - -> [] + | Decl ObjCMethodDecl (_, _, omdi) -> + List.map ~f:(fun d -> Decl d) omdi.omdi_parameters + | Stmt ObjCMessageExpr (_, stmt_list, _, _) -> + List.map ~f:(fun stmt -> Stmt stmt) stmt_list + | _ -> + [] + let parameter_of_corresp_name method_name args name = let names = @@ -703,13 +726,14 @@ let parameter_of_corresp_name method_name args name = in match List.zip names args with | Some names_args - -> ( + -> ( let names_arg_opt = List.find names_args ~f:(fun (arg_label, _) -> ALVar.compare_str_with_alexp arg_label name) in match names_arg_opt with Some (_, arg) -> Some arg | None -> None ) - | None - -> None + | None -> + None + let parameter_of_corresp_pos args pos = let pos_int = @@ -717,11 +741,12 @@ let parameter_of_corresp_pos args pos = | ALVar.Const n -> ( try int_of_string n with Failure _ -> -1 ) - | _ - -> -1 + | _ -> + -1 in List.nth args pos_int + let transition_via_specified_parameter ~pos an key = let invalid_param_name_use () = Logging.die InternalError "Transition ParameterName is only available for ObjC methods" @@ -732,21 +757,21 @@ let transition_via_specified_parameter ~pos an key = let apply_decl arg = Decl arg in let apply_stmt arg = Stmt arg in match an with - | Stmt ObjCMessageExpr (_, stmt_list, _, omei) - -> let method_name = omei.omei_selector in + | Stmt ObjCMessageExpr (_, stmt_list, _, omei) -> + let method_name = omei.omei_selector in let parameter_of_corresp_key = if pos then parameter_of_corresp_pos else parameter_of_corresp_name method_name in let arg_stmt_opt = parameter_of_corresp_key stmt_list key in node_opt_to_ast_node_list apply_stmt arg_stmt_opt - | Stmt CallExpr (_, _ :: args, _) - -> let parameter_of_corresp_key = + | Stmt CallExpr (_, _ :: args, _) -> + let parameter_of_corresp_key = if pos then parameter_of_corresp_pos else invalid_param_name_use () in let arg_stmt_opt = parameter_of_corresp_key args key in node_opt_to_ast_node_list apply_stmt arg_stmt_opt - | Decl ObjCMethodDecl (_, named_decl_info, omdi) - -> let method_name = named_decl_info.ni_name in + | Decl ObjCMethodDecl (_, named_decl_info, omdi) -> + let method_name = named_decl_info.ni_name in let parameter_of_corresp_key = if pos then parameter_of_corresp_pos else parameter_of_corresp_name method_name in @@ -754,14 +779,15 @@ let transition_via_specified_parameter ~pos an key = node_opt_to_ast_node_list apply_decl arg_decl_opt | Decl FunctionDecl (_, _, _, fdi) | Decl CXXMethodDecl (_, _, _, fdi, _) - | Decl CXXConstructorDecl (_, _, _, fdi, _) - -> let parameter_of_corresp_key = + | Decl CXXConstructorDecl (_, _, _, fdi, _) -> + let parameter_of_corresp_key = if pos then parameter_of_corresp_pos else invalid_param_name_use () in let arg_decl_opt = parameter_of_corresp_key fdi.fdi_parameters key in node_opt_to_ast_node_list apply_decl arg_decl_opt - | _ - -> [] + | _ -> + [] + let transition_via_parameter_name an name = transition_via_specified_parameter an name ~pos:false @@ -770,87 +796,94 @@ let transition_via_parameter_pos an pos = transition_via_specified_parameter an let transition_via_fields an = let open Clang_ast_t in match an with - | Decl RecordDecl (_, _, _, decls, _, _, _) | Decl CXXRecordDecl (_, _, _, decls, _, _, _, _) - -> List.filter_map ~f:(fun d -> match d with FieldDecl _ -> Some (Decl d) | _ -> None) decls - | Stmt InitListExpr (_, stmts, _) - -> List.map ~f:(fun stmt -> Stmt stmt) stmts - | _ - -> [] + | Decl RecordDecl (_, _, _, decls, _, _, _) | Decl CXXRecordDecl (_, _, _, decls, _, _, _, _) -> + List.filter_map ~f:(fun d -> match d with FieldDecl _ -> Some (Decl d) | _ -> None) decls + | Stmt InitListExpr (_, stmts, _) -> + List.map ~f:(fun stmt -> Stmt stmt) stmts + | _ -> + [] + let field_has_name name node = match node with - | Decl FieldDecl (_, name_info, _, _) - -> ALVar.compare_str_with_alexp name_info.Clang_ast_t.ni_name name - | _ - -> false + | Decl FieldDecl (_, name_info, _, _) -> + ALVar.compare_str_with_alexp name_info.Clang_ast_t.ni_name name + | _ -> + false + let field_of_name name nodes = List.filter ~f:(field_has_name name) nodes let field_of_corresp_name_from_init_list_expr name init_nodes (expr_info: Clang_ast_t.expr_info) = match CAst_utils.get_decl_from_typ_ptr expr_info.ei_qual_type.qt_type_ptr with | Some decl - -> ( + -> ( let fields = transition_via_fields (Decl decl) in match List.zip init_nodes fields with - | Some init_nodes_fields - -> List.filter ~f:(fun (_, field) -> field_has_name name field) init_nodes_fields + | Some init_nodes_fields -> + List.filter ~f:(fun (_, field) -> field_has_name name field) init_nodes_fields |> List.map ~f:(fun (node, _) -> node) - | None - -> [] ) - | None - -> [] + | None -> + [] ) + | None -> + [] + let transition_via_field_name node name = let open Clang_ast_t in match node with - | Decl RecordDecl _ | Decl CXXRecordDecl _ - -> let fields = transition_via_fields node in + | Decl RecordDecl _ | Decl CXXRecordDecl _ -> + let fields = transition_via_fields node in field_of_name name fields - | Stmt InitListExpr (_, stmts, expr_info) - -> let nodes = List.map ~f:(fun stmt -> Stmt stmt) stmts in + | Stmt InitListExpr (_, stmts, expr_info) -> + let nodes = List.map ~f:(fun stmt -> Stmt stmt) stmts in field_of_corresp_name_from_init_list_expr name nodes expr_info - | _ - -> [] + | _ -> + [] + (* given a node an returns a list of nodes an' such that an transition to an' via label trans *) let next_state_via_transition an trans = match (an, trans) with - | Decl d, Super - -> transition_decl_to_decl_via_super d - | _, FieldName name - -> transition_via_field_name an name - | _, Fields - -> transition_via_fields an - | _, Parameters - -> transition_via_parameters an - | Decl d, InitExpr | Decl d, Body - -> transition_decl_to_stmt d trans - | Decl d, Protocol - -> transition_decl_to_decl_via_protocol d - | Stmt st, Cond - -> transition_stmt_to_stmt_via_condition st - | Stmt st, PointerToDecl - -> transition_stmt_to_decl_via_pointer st - | an, ParameterName name - -> transition_via_parameter_name an name - | an, ParameterPos pos - -> transition_via_parameter_pos an pos - | _, _ - -> [] + | Decl d, Super -> + transition_decl_to_decl_via_super d + | _, FieldName name -> + transition_via_field_name an name + | _, Fields -> + transition_via_fields an + | _, Parameters -> + transition_via_parameters an + | Decl d, InitExpr | Decl d, Body -> + transition_decl_to_stmt d trans + | Decl d, Protocol -> + transition_decl_to_decl_via_protocol d + | Stmt st, Cond -> + transition_stmt_to_stmt_via_condition st + | Stmt st, PointerToDecl -> + transition_stmt_to_decl_via_pointer st + | an, ParameterName name -> + transition_via_parameter_name an name + | an, ParameterPos pos -> + transition_via_parameter_pos an pos + | _, _ -> + [] + let choose_one_witness an1 an2 = if Ctl_parser_types.ast_node_equal an1 an2 then an1 else if Ctl_parser_types.is_node_successor_of an1 ~is_successor:an2 then an2 else an1 + let choose_witness_opt witness_opt1 witness_opt2 = match (witness_opt1, witness_opt2) with - | Some witness1, Some witness2 - -> Some (choose_one_witness witness1 witness2) - | Some witness, None | None, Some witness - -> Some witness - | None, None - -> None + | Some witness1, Some witness2 -> + Some (choose_one_witness witness1 witness2) + | Some witness, None | None, Some witness -> + Some witness + | None, None -> + None + (* Evaluation of formulas *) (* evaluate an atomic formula (i.e. a predicate) on a ast node an and a @@ -858,115 +891,117 @@ let choose_witness_opt witness_opt1 witness_opt2 = let rec eval_Atomic _pred_name args an lcxt = let pred_name = ALVar.formula_id_to_string _pred_name in match (pred_name, args, an) with - | "call_class_method", [c; m], an - -> CPredicates.call_class_method an c m - | "call_function", [m], an - -> CPredicates.call_function an m - | "call_instance_method", [c; m], an - -> CPredicates.call_instance_method an c m - | "call_method", [m], an - -> CPredicates.call_method an m - | "captures_cxx_references", [], _ - -> CPredicates.captures_cxx_references an - | "context_in_synchronized_block", [], _ - -> CPredicates.context_in_synchronized_block lcxt - | "declaration_has_name", [decl_name], an - -> CPredicates.declaration_has_name an decl_name - | "declaration_ref_name", [decl_name], an - -> CPredicates.declaration_ref_name an decl_name - | "decl_unavailable_in_supported_ios_sdk", [], an - -> CPredicates.decl_unavailable_in_supported_ios_sdk lcxt an - | "class_unavailable_in_supported_ios_sdk", [], an - -> CPredicates.class_unavailable_in_supported_ios_sdk lcxt an - | "has_cast_kind", [name], an - -> CPredicates.has_cast_kind an name - | "has_type", [typ], an - -> CPredicates.has_type an typ - | "has_value", [typ], an - -> CPredicates.has_value an typ - | "isa", [classname], an - -> CPredicates.isa an classname - | "is_assign_property", [], an - -> CPredicates.is_assign_property an - | "is_binop_with_kind", [kind], an - -> CPredicates.is_binop_with_kind an kind - | "is_class", [cname], an - -> CPredicates.is_class an cname - | "is_const_var", [], an - -> CPredicates.is_const_expr_var an - | "is_decl", [], an - -> CPredicates.is_decl an - | "is_enum_constant", [cname], an - -> CPredicates.is_enum_constant an cname - | "is_enum_constant_of_enum", [name], an - -> CPredicates.is_enum_constant_of_enum an name - | "is_global_var", [], an - -> CPredicates.is_syntactically_global_var an - | "is_in_block", [], _ - -> CPredicates.is_in_block lcxt - | "is_in_cxx_constructor", [name], _ - -> CPredicates.is_in_cxx_constructor lcxt name - | "is_in_cxx_destructor", [name], _ - -> CPredicates.is_in_cxx_destructor lcxt name - | "is_in_cxx_method", [name], _ - -> CPredicates.is_in_cxx_method lcxt name - | "is_in_function", [name], _ - -> CPredicates.is_in_function lcxt name - | "is_in_objc_method", [name], _ - -> CPredicates.is_in_objc_method lcxt name - | "is_ivar_atomic", [], an - -> CPredicates.is_ivar_atomic an - | "is_method_property_accessor_of_ivar", [], an - -> CPredicates.is_method_property_accessor_of_ivar an lcxt - | "is_node", [nodename], an - -> CPredicates.is_node an nodename - | "is_objc_constructor", [], _ - -> CPredicates.is_objc_constructor lcxt - | "is_objc_dealloc", [], _ - -> CPredicates.is_objc_dealloc lcxt - | "is_objc_extension", [], _ - -> CPredicates.is_objc_extension lcxt - | "is_objc_interface_named", [name], an - -> CPredicates.is_objc_interface_named an name - | "is_property_pointer_type", [], an - -> CPredicates.is_property_pointer_type an - | "is_strong_property", [], an - -> CPredicates.is_strong_property an - | "is_unop_with_kind", [kind], an - -> CPredicates.is_unop_with_kind an kind - | "iphoneos_target_sdk_version_greater_or_equal", [version], _ - -> CPredicates.iphoneos_target_sdk_version_greater_or_equal lcxt (ALVar.alexp_to_string version) - | "method_return_type", [typ], an - -> CPredicates.method_return_type an typ - | "within_responds_to_selector_block", [], an - -> CPredicates.within_responds_to_selector_block lcxt an - | "using_namespace", [namespace], an - -> CPredicates.using_namespace an namespace - | "is_at_selector_with_name", [name], an - -> CPredicates.is_at_selector_with_name an name - | "has_type_const_ptr_to_objc_class", [], an - -> CPredicates.has_type_const_ptr_to_objc_class an - | "has_type_subprotocol_of", [protname], an - -> CPredicates.has_type_subprotocol_of an protname - | "has_visibility_attribute", [vis], an - -> CPredicates.has_visibility_attribute an vis - | "has_used_attribute", [], an - -> CPredicates.has_used_attribute an - | "within_available_class_block", [], an - -> CPredicates.within_available_class_block lcxt an - | _ - -> L.(die ExternalError) "Undefined Predicate or wrong set of arguments: '%s'" pred_name + | "call_class_method", [c; m], an -> + CPredicates.call_class_method an c m + | "call_function", [m], an -> + CPredicates.call_function an m + | "call_instance_method", [c; m], an -> + CPredicates.call_instance_method an c m + | "call_method", [m], an -> + CPredicates.call_method an m + | "captures_cxx_references", [], _ -> + CPredicates.captures_cxx_references an + | "context_in_synchronized_block", [], _ -> + CPredicates.context_in_synchronized_block lcxt + | "declaration_has_name", [decl_name], an -> + CPredicates.declaration_has_name an decl_name + | "declaration_ref_name", [decl_name], an -> + CPredicates.declaration_ref_name an decl_name + | "decl_unavailable_in_supported_ios_sdk", [], an -> + CPredicates.decl_unavailable_in_supported_ios_sdk lcxt an + | "class_unavailable_in_supported_ios_sdk", [], an -> + CPredicates.class_unavailable_in_supported_ios_sdk lcxt an + | "has_cast_kind", [name], an -> + CPredicates.has_cast_kind an name + | "has_type", [typ], an -> + CPredicates.has_type an typ + | "has_value", [typ], an -> + CPredicates.has_value an typ + | "isa", [classname], an -> + CPredicates.isa an classname + | "is_assign_property", [], an -> + CPredicates.is_assign_property an + | "is_binop_with_kind", [kind], an -> + CPredicates.is_binop_with_kind an kind + | "is_class", [cname], an -> + CPredicates.is_class an cname + | "is_const_var", [], an -> + CPredicates.is_const_expr_var an + | "is_decl", [], an -> + CPredicates.is_decl an + | "is_enum_constant", [cname], an -> + CPredicates.is_enum_constant an cname + | "is_enum_constant_of_enum", [name], an -> + CPredicates.is_enum_constant_of_enum an name + | "is_global_var", [], an -> + CPredicates.is_syntactically_global_var an + | "is_in_block", [], _ -> + CPredicates.is_in_block lcxt + | "is_in_cxx_constructor", [name], _ -> + CPredicates.is_in_cxx_constructor lcxt name + | "is_in_cxx_destructor", [name], _ -> + CPredicates.is_in_cxx_destructor lcxt name + | "is_in_cxx_method", [name], _ -> + CPredicates.is_in_cxx_method lcxt name + | "is_in_function", [name], _ -> + CPredicates.is_in_function lcxt name + | "is_in_objc_method", [name], _ -> + CPredicates.is_in_objc_method lcxt name + | "is_ivar_atomic", [], an -> + CPredicates.is_ivar_atomic an + | "is_method_property_accessor_of_ivar", [], an -> + CPredicates.is_method_property_accessor_of_ivar an lcxt + | "is_node", [nodename], an -> + CPredicates.is_node an nodename + | "is_objc_constructor", [], _ -> + CPredicates.is_objc_constructor lcxt + | "is_objc_dealloc", [], _ -> + CPredicates.is_objc_dealloc lcxt + | "is_objc_extension", [], _ -> + CPredicates.is_objc_extension lcxt + | "is_objc_interface_named", [name], an -> + CPredicates.is_objc_interface_named an name + | "is_property_pointer_type", [], an -> + CPredicates.is_property_pointer_type an + | "is_strong_property", [], an -> + CPredicates.is_strong_property an + | "is_unop_with_kind", [kind], an -> + CPredicates.is_unop_with_kind an kind + | "iphoneos_target_sdk_version_greater_or_equal", [version], _ -> + CPredicates.iphoneos_target_sdk_version_greater_or_equal lcxt (ALVar.alexp_to_string version) + | "method_return_type", [typ], an -> + CPredicates.method_return_type an typ + | "within_responds_to_selector_block", [], an -> + CPredicates.within_responds_to_selector_block lcxt an + | "using_namespace", [namespace], an -> + CPredicates.using_namespace an namespace + | "is_at_selector_with_name", [name], an -> + CPredicates.is_at_selector_with_name an name + | "has_type_const_ptr_to_objc_class", [], an -> + CPredicates.has_type_const_ptr_to_objc_class an + | "has_type_subprotocol_of", [protname], an -> + CPredicates.has_type_subprotocol_of an protname + | "has_visibility_attribute", [vis], an -> + CPredicates.has_visibility_attribute an vis + | "has_used_attribute", [], an -> + CPredicates.has_used_attribute an + | "within_available_class_block", [], an -> + CPredicates.within_available_class_block lcxt an + | _ -> + L.(die ExternalError) "Undefined Predicate or wrong set of arguments: '%s'" pred_name + and eval_AND an lcxt f1 f2 = match eval_formula f1 an lcxt with | Some witness1 -> ( match eval_formula f2 an lcxt with - | Some witness2 - -> Some (choose_one_witness witness1 witness2) - | _ - -> None ) - | None (* we short-circuit the AND evaluation *) - -> None + | Some witness2 -> + Some (choose_one_witness witness1 witness2) + | _ -> + None ) + | None (* we short-circuit the AND evaluation *) -> + None + and eval_OR an lcxt f1 f2 = choose_witness_opt (eval_formula f1 an lcxt) (eval_formula f2 an lcxt) @@ -975,6 +1010,7 @@ and eval_Implies an lcxt f1 f2 = let witness2 = eval_formula f2 an lcxt in choose_witness_opt witness1 witness2 + (* an, lcxt |= EF phi <=> an, lcxt |= phi or exists an' in Successors(st): an', lcxt |= EF phi @@ -984,17 +1020,18 @@ and eval_Implies an lcxt f1 f2 = *) and eval_EF phi an lcxt trans = match (trans, an) with - | Some _, _ - -> (* Using equivalence EF[->trans] phi = phi OR EX[->trans](EF[->trans] phi)*) + | Some _, _ -> + (* Using equivalence EF[->trans] phi = phi OR EX[->trans](EF[->trans] phi)*) let phi' = Or (phi, EX (trans, EF (trans, phi))) in eval_formula phi' an lcxt - | None, _ - -> let witness_opt = eval_formula phi an lcxt in + | None, _ -> + let witness_opt = eval_formula phi an lcxt in if Option.is_some witness_opt then witness_opt else List.fold_left (Ctl_parser_types.get_direct_successor_nodes an) ~init:witness_opt ~f: (fun acc node -> choose_witness_opt (eval_EF phi node lcxt trans) acc ) + (* an, lcxt |= EX phi <=> exists an' in Successors(st): an', lcxt |= phi That is: a (an, lcxt) satifies EX phi if and only if @@ -1004,20 +1041,21 @@ and eval_EF phi an lcxt trans = and eval_EX phi an lcxt trans = let succs = match trans with - | Some l - -> next_state_via_transition an l - | None - -> Ctl_parser_types.get_direct_successor_nodes an + | Some l -> + next_state_via_transition an l + | None -> + Ctl_parser_types.get_direct_successor_nodes an in let witness_opt = List.fold_left succs ~init:None ~f:(fun acc node -> choose_witness_opt (eval_formula phi node lcxt) acc ) in match (witness_opt, trans) with - | Some _, Some trans when not (is_transition_to_successor trans) - -> Some an (* We want to limit the witnesses to the successors of the original node. *) - | _ - -> witness_opt + | Some _, Some trans when not (is_transition_to_successor trans) -> + Some an (* We want to limit the witnesses to the successors of the original node. *) + | _ -> + witness_opt + (* an, lcxt |= E(phi1 U phi2) evaluated using the equivalence an, lcxt |= E(phi1 U phi2) <=> an, lcxt |= phi2 or (phi1 and EX(E(phi1 U phi2))) @@ -1029,6 +1067,7 @@ and eval_EU phi1 phi2 an lcxt trans = let f = Or (phi2, And (phi1, EX (trans, EU (trans, phi1, phi2)))) in eval_formula f an lcxt + (* an |= A(phi1 U phi2) evaluated using the equivalence an |= A(phi1 U phi2) <=> an |= phi2 or (phi1 and AX(A(phi1 U phi2))) @@ -1038,23 +1077,25 @@ and eval_AU phi1 phi2 an lcxt trans = let f = Or (phi2, And (phi1, AX (trans, AU (trans, phi1, phi2)))) in eval_formula f an lcxt + (* an, lcxt |= InNode[node_type_list] phi <=> an is a node of type in node_type_list and an satifies phi *) and in_node node_type_list phi an lctx = let holds_for_one_node n = match lctx.CLintersContext.et_evaluation_node with - | Some id - -> if String.equal id (Ctl_parser_types.ast_node_unique_string_id an) then + | Some id -> + if String.equal id (Ctl_parser_types.ast_node_unique_string_id an) then eval_formula phi an lctx else None - | None - -> if Ctl_parser_types.ast_node_has_kind [n] an then eval_formula phi an lctx else None + | None -> + if Ctl_parser_types.ast_node_has_kind [n] an then eval_formula phi an lctx else None in (* This is basically an OR of formula holds in the various nodes in the list *) List.fold_left node_type_list ~init:None ~f:(fun acc node -> choose_witness_opt (holds_for_one_node node) acc ) + (* Intuitive meaning: (an,lcxt) satifies EH[Classes] phi if the node an is among the declaration specified by the list Classes and there exists a super class in its hierarchy whose declaration satisfy phi. @@ -1067,6 +1108,7 @@ and eval_EH classes phi an lcxt = let f = ET (classes, None, EX (Some Super, EF (Some Super, phi))) in eval_formula f an lcxt + (* an, lcxt |= ET[T][->l]phi <=> eventually we reach a node an' such that an' is among the types defined in T and: @@ -1080,54 +1122,56 @@ and eval_EH classes phi an lcxt = and eval_ET tl trs phi an lcxt = let f = match trs with - | Some _ - -> EF (None, InNode (tl, EX (trs, phi))) - | None - -> EF (None, InNode (tl, phi)) + | Some _ -> + EF (None, InNode (tl, EX (trs, phi))) + | None -> + EF (None, InNode (tl, phi)) in eval_formula f an lcxt + (* Formulas are evaluated on a AST node an and a linter context lcxt *) and eval_formula f an lcxt : Ctl_parser_types.ast_node option = debug_eval_begin (debug_create_payload an f lcxt) ; let res = match f with - | True - -> Some an - | False - -> None - | Atomic (name, params) - -> if eval_Atomic name params an lcxt then Some an else None - | InNode (node_type_list, f1) - -> in_node node_type_list f1 an lcxt + | True -> + Some an + | False -> + None + | Atomic (name, params) -> + if eval_Atomic name params an lcxt then Some an else None + | InNode (node_type_list, f1) -> + in_node node_type_list f1 an lcxt | Not f1 -> ( match eval_formula f1 an lcxt with Some _ -> None | None -> Some an ) - | And (f1, f2) - -> eval_AND an lcxt f1 f2 - | Or (f1, f2) - -> eval_OR an lcxt f1 f2 - | Implies (f1, f2) - -> eval_Implies an lcxt f1 f2 - | AU (trans, f1, f2) - -> eval_AU f1 f2 an lcxt trans - | EU (trans, f1, f2) - -> eval_EU f1 f2 an lcxt trans - | EF (trans, f1) - -> eval_EF f1 an lcxt trans - | AF (trans, f1) - -> eval_formula (AU (trans, True, f1)) an lcxt - | AG (trans, f1) - -> eval_formula (Not (EF (trans, Not f1))) an lcxt - | EX (trans, f1) - -> eval_EX f1 an lcxt trans - | AX (trans, f1) - -> eval_formula (Not (EX (trans, Not f1))) an lcxt - | EH (cl, phi) - -> eval_EH cl phi an lcxt - | EG (trans, f1) - -> (* st |= EG f1 <=> st |= f1 /\ EX EG f1 *) + | And (f1, f2) -> + eval_AND an lcxt f1 f2 + | Or (f1, f2) -> + eval_OR an lcxt f1 f2 + | Implies (f1, f2) -> + eval_Implies an lcxt f1 f2 + | AU (trans, f1, f2) -> + eval_AU f1 f2 an lcxt trans + | EU (trans, f1, f2) -> + eval_EU f1 f2 an lcxt trans + | EF (trans, f1) -> + eval_EF f1 an lcxt trans + | AF (trans, f1) -> + eval_formula (AU (trans, True, f1)) an lcxt + | AG (trans, f1) -> + eval_formula (Not (EF (trans, Not f1))) an lcxt + | EX (trans, f1) -> + eval_EX f1 an lcxt trans + | AX (trans, f1) -> + eval_formula (Not (EX (trans, Not f1))) an lcxt + | EH (cl, phi) -> + eval_EH cl phi an lcxt + | EG (trans, f1) -> + (* st |= EG f1 <=> st |= f1 /\ EX EG f1 *) eval_formula (And (f1, EX (trans, EG (trans, f1)))) an lcxt - | ET (tl, sw, phi) - -> eval_ET tl sw phi an lcxt + | ET (tl, sw, phi) -> + eval_ET tl sw phi an lcxt in debug_eval_end res ; res + diff --git a/infer/src/clang/cTrans.ml b/infer/src/clang/cTrans.ml index f1ea2a7c6..1d1ac5cb4 100644 --- a/infer/src/clang/cTrans.ml +++ b/infer/src/clang/cTrans.ml @@ -31,18 +31,18 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let method_kind = Typ.Procname.objc_method_kind_of_bool is_instance in let ms_opt = match method_pointer_opt with - | Some pointer - -> CMethod_trans.method_signature_of_pointer context.translation_unit_context context.tenv + | Some pointer -> + CMethod_trans.method_signature_of_pointer context.translation_unit_context context.tenv pointer - | None - -> None + | None -> + None in let proc_name = match CMethod_trans.get_method_name_from_clang context.tenv ms_opt with - | Some ms - -> CMethod_signature.ms_get_name ms - | None - -> (* fall back to our method resolution if clang's fails *) + | Some ms -> + CMethod_signature.ms_get_name ms + | None -> + (* fall back to our method resolution if clang's fails *) let class_name = CMethod_trans.get_class_name_method_call_from_receiver_kind context obj_c_message_expr_info act_params @@ -51,30 +51,31 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in let predefined_ms_opt = match proc_name with - | Typ.Procname.ObjC_Cpp objc_cpp - -> let class_name = Typ.Procname.objc_cpp_get_class_type_name objc_cpp in + | Typ.Procname.ObjC_Cpp objc_cpp -> + let class_name = Typ.Procname.objc_cpp_get_class_type_name objc_cpp in CTrans_models.get_predefined_model_method_signature class_name selector CProcname.NoAstDecl.objc_method_of_string_kind CFrontend_config.ObjC - | _ - -> None + | _ -> + None in match (predefined_ms_opt, ms_opt) with - | Some ms, _ - -> ignore + | Some ms, _ -> + ignore (CMethod_trans.create_local_procdesc context.translation_unit_context context.cfg context.tenv ms [] [] is_instance) ; (CMethod_signature.ms_get_name ms, CMethod_trans.MCNoVirtual) - | None, Some ms - -> ignore + | None, Some ms -> + ignore (CMethod_trans.create_local_procdesc context.translation_unit_context context.cfg context.tenv ms [] [] is_instance) ; if CMethod_signature.ms_is_getter ms || CMethod_signature.ms_is_setter ms then (proc_name, CMethod_trans.MCNoVirtual) else (proc_name, mc_type) - | _ - -> CMethod_trans.create_external_procdesc context.cfg proc_name is_instance None ; + | _ -> + CMethod_trans.create_external_procdesc context.cfg proc_name is_instance None ; (proc_name, mc_type) + let add_autorelease_call context exp typ sil_loc = let method_name = Typ.Procname.get_method (Procdesc.get_proc_name context.CContext.procdesc) in if !Config.arc_mode && not (CTrans_utils.is_owning_name method_name) @@ -89,25 +90,28 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s [stmt_call] else [] + let rec is_block_expr s = let open Clang_ast_t in match s with - | BlockExpr _ - -> true + | BlockExpr _ -> + true (* the block can be wrapped in ExprWithCleanups or ImplicitCastExpr*) | ImplicitCastExpr (_, [s'], _, _) - | ExprWithCleanups (_, [s'], _, _) - -> is_block_expr s' - | _ - -> false + | ExprWithCleanups (_, [s'], _, _) -> + is_block_expr s' + | _ -> + false + let objc_exp_of_type_block fun_exp_stmt = match fun_exp_stmt with | Clang_ast_t.ImplicitCastExpr (_, _, ei, _) - when CType.is_block_type ei.Clang_ast_t.ei_qual_type - -> true - | _ - -> false + when CType.is_block_type ei.Clang_ast_t.ei_qual_type -> + true + | _ -> + false + (* This function add in tenv a class representing an objc block. *) (* An object of this class has type:*) @@ -137,7 +141,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let block_type = Typ.mk (Typ.Tstruct block_typename) in let trans_res = CTrans_utils.alloc_trans trans_state ~alloc_builtin:BuiltinDecl.__objc_alloc_no_fail loc - (Ast_expressions.dummy_stmt_info ()) block_type + (Ast_expressions.dummy_stmt_info ()) + block_type in let id_block = match trans_res.exps with [(Exp.Var id, _)] -> id | _ -> assert false in let mblock = Mangled.from_string block_name in @@ -160,6 +165,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in declare_block_local :: trans_res.instrs @ [set_instr] @ captured_instrs @ set_fields + (* From a list of expression extract blocks from tuples and *) (* returns block names and assignment to temp vars *) let extract_block_from_tuple procname exps loc = @@ -174,21 +180,23 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in let make_arg typ (id, _, _) = (id, typ) in let f = function - | Exp.Closure {name; captured_vars}, ({Typ.desc= Tptr ({Typ.desc= Tfun _}, _)} as t) - -> let function_name = make_function_name t name in + | Exp.Closure {name; captured_vars}, ({Typ.desc= Tptr ({Typ.desc= Tfun _}, _)} as t) -> + let function_name = make_function_name t name in let args = List.map ~f:(make_arg t) captured_vars in function_name :: args - | e - -> [e] + | e -> + [e] in (* evaluation order matters here *) let exps' = List.concat_map ~f exps in let insts' = !insts in (exps', insts') + let collect_exprs res_trans_list = List.concat_map ~f:(fun res_trans -> res_trans.exps) res_trans_list + (* If e is a block and the calling node has the priority then *) (* we need to release the priority to allow*) (* creation of nodes inside the block.*) @@ -200,6 +208,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s f {trans_state with priority= Free} e ) else f trans_state e + let exec_with_node_creation f trans_state stmt = let res_trans = f trans_state stmt in if res_trans.instrs <> [] then @@ -214,6 +223,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s {to_parent with exps= res_trans.exps} else res_trans + (* This is the standard way of dealing with self:Class or a call [a class]. We translate it as sizeof() The only time when we want to translate those expressions differently is when they are the first argument of method calls. In that case they are not translated as @@ -228,6 +238,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s [ ( Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype= Subtype.exact} , Typ.mk (Tint IULong) ) ] } + let add_reference_if_glvalue (typ: Typ.t) expr_info = (* glvalue definition per C++11:*) (* http://en.cppreference.com/w/cpp/language/value_category *) @@ -235,15 +246,16 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s match expr_info.Clang_ast_t.ei_value_kind with `LValue | `XValue -> true | `RValue -> false in match (is_glvalue, typ.desc) with - | true, Tptr (_, Pk_reference) - -> (* reference of reference is not allowed in C++ - it's most likely frontend *) + | true, Tptr (_, Pk_reference) -> + (* reference of reference is not allowed in C++ - it's most likely frontend *) (* trying to add same reference to same type twice*) (* this is hacky and should be fixed (t9838691) *) typ - | true, _ - -> Typ.mk (Tptr (typ, Pk_reference)) - | _ - -> typ + | true, _ -> + Typ.mk (Tptr (typ, Pk_reference)) + | _ -> + typ + (** Execute translation and then possibly adjust the type of the result of translation: In C++, when expression returns reference to type T, it will be lvalue to T, not T&, but @@ -259,6 +271,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in {res_trans with exps= [(exp, add_reference_if_glvalue typ expr_info)]} + (* Execute translation of e forcing to release priority (if it's not free) and then setting it back.*) (* This is used in conditional operators where we need to force @@ -268,6 +281,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s if PriorityNode.is_priority_free trans_state then f trans_state e else f {trans_state with priority= Free} e + let call_translation context decl = let open CContext in (* translation will reset Ident counter, save it's state and restore it afterwards *) @@ -276,15 +290,18 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s context.cfg `Translation decl ; Ident.NameGenerator.set_current ident_state + let mk_temp_sil_var procdesc var_name_suffix = let procname = Procdesc.get_proc_name procdesc in Pvar.mk_tmp var_name_suffix procname + let mk_temp_sil_var_for_expr tenv procdesc var_name_prefix expr_info = let qual_type = expr_info.Clang_ast_t.ei_qual_type in let typ = CType_decl.qual_type_to_sil_type tenv qual_type in (mk_temp_sil_var procdesc var_name_prefix, typ) + let create_var_exp_tmp_var trans_state expr_info var_name = let context = trans_state.context in let procdesc = context.CContext.procdesc in @@ -292,6 +309,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s Procdesc.append_locals procdesc [(Pvar.get_name pvar, typ)] ; (Exp.Lvar pvar, typ) + let create_call_instr trans_state (return_type: Typ.t) function_sil params_sil sil_loc call_flags ~is_objc_method = let ret_id = @@ -304,10 +322,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let param_type = Typ.mk (Typ.Tptr (return_type, Typ.Pk_pointer)) in let var_exp = match trans_state.var_exp_typ with - | Some (exp, _) - -> exp - | _ - -> let procdesc = trans_state.context.CContext.procdesc in + | Some (exp, _) -> + exp + | _ -> + let procdesc = trans_state.context.CContext.procdesc in let pvar = mk_temp_sil_var procdesc "__temp_return_" in Procdesc.append_locals procdesc [(Pvar.get_name pvar, return_type)] ; Exp.Lvar pvar @@ -335,11 +353,13 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let call_instr = Sil.Call (ret_id', function_sil, params, sil_loc, call_flags) in {empty_res_trans with instrs= [call_instr]; exps= ret_exps; initd_exps} + let stringLiteral_trans trans_state expr_info str = let typ = CType_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in let exp = Exp.Const (Const.Cstr str) in {empty_res_trans with exps= [(exp, typ)]} + (* FROM CLANG DOCS: "Implements the GNU __null extension, which is a name for a null pointer constant *) (* that has integral type (e.g., int or long) and is the same @@ -353,36 +373,44 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let exp = Exp.Const (Const.Cint IntLit.zero) in {empty_res_trans with exps= [(exp, typ)]} + let nullPtrExpr_trans trans_state expr_info = let typ = CType_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in {empty_res_trans with exps= [(Exp.null, typ)]} + let objCSelectorExpr_trans trans_state expr_info selector = stringLiteral_trans trans_state expr_info selector + let objCEncodeExpr_trans trans_state expr_info objc_encode_expr_info = let type_raw = objc_encode_expr_info.Clang_ast_t.oeei_raw in stringLiteral_trans trans_state expr_info type_raw + let objCProtocolExpr_trans trans_state expr_info decl_ref = let name = match decl_ref.Clang_ast_t.dr_name with Some s -> s.Clang_ast_t.ni_name | _ -> "" in stringLiteral_trans trans_state expr_info name + let characterLiteral_trans trans_state expr_info n = let typ = CType_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in let exp = Exp.Const (Const.Cint (IntLit.of_int n)) in {empty_res_trans with exps= [(exp, typ)]} + let booleanValue_trans trans_state expr_info b = characterLiteral_trans trans_state expr_info (if b then 1 else 0) + let floatingLiteral_trans trans_state expr_info float_string = let typ = CType_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in let exp = Exp.Const (Const.Cfloat (float_of_string float_string)) in {empty_res_trans with exps= [(exp, typ)]} + (* Note currently we don't have support for different qual *) (* type like long, unsigned long, etc *) and integerLiteral_trans trans_state expr_info integer_literal_info = @@ -399,68 +427,71 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in {empty_res_trans with exps= [(exp, typ)]} + let cxxScalarValueInitExpr_trans trans_state expr_info = let typ = CType_decl.get_type_from_expr_info expr_info trans_state.context.CContext.tenv in (* constant will be different depending on type *) let zero_opt = match typ.desc with - | Typ.Tfloat _ | Typ.Tptr _ | Typ.Tint _ - -> Some (Sil.zero_value_of_numerical_type typ) - | Typ.Tvoid - -> None - | _ - -> Some (Exp.Const (Const.Cint IntLit.zero)) + | Typ.Tfloat _ | Typ.Tptr _ | Typ.Tint _ -> + Some (Sil.zero_value_of_numerical_type typ) + | Typ.Tvoid -> + None + | _ -> + Some (Exp.Const (Const.Cint IntLit.zero)) in match zero_opt with - | Some zero - -> {empty_res_trans with exps= [(zero, typ)]} - | _ - -> empty_res_trans + | Some zero -> + {empty_res_trans with exps= [(zero, typ)]} + | _ -> + empty_res_trans + (** Create instructions to initialize record with zeroes. It needs to traverse whole type structure, to assign 0 values to all transitive fields because of AST construction in C translation *) let implicitValueInitExpr_trans trans_state stmt_info = match trans_state.var_exp_typ with - | Some var_exp_typ - -> (* This node will always be child of InitListExpr, claiming priority will always fail *) + | Some var_exp_typ -> + (* This node will always be child of InitListExpr, claiming priority will always fail *) let tenv = trans_state.context.CContext.tenv in let sil_loc = CLocation.get_sil_location stmt_info trans_state.context in let flatten_res_trans = collect_res_trans trans_state.context.procdesc in (* Traverse structure of a type and initialize int/float/ptr fields with zero *) let rec fill_typ_with_zero (exp, typ) : trans_result = match typ.Typ.desc with - | Tstruct tn - -> let field_exps = + | Tstruct tn -> + let field_exps = match Tenv.lookup tenv tn with - | Some {fields} - -> List.filter_map fields ~f:(fun (fieldname, fieldtype, _) -> + | Some {fields} -> + List.filter_map fields ~f:(fun (fieldname, fieldtype, _) -> if Typ.Fieldname.is_hidden fieldname then None else Some (Exp.Lfield (exp, fieldname, typ), fieldtype) ) - | None - -> assert false + | None -> + assert false in List.map ~f:fill_typ_with_zero field_exps |> flatten_res_trans - | Tarray (field_typ, Some n, _) - -> let size = IntLit.to_int n in + | Tarray (field_typ, Some n, _) -> + let size = IntLit.to_int n in let indices = CGeneral_utils.list_range 0 (size - 1) in List.map indices ~f:(fun i -> let idx_exp = Exp.Const (Const.Cint (IntLit.of_int i)) in let field_exp = Exp.Lindex (exp, idx_exp) in fill_typ_with_zero (field_exp, field_typ) ) |> flatten_res_trans - | Tint _ | Tfloat _ | Tptr _ - -> let zero_exp = Sil.zero_value_of_numerical_type typ in + | Tint _ | Tfloat _ | Tptr _ -> + let zero_exp = Sil.zero_value_of_numerical_type typ in let instrs = [Sil.Store (exp, typ, zero_exp, sil_loc)] in let exps = [(exp, typ)] in {empty_res_trans with exps; instrs} - | Tfun _ | Tvoid | Tarray _ | TVar _ - -> CFrontend_config.unimplemented "fill_typ_with_zero on type %a" (Typ.pp Pp.text) typ + | Tfun _ | Tvoid | Tarray _ | TVar _ -> + CFrontend_config.unimplemented "fill_typ_with_zero on type %a" (Typ.pp Pp.text) typ in let res_trans = fill_typ_with_zero var_exp_typ in {res_trans with initd_exps= [fst var_exp_typ]} - | None - -> CFrontend_config.unimplemented "Retrieving var from non-InitListExpr parent" + | None -> + CFrontend_config.unimplemented "Retrieving var from non-InitListExpr parent" + let no_op_trans succ_nodes = {empty_res_trans with root_nodes= succ_nodes} @@ -469,8 +500,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let tenv = trans_state.context.CContext.tenv in let typ = CType_decl.qual_type_to_sil_type tenv expr_info.Clang_ast_t.ei_qual_type in match unary_expr_or_type_trait_expr_info.Clang_ast_t.uttei_kind with - | `SizeOf | `SizeOfWithSize _ as size - -> let qt_opt = + | `SizeOf | `SizeOfWithSize _ as size -> + let qt_opt = CAst_utils.type_from_unary_expr_or_type_trait_expr_info unary_expr_or_type_trait_expr_info in @@ -483,12 +514,13 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s {Exp.typ= sizeof_typ; nbytes; dynamic_length= None; subtype= Subtype.exact} in {empty_res_trans with exps= [(Exp.Sizeof sizeof_data, sizeof_typ)]} - | k - -> L.(debug Capture Medium) + | k -> + L.(debug Capture Medium) "@\nWARNING: Missing translation of Uniry_Expression_Or_Trait of kind: %s . Expression ignored, returned -1... @\n" (Clang_ast_j.string_of_unary_expr_or_type_trait_kind k) ; {empty_res_trans with exps= [(Exp.minus_one, typ)]} + (* search the label into the hashtbl - create a fake node eventually *) (* connect that node with this stmt *) let gotoStmt_trans trans_state stmt_info label_name = @@ -496,6 +528,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let root_node' = GotoLabel.find_goto_label trans_state.context label_name sil_loc in {empty_res_trans with root_nodes= [root_node']; leaf_nodes= trans_state.succ_nodes} + let get_builtin_pname_opt trans_unit_ctx qual_name decl_opt (qual_type: Clang_ast_t.qual_type) = let get_annotate_attr_arg decl = let open Clang_ast_t in @@ -504,32 +537,33 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s match List.find_map ~f:get_attr_opt decl_info.di_attributes with | Some attribute_info -> ( match attribute_info.ai_parameters with - | [_; arg; _] - -> Some arg - | _ - -> (* it's not supposed to happen due to hardcoded exporting logic + | [_; arg; _] -> + Some arg + | _ -> + (* it's not supposed to happen due to hardcoded exporting logic coming from ASTExporter.h in facebook-clang-plugins *) assert false ) - | None - -> None + | None -> + None in let name = QualifiedCppName.to_qual_string qual_name in let function_attr_opt = Option.bind decl_opt ~f:get_annotate_attr_arg in match function_attr_opt with - | Some attr when CTrans_models.is_modeled_attribute attr - -> Some (Typ.Procname.from_string_c_fun attr) - | _ when CTrans_models.is_modeled_builtin name - -> Some (Typ.Procname.from_string_c_fun (CFrontend_config.infer ^ name)) - | _ when CTrans_models.is_release_builtin name qual_type.qt_type_ptr - -> Some BuiltinDecl.__objc_release_cf - | _ when CTrans_models.is_retain_builtin name qual_type.qt_type_ptr - -> Some BuiltinDecl.__objc_retain_cf + | Some attr when CTrans_models.is_modeled_attribute attr -> + Some (Typ.Procname.from_string_c_fun attr) + | _ when CTrans_models.is_modeled_builtin name -> + Some (Typ.Procname.from_string_c_fun (CFrontend_config.infer ^ name)) + | _ when CTrans_models.is_release_builtin name qual_type.qt_type_ptr -> + Some BuiltinDecl.__objc_release_cf + | _ when CTrans_models.is_retain_builtin name qual_type.qt_type_ptr -> + Some BuiltinDecl.__objc_retain_cf | _ when String.equal name CFrontend_config.malloc - && CGeneral_utils.is_objc_extension trans_unit_ctx - -> Some BuiltinDecl.malloc_no_fail - | _ - -> None + && CGeneral_utils.is_objc_extension trans_unit_ctx -> + Some BuiltinDecl.malloc_no_fail + | _ -> + None + let function_deref_trans trans_state decl_ref = let open CContext in @@ -543,14 +577,15 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s match get_builtin_pname_opt context.translation_unit_context qual_name decl_opt qual_type with - | Some builtin_pname - -> builtin_pname - | None - -> let name = QualifiedCppName.to_qual_string qual_name in + | Some builtin_pname -> + builtin_pname + | None -> + let name = QualifiedCppName.to_qual_string qual_name in CMethod_trans.create_procdesc_with_pointer context decl_ptr None name in {empty_res_trans with exps= [(Exp.Const (Const.Cfun pname), typ)]} + let field_deref_trans trans_state stmt_info pre_trans_result decl_ref ~is_constructor_init = let open CContext in let context = trans_state.context in @@ -571,12 +606,12 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s | Some FieldDecl ({di_parent_pointer}, _, _, _) | Some ObjCIvarDecl ({di_parent_pointer}, _, _, _, _) -> ( match CAst_utils.get_decl_opt di_parent_pointer with - | Some decl - -> CType_decl.get_record_typename ~tenv:context.tenv decl - | _ - -> assert false ) - | _ as decl - -> (* FIXME(t21762295): we do not expect this to happen but it does *) + | Some decl -> + CType_decl.get_record_typename ~tenv:context.tenv decl + | _ -> + assert false ) + | _ as decl -> + (* FIXME(t21762295): we do not expect this to happen but it does *) CFrontend_config.incorrect_assumption "di_parent_pointer should be always set for fields/ivars, but got %a" (Pp.option (Pp.to_string ~f:Clang_ast_j.string_of_decl)) @@ -604,6 +639,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let instrs = pre_trans_result.instrs @ deref_instrs in {pre_trans_result with instrs; exps= [(exp, field_typ)]} + let method_deref_trans ?(is_inner_destructor= false) trans_state pre_trans_result decl_ref stmt_info decl_kind = let open CContext in @@ -636,21 +672,21 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (* won't have a pointer - if that happens add a pointer to type of the object *) pre_trans_result.exps with - | [] - -> ([], []) + | [] -> + ([], []) (* We need to add a dereference before a method call to find null dereferences when *) (* calling a method with null *) | [(exp, {Typ.desc= Tptr (typ, _)})] - when decl_kind <> `CXXConstructor - -> let no_id = Ident.create_none () in + when decl_kind <> `CXXConstructor -> + let no_id = Ident.create_none () in let extra_instrs = [Sil.Load (no_id, exp, typ, sil_loc)] in (pre_trans_result.exps, extra_instrs) - | [(_, {Typ.desc= Tptr _})] - -> (pre_trans_result.exps, []) - | [(sil, typ)] - -> ([(sil, Typ.mk (Tptr (typ, Typ.Pk_reference)))], []) - | _ - -> assert false + | [(_, {Typ.desc= Tptr _})] -> + (pre_trans_result.exps, []) + | [(sil, typ)] -> + ([(sil, Typ.mk (Tptr (typ, Typ.Pk_reference)))], []) + | _ -> + assert false else (* don't add 'this' expression for static methods *) ([], []) in @@ -661,17 +697,17 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s match get_builtin_pname_opt context.translation_unit_context qual_method_name decl_opt qual_type with - | Some builtin_pname - -> builtin_pname - | None - -> let class_typename = + | Some builtin_pname -> + builtin_pname + | None -> + let class_typename = Typ.Name.Cpp.from_qual_name Typ.NoTemplate (CAst_utils.get_class_name_from_member name_info) in if is_inner_destructor then match ms_opt with - | Some ms - -> let procname = CMethod_signature.ms_get_name ms in + | Some ms -> + let procname = CMethod_signature.ms_get_name ms in let new_method_name = Config.clang_inner_destructor_prefix ^ Typ.Procname.get_method procname in @@ -683,8 +719,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (CMethod_trans.create_local_procdesc context.translation_unit_context context.cfg context.tenv ms' [] [] false) ; CMethod_signature.ms_get_name ms' - | None - -> CMethod_trans.create_procdesc_with_pointer context decl_ptr (Some class_typename) + | None -> + CMethod_trans.create_procdesc_with_pointer context decl_ptr (Some class_typename) method_name else CMethod_trans.create_procdesc_with_pointer context decl_ptr (Some class_typename) @@ -696,32 +732,34 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s ; exps= [method_exp] @ extra_exps ; instrs= pre_trans_result.instrs @ extra_instrs } + let destructor_deref_trans trans_state pvar_trans_result class_type_ptr si ~is_inner_destructor = let open Clang_ast_t in let destruct_decl_ref_opt = match CAst_utils.get_decl_from_typ_ptr class_type_ptr with | Some CXXRecordDecl (_, _, _, _, _, _, _, cxx_record_info) - | Some ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, cxx_record_info, _, _) - -> cxx_record_info.xrdi_destructor - | _ - -> None + | Some ClassTemplateSpecializationDecl (_, _, _, _, _, _, _, cxx_record_info, _, _) -> + cxx_record_info.xrdi_destructor + | _ -> + None in match destruct_decl_ref_opt with | Some decl_ref -> ( match CAst_utils.get_decl decl_ref.Clang_ast_t.dr_decl_pointer with - | Some CXXDestructorDecl (_, named_decl_info, _, {fdi_body= None}, _) - -> L.(debug Capture Verbose) + | Some CXXDestructorDecl (_, named_decl_info, _, {fdi_body= None}, _) -> + L.(debug Capture Verbose) "@\n Trying to translate destructor call, but found empty destructor body for %s@\n@." (CAst_utils.get_unqualified_name named_decl_info) ; empty_res_trans | Some CXXDestructorDecl (_, _, _, {fdi_body= Some _}, _) - (* Translate only those destructors that have bodies *) - -> method_deref_trans ~is_inner_destructor trans_state pvar_trans_result decl_ref si + (* Translate only those destructors that have bodies *) -> + method_deref_trans ~is_inner_destructor trans_state pvar_trans_result decl_ref si `CXXDestructor - | _ - -> empty_res_trans ) - | None - -> empty_res_trans + | _ -> + empty_res_trans ) + | None -> + empty_res_trans + let this_expr_trans trans_state sil_loc class_qual_type = let context = trans_state.context in @@ -734,10 +772,12 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (* there is no cast operation in AST, but backend needs it *) dereference_value_from_result sil_loc {empty_res_trans with exps} ~strip_pointer:false + let cxxThisExpr_trans trans_state stmt_info expr_info = let sil_loc = CLocation.get_sil_location stmt_info trans_state.context in this_expr_trans trans_state sil_loc expr_info.Clang_ast_t.ei_qual_type + let rec labelStmt_trans trans_state stmt_info stmt_list label_name = let context = trans_state.context in (* go ahead with the translation *) @@ -751,18 +791,19 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s Procdesc.node_set_succs_exn context.procdesc root_node' res_trans.root_nodes [] ; {empty_res_trans with root_nodes= [root_node']; leaf_nodes= trans_state.succ_nodes} + and var_deref_trans trans_state stmt_info (decl_ref: Clang_ast_t.decl_ref) = let context = trans_state.context in let _, _, qual_type = CAst_utils.get_info_from_decl_ref decl_ref in let ast_typ = CType_decl.qual_type_to_sil_type context.tenv qual_type in let typ = match ast_typ.Typ.desc with - | Tstruct _ when decl_ref.dr_kind = `ParmVar - -> if CGeneral_utils.is_cpp_translation context.translation_unit_context then + | Tstruct _ when decl_ref.dr_kind = `ParmVar -> + if CGeneral_utils.is_cpp_translation context.translation_unit_context then Typ.mk (Tptr (ast_typ, Pk_reference)) else ast_typ - | _ - -> ast_typ + | _ -> + ast_typ in let procname = Procdesc.get_proc_name context.procdesc in let sil_loc = CLocation.get_sil_location stmt_info context in @@ -781,11 +822,12 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s L.(debug Capture Verbose) "@\n@\n PVAR ='%s'@\n@\n" (Pvar.to_string pvar) ; let res_trans = {empty_res_trans with exps} in match typ.desc with - | Tptr (_, Pk_reference) - -> (* dereference pvar due to the behavior of reference types in clang's AST *) + | Tptr (_, Pk_reference) -> + (* dereference pvar due to the behavior of reference types in clang's AST *) dereference_value_from_result sil_loc res_trans ~strip_pointer:false - | _ - -> res_trans + | _ -> + res_trans + and decl_ref_trans trans_state pre_trans_result stmt_info decl_ref ~is_constructor_init = L.(debug Capture Verbose) @@ -793,21 +835,22 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (string_of_bool (PriorityNode.is_priority_free trans_state)) ; let decl_kind = decl_ref.Clang_ast_t.dr_kind in match decl_kind with - | `EnumConstant - -> enum_constant_trans trans_state decl_ref - | `Function - -> function_deref_trans trans_state decl_ref - | `Var | `ImplicitParam | `ParmVar - -> var_deref_trans trans_state stmt_info decl_ref - | `Field | `ObjCIvar - -> field_deref_trans trans_state stmt_info pre_trans_result decl_ref ~is_constructor_init - | `CXXMethod | `CXXConversion | `CXXConstructor | `CXXDestructor - -> method_deref_trans trans_state pre_trans_result decl_ref stmt_info decl_kind - | _ - -> CFrontend_config.unimplemented + | `EnumConstant -> + enum_constant_trans trans_state decl_ref + | `Function -> + function_deref_trans trans_state decl_ref + | `Var | `ImplicitParam | `ParmVar -> + var_deref_trans trans_state stmt_info decl_ref + | `Field | `ObjCIvar -> + field_deref_trans trans_state stmt_info pre_trans_result decl_ref ~is_constructor_init + | `CXXMethod | `CXXConversion | `CXXConstructor | `CXXDestructor -> + method_deref_trans trans_state pre_trans_result decl_ref stmt_info decl_kind + | _ -> + CFrontend_config.unimplemented "Decl ref expression %a with pointer %d still needs to be translated" - (Pp.to_string ~f:Clang_ast_j.string_of_decl_kind) decl_kind - decl_ref.Clang_ast_t.dr_decl_pointer + (Pp.to_string ~f:Clang_ast_j.string_of_decl_kind) + decl_kind decl_ref.Clang_ast_t.dr_decl_pointer + and declRefExpr_trans trans_state stmt_info decl_ref_expr_info _ = L.(debug Capture Verbose) @@ -815,29 +858,31 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (string_of_bool (PriorityNode.is_priority_free trans_state)) ; let decl_ref = match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with - | Some dr - -> dr - | None - -> assert false + | Some dr -> + dr + | None -> + assert false in decl_ref_trans trans_state empty_res_trans stmt_info decl_ref ~is_constructor_init:false + (* evaluates an enum constant *) and enum_const_eval context enum_constant_pointer prev_enum_constant_opt zero = match CAst_utils.get_decl enum_constant_pointer with | Some Clang_ast_t.EnumConstantDecl (_, _, _, enum_constant_decl_info) -> ( match enum_constant_decl_info.Clang_ast_t.ecdi_init_expr with - | Some stmt - -> expression_trans context stmt "WARNING: Expression in Enumeration constant not found@\n" + | Some stmt -> + expression_trans context stmt "WARNING: Expression in Enumeration constant not found@\n" | None -> match prev_enum_constant_opt with - | Some prev_constant_pointer - -> let previous_exp = get_enum_constant_expr context prev_constant_pointer in + | Some prev_constant_pointer -> + let previous_exp = get_enum_constant_expr context prev_constant_pointer in CArithmetic_trans.sil_const_plus_one previous_exp - | None - -> zero ) - | _ - -> zero + | None -> + zero ) + | _ -> + zero + (* get the sil value of the enum constant from the map or by evaluating it *) and get_enum_constant_expr context enum_constant_pointer = @@ -847,13 +892,15 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s CAst_utils.get_enum_constant_exp enum_constant_pointer in match sil_exp_opt with - | Some exp - -> exp - | None - -> let exp = enum_const_eval context enum_constant_pointer prev_enum_constant_opt zero in - CAst_utils.update_enum_map enum_constant_pointer exp ; exp + | Some exp -> + exp + | None -> + let exp = enum_const_eval context enum_constant_pointer prev_enum_constant_opt zero in + CAst_utils.update_enum_map enum_constant_pointer exp ; + exp with Not_found -> zero + and enum_constant_trans trans_state decl_ref = let context = trans_state.context in let _, _, qual_type = CAst_utils.get_info_from_decl_ref decl_ref in @@ -861,17 +908,18 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let const_exp = get_enum_constant_expr context decl_ref.Clang_ast_t.dr_decl_pointer in {empty_res_trans with exps= [(const_exp, typ)]} + and arraySubscriptExpr_trans trans_state expr_info stmt_list = let context = trans_state.context in let typ = CType_decl.get_type_from_expr_info expr_info context.tenv in let array_stmt, idx_stmt = match stmt_list with - | [a; i] - -> (a, i) + | [a; i] -> + (a, i) (* Assumption: the statement list contains 2 elements, the first is the array expr and the second the index *) - | _ - -> assert false + | _ -> + assert false (* Let's get notified if the assumption is wrong...*) in let res_trans_a = instruction trans_state array_stmt in @@ -905,6 +953,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s ; exps= [(array_exp, typ)] ; initd_exps= res_trans_idx.initd_exps @ res_trans_a.initd_exps } + and binaryOperator_trans trans_state binary_operator_info stmt_info expr_info stmt_list = let bok = Clang_ast_j.string_of_binary_operator_kind binary_operator_info.Clang_ast_t.boi_kind @@ -922,8 +971,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s CType_decl.qual_type_to_sil_type context.CContext.tenv expr_info.Clang_ast_t.ei_qual_type in match stmt_list with - | [s1; s2] - -> (* Assumption: We expect precisely 2 stmt corresponding to the 2 operands*) + | [s1; s2] -> + (* Assumption: We expect precisely 2 stmt corresponding to the 2 operands*) let rhs_owning_method = CTrans_utils.is_owning_method s2 in (* NOTE: we create a node only if required. In that case this node *) (* becomes the successor of the nodes that may be created when *) @@ -936,8 +985,9 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let trans_state'' = {trans_state' with var_exp_typ= Some (var_exp, var_exp_typ)} in let res_trans_e2 = (* translation of s2 is done taking care of block special case *) - exec_with_block_priority_exception (exec_with_self_exception instruction) trans_state'' - s2 stmt_info + exec_with_block_priority_exception + (exec_with_self_exception instruction) + trans_state'' s2 stmt_info in let sil_e2, _ = extract_exp_from_list res_trans_e2.exps @@ -980,8 +1030,9 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s all_res_trans in {res_trans_to_parent with exps= exp_to_parent} - | _ - -> assert false + | _ -> + assert false + (* Binary operator should have two operands *) and callExpr_trans trans_state si stmt_list expr_info = @@ -1028,10 +1079,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (CTrans_utils.builtin_trans trans_state_pri sil_loc si function_type result_trans_subexprs) with - | Some builtin - -> builtin - | None - -> let is_cf_retain_release = + | Some builtin -> + builtin + | None -> + let is_cf_retain_release = Option.value_map ~f:CTrans_models.is_cf_retain_release ~default:false callee_pname_opt in let act_params = @@ -1047,17 +1098,17 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s params_stmt in let act_params = - if is_cf_retain_release then (Exp.Const (Const.Cint IntLit.one), Typ.mk (Tint Typ.IBool)) - :: act_params + if is_cf_retain_release then + (Exp.Const (Const.Cint IntLit.one), Typ.mk (Tint Typ.IBool)) :: act_params else act_params in let res_trans_call = let cast_trans_fun = cast_trans act_params sil_loc function_type in match Option.bind callee_pname_opt ~f:cast_trans_fun with - | Some (instr, cast_exp) - -> {empty_res_trans with instrs= [instr]; exps= [(cast_exp, function_type)]} - | _ - -> let is_call_to_block = objc_exp_of_type_block fun_exp_stmt in + | Some (instr, cast_exp) -> + {empty_res_trans with instrs= [instr]; exps= [(cast_exp, function_type)]} + | _ -> + let is_call_to_block = objc_exp_of_type_block fun_exp_stmt in let call_flags = {CallFlags.default with CallFlags.cf_is_objc_block= is_call_to_block} in @@ -1073,6 +1124,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s Option.iter ~f:add_cg_edge callee_pname_opt ; {res_trans_to_parent with exps= res_trans_call.exps} + and cxx_method_construct_call_trans trans_state_pri result_trans_callee params_stmt si function_type is_cpp_call_virtual extra_res_trans = let open CContext in @@ -1084,10 +1136,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let sil_method, _ = List.hd_exn result_trans_callee.exps in let callee_pname = match sil_method with - | Exp.Const Const.Cfun pn - -> pn - | _ - -> (* method pointer not implemented, this shouldn't happen but it does (t21762295) *) + | Exp.Const Const.Cfun pn -> + pn + | _ -> + (* method pointer not implemented, this shouldn't happen but it does (t21762295) *) CFrontend_config.incorrect_assumption "Could not resolve CXX method call %a" Exp.pp sil_method in @@ -1102,10 +1154,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (* first expr is method address, rest are params including 'this' parameter *) let actual_params = List.tl_exn (collect_exprs result_trans_subexprs) in match cxx_method_builtin_trans trans_state_pri sil_loc result_trans_subexprs callee_pname with - | Some builtin - -> builtin - | _ - -> let call_flags = {CallFlags.default with CallFlags.cf_virtual= is_cpp_call_virtual} in + | Some builtin -> + builtin + | _ -> + let call_flags = {CallFlags.default with CallFlags.cf_virtual= is_cpp_call_virtual} in let res_trans_call = create_call_instr trans_state_pri function_type sil_method actual_params sil_loc call_flags ~is_objc_method:false @@ -1118,6 +1170,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s Cg.add_edge context.CContext.cg procname callee_pname ; {result_trans_to_parent with exps= res_trans_call.exps} + and cxxMemberCallExpr_trans trans_state si stmt_list expr_info = let context = trans_state.context in (* Structure is the following: *) @@ -1137,6 +1190,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s cxx_method_construct_call_trans trans_state_pri result_trans_callee params_stmt si function_type is_cpp_call_virtual empty_res_trans + and cxxConstructExpr_trans trans_state si params_stmt ei cxx_constr_info = let context = trans_state.context in let trans_state_pri = PriorityNode.try_claim_priority_node trans_state si in @@ -1144,10 +1198,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let decl_ref = cxx_constr_info.Clang_ast_t.xcei_decl_ref in let var_exp, class_type = match trans_state.var_exp_typ with - | Some exp_typ - -> exp_typ - | None - -> let procdesc = trans_state.context.CContext.procdesc in + | Some exp_typ -> + exp_typ + | None -> + let procdesc = trans_state.context.CContext.procdesc in let pvar = Pvar.mk_tmp "__temp_construct_" (Procdesc.get_proc_name procdesc) in let class_type = CType_decl.get_type_from_expr_info ei context.CContext.tenv in Procdesc.append_locals procdesc [(Pvar.get_name pvar, class_type)] ; @@ -1164,10 +1218,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s that class type is translated as pointer type. It gets added here instead. *) let extra_res_trans = match class_type.desc with - | Typ.Tptr _ - -> dereference_value_from_result sil_loc tmp_res_trans ~strip_pointer:false - | _ - -> tmp_res_trans + | Typ.Tptr _ -> + dereference_value_from_result sil_loc tmp_res_trans ~strip_pointer:false + | _ -> + tmp_res_trans in let res_trans_callee = decl_ref_trans trans_state this_res_trans si decl_ref ~is_constructor_init:false @@ -1178,6 +1232,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in {res_trans with exps= extra_res_trans.exps} + and cxx_destructor_call_trans trans_state si this_res_trans class_type_ptr ~is_inner_destructor = (* cxx_method_construct_call_trans claims a priority with the same `si`. New pointer is generated to avoid premature node creation *) @@ -1199,6 +1254,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s is_cpp_call_virtual empty_res_trans else empty_res_trans + and objCMessageExpr_trans_special_cases trans_state si obj_c_message_expr_info method_type trans_state_pri sil_loc act_params = let context = trans_state.context in @@ -1217,24 +1273,25 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s || String.equal selector CFrontend_config.new_str then match receiver_kind with - | `Class qual_type - -> let class_opt = + | `Class qual_type -> + let class_opt = CMethod_trans.get_class_name_method_call_from_clang context.translation_unit_context context.CContext.tenv obj_c_message_expr_info in Some (new_or_alloc_trans trans_state_pri sil_loc si qual_type class_opt selector) - | _ - -> None (* assertions *) + | _ -> + None (* assertions *) else if CTrans_models.is_handleFailureInMethod selector then Some (CTrans_utils.trans_assertion trans_state sil_loc) else None + (* If the first argument of the call is self in a static context, remove it as an argument *) (* and change the call from instance to static *) and objCMessageExpr_deal_with_static_self trans_state_param stmt_list obj_c_message_expr_info = match stmt_list with - | stmt :: rest - -> let obj_c_message_expr_info, fst_res_trans = + | stmt :: rest -> + let obj_c_message_expr_info, fst_res_trans = try let fst_res_trans = instruction trans_state_param stmt in (obj_c_message_expr_info, fst_res_trans) @@ -1249,8 +1306,9 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let instruction' = exec_with_self_exception (exec_with_glvalue_as_reference instruction) in let l = List.map ~f:(instruction' trans_state_param) rest in (obj_c_message_expr_info, fst_res_trans :: l) - | [] - -> (obj_c_message_expr_info, [empty_res_trans]) + | [] -> + (obj_c_message_expr_info, [empty_res_trans]) + and objCMessageExpr_trans trans_state si obj_c_message_expr_info stmt_list expr_info = L.(debug Capture Verbose) @@ -1270,10 +1328,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s objCMessageExpr_trans_special_cases trans_state si obj_c_message_expr_info method_type trans_state_pri sil_loc subexpr_exprs with - | Some res - -> res - | None - -> let procname = Procdesc.get_proc_name context.CContext.procdesc in + | Some res -> + res + | None -> + let procname = Procdesc.get_proc_name context.CContext.procdesc in let callee_name, method_call_type = get_callee_objc_method context obj_c_message_expr_info subexpr_exprs in @@ -1305,11 +1363,13 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in {res_trans_to_parent with exps= res_trans_call.exps} + and dispatch_function_trans trans_state stmt_info stmt_list n = L.(debug Capture Verbose) "@\n Call to a dispatch function treated as special case...@\n" ; let transformed_stmt = Ast_expressions.translate_dispatch_function stmt_info stmt_list n in instruction trans_state transformed_stmt + and block_enumeration_trans trans_state stmt_info stmt_list ei = L.(debug Capture Verbose) "@\n Call to a block enumeration function treated as special case...@\n@." ; @@ -1320,6 +1380,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in instruction trans_state transformed_stmt + and compute_this_for_destructor_calls trans_state stmt_info class_ptr = let context = trans_state.context in let sil_loc = CLocation.get_sil_location stmt_info context in @@ -1335,21 +1396,24 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let this_qual_type = match class_typ.desc with Typ.Tptr (t, _) -> t | _ -> class_typ in (obj_sil, this_qual_type, this_res_trans) + and inject_base_class_destructor_calls trans_state stmt_info bases obj_sil this_qual_type = List.rev_map bases ~f:(fun base -> let this_res_trans_destruct = {empty_res_trans with exps= [(obj_sil, this_qual_type)]} in cxx_destructor_call_trans trans_state stmt_info this_res_trans_destruct base ~is_inner_destructor:true ) + and add_this_instrs_if_result_empty res_trans this_res_trans = let all_res_trans = List.filter ~f:(fun res -> res <> empty_res_trans) res_trans in let all_res_trans = - if all_res_trans <> [] then {empty_res_trans with instrs= this_res_trans.instrs} - :: all_res_trans + if all_res_trans <> [] then + {empty_res_trans with instrs= this_res_trans.instrs} :: all_res_trans else all_res_trans in all_res_trans + and cxx_inject_virtual_base_class_destructors trans_state stmt_info = let context = trans_state.context in if not (CGeneral_utils.is_cpp_translation context.translation_unit_context) then @@ -1377,6 +1441,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s PriorityNode.compute_results_to_parent trans_state_pri sil_loc "Destruction" stmt_info_loc all_res_trans + and cxx_inject_field_destructors_in_destructor_body trans_state stmt_info = let context = trans_state.context in if not (CGeneral_utils.is_cpp_translation context.translation_unit_context) then @@ -1401,13 +1466,13 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info' in let all_res_trans = List.rev_map fields ~f:(function - | Clang_ast_t.FieldDecl ({di_parent_pointer}, {ni_name}, qual_type, _) - -> let class_tname = + | Clang_ast_t.FieldDecl ({di_parent_pointer}, {ni_name}, qual_type, _) -> + let class_tname = match CAst_utils.get_decl_opt di_parent_pointer with - | Some decl - -> CType_decl.get_record_typename ~tenv:context.tenv decl - | _ - -> assert false + | Some decl -> + CType_decl.get_record_typename ~tenv:context.tenv decl + | _ -> + assert false in let field_name = CGeneral_utils.mk_class_field_name class_tname ni_name in let field_exp = Exp.Lfield (obj_sil, field_name, this_qual_type) in @@ -1417,8 +1482,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in cxx_destructor_call_trans trans_state_pri stmt_info_loc this_res_trans_destruct qual_type.Clang_ast_t.qt_type_ptr ~is_inner_destructor:false - | _ - -> assert false ) + | _ -> + assert false ) in let bases_res_trans = inject_base_class_destructor_calls trans_state_pri stmt_info_loc bases obj_sil @@ -1431,6 +1496,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s PriorityNode.compute_results_to_parent trans_state_pri sil_loc "Destruction" stmt_info' all_res_trans + and inject_destructors trans_state stmt_info = let context = trans_state.context in if not (CGeneral_utils.is_cpp_translation context.translation_unit_context) then @@ -1452,32 +1518,34 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let vars_to_destroy = CContext.StmtMap.find_exn map stmt_info.Clang_ast_t.si_pointer in List.map ~f:(function - | Clang_ast_t.VarDecl (_, _, qual_type, _) as decl - -> let pvar = CVar_decl.sil_var_of_decl context decl procname in + | Clang_ast_t.VarDecl (_, _, qual_type, _) as decl -> + let pvar = CVar_decl.sil_var_of_decl context decl procname in let exp = Exp.Lvar pvar in let typ = CType_decl.qual_type_to_sil_type context.CContext.tenv qual_type in let this_res_trans_destruct = {empty_res_trans with exps= [(exp, typ)]} in cxx_destructor_call_trans trans_state_pri stmt_info_loc this_res_trans_destruct qual_type.Clang_ast_t.qt_type_ptr ~is_inner_destructor:false - | _ - -> assert false) + | _ -> + assert false) vars_to_destroy with Not_found -> - L.(debug Capture Verbose) "@\n Variables that go out of scope are not found...@\n@." ; [] + L.(debug Capture Verbose) "@\n Variables that go out of scope are not found...@\n@." ; + [] in let sil_loc = CLocation.get_sil_location stmt_info context in PriorityNode.compute_results_to_parent trans_state_pri sil_loc "Destruction" stmt_info' all_res_trans + and compoundStmt_trans trans_state stmt_info stmt_list = (* Computing destructor call nodes to inject at the end of the compound statement, except if the statement ends with Return statemenent *) let destr_trans_result = match List.last stmt_list with - | Some Clang_ast_t.ReturnStmt _ - -> empty_res_trans - | _ - -> inject_destructors trans_state stmt_info + | Some Clang_ast_t.ReturnStmt _ -> + empty_res_trans + | _ -> + inject_destructors trans_state stmt_info in (* Injecting destructor call nodes at the end of the compound statement *) let succ_nodes = @@ -1487,6 +1555,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let trans_state' = {trans_state with succ_nodes} in instructions trans_state' stmt_list + and conditionalOperator_trans trans_state stmt_info stmt_list expr_info = let context = trans_state.context in let succ_nodes = trans_state.succ_nodes in @@ -1515,8 +1584,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s prune_nodes' in match stmt_list with - | [cond; exp1; exp2] - -> let typ = + | [cond; exp1; exp2] -> + let typ = CType_decl.qual_type_to_sil_type context.CContext.tenv expr_info.Clang_ast_t.ei_qual_type in let var_typ = add_reference_if_glvalue typ expr_info in @@ -1540,15 +1609,16 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s ; instrs ; exps= [(Exp.Var id, typ)] ; initd_exps= [] (* TODO we should get exps from branches+cond *) } - | _ - -> assert false + | _ -> + assert false + (* The GNU extension to the conditional operator which allows the middle operand to be omitted. *) and binaryConditionalOperator_trans trans_state stmt_info stmt_list expr_info = match stmt_list with | [stmt1; ostmt1; ostmt2; stmt2] - when contains_opaque_value_expr ostmt1 && contains_opaque_value_expr ostmt2 - -> let sil_loc = CLocation.get_sil_location stmt_info trans_state.context in + when contains_opaque_value_expr ostmt1 && contains_opaque_value_expr ostmt2 -> + let sil_loc = CLocation.get_sil_location stmt_info trans_state.context in let trans_state_pri = PriorityNode.force_claim_priority_node trans_state stmt_info in let trans_state_cond = {trans_state_pri with continuation= mk_cond_continuation trans_state_pri.continuation} @@ -1569,8 +1639,9 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let root_nodes = init_res_trans'.root_nodes in let root_nodes' = if root_nodes <> [] then root_nodes else op_res_trans.root_nodes in {op_res_trans with root_nodes= root_nodes'} - | _ - -> CFrontend_config.unimplemented "BinaryConditionalOperator not translated" + | _ -> + CFrontend_config.unimplemented "BinaryConditionalOperator not translated" + (* Translate a condition for if/loops statement. It shorts-circuit and/or. *) (* The invariant is that the translation of a condition always contains (at least) *) @@ -1604,10 +1675,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s * she need to change both the codes here and the `match` in * binaryOperator_trans_with_cond *) match cond with - | BinaryOperator (si, ss, ei, boi) - -> binaryOperator_trans trans_state boi si ei ss - | _ - -> instruction trans_state cond + | BinaryOperator (si, ss, ei, boi) -> + binaryOperator_trans trans_state boi si ei ss + | _ -> + instruction trans_state cond else instruction trans_state cond in let e', instrs' = @@ -1644,12 +1715,12 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (* where the control flow goes in case of short circuit *) let prune_to_s2, prune_to_short_c = match binop with - | Binop.LAnd - -> (prune_nodes_t, prune_nodes_f) - | Binop.LOr - -> (prune_nodes_f, prune_nodes_t) - | _ - -> assert false + | Binop.LAnd -> + (prune_nodes_t, prune_nodes_f) + | Binop.LOr -> + (prune_nodes_f, prune_nodes_t) + | _ -> + assert false in List.iter ~f:(fun n -> Procdesc.node_set_succs_exn context.procdesc n res_trans_s2.root_nodes []) @@ -1673,29 +1744,31 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s match cond with | BinaryOperator (_, [s1; s2], _, boi) -> ( match boi.boi_kind with - | `LAnd - -> short_circuit (if negate_cond then Binop.LOr else Binop.LAnd) s1 s2 - | `LOr - -> short_circuit (if negate_cond then Binop.LAnd else Binop.LOr) s1 s2 - | `LT | `GT | `LE | `GE | `EQ | `NE - -> no_short_circuit_cond ~is_cmp:true - | _ - -> no_short_circuit_cond ~is_cmp:false ) - | ParenExpr (_, [s], _) - -> (* condition can be wrapped in parenthesys *) + | `LAnd -> + short_circuit (if negate_cond then Binop.LOr else Binop.LAnd) s1 s2 + | `LOr -> + short_circuit (if negate_cond then Binop.LAnd else Binop.LOr) s1 s2 + | `LT | `GT | `LE | `GE | `EQ | `NE -> + no_short_circuit_cond ~is_cmp:true + | _ -> + no_short_circuit_cond ~is_cmp:false ) + | ParenExpr (_, [s], _) -> + (* condition can be wrapped in parenthesys *) cond_trans ~negate_cond trans_state s - | UnaryOperator (_, [s], _, {uoi_kind= `LNot}) - -> cond_trans ~negate_cond:(not negate_cond) trans_state s - | _ - -> no_short_circuit_cond ~is_cmp:false + | UnaryOperator (_, [s], _, {uoi_kind= `LNot}) -> + cond_trans ~negate_cond:(not negate_cond) trans_state s + | _ -> + no_short_circuit_cond ~is_cmp:false + and declStmt_in_condition_trans trans_state decl_stmt res_trans_cond = match decl_stmt with - | Clang_ast_t.DeclStmt (stmt_info, _, decl_list) - -> let trans_state_decl = {trans_state with succ_nodes= res_trans_cond.root_nodes} in + | Clang_ast_t.DeclStmt (stmt_info, _, decl_list) -> + let trans_state_decl = {trans_state with succ_nodes= res_trans_cond.root_nodes} in declStmt_trans trans_state_decl decl_list stmt_info - | _ - -> res_trans_cond + | _ -> + res_trans_cond + and ifStmt_trans trans_state stmt_info stmt_list = let context = trans_state.context in @@ -1709,11 +1782,11 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let res_trans_b = instruction trans_state' stmt_branch in let nodes_branch = match res_trans_b.root_nodes with - | [] - -> [ create_node (Procdesc.Node.Stmt_node "IfStmt Branch") res_trans_b.instrs sil_loc + | [] -> + [ create_node (Procdesc.Node.Stmt_node "IfStmt Branch") res_trans_b.instrs sil_loc context ] - | _ - -> res_trans_b.root_nodes + | _ -> + res_trans_b.root_nodes in let prune_nodes_t, prune_nodes_f = List.partition_tf ~f:is_true_prune_node prune_nodes in let prune_nodes' = if branch then prune_nodes_t else prune_nodes_f in @@ -1722,8 +1795,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s prune_nodes' in match stmt_list with - | [_; decl_stmt; cond; stmt1; stmt2] - -> (* set the flat to inform that we are translating a condition of a if *) + | [_; decl_stmt; cond; stmt1; stmt2] -> + (* set the flat to inform that we are translating a condition of a if *) let continuation' = mk_cond_continuation trans_state.continuation in let trans_state'' = {trans_state with continuation= continuation'; succ_nodes= []} in let res_trans_cond = cond_trans ~negate_cond:false trans_state'' cond in @@ -1732,8 +1805,9 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s do_branch true stmt1 res_trans_cond.leaf_nodes ; do_branch false stmt2 res_trans_cond.leaf_nodes ; {empty_res_trans with root_nodes= res_trans_decl.root_nodes; leaf_nodes= [join_node]} - | _ - -> assert false + | _ -> + assert false + (* Assumption: the CompoundStmt can be made of different stmts, not just CaseStmts *) and switchStmt_trans trans_state stmt_info switch_stmt_list = @@ -1743,8 +1817,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let sil_loc = CLocation.get_sil_location stmt_info context in let open Clang_ast_t in match switch_stmt_list with - | [_; decl_stmt; cond; (CompoundStmt (stmt_info, stmt_list))] - -> let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in + | [_; decl_stmt; cond; (CompoundStmt (stmt_info, stmt_list))] -> + let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in let trans_state' = {trans_state_pri with succ_nodes= []} in let res_trans_cond_tmp = instruction trans_state' cond in let switch_special_cond_node = @@ -1775,46 +1849,46 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let switch_exit_point = succ_nodes in let continuation' = match continuation with - | Some cont - -> Some {cont with break= switch_exit_point} - | None - -> Some {break= switch_exit_point; continue= []; return_temp= false} + | Some cont -> + Some {cont with break= switch_exit_point} + | None -> + Some {break= switch_exit_point; continue= []; return_temp= false} in let trans_state'' = {trans_state_no_pri with continuation= continuation'} in let merge_into_cases stmt_list = (* returns list_of_cases * before_any_case_instrs *) let rec aux rev_stmt_list acc cases = match rev_stmt_list with - | (CaseStmt (info, a :: b :: (CaseStmt x) :: c)) :: rest - -> (* case x: case y: ... *) + | (CaseStmt (info, a :: b :: (CaseStmt x) :: c)) :: rest -> + (* case x: case y: ... *) if c <> [] (* empty case with nested case, then followed by some instructions *) then assert false ; let rest' = CaseStmt (info, [a; b]) :: rest in let rev_stmt_list' = CaseStmt x :: rest' in aux rev_stmt_list' acc cases - | (CaseStmt (info, a :: b :: (DefaultStmt x) :: c)) :: rest - -> (* case x: default: ... *) + | (CaseStmt (info, a :: b :: (DefaultStmt x) :: c)) :: rest -> + (* case x: default: ... *) if c <> [] (* empty case with nested case, then followed by some instructions *) then assert false ; let rest' = CaseStmt (info, [a; b]) :: rest in let rev_stmt_list' = DefaultStmt x :: rest' in aux rev_stmt_list' acc cases - | (DefaultStmt (info, (CaseStmt x) :: c)) :: rest - -> (* default: case x: ... *) + | (DefaultStmt (info, (CaseStmt x) :: c)) :: rest -> + (* default: case x: ... *) if c <> [] (* empty case with nested case, then followed by some instructions *) then assert false ; let rest' = DefaultStmt (info, []) :: rest in let rev_stmt_list' = CaseStmt x :: rest' in aux rev_stmt_list' acc cases - | (CaseStmt (info, a :: b :: c)) :: rest - -> aux rest [] (CaseStmt (info, a :: b :: c @ acc) :: cases) - | (DefaultStmt (info, c)) :: rest - -> (* default is always the last in the list *) + | (CaseStmt (info, a :: b :: c)) :: rest -> + aux rest [] (CaseStmt (info, a :: b :: c @ acc) :: cases) + | (DefaultStmt (info, c)) :: rest -> + (* default is always the last in the list *) aux rest [] (DefaultStmt (info, c @ acc) :: cases) - | x :: rest - -> aux rest (x :: acc) cases - | [] - -> (cases, acc) + | x :: rest -> + aux rest (x :: acc) cases + | [] -> + (cases, acc) in aux (List.rev stmt_list) [] [] in @@ -1822,10 +1896,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let rec connected_instruction rev_instr_list successor_nodes = (* returns the entry point of the translated set of instr *) match rev_instr_list with - | [] - -> successor_nodes - | instr :: rest - -> let trans_state''' = {trans_state'' with succ_nodes= successor_nodes} in + | [] -> + successor_nodes + | instr :: rest -> + let trans_state''' = {trans_state'' with succ_nodes= successor_nodes} in let res_trans_instr = instruction trans_state''' instr in let instr_entry_points = res_trans_instr.root_nodes in connected_instruction rest instr_entry_points @@ -1833,8 +1907,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let rec translate_and_connect_cases cases next_nodes next_prune_nodes = let create_prune_nodes_for_case case = match case with - | CaseStmt (stmt_info, case_const :: _ :: _) - -> let trans_state_pri = + | CaseStmt (stmt_info, case_const :: _ :: _) -> + let trans_state_pri = PriorityNode.try_claim_priority_node trans_state'' stmt_info in let res_trans_case_const = instruction trans_state_pri case_const in @@ -1853,15 +1927,15 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s Sil.Ik_switch context in (true_prune_node, false_prune_node) - | _ - -> assert false + | _ -> + assert false in match cases with - | (* top-down to handle default cases *) - [] - -> (next_nodes, next_prune_nodes) - | (CaseStmt (_, _ :: _ :: case_content) as case) :: rest - -> let last_nodes, last_prune_nodes = + (* top-down to handle default cases *) + | [] -> + (next_nodes, next_prune_nodes) + | (CaseStmt (_, _ :: _ :: case_content) as case) :: rest -> + let last_nodes, last_prune_nodes = translate_and_connect_cases rest next_nodes next_prune_nodes in let case_entry_point = connected_instruction (List.rev case_content) last_nodes in @@ -1870,8 +1944,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s Procdesc.node_set_succs_exn context.procdesc prune_node_t case_entry_point [] ; Procdesc.node_set_succs_exn context.procdesc prune_node_f last_prune_nodes [] ; (case_entry_point, [prune_node_t; prune_node_f]) - | (DefaultStmt (stmt_info, default_content)) :: rest - -> let sil_loc = CLocation.get_sil_location stmt_info context in + | (DefaultStmt (stmt_info, default_content)) :: rest -> + let sil_loc = CLocation.get_sil_location stmt_info context in let placeholder_entry_point = create_node (Procdesc.Node.Stmt_node "DefaultStmt_placeholder") [] sil_loc context in @@ -1884,8 +1958,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s Procdesc.node_set_succs_exn context.procdesc placeholder_entry_point default_entry_point [] ; (default_entry_point, last_prune_nodes) - | _ - -> assert false + | _ -> + assert false in let top_entry_point, top_prune_nodes = translate_and_connect_cases list_of_cases succ_nodes succ_nodes @@ -1895,13 +1969,14 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let top_nodes = res_trans_decl.root_nodes in (* succ_nodes will remove the temps *) {empty_res_trans with root_nodes= top_nodes; leaf_nodes= succ_nodes} - | _ - -> (* TODO(t21762295) this raises sometimes *) + | _ -> + (* TODO(t21762295) this raises sometimes *) CFrontend_config.incorrect_assumption "Unexpected Switch Statement sub-expression list: [%a]" (Pp.semicolon_seq (Pp.to_string ~f:Clang_ast_j.string_of_stmt)) switch_stmt_list + and stmtExpr_trans trans_state stmt_list = let stmt = extract_stmt_from_singleton stmt_list "ERROR: StmtExpr should have only one statement.@\n" @@ -1910,10 +1985,11 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let res_trans_stmt = instruction trans_state' stmt in let exps' = List.rev res_trans_stmt.exps in match exps' with - | last_exp :: _ - -> {res_trans_stmt with exps= [last_exp]} - | [] - -> res_trans_stmt + | last_exp :: _ -> + {res_trans_stmt with exps= [last_exp]} + | [] -> + res_trans_stmt + and loop_instruction trans_state loop_kind stmt_info = let outer_continuation = trans_state.continuation in @@ -1926,50 +2002,50 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let continuation_cond = mk_cond_continuation outer_continuation in let init_incr_nodes = match loop_kind with - | Loops.For (init, _, _, incr, _) - -> let trans_state' = {trans_state with succ_nodes= [join_node]; continuation} in + | Loops.For (init, _, _, incr, _) -> + let trans_state' = {trans_state with succ_nodes= [join_node]; continuation} in let res_trans_init = instruction trans_state' init in let res_trans_incr = instruction trans_state' incr in Some (res_trans_init.root_nodes, res_trans_incr.root_nodes) - | _ - -> None + | _ -> + None in let cond_stmt = Loops.get_cond loop_kind in let trans_state_cond = {trans_state with continuation= continuation_cond; succ_nodes= []} in let res_trans_cond = cond_trans ~negate_cond:false trans_state_cond cond_stmt in let decl_stmt_opt = match loop_kind with - | Loops.For (_, decl_stmt, _, _, _) - -> Some decl_stmt - | Loops.While (decl_stmt_opt, _, _) - -> decl_stmt_opt - | _ - -> None + | Loops.For (_, decl_stmt, _, _, _) -> + Some decl_stmt + | Loops.While (decl_stmt_opt, _, _) -> + decl_stmt_opt + | _ -> + None in let res_trans_decl = match decl_stmt_opt with - | Some decl_stmt - -> declStmt_in_condition_trans trans_state decl_stmt res_trans_cond - | _ - -> res_trans_cond + | Some decl_stmt -> + declStmt_in_condition_trans trans_state decl_stmt res_trans_cond + | _ -> + res_trans_cond in let body_succ_nodes = match loop_kind with | Loops.For _ -> ( match init_incr_nodes with Some (_, nodes_incr) -> nodes_incr | None -> assert false ) - | Loops.While _ - -> [join_node] - | Loops.DoWhile _ - -> res_trans_cond.root_nodes + | Loops.While _ -> + [join_node] + | Loops.DoWhile _ -> + res_trans_cond.root_nodes in let body_continuation = match (loop_kind, continuation, init_incr_nodes) with - | Loops.DoWhile _, Some c, _ - -> Some {c with continue= res_trans_cond.root_nodes} - | _, Some c, Some (_, nodes_incr) - -> Some {c with continue= nodes_incr} - | _ - -> continuation + | Loops.DoWhile _, Some c, _ -> + Some {c with continue= res_trans_cond.root_nodes} + | _, Some c, Some (_, nodes_incr) -> + Some {c with continue= nodes_incr} + | _ -> + continuation in let res_trans_body = let trans_state_body = @@ -1979,10 +2055,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in let join_succ_nodes = match loop_kind with - | Loops.For _ | Loops.While _ - -> res_trans_decl.root_nodes - | Loops.DoWhile _ - -> res_trans_body.root_nodes + | Loops.For _ | Loops.While _ -> + res_trans_decl.root_nodes + | Loops.DoWhile _ -> + res_trans_body.root_nodes in (* Note: prune nodes are by contruction the res_trans_cond.leaf_nodes *) let prune_nodes_t, prune_nodes_f = @@ -1990,10 +2066,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in let prune_t_succ_nodes = match loop_kind with - | Loops.For _ | Loops.While _ - -> res_trans_body.root_nodes - | Loops.DoWhile _ - -> [join_node] + | Loops.For _ | Loops.While _ -> + res_trans_body.root_nodes + | Loops.DoWhile _ -> + [join_node] in Procdesc.node_set_succs_exn context.procdesc join_node join_succ_nodes [] ; List.iter @@ -2006,23 +2082,27 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s match loop_kind with | Loops.For _ -> ( match init_incr_nodes with Some (nodes_init, _) -> nodes_init | None -> assert false ) - | Loops.While _ | Loops.DoWhile _ - -> [join_node] + | Loops.While _ | Loops.DoWhile _ -> + [join_node] in {empty_res_trans with root_nodes; leaf_nodes= prune_nodes_f} + and forStmt_trans trans_state init decl_stmt cond incr body stmt_info = let for_kind = Loops.For (init, decl_stmt, cond, incr, body) in loop_instruction trans_state for_kind stmt_info + and whileStmt_trans trans_state decl_stmt cond body stmt_info = let while_kind = Loops.While (Some decl_stmt, cond, body) in loop_instruction trans_state while_kind stmt_info + and doStmt_trans trans_state stmt_info cond body = let dowhile_kind = Loops.DoWhile (cond, body) in loop_instruction trans_state dowhile_kind stmt_info + (* Iteration over colection for (v : C) { body; } @@ -2041,16 +2121,17 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s and cxxForRangeStmt_trans trans_state stmt_info stmt_list = let open Clang_ast_t in match stmt_list with - | [iterator_decl; begin_stmt; end_stmt; exit_cond; increment; assign_current_index; loop_body] - -> let loop_body' = CompoundStmt (stmt_info, [assign_current_index; loop_body]) in + | [iterator_decl; begin_stmt; end_stmt; exit_cond; increment; assign_current_index; loop_body] -> + let loop_body' = CompoundStmt (stmt_info, [assign_current_index; loop_body]) in let null_stmt = NullStmt (stmt_info, []) in let beginend_stmt = CompoundStmt (stmt_info, [begin_stmt; end_stmt]) in let for_loop = ForStmt (stmt_info, [beginend_stmt; null_stmt; exit_cond; increment; loop_body']) in instruction trans_state (CompoundStmt (stmt_info, [iterator_decl; for_loop])) - | _ - -> assert false + | _ -> + assert false + (* Fast iteration for colection for (type_it i in collection) { body } @@ -2070,6 +2151,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let loop = Clang_ast_t.WhileStmt (stmt_info, [null_stmt; cond; body']) in instruction trans_state (Clang_ast_t.CompoundStmt (stmt_info, [assign_next_object; loop])) + and initListExpr_array_trans trans_state stmt_info stmts var_exp field_typ = let lh_exp idx = let idx_exp = Exp.Const (Const.Cint (IntLit.of_int idx)) in @@ -2081,37 +2163,40 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (* rest of fields when length(stmts) < size is ignored *) List.mapi ~f:init_field stmts + and initListExpr_struct_trans trans_state stmt_info stmts var_exp var_typ = let context = trans_state.context in let tenv = context.tenv in let tname = match var_typ.Typ.desc with Tstruct tname -> tname | _ -> assert false in let field_exps = match Tenv.lookup tenv tname with - | Some {fields} - -> List.filter_map fields ~f:(fun (fieldname, fieldtype, _) -> + | Some {fields} -> + List.filter_map fields ~f:(fun (fieldname, fieldtype, _) -> if Typ.Fieldname.is_hidden fieldname then None else Some (Exp.Lfield (var_exp, fieldname, var_typ), fieldtype) ) - | None - -> assert false + | None -> + assert false in let init_field field_exp_typ stmt = init_expr_trans trans_state field_exp_typ stmt_info (Some stmt) in match List.map2 field_exps stmts ~f:init_field with - | Ok result - -> result - | Unequal_lengths - -> (* This can happen with union initializers. Skip them for now *) [] + | Ok result -> + result + | Unequal_lengths -> + (* This can happen with union initializers. Skip them for now *) [] + and initListExpr_builtin_trans trans_state stmt_info stmts var_exp var_typ = match stmts with - | [stmt] - -> [init_expr_trans trans_state (var_exp, var_typ) stmt_info (Some stmt)] - | _ - -> CFrontend_config.unimplemented + | [stmt] -> + [init_expr_trans trans_state (var_exp, var_typ) stmt_info (Some stmt)] + | _ -> + CFrontend_config.unimplemented "InitListExpression for var %a type %a with multiple init statements" Exp.pp var_exp (Typ.pp_full Pp.text) var_typ + (** InitListExpr can have following meanings: - initialize all record fields - initialize array @@ -2122,20 +2207,20 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s and initListExpr_trans trans_state stmt_info expr_info stmts = let var_exp, var_typ = match trans_state.var_exp_typ with - | Some var_exp_typ - -> var_exp_typ - | None - -> create_var_exp_tmp_var trans_state expr_info "SIL_init_list__" + | Some var_exp_typ -> + var_exp_typ + | None -> + create_var_exp_tmp_var trans_state expr_info "SIL_init_list__" in if Int.equal (List.length stmts) 0 then (* perform zero initialization of a primitive type, record types will have ImplicitValueInitExpr nodes *) let exps = match Sil.zero_value_of_numerical_type_option var_typ with - | Some zero_exp - -> [(zero_exp, var_typ)] - | None - -> [] + | Some zero_exp -> + [(zero_exp, var_typ)] + | None -> + [] in {empty_res_trans with root_nodes= trans_state.succ_nodes; exps} else @@ -2146,14 +2231,14 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in let all_res_trans = match var_typ.Typ.desc with - | Typ.Tarray (typ_inside, _, _) - -> initListExpr_array_trans trans_state_pri init_stmt_info stmts var_exp typ_inside - | Tstruct _ - -> initListExpr_struct_trans trans_state_pri init_stmt_info stmts var_exp var_typ - | Tint _ | Tfloat _ | Tptr _ - -> initListExpr_builtin_trans trans_state_pri init_stmt_info stmts var_exp var_typ - | _ - -> CFrontend_config.unimplemented "InitListExp for var %a of type %a" Exp.pp var_exp + | Typ.Tarray (typ_inside, _, _) -> + initListExpr_array_trans trans_state_pri init_stmt_info stmts var_exp typ_inside + | Tstruct _ -> + initListExpr_struct_trans trans_state_pri init_stmt_info stmts var_exp var_typ + | Tint _ | Tfloat _ | Tptr _ -> + initListExpr_builtin_trans trans_state_pri init_stmt_info stmts var_exp var_typ + | _ -> + CFrontend_config.unimplemented "InitListExp for var %a of type %a" Exp.pp var_exp (Typ.pp Pp.text) var_typ in let nname = "InitListExp" in @@ -2163,6 +2248,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in {res_trans with exps= [(var_exp, var_typ)]; initd_exps= [var_exp]} + and init_dynamic_array trans_state array_exp_typ array_stmt_info dynlength_stmt_pointer = let dynlength_stmt = Int.Table.find_exn ClangPointers.pointer_stmt_table dynlength_stmt_pointer @@ -2188,6 +2274,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in {res_trans with exps= []} + and init_expr_trans trans_state var_exp_typ ?qual_type var_stmt_info init_expr_opt = match init_expr_opt with | None -> ( @@ -2195,15 +2282,15 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s Option.map ~f:(fun qt -> qt.Clang_ast_t.qt_type_ptr) qual_type |> Option.find_map ~f:CAst_utils.get_type with - | Some Clang_ast_t.VariableArrayType (_, _, stmt_pointer) - -> (* Set the dynamic length of the variable length array. Variable length array cannot + | Some Clang_ast_t.VariableArrayType (_, _, stmt_pointer) -> + (* Set the dynamic length of the variable length array. Variable length array cannot have an initialization expression. *) init_dynamic_array trans_state var_exp_typ var_stmt_info stmt_pointer - | _ - -> (* Nothing to do if no init expression and not a variable length array *) + | _ -> + (* Nothing to do if no init expression and not a variable length array *) {empty_res_trans with root_nodes= trans_state.succ_nodes} ) - | Some ie - -> (*For init expr, translate how to compute it and assign to the var*) + | Some ie -> + (*For init expr, translate how to compute it and assign to the var*) let var_exp, _ = var_exp_typ in let context = trans_state.context in let sil_loc = CLocation.get_sil_location var_stmt_info context in @@ -2249,6 +2336,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in {res_trans with exps= [(var_exp, ie_typ)]} + and collect_all_decl trans_state var_decls next_nodes stmt_info = let open Clang_ast_t in let context = trans_state.context in @@ -2264,10 +2352,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s vdi.Clang_ast_t.vdi_init_expr in match var_decls with - | [] - -> {empty_res_trans with root_nodes= next_nodes} - | (VarDecl (di, n, qt, vdi)) :: var_decls' - -> (* Var are defined when procdesc is created, here we only take care of initialization*) + | [] -> + {empty_res_trans with root_nodes= next_nodes} + | (VarDecl (di, n, qt, vdi)) :: var_decls' -> + (* Var are defined when procdesc is created, here we only take care of initialization*) let res_trans_vd = collect_all_decl trans_state var_decls' next_nodes stmt_info in let res_trans_tmp = do_var_dec (di, n, qt, vdi) res_trans_vd.root_nodes in { empty_res_trans with @@ -2278,14 +2366,16 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s ; initd_exps= res_trans_tmp.initd_exps @ res_trans_vd.initd_exps } | (CXXRecordDecl _) :: var_decls' (*C++/C record decl treated in the same way *) - | (RecordDecl _) :: var_decls' - -> (* Record declaration is done in the beginning when procdesc is defined.*) + | (RecordDecl _) :: var_decls' -> + (* Record declaration is done in the beginning when procdesc is defined.*) collect_all_decl trans_state var_decls' next_nodes stmt_info - | decl :: _ - -> CFrontend_config.incorrect_assumption "unexpected decl type %s in collect_all_decl: %a" - (Clang_ast_proj.get_decl_kind_string decl) (Pp.to_string ~f:Clang_ast_j.string_of_decl) + | decl :: _ -> + CFrontend_config.incorrect_assumption "unexpected decl type %s in collect_all_decl: %a" + (Clang_ast_proj.get_decl_kind_string decl) + (Pp.to_string ~f:Clang_ast_j.string_of_decl) decl + (* stmt_list is ignored because it contains the same instructions as *) (* the init expression. We use the latter info. *) and declStmt_trans trans_state decl_list stmt_info = @@ -2297,36 +2387,39 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (* Case for simple variable declarations*) | (CXXRecordDecl _) :: _ (*C++/C record decl treated in the same way *) - | (RecordDecl _) :: _ - -> (* Case for struct *) + | (RecordDecl _) :: _ -> + (* Case for struct *) collect_all_decl trans_state decl_list succ_nodes stmt_info - | (TypedefDecl _) :: _ | (UsingDirectiveDecl _) :: _ - -> empty_res_trans - | decl :: _ - -> CFrontend_config.unimplemented "In DeclStmt found an unknown declaration type %s" + | (TypedefDecl _) :: _ | (UsingDirectiveDecl _) :: _ -> + empty_res_trans + | decl :: _ -> + CFrontend_config.unimplemented "In DeclStmt found an unknown declaration type %s" (Clang_ast_j.string_of_decl decl) - | [] - -> assert false + | [] -> + assert false in {res_trans with leaf_nodes= []} + and objCPropertyRefExpr_trans trans_state stmt_list = match stmt_list with [stmt] -> instruction trans_state stmt | _ -> assert false + (* For OpaqueValueExpr we return the translation generated from its source expression*) and opaqueValueExpr_trans trans_state opaque_value_expr_info = L.(debug Capture Verbose) " priority node free = '%s'@\n@." (string_of_bool (PriorityNode.is_priority_free trans_state)) ; match trans_state.opaque_exp with - | Some exp - -> {empty_res_trans with exps= [exp]} + | Some exp -> + {empty_res_trans with exps= [exp]} | _ -> match opaque_value_expr_info.Clang_ast_t.ovei_source_expr with - | Some stmt - -> instruction trans_state stmt - | _ - -> assert false + | Some stmt -> + instruction trans_state stmt + | _ -> + assert false + (* NOTE: This translation has several hypothesis. Need to be verified when we have more*) (* experience with this construct. Assert false will help to see if we encounter programs*) @@ -2353,18 +2446,19 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let rec do_semantic_elements el = let open Clang_ast_t in match el with - | (OpaqueValueExpr _) :: el' - -> do_semantic_elements el' - | stmt :: _ - -> instruction trans_state stmt - | _ - -> assert false + | (OpaqueValueExpr _) :: el' -> + do_semantic_elements el' + | stmt :: _ -> + instruction trans_state stmt + | _ -> + assert false in match stmt_list with - | _ :: semantic_form - -> do_semantic_elements semantic_form - | _ - -> assert false + | _ :: semantic_form -> + do_semantic_elements semantic_form + | _ -> + assert false + (* Cast expression are treated the same apart from the cast operation kind*) and cast_exprs_trans trans_state stmt_info stmt_list expr_info cast_expr_info = @@ -2392,6 +2486,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in {res_trans_stmt with instrs= res_trans_stmt.instrs @ cast_inst; exps= [cast_exp]} + (* function used in the computation for both Member_Expr and ObjCIVarRefExpr *) and do_memb_ivar_ref_exp trans_state stmt_info stmt_list decl_ref = let exp_stmt = @@ -2405,16 +2500,19 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let result_trans_exp_stmt = exec_with_glvalue_as_reference instruction trans_state' exp_stmt in decl_ref_trans trans_state result_trans_exp_stmt stmt_info decl_ref ~is_constructor_init:false + and objCIvarRefExpr_trans trans_state stmt_info stmt_list obj_c_ivar_ref_expr_info = let decl_ref = obj_c_ivar_ref_expr_info.Clang_ast_t.ovrei_decl_ref in do_memb_ivar_ref_exp trans_state stmt_info stmt_list decl_ref + and memberExpr_trans trans_state stmt_info stmt_list member_expr_info = let decl_ref = member_expr_info.Clang_ast_t.mei_decl_ref in let res_trans = do_memb_ivar_ref_exp trans_state stmt_info stmt_list decl_ref in let is_virtual_dispatch = member_expr_info.Clang_ast_t.mei_performs_virtual_dispatch in {res_trans with is_cpp_call_virtual= res_trans.is_cpp_call_virtual && is_virtual_dispatch} + and unaryOperator_trans trans_state stmt_info expr_info stmt_list unary_operator_info = let context = trans_state.context in let sil_loc = CLocation.get_sil_location stmt_info context in @@ -2445,6 +2543,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in {res_trans_to_parent with exps= [(exp_op, ret_typ)]} + and returnStmt_trans trans_state stmt_info stmt_list = let context = trans_state.context in let succ_nodes = trans_state.succ_nodes in @@ -2474,18 +2573,19 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s sil_loc context in Procdesc.node_set_succs_exn context.procdesc ret_node - [Procdesc.get_exit_node context.CContext.procdesc] [] ; + [Procdesc.get_exit_node context.CContext.procdesc] + [] ; ret_node in let trans_result = match stmt_list with - | [stmt] - -> (* return exp; *) + | [stmt] -> + (* return exp; *) let ret_type = Procdesc.get_ret_type procdesc in let ret_exp, ret_typ, var_instrs = match context.CContext.return_param_typ with - | Some ret_param_typ - -> let name = CFrontend_config.return_param in + | Some ret_param_typ -> + let name = CFrontend_config.return_param in let pvar = Pvar.mk (Mangled.from_string name) procname in let id = Ident.create_fresh Ident.knormal in let instr = Sil.Load (id, Exp.Lvar pvar, ret_param_typ, sil_loc) in @@ -2493,8 +2593,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s match ret_param_typ.desc with Typ.Tptr (t, _) -> t | _ -> assert false in (Exp.Var id, ret_typ, [instr]) - | None - -> (Exp.Lvar (Procdesc.get_ret_var procdesc), ret_type, []) + | None -> + (Exp.Lvar (Procdesc.get_ret_var procdesc), ret_type, []) in let trans_state' = {trans_state_pri with succ_nodes= []; var_exp_typ= Some (ret_exp, ret_typ)} @@ -2519,18 +2619,19 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s else [ret_node] in {empty_res_trans with root_nodes= root_nodes_to_parent; leaf_nodes= []} - | [] - -> (* return; *) + | [] -> + (* return; *) let ret_node = mk_ret_node [] in {empty_res_trans with root_nodes= [ret_node]; leaf_nodes= []} - | _ - -> L.(debug Capture Verbose) + | _ -> + L.(debug Capture Verbose) "@\nWARNING: Missing translation of Return Expression. Return Statement ignored. Need fixing!@\n" ; {empty_res_trans with root_nodes= succ_nodes} in (* We expect a return with only one expression *) trans_result + (* We analyze the content of the expr. We treat ExprWithCleanups as a wrapper. *) (* It may be that later on (when we treat ARC) some info can be taken from it. *) (* For ParenExpression we translate its body composed by the stmt_list. *) @@ -2542,6 +2643,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in instruction trans_state stmt + and objCBoxedExpr_trans trans_state info sel stmt_info stmts = let typ = CType_decl.class_from_pointer_type trans_state.context.CContext.tenv @@ -2555,6 +2657,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in instruction trans_state message_stmt + and objCArrayLiteral_trans trans_state info stmt_info stmts = let typ = CType_decl.class_from_pointer_type trans_state.context.CContext.tenv @@ -2566,6 +2669,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let message_stmt = Clang_ast_t.ObjCMessageExpr (stmt_info, stmts, info, obj_c_mes_expr_info) in instruction trans_state message_stmt + and objCDictionaryLiteral_trans trans_state info stmt_info stmts = let typ = CType_decl.class_from_pointer_type trans_state.context.CContext.tenv @@ -2583,6 +2687,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in instruction trans_state message_stmt + and objCStringLiteral_trans trans_state stmt_info stmts info = let char_star_typ = Ast_expressions.create_char_star_type ~quals:(Typ.mk_type_quals ~is_const:true ()) () @@ -2601,6 +2706,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in instruction trans_state message_stmt + (** When objects are autoreleased, they get added a flag AUTORELEASE. All these objects will be ignored when checking for memory leaks. When the end of the block autoreleasepool is reached, then those objects are released and the autorelease flag is removed. *) @@ -2621,6 +2727,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let trans_state' = {trans_state with continuation= None; succ_nodes= [call_node]} in instructions trans_state' stmts + (* Assumption: stmt_list contains 2 items, the first can be ObjCMessageExpr or ParenExpr *) (* We ignore this item since we don't deal with the concurrency problem yet *) (* For the same reason we also ignore the stmt_info that @@ -2628,17 +2735,19 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (* Finally we recursively work on the CompoundStmt, the second item of stmt_list *) and objCAtSynchronizedStmt_trans trans_state stmt_list = match stmt_list with - | [_; compound_stmt] - -> instruction trans_state compound_stmt - | _ - -> assert false + | [_; compound_stmt] -> + instruction trans_state compound_stmt + | _ -> + assert false + and blockExpr_trans trans_state stmt_info expr_info decl = let context = trans_state.context in let procname = Procdesc.get_proc_name context.CContext.procdesc in let loc = - match stmt_info.Clang_ast_t.si_source_range - with l1, _ -> CLocation.clang_to_sil_location context.CContext.translation_unit_context l1 + match stmt_info.Clang_ast_t.si_source_range with + | l1, _ -> + CLocation.clang_to_sil_location context.CContext.translation_unit_context l1 in (* Given a captured var, return the instruction to assign it to a temp *) let assign_captured_var (cvar, typ) = @@ -2647,8 +2756,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (id, instr) in match decl with - | Clang_ast_t.BlockDecl (_, block_decl_info) - -> let open CContext in + | Clang_ast_t.BlockDecl (_, block_decl_info) -> + let open CContext in let qual_type = expr_info.Clang_ast_t.ei_qual_type in let block_pname = CProcname.mk_fresh_block_procname procname in let typ = CType_decl.qual_type_to_sil_type context.tenv qual_type in @@ -2671,8 +2780,9 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let captured_static_vars = captureds @ static_vars in let alloc_block_instr = allocate_block trans_state block_name captured_static_vars loc in {empty_res_trans with instrs= alloc_block_instr @ instrs; exps= [(closure, typ)]} - | _ - -> assert false + | _ -> + assert false + and lambdaExpr_trans trans_state stmt_info expr_info {Clang_ast_t.lei_lambda_decl} = let open CContext in @@ -2691,27 +2801,27 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in let translate_capture_init (pvar, typ) init_decl = match init_decl with - | Clang_ast_t.VarDecl (_, _, _, {vdi_init_expr}) - -> init_expr_trans trans_state (Exp.Lvar pvar, typ) stmt_info vdi_init_expr - | _ - -> L.die ExternalError "Unexpected: capture-init statement without var decl" + | Clang_ast_t.VarDecl (_, _, _, {vdi_init_expr}) -> + init_expr_trans trans_state (Exp.Lvar pvar, typ) stmt_info vdi_init_expr + | _ -> + L.die ExternalError "Unexpected: capture-init statement without var decl" in let translate_captured {Clang_ast_t.lci_captured_var; lci_init_captured_vardecl} - (trans_results_acc, captured_vars_acc as acc) = + ((trans_results_acc, captured_vars_acc) as acc) = match (lci_captured_var, lci_init_captured_vardecl) with - | Some captured_var_decl_ref, Some init_decl - -> (* capture and init *) + | Some captured_var_decl_ref, Some init_decl -> + (* capture and init *) let pvar_typ = get_captured_pvar_typ captured_var_decl_ref in ( translate_capture_init pvar_typ init_decl :: trans_results_acc , make_captured_tuple pvar_typ :: captured_vars_acc ) - | Some captured_var_decl_ref, None - -> (* just capture *) + | Some captured_var_decl_ref, None -> + (* just capture *) let pvar_typ = get_captured_pvar_typ captured_var_decl_ref in (trans_results_acc, make_captured_tuple pvar_typ :: captured_vars_acc) - | None, None - -> acc - | None, Some _ - -> L.die InternalError "Capture-init with init, but no capture" + | None, None -> + acc + | None, Some _ -> + L.die InternalError "Capture-init with init, but no capture" in let lei_captures = CMethod_trans.get_captures_from_cpp_lambda lei_lambda_decl in let trans_results, captured_vars = @@ -2721,6 +2831,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let closure = Exp.Closure {name= lambda_pname; captured_vars} in {final_trans_result with exps= [(closure, typ)]} + and cxxNewExpr_trans trans_state stmt_info stmt_list expr_info cxx_new_expr_info = let instructions_trans_result = instructions trans_state stmt_list in let context = trans_state.context in @@ -2732,16 +2843,16 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s if is_dyn_array then match CAst_utils.get_stmt_opt cxx_new_expr_info.Clang_ast_t.xnei_array_size_expr with | Some stmt - -> ( + -> ( let trans_state_size = {trans_state_pri with succ_nodes= []} in let res_trans_size = instruction trans_state_size stmt in match res_trans_size.exps with - | [(exp, _)] - -> (Some exp, res_trans_size) - | _ - -> (None, empty_res_trans) ) - | None - -> (Some (Exp.Const (Const.Cint IntLit.minus_one)), empty_res_trans) + | [(exp, _)] -> + (Some exp, res_trans_size) + | _ -> + (None, empty_res_trans) ) + | None -> + (Some (Exp.Const (Const.Cint IntLit.minus_one)), empty_res_trans) else (None, empty_res_trans) in let res_trans_new = cpp_new_trans sil_loc typ size_exp_opt in @@ -2749,13 +2860,13 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let trans_state_init = {trans_state_pri with succ_nodes= []} in let var_exp_typ = match res_trans_new.exps with - | [(var_exp, ({desc= Tptr (t, _)} as var_typ))] when is_dyn_array - -> (* represent dynamic array as Tarray *) + | [(var_exp, ({desc= Tptr (t, _)} as var_typ))] when is_dyn_array -> + (* represent dynamic array as Tarray *) (var_exp, Typ.mk ~default:var_typ (Typ.Tarray (t, None, None))) - | [(var_exp, {desc= Tptr (t, _)})] when not is_dyn_array - -> (var_exp, t) - | _ - -> assert false + | [(var_exp, {desc= Tptr (t, _)})] when not is_dyn_array -> + (var_exp, t) + | _ -> + assert false in (* Need a new stmt_info for the translation of the initializer, so that it can create nodes *) (* if it needs to, with the same stmt_info it doesn't work. *) @@ -2764,24 +2875,24 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in let res_trans_init = match stmt_opt with - | Some InitListExpr _ - -> [init_expr_trans trans_state_init var_exp_typ init_stmt_info stmt_opt] - | _ when is_dyn_array && Typ.is_pointer_to_cpp_class typ - -> (* NOTE: this is heuristic to initialize C++ objects when the size of dynamic + | Some InitListExpr _ -> + [init_expr_trans trans_state_init var_exp_typ init_stmt_info stmt_opt] + | _ when is_dyn_array && Typ.is_pointer_to_cpp_class typ -> + (* NOTE: this is heuristic to initialize C++ objects when the size of dynamic array is constant, it doesn't do anything for non-const lengths, it should be translated as a loop *) let rec create_stmts stmt_opt size_exp_opt = match (stmt_opt, size_exp_opt) with - | Some stmt, Some Exp.Const Const.Cint n when not (IntLit.iszero n) - -> let n_minus_1 = Some (Exp.Const (Const.Cint (IntLit.sub n IntLit.one))) in + | Some stmt, Some Exp.Const Const.Cint n when not (IntLit.iszero n) -> + let n_minus_1 = Some (Exp.Const (Const.Cint (IntLit.sub n IntLit.one))) in stmt :: create_stmts stmt_opt n_minus_1 - | _ - -> [] + | _ -> + [] in let stmts = create_stmts stmt_opt size_exp_opt in let var_exp, var_typ = var_exp_typ in initListExpr_array_trans trans_state_init init_stmt_info stmts var_exp var_typ - | _ - -> [init_expr_trans trans_state_init var_exp_typ init_stmt_info stmt_opt] + | _ -> + [init_expr_trans trans_state_init var_exp_typ init_stmt_info stmt_opt] in let all_res_trans = [res_trans_size; res_trans_new] @ res_trans_init in let nname = "CXXNewExpr" in @@ -2791,6 +2902,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s collect_res_trans context.CContext.procdesc [instructions_trans_result; {result_trans_to_parent with exps= res_trans_new.exps}] + and cxxDeleteExpr_trans trans_state stmt_info stmt_list delete_expr_info = let context = trans_state.context in let sil_loc = CLocation.get_sil_location stmt_info context in @@ -2833,6 +2945,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in {res_trans with exps= []} + and materializeTemporaryExpr_trans trans_state stmt_info stmt_list expr_info = let context = trans_state.context in let procdesc = context.CContext.procdesc in @@ -2848,6 +2961,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s Procdesc.append_locals procdesc [(Pvar.get_name pvar, typ)] ; res_trans + and compoundLiteralExpr_trans trans_state stmt_list expr_info = let stmt = match stmt_list with [stmt] -> stmt | _ -> assert false in let var_exp_typ = @@ -2857,6 +2971,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let trans_state' = {trans_state with var_exp_typ} in instruction trans_state' stmt + and cxxDynamicCastExpr_trans trans_state stmt_info stmts cast_qual_type = let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in let trans_state' = {trans_state_pri with succ_nodes= []} in @@ -2867,10 +2982,10 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let cast_type = CType_decl.qual_type_to_sil_type tenv cast_qual_type in let sizeof_expr = match cast_type.desc with - | Typ.Tptr (typ, _) - -> Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype} - | _ - -> assert false + | Typ.Tptr (typ, _) -> + Exp.Sizeof {typ; nbytes= None; dynamic_length= None; subtype} + | _ -> + assert false in let builtin = Exp.Const (Const.Cfun BuiltinDecl.__cast) in let stmt = match stmts with [stmt] -> stmt | _ -> assert false in @@ -2888,12 +3003,14 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in {res_trans_to_parent with exps= [(res_ex, cast_type)]} + and cxxDefaultExpr_trans trans_state default_expr_info = match default_expr_info.Clang_ast_t.xdaei_init_expr with - | Some exp - -> instruction trans_state exp - | None - -> assert false + | Some exp -> + instruction trans_state exp + | None -> + assert false + and call_function_with_args instr_name pname trans_state stmt_info stmts = let sil_loc = CLocation.get_sil_location stmt_info trans_state.context in @@ -2913,17 +3030,21 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in {res_trans_to_parent with exps= res_trans_call.exps} + and gccAsmStmt_trans trans_state = let pname = Typ.Procname.from_string_c_fun CFrontend_config.infer_skip_gcc_asm_stmt in call_function_with_args "GCCAsmStmt" pname trans_state + and objc_cxx_throw_trans trans_state = call_function_with_args "ObjCCPPThrow" BuiltinDecl.objc_cpp_throw trans_state + and cxxPseudoDestructorExpr_trans () = let fun_name = Typ.Procname.from_string_c_fun CFrontend_config.infer_skip_fun in {empty_res_trans with exps= [(Exp.Const (Const.Cfun fun_name), Typ.mk Tvoid)]} + and cxxTypeidExpr_trans trans_state stmt_info stmts expr_info = let tenv = trans_state.context.CContext.tenv in let typ = CType_decl.get_type_from_expr_info expr_info tenv in @@ -2931,11 +3052,11 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let trans_state_pri = PriorityNode.try_claim_priority_node trans_state stmt_info in let res_trans_subexpr = match stmts with - | [stmt] - -> let trans_state_param = {trans_state_pri with succ_nodes= []} in + | [stmt] -> + let trans_state_param = {trans_state_pri with succ_nodes= []} in instruction trans_state_param stmt - | _ - -> empty_res_trans + | _ -> + empty_res_trans in let fun_name = BuiltinDecl.__cxx_typeid in let sil_fun = Exp.Const (Const.Cfun fun_name) in @@ -2960,6 +3081,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in {res_trans_to_parent with exps= res_trans_call.exps} + and cxxStdInitializerListExpr_trans trans_state stmt_info stmts expr_info = let context = trans_state.context in let tenv = context.CContext.tenv in @@ -2982,6 +3104,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in {res_trans_to_parent with exps= res_trans_call.exps} + and objCBridgedCastExpr_trans trans_state stmts expr_info = let stmt = extract_stmt_from_singleton stmts "" in let tenv = trans_state.context.CContext.tenv in @@ -2989,58 +3112,66 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let trans_state' = {trans_state with obj_bridged_cast_typ= Some typ} in instruction trans_state' stmt + and binaryOperator_trans_with_cond trans_state stmt_info stmt_list expr_info binop_info = let open Clang_ast_t in match binop_info.boi_kind with - | `LAnd | `LOr | `LT | `GT | `LE | `GE | `EQ | `NE - -> (* For LAnd/LOr/comparison operators we compiles a binary expression bo into an semantic + | `LAnd | `LOr | `LT | `GT | `LE | `GE | `EQ | `NE -> + (* For LAnd/LOr/comparison operators we compiles a binary expression bo into an semantic equivalent conditional operator 'bo ? 1:0'. The conditional operator takes care of shortcircuit when/where needed *) let bo = BinaryOperator (stmt_info, stmt_list, expr_info, binop_info) in let cond = Ast_expressions.trans_with_conditional stmt_info expr_info [bo] in instruction trans_state cond - | _ - -> binaryOperator_trans trans_state binop_info stmt_info expr_info stmt_list + | _ -> + binaryOperator_trans trans_state binop_info stmt_info expr_info stmt_list + and attributedStmt_trans trans_state stmts attrs = let open Clang_ast_t in match (stmts, attrs) with | [stmt], [attr] -> ( match (stmt, attr) with - | NullStmt _, FallThroughAttr _ - -> no_op_trans trans_state.succ_nodes - | _ - -> CFrontend_config.unimplemented + | NullStmt _, FallThroughAttr _ -> + no_op_trans trans_state.succ_nodes + | _ -> + CFrontend_config.unimplemented "attributedStmt [stmt] [attr] with:@\nstmt=%s@\nattr=%s@\n" - (Clang_ast_j.string_of_stmt stmt) (Clang_ast_j.string_of_attribute attr) ) - | _ - -> CFrontend_config.unimplemented "attributedStmt with:@\nstmts=[%a]@\nattrs=[%a]@\n" + (Clang_ast_j.string_of_stmt stmt) + (Clang_ast_j.string_of_attribute attr) ) + | _ -> + CFrontend_config.unimplemented "attributedStmt with:@\nstmts=[%a]@\nattrs=[%a]@\n" (Pp.semicolon_seq (Pp.to_string ~f:Clang_ast_j.string_of_stmt)) stmts (Pp.semicolon_seq (Pp.to_string ~f:Clang_ast_j.string_of_attribute)) attrs + and breakStmt_trans trans_state stmt_info = match trans_state.continuation with - | Some bn - -> let trans_state' = {trans_state with succ_nodes= bn.break} in + | Some bn -> + let trans_state' = {trans_state with succ_nodes= bn.break} in let destr_trans_result = inject_destructors trans_state' stmt_info in if destr_trans_result.root_nodes <> [] then destr_trans_result else {empty_res_trans with root_nodes= bn.break} - | _ (* t21762295 *) - -> CFrontend_config.incorrect_assumption "Break stmt without continuation: %a" - (Pp.to_string ~f:Clang_ast_j.string_of_stmt_info) stmt_info + | _ (* t21762295 *) -> + CFrontend_config.incorrect_assumption "Break stmt without continuation: %a" + (Pp.to_string ~f:Clang_ast_j.string_of_stmt_info) + stmt_info + and continueStmt_trans trans_state stmt_info = match trans_state.continuation with - | Some bn - -> let trans_state' = {trans_state with succ_nodes= bn.continue} in + | Some bn -> + let trans_state' = {trans_state with succ_nodes= bn.continue} in let destr_trans_result = inject_destructors trans_state' stmt_info in if destr_trans_result.root_nodes <> [] then destr_trans_result else {empty_res_trans with root_nodes= bn.continue} - | _ (* t21762295 *) - -> CFrontend_config.incorrect_assumption "Continue stmt without continuation: %a" - (Pp.to_string ~f:Clang_ast_j.string_of_stmt_info) stmt_info + | _ (* t21762295 *) -> + CFrontend_config.incorrect_assumption "Continue stmt without continuation: %a" + (Pp.to_string ~f:Clang_ast_j.string_of_stmt_info) + stmt_info + (* Expect that this doesn't happen *) and trans_into_undefined_expr trans_state expr_info = @@ -3048,6 +3179,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let typ = CType_decl.get_type_from_expr_info expr_info tenv in {empty_res_trans with exps= [(CTrans_utils.undefined_expression (), typ)]} + (* no-op translated for unsupported instructions that will at least translate subexpressions *) and skip_unimplemented trans_state stmts = instructions trans_state stmts @@ -3061,105 +3193,106 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s L.(debug Capture Verbose) "@\nPassing from %s '%d' @\n" stmt_kind stmt_pointer ; let open Clang_ast_t in match instr with - | GotoStmt (stmt_info, _, {Clang_ast_t.gsi_label= label_name; _}) - -> gotoStmt_trans trans_state stmt_info label_name - | LabelStmt (stmt_info, stmt_list, label_name) - -> labelStmt_trans trans_state stmt_info stmt_list label_name - | ArraySubscriptExpr (_, stmt_list, expr_info) - -> arraySubscriptExpr_trans trans_state expr_info stmt_list - | BinaryOperator (stmt_info, stmt_list, expr_info, binop_info) - -> binaryOperator_trans_with_cond trans_state stmt_info stmt_list expr_info binop_info + | GotoStmt (stmt_info, _, {Clang_ast_t.gsi_label= label_name; _}) -> + gotoStmt_trans trans_state stmt_info label_name + | LabelStmt (stmt_info, stmt_list, label_name) -> + labelStmt_trans trans_state stmt_info stmt_list label_name + | ArraySubscriptExpr (_, stmt_list, expr_info) -> + arraySubscriptExpr_trans trans_state expr_info stmt_list + | BinaryOperator (stmt_info, stmt_list, expr_info, binop_info) -> + binaryOperator_trans_with_cond trans_state stmt_info stmt_list expr_info binop_info | CallExpr (stmt_info, stmt_list, ei) -> ( match is_dispatch_function stmt_list with - | Some block_arg_pos - -> dispatch_function_trans trans_state stmt_info stmt_list block_arg_pos - | None - -> callExpr_trans trans_state stmt_info stmt_list ei ) - | CXXMemberCallExpr (stmt_info, stmt_list, ei) - -> cxxMemberCallExpr_trans trans_state stmt_info stmt_list ei - | CXXOperatorCallExpr (stmt_info, stmt_list, ei) - -> callExpr_trans trans_state stmt_info stmt_list ei + | Some block_arg_pos -> + dispatch_function_trans trans_state stmt_info stmt_list block_arg_pos + | None -> + callExpr_trans trans_state stmt_info stmt_list ei ) + | CXXMemberCallExpr (stmt_info, stmt_list, ei) -> + cxxMemberCallExpr_trans trans_state stmt_info stmt_list ei + | CXXOperatorCallExpr (stmt_info, stmt_list, ei) -> + callExpr_trans trans_state stmt_info stmt_list ei | CXXConstructExpr (stmt_info, stmt_list, expr_info, cxx_constr_info) - | CXXTemporaryObjectExpr (stmt_info, stmt_list, expr_info, cxx_constr_info) - -> cxxConstructExpr_trans trans_state stmt_info stmt_list expr_info cxx_constr_info - | ObjCMessageExpr (stmt_info, stmt_list, expr_info, obj_c_message_expr_info) - -> if is_block_enumerate_function obj_c_message_expr_info then + | CXXTemporaryObjectExpr (stmt_info, stmt_list, expr_info, cxx_constr_info) -> + cxxConstructExpr_trans trans_state stmt_info stmt_list expr_info cxx_constr_info + | ObjCMessageExpr (stmt_info, stmt_list, expr_info, obj_c_message_expr_info) -> + if is_block_enumerate_function obj_c_message_expr_info then block_enumeration_trans trans_state stmt_info stmt_list expr_info else objCMessageExpr_trans trans_state stmt_info obj_c_message_expr_info stmt_list expr_info - | CompoundStmt (stmt_info, stmt_list) - -> (* No node for this statement. We just collect its statement list*) + | CompoundStmt (stmt_info, stmt_list) -> + (* No node for this statement. We just collect its statement list*) compoundStmt_trans trans_state stmt_info stmt_list - | ConditionalOperator (stmt_info, stmt_list, expr_info) - -> (* Ternary operator "cond ? exp1 : exp2" *) + | ConditionalOperator (stmt_info, stmt_list, expr_info) -> + (* Ternary operator "cond ? exp1 : exp2" *) conditionalOperator_trans trans_state stmt_info stmt_list expr_info - | IfStmt (stmt_info, stmt_list) - -> ifStmt_trans trans_state stmt_info stmt_list - | SwitchStmt (stmt_info, switch_stmt_list) - -> switchStmt_trans trans_state stmt_info switch_stmt_list - | CaseStmt _ - -> (* where do we even get case stmts outside of the switch stmt? (t21762295) *) + | IfStmt (stmt_info, stmt_list) -> + ifStmt_trans trans_state stmt_info stmt_list + | SwitchStmt (stmt_info, switch_stmt_list) -> + switchStmt_trans trans_state stmt_info switch_stmt_list + | CaseStmt _ -> + (* where do we even get case stmts outside of the switch stmt? (t21762295) *) CFrontend_config.incorrect_assumption "Case statement outside of switch statement: %a" - (Pp.to_string ~f:Clang_ast_j.string_of_stmt) instr - | StmtExpr (_, stmt_list, _) - -> stmtExpr_trans trans_state stmt_list - | ForStmt (stmt_info, [init; decl_stmt; cond; incr; body]) - -> forStmt_trans trans_state init decl_stmt cond incr body stmt_info - | WhileStmt (stmt_info, [decl_stmt; cond; body]) - -> whileStmt_trans trans_state decl_stmt cond body stmt_info - | DoStmt (stmt_info, [body; cond]) - -> doStmt_trans trans_state stmt_info cond body - | CXXForRangeStmt (stmt_info, stmt_list) - -> cxxForRangeStmt_trans trans_state stmt_info stmt_list - | ObjCForCollectionStmt (stmt_info, [item; items; body]) - -> objCForCollectionStmt_trans trans_state item items body stmt_info - | NullStmt _ - -> no_op_trans trans_state.succ_nodes - | CompoundAssignOperator (stmt_info, stmt_list, expr_info, binary_operator_info, _) - -> binaryOperator_trans trans_state binary_operator_info stmt_info expr_info stmt_list - | DeclStmt (stmt_info, _, decl_list) - -> declStmt_trans trans_state decl_list stmt_info - | DeclRefExpr (stmt_info, _, _, decl_ref_expr_info) as d - -> declRefExpr_trans trans_state stmt_info decl_ref_expr_info d - | ObjCPropertyRefExpr (_, stmt_list, _, _) - -> objCPropertyRefExpr_trans trans_state stmt_list - | CXXThisExpr (stmt_info, _, expr_info) - -> cxxThisExpr_trans trans_state stmt_info expr_info - | OpaqueValueExpr (_, _, _, opaque_value_expr_info) - -> opaqueValueExpr_trans trans_state opaque_value_expr_info - | PseudoObjectExpr (_, stmt_list, _) - -> pseudoObjectExpr_trans trans_state stmt_list - | UnaryExprOrTypeTraitExpr (_, _, expr_info, ei) - -> unaryExprOrTypeTraitExpr_trans trans_state expr_info ei - | ObjCBridgedCastExpr (_, stmt_list, expr_info, _, _) - -> objCBridgedCastExpr_trans trans_state stmt_list expr_info + (Pp.to_string ~f:Clang_ast_j.string_of_stmt) + instr + | StmtExpr (_, stmt_list, _) -> + stmtExpr_trans trans_state stmt_list + | ForStmt (stmt_info, [init; decl_stmt; cond; incr; body]) -> + forStmt_trans trans_state init decl_stmt cond incr body stmt_info + | WhileStmt (stmt_info, [decl_stmt; cond; body]) -> + whileStmt_trans trans_state decl_stmt cond body stmt_info + | DoStmt (stmt_info, [body; cond]) -> + doStmt_trans trans_state stmt_info cond body + | CXXForRangeStmt (stmt_info, stmt_list) -> + cxxForRangeStmt_trans trans_state stmt_info stmt_list + | ObjCForCollectionStmt (stmt_info, [item; items; body]) -> + objCForCollectionStmt_trans trans_state item items body stmt_info + | NullStmt _ -> + no_op_trans trans_state.succ_nodes + | CompoundAssignOperator (stmt_info, stmt_list, expr_info, binary_operator_info, _) -> + binaryOperator_trans trans_state binary_operator_info stmt_info expr_info stmt_list + | DeclStmt (stmt_info, _, decl_list) -> + declStmt_trans trans_state decl_list stmt_info + | DeclRefExpr (stmt_info, _, _, decl_ref_expr_info) as d -> + declRefExpr_trans trans_state stmt_info decl_ref_expr_info d + | ObjCPropertyRefExpr (_, stmt_list, _, _) -> + objCPropertyRefExpr_trans trans_state stmt_list + | CXXThisExpr (stmt_info, _, expr_info) -> + cxxThisExpr_trans trans_state stmt_info expr_info + | OpaqueValueExpr (_, _, _, opaque_value_expr_info) -> + opaqueValueExpr_trans trans_state opaque_value_expr_info + | PseudoObjectExpr (_, stmt_list, _) -> + pseudoObjectExpr_trans trans_state stmt_list + | UnaryExprOrTypeTraitExpr (_, _, expr_info, ei) -> + unaryExprOrTypeTraitExpr_trans trans_state expr_info ei + | ObjCBridgedCastExpr (_, stmt_list, expr_info, _, _) -> + objCBridgedCastExpr_trans trans_state stmt_list expr_info | ImplicitCastExpr (stmt_info, stmt_list, expr_info, cast_kind) | CStyleCastExpr (stmt_info, stmt_list, expr_info, cast_kind, _) | CXXReinterpretCastExpr (stmt_info, stmt_list, expr_info, cast_kind, _, _) | CXXConstCastExpr (stmt_info, stmt_list, expr_info, cast_kind, _, _) | CXXStaticCastExpr (stmt_info, stmt_list, expr_info, cast_kind, _, _) - | CXXFunctionalCastExpr (stmt_info, stmt_list, expr_info, cast_kind, _) - -> cast_exprs_trans trans_state stmt_info stmt_list expr_info cast_kind - | IntegerLiteral (_, _, expr_info, integer_literal_info) - -> integerLiteral_trans trans_state expr_info integer_literal_info - | StringLiteral (_, _, expr_info, str_list) - -> stringLiteral_trans trans_state expr_info (String.concat ~sep:"" str_list) - | GNUNullExpr (_, _, expr_info) - -> gNUNullExpr_trans trans_state expr_info - | CXXNullPtrLiteralExpr (_, _, expr_info) - -> nullPtrExpr_trans trans_state expr_info - | ObjCSelectorExpr (_, _, expr_info, selector) - -> objCSelectorExpr_trans trans_state expr_info selector - | ObjCEncodeExpr (_, _, expr_info, objc_encode_expr_info) - -> objCEncodeExpr_trans trans_state expr_info objc_encode_expr_info - | ObjCProtocolExpr (_, _, expr_info, decl_ref) - -> objCProtocolExpr_trans trans_state expr_info decl_ref - | ObjCIvarRefExpr (stmt_info, stmt_list, _, obj_c_ivar_ref_expr_info) - -> objCIvarRefExpr_trans trans_state stmt_info stmt_list obj_c_ivar_ref_expr_info - | MemberExpr (stmt_info, stmt_list, _, member_expr_info) - -> memberExpr_trans trans_state stmt_info stmt_list member_expr_info - | UnaryOperator (stmt_info, stmt_list, expr_info, unary_operator_info) - -> if is_logical_negation_of_int trans_state.context.CContext.tenv expr_info + | CXXFunctionalCastExpr (stmt_info, stmt_list, expr_info, cast_kind, _) -> + cast_exprs_trans trans_state stmt_info stmt_list expr_info cast_kind + | IntegerLiteral (_, _, expr_info, integer_literal_info) -> + integerLiteral_trans trans_state expr_info integer_literal_info + | StringLiteral (_, _, expr_info, str_list) -> + stringLiteral_trans trans_state expr_info (String.concat ~sep:"" str_list) + | GNUNullExpr (_, _, expr_info) -> + gNUNullExpr_trans trans_state expr_info + | CXXNullPtrLiteralExpr (_, _, expr_info) -> + nullPtrExpr_trans trans_state expr_info + | ObjCSelectorExpr (_, _, expr_info, selector) -> + objCSelectorExpr_trans trans_state expr_info selector + | ObjCEncodeExpr (_, _, expr_info, objc_encode_expr_info) -> + objCEncodeExpr_trans trans_state expr_info objc_encode_expr_info + | ObjCProtocolExpr (_, _, expr_info, decl_ref) -> + objCProtocolExpr_trans trans_state expr_info decl_ref + | ObjCIvarRefExpr (stmt_info, stmt_list, _, obj_c_ivar_ref_expr_info) -> + objCIvarRefExpr_trans trans_state stmt_info stmt_list obj_c_ivar_ref_expr_info + | MemberExpr (stmt_info, stmt_list, _, member_expr_info) -> + memberExpr_trans trans_state stmt_info stmt_list member_expr_info + | UnaryOperator (stmt_info, stmt_list, expr_info, unary_operator_info) -> + if is_logical_negation_of_int trans_state.context.CContext.tenv expr_info unary_operator_info then let conditional = @@ -3167,126 +3300,129 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in instruction trans_state conditional else unaryOperator_trans trans_state stmt_info expr_info stmt_list unary_operator_info - | ReturnStmt (stmt_info, stmt_list) - -> returnStmt_trans trans_state stmt_info stmt_list + | ReturnStmt (stmt_info, stmt_list) -> + returnStmt_trans trans_state stmt_info stmt_list (* We analyze the content of the expr. We treat ExprWithCleanups as a wrapper. *) (* It may be that later on (when we treat ARC) some info can be taken from it. *) | ExprWithCleanups (_, stmt_list, _, _) - | ParenExpr (_, stmt_list, _) - -> parenExpr_trans trans_state stmt_list + | ParenExpr (_, stmt_list, _) -> + parenExpr_trans trans_state stmt_list | ObjCBoolLiteralExpr (_, _, expr_info, n) | CharacterLiteral (_, _, expr_info, n) - | CXXBoolLiteralExpr (_, _, expr_info, n) - -> characterLiteral_trans trans_state expr_info n - | FloatingLiteral (_, _, expr_info, float_string) - -> floatingLiteral_trans trans_state expr_info float_string - | CXXScalarValueInitExpr (_, _, expr_info) - -> cxxScalarValueInitExpr_trans trans_state expr_info + | CXXBoolLiteralExpr (_, _, expr_info, n) -> + characterLiteral_trans trans_state expr_info n + | FloatingLiteral (_, _, expr_info, float_string) -> + floatingLiteral_trans trans_state expr_info float_string + | CXXScalarValueInitExpr (_, _, expr_info) -> + cxxScalarValueInitExpr_trans trans_state expr_info | ObjCBoxedExpr (stmt_info, stmts, info, boxed_expr_info) -> ( match boxed_expr_info.Clang_ast_t.obei_boxing_method with - | Some sel - -> objCBoxedExpr_trans trans_state info sel stmt_info stmts - | None - -> assert false ) - | ObjCArrayLiteral (stmt_info, stmts, info) - -> objCArrayLiteral_trans trans_state info stmt_info stmts - | ObjCDictionaryLiteral (stmt_info, stmts, info) - -> objCDictionaryLiteral_trans trans_state info stmt_info stmts - | ObjCStringLiteral (stmt_info, stmts, info) - -> objCStringLiteral_trans trans_state stmt_info stmts info - | BreakStmt (stmt_info, _) - -> breakStmt_trans trans_state stmt_info - | ContinueStmt (stmt_info, _) - -> continueStmt_trans trans_state stmt_info - | ObjCAtSynchronizedStmt (_, stmt_list) - -> objCAtSynchronizedStmt_trans trans_state stmt_list - | ObjCIndirectCopyRestoreExpr (_, stmt_list, _) - -> instructions trans_state stmt_list - | BlockExpr (stmt_info, _, expr_info, decl) - -> blockExpr_trans trans_state stmt_info expr_info decl - | ObjCAutoreleasePoolStmt (stmt_info, stmts) - -> objcAutoreleasePool_trans trans_state stmt_info stmts - | ObjCAtTryStmt (stmt_info, stmts) - -> compoundStmt_trans trans_state stmt_info stmts - | CXXTryStmt (stmt_info, stmts) - -> L.(debug Capture Medium) + | Some sel -> + objCBoxedExpr_trans trans_state info sel stmt_info stmts + | None -> + assert false ) + | ObjCArrayLiteral (stmt_info, stmts, info) -> + objCArrayLiteral_trans trans_state info stmt_info stmts + | ObjCDictionaryLiteral (stmt_info, stmts, info) -> + objCDictionaryLiteral_trans trans_state info stmt_info stmts + | ObjCStringLiteral (stmt_info, stmts, info) -> + objCStringLiteral_trans trans_state stmt_info stmts info + | BreakStmt (stmt_info, _) -> + breakStmt_trans trans_state stmt_info + | ContinueStmt (stmt_info, _) -> + continueStmt_trans trans_state stmt_info + | ObjCAtSynchronizedStmt (_, stmt_list) -> + objCAtSynchronizedStmt_trans trans_state stmt_list + | ObjCIndirectCopyRestoreExpr (_, stmt_list, _) -> + instructions trans_state stmt_list + | BlockExpr (stmt_info, _, expr_info, decl) -> + blockExpr_trans trans_state stmt_info expr_info decl + | ObjCAutoreleasePoolStmt (stmt_info, stmts) -> + objcAutoreleasePool_trans trans_state stmt_info stmts + | ObjCAtTryStmt (stmt_info, stmts) -> + compoundStmt_trans trans_state stmt_info stmts + | CXXTryStmt (stmt_info, stmts) -> + L.(debug Capture Medium) "@\n!!!!WARNING: found statement %s. @\nTranslation need to be improved.... @\n" (Clang_ast_proj.get_stmt_kind_string instr) ; compoundStmt_trans trans_state stmt_info stmts - | ObjCAtThrowStmt (stmt_info, stmts) | CXXThrowExpr (stmt_info, stmts, _) - -> objc_cxx_throw_trans trans_state stmt_info stmts - | ObjCAtFinallyStmt (stmt_info, stmts) - -> compoundStmt_trans trans_state stmt_info stmts - | ObjCAtCatchStmt (stmt_info, _, _) | CXXCatchStmt (stmt_info, _, _) - -> compoundStmt_trans trans_state stmt_info [] - | PredefinedExpr (_, _, expr_info, _) - -> stringLiteral_trans trans_state expr_info "" - | BinaryConditionalOperator (stmt_info, stmts, expr_info) - -> binaryConditionalOperator_trans trans_state stmt_info stmts expr_info - | CXXNewExpr (stmt_info, stmt_list, expr_info, cxx_new_expr_info) - -> cxxNewExpr_trans trans_state stmt_info stmt_list expr_info cxx_new_expr_info - | CXXDeleteExpr (stmt_info, stmt_list, _, delete_expr_info) - -> cxxDeleteExpr_trans trans_state stmt_info stmt_list delete_expr_info - | MaterializeTemporaryExpr (stmt_info, stmt_list, expr_info, _) - -> materializeTemporaryExpr_trans trans_state stmt_info stmt_list expr_info - | CompoundLiteralExpr (_, stmt_list, expr_info) - -> compoundLiteralExpr_trans trans_state stmt_list expr_info - | InitListExpr (stmt_info, stmts, expr_info) - -> initListExpr_trans trans_state stmt_info expr_info stmts - | CXXBindTemporaryExpr (_, stmt_list, _, _) - -> (* right now we ignore this expression and try to translate the child node *) + | ObjCAtThrowStmt (stmt_info, stmts) | CXXThrowExpr (stmt_info, stmts, _) -> + objc_cxx_throw_trans trans_state stmt_info stmts + | ObjCAtFinallyStmt (stmt_info, stmts) -> + compoundStmt_trans trans_state stmt_info stmts + | ObjCAtCatchStmt (stmt_info, _, _) | CXXCatchStmt (stmt_info, _, _) -> + compoundStmt_trans trans_state stmt_info [] + | PredefinedExpr (_, _, expr_info, _) -> + stringLiteral_trans trans_state expr_info "" + | BinaryConditionalOperator (stmt_info, stmts, expr_info) -> + binaryConditionalOperator_trans trans_state stmt_info stmts expr_info + | CXXNewExpr (stmt_info, stmt_list, expr_info, cxx_new_expr_info) -> + cxxNewExpr_trans trans_state stmt_info stmt_list expr_info cxx_new_expr_info + | CXXDeleteExpr (stmt_info, stmt_list, _, delete_expr_info) -> + cxxDeleteExpr_trans trans_state stmt_info stmt_list delete_expr_info + | MaterializeTemporaryExpr (stmt_info, stmt_list, expr_info, _) -> + materializeTemporaryExpr_trans trans_state stmt_info stmt_list expr_info + | CompoundLiteralExpr (_, stmt_list, expr_info) -> + compoundLiteralExpr_trans trans_state stmt_list expr_info + | InitListExpr (stmt_info, stmts, expr_info) -> + initListExpr_trans trans_state stmt_info expr_info stmts + | CXXBindTemporaryExpr (_, stmt_list, _, _) -> + (* right now we ignore this expression and try to translate the child node *) parenExpr_trans trans_state stmt_list - | CXXDynamicCastExpr (stmt_info, stmts, _, _, qual_type, _) - -> cxxDynamicCastExpr_trans trans_state stmt_info stmts qual_type + | CXXDynamicCastExpr (stmt_info, stmts, _, _, qual_type, _) -> + cxxDynamicCastExpr_trans trans_state stmt_info stmts qual_type | CXXDefaultArgExpr (_, _, _, default_expr_info) - | CXXDefaultInitExpr (_, _, _, default_expr_info) - -> cxxDefaultExpr_trans trans_state default_expr_info - | ImplicitValueInitExpr (stmt_info, _, _) - -> implicitValueInitExpr_trans trans_state stmt_info + | CXXDefaultInitExpr (_, _, _, default_expr_info) -> + cxxDefaultExpr_trans trans_state default_expr_info + | ImplicitValueInitExpr (stmt_info, _, _) -> + implicitValueInitExpr_trans trans_state stmt_info | GenericSelectionExpr _ (* to be fixed when we dump the right info in the ast *) - | SizeOfPackExpr _ - -> {empty_res_trans with exps= [(Exp.get_undefined false, Typ.mk Tvoid)]} - | GCCAsmStmt (stmt_info, stmts) - -> gccAsmStmt_trans trans_state stmt_info stmts - | CXXPseudoDestructorExpr _ - -> cxxPseudoDestructorExpr_trans () - | CXXTypeidExpr (stmt_info, stmts, expr_info) - -> cxxTypeidExpr_trans trans_state stmt_info stmts expr_info - | CXXStdInitializerListExpr (stmt_info, stmts, expr_info) - -> cxxStdInitializerListExpr_trans trans_state stmt_info stmts expr_info - | LambdaExpr (stmt_info, _, expr_info, lambda_expr_info) - -> let trans_state' = {trans_state with priority= Free} in + | SizeOfPackExpr _ -> + {empty_res_trans with exps= [(Exp.get_undefined false, Typ.mk Tvoid)]} + | GCCAsmStmt (stmt_info, stmts) -> + gccAsmStmt_trans trans_state stmt_info stmts + | CXXPseudoDestructorExpr _ -> + cxxPseudoDestructorExpr_trans () + | CXXTypeidExpr (stmt_info, stmts, expr_info) -> + cxxTypeidExpr_trans trans_state stmt_info stmts expr_info + | CXXStdInitializerListExpr (stmt_info, stmts, expr_info) -> + cxxStdInitializerListExpr_trans trans_state stmt_info stmts expr_info + | LambdaExpr (stmt_info, _, expr_info, lambda_expr_info) -> + let trans_state' = {trans_state with priority= Free} in lambdaExpr_trans trans_state' stmt_info expr_info lambda_expr_info - | AttributedStmt (_, stmts, attrs) - -> attributedStmt_trans trans_state stmts attrs - | TypeTraitExpr (_, _, expr_info, type_trait_info) - -> booleanValue_trans trans_state expr_info type_trait_info.Clang_ast_t.xtti_value - | CXXNoexceptExpr (_, _, expr_info, cxx_noexcept_expr_info) - -> booleanValue_trans trans_state expr_info cxx_noexcept_expr_info.Clang_ast_t.xnee_value - | OffsetOfExpr (_, _, expr_info) | VAArgExpr (_, _, expr_info) - -> trans_into_undefined_expr trans_state expr_info - | ArrayInitIndexExpr _ | ArrayInitLoopExpr _ - -> no_op_trans trans_state.succ_nodes + | AttributedStmt (_, stmts, attrs) -> + attributedStmt_trans trans_state stmts attrs + | TypeTraitExpr (_, _, expr_info, type_trait_info) -> + booleanValue_trans trans_state expr_info type_trait_info.Clang_ast_t.xtti_value + | CXXNoexceptExpr (_, _, expr_info, cxx_noexcept_expr_info) -> + booleanValue_trans trans_state expr_info cxx_noexcept_expr_info.Clang_ast_t.xnee_value + | OffsetOfExpr (_, _, expr_info) | VAArgExpr (_, _, expr_info) -> + trans_into_undefined_expr trans_state expr_info + | ArrayInitIndexExpr _ | ArrayInitLoopExpr _ -> + no_op_trans trans_state.succ_nodes (* vector instructions for OpenCL etc. we basically ignore these for now; just translate the sub-expressions *) - | ObjCAvailabilityCheckExpr (_, _, expr_info, _) - -> trans_into_undefined_expr trans_state expr_info + | ObjCAvailabilityCheckExpr (_, _, expr_info, _) -> + trans_into_undefined_expr trans_state expr_info | ExtVectorElementExpr (_, stmts, _) | ShuffleVectorExpr (_, stmts, _) - | UserDefinedLiteral (_, stmts, _) - -> skip_unimplemented trans_state stmts + | UserDefinedLiteral (_, stmts, _) -> + skip_unimplemented trans_state stmts (* Infer somehow ended up in templated non instantiated code - right now it's not supported and failure in those cases is expected. *) | SubstNonTypeTemplateParmExpr _ | SubstNonTypeTemplateParmPackExpr _ - | CXXDependentScopeMemberExpr _ - -> CFrontend_config.unimplemented "Translation of templated code is unsupported: %a" - (Pp.to_string ~f:Clang_ast_j.string_of_stmt) instr - | ForStmt (_, _) | WhileStmt (_, _) | DoStmt (_, _) | ObjCForCollectionStmt (_, _) - -> CFrontend_config.incorrect_assumption "Unexpected shape for %a: %a" - (Pp.to_string ~f:Clang_ast_proj.get_stmt_kind_string) instr - (Pp.to_string ~f:Clang_ast_j.string_of_stmt) instr + | CXXDependentScopeMemberExpr _ -> + CFrontend_config.unimplemented "Translation of templated code is unsupported: %a" + (Pp.to_string ~f:Clang_ast_j.string_of_stmt) + instr + | ForStmt (_, _) | WhileStmt (_, _) | DoStmt (_, _) | ObjCForCollectionStmt (_, _) -> + CFrontend_config.incorrect_assumption "Unexpected shape for %a: %a" + (Pp.to_string ~f:Clang_ast_proj.get_stmt_kind_string) + instr + (Pp.to_string ~f:Clang_ast_j.string_of_stmt) + instr | MSAsmStmt _ | CapturedStmt _ | CoreturnStmt _ @@ -3375,11 +3511,13 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s | SEHFinallyStmt _ | SEHLeaveStmt _ | SEHTryStmt _ - | DefaultStmt _ - -> CFrontend_config.unimplemented "Statement translation for kind %s: %a" - (Clang_ast_proj.get_stmt_kind_string instr) (Pp.to_string ~f:Clang_ast_j.string_of_stmt) + | DefaultStmt _ -> + CFrontend_config.unimplemented "Statement translation for kind %s: %a" + (Clang_ast_proj.get_stmt_kind_string instr) + (Pp.to_string ~f:Clang_ast_j.string_of_stmt) instr + (* Function similar to instruction function, but it takes C++ constructor initializer as an input parameter. *) and cxx_constructor_init_trans ctor_init trans_state = @@ -3403,8 +3541,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let this_res_trans = this_expr_trans trans_state' sil_loc class_qual_type in let var_res_trans = match ctor_init.Clang_ast_t.xci_subject with - | `Delegating _ | `BaseClass _ - -> let this_exp, this_typ = + | `Delegating _ | `BaseClass _ -> + let this_exp, this_typ = extract_exp_from_list this_res_trans.exps "WARNING: There should be one expression for 'this' in constructor. @\n" in @@ -3412,8 +3550,8 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s (* it will add pointer back before making it a parameter to a call *) let class_typ = match this_typ.Typ.desc with Tptr (t, _) -> t | _ -> assert false in {this_res_trans with exps= [(this_exp, class_typ)]} - | `Member decl_ref - -> decl_ref_trans trans_state' this_res_trans child_stmt_info decl_ref + | `Member decl_ref -> + decl_ref_trans trans_state' this_res_trans child_stmt_info decl_ref ~is_constructor_init:true in let var_exp_typ = @@ -3425,14 +3563,15 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s PriorityNode.compute_results_to_parent trans_state' sil_loc "Constructor Init" this_stmt_info [var_res_trans; init_res_trans] + (** Given a translation state and list of translation functions it executes translation *) and exec_trans_instrs trans_state trans_stmt_fun_list = let rec exec_trans_instrs_no_rev trans_state rev_trans_fun_list = match rev_trans_fun_list with - | [] - -> {empty_res_trans with root_nodes= trans_state.succ_nodes} - | trans_stmt_fun :: trans_stmt_fun_list' - -> let res_trans_s = trans_stmt_fun trans_state in + | [] -> + {empty_res_trans with root_nodes= trans_state.succ_nodes} + | trans_stmt_fun :: trans_stmt_fun_list' -> + let res_trans_s = trans_stmt_fun trans_state in let trans_state' = if res_trans_s.root_nodes <> [] then {trans_state with succ_nodes= res_trans_s.root_nodes} @@ -3448,21 +3587,24 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s in exec_trans_instrs_no_rev trans_state (List.rev trans_stmt_fun_list) + and get_clang_stmt_trans stmt trans_state = exec_with_node_creation instruction trans_state stmt (* TODO write translate function for cxx constructor exprs *) and get_custom_stmt_trans stmt = match stmt with - | `ClangStmt stmt - -> get_clang_stmt_trans stmt - | `CXXConstructorInit instr - -> cxx_constructor_init_trans instr + | `ClangStmt stmt -> + get_clang_stmt_trans stmt + | `CXXConstructorInit instr -> + cxx_constructor_init_trans instr + (** Given a translation state, this function translates a list of clang statements. *) and instructions trans_state stmt_list = let stmt_trans_fun = List.map ~f:get_clang_stmt_trans stmt_list in exec_trans_instrs trans_state stmt_trans_fun + and expression_trans context stmt warning = let trans_state = { context @@ -3476,6 +3618,7 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let res_trans_stmt = instruction trans_state stmt in fst (CTrans_utils.extract_exp_from_list res_trans_stmt.exps warning) + let instructions_trans context body extra_instrs exit_node ~is_destructor_wrapper = let trans_state = { context @@ -3508,4 +3651,5 @@ module CTrans_funct (F : CModule_type.CFrontend) : CModule_type.CTranslation = s let instrs_trans = List.map ~f:get_custom_stmt_trans instrs in let res_trans = exec_trans_instrs trans_state' instrs_trans in res_trans.root_nodes + end diff --git a/infer/src/clang/cTrans_models.ml b/infer/src/clang/cTrans_models.ml index 35a5680c1..10c243af3 100644 --- a/infer/src/clang/cTrans_models.ml +++ b/infer/src/clang/cTrans_models.ml @@ -15,6 +15,7 @@ let class_equal class_typename class_name = String.equal (Typ.Name.name class_ty let is_cf_non_null_alloc pname = String.equal (Typ.Procname.to_string pname) CFrontend_config.cf_non_null_alloc + let is_alloc pname = String.equal (Typ.Procname.to_string pname) CFrontend_config.cf_alloc let is_alloc_model typ pname = @@ -26,29 +27,36 @@ let is_alloc_model typ pname = ^(Typ.to_string typ)^" "^(funct));*) Core_foundation_model.is_core_lib_create typ funct + let is_builtin_expect pname = String.equal (Typ.Procname.to_string pname) CFrontend_config.builtin_expect + let is_builtin_object_size pname = String.equal (Typ.Procname.to_string pname) CFrontend_config.builtin_object_size + let is_std_addressof pname = (* since std_addressof is a template function, matching it requires QualifiedCppName *) QualifiedCppName.Match.match_qualifiers CFrontend_config.std_addressof (Typ.Procname.get_qualifiers pname) + let is_replace_with_deref_first_arg pname = String.equal (Typ.Procname.to_string pname) CFrontend_config.replace_with_deref_first_arg_attr + let is_retain_predefined_model typ pname = let funct = Typ.Procname.to_string pname in Core_foundation_model.is_core_lib_retain typ funct + let is_release_predefined_model typ pname = let funct = Typ.Procname.to_string pname in Core_foundation_model.is_core_lib_release typ funct || Core_foundation_model.is_core_graphics_release typ funct + let is_retain_method funct = String.equal funct CFrontend_config.retain let is_release_method funct = String.equal funct CFrontend_config.release @@ -61,53 +69,61 @@ let get_builtinname method_name = else if is_release_method method_name then Some BuiltinDecl.__objc_release else None + let is_modeled_builtin funct = String.equal funct CFrontend_config.builtin_memset_chk let is_modeled_attribute attr_name = List.mem ~equal:String.equal CFrontend_config.modeled_function_attributes attr_name + let get_first_param_typedef_string_opt type_ptr = match CAst_utils.get_desugared_type type_ptr with - | Some Clang_ast_t.FunctionProtoType (_, _, {pti_params_type= [param_ptr]}) - -> CAst_utils.name_opt_of_typedef_qual_type param_ptr + | Some Clang_ast_t.FunctionProtoType (_, _, {pti_params_type= [param_ptr]}) -> + CAst_utils.name_opt_of_typedef_qual_type param_ptr |> Option.map ~f:QualifiedCppName.to_qual_string - | _ - -> None + | _ -> + None + let is_release_builtin funct fun_type = let pn = Typ.Procname.from_string_c_fun funct in if Specs.summary_exists pn then false else match get_first_param_typedef_string_opt fun_type with - | Some typ - -> is_release_predefined_model typ pn - | _ - -> false + | Some typ -> + is_release_predefined_model typ pn + | _ -> + false + let is_retain_builtin funct fun_type = let pn = Typ.Procname.from_string_c_fun funct in if Specs.summary_exists pn then false else match get_first_param_typedef_string_opt fun_type with - | Some typ - -> is_retain_predefined_model typ pn - | _ - -> false + | Some typ -> + is_retain_predefined_model typ pn + | _ -> + false + let is_assert_log_s funct = String.equal funct CFrontend_config.assert_rtn || String.equal funct CFrontend_config.assert_fail || String.equal funct CFrontend_config.fbAssertWithSignalAndLogFunctionHelper || String.is_substring ~substring:CFrontend_config.google_MakeCheckOpString funct + let is_assert_log_method m = String.equal m CFrontend_config.google_LogMessageFatal let is_handleFailureInMethod funct = String.equal funct CFrontend_config.handleFailureInMethod || String.equal funct CFrontend_config.handleFailureInFunction + let is_retain_or_release funct = is_retain_method funct || is_release_method funct || is_autorelease_method funct + let is_toll_free_bridging pn = let funct = Typ.Procname.to_string pn in String.equal funct CFrontend_config.cf_bridging_release @@ -115,19 +131,22 @@ let is_toll_free_bridging pn = || String.equal funct CFrontend_config.cf_autorelease || String.equal funct CFrontend_config.ns_make_collectable + let is_cf_retain_release pn = Typ.Procname.equal pn BuiltinDecl.__objc_retain_cf || Typ.Procname.equal pn BuiltinDecl.__objc_release_cf + (** If the function is a builtin model, return the model, otherwise return the function *) let is_assert_log pname = match pname with - | Typ.Procname.ObjC_Cpp _ - -> is_assert_log_method (Typ.Procname.to_string pname) - | Typ.Procname.C _ - -> is_assert_log_s (Typ.Procname.to_string pname) - | _ - -> false + | Typ.Procname.ObjC_Cpp _ -> + is_assert_log_method (Typ.Procname.to_string pname) + | Typ.Procname.C _ -> + is_assert_log_s (Typ.Procname.to_string pname) + | _ -> + false + let is_objc_memory_model_controlled o = Core_foundation_model.is_objc_memory_model_controlled o @@ -136,18 +155,20 @@ let get_predefined_ms_method condition class_name method_name method_kind mk_pro if condition then let procname = match builtin with - | Some procname - -> procname - | None - -> mk_procname class_name method_name method_kind + | Some procname -> + procname + | None -> + mk_procname class_name method_name method_kind in let ms = CMethod_signature.make_ms procname arguments return_type attributes - (Ast_expressions.dummy_source_range ()) false lang None None None `None + (Ast_expressions.dummy_source_range ()) + false lang None None None `None in Some ms else None + let get_predefined_ms_stringWithUTF8String class_name method_name mk_procname lang = let condition = class_equal class_name CFrontend_config.nsstring_cl @@ -161,6 +182,7 @@ let get_predefined_ms_stringWithUTF8String class_name method_name mk_procname la get_predefined_ms_method condition class_name method_name Typ.Procname.ObjCClassMethod mk_procname lang args id_type [] None + let get_predefined_ms_retain_release method_name mk_procname lang = let condition = is_retain_or_release method_name in let return_type = @@ -174,6 +196,7 @@ let get_predefined_ms_retain_release method_name mk_procname lang = get_predefined_ms_method condition class_typename method_name Typ.Procname.ObjCInstanceMethod mk_procname lang args return_type [] (get_builtinname method_name) + let get_predefined_ms_autoreleasepool_init class_name method_name mk_procname lang = let condition = String.equal method_name CFrontend_config.init @@ -184,6 +207,7 @@ let get_predefined_ms_autoreleasepool_init class_name method_name mk_procname la mk_procname lang [(Mangled.from_string CFrontend_config.self, class_type)] Ast_expressions.create_void_type [] None + let get_predefined_ms_nsautoreleasepool_release class_name method_name mk_procname lang = let condition = ( String.equal method_name CFrontend_config.release @@ -196,6 +220,7 @@ let get_predefined_ms_nsautoreleasepool_release class_name method_name mk_procna mk_procname lang args Ast_expressions.create_void_type [] (Some BuiltinDecl.__objc_release_autorelease_pool) + let get_predefined_ms_is_kind_of_class class_name method_name mk_procname lang = let condition = String.equal method_name CFrontend_config.is_kind_of_class in let class_type = Ast_expressions.create_class_qual_type class_name in @@ -203,6 +228,7 @@ let get_predefined_ms_is_kind_of_class class_name method_name mk_procname lang = get_predefined_ms_method condition class_name method_name Typ.Procname.ObjCInstanceMethod mk_procname lang args Ast_expressions.create_BOOL_type [] (Some BuiltinDecl.__instanceof) + let get_predefined_model_method_signature class_name method_name mk_procname lang = let next_predefined f = function Some _ as x -> x | None -> f method_name mk_procname lang in get_predefined_ms_nsautoreleasepool_release class_name method_name mk_procname lang @@ -211,6 +237,7 @@ let get_predefined_model_method_signature class_name method_name mk_procname lan |> next_predefined (get_predefined_ms_autoreleasepool_init class_name) |> next_predefined (get_predefined_ms_is_kind_of_class class_name) + let dispatch_functions = [ ("_dispatch_once", 1) ; ("dispatch_async", 1) @@ -223,12 +250,14 @@ let dispatch_functions = ; ("dispatch_source_set_cancel_handler", 1) ; ("dispatch_source_set_event_handler", 1) ] + let is_dispatch_function_name function_name = let rec is_dispatch functions = match functions with - | [] - -> None - | (el, block_arg_pos) :: rest - -> if String.equal el function_name then Some (el, block_arg_pos) else is_dispatch rest + | [] -> + None + | (el, block_arg_pos) :: rest -> + if String.equal el function_name then Some (el, block_arg_pos) else is_dispatch rest in is_dispatch dispatch_functions + diff --git a/infer/src/clang/cTrans_utils.ml b/infer/src/clang/cTrans_utils.ml index 59033409a..a86d36899 100644 --- a/infer/src/clang/cTrans_utils.ml +++ b/infer/src/clang/cTrans_utils.ml @@ -19,7 +19,13 @@ module L = Logging (* assume in many places that a list is just a singleton. We use the *) (* warning if to see which assumption was not correct *) let extract_item_from_singleton l warning_string failure_val = - match l with [item] -> item | _ -> L.(debug Capture Medium) "%s" warning_string ; failure_val + match l with + | [item] -> + item + | _ -> + L.(debug Capture Medium) "%s" warning_string ; + failure_val + let dummy_exp = (Exp.minus_one, Typ.mk (Tint Typ.IInt)) @@ -29,26 +35,31 @@ let dummy_exp = (Exp.minus_one, Typ.mk (Tint Typ.IInt)) let extract_exp_from_list el warning_string = extract_item_from_singleton el warning_string dummy_exp + module Nodes = struct let prune_kind b = Procdesc.Node.Prune_node (b, Sil.Ik_bexp, string_of_bool b ^ " Branch") let is_join_node n = match Procdesc.Node.get_kind n with Procdesc.Node.Join_node -> true | _ -> false + let is_prune_node n = match Procdesc.Node.get_kind n with Procdesc.Node.Prune_node _ -> true | _ -> false + let is_true_prune_node n = match Procdesc.Node.get_kind n with - | Procdesc.Node.Prune_node (true, _, _) - -> true - | _ - -> false + | Procdesc.Node.Prune_node (true, _, _) -> + true + | _ -> + false + let create_node node_kind instrs loc context = let procdesc = CContext.get_procdesc context in Procdesc.create_node procdesc loc node_kind instrs + let create_prune_node ~branch ~negate_cond e_cond instrs_cond loc ik context = let e_cond', _ = extract_exp_from_list e_cond @@ -58,6 +69,7 @@ module Nodes = struct let instrs_cond' = instrs_cond @ [Sil.Prune (e_cond'', loc, branch, ik)] in create_node (prune_kind branch) instrs_cond' loc context + (** Check if this binary opertor requires the creation of a node in the cfg. *) let is_binary_assign_op boi = match boi.Clang_ast_t.boi_kind with @@ -71,8 +83,8 @@ module Nodes = struct | `ShrAssign | `AndAssign | `XorAssign - | `OrAssign - -> true + | `OrAssign -> + true | `PtrMemD | `PtrMemI | `Mul @@ -93,16 +105,18 @@ module Nodes = struct | `Or | `LAnd | `LOr - | `Comma - -> false + | `Comma -> + false + (** Check if this unary opertor requires the creation of a node in the cfg. *) let need_unary_op_node uoi = match uoi.Clang_ast_t.uoi_kind with - | `PostInc | `PostDec | `PreInc | `PreDec | `AddrOf | `Deref | `Plus - -> true - | `Minus | `Not | `LNot | `Real | `Imag | `Extension | `Coawait - -> false + | `PostInc | `PostDec | `PreInc | `PreDec | `AddrOf | `Deref | `Plus -> + true + | `Minus | `Not | `LNot | `Real | `Imag | `Extension | `Coawait -> + false + end module GotoLabel = struct @@ -111,7 +125,9 @@ module GotoLabel = struct with Not_found -> let node_name = Format.sprintf "GotoLabel_%s" label in let new_node = Nodes.create_node (Procdesc.Node.Skip_node node_name) [] sil_loc context in - Hashtbl.add context.CContext.label_map label new_node ; new_node + Hashtbl.add context.CContext.label_map label new_node ; + new_node + end type continuation = @@ -123,16 +139,18 @@ type continuation = let is_return_temp continuation = match continuation with Some cont -> cont.return_temp | _ -> false + let ids_to_parent cont ids = if is_return_temp cont then ids else [] let ids_to_node cont ids = if is_return_temp cont then [] else ids let mk_cond_continuation cont = match cont with - | Some cont' - -> Some {cont' with return_temp= true} - | None - -> Some {break= []; continue= []; return_temp= true} + | Some cont' -> + Some {cont' with return_temp= true} + | None -> + Some {break= []; continue= []; return_temp= true} + type priority_node = Free | Busy of Clang_ast_t.pointer @@ -167,16 +185,17 @@ type trans_result = let empty_res_trans = {root_nodes= []; leaf_nodes= []; instrs= []; exps= []; initd_exps= []; is_cpp_call_virtual= false} + let undefined_expression () = Exp.Var (Ident.create_fresh Ident.knormal) (** Collect the results of translating a list of instructions, and link up the nodes created. *) let collect_res_trans pdesc l = let rec collect l rt = match l with - | [] - -> rt - | rt' :: l' - -> let root_nodes = if rt.root_nodes <> [] then rt.root_nodes else rt'.root_nodes in + | [] -> + rt + | rt' :: l' -> + let root_nodes = if rt.root_nodes <> [] then rt.root_nodes else rt'.root_nodes in let leaf_nodes = if rt'.leaf_nodes <> [] then rt'.leaf_nodes else rt.leaf_nodes in if rt'.root_nodes <> [] then List.iter @@ -193,6 +212,7 @@ let collect_res_trans pdesc l = let rt = collect l empty_res_trans in {rt with instrs= List.rev rt.instrs; exps= List.rev rt.exps; initd_exps= List.rev rt.initd_exps} + (* priority_node is used to enforce some kind of policy for creating nodes *) (* in the cfg. Certain elements of the AST _must_ create nodes therefore *) (* there is no need for them to use priority_node. Certain elements *) @@ -210,23 +230,26 @@ module PriorityNode = struct let try_claim_priority_node trans_state stmt_info = match trans_state.priority with - | Free - -> L.(debug Capture Verbose) + | Free -> + L.(debug Capture Verbose) "Priority is free. Locking priority node in %d@\n@." stmt_info.Clang_ast_t.si_pointer ; {trans_state with priority= Busy stmt_info.Clang_ast_t.si_pointer} - | _ - -> L.(debug Capture Verbose) + | _ -> + L.(debug Capture Verbose) "Priority busy in %d. No claim possible@\n@." stmt_info.Clang_ast_t.si_pointer ; trans_state + let force_claim_priority_node trans_state stmt_info = {trans_state with priority= Busy stmt_info.Clang_ast_t.si_pointer} + let is_priority_free trans_state = match trans_state.priority with Free -> true | _ -> false let own_priority_node pri stmt_info = match pri with Busy p when Int.equal p stmt_info.Clang_ast_t.si_pointer -> true | _ -> false + (* Used by translation functions to handle potenatial cfg nodes. *) (* It connects nodes returned by translation of stmt children and *) (* deals with creating or not a cfg node depending of owning the *) @@ -248,6 +271,7 @@ module PriorityNode = struct else (* The node is created by the parent. We just pass back nodes/leafs params *) {res_state with exps= []} + end module Loops = struct @@ -267,20 +291,21 @@ module Loops = struct let loop_kind_to_if_kind loop_kind = match loop_kind with - | For _ - -> Sil.Ik_for - | While _ - -> Sil.Ik_while - | DoWhile _ - -> Sil.Ik_dowhile + | For _ -> + Sil.Ik_for + | While _ -> + Sil.Ik_while + | DoWhile _ -> + Sil.Ik_dowhile + let get_body loop_kind = - match loop_kind - with For (_, _, _, _, body) | While (_, _, body) | DoWhile (_, body) -> body + match loop_kind with For (_, _, _, _, body) | While (_, _, body) | DoWhile (_, body) -> body + let get_cond loop_kind = - match loop_kind - with For (_, _, cond, _, _) | While (_, cond, _) | DoWhile (cond, _) -> cond + match loop_kind with For (_, _, cond, _, _) | While (_, cond, _) | DoWhile (cond, _) -> cond + end module Scope = struct @@ -290,6 +315,7 @@ module Scope = struct let ptr = stmt_info.Clang_ast_t.si_pointer in StmtMap.add var_map ~key:ptr ~data:vars + let rec compute_vars vars_in_scope break_count var_map stmt = (* vars_in_scope corresponds to the list of all variables existing in the current scope *) (* break_count saves the number of variables in the current scope when entering the most recent loop *) @@ -297,49 +323,51 @@ module Scope = struct let open Clang_ast_t in let get_var_info_from_decl = function VarDecl _ as decl -> Some decl | _ -> None in let get_new_vars = function - | DeclStmt (_, _, decl_list) - -> List.filter_map ~f:get_var_info_from_decl decl_list - | _ - -> [] + | DeclStmt (_, _, decl_list) -> + List.filter_map ~f:get_var_info_from_decl decl_list + | _ -> + [] in let rec handle_instructions_block var_map vars_in_scope break_count instrs = match instrs with - | [] - -> (vars_in_scope, var_map) - | stmt :: rest - -> let new_var_map = compute_vars vars_in_scope break_count var_map stmt in + | [] -> + (vars_in_scope, var_map) + | stmt :: rest -> + let new_var_map = compute_vars vars_in_scope break_count var_map stmt in let new_vars_in_stmt = get_new_vars stmt in handle_instructions_block new_var_map (new_vars_in_stmt @ vars_in_scope) break_count rest in (* TODO handle following stmts: *) (* GotoStmt _ | | LabelStmt_ *) match stmt with - | CompoundStmt (stmt_info, stmt_list) - -> let vars, new_var_map = + | CompoundStmt (stmt_info, stmt_list) -> + let vars, new_var_map = handle_instructions_block var_map vars_in_scope break_count stmt_list in (* vars contains the variables defined in the current compound statement + vars_in_scope *) let vars_to_destroy = List.take vars (List.length vars - List.length vars_in_scope) in add_scope_vars_to_destroy new_var_map stmt_info vars_to_destroy - | ReturnStmt (stmt_info, _) - -> add_scope_vars_to_destroy var_map stmt_info vars_in_scope - | BreakStmt (stmt_info, _) | ContinueStmt (stmt_info, _) - -> let vars_to_destroy = List.take vars_in_scope (List.length vars_in_scope - break_count) in + | ReturnStmt (stmt_info, _) -> + add_scope_vars_to_destroy var_map stmt_info vars_in_scope + | BreakStmt (stmt_info, _) | ContinueStmt (stmt_info, _) -> + let vars_to_destroy = List.take vars_in_scope (List.length vars_in_scope - break_count) in add_scope_vars_to_destroy var_map stmt_info vars_to_destroy | WhileStmt (_, stmt_list) | DoStmt (_, stmt_list) | SwitchStmt (_, stmt_list) (* TODO handle variable declarations inside for / foreach *) | ForStmt (_, stmt_list) - | CXXForRangeStmt (_, stmt_list) - -> let break_count = List.length vars_in_scope in + | CXXForRangeStmt (_, stmt_list) -> + let break_count = List.length vars_in_scope in List.fold_left ~f:(compute_vars vars_in_scope break_count) stmt_list ~init:var_map - | _ - -> let stmt_list = snd (Clang_ast_proj.get_stmt_tuple stmt) in + | _ -> + let stmt_list = snd (Clang_ast_proj.get_stmt_tuple stmt) in List.fold_left ~f:(compute_vars vars_in_scope break_count) stmt_list ~init:var_map + let compute_vars_to_destroy body = List.fold_left ~f:(compute_vars [] 0) ~init:StmtMap.empty [body] + end (** This function handles ObjC new/alloc and C++ new calls *) @@ -349,17 +377,17 @@ let create_alloc_instrs ~alloc_builtin ?alloc_source_function ?size_exp sil_loc | Tptr (styp, Typ.Pk_pointer) | Tptr (styp, Typ.Pk_objc_weak) | Tptr (styp, Typ.Pk_objc_unsafe_unretained) - | Tptr (styp, Typ.Pk_objc_autoreleasing) - -> (function_type, styp) - | _ - -> (CType.add_pointer_to_typ function_type, function_type) + | Tptr (styp, Typ.Pk_objc_autoreleasing) -> + (function_type, styp) + | _ -> + (CType.add_pointer_to_typ function_type, function_type) in let alloc_source_function_arg = match alloc_source_function with - | Some procname - -> [(Exp.Const (Const.Cfun procname), Typ.mk Tvoid)] - | None - -> [] + | Some procname -> + [(Exp.Const (Const.Cfun procname), Typ.mk Tvoid)] + | None -> + [] in let ret_id = Ident.create_fresh Ident.knormal in let args = @@ -368,10 +396,10 @@ let create_alloc_instrs ~alloc_builtin ?alloc_source_function ?size_exp sil_loc in let sizeof_exp = match size_exp with - | Some exp - -> Exp.BinOp (Binop.Mult, sizeof_exp_, exp) - | None - -> sizeof_exp_ + | Some exp -> + Exp.BinOp (Binop.Mult, sizeof_exp_, exp) + | None -> + sizeof_exp_ in let exp = (sizeof_exp, Typ.mk (Tint Typ.IULong)) in exp :: alloc_source_function_arg @@ -382,6 +410,7 @@ let create_alloc_instrs ~alloc_builtin ?alloc_source_function ?size_exp sil_loc in (function_type, [stmt_call], Exp.Var ret_id) + let alloc_trans trans_state ~alloc_builtin ?alloc_source_function loc stmt_info function_type = let function_type, instrs, exp = create_alloc_instrs ~alloc_builtin ?alloc_source_function loc function_type @@ -393,6 +422,7 @@ let alloc_trans trans_state ~alloc_builtin ?alloc_source_function loc stmt_info in {res_trans with exps= [(exp, function_type)]} + let objc_new_trans trans_state ~alloc_builtin loc stmt_info cls_name function_type = let alloc_ret_type, alloc_stmt_call, alloc_ret_exp = create_alloc_instrs ~alloc_builtin loc function_type @@ -418,15 +448,16 @@ let objc_new_trans trans_state ~alloc_builtin loc stmt_info cls_name function_ty in {res_trans with exps= [(Exp.Var init_ret_id, alloc_ret_type)]} + let new_or_alloc_trans trans_state loc stmt_info qual_type class_name_opt selector = let tenv = trans_state.context.CContext.tenv in let function_type = CType_decl.qual_type_to_sil_type tenv qual_type in let class_name = match class_name_opt with - | Some class_name - -> class_name - | None - -> CType.objc_classname_of_type function_type + | Some class_name -> + class_name + | None -> + CType.objc_classname_of_type function_type in if String.equal selector CFrontend_config.alloc then alloc_trans trans_state ~alloc_builtin:BuiltinDecl.__objc_alloc_no_fail loc stmt_info @@ -436,6 +467,7 @@ let new_or_alloc_trans trans_state loc stmt_info qual_type class_name_opt select class_name function_type else Logging.die InternalError "Expected selector new or alloc but got, %s" selector + let cpp_new_trans sil_loc function_type size_exp = let alloc_builtin = match size_exp with Some _ -> BuiltinDecl.__new_array | None -> BuiltinDecl.__new @@ -445,6 +477,7 @@ let cpp_new_trans sil_loc function_type size_exp = in {empty_res_trans with instrs= stmt_call; exps= [(exp, function_type)]} + let create_cast_instrs exp cast_from_typ cast_to_typ sil_loc = let ret_id = Ident.create_fresh Ident.knormal in let ret_id_typ = Some (ret_id, cast_to_typ) in @@ -457,20 +490,23 @@ let create_cast_instrs exp cast_from_typ cast_to_typ sil_loc = in (stmt_call, Exp.Var ret_id) + let cast_trans exps sil_loc function_type pname = if CTrans_models.is_toll_free_bridging pname then match exps with - | [(exp, typ)] - -> Some (create_cast_instrs exp typ function_type sil_loc) - | _ - -> assert false + | [(exp, typ)] -> + Some (create_cast_instrs exp typ function_type sil_loc) + | _ -> + assert false else None + let dereference_var_sil (exp, typ) sil_loc = let id = Ident.create_fresh Ident.knormal in let sil_instr = Sil.Load (id, exp, typ, sil_loc) in ([sil_instr], Exp.Var id) + (** Given trans_result with ONE expression, create temporary variable with value of an expression assigned to it *) let dereference_value_from_result sil_loc trans_result ~strip_pointer = @@ -480,36 +516,38 @@ let dereference_value_from_result sil_loc trans_result ~strip_pointer = let cast_inst, cast_exp = dereference_var_sil (obj_sil, cast_typ) sil_loc in {trans_result with instrs= trans_result.instrs @ cast_inst; exps= [(cast_exp, cast_typ)]} + let cast_operation trans_state cast_kind exps cast_typ sil_loc is_objc_bridged = let exp, typ = extract_exp_from_list exps "" in let is_objc_bridged = Option.is_some trans_state.obj_bridged_cast_typ || is_objc_bridged in match cast_kind with - | `NoOp | `DerivedToBase | `UncheckedDerivedToBase - -> (* These casts ignore change of type *) + | `NoOp | `DerivedToBase | `UncheckedDerivedToBase -> + (* These casts ignore change of type *) ([], (exp, typ)) - | `BitCast | `IntegralCast | `IntegralToBoolean - -> (* This is treated as a nop by returning the same expressions exps*) + | `BitCast | `IntegralCast | `IntegralToBoolean -> + (* This is treated as a nop by returning the same expressions exps*) ([], (exp, cast_typ)) - | (`CPointerToObjCPointerCast | `ARCProduceObject | `ARCConsumeObject) when is_objc_bridged - -> (* Translation of __bridge_transfer or __bridge_retained *) + | (`CPointerToObjCPointerCast | `ARCProduceObject | `ARCConsumeObject) when is_objc_bridged -> + (* Translation of __bridge_transfer or __bridge_retained *) let objc_cast_typ = match trans_state.obj_bridged_cast_typ with Some typ -> typ | None -> cast_typ in let instr, exp = create_cast_instrs exp typ objc_cast_typ sil_loc in ([instr], (exp, cast_typ)) - | `LValueToRValue - -> (* Takes an LValue and allow it to use it as RValue. *) + | `LValueToRValue -> + (* Takes an LValue and allow it to use it as RValue. *) (* So we assign the LValue to a temp and we pass it to the parent.*) let instrs, deref_exp = dereference_var_sil (exp, cast_typ) sil_loc in (instrs, (deref_exp, cast_typ)) - | `NullToPointer - -> if Exp.is_zero exp then ([], (Exp.null, cast_typ)) else ([], (exp, cast_typ)) - | _ - -> L.(debug Capture Verbose) + | `NullToPointer -> + if Exp.is_zero exp then ([], (Exp.null, cast_typ)) else ([], (exp, cast_typ)) + | _ -> + L.(debug Capture Verbose) "@\nWARNING: Missing translation for Cast Kind %s. The construct has been ignored...@\n" (Clang_ast_j.string_of_cast_kind cast_kind) ; ([], (exp, cast_typ)) + let trans_assertion_failure sil_loc (context: CContext.t) = let assert_fail_builtin = Exp.Const (Const.Cfun BuiltinDecl.__infer_fail) in let args = [(Exp.Const (Const.Cstr Config.default_failure_name), Typ.mk Tvoid)] in @@ -521,42 +559,48 @@ let trans_assertion_failure sil_loc (context: CContext.t) = Procdesc.node_set_succs_exn context.procdesc failure_node [exit_node] [] ; {empty_res_trans with root_nodes= [failure_node]} + let trans_assume_false sil_loc (context: CContext.t) succ_nodes = let instrs_cond = [Sil.Prune (Exp.zero, sil_loc, true, Sil.Ik_land_lor)] in let prune_node = Nodes.create_node (Nodes.prune_kind true) instrs_cond sil_loc context in Procdesc.node_set_succs_exn context.procdesc prune_node succ_nodes [] ; {empty_res_trans with root_nodes= [prune_node]; leaf_nodes= [prune_node]} + let trans_assertion trans_state sil_loc = let context = trans_state.context in if Config.report_custom_error then trans_assertion_failure sil_loc context else trans_assume_false sil_loc context trans_state.succ_nodes + let trans_builtin_expect params_trans_res = (* Translate call to __builtin_expect as the first argument *) (* for simpler symbolic execution *) match params_trans_res with [_; fst_arg_res; _] -> Some fst_arg_res | _ -> None + let trans_std_addressof params_trans_res = (* Translate call to std::addressof as the first argument *) (* for simpler symbolic execution. *) match params_trans_res with [_; fst_arg_res] -> Some fst_arg_res | _ -> assert false + let trans_replace_with_deref_first_arg sil_loc params_trans_res ~cxx_method_call = let first_arg_res_trans = match params_trans_res with - | _ :: fst_arg_res :: _ when not cxx_method_call - -> fst_arg_res - | ({exps= _method_exp :: this_exp} as fst_arg_res) :: _ when cxx_method_call - -> (* method_deref_trans uses different format to store first argument - it stores + | _ :: fst_arg_res :: _ when not cxx_method_call -> + fst_arg_res + | ({exps= _method_exp :: this_exp} as fst_arg_res) :: _ when cxx_method_call -> + (* method_deref_trans uses different format to store first argument - it stores two things in exps: [method_exp; this_exp]. We need to get rid of first exp before calling dereference_value_from_result *) {fst_arg_res with exps= this_exp} - | _ - -> assert false + | _ -> + assert false in dereference_value_from_result sil_loc first_arg_res_trans ~strip_pointer:true + let builtin_trans trans_state loc stmt_info function_type params_trans_res pname = if CTrans_models.is_cf_non_null_alloc pname || CTrans_models.is_alloc_model function_type pname then @@ -573,30 +617,35 @@ let builtin_trans trans_state loc stmt_info function_type params_trans_res pname else if CTrans_models.is_std_addressof pname then trans_std_addressof params_trans_res else None + let cxx_method_builtin_trans trans_state loc params_trans_res pname = if CTrans_models.is_assert_log pname then Some (trans_assertion trans_state loc) else if CTrans_models.is_replace_with_deref_first_arg pname then Some (trans_replace_with_deref_first_arg loc params_trans_res ~cxx_method_call:true) else None + let define_condition_side_effects e_cond instrs_cond sil_loc = let e', typ = extract_exp_from_list e_cond "@\nWARNING: Missing expression in IfStmt. Need to be fixed@\n" in match e' with - | Exp.Lvar pvar - -> let id = Ident.create_fresh Ident.knormal in + | Exp.Lvar pvar -> + let id = Ident.create_fresh Ident.knormal in ([(Exp.Var id, typ)], [Sil.Load (id, Exp.Lvar pvar, typ, sil_loc)]) - | _ - -> ([(e', typ)], instrs_cond) + | _ -> + ([(e', typ)], instrs_cond) + let is_superinstance mei = match mei.Clang_ast_t.omei_receiver_kind with `SuperInstance -> true | _ -> false + let get_selector_receiver obj_c_message_expr_info = ( obj_c_message_expr_info.Clang_ast_t.omei_selector , obj_c_message_expr_info.Clang_ast_t.omei_receiver_kind ) + let is_member_exp stmt = match stmt with Clang_ast_t.MemberExpr _ -> true | _ -> false let is_enumeration_constant stmt = @@ -605,49 +654,52 @@ let is_enumeration_constant stmt = match drei.Clang_ast_t.drti_decl_ref with | Some d -> ( match d.Clang_ast_t.dr_kind with `EnumConstant -> true | _ -> false ) - | _ - -> false ) - | _ - -> false + | _ -> + false ) + | _ -> + false + let is_null_stmt s = match s with Clang_ast_t.NullStmt _ -> true | _ -> false let extract_stmt_from_singleton stmt_list warning_string = extract_item_from_singleton stmt_list warning_string (Ast_expressions.dummy_stmt ()) + let rec get_type_from_exp_stmt stmt = let do_decl_ref_exp i = match i.Clang_ast_t.drti_decl_ref with | Some d -> ( match d.Clang_ast_t.dr_qual_type with Some n -> n | _ -> assert false ) - | _ - -> assert false + | _ -> + assert false in let open Clang_ast_t in match stmt with - | CXXOperatorCallExpr (_, _, ei) | CallExpr (_, _, ei) - -> ei.Clang_ast_t.ei_qual_type - | MemberExpr (_, _, ei, _) - -> ei.Clang_ast_t.ei_qual_type - | ParenExpr (_, _, ei) - -> ei.Clang_ast_t.ei_qual_type - | ArraySubscriptExpr (_, _, ei) - -> ei.Clang_ast_t.ei_qual_type - | ObjCIvarRefExpr (_, _, ei, _) - -> ei.Clang_ast_t.ei_qual_type - | ObjCMessageExpr (_, _, ei, _) - -> ei.Clang_ast_t.ei_qual_type - | PseudoObjectExpr (_, _, ei) - -> ei.Clang_ast_t.ei_qual_type + | CXXOperatorCallExpr (_, _, ei) | CallExpr (_, _, ei) -> + ei.Clang_ast_t.ei_qual_type + | MemberExpr (_, _, ei, _) -> + ei.Clang_ast_t.ei_qual_type + | ParenExpr (_, _, ei) -> + ei.Clang_ast_t.ei_qual_type + | ArraySubscriptExpr (_, _, ei) -> + ei.Clang_ast_t.ei_qual_type + | ObjCIvarRefExpr (_, _, ei, _) -> + ei.Clang_ast_t.ei_qual_type + | ObjCMessageExpr (_, _, ei, _) -> + ei.Clang_ast_t.ei_qual_type + | PseudoObjectExpr (_, _, ei) -> + ei.Clang_ast_t.ei_qual_type | CStyleCastExpr (_, stmt_list, _, _, _) | UnaryOperator (_, stmt_list, _, _) - | ImplicitCastExpr (_, stmt_list, _, _) - -> get_type_from_exp_stmt + | ImplicitCastExpr (_, stmt_list, _, _) -> + get_type_from_exp_stmt (extract_stmt_from_singleton stmt_list "WARNING: We expect only one stmt.") - | DeclRefExpr (_, _, _, info) - -> do_decl_ref_exp info - | _ - -> L.die InternalError "get_type_from_expr_stmt failure: %s" (Clang_ast_j.string_of_stmt stmt) + | DeclRefExpr (_, _, _, info) -> + do_decl_ref_exp info + | _ -> + L.die InternalError "get_type_from_expr_stmt failure: %s" (Clang_ast_j.string_of_stmt stmt) + module Self = struct exception SelfClassException of Typ.Name.t @@ -665,9 +717,11 @@ module Self = struct {empty_res_trans with exps= [(self_expr, typ)]; instrs= ins} else empty_res_trans + let is_var_self pvar is_objc_method = let is_self = String.equal (Mangled.to_string (Pvar.get_name pvar)) CFrontend_config.self in is_self && is_objc_method + end (* From the manual: A selector is in a certain selector family if, ignoring any leading underscores, *) @@ -686,58 +740,63 @@ let is_owning_name n = match Str.split (Str.regexp_string ":") n with | fst :: _ -> ( match Str.split (Str.regexp "['_']+") fst with - | [no_und] | _ :: no_und :: _ - -> is_family CFrontend_config.alloc no_und || is_family CFrontend_config.copy no_und + | [no_und] | _ :: no_und :: _ -> + is_family CFrontend_config.alloc no_und || is_family CFrontend_config.copy no_und || is_family CFrontend_config.new_str no_und || is_family CFrontend_config.mutableCopy no_und || is_family CFrontend_config.init no_und - | _ - -> assert false ) - | _ - -> assert false + | _ -> + assert false ) + | _ -> + assert false + let rec is_owning_method s = match s with - | Clang_ast_t.ObjCMessageExpr (_, _, _, mei) - -> is_owning_name mei.Clang_ast_t.omei_selector + | Clang_ast_t.ObjCMessageExpr (_, _, _, mei) -> + is_owning_name mei.Clang_ast_t.omei_selector | _ -> match snd (Clang_ast_proj.get_stmt_tuple s) with - | [] - -> false - | s'' :: _ - -> is_owning_method s'' + | [] -> + false + | s'' :: _ -> + is_owning_method s'' + let rec is_method_call s = match s with - | Clang_ast_t.ObjCMessageExpr _ - -> true + | Clang_ast_t.ObjCMessageExpr _ -> + true | _ -> match snd (Clang_ast_proj.get_stmt_tuple s) with [] -> false | s'' :: _ -> is_method_call s'' + let rec get_decl_ref_info s = match s with | Clang_ast_t.DeclRefExpr (_, _, _, decl_ref_expr_info) -> ( match decl_ref_expr_info.Clang_ast_t.drti_decl_ref with - | Some decl_ref - -> decl_ref - | None - -> assert false ) + | Some decl_ref -> + decl_ref + | None -> + assert false ) | _ -> match Clang_ast_proj.get_stmt_tuple s with - | _, [] - -> assert false - | _, s'' :: _ - -> get_decl_ref_info s'' + | _, [] -> + assert false + | _, s'' :: _ -> + get_decl_ref_info s'' + let rec contains_opaque_value_expr s = match s with - | Clang_ast_t.OpaqueValueExpr _ - -> true + | Clang_ast_t.OpaqueValueExpr _ -> + true | _ -> match snd (Clang_ast_proj.get_stmt_tuple s) with - | [] - -> false - | s'' :: _ - -> contains_opaque_value_expr s'' + | [] -> + false + | s'' :: _ -> + contains_opaque_value_expr s'' + (* checks if a unary operator is a logic negation applied to integers*) let is_logical_negation_of_int tenv ei uoi = @@ -745,25 +804,27 @@ let is_logical_negation_of_int tenv ei uoi = ( (CType_decl.qual_type_to_sil_type tenv ei.Clang_ast_t.ei_qual_type).desc , uoi.Clang_ast_t.uoi_kind ) with - | Typ.Tint _, `LNot - -> true - | _, _ - -> false + | Typ.Tint _, `LNot -> + true + | _, _ -> + false + let rec is_block_stmt stmt = let open Clang_ast_t in match stmt with - | BlockExpr _ - -> true - | DeclRefExpr (_, _, expr_info, _) - -> let qt = expr_info.Clang_ast_t.ei_qual_type in + | BlockExpr _ -> + true + | DeclRefExpr (_, _, expr_info, _) -> + let qt = expr_info.Clang_ast_t.ei_qual_type in CType.is_block_type qt | _ -> match snd (Clang_ast_proj.get_stmt_tuple stmt) with - | [sub_stmt] - -> is_block_stmt sub_stmt - | _ - -> false + | [sub_stmt] -> + is_block_stmt sub_stmt + | _ -> + false + (* Checks if stmt_list is a call to a special dispatch function *) let is_dispatch_function stmt_list = @@ -772,35 +833,37 @@ let is_dispatch_function stmt_list = match stmt with | DeclRefExpr (_, _, _, di) -> ( match di.Clang_ast_t.drti_decl_ref with - | None - -> None + | None -> + None | Some d -> match (d.Clang_ast_t.dr_kind, d.Clang_ast_t.dr_name) with | `Function, Some name_info - -> ( + -> ( let s = name_info.Clang_ast_t.ni_name in match CTrans_models.is_dispatch_function_name s with - | None - -> None + | None -> + None | Some (_, block_arg_pos) -> try let arg_stmt = List.nth_exn arg_stmts block_arg_pos in if is_block_stmt arg_stmt then Some block_arg_pos else None with Invalid_argument _ -> None ) - | _ - -> None ) + | _ -> + None ) | _ -> match snd (Clang_ast_proj.get_stmt_tuple stmt) with - | [sub_stmt] - -> is_dispatch_function sub_stmt arg_stmts - | _ - -> None + | [sub_stmt] -> + is_dispatch_function sub_stmt arg_stmts + | _ -> + None in match stmt_list with stmt :: arg_stmts -> is_dispatch_function stmt arg_stmts | _ -> None + let is_block_enumerate_function mei = String.equal mei.Clang_ast_t.omei_selector CFrontend_config.enumerateObjectsUsingBlock + (* (** Similar to extract_item_from_singleton but for option type *) let extract_item_from_option op warning_string = diff --git a/infer/src/clang/cType_to_sil_type.ml b/infer/src/clang/cType_to_sil_type.ml index 8b16366c1..a2ea35cf3 100644 --- a/infer/src/clang/cType_to_sil_type.ml +++ b/infer/src/clang/cType_to_sil_type.ml @@ -12,76 +12,80 @@ module L = Logging let get_builtin_objc_typename builtin_type = match builtin_type with - | `ObjCId - -> Typ.Name.C.from_string CFrontend_config.objc_object - | `ObjCClass - -> Typ.Name.C.from_string CFrontend_config.objc_class + | `ObjCId -> + Typ.Name.C.from_string CFrontend_config.objc_object + | `ObjCClass -> + Typ.Name.C.from_string CFrontend_config.objc_class + let get_builtin_objc_type builtin_type = let typ = Typ.mk (Tstruct (get_builtin_objc_typename builtin_type)) in match builtin_type with `ObjCId -> typ.Typ.desc | `ObjCClass -> Typ.Tptr (typ, Typ.Pk_pointer) + let type_desc_of_builtin_type_kind builtin_type_kind = match builtin_type_kind with - | `Void - -> Typ.Tvoid - | `Bool - -> Typ.Tint IBool - | `Char_U - -> Typ.Tint IUChar - | `UChar - -> Typ.Tint IUChar - | `WChar_U - -> Typ.Tint IUChar - | `Char_S - -> Typ.Tint IChar - | `SChar - -> Typ.Tint ISChar - | `WChar_S | `Char16 | `Char32 - -> Typ.Tint IChar - | `UShort - -> Typ.Tint IUShort - | `Short - -> Typ.Tint IShort - | `UInt | `UInt128 - -> Typ.Tint IUInt - | `ULong - -> Typ.Tint IULong - | `ULongLong - -> Typ.Tint IULongLong - | `Int | `Int128 - -> Typ.Tint IInt - | `Long - -> Typ.Tint ILong - | `LongLong - -> Typ.Tint ILongLong - | `Half - -> Typ.Tint IShort (*?*) - | `Float - -> Typ.Tfloat FFloat - | `Double - -> Typ.Tfloat FDouble - | `LongDouble - -> Typ.Tfloat FLongDouble - | `NullPtr - -> Typ.Tint IInt - | `ObjCId - -> get_builtin_objc_type `ObjCId - | `ObjCClass - -> get_builtin_objc_type `ObjCClass - | _ - -> Typ.Tvoid + | `Void -> + Typ.Tvoid + | `Bool -> + Typ.Tint IBool + | `Char_U -> + Typ.Tint IUChar + | `UChar -> + Typ.Tint IUChar + | `WChar_U -> + Typ.Tint IUChar + | `Char_S -> + Typ.Tint IChar + | `SChar -> + Typ.Tint ISChar + | `WChar_S | `Char16 | `Char32 -> + Typ.Tint IChar + | `UShort -> + Typ.Tint IUShort + | `Short -> + Typ.Tint IShort + | `UInt | `UInt128 -> + Typ.Tint IUInt + | `ULong -> + Typ.Tint IULong + | `ULongLong -> + Typ.Tint IULongLong + | `Int | `Int128 -> + Typ.Tint IInt + | `Long -> + Typ.Tint ILong + | `LongLong -> + Typ.Tint ILongLong + | `Half -> + Typ.Tint IShort (*?*) + | `Float -> + Typ.Tfloat FFloat + | `Double -> + Typ.Tfloat FDouble + | `LongDouble -> + Typ.Tfloat FLongDouble + | `NullPtr -> + Typ.Tint IInt + | `ObjCId -> + get_builtin_objc_type `ObjCId + | `ObjCClass -> + get_builtin_objc_type `ObjCClass + | _ -> + Typ.Tvoid + let pointer_attribute_of_objc_attribute attr_info = match attr_info.Clang_ast_t.ati_lifetime with - | `OCL_None | `OCL_Strong - -> Typ.Pk_pointer - | `OCL_ExplicitNone - -> Typ.Pk_objc_unsafe_unretained - | `OCL_Weak - -> Typ.Pk_objc_weak - | `OCL_Autoreleasing - -> Typ.Pk_objc_autoreleasing + | `OCL_None | `OCL_Strong -> + Typ.Pk_pointer + | `OCL_ExplicitNone -> + Typ.Pk_objc_unsafe_unretained + | `OCL_Weak -> + Typ.Pk_objc_weak + | `OCL_Autoreleasing -> + Typ.Pk_objc_autoreleasing + let rec build_array_type translate_decl tenv (qual_type: Clang_ast_t.qual_type) length_opt stride_opt = @@ -90,74 +94,77 @@ let rec build_array_type translate_decl tenv (qual_type: Clang_ast_t.qual_type) let stride = Option.map ~f:IntLit.of_int stride_opt in Typ.Tarray (array_type, length, stride) + and type_desc_of_attr_type translate_decl tenv type_info attr_info = match type_info.Clang_ast_t.ti_desugared_type with | Some type_ptr -> ( match CAst_utils.get_type type_ptr with - | Some Clang_ast_t.ObjCObjectPointerType (_, qual_type) - -> let typ = qual_type_to_sil_type translate_decl tenv qual_type in + | Some Clang_ast_t.ObjCObjectPointerType (_, qual_type) -> + let typ = qual_type_to_sil_type translate_decl tenv qual_type in Typ.Tptr (typ, pointer_attribute_of_objc_attribute attr_info) - | _ - -> type_ptr_to_type_desc translate_decl tenv type_ptr ) - | None - -> Typ.Tvoid + | _ -> + type_ptr_to_type_desc translate_decl tenv type_ptr ) + | None -> + Typ.Tvoid + and type_desc_of_c_type translate_decl tenv c_type : Typ.desc = let open Clang_ast_t in match c_type with - | NoneType _ - -> Tvoid - | BuiltinType (_, builtin_type_kind) - -> type_desc_of_builtin_type_kind builtin_type_kind - | PointerType (_, qual_type) | ObjCObjectPointerType (_, qual_type) - -> let typ = qual_type_to_sil_type translate_decl tenv qual_type in + | NoneType _ -> + Tvoid + | BuiltinType (_, builtin_type_kind) -> + type_desc_of_builtin_type_kind builtin_type_kind + | PointerType (_, qual_type) | ObjCObjectPointerType (_, qual_type) -> + let typ = qual_type_to_sil_type translate_decl tenv qual_type in let desc = typ.Typ.desc in if Typ.equal_desc desc (get_builtin_objc_type `ObjCClass) then desc else Typ.Tptr (typ, Typ.Pk_pointer) - | ObjCObjectType (_, objc_object_type_info) - -> type_ptr_to_type_desc translate_decl tenv objc_object_type_info.Clang_ast_t.ooti_base_type - | BlockPointerType (_, qual_type) - -> let typ = qual_type_to_sil_type translate_decl tenv qual_type in + | ObjCObjectType (_, objc_object_type_info) -> + type_ptr_to_type_desc translate_decl tenv objc_object_type_info.Clang_ast_t.ooti_base_type + | BlockPointerType (_, qual_type) -> + let typ = qual_type_to_sil_type translate_decl tenv qual_type in Typ.Tptr (typ, Typ.Pk_pointer) | IncompleteArrayType (_, {arti_element_type; arti_stride}) - | DependentSizedArrayType (_, {arti_element_type; arti_stride}) - -> build_array_type translate_decl tenv arti_element_type None arti_stride - | VariableArrayType (_, {arti_element_type; arti_stride}, _) - -> build_array_type translate_decl tenv arti_element_type None arti_stride - | ConstantArrayType (_, {arti_element_type; arti_stride}, n) - -> build_array_type translate_decl tenv arti_element_type (Some n) arti_stride - | FunctionProtoType _ | FunctionNoProtoType _ - -> Typ.Tfun false - | ParenType (_, qual_type) - -> (qual_type_to_sil_type translate_decl tenv qual_type).Typ.desc - | DecayedType (_, qual_type) - -> (qual_type_to_sil_type translate_decl tenv qual_type).Typ.desc - | RecordType (_, pointer) | EnumType (_, pointer) - -> decl_ptr_to_type_desc translate_decl tenv pointer + | DependentSizedArrayType (_, {arti_element_type; arti_stride}) -> + build_array_type translate_decl tenv arti_element_type None arti_stride + | VariableArrayType (_, {arti_element_type; arti_stride}, _) -> + build_array_type translate_decl tenv arti_element_type None arti_stride + | ConstantArrayType (_, {arti_element_type; arti_stride}, n) -> + build_array_type translate_decl tenv arti_element_type (Some n) arti_stride + | FunctionProtoType _ | FunctionNoProtoType _ -> + Typ.Tfun false + | ParenType (_, qual_type) -> + (qual_type_to_sil_type translate_decl tenv qual_type).Typ.desc + | DecayedType (_, qual_type) -> + (qual_type_to_sil_type translate_decl tenv qual_type).Typ.desc + | RecordType (_, pointer) | EnumType (_, pointer) -> + decl_ptr_to_type_desc translate_decl tenv pointer | ElaboratedType type_info -> ( match type_info.Clang_ast_t.ti_desugared_type with (* TODO desugar to qualtype *) - | Some type_ptr - -> type_ptr_to_type_desc translate_decl tenv type_ptr - | None - -> Typ.Tvoid ) - | ObjCInterfaceType (_, pointer) - -> decl_ptr_to_type_desc translate_decl tenv pointer - | RValueReferenceType (_, qual_type) | LValueReferenceType (_, qual_type) - -> let typ = qual_type_to_sil_type translate_decl tenv qual_type in + | Some type_ptr -> + type_ptr_to_type_desc translate_decl tenv type_ptr + | None -> + Typ.Tvoid ) + | ObjCInterfaceType (_, pointer) -> + decl_ptr_to_type_desc translate_decl tenv pointer + | RValueReferenceType (_, qual_type) | LValueReferenceType (_, qual_type) -> + let typ = qual_type_to_sil_type translate_decl tenv qual_type in Typ.Tptr (typ, Typ.Pk_reference) - | AttributedType (type_info, attr_info) - -> (* TODO desugar to qualtyp *) + | AttributedType (type_info, attr_info) -> + (* TODO desugar to qualtyp *) type_desc_of_attr_type translate_decl tenv type_info attr_info - | _ - -> (* TypedefType, etc *) + | _ -> + (* TypedefType, etc *) let type_info = Clang_ast_proj.get_type_tuple c_type in match type_info.Clang_ast_t.ti_desugared_type with (* TODO desugar typedeftype to qualtype *) - | Some typ - -> type_ptr_to_type_desc translate_decl tenv typ - | None - -> Typ.Tvoid + | Some typ -> + type_ptr_to_type_desc translate_decl tenv typ + | None -> + Typ.Tvoid + and decl_ptr_to_type_desc translate_decl tenv decl_ptr : Typ.desc = let open Clang_ast_t in @@ -173,49 +180,56 @@ and decl_ptr_to_type_desc translate_decl tenv decl_ptr : Typ.desc = | Some (ObjCProtocolDecl _ as d) | Some (ObjCCategoryDecl _ as d) | Some (ObjCCategoryImplDecl _ as d) - | Some (EnumDecl _ as d) - -> translate_decl tenv d - | Some _ - -> L.(debug Capture Verbose) - "Warning: Wrong decl found for pointer %s " (Clang_ast_j.string_of_pointer decl_ptr) ; + | Some (EnumDecl _ as d) -> + translate_decl tenv d + | Some _ -> + L.(debug Capture Verbose) + "Warning: Wrong decl found for pointer %s " + (Clang_ast_j.string_of_pointer decl_ptr) ; Typ.Tvoid - | None - -> L.(debug Capture Verbose) - "Warning: Decl pointer %s not found." (Clang_ast_j.string_of_pointer decl_ptr) ; + | None -> + L.(debug Capture Verbose) + "Warning: Decl pointer %s not found." + (Clang_ast_j.string_of_pointer decl_ptr) ; Typ.Tvoid + and clang_type_ptr_to_type_desc translate_decl tenv type_ptr = try Clang_ast_extend.TypePointerMap.find type_ptr !CFrontend_config.sil_types_map with Not_found -> match CAst_utils.get_type type_ptr with - | Some c_type - -> let type_desc = type_desc_of_c_type translate_decl tenv c_type in - CAst_utils.update_sil_types_map type_ptr type_desc ; type_desc - | _ - -> Typ.Tvoid + | Some c_type -> + let type_desc = type_desc_of_c_type translate_decl tenv c_type in + CAst_utils.update_sil_types_map type_ptr type_desc ; + type_desc + | _ -> + Typ.Tvoid + and type_ptr_to_type_desc translate_decl tenv type_ptr : Typ.desc = match type_ptr with - | Clang_ast_types.TypePtr.Ptr _ - -> clang_type_ptr_to_type_desc translate_decl tenv type_ptr - | Clang_ast_extend.Builtin kind - -> type_desc_of_builtin_type_kind kind - | Clang_ast_extend.PointerOf typ - -> let sil_typ = qual_type_to_sil_type translate_decl tenv typ in + | Clang_ast_types.TypePtr.Ptr _ -> + clang_type_ptr_to_type_desc translate_decl tenv type_ptr + | Clang_ast_extend.Builtin kind -> + type_desc_of_builtin_type_kind kind + | Clang_ast_extend.PointerOf typ -> + let sil_typ = qual_type_to_sil_type translate_decl tenv typ in Typ.Tptr (sil_typ, Pk_pointer) - | Clang_ast_extend.ReferenceOf typ - -> let sil_typ = qual_type_to_sil_type translate_decl tenv typ in + | Clang_ast_extend.ReferenceOf typ -> + let sil_typ = qual_type_to_sil_type translate_decl tenv typ in Typ.Tptr (sil_typ, Pk_reference) - | Clang_ast_extend.ClassType typename - -> Typ.Tstruct typename - | Clang_ast_extend.DeclPtr ptr - -> decl_ptr_to_type_desc translate_decl tenv ptr - | Clang_ast_extend.ErrorType - -> Typ.Tvoid - | _ - -> L.(die InternalError) "unknown variant for type_ptr" + | Clang_ast_extend.ClassType typename -> + Typ.Tstruct typename + | Clang_ast_extend.DeclPtr ptr -> + decl_ptr_to_type_desc translate_decl tenv ptr + | Clang_ast_extend.ErrorType -> + Typ.Tvoid + | _ -> + L.(die InternalError) "unknown variant for type_ptr" + and qual_type_to_sil_type translate_decl tenv qual_type = let desc = type_ptr_to_type_desc translate_decl tenv qual_type.Clang_ast_t.qt_type_ptr in let quals = Typ.mk_type_quals ~is_const:qual_type.Clang_ast_t.qt_is_const () in Typ.mk ~quals desc + diff --git a/infer/src/clang/cVar_decl.ml b/infer/src/clang/cVar_decl.ml index acb5d54f7..034b2aeb4 100644 --- a/infer/src/clang/cVar_decl.ml +++ b/infer/src/clang/cVar_decl.ml @@ -23,93 +23,100 @@ let sil_var_of_decl context var_decl procname = let trans_unit_ctx = context.CContext.translation_unit_context in let open Clang_ast_t in match var_decl with - | VarDecl (decl_info, name_info, qual_type, var_decl_info) - -> let shoud_be_mangled = not (is_custom_var_pointer decl_info.Clang_ast_t.di_pointer) in + | VarDecl (decl_info, name_info, qual_type, var_decl_info) -> + let shoud_be_mangled = not (is_custom_var_pointer decl_info.Clang_ast_t.di_pointer) in let var_decl_details = Some (decl_info, qual_type, var_decl_info, shoud_be_mangled) in CGeneral_utils.mk_sil_var trans_unit_ctx name_info var_decl_details procname outer_procname - | ParmVarDecl (decl_info, name_info, qual_type, var_decl_info) - -> let var_decl_details = Some (decl_info, qual_type, var_decl_info, false) in + | ParmVarDecl (decl_info, name_info, qual_type, var_decl_info) -> + let var_decl_details = Some (decl_info, qual_type, var_decl_info, false) in CGeneral_utils.mk_sil_var trans_unit_ctx name_info var_decl_details procname outer_procname - | _ - -> assert false + | _ -> + assert false + let sil_var_of_decl_ref context decl_ref procname = let name = match decl_ref.Clang_ast_t.dr_name with Some name_info -> name_info | None -> assert false in match decl_ref.Clang_ast_t.dr_kind with - | `ImplicitParam - -> let outer_procname = CContext.get_outer_procname context in + | `ImplicitParam -> + let outer_procname = CContext.get_outer_procname context in let trans_unit_ctx = context.CContext.translation_unit_context in CGeneral_utils.mk_sil_var trans_unit_ctx name None procname outer_procname - | _ - -> let pointer = decl_ref.Clang_ast_t.dr_decl_pointer in + | _ -> + let pointer = decl_ref.Clang_ast_t.dr_decl_pointer in if is_custom_var_pointer pointer then Pvar.mk (Mangled.from_string name.Clang_ast_t.ni_name) procname else match CAst_utils.get_decl pointer with - | Some var_decl - -> sil_var_of_decl context var_decl procname - | None - -> (* FIXME(t21762295) *) + | Some var_decl -> + sil_var_of_decl context var_decl procname + | None -> + (* FIXME(t21762295) *) CFrontend_config.incorrect_assumption "pointer '%d' for var decl not found. The var decl was: %a" pointer - (Pp.to_string ~f:Clang_ast_j.string_of_decl_ref) decl_ref + (Pp.to_string ~f:Clang_ast_j.string_of_decl_ref) + decl_ref + let add_var_to_locals procdesc var_decl sil_typ pvar = let open Clang_ast_t in match var_decl with - | VarDecl (_, _, _, vdi) - -> if not vdi.Clang_ast_t.vdi_is_global then + | VarDecl (_, _, _, vdi) -> + if not vdi.Clang_ast_t.vdi_is_global then Procdesc.append_locals procdesc [(Pvar.get_name pvar, sil_typ)] - | _ - -> assert false + | _ -> + assert false + let compute_autorelease_pool_vars context stmts = let rec do_stmts map = function - | [] - -> map - | (Clang_ast_t.DeclRefExpr (_, _, _, drei)) :: stmts' - -> let map1 = + | [] -> + map + | (Clang_ast_t.DeclRefExpr (_, _, _, drei)) :: stmts' -> + let map1 = match drei.Clang_ast_t.drti_decl_ref with | Some decl_ref -> ( match decl_ref.Clang_ast_t.dr_qual_type with - | Some qual_type when decl_ref.Clang_ast_t.dr_kind = `Var - -> let typ = CType_decl.qual_type_to_sil_type context.CContext.tenv qual_type in + | Some qual_type when decl_ref.Clang_ast_t.dr_kind = `Var -> + let typ = CType_decl.qual_type_to_sil_type context.CContext.tenv qual_type in let procname = Procdesc.get_proc_name context.CContext.procdesc in let pvar = sil_var_of_decl_ref context decl_ref procname in if Pvar.is_local pvar then Exp.Map.add (Exp.Lvar pvar) typ map else map - | _ - -> map ) - | None - -> map + | _ -> + map ) + | None -> + map in do_stmts map1 stmts' - | s :: stmts' - -> let sl = snd (Clang_ast_proj.get_stmt_tuple s) in + | s :: stmts' -> + let sl = snd (Clang_ast_proj.get_stmt_tuple s) in let map1 = do_stmts map sl in do_stmts map1 stmts' in Exp.Map.bindings (do_stmts Exp.Map.empty stmts) + let sil_var_of_captured_var decl_ref context procname = match decl_ref with - | {Clang_ast_t.dr_qual_type= Some qual_type} - -> ( sil_var_of_decl_ref context decl_ref procname + | {Clang_ast_t.dr_qual_type= Some qual_type} -> + ( sil_var_of_decl_ref context decl_ref procname , CType_decl.qual_type_to_sil_type context.CContext.tenv qual_type ) - | _ - -> assert false + | _ -> + assert false + (* Returns a list of captured variables as sil variables. *) let captured_vars_from_block_info context cvl = let procname = Procdesc.get_proc_name context.CContext.procdesc in let sil_var_of_captured_var {Clang_ast_t.bcv_variable} vars_acc = match bcv_variable with - | Some ({Clang_ast_t.dr_name= Some {Clang_ast_t.ni_name}} as decl_ref) - -> if String.equal ni_name CFrontend_config.self && not (CContext.is_objc_instance context) + | Some ({Clang_ast_t.dr_name= Some {Clang_ast_t.ni_name}} as decl_ref) -> + if String.equal ni_name CFrontend_config.self && not (CContext.is_objc_instance context) then vars_acc else sil_var_of_captured_var decl_ref context procname :: vars_acc - | _ - -> assert false + | _ -> + assert false in List.fold_right ~f:sil_var_of_captured_var cvl ~init:[] + diff --git a/infer/src/clang/clang_ast_extend.ml b/infer/src/clang/clang_ast_extend.ml index ee6a41772..ae31d3ff0 100644 --- a/infer/src/clang/clang_ast_extend.ml +++ b/infer/src/clang/clang_ast_extend.ml @@ -23,81 +23,89 @@ type Clang_ast_types.TypePtr.t += | ErrorType let rec type_ptr_to_string = function - | Clang_ast_types.TypePtr.Ptr raw - -> "clang_ptr_" ^ string_of_int raw - | Builtin t - -> "sil_" ^ Clang_ast_j.string_of_builtin_type_kind t - | PointerOf typ - -> "pointer_of_" ^ type_ptr_to_string typ.Clang_ast_t.qt_type_ptr - | ReferenceOf typ - -> "reference_of_" ^ type_ptr_to_string typ.Clang_ast_t.qt_type_ptr - | ClassType name - -> "class_name_" ^ Typ.Name.name name - | DeclPtr raw - -> "decl_ptr_" ^ string_of_int raw - | ErrorType - -> "error_type" - | _ - -> "unknown" + | Clang_ast_types.TypePtr.Ptr raw -> + "clang_ptr_" ^ string_of_int raw + | Builtin t -> + "sil_" ^ Clang_ast_j.string_of_builtin_type_kind t + | PointerOf typ -> + "pointer_of_" ^ type_ptr_to_string typ.Clang_ast_t.qt_type_ptr + | ReferenceOf typ -> + "reference_of_" ^ type_ptr_to_string typ.Clang_ast_t.qt_type_ptr + | ClassType name -> + "class_name_" ^ Typ.Name.name name + | DeclPtr raw -> + "decl_ptr_" ^ string_of_int raw + | ErrorType -> + "error_type" + | _ -> + "unknown" + module TypePointerOrd = struct type t = Clang_ast_types.TypePtr.t let rec compare a1 a2 = match (a1, a2) with - | _ when phys_equal a1 a2 - -> 0 - | Clang_ast_types.TypePtr.Ptr a, Clang_ast_types.TypePtr.Ptr b - -> Int.compare a b - | Clang_ast_types.TypePtr.Ptr _, _ - -> 1 - | _, Clang_ast_types.TypePtr.Ptr _ - -> -1 - | Builtin a, Builtin b - -> Polymorphic_compare.compare a b - | Builtin _, _ - -> 1 - | _, Builtin _ - -> -1 - | PointerOf a, PointerOf b - -> compare_qual_type a b - | PointerOf _, _ - -> 1 - | _, PointerOf _ - -> -1 - | ReferenceOf a, ReferenceOf b - -> compare_qual_type a b - | ReferenceOf _, _ - -> 1 - | _, ReferenceOf _ - -> -1 - | ClassType a, ClassType b - -> Typ.Name.compare a b - | ClassType _, _ - -> 1 - | _, ClassType _ - -> -1 - | DeclPtr a, DeclPtr b - -> Int.compare a b - | DeclPtr _, _ - -> 1 - | _, DeclPtr _ - -> -1 - | ErrorType, ErrorType - -> 0 - | t1, t2 - -> L.(die InternalError) + | _ when phys_equal a1 a2 -> + 0 + | Clang_ast_types.TypePtr.Ptr a, Clang_ast_types.TypePtr.Ptr b -> + Int.compare a b + | Clang_ast_types.TypePtr.Ptr _, _ -> + 1 + | _, Clang_ast_types.TypePtr.Ptr _ -> + -1 + | Builtin a, Builtin b -> + Polymorphic_compare.compare a b + | Builtin _, _ -> + 1 + | _, Builtin _ -> + -1 + | PointerOf a, PointerOf b -> + compare_qual_type a b + | PointerOf _, _ -> + 1 + | _, PointerOf _ -> + -1 + | ReferenceOf a, ReferenceOf b -> + compare_qual_type a b + | ReferenceOf _, _ -> + 1 + | _, ReferenceOf _ -> + -1 + | ClassType a, ClassType b -> + Typ.Name.compare a b + | ClassType _, _ -> + 1 + | _, ClassType _ -> + -1 + | DeclPtr a, DeclPtr b -> + Int.compare a b + | DeclPtr _, _ -> + 1 + | _, DeclPtr _ -> + -1 + | ErrorType, ErrorType -> + 0 + | t1, t2 -> + L.(die InternalError) "unexpected type_ptr variants: %s, %s" (type_ptr_to_string t1) (type_ptr_to_string t2) + and compare_qual_type (qt1: Clang_ast_t.qual_type) (qt2: Clang_ast_t.qual_type) = if phys_equal qt1 qt2 then 0 else (* enable warning here to warn and update comparison funtion when new field is added *) - let {Clang_ast_t.qt_type_ptr= t1; qt_is_const= c1; qt_is_restrict= r1; qt_is_volatile= v1} = - qt1 [@@warning "+9"] + let[@warning "+9"] { Clang_ast_t.qt_type_ptr= t1 + ; qt_is_const= c1 + ; qt_is_restrict= r1 + ; qt_is_volatile= v1 } = + qt1 in - let {Clang_ast_t.qt_type_ptr= t2; qt_is_const= c2; qt_is_restrict= r2; qt_is_volatile= v2} = - qt2 [@@warning "+9"] + let[@warning "+9"] { Clang_ast_t.qt_type_ptr= t2 + ; qt_is_const= c2 + ; qt_is_restrict= r2 + ; qt_is_volatile= v2 } = + qt2 in let qt_cmp = compare t1 t2 in if qt_cmp <> 0 then qt_cmp @@ -107,6 +115,7 @@ module TypePointerOrd = struct else let restrict_cmp = Bool.compare r1 r2 in if restrict_cmp <> 0 then restrict_cmp else Bool.compare v1 v2 + end module TypePointerMap = Caml.Map.Make (TypePointerOrd) diff --git a/infer/src/clang/ctl_parser_types.ml b/infer/src/clang/ctl_parser_types.ml index b9bfad245..4e3ae144b 100644 --- a/infer/src/clang/ctl_parser_types.ml +++ b/infer/src/clang/ctl_parser_types.ml @@ -19,101 +19,106 @@ let rec ast_node_name an = match an with | Decl dec -> ( match Clang_ast_proj.get_named_decl_tuple dec with - | Some (_, n) - -> n.Clang_ast_t.ni_name - | None - -> "" ) + | Some (_, n) -> + n.Clang_ast_t.ni_name + | None -> + "" ) | Stmt DeclRefExpr (_, _, _, drti) -> ( match drti.drti_decl_ref with - | Some dr - -> let ndi, _, _ = CAst_utils.get_info_from_decl_ref dr in + | Some dr -> + let ndi, _, _ = CAst_utils.get_info_from_decl_ref dr in ndi.ni_name - | _ - -> "" ) - | Stmt ObjCIvarRefExpr (_, _, _, obj_c_ivar_ref_expr_info) - -> let ndi, _, _ = CAst_utils.get_info_from_decl_ref obj_c_ivar_ref_expr_info.ovrei_decl_ref in + | _ -> + "" ) + | Stmt ObjCIvarRefExpr (_, _, _, obj_c_ivar_ref_expr_info) -> + let ndi, _, _ = CAst_utils.get_info_from_decl_ref obj_c_ivar_ref_expr_info.ovrei_decl_ref in ndi.ni_name - | Stmt ObjCMessageExpr (_, _, _, {omei_selector}) - -> omei_selector - | Stmt IntegerLiteral (_, _, _, integer_literal_info) - -> integer_literal_info.ili_value + | Stmt ObjCMessageExpr (_, _, _, {omei_selector}) -> + omei_selector + | Stmt IntegerLiteral (_, _, _, integer_literal_info) -> + integer_literal_info.ili_value | Stmt CStyleCastExpr (_, _, _, cast_expr_info, _) -> ( match cast_expr_info.cei_cast_kind with `NullToPointer -> "nil" | _ -> "" ) - | Stmt ObjCSubscriptRefExpr (_, [stmt; stmt_index], _, _) - -> ast_node_name (Stmt stmt) ^ "[" ^ ast_node_name (Stmt stmt_index) ^ "]" + | Stmt ObjCSubscriptRefExpr (_, [stmt; stmt_index], _, _) -> + ast_node_name (Stmt stmt) ^ "[" ^ ast_node_name (Stmt stmt_index) ^ "]" | Stmt OpaqueValueExpr (_, _, _, opaque_value_expr_info) -> ( match opaque_value_expr_info.ovei_source_expr with - | Some stmt - -> ast_node_name (Stmt stmt) - | None - -> "" ) + | Some stmt -> + ast_node_name (Stmt stmt) + | None -> + "" ) | Stmt ImplicitCastExpr (_, [stmt], _, _) | Stmt PseudoObjectExpr (_, stmt :: _, _) - | Stmt ParenExpr (_, [stmt], _) - -> ast_node_name (Stmt stmt) - | Stmt CallExpr (_, func :: _, _) - -> let func_str = ast_node_name (Stmt func) in + | Stmt ParenExpr (_, [stmt], _) -> + ast_node_name (Stmt stmt) + | Stmt CallExpr (_, func :: _, _) -> + let func_str = ast_node_name (Stmt func) in func_str ^ "(...)" - | Stmt ObjCPropertyRefExpr (_, [stmt], _, obj_c_property_ref_expr_info) - -> let property_str = + | Stmt ObjCPropertyRefExpr (_, [stmt], _, obj_c_property_ref_expr_info) -> + let property_str = match obj_c_property_ref_expr_info.oprei_kind with | `MethodRef obj_c_method_ref_info -> ( match (obj_c_method_ref_info.mri_getter, obj_c_method_ref_info.mri_setter) with - | Some name, _ - -> name - | _, Some name - -> name - | _ - -> "" ) + | Some name, _ -> + name + | _, Some name -> + name + | _ -> + "" ) | `PropertyRef decl_ref -> match decl_ref.dr_name with Some name -> name.ni_name | None -> "" in ast_node_name (Stmt stmt) ^ "." ^ property_str - | Stmt StringLiteral (_, _, _, l) - -> String.concat ~sep:"" l - | Stmt ObjCStringLiteral (_, [stmt], _) - -> "@" ^ ast_node_name (Stmt stmt) - | Stmt ObjCBoxedExpr (_, [stmt], _, objc_boxed_expr_info) - -> let selector = + | Stmt StringLiteral (_, _, _, l) -> + String.concat ~sep:"" l + | Stmt ObjCStringLiteral (_, [stmt], _) -> + "@" ^ ast_node_name (Stmt stmt) + | Stmt ObjCBoxedExpr (_, [stmt], _, objc_boxed_expr_info) -> + let selector = match objc_boxed_expr_info.obei_boxing_method with Some sel -> sel | None -> "" in selector ^ ast_node_name (Stmt stmt) - | _ - -> "" + | _ -> + "" + let ast_node_kind node = match node with - | Stmt stmt - -> Clang_ast_proj.get_stmt_kind_string stmt - | Decl decl - -> Clang_ast_proj.get_decl_kind_string decl + | Stmt stmt -> + Clang_ast_proj.get_stmt_kind_string stmt + | Decl decl -> + Clang_ast_proj.get_decl_kind_string decl + (* true iff an ast node is a node of type among the list tl *) let ast_node_has_kind tl an = let an_alexp = ALVar.Const (ast_node_kind an) in List.mem ~equal:ALVar.equal tl an_alexp + let ast_node_pointer node = match node with - | Stmt stmt - -> let s_stmt_info, _ = Clang_ast_proj.get_stmt_tuple stmt in + | Stmt stmt -> + let s_stmt_info, _ = Clang_ast_proj.get_stmt_tuple stmt in s_stmt_info.si_pointer - | Decl decl - -> let d_decl_info = Clang_ast_proj.get_decl_tuple decl in + | Decl decl -> + let d_decl_info = Clang_ast_proj.get_decl_tuple decl in d_decl_info.di_pointer + let ast_node_unique_string_id an = Printf.sprintf "%s %d" (ast_node_kind an) (ast_node_pointer an) let ast_node_cast_kind an = match an with - | Decl _ - -> "" + | Decl _ -> + "" | Stmt stmt -> match Clang_ast_proj.get_cast_kind stmt with - | Some cast_kind - -> Clang_ast_proj.string_of_cast_kind cast_kind - | None - -> "" + | Some cast_kind -> + Clang_ast_proj.string_of_cast_kind cast_kind + | None -> + "" + let ast_node_equal node1 node2 = Int.equal (ast_node_pointer node1) (ast_node_pointer node2) @@ -121,35 +126,38 @@ let get_successor_stmts_of_stmt stmt = let _, node_succ_stmts = Clang_ast_proj.get_stmt_tuple stmt in node_succ_stmts + let get_successor_decls_of_stmt stmt = let open Clang_ast_t in match stmt with - | DeclStmt (_, _, succ_decls) - -> succ_decls - | BlockExpr (_, _, _, decl) - -> [decl] - | _ - -> [] + | DeclStmt (_, _, succ_decls) -> + succ_decls + | BlockExpr (_, _, _, decl) -> + [decl] + | _ -> + [] + let get_successor_decls_of_decl decl = let open Clang_ast_t in match Clang_ast_proj.get_decl_context_tuple decl with - | Some (decls, _) - -> decls + | Some (decls, _) -> + decls | None -> match decl with | FunctionDecl (_, _, _, fdi) | CXXMethodDecl (_, _, _, fdi, _) | CXXConstructorDecl (_, _, _, fdi, _) | CXXConversionDecl (_, _, _, fdi, _) - | CXXDestructorDecl (_, _, _, fdi, _) - -> fdi.Clang_ast_t.fdi_parameters - | ObjCMethodDecl (_, _, mdi) - -> mdi.Clang_ast_t.omdi_parameters - | BlockDecl (_, block_decl_info) - -> block_decl_info.Clang_ast_t.bdi_parameters - | _ - -> [] + | CXXDestructorDecl (_, _, _, fdi, _) -> + fdi.Clang_ast_t.fdi_parameters + | ObjCMethodDecl (_, _, mdi) -> + mdi.Clang_ast_t.omdi_parameters + | BlockDecl (_, block_decl_info) -> + block_decl_info.Clang_ast_t.bdi_parameters + | _ -> + [] + let get_successor_stmts_of_decl decl = let open Clang_ast_t in @@ -158,50 +166,54 @@ let get_successor_stmts_of_decl decl = | CXXMethodDecl (_, _, _, fdi, _) | CXXConstructorDecl (_, _, _, fdi, _) | CXXConversionDecl (_, _, _, fdi, _) - | CXXDestructorDecl (_, _, _, fdi, _) - -> Option.to_list fdi.Clang_ast_t.fdi_body - | ObjCMethodDecl (_, _, mdi) - -> Option.to_list mdi.Clang_ast_t.omdi_body - | BlockDecl (_, block_decl_info) - -> Option.to_list block_decl_info.Clang_ast_t.bdi_body - | VarDecl (_, _, _, var_decl_info) - -> Option.to_list var_decl_info.vdi_init_expr + | CXXDestructorDecl (_, _, _, fdi, _) -> + Option.to_list fdi.Clang_ast_t.fdi_body + | ObjCMethodDecl (_, _, mdi) -> + Option.to_list mdi.Clang_ast_t.omdi_body + | BlockDecl (_, block_decl_info) -> + Option.to_list block_decl_info.Clang_ast_t.bdi_body + | VarDecl (_, _, _, var_decl_info) -> + Option.to_list var_decl_info.vdi_init_expr | ObjCIvarDecl (_, _, _, fldi, _) | FieldDecl (_, _, _, fldi) - | ObjCAtDefsFieldDecl (_, _, _, fldi) - -> Option.to_list fldi.fldi_init_expr - | _ - -> [] + | ObjCAtDefsFieldDecl (_, _, _, fldi) -> + Option.to_list fldi.fldi_init_expr + | _ -> + [] + let get_successor_stmts an = match an with - | Stmt stmt - -> get_successor_stmts_of_stmt stmt - | Decl decl - -> get_successor_stmts_of_decl decl + | Stmt stmt -> + get_successor_stmts_of_stmt stmt + | Decl decl -> + get_successor_stmts_of_decl decl + let get_successor_decls an = match an with - | Stmt stmt - -> get_successor_decls_of_stmt stmt - | Decl decl - -> get_successor_decls_of_decl decl + | Stmt stmt -> + get_successor_decls_of_stmt stmt + | Decl decl -> + get_successor_decls_of_decl decl + (* Either succ_node is a direct successor of node or succ_node is a successor of one of the successors of node *) let rec is_node_successor_of ~is_successor:succ_node node = match succ_node with - | Stmt _ - -> let node_succ_stmts = get_successor_stmts node in + | Stmt _ -> + let node_succ_stmts = get_successor_stmts node in List.exists node_succ_stmts ~f:(fun (s: Clang_ast_t.stmt) -> ast_node_equal (Stmt s) succ_node || is_node_successor_of ~is_successor:succ_node (Stmt s) ) - | Decl _ - -> let node_succ_decls = get_successor_decls node in + | Decl _ -> + let node_succ_decls = get_successor_decls node in List.exists node_succ_decls ~f:(fun (d: Clang_ast_t.decl) -> ast_node_equal (Decl d) succ_node || is_node_successor_of ~is_successor:succ_node (Decl d) ) + let get_direct_successor_nodes an = (* get_decl_of_stmt get declarations that are directly embedded as immediate children (i.e. distance 1) of an stmt (i.e., no transition). @@ -211,16 +223,17 @@ let get_direct_successor_nodes an = match st with Clang_ast_t.BlockExpr (_, _, _, d) -> [Decl d] | _ -> [] in match an with - | Stmt st - -> let _, succs_st = Clang_ast_proj.get_stmt_tuple st in + | Stmt st -> + let _, succs_st = Clang_ast_proj.get_stmt_tuple st in let succs = List.map ~f:(fun s -> Stmt s) succs_st in succs @ get_decl_of_stmt st | Decl dec -> match Clang_ast_proj.get_decl_context_tuple dec with - | Some (decl_list, _) - -> List.map ~f:(fun d -> Decl d) decl_list - | None - -> [] + | Some (decl_list, _) -> + List.map ~f:(fun d -> Decl d) decl_list + | None -> + [] + let infer_prefix = "__infer_ctl_" @@ -267,60 +280,61 @@ let equal_builtin_kind = [%compare.equal : builtin_kind] let builtin_kind_to_string t = match t with - | Char_U - -> "char" - | Char16 - -> "char16_t" - | Char32 - -> "char32_t" - | WChar_U - -> "wchar_t" - | Bool - -> "bool" - | Short - -> "short" - | Int - -> "int" - | Long - -> "long" - | Float - -> "float" - | Double - -> "double" - | Void - -> "void" - | SChar - -> "signed char" - | LongLong - -> "long long" - | UChar - -> "unsigned char" - | UShort - -> "unsigned short" - | UInt - -> "unsigned int" - | ULong - -> "unsigned long" - | ULongLong - -> "unsigned long long" - | LongDouble - -> "long double" - | Int128 - -> "__int128" - | Float128 - -> "__float128" - | UInt128 - -> "unsigned __int128" - | Half - -> "half" - | NullPtr - -> "nullptr_t" - | ObjCId - -> "id" - | ObjCClass - -> "Class" - | ObjCSel - -> "SEL" + | Char_U -> + "char" + | Char16 -> + "char16_t" + | Char32 -> + "char32_t" + | WChar_U -> + "wchar_t" + | Bool -> + "bool" + | Short -> + "short" + | Int -> + "int" + | Long -> + "long" + | Float -> + "float" + | Double -> + "double" + | Void -> + "void" + | SChar -> + "signed char" + | LongLong -> + "long long" + | UChar -> + "unsigned char" + | UShort -> + "unsigned short" + | UInt -> + "unsigned int" + | ULong -> + "unsigned long" + | ULongLong -> + "unsigned long long" + | LongDouble -> + "long double" + | Int128 -> + "__int128" + | Float128 -> + "__float128" + | UInt128 -> + "unsigned __int128" + | Half -> + "half" + | NullPtr -> + "nullptr_t" + | ObjCId -> + "id" + | ObjCClass -> + "Class" + | ObjCSel -> + "SEL" + type abs_ctype = | BuiltIn of builtin_kind @@ -335,18 +349,20 @@ let display_equality_warning () = L.(debug Linters Medium) "[WARNING:] Type Comparison failed... This might indicate that the types are different or the specified type is internally represented in a different way and therefore not recognized.@\n" + let rec abs_ctype_to_string t = match t with - | BuiltIn t' - -> "BuiltIn (" ^ builtin_kind_to_string t' ^ ")" - | Pointer t' - -> "Pointer (" ^ abs_ctype_to_string t' ^ ")" - | Reference t' - -> "Reference (" ^ abs_ctype_to_string t' ^ ")" - | TypeName ae - -> "TypeName (" ^ ALVar.alexp_to_string ae ^ ")" - | ObjCGenProt (b, p) - -> "ObjCGenProt (" ^ abs_ctype_to_string b ^ "," ^ abs_ctype_to_string p ^ ")" + | BuiltIn t' -> + "BuiltIn (" ^ builtin_kind_to_string t' ^ ")" + | Pointer t' -> + "Pointer (" ^ abs_ctype_to_string t' ^ ")" + | Reference t' -> + "Reference (" ^ abs_ctype_to_string t' ^ ")" + | TypeName ae -> + "TypeName (" ^ ALVar.alexp_to_string ae ^ ")" + | ObjCGenProt (b, p) -> + "ObjCGenProt (" ^ abs_ctype_to_string b ^ "," ^ abs_ctype_to_string p ^ ")" + let builtin_type_kind_assoc = [ (`Char_U, Char_U) @@ -379,33 +395,37 @@ let builtin_type_kind_assoc = ; (`ObjCSel, ObjCSel) ; (`Half, Half) ] + let builtin_equal (bi: Clang_ast_t.builtin_type_kind) (abi: builtin_kind) = match List.Assoc.find ~equal:PVariant.( = ) builtin_type_kind_assoc bi with - | Some assoc_abi when equal_builtin_kind assoc_abi abi - -> true - | _ - -> display_equality_warning () ; false + | Some assoc_abi when equal_builtin_kind assoc_abi abi -> + true + | _ -> + display_equality_warning () ; false + let typename_to_string pointer = match CAst_utils.get_decl pointer with | Some decl -> ( match Clang_ast_proj.get_named_decl_tuple decl with - | Some (_, name_decl) - -> Some name_decl.ni_name - | None - -> None ) - | _ - -> None + | Some (_, name_decl) -> + Some name_decl.ni_name + | None -> + None ) + | _ -> + None + let rec pointer_type_equal p ap = let open Clang_ast_t in match (p, ap) with - | PointerType (_, qt), Pointer abs_ctype' | ObjCObjectPointerType (_, qt), Pointer abs_ctype' - -> check_type_ptr qt.qt_type_ptr abs_ctype' - | PointerType (_, qt), BuiltIn _ - -> check_type_ptr qt.qt_type_ptr ap - | _, _ - -> display_equality_warning () ; false + | PointerType (_, qt), Pointer abs_ctype' | ObjCObjectPointerType (_, qt), Pointer abs_ctype' -> + check_type_ptr qt.qt_type_ptr abs_ctype' + | PointerType (_, qt), BuiltIn _ -> + check_type_ptr qt.qt_type_ptr ap + | _, _ -> + display_equality_warning () ; false + and objc_object_type_equal c_type abs_ctype = let open Clang_ast_t in @@ -418,32 +438,35 @@ and objc_object_type_equal c_type abs_ctype = match (CAst_utils.get_type ooti.ooti_base_type, ooti.ooti_protocol_decls_ptr, ooti.ooti_type_args) with - | Some base_type, _ :: _, [] - -> c_type_equal base_type base + | Some base_type, _ :: _, [] -> + c_type_equal base_type base && List.for_all ~f:(check_prot args) ooti.ooti_protocol_decls_ptr - | Some base_type, [], _ :: _ - -> c_type_equal base_type base && List.for_all ~f:(check_type_args args) ooti.ooti_type_args - | _ - -> false ) - | _ - -> false + | Some base_type, [], _ :: _ -> + c_type_equal base_type base && List.for_all ~f:(check_type_args args) ooti.ooti_type_args + | _ -> + false ) + | _ -> + false + and typename_equal pointer typename = match typename_to_string pointer with - | Some name - -> L.(debug Linters Medium) + | Some name -> + L.(debug Linters Medium) "Comparing typename '%s' and pointer '%s' for equality...@\n" (ALVar.alexp_to_string typename) name ; ALVar.compare_str_with_alexp name typename - | None - -> false + | None -> + false + and check_type_ptr type_ptr abs_ctype = match CAst_utils.get_type type_ptr with - | Some c_type' - -> c_type_equal c_type' abs_ctype - | None - -> false + | Some c_type' -> + c_type_equal c_type' abs_ctype + | None -> + false + (* Temporary, partial equality function. Cover only what's covered by the types_parser. It needs to be replaced by a real @@ -451,31 +474,33 @@ and check_type_ptr type_ptr abs_ctype = and c_type_equal c_type abs_ctype = L.(debug Linters Medium) "@\nComparing c_type/abs_ctype for equality... Type compared: @\nc_type = `%s` @\nabs_ctype =`%s`@\n" - (Clang_ast_j.string_of_c_type c_type) (abs_ctype_to_string abs_ctype) ; + (Clang_ast_j.string_of_c_type c_type) + (abs_ctype_to_string abs_ctype) ; let open Clang_ast_t in match (c_type, abs_ctype) with - | BuiltinType (_, bi), BuiltIn abi - -> builtin_equal bi abi - | TypedefType (_, tdi), BuiltIn _ - -> check_type_ptr tdi.tti_child_type.qt_type_ptr abs_ctype - | PointerType _, BuiltIn _ | PointerType _, Pointer _ | ObjCObjectPointerType _, Pointer _ - -> pointer_type_equal c_type abs_ctype - | LValueReferenceType (_, qt), Reference abs_typ | RValueReferenceType (_, qt), Reference abs_typ - -> check_type_ptr qt.qt_type_ptr abs_typ - | ObjCObjectPointerType (_, qt), ObjCGenProt _ - -> check_type_ptr qt.qt_type_ptr abs_ctype - | ObjCObjectType _, ObjCGenProt _ - -> objc_object_type_equal c_type abs_ctype - | ObjCInterfaceType (_, pointer), TypeName ae - -> typename_equal pointer ae - | RecordType (_, pointer), TypeName ae - -> typename_equal pointer ae - | TypedefType (_, tdi), TypeName ae - -> typename_equal tdi.tti_decl_ptr ae + | BuiltinType (_, bi), BuiltIn abi -> + builtin_equal bi abi + | TypedefType (_, tdi), BuiltIn _ -> + check_type_ptr tdi.tti_child_type.qt_type_ptr abs_ctype + | PointerType _, BuiltIn _ | PointerType _, Pointer _ | ObjCObjectPointerType _, Pointer _ -> + pointer_type_equal c_type abs_ctype + | LValueReferenceType (_, qt), Reference abs_typ | RValueReferenceType (_, qt), Reference abs_typ -> + check_type_ptr qt.qt_type_ptr abs_typ + | ObjCObjectPointerType (_, qt), ObjCGenProt _ -> + check_type_ptr qt.qt_type_ptr abs_ctype + | ObjCObjectType _, ObjCGenProt _ -> + objc_object_type_equal c_type abs_ctype + | ObjCInterfaceType (_, pointer), TypeName ae -> + typename_equal pointer ae + | RecordType (_, pointer), TypeName ae -> + typename_equal pointer ae + | TypedefType (_, tdi), TypeName ae -> + typename_equal tdi.tti_decl_ptr ae | TypedefType (ti, _), ObjCGenProt _ -> ( match ti.ti_desugared_type with Some dt -> check_type_ptr dt abs_ctype | None -> false ) - | _, _ - -> display_equality_warning () ; false + | _, _ -> + display_equality_warning () ; false + (* to be extended with more types *) let rec typ_string_of_type_ptr type_ptr = @@ -483,42 +508,45 @@ let rec typ_string_of_type_ptr type_ptr = match CAst_utils.get_type type_ptr with | Some BuiltinType (_, bt) -> ( match List.Assoc.find ~equal:Poly.equal builtin_type_kind_assoc bt with - | Some abt - -> builtin_kind_to_string abt - | None - -> "" ) - | Some PointerType (_, qt) | Some ObjCObjectPointerType (_, qt) - -> typ_string_of_type_ptr qt.qt_type_ptr ^ "*" - | Some ObjCInterfaceType (_, pointer) - -> Option.value ~default:"" (typename_to_string pointer) - | Some TypedefType (_, tdi) - -> Option.value ~default:"" (typename_to_string tdi.tti_decl_ptr) - | _ - -> "" + | Some abt -> + builtin_kind_to_string abt + | None -> + "" ) + | Some PointerType (_, qt) | Some ObjCObjectPointerType (_, qt) -> + typ_string_of_type_ptr qt.qt_type_ptr ^ "*" + | Some ObjCInterfaceType (_, pointer) -> + Option.value ~default:"" (typename_to_string pointer) + | Some TypedefType (_, tdi) -> + Option.value ~default:"" (typename_to_string tdi.tti_decl_ptr) + | _ -> + "" + let ast_node_type an = let typ_str = match an with | Stmt stmt -> ( match Clang_ast_proj.get_expr_tuple stmt with - | Some (_, _, expr_info) - -> typ_string_of_type_ptr expr_info.ei_qual_type.qt_type_ptr - | _ - -> "" ) + | Some (_, _, expr_info) -> + typ_string_of_type_ptr expr_info.ei_qual_type.qt_type_ptr + | _ -> + "" ) | Decl decl -> match CAst_utils.type_of_decl decl with - | Some type_ptr - -> typ_string_of_type_ptr type_ptr - | _ - -> "" + | Some type_ptr -> + typ_string_of_type_ptr type_ptr + | _ -> + "" in if String.length typ_str > 0 then typ_str else "" + let stmt_node_child_type an = match an with | Stmt stmt - -> ( + -> ( let _, stmts = Clang_ast_proj.get_stmt_tuple stmt in match stmts with [stmt] -> ast_node_type (Stmt stmt) | _ -> "" ) - | _ - -> "" + | _ -> + "" + diff --git a/infer/src/clang/objcCategory_decl.ml b/infer/src/clang/objcCategory_decl.ml index d4843b955..85be127ae 100644 --- a/infer/src/clang/objcCategory_decl.ml +++ b/infer/src/clang/objcCategory_decl.ml @@ -20,9 +20,11 @@ let noname_category class_name = CFrontend_config.emtpy_name_category ^ class_na let cat_class_decl dr = match dr.Clang_ast_t.dr_name with Some n -> CAst_utils.get_qualified_name n | _ -> assert false + let get_classname decl_ref_opt = match decl_ref_opt with Some dr -> cat_class_decl dr | _ -> assert false + let get_classname_from_category_decl ocdi = get_classname ocdi.Clang_ast_t.odi_class_interface let get_classname_from_category_impl ocidi = get_classname ocidi.Clang_ast_t.ocidi_class_interface @@ -31,34 +33,38 @@ let add_category_decl qual_type_to_sil_type tenv category_impl_info = let decl_ref_opt = category_impl_info.Clang_ast_t.ocidi_category_decl in CAst_utils.add_type_from_decl_ref_opt qual_type_to_sil_type tenv decl_ref_opt true + let add_class_decl qual_type_to_sil_type tenv category_decl_info = let decl_ref_opt = category_decl_info.Clang_ast_t.odi_class_interface in CAst_utils.add_type_from_decl_ref_opt qual_type_to_sil_type tenv decl_ref_opt true + let add_category_implementation qual_type_to_sil_type tenv category_decl_info = let decl_ref_opt = category_decl_info.Clang_ast_t.odi_implementation in CAst_utils.add_type_from_decl_ref_opt qual_type_to_sil_type tenv decl_ref_opt false + let get_base_class_name_from_category decl = let open Clang_ast_t in let base_class_pointer_opt = match decl with - | ObjCCategoryDecl (_, _, _, _, cdi) - -> cdi.Clang_ast_t.odi_class_interface - | ObjCCategoryImplDecl (_, _, _, _, cii) - -> cii.Clang_ast_t.ocidi_class_interface - | _ - -> None + | ObjCCategoryDecl (_, _, _, _, cdi) -> + cdi.Clang_ast_t.odi_class_interface + | ObjCCategoryImplDecl (_, _, _, _, cii) -> + cii.Clang_ast_t.ocidi_class_interface + | _ -> + None in match base_class_pointer_opt with | Some decl_ref -> ( match CAst_utils.get_decl decl_ref.Clang_ast_t.dr_decl_pointer with - | Some ObjCInterfaceDecl (_, name_info, _, _, _) - -> Some (Typ.Name.Objc.from_qual_name (CAst_utils.get_qualified_name name_info)) - | _ - -> None ) - | None - -> None + | Some ObjCInterfaceDecl (_, name_info, _, _, _) -> + Some (Typ.Name.Objc.from_qual_name (CAst_utils.get_qualified_name name_info)) + | _ -> + None ) + | None -> + None + (* Add potential extra fields defined only in the category *) (* to the corresponding class. Update the tenv accordingly.*) @@ -69,40 +75,43 @@ let process_category qual_type_to_sil_type tenv class_name decl_info decl_list = let decl_key = Clang_ast_extend.DeclPtr decl_info.Clang_ast_t.di_pointer in CAst_utils.update_sil_types_map decl_key class_tn_desc ; ( match Tenv.lookup tenv class_tn_name with - | Some ({fields} as struct_typ) - -> let new_fields = CGeneral_utils.append_no_duplicates_fields decl_fields fields in + | Some ({fields} as struct_typ) -> + let new_fields = CGeneral_utils.append_no_duplicates_fields decl_fields fields in ignore (Tenv.mk_struct tenv ~default:struct_typ ~fields:new_fields ~statics:[] ~methods:[] class_tn_name) ; L.(debug Capture Verbose) " Updating info for class '%a' in tenv@\n" QualifiedCppName.pp class_name - | _ - -> () ) ; + | _ -> + () ) ; class_tn_desc + let category_decl qual_type_to_sil_type tenv decl = let open Clang_ast_t in match decl with - | ObjCCategoryDecl (decl_info, name_info, decl_list, _, cdi) - -> let name = CAst_utils.get_qualified_name name_info in + | ObjCCategoryDecl (decl_info, name_info, decl_list, _, cdi) -> + let name = CAst_utils.get_qualified_name name_info in let class_name = get_classname_from_category_decl cdi in L.(debug Capture Verbose) "ADDING: ObjCCategoryDecl for '%a'@\n" QualifiedCppName.pp name ; let _ = add_class_decl qual_type_to_sil_type tenv cdi in let typ = process_category qual_type_to_sil_type tenv class_name decl_info decl_list in let _ = add_category_implementation qual_type_to_sil_type tenv cdi in typ - | _ - -> assert false + | _ -> + assert false + let category_impl_decl qual_type_to_sil_type tenv decl = let open Clang_ast_t in match decl with - | ObjCCategoryImplDecl (decl_info, name_info, decl_list, _, cii) - -> let name = CAst_utils.get_qualified_name name_info in + | ObjCCategoryImplDecl (decl_info, name_info, decl_list, _, cii) -> + let name = CAst_utils.get_qualified_name name_info in let class_name = get_classname_from_category_impl cii in L.(debug Capture Verbose) "ADDING: ObjCCategoryImplDecl for '%a'@\n" QualifiedCppName.pp name ; let _ = add_category_decl qual_type_to_sil_type tenv cii in let typ = process_category qual_type_to_sil_type tenv class_name decl_info decl_list in typ - | _ - -> assert false + | _ -> + assert false + diff --git a/infer/src/clang/objcInterface_decl.ml b/infer/src/clang/objcInterface_decl.ml index 4c8d87a51..85e1426a9 100644 --- a/infer/src/clang/objcInterface_decl.ml +++ b/infer/src/clang/objcInterface_decl.ml @@ -23,44 +23,52 @@ module L = Logging let is_pointer_to_objc_class typ = match typ.Typ.desc with Tptr (typ, _) when Typ.is_objc_class typ -> true | _ -> false + let get_super_interface_decl otdi_super = match otdi_super with - | Some dr - -> Option.map ~f:CAst_utils.get_qualified_name dr.Clang_ast_t.dr_name - | _ - -> None + | Some dr -> + Option.map ~f:CAst_utils.get_qualified_name dr.Clang_ast_t.dr_name + | _ -> + None + let get_protocols protocols = let protocol_names = List.map ~f:(fun decl -> match decl.Clang_ast_t.dr_name with - | Some name_info - -> CAst_utils.get_qualified_name name_info - | None - -> assert false) + | Some name_info -> + CAst_utils.get_qualified_name name_info + | None -> + assert false) protocols in protocol_names + let add_class_decl qual_type_to_sil_type tenv idi = let decl_ref_opt = idi.Clang_ast_t.oidi_class_interface in CAst_utils.add_type_from_decl_ref_opt qual_type_to_sil_type tenv decl_ref_opt true + let add_super_class_decl qual_type_to_sil_type tenv ocdi = let decl_ref_opt = ocdi.Clang_ast_t.otdi_super in CAst_utils.add_type_from_decl_ref_opt qual_type_to_sil_type tenv decl_ref_opt false + let add_protocols_decl qual_type_to_sil_type tenv protocols = CAst_utils.add_type_from_decl_ref_list qual_type_to_sil_type tenv protocols + let add_categories_decl qual_type_to_sil_type tenv categories = CAst_utils.add_type_from_decl_ref_list qual_type_to_sil_type tenv categories + let add_class_implementation qual_type_to_sil_type tenv idi = let decl_ref_opt = idi.Clang_ast_t.otdi_implementation in CAst_utils.add_type_from_decl_ref_opt qual_type_to_sil_type tenv decl_ref_opt false + (*The superclass is the first element in the list of super classes of structs in the tenv, *) (* then come the protocols and categories. *) let get_interface_supers super_opt protocols = @@ -71,6 +79,7 @@ let get_interface_supers super_opt protocols = let super_classes = super_class @ protocol_names in super_classes + let create_supers_fields qual_type_to_sil_type tenv class_tname decl_list otdi_super otdi_protocols = let super = get_super_interface_decl otdi_super in let protocols = get_protocols otdi_protocols in @@ -78,6 +87,7 @@ let create_supers_fields qual_type_to_sil_type tenv class_tname decl_list otdi_s let fields = CField_decl.get_fields qual_type_to_sil_type tenv class_tname decl_list in (supers, fields) + (* Adds pairs (interface name, interface_type_info) to the global environment. *) let add_class_to_tenv qual_type_to_sil_type tenv decl_info name_info decl_list ocidi = let class_name = CAst_utils.get_qualified_name name_info in @@ -99,11 +109,11 @@ let add_class_to_tenv qual_type_to_sil_type tenv decl_info name_info decl_list o (*In case we found categories, or partial definition of this class earlier and they are already in the tenv *) let fields, (supers: Typ.Name.t list) = match Tenv.lookup tenv interface_name with - | Some {fields; supers} - -> ( CGeneral_utils.append_no_duplicates_fields decl_fields fields + | Some {fields; supers} -> + ( CGeneral_utils.append_no_duplicates_fields decl_fields fields , CGeneral_utils.append_no_duplicates_csu decl_supers supers ) - | _ - -> (decl_fields, decl_supers) + | _ -> + (decl_fields, decl_supers) in let fields = CGeneral_utils.append_no_duplicates_fields fields fields_sc in (* We add the special hidden counter_field for implementing reference counting *) @@ -120,36 +130,41 @@ let add_class_to_tenv qual_type_to_sil_type tenv decl_info name_info decl_list o (Tenv.mk_struct tenv ~fields:all_fields ~supers ~methods:[] ~annots:Annot.Class.objc interface_name) ; L.(debug Capture Verbose) - " >>>Verifying that Typename '%s' is in tenv@\n" (Typ.Name.to_string interface_name) ; + " >>>Verifying that Typename '%s' is in tenv@\n" + (Typ.Name.to_string interface_name) ; ( match Tenv.lookup tenv interface_name with - | Some st - -> L.(debug Capture Verbose) - " >>>OK. Found typ='%a'@\n" (Typ.Struct.pp Pp.text interface_name) st - | None - -> L.(debug Capture Verbose) " >>>NOT Found!!@\n" ) ; + | Some st -> + L.(debug Capture Verbose) + " >>>OK. Found typ='%a'@\n" + (Typ.Struct.pp Pp.text interface_name) + st + | None -> + L.(debug Capture Verbose) " >>>NOT Found!!@\n" ) ; interface_desc + (* Interface_type_info has the name of instance variables and the name of methods. *) let interface_declaration qual_type_to_sil_type tenv decl = let open Clang_ast_t in match decl with - | ObjCInterfaceDecl (decl_info, name_info, decl_list, _, ocidi) - -> let typ = add_class_to_tenv qual_type_to_sil_type tenv decl_info name_info decl_list ocidi in + | ObjCInterfaceDecl (decl_info, name_info, decl_list, _, ocidi) -> + let typ = add_class_to_tenv qual_type_to_sil_type tenv decl_info name_info decl_list ocidi in let _ = add_class_implementation qual_type_to_sil_type tenv ocidi in let _ = add_super_class_decl qual_type_to_sil_type tenv ocidi in let _ = add_protocols_decl qual_type_to_sil_type tenv ocidi.Clang_ast_t.otdi_protocols in let known_categories = ocidi.Clang_ast_t.otdi_known_categories in let _ = add_categories_decl qual_type_to_sil_type tenv known_categories in typ - | _ - -> assert false + | _ -> + assert false + (* Translate the methods defined in the implementation.*) let interface_impl_declaration qual_type_to_sil_type tenv decl = let open Clang_ast_t in match decl with - | ObjCImplementationDecl (decl_info, name_info, decl_list, _, idi) - -> let class_name = CAst_utils.get_qualified_name name_info in + | ObjCImplementationDecl (decl_info, name_info, decl_list, _, idi) -> + let class_name = CAst_utils.get_qualified_name name_info in L.(debug Capture Verbose) "ADDING: ObjCImplementationDecl for class '%a'@\n" QualifiedCppName.pp class_name ; let _ = add_class_decl qual_type_to_sil_type tenv idi in @@ -158,6 +173,8 @@ let interface_impl_declaration qual_type_to_sil_type tenv decl = CField_decl.add_missing_fields tenv class_name fields ; let decl_key = Clang_ast_extend.DeclPtr decl_info.Clang_ast_t.di_pointer in let class_desc = Typ.Tstruct class_tn_name in - CAst_utils.update_sil_types_map decl_key class_desc ; class_desc - | _ - -> assert false + CAst_utils.update_sil_types_map decl_key class_desc ; + class_desc + | _ -> + assert false + diff --git a/infer/src/clang/objcProperty_decl.ml b/infer/src/clang/objcProperty_decl.ml index 2ff511823..137fc6320 100644 --- a/infer/src/clang/objcProperty_decl.ml +++ b/infer/src/clang/objcProperty_decl.ml @@ -23,6 +23,8 @@ let is_strong_property obj_c_property_decl_info = let attrs = obj_c_property_decl_info.Clang_ast_t.opdi_property_attributes in List.exists ~f:(fun a -> match a with `Strong -> true | _ -> false) attrs + let is_assign_property obj_c_property_decl_info = let attrs = obj_c_property_decl_info.Clang_ast_t.opdi_property_attributes in List.exists ~f:(fun a -> match a with `Assign -> true | _ -> false) attrs + diff --git a/infer/src/clang/objcProtocol_decl.ml b/infer/src/clang/objcProtocol_decl.ml index 077733b16..2eed775d7 100644 --- a/infer/src/clang/objcProtocol_decl.ml +++ b/infer/src/clang/objcProtocol_decl.ml @@ -14,11 +14,12 @@ let add_protocol_super qual_type_to_sil_type tenv obj_c_protocol_decl_info = let protocols = obj_c_protocol_decl_info.Clang_ast_t.opcdi_protocols in CAst_utils.add_type_from_decl_ref_list qual_type_to_sil_type tenv protocols + let protocol_decl qual_type_to_sil_type tenv decl = let open Clang_ast_t in match decl with - | ObjCProtocolDecl (decl_info, name_info, _, _, obj_c_protocol_decl_info) - -> let name = CAst_utils.get_qualified_name name_info in + | ObjCProtocolDecl (decl_info, name_info, _, _, obj_c_protocol_decl_info) -> + let name = CAst_utils.get_qualified_name name_info in (* Adds pairs (protocol name, protocol_type_info) to the global environment. *) (* Protocol_type_info contains the methods composing the protocol. *) (* Here we are giving a similar treatment as interfaces (see above)*) @@ -31,7 +32,8 @@ let protocol_decl qual_type_to_sil_type tenv decl = ignore (Tenv.mk_struct tenv ~methods:[] protocol_name) ; add_protocol_super qual_type_to_sil_type tenv obj_c_protocol_decl_info ; protocol_desc - | _ - -> assert false + | _ -> + assert false + let is_protocol decl = Clang_ast_t.(match decl with ObjCProtocolDecl _ -> true | _ -> false) diff --git a/infer/src/clang/tableaux.ml b/infer/src/clang/tableaux.ml index f4ae8e281..9396cd484 100644 --- a/infer/src/clang/tableaux.ml +++ b/infer/src/clang/tableaux.ml @@ -39,27 +39,33 @@ type node_valuation = CTLFormulaSet.t let global_nodes_valuation : node_valuation NodesValuationHashtbl.t ref = ref NodesValuationHashtbl.empty + let init_global_nodes_valuation () = global_nodes_valuation := NodesValuationHashtbl.empty ; closure_map := ClosureHashtbl.empty + let print_table_size () = L.(debug Linters Medium) "@\n[Size: %i]@\n" (NodesValuationHashtbl.cardinal !global_nodes_valuation) + let add_formula_to_valuation k s = global_nodes_valuation := NodesValuationHashtbl.add k s !global_nodes_valuation + let get_node_valuation k = try NodesValuationHashtbl.find k !global_nodes_valuation with Not_found -> CTLFormulaSet.empty + let is_decl_allowed lcxt decl = let decl_info = Clang_ast_proj.get_decl_tuple decl in CLocation.should_do_frontend_check lcxt.CLintersContext.translation_unit_context decl_info.Clang_ast_t.di_source_range + (* true if it's an InNode formulae *) let is_in_formula phi = match phi with CTL.InNode _ -> true | _ -> false @@ -71,6 +77,7 @@ let init_active_map () = ClosureHashtbl.add linter.CFrontend_errors.condition not_inf acc_map) ~init:ClosureHashtbl.empty !CFrontend_errors.parsed_linters + (* update the context map for formulae of type InNode(tl, phi). When we pass from a node in the list tl. The idea is that the context map tell us when we are in a node that is a discendant of a node in tl so that is make @@ -90,71 +97,73 @@ let update_linter_context_map an linter_context_map = ClosureHashtbl.add phi res acc_map with Not_found -> Logging.die InternalError "Every linter condition should have an entry in the map." ) - | _ - -> acc_map + | _ -> + acc_map in List.fold ~f:do_one_linter ~init:linter_context_map !CFrontend_errors.parsed_linters + (* Takes phi and transform it by an equivalent formula containing only a minimal set of operators *) let rec normalize phi = let open CTL in match phi with - | True | False | Atomic _ - -> phi - | Implies (phi1, phi2) - -> normalize (Or (Not phi1, phi2)) - | Or (phi1, phi2) - -> let phi1' = normalize phi1 in + | True | False | Atomic _ -> + phi + | Implies (phi1, phi2) -> + normalize (Or (Not phi1, phi2)) + | Or (phi1, phi2) -> + let phi1' = normalize phi1 in let phi2' = normalize phi2 in Or (phi1', phi2') - | And (phi1, phi2) - -> let phi1' = normalize phi1 in + | And (phi1, phi2) -> + let phi1' = normalize phi1 in let phi2' = normalize phi2 in And (phi1', phi2') - | Not phi1 - -> let phi1' = normalize phi1 in + | Not phi1 -> + let phi1' = normalize phi1 in Not phi1' - | AG (trans, phi1) - -> let phi1' = normalize phi1 in + | AG (trans, phi1) -> + let phi1' = normalize phi1 in Not (EF (trans, Not phi1')) - | EX (trans, phi1) - -> let phi1' = normalize phi1 in + | EX (trans, phi1) -> + let phi1' = normalize phi1 in EX (trans, phi1') - | EF (trans, phi1) - -> let phi1' = normalize phi1 in + | EF (trans, phi1) -> + let phi1' = normalize phi1 in EF (trans, phi1') - | EG (trans, phi1) - -> let phi1' = normalize phi1 in + | EG (trans, phi1) -> + let phi1' = normalize phi1 in EG (trans, phi1') - | AX (trans, phi1) - -> let phi1' = normalize phi1 in + | AX (trans, phi1) -> + let phi1' = normalize phi1 in Not (EX (trans, Not phi1')) - | AF (trans, phi1) - -> let phi1' = normalize phi1 in + | AF (trans, phi1) -> + let phi1' = normalize phi1 in Not (EG (trans, Not phi1')) - | EU (trans, phi1, phi2) - -> let phi1' = normalize phi1 in + | EU (trans, phi1, phi2) -> + let phi1' = normalize phi1 in let phi2' = normalize phi2 in EU (trans, phi1', phi2') - | AU (trans, phi1, phi2) - -> let phi1' = normalize phi1 in + | AU (trans, phi1, phi2) -> + let phi1' = normalize phi1 in let phi2' = normalize phi2 in Not (Or (EU (trans, Not phi2', Not (Or (phi1', phi2'))), EG (trans, phi2'))) - | EH (cl, phi1) - -> normalize (ET (cl, None, EX (Some Super, EF (Some Super, phi1)))) + | EH (cl, phi1) -> + normalize (ET (cl, None, EX (Some Super, EF (Some Super, phi1)))) | ET (tl, trs, phi1) - -> ( + -> ( let phi1' = normalize phi1 in match trs with - | Some _ - -> EF (None, InNode (tl, EX (trs, phi1'))) - | None - -> EF (None, InNode (tl, phi1')) ) - | InNode (nl, phi1) - -> let phi1' = normalize phi1 in + | Some _ -> + EF (None, InNode (tl, EX (trs, phi1'))) + | None -> + EF (None, InNode (tl, phi1')) ) + | InNode (nl, phi1) -> + let phi1' = normalize phi1 in InNode (nl, phi1') + (* Given a phi0 build the list of its subformulae including itself. The order of the list is such that, for any formula phi, its strict subformulae occur before. The order is important for the evaluation. *) @@ -162,18 +171,18 @@ let formula_closure phi0 = let open CTL in let rec do_subformula phi = match phi with - | True | False | Atomic _ - -> [phi] - | Not phi1 - -> phi :: do_subformula phi1 - | And (phi1, phi2) | Or (phi1, phi2) | EU (_, phi1, phi2) - -> let cl1 = do_subformula phi1 in + | True | False | Atomic _ -> + [phi] + | Not phi1 -> + phi :: do_subformula phi1 + | And (phi1, phi2) | Or (phi1, phi2) | EU (_, phi1, phi2) -> + let cl1 = do_subformula phi1 in let cl2 = do_subformula phi2 in phi :: (cl1 @ cl2) - | EX (_, phi1) | EF (_, phi1) | EG (_, phi1) | InNode (_, phi1) - -> phi :: do_subformula phi1 - | AG _ | AX _ | AF _ | AU _ | EH _ | ET _ | Implies _ - -> Logging.die InternalError "@\n Failing with formula @\n %a@\n" CTL.Debug.pp_formula phi + | EX (_, phi1) | EF (_, phi1) | EG (_, phi1) | InNode (_, phi1) -> + phi :: do_subformula phi1 + | AG _ | AX _ | AF _ | AU _ | EH _ | ET _ | Implies _ -> + Logging.die InternalError "@\n Failing with formula @\n %a@\n" CTL.Debug.pp_formula phi in let cl0 = do_subformula phi0 in let cl0' = List.rev cl0 in @@ -181,17 +190,18 @@ let formula_closure phi0 = ~f:(fun acc e -> if List.mem acc e ~equal:CTL.equal then acc else acc @ [e]) ~init:[] cl0' + (* check if there is a formula phi in the set of valid formula of a successor *) let exists_formula_in_successor_nodes an checker trans phi = (*L.(debug Linters Medium) "@\n Successor nodes of %i: " (Ctl_parser_types.ast_node_pointer an) ;*) let succs = match trans with - | Some l - -> (* L.(debug Linters Medium) " (passing by '%a' transition) " CTL.Debug.pp_transition trans ;*) + | Some l -> + (* L.(debug Linters Medium) " (passing by '%a' transition) " CTL.Debug.pp_transition trans ;*) CTL.next_state_via_transition an l - | None - -> (*L.(debug Linters Medium) " (passing by None) " ;*) + | None -> + (*L.(debug Linters Medium) " (passing by None) " ;*) Ctl_parser_types.get_direct_successor_nodes an in (*List.iter @@ -206,6 +216,7 @@ let exists_formula_in_successor_nodes an checker trans phi = CTLFormulaSet.mem phi succ_sat_set) succs + (* Given a node an and a closure cl, returns the subset of valid formulae of cl in an. The hipothesis is that you have constructed the set of valid formulae for the successors of the node an *) @@ -225,56 +236,58 @@ let add_valid_formulae an checker lcxt cl = "@\n In (%i, %s) Dealing with formula @\n %a@\n" pointer name CTL.Debug.pp_formula phi ; L.(debug Linters Medium) "@\n ---------------------------- @\n" ;*) match phi with - | True - -> add_in_set phi acc_set - | False - -> acc_set - | Atomic _ - -> if Option.is_some (eval_formula phi an lcxt) then add_in_set phi acc_set else acc_set - | And (phi1, phi2) when is_valid phi1 acc_set && is_valid phi2 acc_set - -> add_in_set phi acc_set - | Or (phi1, phi2) when is_valid phi1 acc_set || is_valid phi2 acc_set - -> add_in_set phi acc_set - | Not phi1 when not (is_valid phi1 acc_set) - -> add_in_set phi acc_set - | InNode (tl, phi1) when Ctl_parser_types.ast_node_has_kind tl an && is_valid phi1 acc_set - -> add_in_set phi acc_set - | EX (trans, phi1) when exists_formula_in_successor_nodes an checker trans phi1 - -> add_in_set phi acc_set + | True -> + add_in_set phi acc_set + | False -> + acc_set + | Atomic _ -> + if Option.is_some (eval_formula phi an lcxt) then add_in_set phi acc_set else acc_set + | And (phi1, phi2) when is_valid phi1 acc_set && is_valid phi2 acc_set -> + add_in_set phi acc_set + | Or (phi1, phi2) when is_valid phi1 acc_set || is_valid phi2 acc_set -> + add_in_set phi acc_set + | Not phi1 when not (is_valid phi1 acc_set) -> + add_in_set phi acc_set + | InNode (tl, phi1) when Ctl_parser_types.ast_node_has_kind tl an && is_valid phi1 acc_set -> + add_in_set phi acc_set + | EX (trans, phi1) when exists_formula_in_successor_nodes an checker trans phi1 -> + add_in_set phi acc_set | EF (trans, phi1) - when is_valid phi1 acc_set || exists_formula_in_successor_nodes an checker trans phi - -> add_in_set phi acc_set + when is_valid phi1 acc_set || exists_formula_in_successor_nodes an checker trans phi -> + add_in_set phi acc_set | EG (trans, phi1) - when is_valid phi1 acc_set && exists_formula_in_successor_nodes an checker trans phi - -> add_in_set phi acc_set + when is_valid phi1 acc_set && exists_formula_in_successor_nodes an checker trans phi -> + add_in_set phi acc_set | EU (trans, phi1, phi2) when is_valid phi2 acc_set - || is_valid phi1 acc_set && exists_formula_in_successor_nodes an checker trans phi - -> add_in_set phi acc_set - | AG _ | AX _ | AF _ | AU _ | EH _ | ET _ | Implies _ - -> Logging.die InternalError + || is_valid phi1 acc_set && exists_formula_in_successor_nodes an checker trans phi -> + add_in_set phi acc_set + | AG _ | AX _ | AF _ | AU _ | EH _ | ET _ | Implies _ -> + Logging.die InternalError "@\n We should not have operators AG, AX, AF, AU, EH, ET.\n Failing with formula @\n %a@\n" CTL.Debug.pp_formula phi - | _ - -> acc_set + | _ -> + acc_set in List.fold ~f:do_formula cl ~init:CTLFormulaSet.empty + (* true if it's a formulae that does not contain temporal operators and can be decided in a single node *) let rec is_state_only_formula phi = let open CTL in match phi with - | True | False | Atomic _ - -> (*L.(debug Linters Medium) "@\n ****** FOUND state_only_formula ***** @\n" ;*) true - | Not phi1 - -> is_state_only_formula phi1 - | And (phi1, phi2) | Or (phi1, phi2) | Implies (phi1, phi2) - -> is_state_only_formula phi1 && is_state_only_formula phi2 - | InNode (_, phi1) - -> is_state_only_formula phi1 - | AX _ | EX _ | AF _ | EF _ | AG _ | EG _ | AU _ | EU _ | EH _ | ET _ - -> false + | True | False | Atomic _ -> + (*L.(debug Linters Medium) "@\n ****** FOUND state_only_formula ***** @\n" ;*) true + | Not phi1 -> + is_state_only_formula phi1 + | And (phi1, phi2) | Or (phi1, phi2) | Implies (phi1, phi2) -> + is_state_only_formula phi1 && is_state_only_formula phi2 + | InNode (_, phi1) -> + is_state_only_formula phi1 + | AX _ | EX _ | AF _ | EF _ | AG _ | EG _ | AU _ | EU _ | EH _ | ET _ -> + false + (* Report an issue provided that a declaration is allowed (i.e., it's in the analized file )*) @@ -290,18 +303,21 @@ let report_issue an lcxt linter (*npo_condition*) = let should_report = match an with Decl dec -> is_decl_allowed lcxt dec | Stmt _ -> true in if should_report then fill_issue_desc_info_and_log lcxt an linter.issue_desc linter.def_file loc + let check_linter_map linter_map_contex phi = try ClosureHashtbl.find phi linter_map_contex with Not_found -> Logging.die InternalError "@\n ERROR: linter_map must have an entry for each formula" + (* skip the evaluation of a InNode because an is not among the set tl *) let skip_evaluation_InNode_formula an phi = match phi with - | CTL.InNode (tl, _) when not (Ctl_parser_types.ast_node_has_kind tl an) - -> true - | _ - -> false + | CTL.InNode (tl, _) when not (Ctl_parser_types.ast_node_has_kind tl an) -> + true + | _ -> + false + (* Build valuation, i.e. set of valid subformula for a pair (node, checker) *) let build_valuation an lcxt linter_map_context = @@ -334,3 +350,4 @@ let build_valuation an lcxt linter_map_context = && check_linter_map linter_map_context linter.condition then do_one_check linter) !parsed_linters + diff --git a/infer/src/clang_stubs/CTLParserHelper.ml b/infer/src/clang_stubs/CTLParserHelper.ml index c2ced96ad..9c8a4959b 100644 --- a/infer/src/clang_stubs/CTLParserHelper.ml +++ b/infer/src/clang_stubs/CTLParserHelper.ml @@ -8,4 +8,6 @@ *) let validate_al_files () = - prerr_endline "ERROR: infer was built without clang support." ; Die.exit 1 + prerr_endline "ERROR: infer was built without clang support." ; + Die.exit 1 + diff --git a/infer/src/concurrency/RacerD.ml b/infer/src/concurrency/RacerD.ml index 090b7b51d..51ef5a055 100644 --- a/infer/src/concurrency/RacerD.ml +++ b/infer/src/concurrency/RacerD.ml @@ -18,6 +18,7 @@ module Summary = Summary.Make (struct let update_payload post (summary: Specs.summary) = {summary with payload= {summary.payload with racerd= Some post}} + let read_payload (summary: Specs.summary) = summary.payload.racerd end) @@ -37,12 +38,14 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let pn = Typ.Procname.java_get_class_name java_pname in String.is_suffix ~suffix:"ThreadUtils" pn || String.is_suffix ~suffix:"ThreadUtil" pn + let is_thread_utils_method method_name_str = function - | Typ.Procname.Java java_pname - -> is_thread_utils_type java_pname + | Typ.Procname.Java java_pname -> + is_thread_utils_type java_pname && String.equal (Typ.Procname.java_get_method java_pname) method_name_str - | _ - -> false + | _ -> + false + let get_lock_model = let is_cpp_lock = @@ -88,7 +91,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct fun pname actuals -> match pname with | Typ.Procname.Java java_pname - -> ( + -> ( if is_thread_utils_method "assertHoldsLock" (Typ.Procname.Java java_pname) then Lock else match @@ -97,47 +100,49 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | ( ( "java.util.concurrent.locks.Lock" | "java.util.concurrent.locks.ReentrantLock" | "java.util.concurrent.locks.ReentrantReadWriteLock$ReadLock" | "java.util.concurrent.locks.ReentrantReadWriteLock$WriteLock" ) - , ("lock" | "lockInterruptibly") ) - -> Lock + , ("lock" | "lockInterruptibly") ) -> + Lock | ( ( "java.util.concurrent.locks.Lock" | "java.util.concurrent.locks.ReentrantLock" | "java.util.concurrent.locks.ReentrantReadWriteLock$ReadLock" | "java.util.concurrent.locks.ReentrantReadWriteLock$WriteLock" ) - , "unlock" ) - -> Unlock + , "unlock" ) -> + Unlock | ( ( "java.util.concurrent.locks.Lock" | "java.util.concurrent.locks.ReentrantLock" | "java.util.concurrent.locks.ReentrantReadWriteLock$ReadLock" | "java.util.concurrent.locks.ReentrantReadWriteLock$WriteLock" ) - , "tryLock" ) - -> LockedIfTrue + , "tryLock" ) -> + LockedIfTrue | ( "com.facebook.buck.util.concurrent.AutoCloseableReadWriteUpdateLock" - , ("readLock" | "updateLock" | "writeLock") ) - -> Lock - | _ - -> NoEffect ) - | Typ.Procname.ObjC_Cpp _ as pname when is_cpp_lock pname actuals - -> Lock - | Typ.Procname.ObjC_Cpp _ as pname when is_cpp_unlock pname - -> Unlock - | pname when Typ.Procname.equal pname BuiltinDecl.__set_locked_attribute - -> Lock - | pname when Typ.Procname.equal pname BuiltinDecl.__delete_locked_attribute - -> Unlock - | _ - -> NoEffect + , ("readLock" | "updateLock" | "writeLock") ) -> + Lock + | _ -> + NoEffect ) + | Typ.Procname.ObjC_Cpp _ as pname when is_cpp_lock pname actuals -> + Lock + | Typ.Procname.ObjC_Cpp _ as pname when is_cpp_unlock pname -> + Unlock + | pname when Typ.Procname.equal pname BuiltinDecl.__set_locked_attribute -> + Lock + | pname when Typ.Procname.equal pname BuiltinDecl.__delete_locked_attribute -> + Unlock + | _ -> + NoEffect + let get_thread_model = function | Typ.Procname.Java java_pname when is_thread_utils_type java_pname -> ( match Typ.Procname.java_get_method java_pname with - | "assertMainThread" | "assertOnUiThread" | "checkOnMainThread" - -> MainThread - | "isMainThread" | "isUiThread" - -> MainThreadIfTrue - | "assertOnBackgroundThread" | "assertOnNonUiThread" | "checkOnNonUiThread" - -> BackgroundThread - | _ - -> UnknownThread ) - | _ - -> UnknownThread + | "assertMainThread" | "assertOnUiThread" | "checkOnMainThread" -> + MainThread + | "isMainThread" | "isUiThread" -> + MainThreadIfTrue + | "assertOnBackgroundThread" | "assertOnNonUiThread" | "checkOnNonUiThread" -> + BackgroundThread + | _ -> + UnknownThread ) + | _ -> + UnknownThread + let get_container_access = let is_cpp_container_read = @@ -153,49 +158,50 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in fun pn tenv -> match pn with - | Typ.Procname.Java java_pname - -> let typename = Typ.Name.Java.from_string (Typ.Procname.java_get_class_name java_pname) in + | Typ.Procname.Java java_pname -> + let typename = Typ.Name.Java.from_string (Typ.Procname.java_get_class_name java_pname) in let get_container_access_ typename = match (Typ.Name.name typename, Typ.Procname.java_get_method java_pname) with | ( ("android.util.SparseArray" | "android.support.v4.util.SparseArrayCompat") , ( "append" | "clear" | "delete" | "put" | "remove" | "removeAt" | "removeAtRange" - | "setValueAt" ) ) - -> Some ContainerWrite + | "setValueAt" ) ) -> + Some ContainerWrite | ( ("android.util.SparseArray" | "android.support.v4.util.SparseArrayCompat") - , ("clone" | "get" | "indexOfKey" | "indexOfValue" | "keyAt" | "size" | "valueAt") ) - -> Some ContainerRead + , ("clone" | "get" | "indexOfKey" | "indexOfValue" | "keyAt" | "size" | "valueAt") ) -> + Some ContainerRead | ( "android.support.v4.util.SimpleArrayMap" , ( "clear" | "ensureCapacity" | "put" | "putAll" | "remove" | "removeAt" - | "setValueAt" ) ) - -> Some ContainerWrite + | "setValueAt" ) ) -> + Some ContainerWrite | ( "android.support.v4.util.SimpleArrayMap" , ( "containsKey" | "containsValue" | "get" | "hashCode" | "indexOfKey" | "isEmpty" - | "keyAt" | "size" | "valueAt" ) ) - -> Some ContainerRead - | "android.support.v4.util.Pools$SimplePool", ("acquire" | "release") - -> Some ContainerWrite - | "java.util.List", ("add" | "addAll" | "clear" | "remove" | "set") - -> Some ContainerWrite + | "keyAt" | "size" | "valueAt" ) ) -> + Some ContainerRead + | "android.support.v4.util.Pools$SimplePool", ("acquire" | "release") -> + Some ContainerWrite + | "java.util.List", ("add" | "addAll" | "clear" | "remove" | "set") -> + Some ContainerWrite | ( "java.util.List" , ( "contains" | "containsAll" | "equals" | "get" | "hashCode" | "indexOf" - | "isEmpty" | "iterator" | "lastIndexOf" | "listIterator" | "size" | "toArray" ) ) - -> Some ContainerRead - | "java.util.Map", ("clear" | "put" | "putAll" | "remove") - -> Some ContainerWrite + | "isEmpty" | "iterator" | "lastIndexOf" | "listIterator" | "size" | "toArray" ) ) -> + Some ContainerRead + | "java.util.Map", ("clear" | "put" | "putAll" | "remove") -> + Some ContainerWrite | ( "java.util.Map" , ( "containsKey" | "containsValue" | "entrySet" | "equals" | "get" | "hashCode" - | "isEmpty" | "keySet" | "size" | "values" ) ) - -> Some ContainerRead - | _ - -> None + | "isEmpty" | "keySet" | "size" | "values" ) ) -> + Some ContainerRead + | _ -> + None in PatternMatch.supertype_find_map_opt tenv get_container_access_ typename - | Typ.Procname.ObjC_Cpp _ as pname when is_cpp_container_read pname - -> Some ContainerRead - | Typ.Procname.ObjC_Cpp _ as pname when is_cpp_container_write pname - -> Some ContainerWrite - | _ - -> None + | Typ.Procname.ObjC_Cpp _ as pname when is_cpp_container_read pname -> + Some ContainerRead + | Typ.Procname.ObjC_Cpp _ as pname when is_cpp_container_write pname -> + Some ContainerWrite + | _ -> + None + (* propagate attributes from the leaves to the root of an RHS Hil expression *) let rec attributes_of_expr attribute_map e = @@ -205,31 +211,33 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | HilExp.AccessPath ap -> ( try AttributeMapDomain.find ap attribute_map with Not_found -> AttributeSetDomain.empty ) - | Constant _ - -> AttributeSetDomain.of_list [Attribute.Functional] - | Exception expr (* treat exceptions as transparent wrt attributes *) | Cast (_, expr) - -> attributes_of_expr attribute_map expr - | UnaryOperator (_, expr, _) - -> attributes_of_expr attribute_map expr - | BinaryOperator (_, expr1, expr2) - -> let attributes1 = attributes_of_expr attribute_map expr1 in + | Constant _ -> + AttributeSetDomain.of_list [Attribute.Functional] + | Exception expr (* treat exceptions as transparent wrt attributes *) | Cast (_, expr) -> + attributes_of_expr attribute_map expr + | UnaryOperator (_, expr, _) -> + attributes_of_expr attribute_map expr + | BinaryOperator (_, expr1, expr2) -> + let attributes1 = attributes_of_expr attribute_map expr1 in let attributes2 = attributes_of_expr attribute_map expr2 in AttributeSetDomain.join attributes1 attributes2 - | Closure _ | Sizeof _ - -> AttributeSetDomain.empty + | Closure _ | Sizeof _ -> + AttributeSetDomain.empty + let rec ownership_of_expr expr ownership = let open Domain in let open HilExp in match expr with - | AccessPath ap - -> OwnershipDomain.get_owned ap ownership - | Constant _ - -> OwnershipAbstractValue.owned - | Exception e (* treat exceptions as transparent wrt ownership *) | Cast (_, e) - -> ownership_of_expr e ownership - | _ - -> OwnershipAbstractValue.unowned + | AccessPath ap -> + OwnershipDomain.get_owned ap ownership + | Constant _ -> + OwnershipAbstractValue.owned + | Exception e (* treat exceptions as transparent wrt ownership *) | Cast (_, e) -> + ownership_of_expr e ownership + | _ -> + OwnershipAbstractValue.unowned + (* will return true on x.f.g.h when x.f and x.f.g are owned, but not requiring x.f.g.h *) (* must not be called with an empty access list *) @@ -241,56 +249,59 @@ module TransferFunctions (CFG : ProcCfg.S) = struct ~f:(fun ap -> RacerDDomain.OwnershipDomain.is_owned (base, ap) attribute_map) prefixes + let propagate_attributes lhs_access_path rhs_exp attribute_map = let rhs_attributes = attributes_of_expr attribute_map rhs_exp in Domain.AttributeMapDomain.add lhs_access_path rhs_attributes attribute_map - let propagate_ownership (lhs_root, accesses as lhs_access_path) rhs_exp ownership = + + let propagate_ownership ((lhs_root, accesses) as lhs_access_path) rhs_exp ownership = if Var.is_global (fst lhs_root) then (* do not assign ownership to access paths rooted at globals *) ownership else let ownership_value = match accesses with - | [] - -> ownership_of_expr rhs_exp ownership + | [] -> + ownership_of_expr rhs_exp ownership | [_] when match Domain.OwnershipDomain.get_owned (lhs_root, []) ownership with - | Domain.OwnershipAbstractValue.OwnedIf _ - -> true - | _ - -> false - -> ownership_of_expr rhs_exp ownership - | _ when all_prefixes_owned lhs_access_path ownership - -> ownership_of_expr rhs_exp ownership - | _ - -> Domain.OwnershipAbstractValue.unowned + | Domain.OwnershipAbstractValue.OwnedIf _ -> + true + | _ -> + false -> + ownership_of_expr rhs_exp ownership + | _ when all_prefixes_owned lhs_access_path ownership -> + ownership_of_expr rhs_exp ownership + | _ -> + Domain.OwnershipAbstractValue.unowned in Domain.OwnershipDomain.add lhs_access_path ownership_value ownership + let propagate_return ret_opt ret_ownership ret_attributes actuals {Domain.ownership; attribute_map} = let open Domain in match ret_opt with - | None - -> (ownership, attribute_map) - | Some ret - -> let ret_access_path = (ret, []) in + | None -> + (ownership, attribute_map) + | Some ret -> + let ret_access_path = (ret, []) in let get_ownership formal_index acc = match List.nth actuals formal_index with - | Some HilExp.AccessPath actual_ap - -> OwnershipDomain.get_owned actual_ap ownership |> OwnershipAbstractValue.join acc - | Some HilExp.Constant _ - -> acc - | _ - -> OwnershipAbstractValue.unowned + | Some HilExp.AccessPath actual_ap -> + OwnershipDomain.get_owned actual_ap ownership |> OwnershipAbstractValue.join acc + | Some HilExp.Constant _ -> + acc + | _ -> + OwnershipAbstractValue.unowned in let ownership' = match ret_ownership with - | OwnershipAbstractValue.Owned | Unowned - -> OwnershipDomain.add ret_access_path ret_ownership ownership - | OwnershipAbstractValue.OwnedIf formal_indexes - -> let actuals_ownership = + | OwnershipAbstractValue.Owned | Unowned -> + OwnershipDomain.add ret_access_path ret_ownership ownership + | OwnershipAbstractValue.OwnedIf formal_indexes -> + let actuals_ownership = IntSet.fold get_ownership formal_indexes OwnershipAbstractValue.owned in OwnershipDomain.add ret_access_path actuals_ownership ownership @@ -298,28 +309,32 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let attribute_map' = AttributeMapDomain.add ret_access_path ret_attributes attribute_map in (ownership', attribute_map') + (** return true if this function is library code from the JDK core libraries or Android *) let is_java_library = function | Typ.Procname.Java java_pname -> ( match Typ.Procname.java_get_package java_pname with - | Some package_name - -> String.is_prefix ~prefix:"java." package_name + | Some package_name -> + String.is_prefix ~prefix:"java." package_name || String.is_prefix ~prefix:"android." package_name || String.is_prefix ~prefix:"com.google." package_name - | None - -> false ) - | _ - -> false + | None -> + false ) + | _ -> + false + let is_builder_function = function - | Typ.Procname.Java java_pname - -> String.is_suffix ~suffix:"$Builder" (Typ.Procname.java_get_class_name java_pname) - | _ - -> false + | Typ.Procname.Java java_pname -> + String.is_suffix ~suffix:"$Builder" (Typ.Procname.java_get_class_name java_pname) + | _ -> + false + let has_return_annot predicate pn = Annotations.pname_has_return_annot pn ~attrs_of_pname:Specs.proc_resolve_attributes predicate + let add_unannotated_call_access pname (call_flags: CallFlags.t) loc tenv ~locks ~threads attribute_map (proc_data: extras ProcData.t) = if call_flags.cf_interface && Typ.Procname.is_java pname @@ -334,6 +349,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct AccessDomain.add_access pre (make_unannotated_call_access pname loc) attribute_map else attribute_map + let add_access exp loc ~is_write_access accesses locks threads ownership (proc_data: extras ProcData.t) = let open Domain in @@ -344,20 +360,20 @@ module TransferFunctions (CFG : ProcCfg.S) = struct | ( AccessPath.FieldAccess fieldname , Some ({Typ.desc= Tstruct typename} | {desc= Tptr ({desc= Tstruct typename}, _)}) ) -> ( match Tenv.lookup tenv typename with - | Some struct_typ - -> Annotations.struct_typ_has_annot struct_typ Annotations.ia_is_thread_confined + | Some struct_typ -> + Annotations.struct_typ_has_annot struct_typ Annotations.ia_is_thread_confined || Annotations.field_has_annot fieldname struct_typ Annotations.ia_is_thread_confined || Annotations.field_has_annot fieldname struct_typ Annotations.ia_is_volatile - | None - -> false ) - | _ - -> false + | None -> + false ) + | _ -> + false in let rec add_field_accesses pre prefix_path access_acc = function - | [] - -> access_acc - | access :: access_list' - -> let is_write = if List.is_empty access_list' then is_write_access else false in + | [] -> + access_acc + | access :: access_list' -> + let is_write = if List.is_empty access_list' then is_write_access else false in let access_path = (fst prefix_path, snd prefix_path @ [access]) in let access_acc' = if OwnershipDomain.is_owned prefix_path ownership @@ -374,21 +390,22 @@ module TransferFunctions (CFG : ProcCfg.S) = struct else let pre = match AccessPrecondition.make locks threads proc_data.pdesc with - | AccessPrecondition.Protected _ as excluder - -> excluder + | AccessPrecondition.Protected _ as excluder -> + excluder | _ -> match OwnershipDomain.get_owned base_access_path ownership with - | OwnershipAbstractValue.OwnedIf formal_indexes - -> AccessPrecondition.Unprotected formal_indexes - | OwnershipAbstractValue.Owned - -> assert false - | OwnershipAbstractValue.Unowned - -> AccessPrecondition.TotallyUnprotected + | OwnershipAbstractValue.OwnedIf formal_indexes -> + AccessPrecondition.Unprotected formal_indexes + | OwnershipAbstractValue.Owned -> + assert false + | OwnershipAbstractValue.Unowned -> + AccessPrecondition.TotallyUnprotected in add_field_accesses pre base_access_path acc accesses in List.fold ~f:add_access_ ~init:accesses (HilExp.get_access_paths exp) + let is_functional pname = let is_annotated_functional = has_return_annot Annotations.ia_is_functional in let is_modeled_functional = function @@ -396,8 +413,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct match (Typ.Procname.java_get_class_name java_pname, Typ.Procname.java_get_method java_pname) with - | "android.content.res.Resources", method_name - -> (* all methods of Resources are considered @Functional except for the ones in this + | "android.content.res.Resources", method_name -> + (* all methods of Resources are considered @Functional except for the ones in this blacklist *) let non_functional_resource_methods = [ "getAssets" @@ -408,13 +425,14 @@ module TransferFunctions (CFG : ProcCfg.S) = struct ; "openRawResourceFd" ] in not (List.mem ~equal:String.equal non_functional_resource_methods method_name) - | _ - -> false ) - | _ - -> false + | _ -> + false ) + | _ -> + false in is_annotated_functional pname || is_modeled_functional pname + let acquires_ownership pname tenv = let is_allocation pn = Typ.Procname.equal pn BuiltinDecl.__new || Typ.Procname.equal pn BuiltinDecl.__new_array @@ -425,77 +443,80 @@ module TransferFunctions (CFG : ProcCfg.S) = struct match (Typ.Procname.java_get_class_name java_pname, Typ.Procname.java_get_method java_pname) with - | "javax.inject.Provider", "get" - -> (* in dependency injection, the library allocates fresh values behind the scenes *) + | "javax.inject.Provider", "get" -> + (* in dependency injection, the library allocates fresh values behind the scenes *) true - | ("java.lang.Class" | "java.lang.reflect.Constructor"), "newInstance" - -> (* reflection can perform allocations *) + | ("java.lang.Class" | "java.lang.reflect.Constructor"), "newInstance" -> + (* reflection can perform allocations *) true - | "java.lang.Object", "clone" - -> (* cloning is like allocation *) + | "java.lang.Object", "clone" -> + (* cloning is like allocation *) true - | "java.lang.ThreadLocal", "get" - -> (* ThreadLocal prevents sharing between threads behind the scenes *) + | "java.lang.ThreadLocal", "get" -> + (* ThreadLocal prevents sharing between threads behind the scenes *) true - | ("android.app.Activity" | "android.view.View"), "findViewById" - -> (* assume findViewById creates fresh View's (note: not always true) *) + | ("android.app.Activity" | "android.view.View"), "findViewById" -> + (* assume findViewById creates fresh View's (note: not always true) *) true | ( ( "android.support.v4.util.Pools$Pool" | "android.support.v4.util.Pools$SimplePool" | "android.support.v4.util.Pools$SynchronizedPool" ) - , "acquire" ) - -> (* a pool should own all of its objects *) + , "acquire" ) -> + (* a pool should own all of its objects *) true - | _ - -> false ) - | _ - -> false + | _ -> + false ) + | _ -> + false in is_allocation pname || is_owned_in_library pname || PatternMatch.override_exists is_owned_in_library tenv pname + let is_threadsafe_collection pn tenv = match pn with - | Typ.Procname.Java java_pname - -> let typename = Typ.Name.Java.from_string (Typ.Procname.java_get_class_name java_pname) in + | Typ.Procname.Java java_pname -> + let typename = Typ.Name.Java.from_string (Typ.Procname.java_get_class_name java_pname) in let aux tn _ = match Typ.Name.name tn with | "java.util.concurrent.ConcurrentMap" | "java.util.concurrent.CopyOnWriteArrayList" - | "android.support.v4.util.Pools$SynchronizedPool" - -> true - | _ - -> false + | "android.support.v4.util.Pools$SynchronizedPool" -> + true + | _ -> + false in PatternMatch.supertype_exists tenv aux typename - | _ - -> false + | _ -> + false + let is_synchronized_container callee_pname ((_, (base_typ: Typ.t)), accesses) tenv = if is_threadsafe_collection callee_pname tenv then true else let is_annotated_synchronized base_typename container_field tenv = match Tenv.lookup tenv base_typename with - | Some base_typ - -> Annotations.field_has_annot container_field base_typ + | Some base_typ -> + Annotations.field_has_annot container_field base_typ Annotations.ia_is_synchronized_collection - | None - -> false + | None -> + false in match List.rev accesses with | (AccessPath.FieldAccess base_field) :: (AccessPath.FieldAccess container_field) :: _ - when Typ.Procname.is_java callee_pname - -> let base_typename = + when Typ.Procname.is_java callee_pname -> + let base_typename = Typ.Name.Java.from_string (Typ.Fieldname.java_get_class base_field) in is_annotated_synchronized base_typename container_field tenv | [(AccessPath.FieldAccess container_field)] -> ( match base_typ.desc with - | Typ.Tstruct base_typename | Tptr ({Typ.desc= Tstruct base_typename}, _) - -> is_annotated_synchronized base_typename container_field tenv - | _ - -> false ) - | _ - -> false + | Typ.Tstruct base_typename | Tptr ({Typ.desc= Tstruct base_typename}, _) -> + is_annotated_synchronized base_typename container_field tenv + | _ -> + false ) + | _ -> + false + let make_container_access callee_pname ~is_write receiver_ap callee_loc tenv = (* create a dummy write that represents mutating the contents of the container *) @@ -516,36 +537,39 @@ module TransferFunctions (CFG : ProcCfg.S) = struct ; return_ownership= OwnershipAbstractValue.unowned ; return_attributes= AttributeSetDomain.empty } + let cpp_force_skipped = let matcher = - ( lazy - (QualifiedCppName.Match.of_fuzzy_qual_names - ["folly::AtomicStruct::load"; "folly::detail::SingletonHolder::createInstance"]) ) + lazy + (QualifiedCppName.Match.of_fuzzy_qual_names + ["folly::AtomicStruct::load"; "folly::detail::SingletonHolder::createInstance"]) in fun pname -> QualifiedCppName.Match.match_qualifiers (Lazy.force matcher) (Typ.Procname.get_qualifiers pname) + let get_summary caller_pdesc callee_pname actuals callee_loc tenv = let get_receiver_ap actuals = match List.hd actuals with - | Some HilExp.AccessPath receiver_ap - -> receiver_ap - | _ - -> L.(die InternalError) + | Some HilExp.AccessPath receiver_ap -> + receiver_ap + | _ -> + L.(die InternalError) "Call to %a is marked as a container write, but has no receiver" Typ.Procname.pp callee_pname in match (get_container_access callee_pname tenv, callee_pname) with - | Some ContainerWrite, _ - -> make_container_access callee_pname ~is_write:true (get_receiver_ap actuals) callee_loc tenv - | Some ContainerRead, _ - -> make_container_access callee_pname ~is_write:false (get_receiver_ap actuals) callee_loc + | Some ContainerWrite, _ -> + make_container_access callee_pname ~is_write:true (get_receiver_ap actuals) callee_loc tenv + | Some ContainerRead, _ -> + make_container_access callee_pname ~is_write:false (get_receiver_ap actuals) callee_loc tenv - | None, Typ.Procname.ObjC_Cpp _ when cpp_force_skipped callee_pname - -> None - | None, _ - -> Summary.read_summary caller_pdesc callee_pname + | None, Typ.Procname.ObjC_Cpp _ when cpp_force_skipped callee_pname -> + None + | None, _ -> + Summary.read_summary caller_pdesc callee_pname + (* return true if the given procname boxes a primitive type into a reference type *) let is_box = function @@ -555,12 +579,13 @@ module TransferFunctions (CFG : ProcCfg.S) = struct with | ( ( "java.lang.Boolean" | "java.lang.Byte" | "java.lang.Char" | "java.lang.Double" | "java.lang.Float" | "java.lang.Integer" | "java.lang.Long" | "java.lang.Short" ) - , "valueOf" ) - -> true - | _ - -> false ) - | _ - -> false + , "valueOf" ) -> + true + | _ -> + false ) + | _ -> + false + let add_reads exps loc accesses locks threads ownership proc_data = List.fold @@ -568,33 +593,34 @@ module TransferFunctions (CFG : ProcCfg.S) = struct add_access exp loc ~is_write_access:false acc locks threads ownership proc_data) exps ~init:accesses + let expand_actuals actuals accesses pdesc = let open Domain in if AccessDomain.is_empty accesses then accesses else let rec get_access_path = function - | HilExp.AccessPath ap - -> Some ap - | HilExp.Cast (_, e) | HilExp.Exception e - -> get_access_path e - | _ - -> None + | HilExp.AccessPath ap -> + Some ap + | HilExp.Cast (_, e) | HilExp.Exception e -> + get_access_path e + | _ -> + None in let formal_map = FormalMap.make pdesc in - let expand_path (base, accesses as path) = + let expand_path ((base, accesses) as path) = match FormalMap.get_formal_index base formal_map with | Some formal_index -> ( match List.nth actuals formal_index with | Some actual_exp -> ( match get_access_path actual_exp with - | Some actual - -> AccessPath.append actual accesses - | None - -> path ) - | None - -> path ) - | None - -> path + | Some actual -> + AccessPath.append actual accesses + | None -> + path ) + | None -> + path ) + | None -> + path in let expand_pre accesses = let sinks = @@ -608,12 +634,13 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in AccessDomain.map expand_pre accesses + let exec_instr (astate: Domain.astate) ({ProcData.tenv; extras; pdesc} as proc_data) _ (instr: HilInstr.t) = let open Domain in match instr with - | Call (Some ret_base, Direct procname, actuals, _, loc) when acquires_ownership procname tenv - -> let accesses = + | Call (Some ret_base, Direct procname, actuals, _, loc) when acquires_ownership procname tenv -> + let accesses = add_reads actuals loc astate.accesses astate.locks astate.threads astate.ownership proc_data in @@ -622,7 +649,7 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in {astate with accesses; ownership} | Call (ret_opt, Direct callee_pname, actuals, call_flags, loc) - -> ( + -> ( let accesses_with_unannotated_calls = add_unannotated_call_access callee_pname call_flags loc tenv ~locks:astate.locks ~threads:astate.threads astate.accesses proc_data @@ -634,24 +661,24 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let astate = {astate with accesses} in let astate = match get_thread_model callee_pname with - | BackgroundThread - -> {astate with threads= ThreadsDomain.AnyThread} - | MainThread - -> {astate with threads= ThreadsDomain.AnyThreadButSelf} + | BackgroundThread -> + {astate with threads= ThreadsDomain.AnyThread} + | MainThread -> + {astate with threads= ThreadsDomain.AnyThreadButSelf} | MainThreadIfTrue -> ( match ret_opt with - | Some ret_access_path - -> let attribute_map = + | Some ret_access_path -> + let attribute_map = AttributeMapDomain.add_attribute (ret_access_path, []) (Choice Choice.OnMainThread) astate.attribute_map in {astate with attribute_map} - | None - -> L.(die InternalError) + | None -> + L.(die InternalError) "Procedure %a specified as returning boolean, but returns nothing" Typ.Procname.pp callee_pname ) - | UnknownThread - -> astate + | UnknownThread -> + astate in let astate_callee = (* assuming that modeled procedures do not have useful summaries *) @@ -662,30 +689,30 @@ module TransferFunctions (CFG : ProcCfg.S) = struct with other threads or not, start assuming that it can. why use a lock if the function can't run in a multithreaded context? *) let update_for_lock_use = function - | ThreadsDomain.AnyThreadButSelf - -> ThreadsDomain.AnyThreadButSelf - | _ - -> ThreadsDomain.AnyThread + | ThreadsDomain.AnyThreadButSelf -> + ThreadsDomain.AnyThreadButSelf + | _ -> + ThreadsDomain.AnyThread in match get_lock_model callee_pname actuals with - | Lock - -> {astate with locks= true; threads= update_for_lock_use astate.threads} - | Unlock - -> {astate with locks= false; threads= update_for_lock_use astate.threads} + | Lock -> + {astate with locks= true; threads= update_for_lock_use astate.threads} + | Unlock -> + {astate with locks= false; threads= update_for_lock_use astate.threads} | LockedIfTrue -> ( match ret_opt with - | Some ret_access_path - -> let attribute_map = + | Some ret_access_path -> + let attribute_map = AttributeMapDomain.add_attribute (ret_access_path, []) (Choice Choice.LockHeld) astate.attribute_map in {astate with attribute_map; threads= update_for_lock_use astate.threads} - | None - -> L.(die InternalError) + | None -> + L.(die InternalError) "Procedure %a specified as returning boolean, but returns nothing" Typ.Procname.pp callee_pname ) - | NoEffect - -> let summary_opt = get_summary pdesc callee_pname actuals loc tenv in + | NoEffect -> + let summary_opt = get_summary pdesc callee_pname actuals loc tenv in let callee_pdesc = extras callee_pname in match Option.map summary_opt ~f:(fun summary -> @@ -695,8 +722,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in {summary with accesses= rebased_accesses} ) with - | Some {threads; locks; accesses; return_ownership; return_attributes} - -> let update_caller_accesses pre callee_accesses caller_accesses = + | Some {threads; locks; accesses; return_ownership; return_attributes} -> + let update_caller_accesses pre callee_accesses caller_accesses = let combined_accesses = PathDomain.with_callsite callee_accesses (CallSite.make callee_pname loc) |> PathDomain.join (AccessDomain.get_accesses pre caller_accesses) @@ -706,75 +733,74 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let locks = locks || astate.locks in let threads = match (astate.threads, threads) with - | _, ThreadsDomain.AnyThreadButSelf | AnyThreadButSelf, _ - -> ThreadsDomain.AnyThreadButSelf - | _, ThreadsDomain.AnyThread - -> astate.threads - | _ - -> ThreadsDomain.join threads astate.threads + | _, ThreadsDomain.AnyThreadButSelf | AnyThreadButSelf, _ -> + ThreadsDomain.AnyThreadButSelf + | _, ThreadsDomain.AnyThread -> + astate.threads + | _ -> + ThreadsDomain.join threads astate.threads in (* add [ownership_accesses] to the [accesses_acc] with a protected pre if [exp] is owned, and an appropriate unprotected pre otherwise *) let add_ownership_access ownership_accesses actual_exp accesses_acc = match actual_exp with - | HilExp.Constant _ - -> (* the actual is a constant, so it's owned in the caller. *) + | HilExp.Constant _ -> + (* the actual is a constant, so it's owned in the caller. *) accesses_acc - | HilExp.AccessPath actual_access_path - -> if OwnershipDomain.is_owned actual_access_path astate.ownership then + | HilExp.AccessPath actual_access_path -> + if OwnershipDomain.is_owned actual_access_path astate.ownership then (* the actual passed to the current callee is owned. drop all the conditional accesses for that actual, since they're all safe *) accesses_acc else let pre = match AccessPrecondition.make locks threads pdesc with - | AccessPrecondition.Protected _ as excluder (* access protected *) - -> excluder - | _ - -> let base = fst actual_access_path in + | AccessPrecondition.Protected _ as excluder (* access protected *) -> + excluder + | _ -> + let base = fst actual_access_path in match OwnershipDomain.get_owned (base, []) astate.ownership with - | OwnershipAbstractValue.OwnedIf formal_indexes - -> (* the actual passed to the current callee is rooted in a + | OwnershipAbstractValue.OwnedIf formal_indexes -> + (* the actual passed to the current callee is rooted in a formal *) AccessPrecondition.Unprotected formal_indexes - | OwnershipAbstractValue.Unowned | OwnershipAbstractValue.Owned - -> + | OwnershipAbstractValue.Unowned | OwnershipAbstractValue.Owned -> match OwnershipDomain.get_owned actual_access_path astate.ownership with - | OwnershipAbstractValue.OwnedIf formal_indexes - -> (* access path conditionally owned if [formal_indexes] are + | OwnershipAbstractValue.OwnedIf formal_indexes -> + (* access path conditionally owned if [formal_indexes] are owned *) AccessPrecondition.Unprotected formal_indexes - | OwnershipAbstractValue.Owned - -> assert false - | OwnershipAbstractValue.Unowned - -> (* access path not rooted in a formal and not conditionally + | OwnershipAbstractValue.Owned -> + assert false + | OwnershipAbstractValue.Unowned -> + (* access path not rooted in a formal and not conditionally owned *) AccessPrecondition.TotallyUnprotected in update_caller_accesses pre ownership_accesses accesses_acc - | _ - -> (* couldn't find access path, don't know if it's owned *) + | _ -> + (* couldn't find access path, don't know if it's owned *) update_caller_accesses AccessPrecondition.TotallyUnprotected ownership_accesses accesses_acc in let accesses = let update_accesses pre callee_accesses accesses_acc = match pre with - | AccessPrecondition.Protected _ - -> update_caller_accesses pre callee_accesses accesses_acc - | AccessPrecondition.TotallyUnprotected - -> let pre' = AccessPrecondition.make locks threads pdesc in + | AccessPrecondition.Protected _ -> + update_caller_accesses pre callee_accesses accesses_acc + | AccessPrecondition.TotallyUnprotected -> + let pre' = AccessPrecondition.make locks threads pdesc in update_caller_accesses pre' callee_accesses accesses_acc - | AccessPrecondition.Unprotected formal_indexes - -> IntSet.fold + | AccessPrecondition.Unprotected formal_indexes -> + IntSet.fold (fun index acc -> match List.nth actuals index with - | Some actual - -> add_ownership_access callee_accesses actual acc - | None - -> L.internal_error + | Some actual -> + add_ownership_access callee_accesses actual acc + | None -> + L.internal_error "Bad actual index %d for callee %a with %d actuals." index Typ.Procname.pp callee_pname (List.length actuals) ; acc) @@ -786,8 +812,8 @@ module TransferFunctions (CFG : ProcCfg.S) = struct propagate_return ret_opt return_ownership return_attributes actuals astate in {locks; threads; accesses; ownership; attribute_map} - | None - -> let should_assume_returns_ownership (call_flags: CallFlags.t) actuals = + | None -> + let should_assume_returns_ownership (call_flags: CallFlags.t) actuals = (* assume non-interface methods with no summary and no parameters return ownership *) not call_flags.cf_interface && List.is_empty actuals @@ -796,30 +822,30 @@ module TransferFunctions (CFG : ProcCfg.S) = struct match (ret_opt, actuals) with | Some ret, (HilExp.AccessPath actual_ap) :: _ when AttributeMapDomain.has_attribute actual_ap Functional - astate.attribute_map - -> (* TODO: check for constants, which are functional? *) + astate.attribute_map -> + (* TODO: check for constants, which are functional? *) let attribute_map = AttributeMapDomain.add_attribute (ret, []) Functional astate.attribute_map in {astate with attribute_map} - | _ - -> astate + | _ -> + astate else if should_assume_returns_ownership call_flags actuals then match ret_opt with - | Some ret - -> let ownership = + | Some ret -> + let ownership = OwnershipDomain.add (ret, []) OwnershipAbstractValue.owned astate.ownership in {astate with ownership} - | None - -> astate + | None -> + astate else astate in match ret_opt with - | Some ret - -> let add_if_annotated predicate attribute attribute_map = + | Some ret -> + let add_if_annotated predicate attribute attribute_map = if PatternMatch.override_exists predicate tenv callee_pname then AttributeMapDomain.add_attribute (ret, []) attribute attribute_map else attribute_map @@ -829,16 +855,17 @@ module TransferFunctions (CFG : ProcCfg.S) = struct in let ownership = if PatternMatch.override_exists - (has_return_annot Annotations.ia_is_returns_ownership) tenv callee_pname + (has_return_annot Annotations.ia_is_returns_ownership) + tenv callee_pname then OwnershipDomain.add (ret, []) OwnershipAbstractValue.owned astate_callee.ownership else astate_callee.ownership in {astate_callee with ownership; attribute_map} - | _ - -> astate_callee ) - | Assign (lhs_access_path, rhs_exp, loc) - -> let rhs_accesses = + | _ -> + astate_callee ) + | Assign (lhs_access_path, rhs_exp, loc) -> + let rhs_accesses = add_access rhs_exp loc ~is_write_access:false astate.accesses astate.locks astate.threads astate.ownership proc_data in @@ -851,13 +878,13 @@ module TransferFunctions (CFG : ProcCfg.S) = struct rhs_access_paths && match AccessPath.get_typ lhs_access_path tenv with - | Some {Typ.desc= Typ.Tint ILong | Tfloat FDouble} - -> (* writes to longs and doubles are not guaranteed to be atomic in Java + | Some {Typ.desc= Typ.Tint ILong | Tfloat FDouble} -> + (* writes to longs and doubles are not guaranteed to be atomic in Java (http://docs.oracle.com/javase/specs/jls/se7/html/jls-17.html#jls-17.7), so there can be a race even if the RHS is functional *) false - | _ - -> true + | _ -> + true in let accesses = if is_functional then @@ -871,42 +898,42 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let ownership = propagate_ownership lhs_access_path rhs_exp astate.ownership in let attribute_map = propagate_attributes lhs_access_path rhs_exp astate.attribute_map in {astate with accesses; ownership; attribute_map} - | Assume (assume_exp, _, _, loc) - -> let rec eval_binop op var e1 e2 = + | Assume (assume_exp, _, _, loc) -> + let rec eval_binop op var e1 e2 = match (eval_bexp var e1, eval_bexp var e2) with - | Some b1, Some b2 - -> Some (op b1 b2) - | _ - -> None + | Some b1, Some b2 -> + Some (op b1 b2) + | _ -> + None (* return Some bool_value if the given boolean expression evaluates to bool_value when [var] is set to true. return None if it has free variables that stop us from evaluating it *) and eval_bexp var = function - | HilExp.AccessPath ap when AccessPath.equal ap var - -> Some true - | HilExp.Constant c - -> Some (not (Const.iszero_int_float c)) - | HilExp.UnaryOperator (Unop.LNot, e, _) - -> let b_opt = eval_bexp var e in + | HilExp.AccessPath ap when AccessPath.equal ap var -> + Some true + | HilExp.Constant c -> + Some (not (Const.iszero_int_float c)) + | HilExp.UnaryOperator (Unop.LNot, e, _) -> + let b_opt = eval_bexp var e in Option.map ~f:not b_opt - | HilExp.BinaryOperator (Binop.LAnd, e1, e2) - -> eval_binop ( && ) var e1 e2 - | HilExp.BinaryOperator (Binop.LOr, e1, e2) - -> eval_binop ( || ) var e1 e2 - | HilExp.BinaryOperator (Binop.Eq, e1, e2) - -> eval_binop Bool.equal var e1 e2 - | HilExp.BinaryOperator (Binop.Ne, e1, e2) - -> eval_binop ( <> ) var e1 e2 - | _ - -> (* non-boolean expression; can't evaluate it *) + | HilExp.BinaryOperator (Binop.LAnd, e1, e2) -> + eval_binop ( && ) var e1 e2 + | HilExp.BinaryOperator (Binop.LOr, e1, e2) -> + eval_binop ( || ) var e1 e2 + | HilExp.BinaryOperator (Binop.Eq, e1, e2) -> + eval_binop Bool.equal var e1 e2 + | HilExp.BinaryOperator (Binop.Ne, e1, e2) -> + eval_binop ( <> ) var e1 e2 + | _ -> + (* non-boolean expression; can't evaluate it *) None in let add_choice bool_value (acc: Domain.astate) = function - | Choice.LockHeld - -> let locks = bool_value in + | Choice.LockHeld -> + let locks = bool_value in {acc with locks} - | Choice.OnMainThread - -> let threads = + | Choice.OnMainThread -> + let threads = if bool_value then ThreadsDomain.AnyThreadButSelf else ThreadsDomain.AnyThread in {acc with threads} @@ -918,25 +945,26 @@ module TransferFunctions (CFG : ProcCfg.S) = struct let astate' = match HilExp.get_access_paths assume_exp with | [access_path] - -> ( + -> ( let choices = AttributeMapDomain.get_choices access_path astate.attribute_map in match eval_bexp access_path assume_exp with - | Some bool_value - -> (* prune (prune_exp) can only evaluate to true if the choice is [bool_value]. + | Some bool_value -> + (* prune (prune_exp) can only evaluate to true if the choice is [bool_value]. add the constraint that the the choice must be [bool_value] to the state *) List.fold ~f:(add_choice bool_value) ~init:astate choices - | None - -> astate ) - | _ - -> astate + | None -> + astate ) + | _ -> + astate in {astate' with accesses} | Call (_, Indirect _, _, _, _) -> match Procdesc.get_proc_name pdesc with - | Typ.Procname.Java _ - -> L.(die InternalError) "Unexpected indirect call instruction %a" HilInstr.pp instr - | _ - -> astate + | Typ.Procname.Java _ -> + L.(die InternalError) "Unexpected indirect call instruction %a" HilInstr.pp instr + | _ -> + astate + end module Analyzer = @@ -952,6 +980,7 @@ let is_thread_confined_method tenv pdesc = || PatternMatch.check_current_class_attributes Annotations.ia_is_thread_confined tenv (Procdesc.get_proc_name pdesc) + (* we don't want to warn on methods that run on the UI thread because they should always be single-threaded *) let runs_on_ui_thread proc_desc = @@ -962,9 +991,11 @@ let runs_on_ui_thread proc_desc = || Annotations.ia_is_on_event annot || Annotations.ia_is_on_mount annot || Annotations.ia_is_on_unbind annot || Annotations.ia_is_on_unmount annot ) + let threadsafe_annotations = Annotations.thread_safe :: RacerDConfig.AnnotationAliases.of_json Config.threadsafe_aliases + (* returns true if the annotation is @ThreadSafe, @ThreadSafe(enableChecks = true), or is defined as an alias of @ThreadSafe in a .inferconfig file. *) let is_thread_safe item_annot = @@ -978,6 +1009,7 @@ let is_thread_safe item_annot = in List.exists ~f item_annot + (* returns true if the annotation is @ThreadSafe(enableChecks = false) *) let is_assumed_thread_safe item_annot = let f (annot, _) = @@ -986,11 +1018,13 @@ let is_assumed_thread_safe item_annot = in List.exists ~f item_annot + let pdesc_is_assumed_thread_safe pdesc tenv = is_assumed_thread_safe (Annotations.pdesc_get_return_annot pdesc) || PatternMatch.check_current_class_attributes is_assumed_thread_safe tenv (Procdesc.get_proc_name pdesc) + (* return true if we should compute a summary for the procedure. if this returns false, we won't analyze the procedure or report any warnings on it *) (* note: in the future, we will want to analyze the procedures in all of these cases in order to @@ -1000,16 +1034,18 @@ let should_analyze_proc pdesc tenv = not (Typ.Procname.is_class_initializer pn) && not (FbThreadSafety.is_logging_method pn) && not (pdesc_is_assumed_thread_safe pdesc tenv) + let get_current_class_and_threadsafe_superclasses tenv pname = match pname with - | Typ.Procname.Java java_pname - -> let current_class = Typ.Procname.java_get_class_type_name java_pname in + | Typ.Procname.Java java_pname -> + let current_class = Typ.Procname.java_get_class_type_name java_pname in let thread_safe_annotated_classes = PatternMatch.find_superclasses_with_attributes is_thread_safe tenv current_class in Some (current_class, thread_safe_annotated_classes) - | _ - -> None + | _ -> + None + let is_thread_safe_class pname tenv = not @@ -1018,10 +1054,11 @@ let is_thread_safe_class pname tenv = && (* current class or superclass is marked thread-safe *) match get_current_class_and_threadsafe_superclasses tenv pname with - | Some (_, thread_safe_annotated_classes) - -> not (List.is_empty thread_safe_annotated_classes) - | _ - -> false + | Some (_, thread_safe_annotated_classes) -> + not (List.is_empty thread_safe_annotated_classes) + | _ -> + false + let is_thread_safe_method pname tenv = PatternMatch.override_exists @@ -1030,10 +1067,12 @@ let is_thread_safe_method pname tenv = is_thread_safe) tenv pname + let is_marked_thread_safe pdesc tenv = let pname = Procdesc.get_proc_name pdesc in is_thread_safe_class pname tenv || is_thread_safe_method pname tenv + let empty_post : RacerDDomain.summary = { threads= RacerDDomain.ThreadsDomain.empty ; locks= false @@ -1041,6 +1080,7 @@ let empty_post : RacerDDomain.summary = ; return_ownership= RacerDDomain.OwnershipAbstractValue.unowned ; return_attributes= RacerDDomain.AttributeSetDomain.empty } + let analyze_procedure {Callbacks.proc_desc; get_proc_desc; tenv; summary} = let is_initializer tenv proc_name = Typ.Procname.is_constructor proc_name || FbThreadSafety.is_custom_init tenv proc_name @@ -1067,19 +1107,19 @@ let analyze_procedure {Callbacks.proc_desc; get_proc_desc; tenv; summary} = variables cannot be raced on as every thread has its own stack. *) let own_locals_in_cpp = match Procdesc.get_proc_name proc_desc with - | ObjC_Cpp _ - -> List.fold ~f:add_owned_local (Procdesc.get_locals proc_desc) + | ObjC_Cpp _ -> + List.fold ~f:add_owned_local (Procdesc.get_locals proc_desc) ~init:OwnershipDomain.empty - | _ - -> OwnershipDomain.empty + | _ -> + OwnershipDomain.empty in if is_initializer tenv (Procdesc.get_proc_name proc_desc) then let add_owned_formal acc formal_index = match FormalMap.get_formal_base formal_index formal_map with - | Some base - -> OwnershipDomain.add (base, []) OwnershipAbstractValue.owned acc - | None - -> acc + | Some base -> + OwnershipDomain.add (base, []) OwnershipAbstractValue.owned acc + | None -> + acc in let owned_formals = (* if a constructer is called via DI, all of its formals will be freshly allocated and @@ -1099,14 +1139,15 @@ let analyze_procedure {Callbacks.proc_desc; get_proc_desc; tenv; summary} = OwnershipDomain.add (formal, []) (OwnershipAbstractValue.make_owned_if formal_index) acc in let ownership = - List.fold ~f:add_owned_formal (FormalMap.get_formals_indexes formal_map) + List.fold ~f:add_owned_formal + (FormalMap.get_formals_indexes formal_map) ~init:own_locals_in_cpp in ({RacerDDomain.empty with ownership; threads}, IdAccessPathMapDomain.empty) in match Analyzer.compute_post proc_data ~initial ~debug:false with - | Some ({threads; locks; accesses; ownership; attribute_map}, _) - -> let return_var_ap = + | Some ({threads; locks; accesses; ownership; attribute_map}, _) -> + let return_var_ap = AccessPath.of_pvar (Pvar.get_ret_pvar (Procdesc.get_proc_name proc_desc)) (Procdesc.get_ret_type proc_desc) @@ -1118,10 +1159,11 @@ let analyze_procedure {Callbacks.proc_desc; get_proc_desc; tenv; summary} = in let post = {threads; locks; accesses; return_ownership; return_attributes} in Summary.update_summary post summary - | None - -> summary ) + | None -> + summary ) else Summary.update_summary empty_post summary + module AccessListMap = Caml.Map.Make (RacerDDomain.Access) type conflicts = RacerDDomain.TraceElem.t list @@ -1143,43 +1185,45 @@ let get_reporting_explanation report_kind tenv pname thread = MF.pp_monospaced "@ThreadSafe") else match get_current_class_and_threadsafe_superclasses tenv pname with - | Some (current_class, (thread_safe_class :: _ as thread_safe_annotated_classes)) - -> Some + | Some (current_class, (thread_safe_class :: _ as thread_safe_annotated_classes)) -> + Some ( if List.mem ~equal:Typ.Name.equal thread_safe_annotated_classes current_class then F.asprintf "@\n Reporting because the current class is annotated %a" MF.pp_monospaced "@ThreadSafe" else F.asprintf "@\n Reporting because a superclass %a is annotated %a" (MF.wrap_monospaced Typ.Name.pp) thread_safe_class MF.pp_monospaced "@ThreadSafe" ) - | _ - -> None + | _ -> + None in match (report_kind, annotation_explanation_opt) with - | UnannotatedInterface, Some threadsafe_explanation - -> F.asprintf "%s." threadsafe_explanation - | UnannotatedInterface, None - -> Logging.die InternalError + | UnannotatedInterface, Some threadsafe_explanation -> + F.asprintf "%s." threadsafe_explanation + | UnannotatedInterface, None -> + Logging.die InternalError "Reporting non-threadsafe interface call, but can't find a @ThreadSafe annotation" - | _, Some threadsafe_explanation when RacerDDomain.ThreadsDomain.is_any thread - -> F.asprintf + | _, Some threadsafe_explanation when RacerDDomain.ThreadsDomain.is_any thread -> + F.asprintf "%s, so we assume that this method can run in parallel with other non-private methods in the class (incuding itself)." threadsafe_explanation - | _, Some threadsafe_explanation - -> F.asprintf + | _, Some threadsafe_explanation -> + F.asprintf "%s. Although this access is not known to run on a background thread, it may happen in parallel with another access that does." threadsafe_explanation - | _, None - -> (* failed to explain based on @ThreadSafe annotation; have to justify using background thread *) + | _, None -> + (* failed to explain based on @ThreadSafe annotation; have to justify using background thread *) if RacerDDomain.ThreadsDomain.is_any thread then F.asprintf "@\n Reporting because this access may occur on a background thread." else F.asprintf "@\n Reporting because another access to the same memory occurs on a background thread, although this access may not." + let filter_by_access access_filter trace = let open RacerDDomain in PathDomain.Sinks.filter access_filter (PathDomain.sinks trace) |> PathDomain.update_sinks trace + let get_all_accesses_with_pre pre_filter access_filter accesses = let open RacerDDomain in AccessDomain.fold @@ -1187,51 +1231,58 @@ let get_all_accesses_with_pre pre_filter access_filter accesses = if pre_filter pre then PathDomain.join (filter_by_access access_filter trace) acc else acc) accesses PathDomain.empty + let get_all_accesses = get_all_accesses_with_pre (fun _ -> true) let pp_container_access fmt (access_path, access_pname) = - F.fprintf fmt "container %a via call to %s" (MF.wrap_monospaced AccessPath.pp) access_path + F.fprintf fmt "container %a via call to %s" + (MF.wrap_monospaced AccessPath.pp) + access_path (MF.monospaced_to_string (Typ.Procname.get_method access_pname)) + let pp_access fmt sink = match RacerDDomain.PathDomain.Sink.kind sink with - | Read access_path | Write access_path - -> F.fprintf fmt "%a" (MF.wrap_monospaced AccessPath.pp) access_path - | ContainerRead (access_path, access_pname) | ContainerWrite (access_path, access_pname) - -> pp_container_access fmt (access_path, access_pname) - | InterfaceCall _ as access - -> F.fprintf fmt "%a" RacerDDomain.Access.pp access + | Read access_path | Write access_path -> + F.fprintf fmt "%a" (MF.wrap_monospaced AccessPath.pp) access_path + | ContainerRead (access_path, access_pname) | ContainerWrite (access_path, access_pname) -> + pp_container_access fmt (access_path, access_pname) + | InterfaceCall _ as access -> + F.fprintf fmt "%a" RacerDDomain.Access.pp access + let desc_of_sink sink = let sink_pname = CallSite.pname (RacerDDomain.PathDomain.Sink.call_site sink) in match RacerDDomain.PathDomain.Sink.kind sink with - | Read _ | Write _ - -> if Typ.Procname.equal sink_pname Typ.Procname.empty_block then + | Read _ | Write _ -> + if Typ.Procname.equal sink_pname Typ.Procname.empty_block then F.asprintf "access to %a" pp_access sink else F.asprintf "call to %a" Typ.Procname.pp sink_pname - | ContainerRead (access_path, access_pname) - -> if Typ.Procname.equal sink_pname access_pname then + | ContainerRead (access_path, access_pname) -> + if Typ.Procname.equal sink_pname access_pname then F.asprintf "Read of %a" pp_container_access (access_path, access_pname) else F.asprintf "call to %a" Typ.Procname.pp sink_pname - | ContainerWrite (access_path, access_pname) - -> if Typ.Procname.equal sink_pname access_pname then + | ContainerWrite (access_path, access_pname) -> + if Typ.Procname.equal sink_pname access_pname then F.asprintf "Write to %a" pp_container_access (access_path, access_pname) else F.asprintf "call to %a" Typ.Procname.pp sink_pname - | InterfaceCall _ as access - -> if Typ.Procname.equal sink_pname Typ.Procname.empty_block then + | InterfaceCall _ as access -> + if Typ.Procname.equal sink_pname Typ.Procname.empty_block then F.asprintf "%a" RacerDDomain.Access.pp access else F.asprintf "call to %a" Typ.Procname.pp sink_pname + let trace_of_pname orig_sink orig_pdesc callee_pname = let open RacerDDomain in let orig_access = PathDomain.Sink.kind orig_sink in match Summary.read_summary orig_pdesc callee_pname with - | Some {accesses} - -> get_all_accesses + | Some {accesses} -> + get_all_accesses (fun access -> Access.matches ~caller:orig_access ~callee:(PathDomain.Sink.kind access)) accesses - | _ - -> PathDomain.empty + | _ -> + PathDomain.empty + let make_trace ~report_kind original_path pdesc = let open RacerDDomain in @@ -1239,10 +1290,10 @@ let make_trace ~report_kind original_path pdesc = let make_trace_for_sink sink = let trace_of_pname = trace_of_pname sink pdesc in match PathDomain.get_reportable_sink_path sink ~trace_of_pname with - | Some path - -> loc_trace_of_path path - | None - -> [] + | Some path -> + loc_trace_of_path path + | None -> + [] in let original_trace = loc_trace_of_path original_path in let make_with_conflicts conflict_sink original_trace ~label1 ~label2 = @@ -1258,20 +1309,21 @@ let make_trace ~report_kind original_path pdesc = first_trace_spacer :: original_trace @ second_trace_spacer :: conflict_trace in match report_kind with - | ReadWriteRace (conflict_sink :: _) - -> make_with_conflicts conflict_sink original_trace ~label1:"" + | ReadWriteRace (conflict_sink :: _) -> + make_with_conflicts conflict_sink original_trace ~label1:"" ~label2:"" - | WriteWriteRace (conflict_sink :: _) - -> make_with_conflicts conflict_sink original_trace ~label1:"" + | WriteWriteRace (conflict_sink :: _) -> + make_with_conflicts conflict_sink original_trace ~label1:"" ~label2:"" - | ReadWriteRace [] | WriteWriteRace [] | UnannotatedInterface - -> original_trace + | ReadWriteRace [] | WriteWriteRace [] | UnannotatedInterface -> + original_trace + let report_thread_safety_violation tenv pdesc issue_type ~make_description ~report_kind access thread = let open RacerDDomain in let pname = Procdesc.get_proc_name pdesc in - let report_one_path (_, sinks as path) = + let report_one_path ((_, sinks) as path) = let initial_sink, _ = List.last_exn sinks in let final_sink, _ = List.hd_exn sinks in let initial_sink_site = PathDomain.Sink.call_site initial_sink in @@ -1291,10 +1343,11 @@ let report_thread_safety_violation tenv pdesc issue_type ~make_description ~repo let trace_of_pname = trace_of_pname access pdesc in Option.iter ~f:report_one_path (PathDomain.get_reportable_sink_path access ~trace_of_pname) + let report_unannotated_interface_violation tenv pdesc access thread reported_pname = match reported_pname with - | Typ.Procname.Java java_pname - -> let class_name = Typ.Procname.java_get_class_name java_pname in + | Typ.Procname.Java java_pname -> + let class_name = Typ.Procname.java_get_class_name java_pname in let make_description _ _ _ _ = F.asprintf "Unprotected call to method of un-annotated interface %s. Consider annotating the class with %a, adding a lock, or using an interface that is known to be thread-safe." @@ -1302,24 +1355,29 @@ let report_unannotated_interface_violation tenv pdesc access thread reported_pna in report_thread_safety_violation tenv pdesc IssueType.interface_not_thread_safe ~make_description ~report_kind:UnannotatedInterface access thread - | _ - -> (* skip reporting on C++ *) + | _ -> + (* skip reporting on C++ *) () + let pp_procname_short fmt = function - | Typ.Procname.Java java - -> F.fprintf fmt "%s.%s" (Typ.Procname.java_get_class_name java) + | Typ.Procname.Java java -> + F.fprintf fmt "%s.%s" + (Typ.Procname.java_get_class_name java) (Typ.Procname.java_get_method java) - | pname - -> Typ.Procname.pp fmt pname + | pname -> + Typ.Procname.pp fmt pname + let make_unprotected_write_description pname final_sink_site initial_sink_site final_sink = Format.asprintf "Unprotected write. Non-private method %a%s %s %a outside of synchronization." - (MF.wrap_monospaced pp_procname_short) pname + (MF.wrap_monospaced pp_procname_short) + pname (if CallSite.equal final_sink_site initial_sink_site then "" else " indirectly") (if RacerDDomain.TraceElem.is_container_write final_sink then "mutates" else "writes to field") pp_access final_sink + let make_read_write_race_description ~read_is_sync conflicts pname final_sink_site initial_sink_site final_sink = let conflicting_proc_names = @@ -1338,11 +1396,13 @@ let make_read_write_race_description ~read_is_sync conflicts pname final_sink_si (MF.wrap_monospaced pp_conflicts) conflicting_proc_names in Format.asprintf "Read/Write race. Non-private method %a%s reads%s from %a. %s." - (MF.wrap_monospaced pp_procname_short) pname + (MF.wrap_monospaced pp_procname_short) + pname (if CallSite.equal final_sink_site initial_sink_site then "" else " indirectly") (if read_is_sync then " with synchronization" else " without synchronization") pp_access final_sink conflicts_description + (** type for remembering what we have already reported to avoid duplicates. our policy is to report each kind of access (read/write) to the same field reachable from the same procedure only once. in addition, if a call to a procedure (transitively) accesses multiple fields, we will only @@ -1358,6 +1418,7 @@ let empty_reported = let reported_reads = Typ.Procname.Set.empty in {reported_sites; reported_reads; reported_writes} + (* return true if procedure is at an abstraction boundary or reporting has been explicitly requested via @ThreadSafe *) let should_report_on_proc proc_desc tenv = @@ -1367,6 +1428,7 @@ let should_report_on_proc proc_desc tenv = && Procdesc.get_access proc_desc <> PredSymb.Private && not (Annotations.pdesc_return_annot_ends_with proc_desc Annotations.visibleForTesting) + (** Report accesses that may race with each other. Principles for race reporting. @@ -1397,38 +1459,38 @@ let should_report_on_proc proc_desc tenv = *) let report_unsafe_accesses (aggregated_access_map: - ( RacerDDomain.TraceElem.t - * RacerDDomain.AccessPrecondition.t - * RacerDDomain.ThreadsDomain.astate - * Tenv.t - * Procdesc.t ) - list - AccessListMap.t) = + ( RacerDDomain.TraceElem.t + * RacerDDomain.AccessPrecondition.t + * RacerDDomain.ThreadsDomain.astate + * Tenv.t + * Procdesc.t ) + list + AccessListMap.t) = let open RacerDDomain in let is_duplicate_report access pname {reported_sites; reported_writes; reported_reads} = if Config.filtering then CallSite.Set.mem (TraceElem.call_site access) reported_sites || match TraceElem.kind access with - | Access.Write _ | Access.ContainerWrite _ - -> Typ.Procname.Set.mem pname reported_writes - | Access.Read _ | Access.ContainerRead _ - -> Typ.Procname.Set.mem pname reported_reads - | Access.InterfaceCall _ - -> false + | Access.Write _ | Access.ContainerWrite _ -> + Typ.Procname.Set.mem pname reported_writes + | Access.Read _ | Access.ContainerRead _ -> + Typ.Procname.Set.mem pname reported_reads + | Access.InterfaceCall _ -> + false else false in let update_reported access pname reported = if Config.filtering then let reported_sites = CallSite.Set.add (TraceElem.call_site access) reported.reported_sites in match TraceElem.kind access with - | Access.Write _ | Access.ContainerWrite _ - -> let reported_writes = Typ.Procname.Set.add pname reported.reported_writes in + | Access.Write _ | Access.ContainerWrite _ -> + let reported_writes = Typ.Procname.Set.add pname reported.reported_writes in {reported with reported_writes; reported_sites} - | Access.Read _ | Access.ContainerRead _ - -> let reported_reads = Typ.Procname.Set.add pname reported.reported_reads in + | Access.Read _ | Access.ContainerRead _ -> + let reported_reads = Typ.Procname.Set.add pname reported.reported_reads in {reported with reported_reads; reported_sites} - | Access.InterfaceCall _ - -> reported + | Access.InterfaceCall _ -> + reported else reported in let report_unsafe_access (access, pre, thread, tenv, pdesc) accesses reported_acc = @@ -1437,20 +1499,20 @@ let report_unsafe_accesses else match (TraceElem.kind access, pre) with | ( Access.InterfaceCall unannoted_call_pname - , (AccessPrecondition.Unprotected _ | AccessPrecondition.TotallyUnprotected) ) - -> if ThreadsDomain.is_any thread && is_marked_thread_safe pdesc tenv then ( + , (AccessPrecondition.Unprotected _ | AccessPrecondition.TotallyUnprotected) ) -> + if ThreadsDomain.is_any thread && is_marked_thread_safe pdesc tenv then ( (* un-annotated interface call + no lock in method marked thread-safe. warn *) report_unannotated_interface_violation tenv pdesc access thread unannoted_call_pname ; update_reported access pname reported_acc ) else reported_acc - | Access.InterfaceCall _, AccessPrecondition.Protected _ - -> (* un-annotated interface call, but it's protected by a lock/thread. don't report *) + | Access.InterfaceCall _, AccessPrecondition.Protected _ -> + (* un-annotated interface call, but it's protected by a lock/thread. don't report *) reported_acc | ( (Access.Write _ | ContainerWrite _) , (AccessPrecondition.Unprotected _ | AccessPrecondition.TotallyUnprotected) ) -> ( match Procdesc.get_proc_name pdesc with - | Java _ - -> let writes_on_background_thread = + | Java _ -> + let writes_on_background_thread = if ThreadsDomain.is_any thread then (* unprotected write in method that may run in parallel with itself. warn *) [] @@ -1472,23 +1534,23 @@ let report_unsafe_accesses ~make_description:make_unprotected_write_description ~report_kind:(WriteWriteRace writes_on_background_thread) access thread ; update_reported access pname reported_acc ) - | _ - -> (* Do not report unprotected writes when an access can't run in parallel with itself, or + | _ -> + (* Do not report unprotected writes when an access can't run in parallel with itself, or for ObjC_Cpp *) reported_acc ) - | (Access.Write _ | ContainerWrite _), AccessPrecondition.Protected _ - -> (* protected write, do nothing *) + | (Access.Write _ | ContainerWrite _), AccessPrecondition.Protected _ -> + (* protected write, do nothing *) reported_acc | ( (Access.Read _ | ContainerRead _) - , (AccessPrecondition.Unprotected _ | AccessPrecondition.TotallyUnprotected) ) - -> (* unprotected read. report all writes as conflicts for java. for c++ filter out + , (AccessPrecondition.Unprotected _ | AccessPrecondition.TotallyUnprotected) ) -> + (* unprotected read. report all writes as conflicts for java. for c++ filter out unprotected writes *) let is_cpp_protected_write pre = match pre with - | AccessPrecondition.Unprotected _ | TotallyUnprotected - -> Typ.Procname.is_java pname - | AccessPrecondition.Protected _ - -> true + | AccessPrecondition.Unprotected _ | TotallyUnprotected -> + Typ.Procname.is_java pname + | AccessPrecondition.Protected _ -> + true in let is_conflict other_access pre other_thread = TraceElem.is_write other_access @@ -1511,27 +1573,27 @@ let report_unsafe_accesses (ReadWriteRace (List.map ~f:(fun (access, _, _, _, _) -> access) all_writes)) access thread ; update_reported access pname reported_acc ) - | (Access.Read _ | ContainerRead _), AccessPrecondition.Protected excl - -> (* protected read. report unprotected writes and opposite protected writes as conflicts + | (Access.Read _ | ContainerRead _), AccessPrecondition.Protected excl -> + (* protected read. report unprotected writes and opposite protected writes as conflicts Thread and Lock are opposites of one another, and Both has no opposite *) let is_opposite = function - | Excluder.Lock, Excluder.Thread - -> true - | Excluder.Thread, Excluder.Lock - -> true - | _, _ - -> false + | Excluder.Lock, Excluder.Thread -> + true + | Excluder.Thread, Excluder.Lock -> + true + | _, _ -> + false in let conflicting_writes = List.filter ~f:(fun (access, pre, other_thread, _, _) -> match pre with - | AccessPrecondition.Unprotected _ - -> TraceElem.is_write access && ThreadsDomain.is_any other_thread - | AccessPrecondition.Protected other_excl when is_opposite (excl, other_excl) - -> TraceElem.is_write access - | _ - -> false) + | AccessPrecondition.Unprotected _ -> + TraceElem.is_write access && ThreadsDomain.is_any other_thread + | AccessPrecondition.Protected other_excl when is_opposite (excl, other_excl) -> + TraceElem.is_write access + | _ -> + false) accesses in if List.is_empty conflicting_writes then reported_acc @@ -1564,8 +1626,8 @@ let report_unsafe_accesses in let should_report pdesc tenv = match Procdesc.get_proc_name pdesc with - | Java _ - -> (* report if + | Java _ -> + (* report if - the method/class of the access is thread-safe (or an override or superclass is), or - any access is in a field marked thread-safe (or an override) *) @@ -1573,13 +1635,13 @@ let report_unsafe_accesses ~f:(fun (_, _, thread, _, _) -> ThreadsDomain.is_any thread) grouped_accesses && should_report_on_proc pdesc tenv - | ObjC_Cpp objc_cpp - -> (* do not report if a procedure is private *) + | ObjC_Cpp objc_cpp -> + (* do not report if a procedure is private *) Procdesc.get_access pdesc <> PredSymb.Private && (* report if the class has a mutex member *) class_has_mutex_member objc_cpp tenv - | _ - -> false + | _ -> + false in let reportable_accesses = List.filter ~f:(fun (_, _, _, tenv, pdesc) -> should_report pdesc tenv) grouped_accesses @@ -1590,6 +1652,7 @@ let report_unsafe_accesses aggregated_access_map empty_reported |> ignore + type ('a, 'b, 'c) dat = RacerDDomain.TraceElem.t * 'a * 'b * Tenv.t * 'c module type QuotientedAccessListMap = sig @@ -1612,20 +1675,22 @@ module SyntacticQuotientedAccessListMap : QuotientedAccessListMap = struct if phys_equal u v then 0 else match (u, v) with - | LogicalVar i, LogicalVar j - -> Ident.compare i j - | ProgramVar x, ProgramVar y - -> Pvar.compare_modulo_this x y - | _ - -> Pervasives.compare u v + | LogicalVar i, LogicalVar j -> + Ident.compare i j + | ProgramVar x, ProgramVar y -> + Pvar.compare_modulo_this x y + | _ -> + Pervasives.compare u v + let compare (x: t) (y: t) = match (x, y) with | ( (Read ap1 | Write ap1 | ContainerRead (ap1, _) | ContainerWrite (ap1, _)) - , (Read ap2 | Write ap2 | ContainerRead (ap2, _) | ContainerWrite (ap2, _)) ) - -> [%compare : (_var * Typ.t) * AccessPath.access list] ap1 ap2 - | InterfaceCall _, _ | _, InterfaceCall _ - -> RacerDDomain.Access.compare x y + , (Read ap2 | Write ap2 | ContainerRead (ap2, _) | ContainerWrite (ap2, _)) ) -> + [%compare : (_var * Typ.t) * AccessPath.access list] ap1 ap2 + | InterfaceCall _, _ | _, InterfaceCall _ -> + RacerDDomain.Access.compare x y + end) type ('a, 'b, 'c) t = ('a, 'b, 'c) dat list M.t @@ -1639,6 +1704,7 @@ module SyntacticQuotientedAccessListMap : QuotientedAccessListMap = struct in M.add k (d :: ds) m + let quotient m = M.fold AccessListMap.add m AccessListMap.empty end @@ -1656,6 +1722,7 @@ module MayAliasQuotientedAccessListMap : QuotientedAccessListMap = struct in add k (d :: ds) m + let sound = false let syntactic_equal_access_path tenv p1 p2 = @@ -1664,10 +1731,10 @@ module MayAliasQuotientedAccessListMap : QuotientedAccessListMap = struct other Map, etc. Instead, do something simple and unsound: just assume that two accesses can be to the same container if they are to the same access path *) match (AccessPath.get_typ p1 tenv, AccessPath.get_typ p2 tenv) with - | Some {desc= Tptr ({desc= Tstruct tn1}, _)}, Some {desc= Tptr ({desc= Tstruct tn2}, _)} - -> PatternMatch.is_subtype tenv tn1 tn2 || PatternMatch.is_subtype tenv tn2 tn1 - | _ - -> true + | Some {desc= Tptr ({desc= Tstruct tn1}, _)}, Some {desc= Tptr ({desc= Tstruct tn2}, _)} -> + PatternMatch.is_subtype tenv tn1 tn2 || PatternMatch.is_subtype tenv tn2 tn1 + | _ -> + true else (* unsound, but effective: report that the containers alias if their access paths are syntactically identical *) @@ -1675,13 +1742,14 @@ module MayAliasQuotientedAccessListMap : QuotientedAccessListMap = struct | (Var.ProgramVar pvar1, typ1), (Var.ProgramVar pvar2, typ2) when Pvar.is_this pvar1 && Pvar.is_this pvar2 && ( Typ.equal typ1 typ2 || Prover.Subtyping_check.check_subtype tenv typ1 typ2 - || Prover.Subtyping_check.check_subtype tenv typ2 typ1 ) - -> (* the `this` used in C.foo and C.bar will compare unequal if we're not careful `this` is + || Prover.Subtyping_check.check_subtype tenv typ2 typ1 ) -> + (* the `this` used in C.foo and C.bar will compare unequal if we're not careful `this` is represented as a local pvar, and a local pvar contains its parent procedure name. Count the `this`'s as equal if their types are compatible *) AccessPath.equal_access_list (snd p1) (snd p2) - | _ - -> AccessPath.equal p1 p2 + | _ -> + AccessPath.equal p1 p2 + (* equivalence relation computing whether two access paths may refer to the same heap location. *) @@ -1691,20 +1759,21 @@ module MayAliasQuotientedAccessListMap : QuotientedAccessListMap = struct phys_equal p1 p2 || match (List.last_exn (snd p1), List.last_exn (snd p2)) with - | FieldAccess _, ArrayAccess _ | ArrayAccess _, FieldAccess _ - -> false + | FieldAccess _, ArrayAccess _ | ArrayAccess _, FieldAccess _ -> + false (* fields in Java contain the class name /declaring/ them thus two fields can be aliases *iff* they are equal *) - | FieldAccess f1, FieldAccess f2 - -> Typ.Fieldname.equal f1 f2 + | FieldAccess f1, FieldAccess f2 -> + Typ.Fieldname.equal f1 f2 (* if arrays of objects that have an inheritance rel then they can alias *) | ( ArrayAccess ({desc= Tptr ({desc= Tstruct tn1}, _)}, _) - , ArrayAccess ({desc= Tptr ({desc= Tstruct tn2}, _)}, _) ) - -> if sound then PatternMatch.is_subtype tenv tn1 tn2 || PatternMatch.is_subtype tenv tn2 tn1 + , ArrayAccess ({desc= Tptr ({desc= Tstruct tn2}, _)}, _) ) -> + if sound then PatternMatch.is_subtype tenv tn1 tn2 || PatternMatch.is_subtype tenv tn2 tn1 else syntactic_equal_access_path tenv p1 p2 (* primitive type arrays can alias if the prim. type is the same *) - | ArrayAccess (t1, _), ArrayAccess (t2, _) - -> if sound then equal_desc t1.desc t2.desc else syntactic_equal_access_path tenv p1 p2 + | ArrayAccess (t1, _), ArrayAccess (t2, _) -> + if sound then equal_desc t1.desc t2.desc else syntactic_equal_access_path tenv p1 p2 + (* take a results table and quotient it by the may_alias relation *) let quotient acc_map = @@ -1721,13 +1790,13 @@ module MayAliasQuotientedAccessListMap : QuotientedAccessListMap = struct AccessListMap.partition (fun k' _ -> match (k, k') with - | (Read ap1 | Write ap1), (Read ap2 | Write ap2) - -> may_alias tenv ap1 ap2 + | (Read ap1 | Write ap1), (Read ap2 | Write ap2) -> + may_alias tenv ap1 ap2 | ( (ContainerRead (ap1, _) | ContainerWrite (ap1, _)) - , (ContainerRead (ap2, _) | ContainerWrite (ap2, _)) ) - -> syntactic_equal_access_path tenv ap1 ap2 - | _ - -> RacerDDomain.Access.equal k k') + , (ContainerRead (ap2, _) | ContainerWrite (ap2, _)) ) -> + syntactic_equal_access_path tenv ap1 ap2 + | _ -> + RacerDDomain.Access.equal k k') m in if AccessListMap.is_empty k_part then L.(die InternalError) "may_alias is not reflexive!" ; @@ -1736,6 +1805,7 @@ module MayAliasQuotientedAccessListMap : QuotientedAccessListMap = struct aux new_acc non_k_part in aux AccessListMap.empty acc_map + end (* decide if we should throw away a path before doing safety analysis @@ -1743,16 +1813,17 @@ end that is auto-generated by Java. *) let should_filter_access access = match RacerDDomain.Access.get_access_path access with - | Some (_, path) - -> let check_access_step = function - | AccessPath.ArrayAccess _ - -> false - | AccessPath.FieldAccess fld - -> String.is_substring ~substring:"$SwitchMap" (Typ.Fieldname.to_string fld) + | Some (_, path) -> + let check_access_step = function + | AccessPath.ArrayAccess _ -> + false + | AccessPath.FieldAccess fld -> + String.is_substring ~substring:"$SwitchMap" (Typ.Fieldname.to_string fld) in List.exists path ~f:check_access_step - | None - -> false + | None -> + false + (* create a map from [abstraction of a memory loc] -> accesses that may touch that memory loc. for now, our abstraction is an access path like x.f.g whose concretization is the set of memory cells @@ -1772,25 +1843,26 @@ let make_results_table (module AccessListMap: QuotientedAccessListMap) file_env in let aggregate_posts acc (tenv, proc_desc) = match Summary.read_summary proc_desc (Procdesc.get_proc_name proc_desc) with - | Some summary - -> aggregate_post summary tenv proc_desc acc - | None - -> acc + | Some summary -> + aggregate_post summary tenv proc_desc acc + | None -> + acc in List.fold ~f:aggregate_posts file_env ~init:AccessListMap.empty |> AccessListMap.quotient + (* aggregate all of the procedures in the file env by their declaring class. this lets us analyze each class individually *) let aggregate_by_class file_env = List.fold file_env - ~f:(fun acc (_, pdesc as proc) -> + ~f:(fun acc ((_, pdesc) as proc) -> let pname = Procdesc.get_proc_name pdesc in let classname = match pname with - | Typ.Procname.Java java_pname - -> Typ.Procname.java_get_class_name java_pname - | _ - -> "unknown" + | Typ.Procname.Java java_pname -> + Typ.Procname.java_get_class_name java_pname + | _ -> + "unknown" in let bucket = try String.Map.find_exn acc classname @@ -1799,6 +1871,7 @@ let aggregate_by_class file_env = String.Map.add ~key:classname ~data:(proc :: bucket) acc) ~init:String.Map.empty + (* Gathers results by analyzing all the methods in a file, then post-processes the results to check an (approximation of) thread safety *) let file_analysis {Callbacks.procedures} = @@ -1811,3 +1884,4 @@ let file_analysis {Callbacks.procedures} = else (module MayAliasQuotientedAccessListMap) ) class_env)) (aggregate_by_class procedures) + diff --git a/infer/src/concurrency/RacerDConfig.ml b/infer/src/concurrency/RacerDConfig.ml index 008e6b653..039e959ae 100644 --- a/infer/src/concurrency/RacerDConfig.ml +++ b/infer/src/concurrency/RacerDConfig.ml @@ -13,9 +13,10 @@ module L = Logging module AnnotationAliases = struct let of_json = function - | `List aliases - -> List.map ~f:Yojson.Basic.Util.to_string aliases - | _ - -> L.(die UserError) + | `List aliases -> + List.map ~f:Yojson.Basic.Util.to_string aliases + | _ -> + L.(die UserError) "Couldn't parse thread-safety annotation aliases; expected list of strings" + end diff --git a/infer/src/concurrency/RacerDDomain.ml b/infer/src/concurrency/RacerDDomain.ml index 8fb6ce7d6..acb68d887 100644 --- a/infer/src/concurrency/RacerDDomain.ml +++ b/infer/src/concurrency/RacerDDomain.ml @@ -21,61 +21,67 @@ module Access = struct let suffix_matches (_, accesses1) (_, accesses2) = match (List.rev accesses1, List.rev accesses2) with - | access1 :: _, access2 :: _ - -> AccessPath.equal_access access1 access2 - | _ - -> false + | access1 :: _, access2 :: _ -> + AccessPath.equal_access access1 access2 + | _ -> + false + let matches ~caller ~callee = match (caller, callee) with - | Read ap1, Read ap2 | Write ap1, Write ap2 - -> suffix_matches ap1 ap2 + | Read ap1, Read ap2 | Write ap1, Write ap2 -> + suffix_matches ap1 ap2 | ContainerRead (ap1, pname1), ContainerRead (ap2, pname2) - | ContainerWrite (ap1, pname1), ContainerWrite (ap2, pname2) - -> Typ.Procname.equal pname1 pname2 && suffix_matches ap1 ap2 - | InterfaceCall pname1, InterfaceCall pname2 - -> Typ.Procname.equal pname1 pname2 - | _ - -> false + | ContainerWrite (ap1, pname1), ContainerWrite (ap2, pname2) -> + Typ.Procname.equal pname1 pname2 && suffix_matches ap1 ap2 + | InterfaceCall pname1, InterfaceCall pname2 -> + Typ.Procname.equal pname1 pname2 + | _ -> + false + let make_field_access access_path ~is_write = if is_write then Write access_path else Read access_path + let get_access_path = function | Read access_path | Write access_path | ContainerWrite (access_path, _) - | ContainerRead (access_path, _) - -> Some access_path - | InterfaceCall _ - -> None + | ContainerRead (access_path, _) -> + Some access_path + | InterfaceCall _ -> + None + let map ~f = function - | Read access_path - -> Read (f access_path) - | Write access_path - -> Write (f access_path) - | ContainerWrite (access_path, pname) - -> ContainerWrite (f access_path, pname) - | ContainerRead (access_path, pname) - -> ContainerRead (f access_path, pname) - | InterfaceCall _ as intfcall - -> intfcall + | Read access_path -> + Read (f access_path) + | Write access_path -> + Write (f access_path) + | ContainerWrite (access_path, pname) -> + ContainerWrite (f access_path, pname) + | ContainerRead (access_path, pname) -> + ContainerRead (f access_path, pname) + | InterfaceCall _ as intfcall -> + intfcall + let equal t1 t2 = Int.equal (compare t1 t2) 0 let pp fmt = function - | Read access_path - -> F.fprintf fmt "Read of %a" AccessPath.pp access_path - | Write access_path - -> F.fprintf fmt "Write to %a" AccessPath.pp access_path - | ContainerRead (access_path, pname) - -> F.fprintf fmt "Read of container %a via %a" AccessPath.pp access_path Typ.Procname.pp pname - | ContainerWrite (access_path, pname) - -> F.fprintf fmt "Write to container %a via %a" AccessPath.pp access_path Typ.Procname.pp + | Read access_path -> + F.fprintf fmt "Read of %a" AccessPath.pp access_path + | Write access_path -> + F.fprintf fmt "Write to %a" AccessPath.pp access_path + | ContainerRead (access_path, pname) -> + F.fprintf fmt "Read of container %a via %a" AccessPath.pp access_path Typ.Procname.pp pname + | ContainerWrite (access_path, pname) -> + F.fprintf fmt "Write to container %a via %a" AccessPath.pp access_path Typ.Procname.pp pname - | InterfaceCall pname - -> F.fprintf fmt "Call to un-annotated interface method %a" Typ.Procname.pp pname + | InterfaceCall pname -> + F.fprintf fmt "Call to un-annotated interface method %a" Typ.Procname.pp pname + end module TraceElem = struct @@ -85,17 +91,19 @@ module TraceElem = struct let is_write {kind} = match kind with - | InterfaceCall _ | Read _ | ContainerRead _ - -> false - | ContainerWrite _ | Write _ - -> true + | InterfaceCall _ | Read _ | ContainerRead _ -> + false + | ContainerWrite _ | Write _ -> + true + let is_container_write {kind} = match kind with - | InterfaceCall _ | Read _ | Write _ | ContainerRead _ - -> false - | ContainerWrite _ - -> true + | InterfaceCall _ | Read _ | Write _ | ContainerRead _ -> + false + | ContainerWrite _ -> + true + let call_site {site} = site @@ -126,14 +134,17 @@ let make_container_access access_path pname ~is_write loc = in TraceElem.make access site + let make_field_access access_path ~is_write loc = let site = CallSite.make Typ.Procname.empty_block loc in TraceElem.make (Access.make_field_access access_path ~is_write) site + let make_unannotated_call_access pname loc = let site = CallSite.make Typ.Procname.empty_block loc in TraceElem.make (Access.InterfaceCall pname) site + (* In this domain true<=false. The intended denotations [[.]] are [[true]] = the set of all states where we know according, to annotations or assertions or lock instructions, that some lock is held. @@ -151,37 +162,40 @@ module ThreadsDomain = struct (* NoThread < AnyThreadButSelf < Any *) let ( <= ) ~lhs ~rhs = match (lhs, rhs) with - | NoThread, _ - -> true - | _, NoThread - -> false - | _, AnyThread - -> true - | AnyThread, _ - -> false - | _ - -> Int.equal 0 (compare_astate lhs rhs) + | NoThread, _ -> + true + | _, NoThread -> + false + | _, AnyThread -> + true + | AnyThread, _ -> + false + | _ -> + Int.equal 0 (compare_astate lhs rhs) + let join astate1 astate2 = match (astate1, astate2) with - | NoThread, astate | astate, NoThread - -> astate - | AnyThread, _ | _, AnyThread - -> AnyThread - | AnyThreadButSelf, AnyThreadButSelf - -> AnyThreadButSelf + | NoThread, astate | astate, NoThread -> + astate + | AnyThread, _ | _, AnyThread -> + AnyThread + | AnyThreadButSelf, AnyThreadButSelf -> + AnyThreadButSelf + let widen ~prev ~next ~num_iters:_ = join prev next let pp fmt astate = F.fprintf fmt ( match astate with - | NoThread - -> "NoThread" - | AnyThreadButSelf - -> "AnyThreadButSelf" - | AnyThread - -> "AnyThread" ) + | NoThread -> + "NoThread" + | AnyThreadButSelf -> + "AnyThreadButSelf" + | AnyThread -> + "AnyThread" ) + let is_empty = function NoThread -> true | _ -> false @@ -196,20 +210,22 @@ module Choice = struct type t = OnMainThread | LockHeld [@@deriving compare] let pp fmt = function - | OnMainThread - -> F.fprintf fmt "OnMainThread" - | LockHeld - -> F.fprintf fmt "LockHeld" + | OnMainThread -> + F.fprintf fmt "OnMainThread" + | LockHeld -> + F.fprintf fmt "LockHeld" + end module Attribute = struct type t = Functional | Choice of Choice.t [@@deriving compare] let pp fmt = function - | Functional - -> F.fprintf fmt "Functional" - | Choice choice - -> Choice.pp fmt choice + | Functional -> + F.fprintf fmt "Functional" + | Choice choice -> + Choice.pp fmt choice + module Set = PrettyPrintable.MakePPSet (struct type nonrec t = t @@ -235,38 +251,42 @@ module OwnershipAbstractValue = struct if phys_equal lhs rhs then true else match (lhs, rhs) with - | _, Unowned - -> true (* Unowned is top *) - | Unowned, _ - -> false - | Owned, _ - -> true (* Owned is bottom *) - | OwnedIf s1, OwnedIf s2 - -> IntSet.subset s1 s2 - | OwnedIf _, Owned - -> false + | _, Unowned -> + true (* Unowned is top *) + | Unowned, _ -> + false + | Owned, _ -> + true (* Owned is bottom *) + | OwnedIf s1, OwnedIf s2 -> + IntSet.subset s1 s2 + | OwnedIf _, Owned -> + false + let join astate1 astate2 = if phys_equal astate1 astate2 then astate1 else match (astate1, astate2) with - | _, Unowned | Unowned, _ - -> Unowned - | astate, Owned | Owned, astate - -> astate - | OwnedIf s1, OwnedIf s2 - -> OwnedIf (IntSet.union s1 s2) + | _, Unowned | Unowned, _ -> + Unowned + | astate, Owned | Owned, astate -> + astate + | OwnedIf s1, OwnedIf s2 -> + OwnedIf (IntSet.union s1 s2) + let widen ~prev ~next ~num_iters:_ = join prev next let pp fmt = function - | Unowned - -> F.fprintf fmt "Unowned" - | OwnedIf s - -> F.fprintf fmt "OwnedIf%a" (PrettyPrintable.pp_collection ~pp_item:Int.pp) + | Unowned -> + F.fprintf fmt "Unowned" + | OwnedIf s -> + F.fprintf fmt "OwnedIf%a" + (PrettyPrintable.pp_collection ~pp_item:Int.pp) (IntSet.elements s) - | Owned - -> F.fprintf fmt "Owned" + | Owned -> + F.fprintf fmt "Owned" + end module OwnershipDomain = struct @@ -276,9 +296,11 @@ module OwnershipDomain = struct try find access_path astate with Not_found -> OwnershipAbstractValue.Unowned + let is_owned access_path astate = match get_owned access_path astate with OwnershipAbstractValue.Owned -> true | _ -> false + let find = `Use_get_owned_instead end @@ -288,10 +310,12 @@ module AttributeMapDomain = struct let add access_path attribute_set t = if AttributeSetDomain.is_empty attribute_set then t else add access_path attribute_set t + let has_attribute access_path attribute t = try find access_path t |> AttributeSetDomain.mem attribute with Not_found -> false + let get_choices access_path t = try let attributes = find access_path t in @@ -300,6 +324,7 @@ module AttributeMapDomain = struct (AttributeSetDomain.elements attributes) with Not_found -> [] + let add_attribute access_path attribute t = let attribute_set = ( try find access_path t @@ -307,18 +332,20 @@ module AttributeMapDomain = struct |> AttributeSetDomain.add attribute in add access_path attribute_set t + end module Excluder = struct type t = Thread | Lock | Both [@@deriving compare] let pp fmt = function - | Thread - -> F.fprintf fmt "Thread" - | Lock - -> F.fprintf fmt "Lock" - | Both - -> F.fprintf fmt "both Thread and Lock" + | Thread -> + F.fprintf fmt "Thread" + | Lock -> + F.fprintf fmt "Lock" + | Both -> + F.fprintf fmt "both Thread and Lock" + end module AccessPrecondition = struct @@ -329,14 +356,16 @@ module AccessPrecondition = struct [@@deriving compare] let pp fmt = function - | Protected excl - -> F.fprintf fmt "ProtectedBy(%a)" Excluder.pp excl - | TotallyUnprotected - -> F.fprintf fmt "TotallyUnprotected" - | Unprotected indexes - -> F.fprintf fmt "Unprotected(%a)" (PrettyPrintable.pp_collection ~pp_item:Int.pp) + | Protected excl -> + F.fprintf fmt "ProtectedBy(%a)" Excluder.pp excl + | TotallyUnprotected -> + F.fprintf fmt "TotallyUnprotected" + | Unprotected indexes -> + F.fprintf fmt "Unprotected(%a)" + (PrettyPrintable.pp_collection ~pp_item:Int.pp) (IntSet.elements indexes) + let make locks thread pdesc = let is_main_thread = ThreadsDomain.is_any_but_self thread in let locked = locks || Procdesc.is_java_synchronized pdesc in @@ -344,6 +373,7 @@ module AccessPrecondition = struct else if locked && is_main_thread then Protected Excluder.Both else if locked then Protected Excluder.Lock else Protected Excluder.Thread + end module AccessDomain = struct @@ -357,9 +387,11 @@ module AccessDomain = struct let precondition_accesses' = PathDomain.add_sink access_path precondition_accesses in add precondition precondition_accesses' t + let get_accesses precondition t = try find precondition t with Not_found -> PathDomain.empty + end type astate = @@ -377,10 +409,12 @@ let empty = let attribute_map = AttributeMapDomain.empty in {threads; locks; accesses; ownership; attribute_map} + let is_empty {threads; locks; accesses; ownership; attribute_map} = ThreadsDomain.is_empty threads && not locks && AccessDomain.is_empty accesses && OwnershipDomain.is_empty ownership && AttributeMapDomain.is_empty attribute_map + let ( <= ) ~lhs ~rhs = if phys_equal lhs rhs then true else ThreadsDomain.( <= ) ~lhs:lhs.threads ~rhs:rhs.threads @@ -388,6 +422,7 @@ let ( <= ) ~lhs ~rhs = && AccessDomain.( <= ) ~lhs:lhs.accesses ~rhs:rhs.accesses && AttributeMapDomain.( <= ) ~lhs:lhs.attribute_map ~rhs:rhs.attribute_map + let join astate1 astate2 = if phys_equal astate1 astate2 then astate1 else @@ -398,6 +433,7 @@ let join astate1 astate2 = let attribute_map = AttributeMapDomain.join astate1.attribute_map astate2.attribute_map in {threads; locks; accesses; ownership; attribute_map} + let widen ~prev ~next ~num_iters = if phys_equal prev next then prev else @@ -410,6 +446,7 @@ let widen ~prev ~next ~num_iters = in {threads; locks; accesses; ownership; attribute_map} + type summary = { threads: ThreadsDomain.astate ; locks: LocksDomain.astate @@ -423,7 +460,9 @@ let pp_summary fmt {threads; locks; accesses; return_ownership; return_attribute ThreadsDomain.pp threads LocksDomain.pp locks AccessDomain.pp accesses OwnershipAbstractValue.pp return_ownership AttributeSetDomain.pp return_attributes + let pp fmt {threads; locks; accesses; ownership; attribute_map} = F.fprintf fmt "Threads: %a, Locks: %a @\nAccesses %a @\n Ownership: %a @\nAttributes: %a @\n" ThreadsDomain.pp threads LocksDomain.pp locks AccessDomain.pp accesses OwnershipDomain.pp ownership AttributeMapDomain.pp attribute_map + diff --git a/infer/src/eradicate/AnnotatedSignature.ml b/infer/src/eradicate/AnnotatedSignature.ml index e96a0d8b6..fa6efca4e 100644 --- a/infer/src/eradicate/AnnotatedSignature.ml +++ b/infer/src/eradicate/AnnotatedSignature.ml @@ -18,10 +18,11 @@ type annotation = Nullable | Present [@@deriving compare] let ia_is ann ia = match ann with - | Nullable - -> Annotations.ia_is_nullable ia - | Present - -> Annotations.ia_is_present ia + | Nullable -> + Annotations.ia_is_nullable ia + | Present -> + Annotations.ia_is_present ia + let get proc_attributes : t = let method_annotation = proc_attributes.ProcAttributes.method_annotation in @@ -31,32 +32,35 @@ let get proc_attributes : t = let natl = let rec extract ial parl = match (ial, parl) with - | ia :: ial', (name, typ) :: parl' - -> (name, ia, typ) :: extract ial' parl' - | [], (name, typ) :: parl' - -> (name, Annot.Item.empty, typ) :: extract [] parl' - | [], [] - -> [] - | _ :: _, [] - -> assert false + | ia :: ial', (name, typ) :: parl' -> + (name, ia, typ) :: extract ial' parl' + | [], (name, typ) :: parl' -> + (name, Annot.Item.empty, typ) :: extract [] parl' + | [], [] -> + [] + | _ :: _, [] -> + assert false in List.rev (extract (List.rev ial0) (List.rev formals)) in let annotated_signature = {ret= (ia, ret_type); params= natl} in annotated_signature + let param_is_nullable pvar ann_sig = List.exists ~f:(fun (param, annot, _) -> Mangled.equal param (Pvar.get_name pvar) && Annotations.ia_is_nullable annot) ann_sig.params + let param_has_annot predicate pvar ann_sig = List.exists ~f:(fun (param, param_annot, _) -> Mangled.equal param (Pvar.get_name pvar) && predicate param_annot) ann_sig.params + let pp proc_name fmt annotated_signature = let pp_ia fmt ia = if ia <> [] then F.fprintf fmt "%a " Annot.Item.pp ia in let pp_annotated_param fmt (p, ia, t) = @@ -64,8 +68,9 @@ let pp proc_name fmt annotated_signature = in let ia, ret_type = annotated_signature.ret in F.fprintf fmt "%a%a %s (%a )" pp_ia ia (Typ.pp_full Pp.text) ret_type - (Typ.Procname.to_simplified_string proc_name) (Pp.comma_seq pp_annotated_param) - annotated_signature.params + (Typ.Procname.to_simplified_string proc_name) + (Pp.comma_seq pp_annotated_param) annotated_signature.params + let is_anonymous_inner_class_wrapper ann_sig proc_name = let check_ret (ia, t) = Annot.Item.is_empty ia && PatternMatch.type_is_object t in @@ -92,13 +97,15 @@ let is_anonymous_inner_class_wrapper ann_sig proc_name = Typ.Procname.java_is_anonymous_inner_class proc_name && check_ret ann_sig.ret && List.for_all ~f:check_param ann_sig.params && !x_param_found + let mk_ann_str s = {Annot.class_name= s; parameters= []} let mk_ann = function - | Nullable - -> mk_ann_str Annotations.nullable - | Present - -> mk_ann_str Annotations.present + | Nullable -> + mk_ann_str Annotations.nullable + | Present -> + mk_ann_str Annotations.present + let mk_ia ann ia = if ia_is ann ia then ia else (mk_ann ann, true) :: ia @@ -109,6 +116,7 @@ let method_annotation_mark_return ann method_annotation = let ia_ret' = mark_ia ann ia_ret true in (ia_ret', params) + let mark proc_name ann asig (b, bs) = let ia, t = asig.ret in let ret' = (mark_ia ann ia b, t) in @@ -120,26 +128,29 @@ let mark proc_name ann asig (b, bs) = let fail () = L.die InternalError "Annotation for procedure %s has wrong number of arguments.@\n Annotated signature: %a" - (Typ.Procname.to_unique_id proc_name) (pp proc_name) asig + (Typ.Procname.to_unique_id proc_name) + (pp proc_name) asig in let rec combine l1 l2 = match (l1, l2) with - | (p, ia, t) :: l1', l2' when String.equal (Mangled.to_string p) "this" - -> (p, ia, t) :: combine l1' l2' - | (s, ia, t) :: l1', x :: l2' - -> mark_param (s, ia, t) x :: combine l1' l2' - | [], _ :: _ - -> fail () - | _ :: _, [] - -> fail () - | [], [] - -> [] + | (p, ia, t) :: l1', l2' when String.equal (Mangled.to_string p) "this" -> + (p, ia, t) :: combine l1' l2' + | (s, ia, t) :: l1', x :: l2' -> + mark_param (s, ia, t) x :: combine l1' l2' + | [], _ :: _ -> + fail () + | _ :: _, [] -> + fail () + | [], [] -> + [] in combine asig.params bs in {ret= ret'; params= params'} + let mark_return ann asig = let ia, t = asig.ret in let ret' = (mark_ia ann ia true, t) in {asig with ret= ret'} + diff --git a/infer/src/eradicate/eradicate.ml b/infer/src/eradicate/eradicate.ml index e5e96e04a..cf042fc0d 100644 --- a/infer/src/eradicate/eradicate.ml +++ b/infer/src/eradicate/eradicate.ml @@ -43,22 +43,23 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct (** Update the summary with stats from the checker. *) let update_summary proc_name proc_desc final_typestate_opt = match Specs.get_summary proc_name with - | Some old_summ - -> let nodes = List.map ~f:(fun n -> Procdesc.Node.get_id n) (Procdesc.get_nodes proc_desc) in + | Some old_summ -> + let nodes = List.map ~f:(fun n -> Procdesc.Node.get_id n) (Procdesc.get_nodes proc_desc) in let method_annotation = (Specs.pdesc_resolve_attributes proc_desc).ProcAttributes.method_annotation in let new_summ = { old_summ with - Specs.nodes= nodes + Specs.nodes ; Specs.payload= Extension.update_payload final_typestate_opt old_summ.Specs.payload ; Specs.attributes= { old_summ.Specs.attributes with ProcAttributes.loc= Procdesc.get_loc proc_desc; method_annotation } } in Specs.add_summary proc_name new_summ - | None - -> () + | None -> + () + let callback1 tenv find_canonical_duplicate calls_this checks get_proc_desc idenv curr_pname curr_pdesc annotated_signature linereader proc_loc @@ -128,17 +129,19 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct List.iter ~f:d_typestate typestates_succ ) ; NodePrinter.finish_session node ; (typestates_succ, typestates_exn) + let proc_throws _ = DontKnow end) in let initial_typestate = get_initial_typestate () in do_before_dataflow initial_typestate ; let transitions = DFTypeCheck.run tenv curr_pdesc initial_typestate in match transitions (Procdesc.get_exit_node curr_pdesc) with - | DFTypeCheck.Transition (final_typestate, _, _) - -> do_after_dataflow find_canonical_duplicate final_typestate ; + | DFTypeCheck.Transition (final_typestate, _, _) -> + do_after_dataflow find_canonical_duplicate final_typestate ; (!calls_this, Some final_typestate) - | DFTypeCheck.Dead_state - -> (!calls_this, None) + | DFTypeCheck.Dead_state -> + (!calls_this, None) + let callback2 calls_this checks {Callbacks.proc_desc= curr_pdesc; summary; get_proc_desc; tenv; get_procs_in_file} @@ -154,10 +157,10 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct let typecheck_proc do_checks pname pdesc proc_details_opt = let ann_sig, loc, idenv_pn = match proc_details_opt with - | Some (ann_sig, loc, idenv_pn) - -> (ann_sig, loc, idenv_pn) - | None - -> let ann_sig = + | Some (ann_sig, loc, idenv_pn) -> + (ann_sig, loc, idenv_pn) + | None -> + let ann_sig = Models.get_modelled_annotated_signature (Procdesc.get_attributes pdesc) in let loc = Procdesc.get_loc pdesc in @@ -187,10 +190,10 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct let same_class = let get_class_opt pn = match pn with - | Typ.Procname.Java pn_java - -> Some (Typ.Procname.java_get_class_name pn_java) - | _ - -> None + | Typ.Procname.Java pn_java -> + Some (Typ.Procname.java_get_class_name pn_java) + | _ -> + None in equal_class_opt (get_class_opt init_pn) (get_class_opt callee_pn) in @@ -201,10 +204,10 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct in let do_called (callee_pn, _) = match get_proc_desc callee_pn with - | Some callee_pd - -> res := (callee_pn, callee_pd) :: !res - | None - -> () + | Some callee_pd -> + res := (callee_pn, callee_pd) :: !res + | None -> + () in List.iter ~f:do_called private_called in @@ -234,69 +237,73 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct let final_typestates = ref [] in let get_final_typestate (pname, pdesc) = match typecheck_proc false pname pdesc None with - | _, Some final_typestate - -> final_typestates := (pname, final_typestate) :: !final_typestates - | _, None - -> () + | _, Some final_typestate -> + final_typestates := (pname, final_typestate) :: !final_typestates + | _, None -> + () in List.iter ~f:get_final_typestate initializers_recursive ; List.rev !final_typestates + let pname_and_pdescs_with f = let res = ref [] in let filter pname = match Specs.proc_resolve_attributes pname with - | Some proc_attributes - -> f (pname, proc_attributes) - | None - -> false + | Some proc_attributes -> + f (pname, proc_attributes) + | None -> + false in let do_proc pname = if filter pname then match get_proc_desc pname with - | Some pdesc - -> res := (pname, pdesc) :: !res - | None - -> () + | Some pdesc -> + res := (pname, pdesc) :: !res + | None -> + () in List.iter ~f:do_proc (get_procs_in_file curr_pname) ; List.rev !res + let get_class pn = match pn with - | Typ.Procname.Java pn_java - -> Some (Typ.Procname.java_get_class_name pn_java) - | _ - -> None + | Typ.Procname.Java pn_java -> + Some (Typ.Procname.java_get_class_name pn_java) + | _ -> + None + (** Typestates after the current procedure and all initializer procedures. *) let final_initializer_typestates_lazy = - ( lazy - (let is_initializer proc_attributes = - PatternMatch.method_is_initializer tenv proc_attributes - || - let ia, _ = - (Models.get_modelled_annotated_signature proc_attributes).AnnotatedSignature.ret + lazy + (let is_initializer proc_attributes = + PatternMatch.method_is_initializer tenv proc_attributes + || + let ia, _ = + (Models.get_modelled_annotated_signature proc_attributes).AnnotatedSignature.ret + in + Annotations.ia_is_initializer ia in - Annotations.ia_is_initializer ia - in - let initializers_current_class = - pname_and_pdescs_with (function - | pname, proc_attributes - -> is_initializer proc_attributes + let initializers_current_class = + pname_and_pdescs_with (function pname, proc_attributes -> + is_initializer proc_attributes && equal_class_opt (get_class pname) (get_class curr_pname) ) - in - final_typestates ((curr_pname, curr_pdesc) :: initializers_current_class)) ) + in + final_typestates ((curr_pname, curr_pdesc) :: initializers_current_class)) + (** Typestates after all constructors. *) let final_constructor_typestates_lazy = - ( lazy - (let constructors_current_class = - pname_and_pdescs_with (fun (pname, _) -> - Typ.Procname.is_constructor pname - && equal_class_opt (get_class pname) (get_class curr_pname) ) - in - final_typestates constructors_current_class) ) + lazy + (let constructors_current_class = + pname_and_pdescs_with (fun (pname, _) -> + Typ.Procname.is_constructor pname + && equal_class_opt (get_class pname) (get_class curr_pname) ) + in + final_typestates constructors_current_class) + end (* Initializers *) in let do_final_typestate typestate_opt calls_this = @@ -325,6 +332,7 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct TypeErr.report_forall_checks_and_reset tenv (Checkers.ST.report_error tenv) curr_pdesc ; update_summary curr_pname curr_pdesc final_typestate_opt + (** Entry point for the eradicate-based checker infrastructure. *) let callback checks ({Callbacks.proc_desc; summary} as callback_args) : Specs.summary = let proc_name = Procdesc.get_proc_name proc_desc in @@ -340,15 +348,16 @@ module MkCallback (Extension : ExtensionT) : CallBackT = struct Some annotated_signature in ( match filter_special_cases () with - | None - -> () - | Some annotated_signature - -> let loc = Procdesc.get_loc proc_desc in + | None -> + () + | Some annotated_signature -> + let loc = Procdesc.get_loc proc_desc in let linereader = Printer.LineReader.create () in if Config.eradicate_verbose then L.result "%a@." (AnnotatedSignature.pp proc_name) annotated_signature ; callback2 calls_this checks callback_args annotated_signature linereader loc ) ; summary + end (* MkCallback *) @@ -370,7 +379,8 @@ module EmptyExtension : ExtensionT = struct let check_instr _ _ _ _ ext _ _ = ext in let join () () = () in let pp _ () = () in - {TypeState.empty= empty; check_instr; join; pp} + {TypeState.empty; check_instr; join; pp} + let update_payload typestate_opt payload = {payload with Specs.typestate= typestate_opt} end @@ -382,9 +392,11 @@ let callback_eradicate = let checks = {TypeCheck.eradicate= true; check_extension= false; check_ret_type= []} in Main.callback checks + (** Call the given check_return_type at the end of every procedure. *) let callback_check_return_type check_return_type callback_args = let checks = {TypeCheck.eradicate= false; check_extension= false; check_ret_type= [check_return_type]} in Main.callback checks callback_args + diff --git a/infer/src/eradicate/eradicateChecks.ml b/infer/src/eradicate/eradicateChecks.ml index 2975fe25e..e8aa2b15e 100644 --- a/infer/src/eradicate/eradicateChecks.ml +++ b/infer/src/eradicate/eradicateChecks.ml @@ -21,10 +21,10 @@ let check_library_calls = false let get_field_annotation tenv fn typ = let lookup = Tenv.lookup tenv in match Typ.Struct.get_field_type_and_annotation ~lookup fn typ with - | None - -> None - | Some (t, ia) - -> let ia' = + | None -> + None + | Some (t, ia) -> + let ia' = (* TODO (t4968422) eliminate not !Config.eradicate check by marking fields as nullified *) (* outside of Eradicate in some other way *) if (Models.Inference.enabled || not Config.eradicate) @@ -34,14 +34,16 @@ let get_field_annotation tenv fn typ = in Some (t, ia') + let report_error tenv = TypeErr.report_error tenv (Checkers.ST.report_error tenv) let explain_expr tenv node e = match Errdesc.exp_rv_dexp tenv node e with - | Some de - -> Some (DecompiledExp.to_string de) - | None - -> None + | Some de -> + Some (DecompiledExp.to_string de) + | None -> + None + (** Classify a procedure. *) let classify_procedure proc_attributes = @@ -56,11 +58,13 @@ let classify_procedure proc_attributes = in classification + let is_virtual = function - | (p, _, _) :: _ when String.equal (Mangled.to_string p) "this" - -> true - | _ - -> false + | (p, _, _) :: _ when String.equal (Mangled.to_string p) "this" -> + true + | _ -> + false + (** Check an access (read or write) to a field. *) let check_field_access tenv find_canonical_duplicate curr_pname node instr_ref exp fname ta loc @@ -71,6 +75,7 @@ let check_field_access tenv find_canonical_duplicate curr_pname node instr_ref e (TypeErr.Null_field_access (explain_expr tenv node exp, fname, origin_descr, false)) (Some instr_ref) loc curr_pname + (** Check an access to an array *) let check_array_access tenv find_canonical_duplicate curr_pname node instr_ref array_exp fname ta loc indexed = @@ -80,6 +85,7 @@ let check_array_access tenv find_canonical_duplicate curr_pname node instr_ref a (TypeErr.Null_field_access (explain_expr tenv node array_exp, fname, origin_descr, indexed)) (Some instr_ref) loc curr_pname + (** Where the condition is coming from *) type from_call = | From_condition (** Direct condition *) @@ -97,11 +103,11 @@ let check_condition tenv case_zero find_canonical_duplicate curr_pdesc node e ty from_call idenv linereader loc instr_ref : unit = let is_fun_nonnull ta = match TypeAnnotation.get_origin ta with - | TypeOrigin.Proc proc_origin - -> let ia, _ = proc_origin.TypeOrigin.annotated_signature.AnnotatedSignature.ret in + | TypeOrigin.Proc proc_origin -> + let ia, _ = proc_origin.TypeOrigin.annotated_signature.AnnotatedSignature.ret in Annotations.ia_is_nonnull ia - | _ - -> false + | _ -> + false in let contains_instanceof_throwable pdesc node = (* Check if the current procedure has a catch Throwable. *) @@ -110,17 +116,17 @@ let check_condition tenv case_zero find_canonical_duplicate curr_pdesc node e ty let throwable_found = ref false in let typ_is_throwable {Typ.desc} = match desc with - | Typ.Tstruct (Typ.JavaClass _ as name) - -> String.equal (Typ.Name.name name) "java.lang.Throwable" - | _ - -> false + | Typ.Tstruct (Typ.JavaClass _ as name) -> + String.equal (Typ.Name.name name) "java.lang.Throwable" + | _ -> + false in let do_instr = function | Sil.Call (_, Exp.Const Const.Cfun pn, [_; (Exp.Sizeof {typ}, _)], _, _) - when Typ.Procname.equal pn BuiltinDecl.__instanceof && typ_is_throwable typ - -> throwable_found := true - | _ - -> () + when Typ.Procname.equal pn BuiltinDecl.__instanceof && typ_is_throwable typ -> + throwable_found := true + | _ -> + () in let do_node n = if Location.equal loc (Procdesc.Node.get_loc n) then @@ -131,11 +137,11 @@ let check_condition tenv case_zero find_canonical_duplicate curr_pdesc node e ty let from_try_with_resources () : bool = (* heuristic to check if the condition is the translation of try-with-resources *) match Printer.LineReader.from_loc linereader loc with - | Some line - -> not (String.is_substring ~substring:"==" line || String.is_substring ~substring:"!=" line) + | Some line -> + not (String.is_substring ~substring:"==" line || String.is_substring ~substring:"!=" line) && String.is_substring ~substring:"}" line && contains_instanceof_throwable curr_pdesc node - | None - -> false + | None -> + false in let is_temp = Idenv.exp_is_temp idenv e in let nonnull = is_fun_nonnull ta in @@ -152,6 +158,7 @@ let check_condition tenv case_zero find_canonical_duplicate curr_pdesc node e ty (TypeErr.Condition_redundant (is_always_true, explain_expr tenv node e, nonnull)) (Some instr_ref) loc curr_pdesc + (** Check an "is zero" condition. *) let check_zero tenv find_canonical_duplicate = check_condition tenv true find_canonical_duplicate @@ -159,6 +166,7 @@ let check_zero tenv find_canonical_duplicate = check_condition tenv true find_ca let check_nonzero tenv find_canonical_duplicate = check_condition tenv false find_canonical_duplicate + (** Check an assignment to a field. *) let check_field_assignment tenv find_canonical_duplicate curr_pdesc node instr_ref typestate exp_lhs exp_rhs typ loc fname t_ia_opt typecheck_expr : unit = @@ -174,10 +182,10 @@ let check_field_assignment tenv find_canonical_duplicate curr_pdesc node instr_r let should_report_nullable = let field_is_field_injector_readwrite () = match t_ia_opt with - | Some (_, ia) - -> Annotations.ia_is_field_injector_readwrite ia - | _ - -> false + | Some (_, ia) -> + Annotations.ia_is_field_injector_readwrite ia + | _ -> + false in not (TypeAnnotation.get_value AnnotatedSignature.Nullable ta_lhs) && TypeAnnotation.get_value AnnotatedSignature.Nullable ta_rhs @@ -210,6 +218,7 @@ let check_field_assignment tenv find_canonical_duplicate curr_pdesc node instr_r report_error tenv find_canonical_duplicate (TypeErr.Field_not_mutable (fname, origin_descr)) (Some instr_ref) loc curr_pdesc + (** Check that nonnullable fields are initialized in constructors. *) let check_constructor_initialization tenv find_canonical_duplicate curr_pname curr_pdesc start_node final_initializer_typestates final_constructor_typestates loc : unit = @@ -218,8 +227,8 @@ let check_constructor_initialization tenv find_canonical_duplicate curr_pname cu match PatternMatch.get_this_type (Procdesc.get_attributes curr_pdesc) with | Some {desc= Tptr (({desc= Tstruct name} as ts), _)} -> ( match Tenv.lookup tenv name with - | Some {fields} - -> let do_field (fn, ft, _) = + | Some {fields} -> + let do_field (fn, ft, _) = let annotated_with f = match get_field_annotation tenv fn ts with None -> false | Some (_, ia) -> f ia in @@ -232,8 +241,8 @@ let check_constructor_initialization tenv find_canonical_duplicate curr_pname cu let filter_range_opt = function Some (_, ta, _) -> f ta | None -> unknown in List.exists ~f:(function - | pname, typestate - -> let pvar = + | pname, typestate -> + let pvar = Pvar.mk (Mangled.from_string (Typ.Fieldname.to_string fn)) pname in filter_range_opt (TypeState.lookup_pvar pvar typestate)) @@ -241,13 +250,13 @@ let check_constructor_initialization tenv find_canonical_duplicate curr_pname cu in let may_be_assigned_in_final_typestate = let origin_is_initialized = function - | TypeOrigin.Undef - -> false - | TypeOrigin.Field (TypeOrigin.Formal name, _, _) - -> let circular = String.equal (Mangled.to_string name) "this" in + | TypeOrigin.Undef -> + false + | TypeOrigin.Field (TypeOrigin.Formal name, _, _) -> + let circular = String.equal (Mangled.to_string name) "this" in not circular - | _ - -> true + | _ -> + true in final_type_annotation_with false (Lazy.force final_initializer_typestates) (fun ta -> origin_is_initialized (TypeAnnotation.get_origin ta) ) @@ -280,16 +289,17 @@ let check_constructor_initialization tenv find_canonical_duplicate curr_pname cu (TypeErr.Field_over_annotated (fn, curr_pname)) None loc curr_pdesc ) in List.iter ~f:do_field fields - | None - -> () ) - | _ - -> () + | None -> + () ) + | _ -> + () + (** Make the return type @Nullable by modifying the spec. *) let spec_make_return_nullable curr_pname = match Specs.get_summary curr_pname with - | Some summary - -> let proc_attributes = Specs.get_attributes summary in + | Some summary -> + let proc_attributes = Specs.get_attributes summary in let method_annotation = proc_attributes.ProcAttributes.method_annotation in let method_annotation' = AnnotatedSignature.method_annotation_mark_return AnnotatedSignature.Nullable @@ -300,8 +310,9 @@ let spec_make_return_nullable curr_pname = in let summary' = {summary with Specs.attributes= proc_attributes'} in Specs.add_summary curr_pname summary' - | None - -> () + | None -> + () + (** Check the annotations when returning from a method. *) let check_return_annotation tenv find_canonical_duplicate curr_pdesc ret_range @@ -319,10 +330,10 @@ let check_return_annotation tenv find_canonical_duplicate curr_pdesc ret_range match ret_range with (* Disables the warnings since it is not clear how to annotate the return value of lambdas *) | Some _ - when Typ.Procname.java_is_lambda curr_pname - -> () - | Some (_, final_ta, _) - -> let final_nullable = TypeAnnotation.get_value AnnotatedSignature.Nullable final_ta in + when Typ.Procname.java_is_lambda curr_pname -> + () + | Some (_, final_ta, _) -> + let final_nullable = TypeAnnotation.get_value AnnotatedSignature.Nullable final_ta in let final_present = TypeAnnotation.get_value AnnotatedSignature.Present final_ta in let origin_descr = TypeAnnotation.descr_origin tenv final_ta in let return_not_nullable = @@ -349,15 +360,16 @@ let check_return_annotation tenv find_canonical_duplicate curr_pdesc ret_range if return_over_annotated then report_error tenv find_canonical_duplicate (TypeErr.Return_over_annotated curr_pname) None loc curr_pdesc - | None - -> () + | None -> + () + (** Check the receiver of a virtual call. *) let check_call_receiver tenv find_canonical_duplicate curr_pdesc node typestate call_params callee_pname (instr_ref: TypeErr.InstrRef.t) loc typecheck_expr : unit = match call_params with - | ((original_this_e, this_e), typ) :: _ - -> let _, this_ta, _ = + | ((original_this_e, this_e), typ) :: _ -> + let _, this_ta, _ = typecheck_expr tenv node instr_ref curr_pdesc typestate this_e (typ, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, []) loc in @@ -375,8 +387,9 @@ let check_call_receiver tenv find_canonical_duplicate curr_pdesc node typestate report_error tenv find_canonical_duplicate (TypeErr.Call_receiver_annotation_inconsistent (ann, descr, callee_pname, origin_descr)) (Some instr_ref) loc curr_pdesc - | [] - -> () + | [] -> + () + type resolved_param = { num: int @@ -393,10 +406,10 @@ let check_call_parameters tenv find_canonical_duplicate curr_pdesc node callee_a let report ann = let description = match explain_expr tenv node orig_e2 with - | Some descr - -> descr - | None - -> "formal parameter " ^ Mangled.to_string s1 + | Some descr -> + descr + | None -> + "formal parameter " ^ Mangled.to_string s1 in let origin_descr = TypeAnnotation.descr_origin tenv ta2 in let callee_loc = callee_attributes.ProcAttributes.loc in @@ -409,14 +422,14 @@ let check_call_parameters tenv find_canonical_duplicate curr_pdesc node callee_a let b1 = TypeAnnotation.get_value ann ta1 in let b2 = TypeAnnotation.get_value ann ta2 in match (ann, b1, b2) with - | AnnotatedSignature.Nullable, false, true - -> report ann ; + | AnnotatedSignature.Nullable, false, true -> + report ann ; if Models.Inference.enabled then Models.Inference.proc_add_parameter_nullable callee_pname param_num tot_param_num - | AnnotatedSignature.Present, true, false - -> report ann - | _ - -> () + | AnnotatedSignature.Present, true, false -> + report ann + | _ -> + () in if PatternMatch.type_is_class t1 then ( check_ann AnnotatedSignature.Nullable ; @@ -431,6 +444,7 @@ let check_call_parameters tenv find_canonical_duplicate curr_pdesc node callee_a (* left to right to avoid guessing the different lengths *) List.iter ~f:check resolved_params + (** Checks if the annotations are consistent with the inherited class or with the implemented interfaces *) let check_overridden_annotations find_canonical_duplicate tenv proc_name proc_desc @@ -472,11 +486,12 @@ let check_overridden_annotations find_canonical_duplicate tenv proc_name proc_de in let check overriden_proc_name = match Specs.proc_resolve_attributes overriden_proc_name with - | Some attributes - -> let overridden_signature = Models.get_modelled_annotated_signature attributes in + | Some attributes -> + let overridden_signature = Models.get_modelled_annotated_signature attributes in check_return overriden_proc_name overridden_signature ; check_params overriden_proc_name overridden_signature - | None - -> () + | None -> + () in PatternMatch.override_iter check tenv proc_name + diff --git a/infer/src/eradicate/modelTables.ml b/infer/src/eradicate/modelTables.ml index 35d21e0df..5c028e01e 100644 --- a/infer/src/eradicate/modelTables.ml +++ b/infer/src/eradicate/modelTables.ml @@ -106,6 +106,7 @@ let check_not_null_parameter_list, check_not_null_list = in (List.map ~f:(fun (x, _, z) -> (x, z)) list, List.map ~f:(fun (_, y, z) -> (y, z)) list) + let check_state_list = [ ((o, [n]), "Preconditions.checkState(boolean):void") ; ((o, [n]), "com.facebook.common.internal.Preconditions.checkState(boolean):void") @@ -126,6 +127,7 @@ let check_state_list = ; ( (o, [n; o]) , "com.facebook.infer.annotation.Assertions.assumeCondition(boolean,java.lang.String):void" ) ] + let check_argument_list = [ ((o, [n]), "com.facebook.common.internal.Preconditions.checkArgument(boolean):void") ; ( (o, [n; n]) @@ -140,23 +142,28 @@ let check_argument_list = , "com.google.common.base.Preconditions.checkArgument(boolean,java.lang.String,java.lang.Object[]):void" ) ] + let optional_get_list : ((_ * bool list) * _) list = [ ((o, []), "Optional.get():java.lang.Object") ; ((o, []), "com.google.common.base.Optional.get():java.lang.Object") ] + let optional_isPresent_list : ((_ * bool list) * _) list = [ ((o, []), "Optional.isPresent():boolean") ; ((o, []), "com.google.common.base.Optional.isPresent():boolean") ] + (** Models for boolean functions that return true on null. *) let true_on_null_list : ((_ * bool list) * _) list = [(n1, "android.text.TextUtils.isEmpty(java.lang.CharSequence):boolean")] + (** Models for Map.containsKey *) let containsKey_list = [ (n1, "com.google.common.collect.ImmutableMap.containsKey(java.lang.Object):boolean") ; (n1, "java.util.Map.containsKey(java.lang.Object):boolean") ] + (** Models for Map.put *) let mapPut_list = [ ( cp @@ -164,6 +171,7 @@ let mapPut_list = ) ; (cp, "java.util.Map.put(java.lang.Object,java.lang.Object):java.lang.Object") ] + (** Models for @Nullable annotations *) let annotated_list_nullable = check_not_null_list @ check_state_list @ check_argument_list @@ -190,9 +198,9 @@ let annotated_list_nullable = ; (n1, "com.google.common.base.Strings.nullToEmpty(java.lang.String):java.lang.String") ; (cg, "com.google.common.collect.ImmutableMap.get(java.lang.Object):java.lang.Object") ; (* container get *) - ( o1 - , "com.google.common.collect.ImmutableList$Builder.add(java.lang.Object):com.google.common.collect.ImmutableList$Builder" - ) + ( o1 + , "com.google.common.collect.ImmutableList$Builder.add(java.lang.Object):com.google.common.collect.ImmutableList$Builder" + ) ; ( o1 , "com.google.common.collect.ImmutableList$Builder.addAll(java.lang.Iterable):com.google.common.collect.ImmutableList$Builder" ) @@ -221,15 +229,15 @@ let annotated_list_nullable = ; (n1, "java.util.AbstractList.equals(java.lang.Object):boolean") ; (ca, "java.util.ArrayList.add(java.lang.Object):boolean") ; (* container add *) - (ca, "java.util.List.add(java.lang.Object):boolean") + (ca, "java.util.List.add(java.lang.Object):boolean") ; (* container add *) - (cg, "java.util.Map.get(java.lang.Object):java.lang.Object") + (cg, "java.util.Map.get(java.lang.Object):java.lang.Object") ; (* container get *) - (cp, "java.util.Map.put(java.lang.Object,java.lang.Object):java.lang.Object") + (cp, "java.util.Map.put(java.lang.Object,java.lang.Object):java.lang.Object") ; (* container put *) - ( (n, [o]) - , "javax.lang.model.element.Element.getAnnotation(java.lang.Class):java.lang.annotation.Annotation" - ) + ( (n, [o]) + , "javax.lang.model.element.Element.getAnnotation(java.lang.Class):java.lang.annotation.Annotation" + ) ; ( ng , "javax.lang.model.element.Element.getEnclosingElement():javax.lang.model.element.Element" ) ; ( ng @@ -396,28 +404,31 @@ let annotated_list_nullable = , "org.w3c.dom.Node.setUserData(java.lang.String,java.lang.Object,org.w3c.dom.UserDataHandler):java.lang.Object" ) ; (* References *) - (ng, "java.lang.ref.Reference.get():java.lang.Object") + (ng, "java.lang.ref.Reference.get():java.lang.Object") ; (ng, "java.lang.ref.PhantomReference.get():java.lang.Object") ; (ng, "java.lang.ref.SoftReference.get():java.lang.Object") ; (ng, "java.lang.ref.WeakReference.get():java.lang.Object") ; (ng, "java.util.concurrent.atomic.AtomicReference.get():java.lang.Object") ] + (** Models for @Present annotations *) let annotated_list_present = [ ((n, [o]), "Optional.of(java.lang.Object):Optional") ; ( (n, [o]) , "com.google.common.base.Optional.of(java.lang.Object):com.google.common.base.Optional" ) ] + (** Models for methods that do not return *) let noreturn_list = [((o, [o]), "java.lang.System.exit(int):void")] -type model_table_t = (string, (bool * bool list)) Hashtbl.t +type model_table_t = (string, bool * bool list) Hashtbl.t let mk_table list = let map = Hashtbl.create 1 in List.iter ~f:(function v, pn_id -> Hashtbl.replace map pn_id v) list ; map + let this_file = Filename.basename __FILE__ let annotated_table_nullable = mk_table annotated_list_nullable @@ -427,6 +438,7 @@ let annotated_table_present = mk_table annotated_list_present let check_not_null_table, check_not_null_parameter_table = (mk_table check_not_null_list, mk_table check_not_null_parameter_list) + let check_state_table = mk_table check_state_list let check_argument_table = mk_table check_argument_list diff --git a/infer/src/eradicate/modelTables.mli b/infer/src/eradicate/modelTables.mli index 5b149f2fd..b65ff52f4 100644 --- a/infer/src/eradicate/modelTables.mli +++ b/infer/src/eradicate/modelTables.mli @@ -9,7 +9,7 @@ open! IStd -type model_table_t = (string, (bool * bool list)) Caml.Hashtbl.t +type model_table_t = (string, bool * bool list) Caml.Hashtbl.t val this_file : string (** Name of this file. *) diff --git a/infer/src/eradicate/models.ml b/infer/src/eradicate/models.ml index ad4bd2056..571c9389b 100644 --- a/infer/src/eradicate/models.ml +++ b/infer/src/eradicate/models.ml @@ -27,18 +27,22 @@ module Inference = struct let fname = Typ.Fieldname.to_string fn in (get_dir (), fname) + let field_is_marked fn = let dir, fname = field_get_dir_fname fn in DB.read_file_with_lock dir fname <> None + let proc_get_ret_dir_fname pname = let fname = Typ.Procname.to_filename pname ^ "_ret" in (get_dir (), fname) + let proc_get_param_dir_fname pname = let fname = Typ.Procname.to_filename pname ^ "_params" in (get_dir (), fname) + let update_count_str s_old = let n = if String.is_empty s_old then 0 @@ -48,18 +52,21 @@ module Inference = struct in string_of_int (n + 1) + let update_boolvec_str _s size index bval = let s = if String.is_empty _s then String.make size '0' else _s in s.[index] <- (if bval then '1' else '0') ; s + let mark_file update_str dir fname = DB.update_file_with_lock dir fname update_str ; match DB.read_file_with_lock dir fname with - | Some buf - -> L.internal_error "Read %s: %s@." fname buf - | None - -> L.internal_error "Read %s: None@." fname + | Some buf -> + L.internal_error "Read %s: %s@." fname buf + | None -> + L.internal_error "Read %s: None@." fname + let mark_file_count = mark_file update_count_str @@ -68,32 +75,37 @@ module Inference = struct let dir, fname = field_get_dir_fname fn in mark_file_count dir fname + (** Mark the return type @Nullable indirectly by writing to a global file. *) let proc_mark_return_nullable pn = let dir, fname = proc_get_ret_dir_fname pn in mark_file_count dir fname + (** Return true if the return type is marked @Nullable in the global file *) let proc_return_is_marked pname = let dir, fname = proc_get_ret_dir_fname pname in DB.read_file_with_lock dir fname <> None + (** Mark the n-th parameter @Nullable indirectly by writing to a global file. *) let proc_add_parameter_nullable pn n tot = let dir, fname = proc_get_param_dir_fname pn in let update_str s = update_boolvec_str s tot n true in mark_file update_str dir fname + (** Return None if the parameters are not marked, or a vector of marked parameters *) let proc_parameters_marked pn = let dir, fname = proc_get_param_dir_fname pn in match DB.read_file_with_lock dir fname with - | None - -> None - | Some buf - -> let boolvec = ref [] in + | None -> + None + | Some buf -> + let boolvec = ref [] in String.iter ~f:(fun c -> boolvec := Char.equal c '1' :: !boolvec) buf ; Some (List.rev !boolvec) + end (* Inference *) @@ -105,6 +117,7 @@ let table_has_procedure table proc_name = true with Not_found -> false + (** Return the annotated signature of the procedure, taking into account models. *) let get_modelled_annotated_signature proc_attributes = let proc_name = proc_attributes.ProcAttributes.proc_name in @@ -115,10 +128,10 @@ let get_modelled_annotated_signature proc_attributes = if Inference.enabled then Inference.proc_parameters_marked proc_name else None in match mark_par with - | None - -> ann_sig - | Some bs - -> let mark = (false, bs) in + | None -> + ann_sig + | Some bs -> + let mark = (false, bs) in AnnotatedSignature.mark proc_name AnnotatedSignature.Nullable ann_sig mark in let infer_return ann_sig = @@ -144,6 +157,7 @@ let get_modelled_annotated_signature proc_attributes = annotated_signature |> lookup_models_nullable |> lookup_models_present |> infer_return |> infer_parameters + (** Return true when the procedure has been modelled for nullable. *) let is_modelled_nullable proc_name = if use_models then @@ -154,6 +168,7 @@ let is_modelled_nullable proc_name = with Not_found -> false else false + (** Check if the procedure is one of the known Preconditions.checkNotNull. *) let is_check_not_null proc_name = table_has_procedure check_not_null_table proc_name @@ -163,6 +178,7 @@ let get_check_not_null_parameter proc_name = try Hashtbl.find check_not_null_parameter_table proc_id with Not_found -> 0 + (** Check if the procedure is one of the known Preconditions.checkState. *) let is_check_state proc_name = table_has_procedure check_state_table proc_name diff --git a/infer/src/eradicate/typeAnnotation.ml b/infer/src/eradicate/typeAnnotation.ml index 28c060172..7e07837fb 100644 --- a/infer/src/eradicate/typeAnnotation.ml +++ b/infer/src/eradicate/typeAnnotation.ml @@ -26,9 +26,11 @@ let get_value ann ta = try AnnotationsMap.find ann ta.map with Not_found -> false + let set_value ann b ta = if Bool.equal (get_value ann ta) b then ta else {ta with map= AnnotationsMap.add ann b ta.map} + let get_nullable = get_value AnnotatedSignature.Nullable let get_present = get_value Present @@ -40,16 +42,18 @@ let set_present b = set_value Present b let descr_origin tenv ta = let descr_opt = TypeOrigin.get_description tenv ta.origin in match descr_opt with - | None - -> ("", None, None) - | Some (str, loc_opt, sig_opt) - -> ("(Origin: " ^ str ^ ")", loc_opt, sig_opt) + | None -> + ("", None, None) + | Some (str, loc_opt, sig_opt) -> + ("(Origin: " ^ str ^ ")", loc_opt, sig_opt) + let to_string ta = let nullable_s = if get_nullable ta then " @Nullable" else "" in let present_s = if get_present ta then " @Present" else "" in nullable_s ^ present_s + let join ta1 ta2 = let nul1, nul2 = (get_nullable ta1, get_nullable ta2) in let choose_left = match (nul1, nul2) with false, true -> false | _ -> true in @@ -62,28 +66,32 @@ let join ta1 ta2 = let ta' = set_present present {ta_chosen with origin} in if equal ta' ta1 then None else Some ta' + let get_origin ta = ta.origin let origin_is_fun_library ta = match get_origin ta with - | TypeOrigin.Proc proc_origin - -> proc_origin.TypeOrigin.is_library - | _ - -> false + | TypeOrigin.Proc proc_origin -> + proc_origin.TypeOrigin.is_library + | _ -> + false + let const annotation b origin = let nullable, present = match annotation with - | AnnotatedSignature.Nullable - -> (b, false) - | AnnotatedSignature.Present - -> (false, b) + | AnnotatedSignature.Nullable -> + (b, false) + | AnnotatedSignature.Present -> + (false, b) in let ta = {origin; map= AnnotationsMap.empty} in set_present present (set_nullable nullable ta) + let with_origin ta o = {ta with origin= o} let from_item_annotation ia origin = let ta = const Nullable (Annotations.ia_is_nullable ia) origin in set_value Present (Annotations.ia_is_present ia) ta + diff --git a/infer/src/eradicate/typeCheck.ml b/infer/src/eradicate/typeCheck.ml index 7cb267d8b..f5c2a41af 100644 --- a/infer/src/eradicate/typeCheck.ml +++ b/infer/src/eradicate/typeCheck.ml @@ -46,25 +46,27 @@ module ComplexExpressions = struct let procname_is_false_on_null pn = match Specs.proc_resolve_attributes pn with - | Some proc_attributes - -> let annotated_signature = Models.get_modelled_annotated_signature proc_attributes in + | Some proc_attributes -> + let annotated_signature = Models.get_modelled_annotated_signature proc_attributes in let ret_ann, _ = annotated_signature.AnnotatedSignature.ret in Annotations.ia_is_false_on_null ret_ann - | None - -> false + | None -> + false + let procname_is_true_on_null pn = let annotated_true_on_null () = match Specs.proc_resolve_attributes pn with - | Some proc_attributes - -> let annotated_signature = Models.get_modelled_annotated_signature proc_attributes in + | Some proc_attributes -> + let annotated_signature = Models.get_modelled_annotated_signature proc_attributes in let ret_ann, _ = annotated_signature.AnnotatedSignature.ret in Annotations.ia_is_true_on_null ret_ann - | None - -> false + | None -> + false in Models.is_true_on_null pn || annotated_true_on_null () + let procname_containsKey = Models.is_containsKey (** Recognize *all* the procedures treated specially in conditionals *) @@ -72,6 +74,7 @@ module ComplexExpressions = struct procname_optional_isPresent pn || procname_instanceof pn || procname_containsKey pn || BuiltinDecl.is_declared pn + exception Not_handled (* Convert an expression to a unique string. *) @@ -82,51 +85,53 @@ module ComplexExpressions = struct let rec dexp_to_string dexp = let case_not_handled () = raise Not_handled in match dexp with - | DExp.Darray (de1, de2) - -> dexp_to_string de1 ^ "[" ^ dexp_to_string de2 ^ "]" - | DExp.Darrow (de, f) | DExp.Ddot (de, f) - -> dexp_to_string de ^ "." ^ Typ.Fieldname.to_string f - | DExp.Dbinop (op, de1, de2) - -> "(" ^ dexp_to_string de1 ^ Binop.str Pp.text op ^ dexp_to_string de2 ^ ")" - | DExp.Dconst Const.Cfun pn - -> Typ.Procname.to_unique_id pn - | DExp.Dconst c - -> F.asprintf "%a" (Const.pp Pp.text) c - | DExp.Dderef de - -> dexp_to_string de + | DExp.Darray (de1, de2) -> + dexp_to_string de1 ^ "[" ^ dexp_to_string de2 ^ "]" + | DExp.Darrow (de, f) | DExp.Ddot (de, f) -> + dexp_to_string de ^ "." ^ Typ.Fieldname.to_string f + | DExp.Dbinop (op, de1, de2) -> + "(" ^ dexp_to_string de1 ^ Binop.str Pp.text op ^ dexp_to_string de2 ^ ")" + | DExp.Dconst Const.Cfun pn -> + Typ.Procname.to_unique_id pn + | DExp.Dconst c -> + F.asprintf "%a" (Const.pp Pp.text) c + | DExp.Dderef de -> + dexp_to_string de | DExp.Dfcall (fun_dexp, args, _, {CallFlags.cf_virtual= isvirtual}) | DExp.Dretcall (fun_dexp, args, _, {CallFlags.cf_virtual= isvirtual}) - when functions_idempotent () - -> let pp_arg fmt de = F.fprintf fmt "%s" (dexp_to_string de) in + when functions_idempotent () -> + let pp_arg fmt de = F.fprintf fmt "%s" (dexp_to_string de) in let pp_args fmt des = Pp.comma_seq pp_arg fmt des in let pp fmt = let virt = if isvirtual then "V" else "" in F.fprintf fmt "%a(%a)%s" pp_arg fun_dexp pp_args args virt in F.asprintf "%t" pp - | DExp.Dfcall _ | DExp.Dretcall _ - -> case_not_handled () - | (DExp.Dpvar pv | DExp.Dpvaraddr pv) when not (Pvar.is_frontend_tmp pv) - -> Pvar.to_string pv - | DExp.Dpvar _ | DExp.Dpvaraddr _ (* front-end variable -- this should not happen) *) - -> case_not_handled () - | DExp.Dunop (op, de) - -> Unop.str op ^ dexp_to_string de - | DExp.Dsizeof _ - -> case_not_handled () - | DExp.Dunknown - -> case_not_handled () + | DExp.Dfcall _ | DExp.Dretcall _ -> + case_not_handled () + | (DExp.Dpvar pv | DExp.Dpvaraddr pv) when not (Pvar.is_frontend_tmp pv) -> + Pvar.to_string pv + | DExp.Dpvar _ | DExp.Dpvaraddr _ (* front-end variable -- this should not happen) *) -> + case_not_handled () + | DExp.Dunop (op, de) -> + Unop.str op ^ dexp_to_string de + | DExp.Dsizeof _ -> + case_not_handled () + | DExp.Dunknown -> + case_not_handled () in match map_dexp (Errdesc.exp_rv_dexp tenv node' exp) with | Some de -> ( try Some (dexp_to_string de) with Not_handled -> None ) - | None - -> None + | None -> + None + let exp_to_string tenv node' exp = let map_dexp de_opt = de_opt in exp_to_string_map_dexp tenv map_dexp node' exp + end (* ComplexExpressions *) @@ -146,31 +151,31 @@ let rec typecheck_expr find_canonical_duplicate visited checks tenv node instr_r match e with | Exp.Lvar pvar -> ( match TypeState.lookup_pvar pvar typestate with - | Some tr - -> TypeState.range_add_locs tr [loc] - | None - -> tr_default ) + | Some tr -> + TypeState.range_add_locs tr [loc] + | None -> + tr_default ) | Exp.Var id -> ( match TypeState.lookup_id id typestate with - | Some tr - -> TypeState.range_add_locs tr [loc] - | None - -> tr_default ) - | Exp.Const Const.Cint i when IntLit.iszero i - -> let typ, _, locs = tr_default in + | Some tr -> + TypeState.range_add_locs tr [loc] + | None -> + tr_default ) + | Exp.Const Const.Cint i when IntLit.iszero i -> + let typ, _, locs = tr_default in if PatternMatch.type_is_class typ then (typ, TypeAnnotation.const AnnotatedSignature.Nullable true (TypeOrigin.Const loc), locs) else let t, ta, ll = tr_default in (t, TypeAnnotation.with_origin ta (TypeOrigin.Const loc), ll) - | Exp.Exn e1 - -> typecheck_expr find_canonical_duplicate visited checks tenv node instr_ref curr_pdesc + | Exp.Exn e1 -> + typecheck_expr find_canonical_duplicate visited checks tenv node instr_ref curr_pdesc typestate e1 tr_default loc - | Exp.Const _ - -> let typ, _, locs = tr_default in + | Exp.Const _ -> + let typ, _, locs = tr_default in (typ, TypeAnnotation.const AnnotatedSignature.Nullable false (TypeOrigin.Const loc), locs) - | Exp.Lfield (exp, fn, typ) - -> let _, _, locs = tr_default in + | Exp.Lfield (exp, fn, typ) -> + let _, _, locs = tr_default in let _, ta, locs' = typecheck_expr find_canonical_duplicate visited checks tenv node instr_ref curr_pdesc typestate exp @@ -179,19 +184,19 @@ let rec typecheck_expr find_canonical_duplicate visited checks tenv node instr_r let exp_origin = TypeAnnotation.get_origin ta in let tr_new = match EradicateChecks.get_field_annotation tenv fn typ with - | Some (t, ia) - -> ( t + | Some (t, ia) -> + ( t , TypeAnnotation.from_item_annotation ia (TypeOrigin.Field (exp_origin, fn, loc)) , locs' ) - | None - -> tr_default + | None -> + tr_default in if checks.eradicate then EradicateChecks.check_field_access tenv find_canonical_duplicate curr_pdesc node instr_ref exp fn ta loc ; tr_new - | Exp.Lindex (array_exp, index_exp) - -> let _, ta, _ = + | Exp.Lindex (array_exp, index_exp) -> + let _, ta, _ = typecheck_expr find_canonical_duplicate visited checks tenv node instr_ref curr_pdesc typestate array_exp tr_default loc in @@ -203,8 +208,9 @@ let rec typecheck_expr find_canonical_duplicate visited checks tenv node instr_r EradicateChecks.check_array_access tenv find_canonical_duplicate curr_pdesc node instr_ref array_exp fname ta loc true ; tr_default - | _ - -> tr_default + | _ -> + tr_default + (** Typecheck an instruction. *) let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get_proc_desc @@ -225,31 +231,31 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get in let pvar_get_origin pvar = match TypeState.lookup_pvar pvar typestate with - | Some (_, ta, _) - -> Some (TypeAnnotation.get_origin ta) - | None - -> None + | Some (_, ta, _) -> + Some (TypeAnnotation.get_origin ta) + | None -> + None in let handle_temporary e = match Idenv.expand_expr idenv e with | Exp.Lvar pvar when name_is_temporary (Pvar.to_string pvar) -> ( match pvar_get_origin pvar with - | Some TypeOrigin.Formal s - -> let pvar' = Pvar.mk s curr_pname in + | Some TypeOrigin.Formal s -> + let pvar' = Pvar.mk s curr_pname in Some (Exp.Lvar pvar') - | _ - -> None ) - | _ - -> None + | _ -> + None ) + | _ -> + None in match exp with - | Exp.Lfield (e, fn, typ) - -> let exp' = + | Exp.Lfield (e, fn, typ) -> + let exp' = match handle_temporary e with Some e' -> Exp.Lfield (e', fn, typ) | None -> exp in exp' - | _ - -> exp + | _ -> + exp in (* Convert a complex expressions into a pvar. When [is_assigment] is true, update the relevant annotations for the pvar. *) @@ -259,19 +265,19 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get (* If this is an assignment, update the typestate for a field access pvar. *) let update_typestate_fld pvar origin fn typ = match TypeState.lookup_pvar pvar typestate with - | Some _ when not is_assignment - -> typestate + | Some _ when not is_assignment -> + typestate | _ -> match EradicateChecks.get_field_annotation tenv fn typ with - | Some (t, ia) - -> let range = + | Some (t, ia) -> + let range = ( t , TypeAnnotation.from_item_annotation ia (TypeOrigin.Field (origin, fn, loc)) , [loc] ) in TypeState.add pvar range typestate - | None - -> typestate + | None -> + typestate in (* Convert a function call to a pvar. *) let handle_function_call call_node id = @@ -279,47 +285,47 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get | Some (Exp.Const Const.Cfun pn, _, _, _) when not (ComplexExpressions.procname_used_in_condition pn) -> ( match ComplexExpressions.exp_to_string tenv node' exp with - | None - -> default - | Some exp_str - -> let pvar = Pvar.mk (Mangled.from_string exp_str) curr_pname in + | None -> + default + | Some exp_str -> + let pvar = Pvar.mk (Mangled.from_string exp_str) curr_pname in let already_defined_in_typestate = match TypeState.lookup_pvar pvar typestate with - | Some (_, ta, _) - -> not (TypeOrigin.equal TypeOrigin.Undef (TypeAnnotation.get_origin ta)) - | None - -> false + | Some (_, ta, _) -> + not (TypeOrigin.equal TypeOrigin.Undef (TypeAnnotation.get_origin ta)) + | None -> + false in if is_assignment && already_defined_in_typestate then default (* Don't overwrite pvar representing result of function call. *) else (Exp.Lvar pvar, typestate) ) - | _ - -> default + | _ -> + default in match exp with | Exp.Var id when ComplexExpressions.functions_idempotent () - && Errdesc.find_normal_variable_funcall node' id <> None - -> handle_function_call node' id + && Errdesc.find_normal_variable_funcall node' id <> None -> + handle_function_call node' id | Exp.Lvar pvar when ComplexExpressions.functions_idempotent () && Pvar.is_frontend_tmp pvar - -> ( + -> ( let frontend_variable_assignment = Errdesc.find_program_variable_assignment node pvar in match frontend_variable_assignment with - | Some (call_node, id) - -> handle_function_call call_node id - | _ - -> default ) - | Exp.Lvar _ - -> default - | Exp.Lfield (exp_, fn, typ) when ComplexExpressions.parameter_and_static_field () - -> let inner_origin = + | Some (call_node, id) -> + handle_function_call call_node id + | _ -> + default ) + | Exp.Lvar _ -> + default + | Exp.Lfield (exp_, fn, typ) when ComplexExpressions.parameter_and_static_field () -> + let inner_origin = ( match exp_ with - | Exp.Lvar pvar - -> TypeState.lookup_pvar pvar typestate - | Exp.Var id - -> TypeState.lookup_id id typestate - | _ - -> None ) + | Exp.Lvar pvar -> + TypeState.lookup_pvar pvar typestate + | Exp.Var id -> + TypeState.lookup_id id typestate + | _ -> + None ) |> Option.value_map ~f:(fun (_, ta, _) -> TypeAnnotation.get_origin ta) ~default:TypeOrigin.ONone @@ -340,13 +346,13 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get in let res = match exp' with - | Exp.Lvar pv when is_parameter_field pv || is_static_field pv - -> let fld_name = pvar_to_str pv ^ Typ.Fieldname.to_string fn in + | Exp.Lvar pv when is_parameter_field pv || is_static_field pv -> + let fld_name = pvar_to_str pv ^ Typ.Fieldname.to_string fn in let pvar = Pvar.mk (Mangled.from_string fld_name) curr_pname in let typestate' = update_typestate_fld pvar inner_origin fn typ in (Exp.Lvar pvar, typestate') - | Exp.Lfield (_exp', fn', _) when Typ.Fieldname.java_is_outer_instance fn' - -> (* handle double dereference when accessing a field from an outer class *) + | Exp.Lfield (_exp', fn', _) when Typ.Fieldname.java_is_outer_instance fn' -> + (* handle double dereference when accessing a field from an outer class *) let fld_name = Typ.Fieldname.to_string fn' ^ "_" ^ Typ.Fieldname.to_string fn in let pvar = Pvar.mk (Mangled.from_string fld_name) curr_pname in let typestate' = update_typestate_fld pvar inner_origin fn typ in @@ -356,35 +362,36 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get (* treat var.field1. ... .fieldn as a constant *) ComplexExpressions.exp_to_string tenv node' exp with - | Some exp_str - -> let pvar = Pvar.mk (Mangled.from_string exp_str) curr_pname in + | Some exp_str -> + let pvar = Pvar.mk (Mangled.from_string exp_str) curr_pname in let typestate' = update_typestate_fld pvar inner_origin fn typ in (Exp.Lvar pvar, typestate') - | None - -> default ) - | _ - -> default + | None -> + default ) + | _ -> + default in res - | _ - -> default + | _ -> + default in let constructor_check_calls_this calls_this pn = match (curr_pname, pn) with - | Typ.Procname.Java curr_pname_java, Typ.Procname.Java pn_java - -> if String.equal (Typ.Procname.java_get_class_name curr_pname_java) + | Typ.Procname.Java curr_pname_java, Typ.Procname.Java pn_java -> + if String.equal + (Typ.Procname.java_get_class_name curr_pname_java) (Typ.Procname.java_get_class_name pn_java) then calls_this := true - | _ - -> () + | _ -> + () in (* Drops hidden and synthetic parameters which we do not check in a call. *) let drop_unchecked_params calls_this proc_attributes params = let pname = proc_attributes.ProcAttributes.proc_name in if Typ.Procname.is_constructor pname then match PatternMatch.get_this_type proc_attributes with - | Some _ - -> constructor_check_calls_this calls_this pname ; + | Some _ -> + constructor_check_calls_this calls_this pname ; (* Drop reference parameters to this and outer objects. *) let is_hidden_parameter (n, _) = let n_str = Mangled.to_string n in @@ -392,10 +399,10 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get in let rec drop_n_args ntl = match ntl with - | fp :: tail when is_hidden_parameter fp - -> 1 + drop_n_args tail - | _ - -> 0 + | fp :: tail when is_hidden_parameter fp -> + 1 + drop_n_args tail + | _ -> + 0 in let n = drop_n_args proc_attributes.ProcAttributes.formals in let visible_params = List.drop params n in @@ -403,8 +410,8 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get if proc_attributes.ProcAttributes.is_synthetic_method then List.take visible_params (List.length visible_params - 1) else visible_params - | None - -> params + | None -> + params else params in (* Drop parameters from the signature which we do not check in a call. *) @@ -429,16 +436,16 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get else None in match frontent_variable_assignment with - | None - -> typestate' - | Some (node', id) - -> (* handle the case where pvar is a frontend-generated program variable *) + | None -> + typestate' + | Some (node', id) -> + (* handle the case where pvar is a frontend-generated program variable *) let exp = Idenv.expand_expr idenv (Exp.Var id) in match convert_complex_exp_to_pvar node' false exp typestate' loc with - | Exp.Lvar pvar', _ - -> handle_pvar typestate' pvar' - | _ - -> typestate' + | Exp.Lvar pvar', _ -> + handle_pvar typestate' pvar' + | _ -> + typestate' in (* typecheck_expr with fewer parameters, using a common template for typestate range *) let typecheck_expr_simple typestate1 exp1 typ1 origin1 loc1 = @@ -451,84 +458,87 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get ignore (typecheck_expr_simple typestate1 exp1 (Typ.mk Tvoid) TypeOrigin.Undef loc1) in match instr with - | Sil.Remove_temps (idl, _) - -> if remove_temps then List.fold_right ~f:TypeState.remove_id idl ~init:typestate + | Sil.Remove_temps (idl, _) -> + if remove_temps then List.fold_right ~f:TypeState.remove_id idl ~init:typestate else typestate - | Sil.Declare_locals _ | Sil.Abstract _ | Sil.Nullify _ - -> typestate - | Sil.Load (id, e, typ, loc) - -> typecheck_expr_for_errors typestate e loc ; + | Sil.Declare_locals _ | Sil.Abstract _ | Sil.Nullify _ -> + typestate + | Sil.Load (id, e, typ, loc) -> + typecheck_expr_for_errors typestate e loc ; let e', typestate' = convert_complex_exp_to_pvar node false e typestate loc in TypeState.add_id id (typecheck_expr_simple typestate' e' typ TypeOrigin.Undef loc) typestate' - | Sil.Store (Exp.Lvar pvar, _, Exp.Exn _, _) when is_return pvar - -> (* skip assignment to return variable where it is an artifact of a throw instruction *) + | Sil.Store (Exp.Lvar pvar, _, Exp.Exn _, _) when is_return pvar -> + (* skip assignment to return variable where it is an artifact of a throw instruction *) typestate - | Sil.Store (e1, typ, e2, loc) - -> typecheck_expr_for_errors typestate e1 loc ; + | Sil.Store (e1, typ, e2, loc) -> + typecheck_expr_for_errors typestate e1 loc ; let e1', typestate1 = convert_complex_exp_to_pvar node true e1 typestate loc in let check_field_assign () = match e1 with - | Exp.Lfield (_, fn, f_typ) - -> let t_ia_opt = EradicateChecks.get_field_annotation tenv fn f_typ in + | Exp.Lfield (_, fn, f_typ) -> + let t_ia_opt = EradicateChecks.get_field_annotation tenv fn f_typ in if checks.eradicate then EradicateChecks.check_field_assignment tenv find_canonical_duplicate curr_pdesc node instr_ref typestate1 e1' e2 typ loc fn t_ia_opt (typecheck_expr find_canonical_duplicate calls_this checks tenv) - | _ - -> () + | _ -> + () in let typestate2 = match e1' with - | Exp.Lvar pvar - -> TypeState.add pvar (typecheck_expr_simple typestate1 e2 typ TypeOrigin.Undef loc) + | Exp.Lvar pvar -> + TypeState.add pvar + (typecheck_expr_simple typestate1 e2 typ TypeOrigin.Undef loc) typestate1 - | Exp.Lfield _ - -> typestate1 - | _ - -> typestate1 + | Exp.Lfield _ -> + typestate1 + | _ -> + typestate1 in check_field_assign () ; typestate2 | Sil.Call (Some (id, _), Exp.Const Const.Cfun pn, [(_, typ)], loc, _) - when Typ.Procname.equal pn BuiltinDecl.__new || Typ.Procname.equal pn BuiltinDecl.__new_array - -> TypeState.add_id id + when Typ.Procname.equal pn BuiltinDecl.__new || Typ.Procname.equal pn BuiltinDecl.__new_array -> + TypeState.add_id id (typ, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.New, [loc]) typestate (* new never returns null *) | Sil.Call (Some (id, _), Exp.Const Const.Cfun pn, (e, typ) :: _, loc, _) - when Typ.Procname.equal pn BuiltinDecl.__cast - -> typecheck_expr_for_errors typestate e loc ; + when Typ.Procname.equal pn BuiltinDecl.__cast -> + typecheck_expr_for_errors typestate e loc ; let e', typestate' = convert_complex_exp_to_pvar node false e typestate loc in (* cast copies the type of the first argument *) TypeState.add_id id (typecheck_expr_simple typestate' e' typ TypeOrigin.ONone loc) typestate' | Sil.Call (Some (id, _), Exp.Const Const.Cfun pn, [(array_exp, t)], loc, _) - when Typ.Procname.equal pn BuiltinDecl.__get_array_length - -> let _, ta, _ = + when Typ.Procname.equal pn BuiltinDecl.__get_array_length -> + let _, ta, _ = typecheck_expr find_canonical_duplicate calls_this checks tenv node instr_ref curr_pdesc typestate array_exp (t, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, [loc]) loc in if checks.eradicate then EradicateChecks.check_array_access tenv find_canonical_duplicate curr_pdesc node instr_ref - array_exp (Typ.Fieldname.Java.from_string "length") ta loc false ; + array_exp + (Typ.Fieldname.Java.from_string "length") + ta loc false ; TypeState.add_id id ( Typ.mk (Tint Typ.IInt) , TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.New , [loc] ) typestate - | Sil.Call (_, Exp.Const Const.Cfun pn, _, _, _) when BuiltinDecl.is_declared pn - -> typestate (* skip othe builtins *) + | Sil.Call (_, Exp.Const Const.Cfun pn, _, _, _) when BuiltinDecl.is_declared pn -> + typestate (* skip othe builtins *) | Sil.Call ( ret_id , Exp.Const Const.Cfun (Typ.Procname.Java callee_pname_java as callee_pname) , etl_ , loc - , cflags ) - -> ignore (Ondemand.analyze_proc_name curr_pdesc callee_pname) ; + , cflags ) -> + ignore (Ondemand.analyze_proc_name curr_pdesc callee_pname) ; let callee_attributes = match Specs.proc_resolve_attributes (* AttributesTable.load_attributes *) callee_pname with - | Some proc_attributes - -> proc_attributes - | None - -> let formals = + | Some proc_attributes -> + proc_attributes + | None -> + let formals = List.mapi ~f:(fun i (_, typ) -> let arg = @@ -541,7 +551,7 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get let ret_type = Typ.java_proc_return_typ callee_pname_java in let proc_attributes = { (ProcAttributes.default callee_pname Config.Java) with - ProcAttributes.formals= formals; ret_type } + ProcAttributes.formals; ret_type } in proc_attributes in @@ -564,10 +574,10 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get let do_return (ret_ta, ret_typ) loc' typestate' = let mk_return_range () = (ret_typ, ret_ta, [loc']) in match ret_id with - | None - -> typestate' - | Some (id, _) - -> TypeState.add_id id (mk_return_range ()) typestate' + | None -> + typestate' + | Some (id, _) -> + TypeState.add_id id (mk_return_range ()) typestate' in (* Handle Preconditions.checkNotNull. *) let do_preconditions_check_not_null parameter_num ~is_vararg typestate' = @@ -575,8 +585,8 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get let clear_nullable_flag typestate'' pvar = (* remove the nullable flag for the given pvar *) match TypeState.lookup_pvar pvar typestate'' with - | Some (t, ta, _) - -> let should_report = + | Some (t, ta, _) -> + let should_report = Config.eradicate_condition_redundant && not (TypeAnnotation.get_value AnnotatedSignature.Nullable ta) && not (TypeAnnotation.origin_is_fun_library ta) @@ -590,43 +600,43 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get TypeState.add pvar (t, TypeAnnotation.const AnnotatedSignature.Nullable false TypeOrigin.ONone, [loc]) typestate'' - | None - -> typestate' + | None -> + typestate' in let rec find_parameter n eetl1 = match (n, eetl1) with - | n, _ :: eetl2 when n > 1 - -> find_parameter (n - 1) eetl2 - | 1, ((_, Exp.Lvar pvar), typ) :: _ - -> Some (pvar, typ) - | _ - -> None + | n, _ :: eetl2 when n > 1 -> + find_parameter (n - 1) eetl2 + | 1, ((_, Exp.Lvar pvar), typ) :: _ -> + Some (pvar, typ) + | _ -> + None in match find_parameter parameter_num call_params with - | Some (pvar, _) - -> if is_vararg then + | Some (pvar, _) -> + if is_vararg then let do_vararg_value e ts = match Idenv.expand_expr idenv e with - | Exp.Lvar pvar1 - -> pvar_apply loc clear_nullable_flag ts pvar1 - | _ - -> ts + | Exp.Lvar pvar1 -> + pvar_apply loc clear_nullable_flag ts pvar1 + | _ -> + ts in let vararg_values = PatternMatch.java_get_vararg_values node pvar idenv in List.fold_right ~f:do_vararg_value vararg_values ~init:typestate' else pvar_apply loc clear_nullable_flag typestate' pvar - | None - -> typestate' + | None -> + typestate' in (* Handle Preconditions.checkState for &&-separated conditions x!=null. *) let do_preconditions_check_state typestate' = let handle_pvar ann b typestate1 pvar = (* handle the annotation flag for pvar *) match TypeState.lookup_pvar pvar typestate1 with - | Some (t, _, _) - -> TypeState.add pvar (t, TypeAnnotation.const ann b TypeOrigin.ONone, [loc]) typestate1 - | None - -> typestate1 + | Some (t, _, _) -> + TypeState.add pvar (t, TypeAnnotation.const ann b TypeOrigin.ONone, [loc]) typestate1 + | None -> + typestate1 in let res_typestate = ref typestate' in let set_flag pvar ann b = @@ -634,61 +644,60 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get res_typestate := pvar_apply loc (handle_pvar ann b) !res_typestate pvar in let handle_negated_condition cond_node = - let do_instr = - function[@warning "-57"] - | Sil.Prune (Exp.BinOp (Binop.Eq, _cond_e, Exp.Const Const.Cint i), _, _, _) - | Sil.Prune (Exp.BinOp (Binop.Eq, Exp.Const Const.Cint i, _cond_e), _, _, _) - when IntLit.iszero i - -> ( - let cond_e = Idenv.expand_expr_temps idenv cond_node _cond_e in - match convert_complex_exp_to_pvar cond_node false cond_e typestate' loc with - | Exp.Lvar pvar', _ - -> set_flag pvar' AnnotatedSignature.Nullable false - | _ - -> () ) - | _ - -> () + let do_instr = function[@warning "-57"] + | Sil.Prune (Exp.BinOp (Binop.Eq, _cond_e, Exp.Const Const.Cint i), _, _, _) + | Sil.Prune (Exp.BinOp (Binop.Eq, Exp.Const Const.Cint i, _cond_e), _, _, _) + when IntLit.iszero i + -> ( + let cond_e = Idenv.expand_expr_temps idenv cond_node _cond_e in + match convert_complex_exp_to_pvar cond_node false cond_e typestate' loc with + | Exp.Lvar pvar', _ -> + set_flag pvar' AnnotatedSignature.Nullable false + | _ -> + () ) + | _ -> + () (* FIXME: silenced warning may be legit *) in List.iter ~f:do_instr (Procdesc.Node.get_instrs cond_node) in let handle_optional_isPresent node' e = match convert_complex_exp_to_pvar node' false e typestate' loc with - | Exp.Lvar pvar', _ - -> set_flag pvar' AnnotatedSignature.Present true - | _ - -> () + | Exp.Lvar pvar', _ -> + set_flag pvar' AnnotatedSignature.Present true + | _ -> + () in match call_params with | ((_, Exp.Lvar pvar), _) :: _ - -> ( + -> ( (* temporary variable for the value of the boolean condition *) let curr_node = TypeErr.InstrRef.get_node instr_ref in let branch = false in match Errdesc.find_boolean_assignment curr_node pvar branch with (* In foo(cond1 && cond2), the node that sets the result to false has all the negated conditions as parents. *) - | Some boolean_assignment_node - -> List.iter ~f:handle_negated_condition + | Some boolean_assignment_node -> + List.iter ~f:handle_negated_condition (Procdesc.Node.get_preds boolean_assignment_node) ; !res_typestate - | None - -> ( match Errdesc.find_program_variable_assignment curr_node pvar with - | None - -> () - | Some (node', id) - -> let () = + | None -> + ( match Errdesc.find_program_variable_assignment curr_node pvar with + | None -> + () + | Some (node', id) -> + let () = match Errdesc.find_normal_variable_funcall node' id with | Some (Exp.Const Const.Cfun pn, [e], _, _) - when ComplexExpressions.procname_optional_isPresent pn - -> handle_optional_isPresent node' e - | _ - -> () + when ComplexExpressions.procname_optional_isPresent pn -> + handle_optional_isPresent node' e + | _ -> + () in () ) ; !res_typestate ) - | _ - -> typestate' + | _ -> + typestate' in (* Handle m.put(k,v) as assignment pvar = v for the pvar associated to m.get(k) *) let do_map_put typestate' = @@ -698,38 +707,39 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get let parameters = [object_t] in Typ.Procname.java_replace_parameters (Typ.Procname.java_replace_return_type - (Typ.Procname.java_replace_method pname_put "get") object_t) + (Typ.Procname.java_replace_method pname_put "get") + object_t) parameters in match call_params with | ((_, Exp.Lvar pv_map), _) :: ((_, exp_key), _) :: ((_, exp_value), typ_value) :: _ - -> ( + -> ( (* Convert the dexp for k to the dexp for m.get(k) *) let convert_dexp_key_to_dexp_get dopt = match (dopt, callee_pname) with - | Some dexp_key, Typ.Procname.Java callee_pname_java - -> let pname_get = Typ.Procname.Java (pname_get_from_pname_put callee_pname_java) in + | Some dexp_key, Typ.Procname.Java callee_pname_java -> + let pname_get = Typ.Procname.Java (pname_get_from_pname_put callee_pname_java) in let dexp_get = DExp.Dconst (Const.Cfun pname_get) in let dexp_map = DExp.Dpvar pv_map in let args = [dexp_map; dexp_key] in let call_flags = {CallFlags.default with CallFlags.cf_virtual= true} in Some (DExp.Dretcall (dexp_get, args, loc, call_flags)) - | _ - -> None + | _ -> + None in match ComplexExpressions.exp_to_string_map_dexp tenv convert_dexp_key_to_dexp_get node exp_key with - | Some map_get_str - -> let pvar_map_get = Pvar.mk (Mangled.from_string map_get_str) curr_pname in + | Some map_get_str -> + let pvar_map_get = Pvar.mk (Mangled.from_string map_get_str) curr_pname in TypeState.add pvar_map_get (typecheck_expr_simple typestate' exp_value typ_value TypeOrigin.Undef loc) typestate' - | None - -> typestate' ) - | _ - -> typestate' + | None -> + typestate' ) + | _ -> + typestate' in let typestate_after_call, resolved_ret = let resolve_param i (sparam, cparam) = @@ -754,8 +764,8 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get (resolved_params: EradicateChecks.resolved_param list) = let rec handle_params resolved_ret params = match (params : EradicateChecks.resolved_param list) with - | param :: params' when param.propagates_nullable - -> let _, actual_ta = param.actual in + | param :: params' when param.propagates_nullable -> + let _, actual_ta = param.actual in let resolved_ret' = let ret_ta, ret_typ = resolved_ret in let ret_ta' = @@ -771,10 +781,10 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get (ret_ta', ret_typ) in handle_params resolved_ret' params' - | _ :: params' - -> handle_params resolved_ret params' - | [] - -> resolved_ret + | _ :: params' -> + handle_params resolved_ret params' + | [] -> + resolved_ret in handle_params resolved_ret resolved_params in @@ -835,13 +845,14 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get in let has_method pn name = match pn with - | Typ.Procname.Java pn_java - -> String.equal (Typ.Procname.java_get_method pn_java) name - | _ - -> false + | Typ.Procname.Java pn_java -> + String.equal (Typ.Procname.java_get_method pn_java) name + | _ -> + false in if Models.is_check_not_null callee_pname then - do_preconditions_check_not_null (Models.get_check_not_null_parameter callee_pname) + do_preconditions_check_not_null + (Models.get_check_not_null_parameter callee_pname) ~is_vararg:false typestate2 else if has_method callee_pname "checkNotNull" && Typ.Procname.java_is_vararg callee_pname @@ -857,21 +868,21 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get (typestate_after_call, resolved_ret) in do_return resolved_ret loc typestate_after_call - | Sil.Call _ - -> typestate - | Sil.Prune (cond, loc, true_branch, _) - -> let rec check_condition node' c : _ TypeState.t = + | Sil.Call _ -> + typestate + | Sil.Prune (cond, loc, true_branch, _) -> + let rec check_condition node' c : _ TypeState.t = (* check if the expression is coming from a call, and return the argument *) let from_call filter_callee e : Exp.t option = match e with | Exp.Var id -> ( match Errdesc.find_normal_variable_funcall node' id with - | Some (Exp.Const Const.Cfun pn, e1 :: _, _, _) when filter_callee pn - -> Some e1 - | _ - -> None ) - | _ - -> None + | Some (Exp.Const Const.Cfun pn, e1 :: _, _, _) when filter_callee pn -> + Some e1 + | _ -> + None ) + | _ -> + None in (* check if the expression is coming from instanceof *) let from_instanceof e : Exp.t option = @@ -899,20 +910,21 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get let map_dexp = function | Some DExp.Dretcall - (DExp.Dconst Const.Cfun Typ.Procname.Java pname_java, args, loc, call_flags) - -> let pname_java' = + (DExp.Dconst Const.Cfun Typ.Procname.Java pname_java, args, loc, call_flags) -> + let pname_java' = let object_t = (Some "java.lang", "Object") in Typ.Procname.java_replace_return_type - (Typ.Procname.java_replace_method pname_java "get") object_t + (Typ.Procname.java_replace_method pname_java "get") + object_t in let fun_dexp = DExp.Dconst (Const.Cfun (Typ.Procname.Java pname_java')) in Some (DExp.Dretcall (fun_dexp, args, loc, call_flags)) - | _ - -> None + | _ -> + None in match ComplexExpressions.exp_to_string_map_dexp tenv map_dexp node' e with - | Some e_str - -> let pvar = Pvar.mk (Mangled.from_string e_str) curr_pname in + | Some e_str -> + let pvar = Pvar.mk (Mangled.from_string e_str) curr_pname in let e1 = Exp.Lvar pvar in let typ, ta, _ = typecheck_expr_simple typestate e1 (Typ.mk Tvoid) TypeOrigin.ONone loc @@ -920,39 +932,39 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get let range = (typ, ta, [loc]) in let typestate1 = TypeState.add pvar range typestate in (typestate1, e1, EradicateChecks.From_containsKey) - | None - -> (typestate, e, EradicateChecks.From_condition) + | None -> + (typestate, e, EradicateChecks.From_condition) in let set_flag e' ann b typestate2 = (* add constraint on e' for annotation ann *) let handle_pvar typestate' pvar = match TypeState.lookup_pvar pvar typestate' with - | Some (t, ta1, locs) - -> if TypeAnnotation.get_value ann ta1 <> b then + | Some (t, ta1, locs) -> + if TypeAnnotation.get_value ann ta1 <> b then let ta2 = TypeAnnotation.set_value ann b ta1 in TypeState.add pvar (t, ta2, locs) typestate' else typestate' - | None - -> typestate' + | None -> + typestate' in match e' with - | Exp.Lvar pvar - -> pvar_apply loc handle_pvar typestate2 pvar - | _ - -> typestate2 + | Exp.Lvar pvar -> + pvar_apply loc handle_pvar typestate2 pvar + | _ -> + typestate2 in - match[@warning "-57"] c with + ( match[@warning "-57"] c with | Exp.BinOp (Binop.Eq, Exp.Const Const.Cint i, e) | Exp.BinOp (Binop.Eq, e, Exp.Const Const.Cint i) when IntLit.iszero i - -> ( + -> ( typecheck_expr_for_errors typestate e loc ; let typestate1, e1, from_call = match from_is_true_on_null e with - | Some e1 - -> (typestate, e1, EradicateChecks.From_is_true_on_null) - | None - -> (typestate, e, EradicateChecks.From_condition) + | Some e1 -> + (typestate, e1, EradicateChecks.From_is_true_on_null) + | None -> + (typestate, e, EradicateChecks.From_condition) in let e', typestate2 = convert_complex_exp_to_pvar node' false e1 typestate1 loc in let typ, ta, _ = @@ -962,37 +974,37 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get EradicateChecks.check_zero tenv find_canonical_duplicate curr_pdesc node' e' typ ta true_branch EradicateChecks.From_condition idenv linereader loc instr_ref ; match from_call with - | EradicateChecks.From_is_true_on_null - -> (* if f returns true on null, then false branch implies != null *) + | EradicateChecks.From_is_true_on_null -> + (* if f returns true on null, then false branch implies != null *) if TypeAnnotation.get_value AnnotatedSignature.Nullable ta then set_flag e' AnnotatedSignature.Nullable false typestate2 else typestate2 - | _ - -> typestate2 ) + | _ -> + typestate2 ) | Exp.BinOp (Binop.Ne, Exp.Const Const.Cint i, e) | Exp.BinOp (Binop.Ne, e, Exp.Const Const.Cint i) when IntLit.iszero i - -> ( + -> ( typecheck_expr_for_errors typestate e loc ; let typestate1, e1, from_call = match from_instanceof e with - | Some e1 - -> (* (e1 instanceof C) implies (e1 != null) *) + | Some e1 -> + (* (e1 instanceof C) implies (e1 != null) *) (typestate, e1, EradicateChecks.From_instanceof) | None -> match from_optional_isPresent e with - | Some e1 - -> (typestate, e1, EradicateChecks.From_optional_isPresent) + | Some e1 -> + (typestate, e1, EradicateChecks.From_optional_isPresent) | None -> match from_is_false_on_null e with - | Some e1 - -> (typestate, e1, EradicateChecks.From_is_false_on_null) + | Some e1 -> + (typestate, e1, EradicateChecks.From_is_false_on_null) | None -> match from_containsKey e with - | Some _ when ComplexExpressions.functions_idempotent () - -> handle_containsKey e - | _ - -> (typestate, e, EradicateChecks.From_condition) + | Some _ when ComplexExpressions.functions_idempotent () -> + handle_containsKey e + | _ -> + (typestate, e, EradicateChecks.From_condition) in let e', typestate2 = convert_complex_exp_to_pvar node' false e1 typestate1 loc in let typ, ta, _ = @@ -1002,74 +1014,75 @@ let typecheck_instr tenv ext calls_this checks (node: Procdesc.Node.t) idenv get EradicateChecks.check_nonzero tenv find_canonical_duplicate curr_pdesc node e' typ ta true_branch from_call idenv linereader loc instr_ref ; match from_call with - | EradicateChecks.From_optional_isPresent - -> if not (TypeAnnotation.get_value AnnotatedSignature.Present ta) then + | EradicateChecks.From_optional_isPresent -> + if not (TypeAnnotation.get_value AnnotatedSignature.Present ta) then set_flag e' AnnotatedSignature.Present true typestate2 else typestate2 - | EradicateChecks.From_is_true_on_null - -> typestate2 + | EradicateChecks.From_is_true_on_null -> + typestate2 | EradicateChecks.From_condition | EradicateChecks.From_containsKey | EradicateChecks.From_instanceof - | EradicateChecks.From_is_false_on_null - -> if TypeAnnotation.get_value AnnotatedSignature.Nullable ta then + | EradicateChecks.From_is_false_on_null -> + if TypeAnnotation.get_value AnnotatedSignature.Nullable ta then set_flag e' AnnotatedSignature.Nullable false typestate2 else typestate2 ) - | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.Eq, e1, e2), _) - -> check_condition node' (Exp.BinOp (Binop.Ne, e1, e2)) - | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.Ne, e1, e2), _) - -> check_condition node' (Exp.BinOp (Binop.Eq, e1, e2)) - | _ - -> typestate + | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.Eq, e1, e2), _) -> + check_condition node' (Exp.BinOp (Binop.Ne, e1, e2)) + | Exp.UnOp (Unop.LNot, Exp.BinOp (Binop.Ne, e1, e2), _) -> + check_condition node' (Exp.BinOp (Binop.Eq, e1, e2)) + | _ -> + typestate ) (* FIXME: silenced warning may be legit *) in (* Handle assigment fron a temp pvar in a condition. This recognizes the handling of temp variables in ((x = ...) != null) *) let handle_assignment_in_condition pvar = match Procdesc.Node.get_preds node with - | [prev_node] - -> let found = ref None in + | [prev_node] -> + let found = ref None in let do_instr i = match i with - | Sil.Store (e, _, e', _) when Exp.equal (Exp.Lvar pvar) (Idenv.expand_expr idenv e') - -> found := Some e - | _ - -> () + | Sil.Store (e, _, e', _) when Exp.equal (Exp.Lvar pvar) (Idenv.expand_expr idenv e') -> + found := Some e + | _ -> + () in List.iter ~f:do_instr (Procdesc.Node.get_instrs prev_node) ; !found - | _ - -> None + | _ -> + None in (* Normalize the condition by resolving temp variables. *) let rec normalize_cond _node _cond = match _cond with - | Exp.UnOp (Unop.LNot, c, top) - -> let node', c' = normalize_cond _node c in + | Exp.UnOp (Unop.LNot, c, top) -> + let node', c' = normalize_cond _node c in (node', Exp.UnOp (Unop.LNot, c', top)) - | Exp.BinOp (bop, c1, c2) - -> let node', c1' = normalize_cond _node c1 in + | Exp.BinOp (bop, c1, c2) -> + let node', c1' = normalize_cond _node c1 in let node'', c2' = normalize_cond node' c2 in (node'', Exp.BinOp (bop, c1', c2')) - | Exp.Var _ - -> let c' = Idenv.expand_expr idenv _cond in + | Exp.Var _ -> + let c' = Idenv.expand_expr idenv _cond in if not (Exp.equal c' _cond) then normalize_cond _node c' else (_node, c') | Exp.Lvar pvar when Pvar.is_frontend_tmp pvar -> ( match handle_assignment_in_condition pvar with | None -> ( match Errdesc.find_program_variable_assignment _node pvar with - | Some (node', id) - -> (node', Exp.Var id) - | None - -> (_node, _cond) ) - | Some e2 - -> (_node, e2) ) - | c - -> (_node, c) + | Some (node', id) -> + (node', Exp.Var id) + | None -> + (_node, _cond) ) + | Some e2 -> + (_node, e2) ) + | c -> + (_node, c) in let node', ncond = normalize_cond node cond in check_condition node' ncond + (** Typecheck the instructions in a cfg node. *) let typecheck_node tenv ext calls_this checks idenv get_proc_desc curr_pname curr_pdesc find_canonical_duplicate annotated_signature typestate node linereader = @@ -1079,26 +1092,26 @@ let typecheck_node tenv ext calls_this checks idenv get_proc_desc curr_pname cur let noreturn = ref false in let handle_exceptions typestate instr = match instr with - | Sil.Call (_, Exp.Const Const.Cfun callee_pname, _, _, _) when Models.is_noreturn callee_pname - -> noreturn := true - | Sil.Call (_, Exp.Const Const.Cfun callee_pname, _, _, _) - -> let callee_attributes_opt = Specs.proc_resolve_attributes callee_pname in + | Sil.Call (_, Exp.Const Const.Cfun callee_pname, _, _, _) when Models.is_noreturn callee_pname -> + noreturn := true + | Sil.Call (_, Exp.Const Const.Cfun callee_pname, _, _, _) -> + let callee_attributes_opt = Specs.proc_resolve_attributes callee_pname in (* check if the call might throw an exception *) let has_exceptions = match callee_attributes_opt with - | Some callee_attributes - -> callee_attributes.ProcAttributes.exceptions <> [] - | None - -> false + | Some callee_attributes -> + callee_attributes.ProcAttributes.exceptions <> [] + | None -> + false in if has_exceptions then typestates_exn := typestate :: !typestates_exn | Sil.Store (Exp.Lvar pv, _, _, _) when Pvar.is_return pv - && Procdesc.Node.equal_nodekind (Procdesc.Node.get_kind node) Procdesc.Node.throw_kind - -> (* throw instruction *) + && Procdesc.Node.equal_nodekind (Procdesc.Node.get_kind node) Procdesc.Node.throw_kind -> + (* throw instruction *) typestates_exn := typestate :: !typestates_exn - | _ - -> () + | _ -> + () in let canonical_node = find_canonical_duplicate node in let do_instruction ext typestate instr = @@ -1123,3 +1136,4 @@ let typecheck_node tenv ext calls_this checks idenv get_proc_desc curr_pname cur in if dont_propagate then ([], []) (* don't propagate to exit node *) else ([typestate_succ], !typestates_exn) + diff --git a/infer/src/eradicate/typeErr.ml b/infer/src/eradicate/typeErr.ml index 0cc84f10b..8dedf53d4 100644 --- a/infer/src/eradicate/typeErr.ml +++ b/infer/src/eradicate/typeErr.ml @@ -55,6 +55,7 @@ module InstrRef : InstrRefT = struct let gen instr_ref_gen = let node, ir = instr_ref_gen in incr ir ; (node, !ir) + end (* InstrRef *) @@ -103,38 +104,40 @@ module H = Hashtbl.Make (struct let string_hash s = Hashtbl.hash s in let string_opt_hash so = Hashtbl.hash so in match x with - | Condition_redundant (b, so, nn) - -> Hashtbl.hash (1, b, string_opt_hash so, nn) - | Field_not_initialized (fn, pn) - -> Hashtbl.hash (2, string_hash (Typ.Fieldname.to_string fn ^ Typ.Procname.to_string pn)) - | Field_not_mutable (fn, _) - -> Hashtbl.hash (3, string_hash (Typ.Fieldname.to_string fn)) - | Field_annotation_inconsistent (ann, fn, _) - -> Hashtbl.hash (4, ann, string_hash (Typ.Fieldname.to_string fn)) - | Field_over_annotated (fn, pn) - -> Hashtbl.hash (5, string_hash (Typ.Fieldname.to_string fn ^ Typ.Procname.to_string pn)) - | Null_field_access (so, fn, _, _) - -> Hashtbl.hash (6, string_opt_hash so, string_hash (Typ.Fieldname.to_string fn)) - | Call_receiver_annotation_inconsistent (ann, so, pn, _) - -> Hashtbl.hash (7, ann, string_opt_hash so, Typ.Procname.hash_pname pn) - | Parameter_annotation_inconsistent (ann, s, n, pn, _, _) - -> Hashtbl.hash (8, ann, string_hash s, n, Typ.Procname.hash_pname pn) - | Return_annotation_inconsistent (ann, pn, _) - -> Hashtbl.hash (9, ann, Typ.Procname.hash_pname pn) - | Return_over_annotated pn - -> Hashtbl.hash (10, Typ.Procname.hash_pname pn) - | Inconsistent_subclass_return_annotation (pn, opn) - -> Hashtbl.hash (11, Typ.Procname.hash_pname pn, Typ.Procname.hash_pname opn) - | Inconsistent_subclass_parameter_annotation (param_name, pos, pn, opn) - -> let pn_hash = string_hash param_name in + | Condition_redundant (b, so, nn) -> + Hashtbl.hash (1, b, string_opt_hash so, nn) + | Field_not_initialized (fn, pn) -> + Hashtbl.hash (2, string_hash (Typ.Fieldname.to_string fn ^ Typ.Procname.to_string pn)) + | Field_not_mutable (fn, _) -> + Hashtbl.hash (3, string_hash (Typ.Fieldname.to_string fn)) + | Field_annotation_inconsistent (ann, fn, _) -> + Hashtbl.hash (4, ann, string_hash (Typ.Fieldname.to_string fn)) + | Field_over_annotated (fn, pn) -> + Hashtbl.hash (5, string_hash (Typ.Fieldname.to_string fn ^ Typ.Procname.to_string pn)) + | Null_field_access (so, fn, _, _) -> + Hashtbl.hash (6, string_opt_hash so, string_hash (Typ.Fieldname.to_string fn)) + | Call_receiver_annotation_inconsistent (ann, so, pn, _) -> + Hashtbl.hash (7, ann, string_opt_hash so, Typ.Procname.hash_pname pn) + | Parameter_annotation_inconsistent (ann, s, n, pn, _, _) -> + Hashtbl.hash (8, ann, string_hash s, n, Typ.Procname.hash_pname pn) + | Return_annotation_inconsistent (ann, pn, _) -> + Hashtbl.hash (9, ann, Typ.Procname.hash_pname pn) + | Return_over_annotated pn -> + Hashtbl.hash (10, Typ.Procname.hash_pname pn) + | Inconsistent_subclass_return_annotation (pn, opn) -> + Hashtbl.hash (11, Typ.Procname.hash_pname pn, Typ.Procname.hash_pname opn) + | Inconsistent_subclass_parameter_annotation (param_name, pos, pn, opn) -> + let pn_hash = string_hash param_name in Hashtbl.hash (12, pn_hash, pos, Typ.Procname.hash_pname pn, Typ.Procname.hash_pname opn) + let hash (err_inst, instr_ref_opt) = let x = match instr_ref_opt with None -> None | Some instr_ref -> Some (InstrRef.hash instr_ref) in let y = err_instance_hash err_inst in Hashtbl.hash (x, y) + end (* H *)) @@ -151,44 +154,46 @@ let reset () = H.reset err_tbl The forall status indicates that the error should be printed only if it occurs on every path. *) let get_forall = function - | Condition_redundant _ - -> true - | Field_not_initialized _ - -> false - | Field_not_mutable _ - -> false - | Field_annotation_inconsistent _ - -> false - | Field_over_annotated _ - -> false - | Inconsistent_subclass_return_annotation _ - -> false - | Inconsistent_subclass_parameter_annotation _ - -> false - | Null_field_access _ - -> false - | Call_receiver_annotation_inconsistent _ - -> false - | Parameter_annotation_inconsistent _ - -> false - | Return_annotation_inconsistent _ - -> false - | Return_over_annotated _ - -> false + | Condition_redundant _ -> + true + | Field_not_initialized _ -> + false + | Field_not_mutable _ -> + false + | Field_annotation_inconsistent _ -> + false + | Field_over_annotated _ -> + false + | Inconsistent_subclass_return_annotation _ -> + false + | Inconsistent_subclass_parameter_annotation _ -> + false + | Null_field_access _ -> + false + | Call_receiver_annotation_inconsistent _ -> + false + | Parameter_annotation_inconsistent _ -> + false + | Return_annotation_inconsistent _ -> + false + | Return_over_annotated _ -> + false + (** Reset the always field of the forall erros in the node, so if they are not set again we know that they don't fire on every path. *) let node_reset_forall node = let iter (err_instance, instr_ref_opt) err_state = match (instr_ref_opt, get_forall err_instance) with - | Some instr_ref, is_forall - -> let node' = InstrRef.get_node instr_ref in + | Some instr_ref, is_forall -> + let node' = InstrRef.get_node instr_ref in if is_forall && Procdesc.Node.equal node node' then err_state.always <- false - | None, _ - -> () + | None, _ -> + () in H.iter iter err_tbl + (** Add an error to the error table and return whether it should be printed now. *) let add_err find_canonical_duplicate err_instance instr_ref_opt loc = let is_forall = get_forall err_instance in @@ -196,18 +201,19 @@ let add_err find_canonical_duplicate err_instance instr_ref_opt loc = else let instr_ref_opt_deduplicate = match (is_forall, instr_ref_opt) with - | true, Some instr_ref - -> (* use canonical duplicate for forall checks *) + | true, Some instr_ref -> + (* use canonical duplicate for forall checks *) let node = InstrRef.get_node instr_ref in let canonical_node = find_canonical_duplicate node in let instr_ref' = InstrRef.replace_node instr_ref canonical_node in Some instr_ref' - | _ - -> instr_ref_opt + | _ -> + instr_ref_opt in H.add err_tbl (err_instance, instr_ref_opt_deduplicate) {loc; always= true} ; not is_forall + (* print now if it's not a forall check *) module Strict = struct @@ -215,30 +221,34 @@ module Strict = struct let ia, _ = signature.ret in Annotations.ia_get_strict ia + let this_type_get_strict tenv (signature: AnnotatedSignature.t) = match signature.params with | (p, _, this_type) :: _ when String.equal (Mangled.to_string p) "this" -> ( match PatternMatch.type_get_annotation tenv this_type with - | Some ia - -> Annotations.ia_get_strict ia - | None - -> None ) - | _ - -> None + | Some ia -> + Annotations.ia_get_strict ia + | None -> + None ) + | _ -> + None + let signature_get_strict tenv signature = match method_get_strict signature with - | None - -> this_type_get_strict tenv signature - | Some x - -> Some x + | None -> + this_type_get_strict tenv signature + | Some x -> + Some x + let origin_descr_get_strict tenv origin_descr = match origin_descr with - | _, _, Some signature - -> signature_get_strict tenv signature - | _, _, None - -> None + | _, _, Some signature -> + signature_get_strict tenv signature + | _, _, None -> + None + let report_on_method_arguments = false @@ -248,13 +258,14 @@ module Strict = struct let err_instance_get_strict tenv err_instance : Annot.t option = match err_instance with | Call_receiver_annotation_inconsistent (AnnotatedSignature.Nullable, _, _, origin_descr) - | Null_field_access (_, _, origin_descr, _) - -> origin_descr_get_strict tenv origin_descr + | Null_field_access (_, _, origin_descr, _) -> + origin_descr_get_strict tenv origin_descr | Parameter_annotation_inconsistent (AnnotatedSignature.Nullable, _, _, _, _, origin_descr) - when report_on_method_arguments - -> origin_descr_get_strict tenv origin_descr - | _ - -> None + when report_on_method_arguments -> + origin_descr_get_strict tenv origin_descr + | _ -> + None + end (* Strict *) @@ -272,17 +283,17 @@ let report_error_now tenv (st_report_error: st_report_error) err_instance loc pd L.progress "%a:%d " SourceFile.pp loc.Location.file loc.Location.line ; let mname = match pname with - | Typ.Procname.Java pname_java - -> Typ.Procname.java_get_method pname_java - | _ - -> Typ.Procname.to_simplified_string pname + | Typ.Procname.Java pname_java -> + Typ.Procname.java_get_method pname_java + | _ -> + Typ.Procname.to_simplified_string pname in L.progress "%s %s in %s %s@." ew_string kind.IssueType.unique_id mname s in let is_err, kind, description, advice, field_name, origin_loc = match err_instance with - | Condition_redundant (b, s_opt, nonnull) - -> let name = + | Condition_redundant (b, s_opt, nonnull) -> + let name = if nonnull then IssueType.eradicate_condition_redundant_nonnull else IssueType.eradicate_condition_redundant in @@ -295,161 +306,173 @@ let report_error_now tenv (st_report_error: st_report_error) err_instance loc pd ^ " annotation or removing the redundant check." ) , None , None ) - | Field_not_initialized (fn, pn) - -> let constructor_name = + | Field_not_initialized (fn, pn) -> + let constructor_name = if Typ.Procname.is_constructor pn then "the constructor" else match pn with - | Typ.Procname.Java pn_java - -> MF.monospaced_to_string (Typ.Procname.java_get_method pn_java) - | _ - -> MF.monospaced_to_string (Typ.Procname.to_simplified_string pn) + | Typ.Procname.Java pn_java -> + MF.monospaced_to_string (Typ.Procname.java_get_method pn_java) + | _ -> + MF.monospaced_to_string (Typ.Procname.to_simplified_string pn) in ( true , IssueType.eradicate_field_not_initialized , Format.asprintf "Field %a is not initialized in %s and is not declared %a" - MF.pp_monospaced (Typ.Fieldname.to_simplified_string fn) constructor_name - MF.pp_monospaced "@Nullable" + MF.pp_monospaced + (Typ.Fieldname.to_simplified_string fn) + constructor_name MF.pp_monospaced "@Nullable" , None , Some fn , None ) - | Field_not_mutable (fn, (origin_description, origin_loc, _)) - -> ( true + | Field_not_mutable (fn, (origin_description, origin_loc, _)) -> + ( true , IssueType.eradicate_field_not_mutable , Format.asprintf "Field %a is modified but is not declared %a. %s" MF.pp_monospaced - (Typ.Fieldname.to_simplified_string fn) MF.pp_monospaced "@Mutable" origin_description + (Typ.Fieldname.to_simplified_string fn) + MF.pp_monospaced "@Mutable" origin_description , None , None , origin_loc ) - | Field_annotation_inconsistent (ann, fn, (origin_description, origin_loc, _)) - -> let kind_s, description = + | Field_annotation_inconsistent (ann, fn, (origin_description, origin_loc, _)) -> + let kind_s, description = match ann with - | AnnotatedSignature.Nullable - -> ( IssueType.eradicate_field_not_nullable + | AnnotatedSignature.Nullable -> + ( IssueType.eradicate_field_not_nullable , Format.asprintf "Field %a can be null but is not declared %a. %s" MF.pp_monospaced - (Typ.Fieldname.to_simplified_string fn) MF.pp_monospaced "@Nullable" - origin_description ) - | AnnotatedSignature.Present - -> ( IssueType.eradicate_field_value_absent + (Typ.Fieldname.to_simplified_string fn) + MF.pp_monospaced "@Nullable" origin_description ) + | AnnotatedSignature.Present -> + ( IssueType.eradicate_field_value_absent , Format.asprintf "Field %a is assigned a possibly absent value but is declared %a. %s" - MF.pp_monospaced (Typ.Fieldname.to_simplified_string fn) MF.pp_monospaced - "@Present" origin_description ) + MF.pp_monospaced + (Typ.Fieldname.to_simplified_string fn) + MF.pp_monospaced "@Present" origin_description ) in (true, kind_s, description, None, None, origin_loc) - | Field_over_annotated (fn, pn) - -> let constructor_name = + | Field_over_annotated (fn, pn) -> + let constructor_name = if Typ.Procname.is_constructor pn then "the constructor" else match pn with - | Typ.Procname.Java pn_java - -> Typ.Procname.java_get_method pn_java - | _ - -> Typ.Procname.to_simplified_string pn + | Typ.Procname.Java pn_java -> + Typ.Procname.java_get_method pn_java + | _ -> + Typ.Procname.to_simplified_string pn in ( true , IssueType.eradicate_field_over_annotated , Format.asprintf "Field %a is always initialized in %s but is declared %a" - MF.pp_monospaced (Typ.Fieldname.to_simplified_string fn) constructor_name - MF.pp_monospaced "@Nullable" + MF.pp_monospaced + (Typ.Fieldname.to_simplified_string fn) + constructor_name MF.pp_monospaced "@Nullable" , None , Some fn , None ) - | Null_field_access (s_opt, fn, (origin_description, origin_loc, _), indexed) - -> let at_index = if indexed then "element at index" else "field" in + | Null_field_access (s_opt, fn, (origin_description, origin_loc, _), indexed) -> + let at_index = if indexed then "element at index" else "field" in ( true , IssueType.eradicate_null_field_access , Format.asprintf "Object %a could be null when accessing %s %a. %s" MF.pp_monospaced (Option.value s_opt ~default:"") at_index MF.pp_monospaced - (Typ.Fieldname.to_simplified_string fn) origin_description + (Typ.Fieldname.to_simplified_string fn) + origin_description , None , None , origin_loc ) - | Call_receiver_annotation_inconsistent (ann, s_opt, pn, (origin_description, origin_loc, _)) - -> let kind_s, description = + | Call_receiver_annotation_inconsistent (ann, s_opt, pn, (origin_description, origin_loc, _)) -> + let kind_s, description = match ann with - | AnnotatedSignature.Nullable - -> ( IssueType.eradicate_null_method_call + | AnnotatedSignature.Nullable -> + ( IssueType.eradicate_null_method_call , Format.asprintf "The value of %a in the call to %a could be null. %s" MF.pp_monospaced (Option.value s_opt ~default:"") MF.pp_monospaced - (Typ.Procname.to_simplified_string pn) origin_description ) - | AnnotatedSignature.Present - -> ( IssueType.eradicate_value_not_present + (Typ.Procname.to_simplified_string pn) + origin_description ) + | AnnotatedSignature.Present -> + ( IssueType.eradicate_value_not_present , Format.asprintf "The value of %a in the call to %a is not %a. %s" MF.pp_monospaced (Option.value s_opt ~default:"") MF.pp_monospaced - (Typ.Procname.to_simplified_string pn) MF.pp_monospaced "@Present" - origin_description ) + (Typ.Procname.to_simplified_string pn) + MF.pp_monospaced "@Present" origin_description ) in (true, kind_s, description, None, None, origin_loc) - | Parameter_annotation_inconsistent (ann, s, n, pn, _, (origin_desc, origin_loc, _)) - -> let kind_s, description = + | Parameter_annotation_inconsistent (ann, s, n, pn, _, (origin_desc, origin_loc, _)) -> + let kind_s, description = match ann with - | AnnotatedSignature.Nullable - -> ( IssueType.eradicate_parameter_not_nullable + | AnnotatedSignature.Nullable -> + ( IssueType.eradicate_parameter_not_nullable , Format.asprintf "%a needs a non-null value in parameter %d but argument %a can be null. %s" - MF.pp_monospaced (Typ.Procname.to_simplified_string pn) n MF.pp_monospaced s - origin_desc ) - | AnnotatedSignature.Present - -> ( IssueType.eradicate_parameter_value_absent + MF.pp_monospaced + (Typ.Procname.to_simplified_string pn) + n MF.pp_monospaced s origin_desc ) + | AnnotatedSignature.Present -> + ( IssueType.eradicate_parameter_value_absent , Format.asprintf "%a needs a present value in parameter %d but argument %a can be absent. %s" - MF.pp_monospaced (Typ.Procname.to_simplified_string pn) n MF.pp_monospaced s - origin_desc ) + MF.pp_monospaced + (Typ.Procname.to_simplified_string pn) + n MF.pp_monospaced s origin_desc ) in (true, kind_s, description, None, None, origin_loc) - | Return_annotation_inconsistent (ann, pn, (origin_description, origin_loc, _)) - -> let kind_s, description = + | Return_annotation_inconsistent (ann, pn, (origin_description, origin_loc, _)) -> + let kind_s, description = match ann with - | AnnotatedSignature.Nullable - -> ( IssueType.eradicate_return_not_nullable + | AnnotatedSignature.Nullable -> + ( IssueType.eradicate_return_not_nullable , Format.asprintf "Method %a may return null but it is not annotated with %a. %s" - MF.pp_monospaced (Typ.Procname.to_simplified_string pn) MF.pp_monospaced - "@Nullable" origin_description ) - | AnnotatedSignature.Present - -> ( IssueType.eradicate_return_value_not_present + MF.pp_monospaced + (Typ.Procname.to_simplified_string pn) + MF.pp_monospaced "@Nullable" origin_description ) + | AnnotatedSignature.Present -> + ( IssueType.eradicate_return_value_not_present , Format.asprintf "Method %a may return an absent value but it is annotated with %a. %s" - MF.pp_monospaced (Typ.Procname.to_simplified_string pn) MF.pp_monospaced - "@Present" origin_description ) + MF.pp_monospaced + (Typ.Procname.to_simplified_string pn) + MF.pp_monospaced "@Present" origin_description ) in (true, kind_s, description, None, None, origin_loc) - | Return_over_annotated pn - -> ( false + | Return_over_annotated pn -> + ( false , IssueType.eradicate_return_over_annotated , Format.asprintf "Method %a is annotated with %a but never returns null." MF.pp_monospaced - (Typ.Procname.to_simplified_string pn) MF.pp_monospaced "@Nullable" + (Typ.Procname.to_simplified_string pn) + MF.pp_monospaced "@Nullable" , None , None , None ) - | Inconsistent_subclass_return_annotation (pn, opn) - -> ( false + | Inconsistent_subclass_return_annotation (pn, opn) -> + ( false , IssueType.eradicate_inconsistent_subclass_return_annotation , Format.asprintf "Method %a is annotated with %a but overrides unannotated method %a." - MF.pp_monospaced (Typ.Procname.to_simplified_string ~withclass:true pn) + MF.pp_monospaced + (Typ.Procname.to_simplified_string ~withclass:true pn) MF.pp_monospaced "@Nullable" MF.pp_monospaced (Typ.Procname.to_simplified_string ~withclass:true opn) , None , None , None ) - | Inconsistent_subclass_parameter_annotation (param_name, pos, pn, opn) - -> let translate_position = function - | 1 - -> "First" - | 2 - -> "Second" - | 3 - -> "Third" - | n - -> string_of_int n ^ "th" + | Inconsistent_subclass_parameter_annotation (param_name, pos, pn, opn) -> + let translate_position = function + | 1 -> + "First" + | 2 -> + "Second" + | 3 -> + "Third" + | n -> + string_of_int n ^ "th" in ( false , IssueType.eradicate_inconsistent_subclass_parameter_annotation , Format.asprintf "%s parameter %a of method %a is not %a but is declared %ain the parent class method %a." (translate_position pos) MF.pp_monospaced param_name MF.pp_monospaced - (Typ.Procname.to_simplified_string ~withclass:true pn) MF.pp_monospaced "@Nullable" - MF.pp_monospaced "@Nullable" MF.pp_monospaced + (Typ.Procname.to_simplified_string ~withclass:true pn) + MF.pp_monospaced "@Nullable" MF.pp_monospaced "@Nullable" MF.pp_monospaced (Typ.Procname.to_simplified_string ~withclass:true opn) , None , None @@ -462,6 +485,7 @@ let report_error_now tenv (st_report_error: st_report_error) err_instance loc pd ~exception_kind:(fun k d -> Exceptions.Eradicate (k, d)) ~always_report description + (** Report an error unless is has been reported already, or unless it's a forall error since it requires waiting until the end of the analysis and be printed by flush. *) let report_error tenv (st_report_error: st_report_error) find_canonical_duplicate err_instance @@ -469,16 +493,18 @@ let report_error tenv (st_report_error: st_report_error) find_canonical_duplicat let should_report_now = add_err find_canonical_duplicate err_instance instr_ref_opt loc in if should_report_now then report_error_now tenv st_report_error err_instance loc pdesc + (** Report the forall checks at the end of the analysis and reset the error table *) let report_forall_checks_and_reset tenv st_report_error proc_desc = let iter (err_instance, instr_ref_opt) err_state = match (instr_ref_opt, get_forall err_instance) with - | Some instr_ref, is_forall - -> let node = InstrRef.get_node instr_ref in + | Some instr_ref, is_forall -> + let node = InstrRef.get_node instr_ref in State.set_node node ; if is_forall && err_state.always then report_error_now tenv st_report_error err_instance err_state.loc proc_desc - | None, _ - -> () + | None, _ -> + () in H.iter iter err_tbl ; reset () + diff --git a/infer/src/eradicate/typeOrigin.ml b/infer/src/eradicate/typeOrigin.ml index c81d38e6c..f98024e46 100644 --- a/infer/src/eradicate/typeOrigin.ml +++ b/infer/src/eradicate/typeOrigin.ml @@ -33,63 +33,67 @@ type t = let equal = [%compare.equal : t] let rec to_string = function - | Const _ - -> "Const" - | Field (o, fn, _) - -> "Field " ^ Typ.Fieldname.to_simplified_string fn ^ " (inner: " ^ to_string o ^ ")" - | Formal s - -> "Formal " ^ Mangled.to_string s - | Proc po - -> Printf.sprintf "Fun %s" (Typ.Procname.to_simplified_string po.pname) - | New - -> "New" - | ONone - -> "ONone" - | Undef - -> "Undef" + | Const _ -> + "Const" + | Field (o, fn, _) -> + "Field " ^ Typ.Fieldname.to_simplified_string fn ^ " (inner: " ^ to_string o ^ ")" + | Formal s -> + "Formal " ^ Mangled.to_string s + | Proc po -> + Printf.sprintf "Fun %s" (Typ.Procname.to_simplified_string po.pname) + | New -> + "New" + | ONone -> + "ONone" + | Undef -> + "Undef" + let get_description tenv origin = let atline loc = " at line " ^ string_of_int loc.Location.line in match origin with - | Const loc - -> Some ("null constant" ^ atline loc, Some loc, None) - | Field (_, fn, loc) - -> Some ("field " ^ Typ.Fieldname.to_simplified_string fn ^ atline loc, Some loc, None) - | Formal s - -> Some ("method parameter " ^ Mangled.to_string s, None, None) - | Proc po - -> let strict = + | Const loc -> + Some ("null constant" ^ atline loc, Some loc, None) + | Field (_, fn, loc) -> + Some ("field " ^ Typ.Fieldname.to_simplified_string fn ^ atline loc, Some loc, None) + | Formal s -> + Some ("method parameter " ^ Mangled.to_string s, None, None) + | Proc po -> + let strict = match TypeErr.Strict.signature_get_strict tenv po.annotated_signature with | Some ann - -> ( + -> ( let str = "@Strict" in match ann.Annot.parameters with - | par1 :: _ - -> Printf.sprintf "%s(%s) " str par1 - | [] - -> Printf.sprintf "%s " str ) - | None - -> "" + | par1 :: _ -> + Printf.sprintf "%s(%s) " str par1 + | [] -> + Printf.sprintf "%s " str ) + | None -> + "" in let modelled_in = if Models.is_modelled_nullable po.pname then " modelled in " ^ ModelTables.this_file else "" in let description = - Printf.sprintf "call to %s%s%s%s" strict (Typ.Procname.to_simplified_string po.pname) + Printf.sprintf "call to %s%s%s%s" strict + (Typ.Procname.to_simplified_string po.pname) modelled_in (atline po.loc) in Some (description, Some po.loc, Some po.annotated_signature) - | New | ONone | Undef - -> None + | New | ONone | Undef -> + None + let join o1 o2 = match (o1, o2) with (* left priority *) - | Undef, _ | _, Undef - -> Undef - | Field _, (Const _ | Formal _ | Proc _ | New) - -> (* low priority to Field, to support field initialization patterns *) + | Undef, _ | _, Undef -> + Undef + | Field _, (Const _ | Formal _ | Proc _ | New) -> + (* low priority to Field, to support field initialization patterns *) o2 - | _ - -> o1 + | _ -> + o1 + diff --git a/infer/src/eradicate/typeState.ml b/infer/src/eradicate/typeState.ml index e0c512348..f6aba82e2 100644 --- a/infer/src/eradicate/typeState.ml +++ b/infer/src/eradicate/typeState.ml @@ -35,6 +35,7 @@ let unit_ext : unit ext = ; join= (fun () () -> ()) ; pp= (fun _ () -> ()) } + module M = Caml.Map.Make (struct type t = Exp.t @@ -63,6 +64,7 @@ let pp ext fmt typestate = let pp_map map = M.iter pp_one map in pp_map typestate.map ; ext.pp fmt typestate.extension + let type_join typ1 typ2 = if PatternMatch.type_is_object typ1 then typ2 else typ1 let locs_join locs1 locs2 = IList.merge_sorted_nodup Location.compare [] locs1 locs2 @@ -72,6 +74,7 @@ let range_add_locs (typ, ta, locs1) locs2 = let locs' = locs_join locs1 locs2 in (typ, ta, locs') + (** Only keep variables if they are present on both sides of the join. *) let only_keep_intersection = true @@ -81,10 +84,10 @@ let map_join m1 m2 = let tjoined = ref (if only_keep_intersection then M.empty else m1) in let range_join (typ1, ta1, locs1) (typ2, ta2, locs2) = match TypeAnnotation.join ta1 ta2 with - | None - -> None - | Some ta' - -> let typ' = type_join typ1 typ2 in + | None -> + None + | Some ta' -> + let typ' = type_join typ1 typ2 in let locs' = locs_join locs1 locs2 in Some (typ', ta', locs') in @@ -93,10 +96,10 @@ let map_join m1 m2 = try let range1 = M.find exp2 m1 in match range_join range1 range2 with - | None - -> if only_keep_intersection then tjoined := M.add exp2 range1 !tjoined - | Some range' - -> tjoined := M.add exp2 range' !tjoined + | None -> + if only_keep_intersection then tjoined := M.add exp2 range1 !tjoined + | Some range' -> + tjoined := M.add exp2 range' !tjoined with Not_found -> if not only_keep_intersection then tjoined := M.add exp2 range2 !tjoined in let missing_rhs exp1 range1 = @@ -112,6 +115,7 @@ let map_join m1 m2 = in if phys_equal m1 m2 then m1 else ( M.iter extend_lhs m2 ; M.iter missing_rhs m1 ; !tjoined ) + let join ext t1 t2 = let tjoin = {map= map_join t1.map t2.map; extension= ext.join t1.extension t2.extension} in ( if Config.write_html then @@ -122,26 +126,32 @@ let join ext t1 t2 = L.d_strln s ) ; tjoin + let lookup_id id typestate = try Some (M.find (Exp.Var id) typestate.map) with Not_found -> None + let lookup_pvar pvar typestate = try Some (M.find (Exp.Lvar pvar) typestate.map) with Not_found -> None + let add_id id range typestate = let map' = M.add (Exp.Var id) range typestate.map in if phys_equal map' typestate.map then typestate else {typestate with map= map'} + let add pvar range typestate = let map' = M.add (Exp.Lvar pvar) range typestate.map in if phys_equal map' typestate.map then typestate else {typestate with map= map'} + let remove_id id typestate = let map' = M.remove (Exp.Var id) typestate.map in if phys_equal map' typestate.map then typestate else {typestate with map= map'} + let get_extension typestate = typestate.extension let set_extension typestate extension = {typestate with extension} diff --git a/infer/src/harness/androidFramework.ml b/infer/src/harness/androidFramework.ml index c0b2ffddd..c09ad31c2 100644 --- a/infer/src/harness/androidFramework.ml +++ b/infer/src/harness/androidFramework.ml @@ -22,11 +22,12 @@ let drawable_prefix = "R$drawable" (** return true if [pname] is a special lifecycle cleanup method *) let is_destroy_method pname = match pname with - | Typ.Procname.Java pname_java - -> let method_name = Typ.Procname.java_get_method pname_java in + | Typ.Procname.Java pname_java -> + let method_name = Typ.Procname.java_get_method pname_java in String.equal method_name on_destroy || String.equal method_name on_destroy_view - | _ - -> false + | _ -> + false + let android_lifecycles = let android_content = "android.content" in @@ -68,11 +69,13 @@ let android_lifecycles = ; (android_content, "BroadcastReceiever", ["onReceive"]) ; (android_app, "Fragment", fragment_lifecycle) ; (* this is the pre-Android 3.0 Fragment type (can also be used post-3.0) *) - ("android.support.v4.app", "Fragment", fragment_lifecycle) ] + ("android.support.v4.app", "Fragment", fragment_lifecycle) ] + let is_subtype_package_class tenv tname package classname = PatternMatch.is_subtype tenv tname (Typ.Name.Java.from_package_class package classname) + let is_autocloseable tenv tname = is_subtype_package_class tenv tname "java.lang" "AutoCloseable" let is_context tenv tname = is_subtype_package_class tenv tname "android.content" "Context" @@ -87,25 +90,27 @@ let is_fragment tenv tname = is_subtype_package_class tenv tname "android.app" "Fragment" || is_subtype_package_class tenv tname "android.support.v4.app" "Fragment" + (** return true if [class_name] is the name of a class that belong to the Android framework *) let is_android_lib_class class_name = let class_str = Typ.Name.name class_name in String.is_prefix ~prefix:"android" class_str || String.is_prefix ~prefix:"com.android" class_str + (** given an Android framework type mangled string [lifecycle_typ] (e.g., android.app.Activity) and a list of method names [lifecycle_procs_strs], get the appropriate typ and procnames *) let get_lifecycle_for_framework_typ_opt tenv lifecycle_typ lifecycle_proc_strs = match Tenv.lookup tenv lifecycle_typ with - | Some {methods} - -> (* TODO (t4645631): collect the procedures for which is_java is returning false *) + | Some {methods} -> + (* TODO (t4645631): collect the procedures for which is_java is returning false *) let lookup_proc lifecycle_proc = List.find_exn ~f:(fun decl_proc -> match decl_proc with - | Typ.Procname.Java decl_proc_java - -> String.equal lifecycle_proc (Typ.Procname.java_get_method decl_proc_java) - | _ - -> false) + | Typ.Procname.Java decl_proc_java -> + String.equal lifecycle_proc (Typ.Procname.java_get_method decl_proc_java) + | _ -> + false) methods in (* convert each of the framework lifecycle proc strings to a lifecycle method procname *) @@ -117,8 +122,9 @@ let get_lifecycle_for_framework_typ_opt tenv lifecycle_typ lifecycle_proc_strs = ~init:[] lifecycle_proc_strs in lifecycle_procs - | _ - -> [] + | _ -> + [] + (** return the complete list of (package, lifecycle_classname, lifecycle_methods) trios *) let get_lifecycles = android_lifecycles diff --git a/infer/src/harness/harness.ml b/infer/src/harness/harness.ml index 2a4757831..f58120987 100644 --- a/infer/src/harness/harness.ml +++ b/infer/src/harness/harness.ml @@ -17,8 +17,8 @@ module F = Format constituting a lifecycle trace *) let try_create_lifecycle_trace name lifecycle_name lifecycle_procs tenv = match name with - | Typ.JavaClass _ - -> if PatternMatch.is_subtype tenv name lifecycle_name + | Typ.JavaClass _ -> + if PatternMatch.is_subtype tenv name lifecycle_name && not (AndroidFramework.is_android_lib_class name) then let ptr_to_struct_typ = Some (Typ.mk (Tptr (Typ.mk (Tstruct name), Pk_pointer))) in @@ -30,8 +30,9 @@ let try_create_lifecycle_trace name lifecycle_name lifecycle_procs tenv = (resolved_proc, ptr_to_struct_typ) :: trace) ~init:[] lifecycle_procs else [] - | _ - -> [] + | _ -> + [] + (** generate a harness for a lifecycle type in an Android application *) let create_harness cfg cg tenv = @@ -48,22 +49,24 @@ let create_harness cfg cg tenv = Tenv.iter (fun name _ -> match try_create_lifecycle_trace name typname framework_procs tenv with - | [] - -> () - | lifecycle_trace - -> let harness_procname = + | [] -> + () + | lifecycle_trace -> + let harness_procname = let harness_cls_name = Typ.Name.name name in let pname = Typ.Procname.Java - (Typ.Procname.java (Typ.Name.Java.from_string harness_cls_name) None - "InferGeneratedHarness" [] Typ.Procname.Static) + (Typ.Procname.java + (Typ.Name.Java.from_string harness_cls_name) + None "InferGeneratedHarness" [] Typ.Procname.Static) in match pname with - | Typ.Procname.Java harness_procname - -> harness_procname - | _ - -> assert false + | Typ.Procname.Java harness_procname -> + harness_procname + | _ -> + assert false in Inhabit.inhabit_trace tenv lifecycle_trace harness_procname cg cfg) tenv) AndroidFramework.get_lifecycles + diff --git a/infer/src/harness/inhabit.ml b/infer/src/harness/inhabit.ml index 9e32de966..73b7f48ff 100644 --- a/infer/src/harness/inhabit.ml +++ b/infer/src/harness/inhabit.ml @@ -37,14 +37,17 @@ let procdesc_from_name cfg pname = if Typ.Procname.equal cfg_pname pname then pdesc_ref := Some pdesc ) ; !pdesc_ref + let formals_from_name cfg pname = match procdesc_from_name cfg pname with Some pdesc -> Procdesc.get_formals pdesc | None -> [] + (** add an instruction to the env, update tmp_vars, and bump the pc *) let env_add_instr instr env = let incr_pc pc = {pc with Location.line= pc.Location.line + 1} in {env with instrs= instr :: env.instrs; pc= incr_pc env.pc} + (** call flags for an allocation or call to a constructor *) let cf_alloc = CallFlags.default @@ -56,6 +59,7 @@ let create_fresh_local_name () = incr local_name_cntr ; "dummy_local" ^ string_of_int !local_name_cntr + (** more forgiving variation of List.tl that won't raise an exception on the empty list *) let tl_or_empty l = if List.is_empty l then l else List.tl_exn l @@ -77,6 +81,7 @@ let inhabit_alloc sizeof_typ sizeof_len ret_typ alloc_kind env = in (inhabited_exp, env_add_instr call_instr env) + (* TODO: this should be done in a differnt way: just make typ a param of the harness procedure *) (** find or create a Sil expression with type typ *) @@ -85,12 +90,12 @@ let rec inhabit_typ tenv typ cfg env = with Not_found -> let inhabit_internal typ env = match typ.Typ.desc with - | Typ.Tptr ({desc= Tarray (inner_typ, Some _, _)}, Typ.Pk_pointer) - -> let len = Exp.Const (Const.Cint IntLit.one) in + | Typ.Tptr ({desc= Tarray (inner_typ, Some _, _)}, Typ.Pk_pointer) -> + let len = Exp.Const (Const.Cint IntLit.one) in let arr_typ = Typ.mk (Tarray (inner_typ, Some IntLit.one, None)) in inhabit_alloc arr_typ (Some len) typ BuiltinDecl.__new_array env - | Typ.Tptr (typ, Typ.Pk_pointer) - -> (* TODO (t4575417): this case does not work correctly for enums, but they are currently + | Typ.Tptr (typ, Typ.Pk_pointer) -> + (* TODO (t4575417): this case does not work correctly for enums, but they are currently * broken in Infer anyway (see t4592290) *) let allocated_obj_exp, env = inhabit_alloc typ None typ BuiltinDecl.__new env in (* select methods that are constructors and won't force us into infinite recursion because @@ -99,8 +104,8 @@ let rec inhabit_typ tenv typ cfg env = match typ.desc with | Tstruct name when Typ.Name.is_class name -> ( match Tenv.lookup tenv name with - | Some {methods} - -> let is_suitable_constructor p = + | Some {methods} -> + let is_suitable_constructor p = let try_get_non_receiver_formals p = get_non_receiver_formals (formals_from_name cfg p) in @@ -110,29 +115,29 @@ let rec inhabit_typ tenv typ cfg env = (try_get_non_receiver_formals p) in List.filter ~f:(fun p -> is_suitable_constructor p) methods - | _ - -> [] ) - | _ - -> [] + | _ -> + [] ) + | _ -> + [] in let env, typ_class_name = match get_all_suitable_constructors typ with - | constructor :: _ - -> (* arbitrarily choose a constructor for typ and invoke it. eventually, we may want to + | constructor :: _ -> + (* arbitrarily choose a constructor for typ and invoke it. eventually, we may want to * nondeterministically call all possible constructors instead *) let env = inhabit_constructor tenv constructor (allocated_obj_exp, typ) cfg env in (* try to get the unqualified name as a class (e.g., Object for java.lang.Object so we * we can use it as a descriptive local variable name in the harness *) let typ_class_name = match constructor with - | Typ.Procname.Java pname_java - -> Typ.Procname.java_get_simple_class_name pname_java - | _ - -> create_fresh_local_name () + | Typ.Procname.Java pname_java -> + Typ.Procname.java_get_simple_class_name pname_java + | _ -> + create_fresh_local_name () in (env, Mangled.from_string typ_class_name) - | [] - -> (env, Mangled.from_string (create_fresh_local_name ())) + | [] -> + (env, Mangled.from_string (create_fresh_local_name ())) in (* add the instructions *& local = [allocated_obj_exp]; id = *& local, where local and id are * both fresh. the only point of this is to add a descriptive local name that makes error @@ -145,12 +150,12 @@ let rec inhabit_typ tenv typ cfg env = let fresh_id = Ident.create_fresh Ident.knormal in let read_from_local_instr = Sil.Load (fresh_id, fresh_local_exp, typ, env'.pc) in (Exp.Var fresh_id, env_add_instr read_from_local_instr env') - | Typ.Tint _ - -> (Exp.Const (Const.Cint IntLit.zero), env) - | Typ.Tfloat _ - -> (Exp.Const (Const.Cfloat 0.0), env) - | _ - -> L.die InternalError "Couldn't inhabit typ: %a" (Typ.pp Pp.text) typ + | Typ.Tint _ -> + (Exp.Const (Const.Cint IntLit.zero), env) + | Typ.Tfloat _ -> + (Exp.Const (Const.Cfloat 0.0), env) + | _ -> + L.die InternalError "Couldn't inhabit typ: %a" (Typ.pp Pp.text) typ in let inhabited_exp, env' = inhabit_internal typ {env with cur_inhabiting= TypSet.add typ env.cur_inhabiting} @@ -159,6 +164,7 @@ let rec inhabit_typ tenv typ cfg env = , {env' with cache= TypMap.add typ inhabited_exp env.cache; cur_inhabiting= env.cur_inhabiting} ) + (** inhabit each of the types in the formals list *) and inhabit_args tenv formals cfg env = let inhabit_arg (_, formal_typ) (args, env) = @@ -167,6 +173,7 @@ and inhabit_args tenv formals cfg env = in List.fold_right ~f:inhabit_arg formals ~init:([], env) + (** create Sil that calls the constructor in constr_name on allocated_obj and inhabits the * remaining arguments *) and inhabit_constructor tenv constr_name (allocated_obj, obj_type) cfg env = @@ -184,6 +191,7 @@ and inhabit_constructor tenv constr_name (allocated_obj, obj_type) cfg env = env_add_instr constr_instr env with Not_found -> env + let inhabit_call_with_args procname procdesc args env = let retval = let ret_typ = Procdesc.get_ret_type procdesc in @@ -199,29 +207,31 @@ let inhabit_call_with_args procname procdesc args env = in env_add_instr call_instr env + (** create Sil that inhabits args to and calls proc_name *) let inhabit_call tenv (procname, receiver) cfg env = try match procdesc_from_name cfg procname with - | Some procdesc - -> (* swap the type of the 'this' formal with the receiver type, if there is one *) + | Some procdesc -> + (* swap the type of the 'this' formal with the receiver type, if there is one *) let formals = match (Procdesc.get_formals procdesc, receiver) with - | (name, _) :: formals, Some receiver - -> (name, receiver) :: formals - | formals, None - -> formals - | [], Some _ - -> L.(die InternalError) + | (name, _) :: formals, Some receiver -> + (name, receiver) :: formals + | formals, None -> + formals + | [], Some _ -> + L.(die InternalError) "Expected at least one formal to bind receiver to in method %a" Typ.Procname.pp procname in let args, env = inhabit_args tenv formals cfg env in inhabit_call_with_args procname procdesc args env - | None - -> env + | None -> + env with Not_found -> env + (** create a dummy file for the harness and associate them in the exe_env *) let create_dummy_harness_filename harness_name = let dummy_file_dir = Filename.temp_dir_name in @@ -231,6 +241,7 @@ let create_dummy_harness_filename harness_name = in Filename.concat dummy_file_dir file_str + (* TODO (t3040429): fill this file up with Java-like code that matches the SIL *) (** write the SIL for the harness to a file *) @@ -243,6 +254,7 @@ let write_harness_to_file harness_instrs harness_file_name = in Utils.do_outf harness_file (fun outf -> pp_harness outf.fmt ; Utils.close_outf outf) + (** add the harness proc to the cg and make sure its callees can be looked up by sym execution *) let add_harness_to_cg harness_name harness_node cg = Cg.add_defined_node cg (Typ.Procname.Java harness_name) ; @@ -250,6 +262,7 @@ let add_harness_to_cg harness_name harness_node cg = ~f:(fun p -> Cg.add_edge cg (Typ.Procname.Java harness_name) p) (Procdesc.Node.get_callees harness_node) + (** create and fill the appropriate nodes and add them to the harness cfg. also add the harness * proc to the cg *) let setup_harness_cfg harness_name env cg cfg = @@ -280,6 +293,7 @@ let setup_harness_cfg harness_name env cg cfg = Procdesc.node_set_succs_exn procdesc harness_node [exit_node] [exit_node] ; add_harness_to_cg harness_name harness_node cg + (** create a procedure named harness_name that calls each of the methods in trace in the specified * order with the specified receiver and add it to the execution environment *) let inhabit_trace tenv trace harness_name cg cfg = @@ -299,3 +313,4 @@ let inhabit_trace tenv trace harness_name cg cfg = setup_harness_cfg harness_name env'' cg cfg ; write_harness_to_file (List.rev env''.instrs) harness_filename with Not_found -> () + diff --git a/infer/src/integration/Buck.ml b/infer/src/integration/Buck.ml index 10b3d758c..87b58a352 100644 --- a/infer/src/integration/Buck.ml +++ b/infer/src/integration/Buck.ml @@ -14,27 +14,31 @@ type target = {name: string; flavors: string list} let target_of_string target = match String.split target ~on:'#' with - | [name; flavors_string] - -> let flavors = String.split flavors_string ~on:',' in + | [name; flavors_string] -> + let flavors = String.split flavors_string ~on:',' in {name; flavors} - | [name] - -> {name; flavors= []} - | _ - -> L.(die ExternalError) "cannot parse target %s" target + | [name] -> + {name; flavors= []} + | _ -> + L.(die ExternalError) "cannot parse target %s" target + let string_of_target {name; flavors} = let pp_string fmt s = Format.fprintf fmt "%s" s in Format.asprintf "%s#%a" name (Pp.comma_seq pp_string) flavors + let is_target_string = let target_regexp = Str.regexp "[^/]*//[^/]+.*:.*" in fun s -> Str.string_match target_regexp s 0 + let no_targets_found_error_and_exit buck_cmd = Process.print_error_and_exit "No targets found in Buck command %s.@\nOnly fully qualified Buck targets are supported. In particular, aliases are not allowed.@." (String.concat ~sep:" " buck_cmd) + let add_flavor_to_target target = let add flavor = if List.mem ~equal:String.equal target.flavors flavor then @@ -43,17 +47,18 @@ let add_flavor_to_target target = else {target with flavors= flavor :: target.flavors} in match (Config.buck_compilation_database, Config.analyzer) with - | Some _, _ - -> add "compilation-database" - | None, CompileOnly - -> target - | None, (BiAbduction | CaptureOnly | Checkers | Linters) - -> add "infer-capture-all" - | None, Crashcontext - -> L.(die UserError) + | Some _, _ -> + add "compilation-database" + | None, CompileOnly -> + target + | None, (BiAbduction | CaptureOnly | Checkers | Linters) -> + add "infer-capture-all" + | None, Crashcontext -> + L.(die UserError) "Analyzer %s is Java-only; not supported with Buck flavors" (Config.string_of_analyzer Config.analyzer) + let add_flavors_to_buck_command build_cmd = let add_infer_if_target s (cmd, found_one_target) = if not (is_target_string s) then (s :: cmd, found_one_target) @@ -65,34 +70,36 @@ let add_flavors_to_buck_command build_cmd = if not found_one_target then no_targets_found_error_and_exit build_cmd ; cmd' + let get_dependency_targets_and_add_flavors targets ~depth = let build_deps_string targets = List.map targets ~f:(fun target -> match depth with - | None (* full depth *) - -> Printf.sprintf "deps('%s')" target - | Some n - -> Printf.sprintf "deps('%s', %d)" target n ) + | None (* full depth *) -> + Printf.sprintf "deps('%s')" target + | Some n -> + Printf.sprintf "deps('%s', %d)" target n ) |> String.concat ~sep:" union " in let buck_query = [ "buck" ; "query" - ; ( "\"kind('(apple_binary|apple_library|apple_test|cxx_binary|cxx_library|cxx_test)', " - ^ build_deps_string targets ^ ")\"" ) ] + ; "\"kind('(apple_binary|apple_library|apple_test|cxx_binary|cxx_library|cxx_test)', " + ^ build_deps_string targets ^ ")\"" ] in let buck_query_cmd = String.concat buck_query ~sep:" " in Logging.(debug Linters Quiet) "*** Executing command:@\n*** %s@." buck_query_cmd ; let output, exit_or_signal = Utils.with_process_in buck_query_cmd In_channel.input_lines in match exit_or_signal with - | Error _ as status - -> Logging.(die ExternalError) + | Error _ as status -> + Logging.(die ExternalError) "*** command failed:@\n*** %s@\n*** %s@." buck_query_cmd (Unix.Exit_or_signal.to_string_hum status) - | Ok () - -> List.map output ~f:(fun name -> + | Ok () -> + List.map output ~f:(fun name -> string_of_target (add_flavor_to_target {name; flavors= Config.append_buck_flavors}) ) + (** Given a list of arguments return the extended list of arguments where the args in a file have been extracted *) let inline_argument_files buck_args = @@ -112,9 +119,11 @@ let inline_argument_files buck_args = in List.concat_map ~f:expand_buck_arg buck_args + let store_targets_in_file buck_targets = let file = Filename.temp_file "buck_targets_" ".txt" in let write_args outc = Out_channel.output_string outc (String.concat ~sep:"\n" buck_targets) in Utils.with_file_out file ~f:write_args |> ignore ; L.(debug Capture Quiet) "Buck targets options stored in file '%s'@\n" file ; Printf.sprintf "@%s" file + diff --git a/infer/src/integration/CaptureCompilationDatabase.ml b/infer/src/integration/CaptureCompilationDatabase.ml index bf4bdf88b..c9e1fd50d 100644 --- a/infer/src/integration/CaptureCompilationDatabase.ml +++ b/infer/src/integration/CaptureCompilationDatabase.ml @@ -24,6 +24,7 @@ let create_cmd (compilation_data: CompilationDatabase.compilation_data) = in {cwd= compilation_data.dir; prog= swap_command compilation_data.command; args= arg_file} + (* A sentinel is a file which indicates that a failure occurred in another infer process. Because infer processes run in parallel but do not share any memory, we use the filesystem to signal failures across processes. *) @@ -31,6 +32,7 @@ let sentinel_exists sentinel_opt = let file_exists sentinel = PVariant.( = ) (Sys.file_exists sentinel) `Yes in Option.value_map ~default:false sentinel_opt ~f:file_exists + let invoke_cmd ~fail_sentinel cmd = let create_sentinel_if_needed () = let create_empty_file fname = Utils.with_file_out ~f:(fun _ -> ()) fname in @@ -41,20 +43,21 @@ let invoke_cmd ~fail_sentinel cmd = try let pid = let prog = cmd.prog in - let argv = [prog; ("@" ^ cmd.args); "-fsyntax-only"] in + let argv = [prog; "@" ^ cmd.args; "-fsyntax-only"] in Spawn.(spawn ~cwd:(Path cmd.cwd) ~prog ~argv ()) in match Unix.waitpid (Pid.of_int pid) with - | Ok () - -> L.progress ".%!" - | Error _ - -> L.progress "!%!" ; create_sentinel_if_needed () + | Ok () -> + L.progress ".%!" + | Error _ -> + L.progress "!%!" ; create_sentinel_if_needed () with exn -> let trace = Printexc.get_backtrace () in L.external_error "@\nException caught:@\n%a.@\n%s@\n" Exn.pp exn trace ; L.progress "X%!" ; create_sentinel_if_needed () + let run_compilation_database compilation_database should_capture_file = let compilation_data = CompilationDatabase.filter_compilation_data compilation_database ~f:should_capture_file @@ -71,10 +74,10 @@ let run_compilation_database compilation_database should_capture_file = if Config.linters_ignore_clang_failures then None else match Config.buck_compilation_database with - | Some NoDeps when Config.clang_frontend_do_lint - -> Some fail_sentinel_fname - | Some NoDeps | Some Deps _ | None - -> None + | Some NoDeps when Config.clang_frontend_do_lint -> + Some fail_sentinel_fname + | Some NoDeps | Some Deps _ | None -> + None in Utils.rmtree fail_sentinel_fname ; let chunksize = min (List.length compilation_data / Config.jobs + 1) 10 in @@ -86,24 +89,26 @@ let run_compilation_database compilation_database should_capture_file = "Failure detected, capture did not finish successfully. Use `--linters-ignore-clang-failures` to ignore compilation errors. Terminating@." ; L.exit 1 ) + (** Computes the compilation database files. *) let get_compilation_database_files_buck ~prog ~args = let all_buck_args = Buck.inline_argument_files args in let targets, no_targets = List.partition_tf ~f:Buck.is_target_string all_buck_args in let targets = match Config.buck_compilation_database with - | Some Deps depth - -> Buck.get_dependency_targets_and_add_flavors targets ~depth - | _ - -> Buck.add_flavors_to_buck_command targets + | Some Deps depth -> + Buck.get_dependency_targets_and_add_flavors targets ~depth + | _ -> + Buck.add_flavors_to_buck_command targets in match no_targets with | "build" :: no_targets_no_build - -> ( + -> ( let targets_in_file = Buck.store_targets_in_file targets in let build_args = no_targets @ ["--config"; "*//cxx.pch_enabled=false"; targets_in_file] in Logging.(debug Linters Quiet) - "Processed buck command is : 'buck %s'@\n" (String.concat ~sep:" " build_args) ; + "Processed buck command is : 'buck %s'@\n" + (String.concat ~sep:" " build_args) ; Process.create_process_and_wait ~prog ~args:build_args ; let buck_targets_shell = List.append [prog; "targets"; "--show-output"; targets_in_file] no_targets_no_build @@ -113,33 +118,35 @@ let get_compilation_database_files_buck ~prog ~args = Utils.with_process_in buck_targets_shell In_channel.input_lines in match exit_or_signal with - | Error _ as status - -> L.(die ExternalError) + | Error _ as status -> + L.(die ExternalError) "*** command failed:@\n*** %s@\n*** %s@." buck_targets_shell (Unix.Exit_or_signal.to_string_hum status) | Ok () -> match output with - | [] - -> L.external_error "There are no files to process, exiting@." ; L.exit 0 - | lines - -> L.(debug Capture Quiet) + | [] -> + L.external_error "There are no files to process, exiting@." ; + L.exit 0 + | lines -> + L.(debug Capture Quiet) "Reading compilation database from:@\n%s@\n" (String.concat ~sep:"\n" lines) ; (* this assumes that flavors do not contain spaces *) let split_regex = Str.regexp "#[^ ]* " in let scan_output compilation_database_files line = match Str.bounded_split split_regex line 2 with - | [_; filename] - -> `Raw filename :: compilation_database_files - | _ - -> L.(die ExternalError) + | [_; filename] -> + `Raw filename :: compilation_database_files + | _ -> + L.(die ExternalError) "Failed to parse `buck targets --show-output ...` line of output:@\n%s" line in List.fold ~f:scan_output ~init:[] lines ) - | _ - -> let cmd = String.concat ~sep:" " (prog :: args) in + | _ -> + let cmd = String.concat ~sep:" " (prog :: args) in Process.print_error_and_exit "Incorrect buck command: %s. Please use buck build " cmd + (** Compute the compilation database files. *) let get_compilation_database_files_xcodebuild ~prog ~args = let tmp_file = Filename.temp_file "cdb" ".json" in @@ -149,27 +156,31 @@ let get_compilation_database_files_xcodebuild ~prog ~args = [xcpretty_prog; "--report"; "json-compilation-database"; "--output"; tmp_file] in L.(debug Capture Quiet) - "Running %s | %s@\n@." (List.to_string ~f:Fn.id xcodebuild_args) + "Running %s | %s@\n@." + (List.to_string ~f:Fn.id xcodebuild_args) (List.to_string ~f:Fn.id xcpretty_args) ; let producer_status, consumer_status = Process.pipeline ~producer_prog:xcodebuild_prog ~producer_args:xcodebuild_args ~consumer_prog:xcpretty_prog ~consumer_args:xcpretty_args in match (producer_status, consumer_status) with - | Ok (), Ok () - -> [`Escaped tmp_file] - | _ - -> L.(die ExternalError) "There was an error executing the build command" + | Ok (), Ok () -> + [`Escaped tmp_file] + | _ -> + L.(die ExternalError) "There was an error executing the build command" + let capture_files_in_database ~changed_files compilation_database = let filter_changed = match changed_files with - | None - -> fun _ -> true - | Some changed_files_set - -> fun source_file -> SourceFile.Set.mem source_file changed_files_set + | None -> + fun _ -> true + | Some changed_files_set -> + fun source_file -> SourceFile.Set.mem source_file changed_files_set in run_compilation_database compilation_database filter_changed + let capture_file_in_database compilation_database source_file = run_compilation_database compilation_database (SourceFile.equal source_file) + diff --git a/infer/src/integration/Clang.ml b/infer/src/integration/Clang.ml index 4d371cae6..ecdd1a3f4 100644 --- a/infer/src/integration/Clang.ml +++ b/infer/src/integration/Clang.ml @@ -13,12 +13,13 @@ module L = Logging type compiler = Clang | Make [@@deriving compare] let rec pp_list pp fmt = function - | [] - -> () - | [x] - -> pp fmt x - | x :: tl - -> F.fprintf fmt "%a@\n%a" pp x (pp_list pp) tl + | [] -> + () + | [x] -> + pp fmt x + | x :: tl -> + F.fprintf fmt "%a@\n%a" pp x (pp_list pp) tl + let pp_env fmt env = pp_list (fun fmt s -> F.fprintf fmt "%s" s) fmt env @@ -26,39 +27,41 @@ let pp_extended_env fmt (env: Unix.env) = let pp_pair fmt (var, value) = F.fprintf fmt "%s=%s" var value in let pp_pair_list = pp_list pp_pair in match env with - | `Replace values - -> pp_pair_list fmt values - | `Extend values - -> let is_extended s = + | `Replace values -> + pp_pair_list fmt values + | `Extend values -> + let is_extended s = match String.lsplit2 s ~on:'=' with - | Some (var, _) - -> List.exists ~f:(fun (var', _) -> String.equal var var') values - | None - -> false + | Some (var, _) -> + List.exists ~f:(fun (var', _) -> String.equal var var') values + | None -> + false in let env_not_extended = Unix.environment () |> Array.to_list |> List.filter ~f:(Fn.non is_extended) in F.fprintf fmt "%a@\n%a" pp_env env_not_extended pp_pair_list values - | `Replace_raw values - -> pp_env fmt values + | `Replace_raw values -> + pp_env fmt values + let capture compiler ~prog ~args = match compiler with - | Clang - -> ClangWrapper.exe ~prog ~args - | Make - -> let path_var = "PATH" in + | Clang -> + ClangWrapper.exe ~prog ~args + | Make -> + let path_var = "PATH" in let old_path = Option.value ~default:"" (Sys.getenv path_var) in let new_path = Config.wrappers_dir ^ ":" ^ old_path in let extended_env = `Extend [(path_var, new_path); ("INFER_OLD_PATH", old_path)] in L.environment_info "Running command %s with env:@\n%a@\n@." prog pp_extended_env extended_env ; Unix.fork_exec ~prog ~argv:(prog :: args) ~env:extended_env () |> Unix.waitpid |> function - | Ok () - -> () - | Error _ as status - -> L.(die ExternalError) + | Ok () -> + () + | Error _ as status -> + L.(die ExternalError) "*** capture command failed:@\n*** %s@\n*** %s@." (String.concat ~sep:" " (prog :: args)) (Unix.Exit_or_signal.to_string_hum status) + diff --git a/infer/src/integration/ClangQuotes.ml b/infer/src/integration/ClangQuotes.ml index 4bfcfdd26..c9944948d 100644 --- a/infer/src/integration/ClangQuotes.ml +++ b/infer/src/integration/ClangQuotes.ml @@ -21,14 +21,15 @@ type style = let quote style = match style with - | EscapedNoQuotes - -> fun s -> s - | EscapedDoubleQuotes - -> fun s -> "\"" ^ s ^ "\"" - | SingleQuotes - -> let map = function '\'' -> Some "\\'" | '\\' -> Some "\\\\" | _ -> None in + | EscapedNoQuotes -> + fun s -> s + | EscapedDoubleQuotes -> + fun s -> "\"" ^ s ^ "\"" + | SingleQuotes -> + let map = function '\'' -> Some "\\'" | '\\' -> Some "\\\\" | _ -> None in fun s -> "'" ^ Escape.escape_map map s ^ "'" + let mk_arg_file prefix style args = let file = Filename.temp_file prefix ".txt" in let write_args outc = @@ -37,3 +38,4 @@ let mk_arg_file prefix style args = Utils.with_file_out file ~f:write_args |> ignore ; L.(debug Capture Medium) "Clang options stored in file %s@\n" file ; file + diff --git a/infer/src/integration/CompilationDatabase.ml b/infer/src/integration/CompilationDatabase.ml index 2ff752739..4e53a9958 100644 --- a/infer/src/integration/CompilationDatabase.ml +++ b/infer/src/integration/CompilationDatabase.ml @@ -23,6 +23,7 @@ let iter database f = SourceFile.Map.iter f !database let filter_compilation_data database ~f = SourceFile.Map.filter (fun s _ -> f s) !database |> SourceFile.Map.bindings |> List.map ~f:snd + let find database key = SourceFile.Map.find key !database let parse_command_and_arguments command_and_arguments = @@ -32,22 +33,21 @@ let parse_command_and_arguments command_and_arguments = let arguments = Str.string_after command_and_arguments (index + 1) in (command, arguments) + (** Parse the compilation database json file into the compilationDatabase map. The json file consists of an array of json objects that contain the file to be compiled, the directory to be compiled in, and the compilation command as a list and as a string. We pack this information into the compilationDatabase map, and remove the clang invocation part, because we will use a clang wrapper. *) let decode_json_file (database: t) json_format = - let json_path = - match json_format - with `Raw x | `Escaped x -> x - in + let json_path = match json_format with `Raw x | `Escaped x -> x in let to_string s = match json_format with - | `Raw _ - -> s - | `Escaped _ - -> Utils.with_process_in (Printf.sprintf "/bin/sh -c 'printf \"%%s\" %s'" s) + | `Raw _ -> + s + | `Escaped _ -> + Utils.with_process_in + (Printf.sprintf "/bin/sh -c 'printf \"%%s\" %s'" s) In_channel.input_line_exn |> fst in @@ -59,10 +59,10 @@ let decode_json_file (database: t) json_format = let get_cmd el = match el with "command", `String cmd -> Some cmd | _ -> None in let rec parse_json json = match json with - | `List arguments - -> List.iter ~f:parse_json arguments - | `Assoc l - -> let dir = + | `List arguments -> + List.iter ~f:parse_json arguments + | `Assoc l -> + let dir = match List.find_map ~f:get_dir l with Some dir -> dir | None -> exit_format_error () in let file = @@ -76,13 +76,15 @@ let decode_json_file (database: t) json_format = let abs_file = if Filename.is_relative file then dir ^/ file else file in let source_file = SourceFile.from_abs_path abs_file in database := SourceFile.Map.add source_file compilation_data !database - | _ - -> exit_format_error () + | _ -> + exit_format_error () in parse_json json + let from_json_files db_json_files = let db = empty () in List.iter ~f:(decode_json_file db) db_json_files ; L.(debug Capture Quiet) "created database with %d entries@\n" (get_size db) ; db + diff --git a/infer/src/integration/Diff.ml b/infer/src/integration/Diff.ml index 3838f52b6..f3ef6a0f1 100644 --- a/infer/src/integration/Diff.ml +++ b/infer/src/integration/Diff.ml @@ -19,43 +19,47 @@ let pp_revision f r = F.fprintf f "%s" (string_of_revision r) let checkout revision = let script_opt = match revision with - | Current - -> Config.previous_to_current_script - | Previous - -> Config.current_to_previous_script + | Current -> + Config.previous_to_current_script + | Previous -> + Config.current_to_previous_script in match script_opt with - | None - -> L.(die UserError) + | None -> + L.(die UserError) "Please specify a script to checkout the %a revision of your project using --checkout-%a