From 7021c53d4ecf97c82ccebb6bb45f5305d8b482ea Mon Sep 17 00:00:00 2001 From: ckeller Date: Mon, 28 Jan 2019 23:19:12 +0100 Subject: Merge from LFSC (#26) * Showing models as coq counter examples in tactic without constructing coq terms * also read models when calling cvc4 with a file (deactivated because cvc4 crashes) * Show counter examples with variables in the order they are quantified in the Coq goal * Circumvent issue with ocamldep * fix issue with dependencies * fix issue with dependencies * Translation and OCaml support for extract, zero_extend, sign_extend * Show run times of components * print time on stdout instead * Tests now work with new version (master) of CVC4 * fix small printing issue * look for date on mac os x * proof of valid_check_bbShl: some cases to prove. * full proof of "left shift checker". * full proof of "rigth shift checker". * Support translation of terms bvlshr, bvshl but LFSC rules do not exists at the moment Bug fix for bitvector extract (inverted arguments) * Typo * More modularity on the format of traces depending on the version of coq * More straightforward definitions in Int63Native_standard * Use the Int31 library with coq-8.5 * Use the most efficient operations of Int31 * Improved performance with coq-8.5 * Uniform treatment of sat and smt tactics * Hopefully solved the problem with universes for the tactic * Updated the installation instructions * Holes for unsupported bit blasting rules * Cherry-picking from smtcoq/smtcoq * bug fix hole for bitblast * Predefined arrays are not required anymore * fix issue with coq bbT and bitof construction from ocaml * bug fix in smtAtom for uninterpreted functions fix verit test file * fix issue with smtlib2 extract parsing * It looks like we still need the PArray function instances for some examples (see vmcai_bytes.smt2) * Solver specific reification: Each solver has a list of supported theories which is passed to Atom.of_coq, this function creates uninterpreted functions / sorts for unsupported features. * show counter-examples with const_farray instead of const for constant array definitions * Vernacular commands to debug checkers. Verit/Lfsc_Checker_Debug will always fail, reporting the first proof step of the certificate that failed be checked * Update INSTALL.md * show smtcoq proof when converting * (Hopefully) repared the universes problems * Corrected a bug with holes in proofs * scripts for tests: create a folder "work" under "lfsc/tests/", locate the benchmarks there. create a folder "results" under "lfsc/tests/work/" in which you'll find the results of ./cvc4tocoq. * make sure to give correct path for your benchs... * Checker for array extensionality modulo symmetry of equality * fix oversight with bitvectors larger than 63 bits * some printing functions for smt2 ast * handle smtlib2 files with more complicated equivalence with (= ... ) * revert: ./cvc4tocoq does not output lfsc proofs... * bug fix one input was ignored * Don't show verit translation of LFSC proof if environment variable DONTSHOWVERIT is set (e.g. put export DONTSHOWVERIT="" in your .bashrc or .bashprofile) * Also sort names of introduced variables when showing counter-example * input files for which SMTCoq retuns false. * input files for which SMTCoq retuns false. * use debug checker for debug file * More efficient debug checker * better approximate number of failing step of certificate in debug checker * fix mistake in ml4 * very first attempt to support goals in Prop * bvs: comparison predicates in Prop and their <-> proofs with the ones in bool farrays: equality predicate in Prop and its <-> proof with the one in bool. * unit, Bool, Z, Pos: comparison and equality predicates in Prop. * a typo fixed. * an example of array equality in Prop (converted into Bool by hand)... TODO: enhance the search space of cvc4 tactic. * first version of cvc4' tactic: "solves" the goals in Prop. WARNING: supports only bv and array goals and might not be complete TODO: add support for lia goals * cvc4' support for lia WARNING: might not be complete! * small fix in cvc4' and some variations of examples * small fix + support for goals in Bool and Bool = true + use of solve tactical WARNING: does not support UF and INT63 goals in Prop * cvc4': better arrangement * cvc4': Prop2Bool by context search... * cvc4': solve tactial added -> do not modify unsolved goals. * developer documentation for the smtcoq repo * cvc4': rudimentary support for uninterpreted function goals in Prop. * cvc4': support for goals with Leibniz equality... WARNING: necessary use of "Grab Existential Variables." to instantiate variable types for farrays! * cvc4': Z.lt adapted + better support from verit... * cvc4': support for Z.le, Z.ge, Z.gt. * Try arrays with default value (with a constructor for constant arrays), but extensionality is not provable * cvc4': support for equality over uninterpreted types * lfsc demo: goals in Coq's Prop. * lfsc demo: goals in Bool. * Fix issue with existential variables generated by prop2bool. - prop2bool tactic exported by SMTCoq - remove useless stuff * update usage and installation instructions * Update INSTALL.md * highlighting * the tactic: bool2prop. * clean up * the tactic smt: very first version. * smt: return unsolved goals in Prop. * Show when a certificate cannot be checked when running the tactic instead of at Qed * Tactic improvements - Handle negation/True/False in prop/bool conversions tactic. - Remove alias for farray (this caused problem for matching on this type in tactics). - Tactic `smt` that combines cvc4 and veriT. - return subgoals in prop * test change header * smt: support for negated goals + some reorganization. * conflicts resolved + some reorganization. * a way to solve the issue with ambiguous coercions. * reorganization. * small change. * another small change. * developer documentation of the tactics. * developer guide: some improvements. * developer guide: some more improvements. * developer guide: some more improvements. * developer guide: some more improvements. * pass correct environment for conversion + better error messages * cleaning * ReflectFacts added. * re-organizing developers' guide. * re-organizing developers' guide. * re-organizing developers' guide. * removing unused maps. * headers. * artifact readme getting started... * first attempt * second... * third... * 4th... * 5th... * 6th... * 7th... * 8th... * 9th... * 10th... * 11th... * 12th... * 13th... * 14th... * 15th... * 16th... * 17th... * Update artifact.md Use links to lfsc repository like in the paper * 18th... * 19th... * 20th... * 21st... * 22nd... * 23rd... * 24th... * 25th... * 26th... * 27th... * 28th... * Update artifact.md Small reorganization * minor edits * More minor edits * revised description of tactics * Final pass * typo * name changed: artifact-readme.md * file added... * passwd chaged... * links... * removal * performance statement... * typos... * the link to the artifact image updated... * suggestions by Guy... * aux files removed... * clean-up... * clean-up... * some small changes... * small fix... * additional information on newly created files after running cvc4tocoq script... * some small fix... * another small fix... * typo... * small fix... * another small fix... * fix... * link to the artifact image... * We do not want to force vm_cast for the Theorem commands * no_check variants of the tactics * TODO: a veriT test does not work anymore * Compiles with both versions of Coq * Test of the tactics in real conditions * Comment on this case study * an example for the FroCoS paper. * Fix smt tactic that doesn't return cvc4's subgoals * readme modifications * readme modifications 2 * small typo in readme. * small changes in readme. * small changes in readme. * typo in readme. * Sync with https://github.com/LFSC/smtcoq * Port to Coq 8.6 * README * README * INSTALL * Missing file * Yves' proposition for installation instructions * Updated link to CVC4 * Compiles again with native-coq * Compiles with both versions of Coq * Command to bypass typechecking when generating a zchaff theorem * Solved bug on cuts from Hole * Counter-models for uninterpreted sorts (improves issue #13) * OCaml version note (#15) * update .gitignore * needs OCaml 4.04.0 * Solving merge issues (under progress) * Make SmtBtype compile * Compilation of SmtForm under progress * Make SmtForm compile * Make SmtCertif compile * Make SmtTrace compile * Make SatAtom compile * Make smtAtom compile * Make CnfParser compile * Make Zchaff compile * Make VeritSyntax compile * Make VeritParser compile * Make lfsc/tosmtcoq compile * Make smtlib2_genconstr compile * smtCommand under progress * smtCommands and verit compile again * lfsc compiles * ml4 compiles * Everything compiles * All ZChaff unit tests and most verit unit tests (but taut5 and un_menteur) go through * Most LFSC tests ok; some fail due to the problem of verit; a few fail due to an error "Not_found" to investigate * Authors and headings * Compiles with native-coq * Typo --- src/smtlib2/smtlib2_genConstr.ml | 296 ++++++++++++++++++++++++++++++++------- 1 file changed, 248 insertions(+), 48 deletions(-) (limited to 'src/smtlib2/smtlib2_genConstr.ml') diff --git a/src/smtlib2/smtlib2_genConstr.ml b/src/smtlib2/smtlib2_genConstr.ml index 76dde25..692294d 100644 --- a/src/smtlib2/smtlib2_genConstr.ml +++ b/src/smtlib2/smtlib2_genConstr.ml @@ -1,13 +1,9 @@ (**************************************************************************) (* *) (* SMTCoq *) -(* Copyright (C) 2011 - 2016 *) +(* Copyright (C) 2011 - 2019 *) (* *) -(* Michaël Armand *) -(* Benjamin Grégoire *) -(* Chantal Keller *) -(* *) -(* Inria - École Polytechnique - Université Paris-Sud *) +(* See file "AUTHORS" for the list of authors *) (* *) (* This file is distributed under the terms of the CeCILL-C licence *) (* *) @@ -42,45 +38,72 @@ let identifier_of_qualidentifier = function | QualIdentifierId (_,id) | QualIdentifierAs (_,id,_) -> id -let string_type s = match s with - | "Bool" -> Tbool - | "Int" -> TZ - | _ -> VeritSyntax.get_btype s - +let string_type s = + match s with + | "Bool" -> fun _ -> Tbool + | "Int" -> fun _ -> TZ + | "Array" -> (function [ti;te] -> TFArray (ti, te) | _ -> assert false) + | _ -> + try Scanf.sscanf s "BitVec_%d%!" (fun size -> fun _ -> TBV size) + with _ -> fun _ -> VeritSyntax.get_btype s -let sort_of_string s = (string_type s, []) +let sort_of_string s = string_type s let sort_of_symbol s = sort_of_string (string_of_symbol s) +let rec bigint_binary_size acc i size = + let open Big_int in + if size = 0 then "#b" ^ String.concat "" acc + else + if eq_big_int i zero_big_int then + bigint_binary_size ("0" :: acc) i (size - 1) + else begin + assert (gt_big_int i zero_big_int && size > 0); + bigint_binary_size (string_of_big_int (and_big_int i unit_big_int) :: acc) + (shift_right_big_int i 1) (size - 1) + end + +let bigint_bv i size = bigint_binary_size [] i size + + +exception DecimalBv of string + let string_of_identifier = function | IdSymbol (_,s) -> (string_of_symbol s) | IdUnderscoreSymNum (_,s,(_,l)) -> - List.fold_left (fun c c' -> c^"_"^c') (string_of_symbol s) l + let s = string_of_symbol s in + let isbvdec = + try s.[0] = 'b' && s.[1]= 'v' with Invalid_argument _ -> false in + (match isbvdec, l with + (* rewrite bitvectors decimal constants *) + | true, [size] -> + let sbv = + Scanf.sscanf s "bv%s" (fun n -> + bigint_bv (Big_int.big_int_of_string n) (int_of_string size)) in + raise (DecimalBv sbv) + | _ -> List.fold_left (fun c c' -> c^"_"^c') s l + ) let string_of_qualidentifier id = string_of_identifier (identifier_of_qualidentifier id) let rec sort_of_sort = function - | SortIdentifier (_,id) -> sort_of_string (string_of_identifier id) + | SortIdentifier (_,id) -> sort_of_string (string_of_identifier id) [] | SortIdSortMulti (_,id,(_,l)) -> - (string_type (string_of_identifier id), List.map sort_of_sort l) + sort_of_string (string_of_identifier id) (List.map sort_of_sort l) let declare_sort rt sym = let s = string_of_symbol sym in let cons_t = declare_new_type (Names.id_of_string ("Smt_sort_"^s)) in - let eq_t = declare_new_variable (Names.id_of_string ("eq_"^s)) (Term.mkArrow cons_t (Term.mkArrow cons_t (Lazy.force cbool))) in - let x = mkName "x" in - let y = mkName "y" in - let rx = Term.mkRel 2 in - let ry = Term.mkRel 1 in - let eq_refl = Term.mkProd (x,cons_t,Term.mkProd (y,cons_t,mklApp creflect [|mklApp ceq [|cons_t;rx;ry|];mklApp (lazy eq_t) [|rx;ry|]|])) in - let eq_refl_v = declare_new_variable (Names.id_of_string ("eq_refl_"^s)) eq_refl in - let ce = mklApp cTyp_eqb [|cons_t;eq_t;eq_refl_v|] in - let res = declare rt cons_t ce in + let compdec_type = mklApp cCompDec [| cons_t |] in + let compdec_var = + declare_new_variable (Names.id_of_string ("CompDec_"^s)) compdec_type in + let ce = mklApp cTyp_compdec [|cons_t; compdec_var|] in + let res = SmtBtype.declare rt cons_t ce in VeritSyntax.add_btype s res; res @@ -89,15 +112,27 @@ let declare_fun rt ro sym arg cod = let s = string_of_symbol sym in let tyl = List.map sort_of_sort arg in let ty = sort_of_sort cod in - - let coqTy = List.fold_right (fun typ c -> Term.mkArrow (interp_to_coq rt (fst typ)) c) tyl (interp_to_coq rt (fst ty)) in + let coqTy = List.fold_right (fun typ c -> + Term.mkArrow (interp_to_coq rt typ) c) + tyl (interp_to_coq rt ty) in let cons_v = declare_new_variable (Names.id_of_string ("Smt_var_"^s)) coqTy in - - let op = Op.declare ro cons_v (Array.of_list (List.map fst tyl)) (fst ty) None in + let op = Op.declare ro cons_v (Array.of_list tyl) ty None in VeritSyntax.add_fun s op; op + +let parse_smt2bv s = + let l = ref [] in + for i = 2 to String.length s - 1 do + match s.[i] with + | '0' -> l := false :: !l + | '1' -> l := true :: !l + | _ -> failwith "Not a bitvector" + done; + !l + + let make_root_specconstant ra = function | SpecConstsDec _ -> failwith "Smtlib2_genConstr.make_root_specconstant: decimals not implemented yet" | SpecConstNum (_,s) -> @@ -110,11 +145,15 @@ let make_root_specconstant ra = function Atom.hatom_Z_of_bigint ra i) | SpecConstString _ -> failwith "Smtlib2_genConstr.make_root_specconstant: strings not implemented yet" | SpecConstsHex _ -> failwith "Smtlib2_genConstr.make_root_specconstant: hexadecimals not implemented yet" - | SpecConstsBinary _ -> failwith "Smtlib2_genConstr.make_root_specconstant: binaries not implemented yet" + | SpecConstsBinary (_, s) -> Atom.mk_bvconst ra (parse_smt2bv s) + + type atom_form = | Atom of SmtAtom.Atom.t | Form of SmtAtom.Form.t +let startwith prefix s = + try Scanf.sscanf s (prefix ^^ "%_s") true with _ -> false let make_root ra rf t = @@ -122,11 +161,14 @@ let make_root ra rf t = let rec make_root_term = function | TermSpecConst (_,c) -> Atom (make_root_specconstant ra c) - | TermQualIdentifier (_,id) -> - let v = string_of_qualidentifier id in - (try Hashtbl.find hlets v with - | Not_found -> - make_root_app v []) + | TermQualIdentifier (loc,id) -> + (try + let v = string_of_qualidentifier id in + (try Hashtbl.find hlets v with Not_found -> make_root_app v []) + with + | DecimalBv sbv -> + make_root_term (TermSpecConst (loc, SpecConstsBinary (loc, sbv))) + ) | TermQualIdTerm (_,id,(_,l)) -> let v = string_of_qualidentifier id in make_root_app v l @@ -144,43 +186,162 @@ let make_root ra rf t = match (v,l) with | "=", [a;b] -> (match make_root_term a, make_root_term b with - | Atom a', Atom b' -> - (match Atom.type_of a' with - | Tbool -> Form (Form.get rf (Fapp (Fiff, [|Form.get rf (Fatom a'); Form.get rf (Fatom b')|]))) - | ty -> Atom (Atom.mk_eq ra true ty a' b')) - | _, _ -> assert false) + | Atom a', Atom b' when Atom.type_of a' <> Tbool -> + Atom (Atom.mk_eq ra (Atom.type_of a') a' b') + | _ -> Form (Form.get rf (Fapp (Fiff, [|make_root a; make_root b|]))) + ) | "<", [a;b] -> (match make_root_term a, make_root_term b with - | Atom a', Atom b' -> Atom (Atom.mk_lt ra true a' b') + | Atom a', Atom b' -> Atom (Atom.mk_lt ra a' b') | _, _ -> assert false) | "<=", [a;b] -> (match make_root_term a, make_root_term b with - | Atom a', Atom b' -> Atom (Atom.mk_le ra true a' b') + | Atom a', Atom b' -> Atom (Atom.mk_le ra a' b') | _, _ -> assert false) | ">", [a;b] -> (match make_root_term a, make_root_term b with - | Atom a', Atom b' -> Atom (Atom.mk_gt ra true a' b') + | Atom a', Atom b' -> Atom (Atom.mk_gt ra a' b') | _, _ -> assert false) | ">=", [a;b] -> (match make_root_term a, make_root_term b with - | Atom a', Atom b' -> Atom (Atom.mk_ge ra true a' b') + | Atom a', Atom b' -> Atom (Atom.mk_ge ra a' b') | _, _ -> assert false) | "+", [a;b] -> (match make_root_term a, make_root_term b with - | Atom a', Atom b' -> Atom (Atom.mk_plus ra true a' b') + | Atom a', Atom b' -> Atom (Atom.mk_plus ra a' b') | _, _ -> assert false) | "-", [a;b] -> (match make_root_term a, make_root_term b with - | Atom a', Atom b' -> Atom (Atom.mk_minus ra true a' b') + | Atom a', Atom b' -> Atom (Atom.mk_minus ra a' b') | _, _ -> assert false) | "*", [a;b] -> (match make_root_term a, make_root_term b with - | Atom a', Atom b' -> Atom (Atom.mk_mult ra true a' b') + | Atom a', Atom b' -> Atom (Atom.mk_mult ra a' b') | _, _ -> assert false) | "-", [a] -> (match make_root_term a with | Atom a' -> Atom (Atom.mk_opp ra a') | _ -> assert false) + | "bvnot", [a] -> + (match make_root_term a with + | Atom a' -> + (match Atom.type_of a' with + | TBV s -> Atom (Atom.mk_bvnot ra s a') + | _ -> assert false) + | _ -> assert false) + | "bvneg", [a] -> + (match make_root_term a with + | Atom a' -> + (match Atom.type_of a' with + | TBV s -> Atom (Atom.mk_bvneg ra s a') + | _ -> assert false) + | _ -> assert false) + | "bvand", [a;b] -> + (match make_root_term a, make_root_term b with + | Atom a', Atom b' -> + (match Atom.type_of a' with + | TBV s -> Atom (Atom.mk_bvand ra s a' b') + | _ -> assert false) + | _, _ -> assert false) + | "bvor", [a;b] -> + (match make_root_term a, make_root_term b with + | Atom a', Atom b' -> + (match Atom.type_of a' with + | TBV s -> Atom (Atom.mk_bvor ra s a' b') + | _ -> assert false) + | _, _ -> assert false) + | "bvxor", [a;b] -> + (match make_root_term a, make_root_term b with + | Atom a', Atom b' -> + (match Atom.type_of a' with + | TBV s -> Atom (Atom.mk_bvxor ra s a' b') + | _ -> assert false) + | _, _ -> assert false) + | "bvadd", [a;b] -> + (match make_root_term a, make_root_term b with + | Atom a', Atom b' -> + (match Atom.type_of a' with + | TBV s -> Atom (Atom.mk_bvadd ra s a' b') + | _ -> assert false) + | _, _ -> assert false) + | "bvmul", [a;b] -> + (match make_root_term a, make_root_term b with + | Atom a', Atom b' -> + (match Atom.type_of a' with + | TBV s -> Atom (Atom.mk_bvmult ra s a' b') + | _ -> assert false) + | _, _ -> assert false) + | "bvult", [a;b] -> + (match make_root_term a, make_root_term b with + | Atom a', Atom b' -> + (match Atom.type_of a' with + | TBV s -> Atom (Atom.mk_bvult ra s a' b') + | _ -> assert false) + | _, _ -> assert false) + | "bvslt", [a;b] -> + (match make_root_term a, make_root_term b with + | Atom a', Atom b' -> + (match Atom.type_of a' with + | TBV s -> Atom (Atom.mk_bvslt ra s a' b') + | _ -> assert false) + | _, _ -> assert false) + | "bvule", [a;b] -> + (match make_root_term a, make_root_term b with + | Atom h1, Atom h2 -> + (match Atom.type_of h1 with + | TBV s -> + let a = Atom.mk_bvult ra s h2 h1 in + Form (Form.neg (Form.get rf (Fatom a))) + | _ -> assert false) + | _,_ -> assert false + ) + | "bvsle", [a;b] -> + (match make_root_term a, make_root_term b with + | Atom h1, Atom h2 -> + (match Atom.type_of h1 with + | TBV s -> + let a = Atom.mk_bvslt ra s h2 h1 in + Form (Form.neg (Form.get rf (Fatom a))) + | _ -> assert false) + | _,_ -> assert false + ) + | "bvshl", [a;b] -> + (match make_root_term a, make_root_term b with + | Atom a', Atom b' -> + (match Atom.type_of a' with + | TBV s -> Atom (Atom.mk_bvshl ra s a' b') + | _ -> assert false) + | _, _ -> assert false) + | "bvlshr", [a;b] -> + (match make_root_term a, make_root_term b with + | Atom a', Atom b' -> + (match Atom.type_of a' with + | TBV s -> Atom (Atom.mk_bvshr ra s a' b') + | _ -> assert false) + | _, _ -> assert false) + | "concat", [a;b] -> + (match make_root_term a, make_root_term b with + | Atom a', Atom b' -> + (match Atom.type_of a', Atom.type_of b' with + | TBV s1, TBV s2 -> Atom (Atom.mk_bvconcat ra s1 s2 a' b') + | _ -> assert false) + | _, _ -> assert false) + | "select", [a;i] -> + (match make_root_term a, make_root_term i with + | Atom a', Atom i' -> + (match Atom.type_of a' with + | TFArray (ti, te) -> Atom (Atom.mk_select ra ti te a' i') + | _ -> assert false) + | _ -> assert false) + + | "store", [a;i;v] -> + (match make_root_term a, make_root_term i, make_root_term v with + | Atom a', Atom i', Atom v' -> + (match Atom.type_of a' with + | TFArray (ti, te) -> Atom (Atom.mk_store ra ti te a' i' v') + | _ -> assert false) + | _ -> assert false) + | "distinct", _ -> let make_h h = match make_root_term h with @@ -205,10 +366,49 @@ let make_root ra rf t = | "ite", _ -> Form (Form.get rf (Fapp (Fite, Array.of_list (List.map make_root l)))) | "not", [a] -> Form (Form.neg (make_root a)) + + | _, [a] when startwith "extract_" v -> + (try + Scanf.sscanf v "extract_%s@_%d" (fun s i -> + let j = int_of_string s in + (match make_root_term a with + | Atom a' -> + (match Atom.type_of a' with + | TBV s -> Atom (Atom.mk_bvextr ra ~s ~i ~n:(j-i+1) a') + | _ -> assert false) + | _ -> assert false) + ) + with _ -> assert false) + + | _, [a] when startwith "zero_extend_" v -> + (try + Scanf.sscanf v "zero_extend_%d" (fun n -> + (match make_root_term a with + | Atom a' -> + (match Atom.type_of a' with + | TBV s -> Atom (Atom.mk_bvzextn ra ~s ~n a') + | _ -> assert false) + | _ -> assert false) + ) + with _ -> assert false) + + | _, [a] when startwith "sign_extend_" v -> + (try + Scanf.sscanf v "sign_extend_%d" (fun n -> + (match make_root_term a with + | Atom a' -> + (match Atom.type_of a' with + | TBV s -> Atom (Atom.mk_bvsextn ra ~s ~n a') + | _ -> assert false) + | _ -> assert false) + ) + with _ -> assert false) + | _, _ -> let op = VeritSyntax.get_fun v in - let l' = List.map (fun t -> match make_root_term t with - | Atom h -> h | Form _ -> assert false) l in + let l' = List.map (fun t -> + match make_root_term t with + | Atom h -> h | Form _ -> assert false) l in Atom (Atom.get ra (Aapp (op, Array.of_list l'))) and make_root t = -- cgit