From bada5a0270c02d35f48dcf6775b69f7b9395cd8e Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Tue, 20 Jan 2026 12:46:21 +0000 Subject: [PATCH 001/145] Circuit reasoning functionality --- .gitmodules | 3 + config/tests.config | 2 +- dune | 7 +- dune-project | 9 +- easycrypt.opam | 9 +- examples/bindings.ec | 410 ++++++ examples/circuit_test.ec | 158 +++ examples/exclude/rejection.ec | 156 +++ examples/mapreduce_paper.ec | 128 ++ flake.lock | 146 ++- flake.nix | 112 +- libs/lospecs/aig.ml | 687 ++++++++++ libs/lospecs/ast.ml | 104 ++ libs/lospecs/circuit.ml | 773 ++++++++++++ libs/lospecs/circuit.mli | 171 +++ libs/lospecs/circuit_spec.ml | 279 +++++ libs/lospecs/circuit_spec.mli | 3 + libs/lospecs/deps.ml | 200 +++ libs/lospecs/deps.ml.bck | 196 +++ libs/lospecs/deps.mli.bck | 35 + libs/lospecs/dune | 15 + libs/lospecs/io.ml | 38 + libs/lospecs/lexer.mll | 75 ++ libs/lospecs/parser.mly | 148 +++ libs/lospecs/ptree.ml | 107 ++ libs/lospecs/smt.ml | 274 ++++ libs/lospecs/tests/avx2.ml | 259 ++++ libs/lospecs/tests/avx2_runtime.cpp | 534 ++++++++ libs/lospecs/tests/avx2_runtime.h | 210 ++++ libs/lospecs/tests/circuit_avx2.ml | 265 ++++ libs/lospecs/tests/circuit_test.ml | 1109 ++++++++++++++++ libs/lospecs/tests/simde | 1 + libs/lospecs/typing.ml | 646 ++++++++++ libs/lospecs/word.ml | 193 +++ libs/lospecs/word.mli | 37 + src/dune | 2 +- src/ec.ml | 9 + src/ecBigInt.ml | 12 + src/ecBigIntCore.ml | 2 + src/ecCircuits.ml | 1114 +++++++++++++++++ src/ecCircuits.mli | 87 ++ src/ecCommands.ml | 11 + src/ecCommands.mli | 1 + src/ecCoreFol.ml | 52 +- src/ecCoreFol.mli | 31 + src/ecCoreGoal.ml | 1 + src/ecCoreGoal.mli | 1 + src/ecCoreLib.ml | 27 + src/ecCoreLib.mli | 27 + src/ecDecl.ml | 86 +- src/ecDecl.mli | 81 +- src/ecEnv.ml | 1431 ++++++++++++--------- src/ecEnv.mli | 54 + src/ecHiInductive.ml | 7 +- src/ecHiTacticals.ml | 11 +- src/ecLexer.mll | 7 +- src/ecLowCircuits.ml | 1807 +++++++++++++++++++++++++++ src/ecLowPhlGoal.ml | 12 +- src/ecOptions.ml | 44 +- src/ecOptions.mli | 8 + src/ecPV.ml | 2 + src/ecPV.mli | 8 +- src/ecParser.mly | 73 +- src/ecParsetree.ml | 100 +- src/ecPrinting.ml | 74 ++ src/ecScope.ml | 541 +++++++- src/ecScope.mli | 10 + src/ecSection.ml | 80 +- src/ecSubst.ml | 107 +- src/ecSubst.mli | 5 + src/ecThCloning.ml | 1 + src/ecTheory.ml | 1 + src/ecTheory.mli | 1 + src/ecTheoryReplay.ml | 241 +++- src/ecTypes.ml | 21 +- src/ecTypes.mli | 6 + src/ecTypesafeFol.ml | 152 +++ src/ecTyping.ml | 12 +- src/ecTyping.mli | 1 + src/ecUtils.ml | 19 +- src/ecUtils.mli | 2 + src/phl/ecPhlBDep.ml | 445 +++++++ src/phl/ecPhlBDep.mli | 11 + src/phl/ecPhlCodeTx.ml | 43 +- src/phl/ecPhlEqobs.ml | 185 ++- src/phl/ecPhlEqobs.mli | 17 +- src/phl/ecPhlLoopTx.ml | 23 +- src/phl/ecPhlLoopTx.mli | 4 +- src/phl/ecPhlOutline.ml | 36 +- src/phl/ecPhlRCond.mli | 2 +- src/phl/ecPhlRewrite.ml | 113 +- src/phl/ecPhlRewrite.mli | 3 +- src/phl/ecPhlRwEquiv.ml | 24 +- src/phl/ecPhlRwEquiv.mli | 7 +- src/phl/ecPhlRwPrgm.ml | 78 +- tests/abstract_bind.ec | 70 ++ tests/circuit_test.ec | 176 +++ tests/ext_test.ec | 13 + tests/procchange.ec | 7 +- theories/algebra/StdBigop.ec | 7 + theories/datatypes/List.ec | 7 + theories/datatypes/QFABV.ec | 552 ++++++++ theories/dune | 1 - 103 files changed, 14820 insertions(+), 885 deletions(-) create mode 100644 .gitmodules create mode 100644 examples/bindings.ec create mode 100644 examples/circuit_test.ec create mode 100644 examples/exclude/rejection.ec create mode 100644 examples/mapreduce_paper.ec create mode 100644 libs/lospecs/aig.ml create mode 100644 libs/lospecs/ast.ml create mode 100644 libs/lospecs/circuit.ml create mode 100644 libs/lospecs/circuit.mli create mode 100644 libs/lospecs/circuit_spec.ml create mode 100644 libs/lospecs/circuit_spec.mli create mode 100644 libs/lospecs/deps.ml create mode 100644 libs/lospecs/deps.ml.bck create mode 100644 libs/lospecs/deps.mli.bck create mode 100644 libs/lospecs/dune create mode 100644 libs/lospecs/io.ml create mode 100644 libs/lospecs/lexer.mll create mode 100644 libs/lospecs/parser.mly create mode 100644 libs/lospecs/ptree.ml create mode 100644 libs/lospecs/smt.ml create mode 100644 libs/lospecs/tests/avx2.ml create mode 100644 libs/lospecs/tests/avx2_runtime.cpp create mode 100644 libs/lospecs/tests/avx2_runtime.h create mode 100644 libs/lospecs/tests/circuit_avx2.ml create mode 100644 libs/lospecs/tests/circuit_test.ml create mode 160000 libs/lospecs/tests/simde create mode 100644 libs/lospecs/typing.ml create mode 100644 libs/lospecs/word.ml create mode 100644 libs/lospecs/word.mli create mode 100644 src/ecCircuits.ml create mode 100644 src/ecCircuits.mli create mode 100644 src/ecLowCircuits.ml create mode 100644 src/ecTypesafeFol.ml create mode 100644 src/phl/ecPhlBDep.ml create mode 100644 src/phl/ecPhlBDep.mli create mode 100644 tests/abstract_bind.ec create mode 100644 tests/circuit_test.ec create mode 100644 tests/ext_test.ec create mode 100644 theories/datatypes/QFABV.ec diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000000..1810e6abc9 --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "libs/lospecs/tests/simde"] + path = libs/lospecs/tests/simde + url = git@github.com:simd-everywhere/simde.git diff --git a/config/tests.config b/config/tests.config index f7df574a8f..8e017a6e82 100644 --- a/config/tests.config +++ b/config/tests.config @@ -8,7 +8,7 @@ exclude = theories/prelude [test-examples] okdirs = !examples -exclude = examples/MEE-CBC examples/old examples/old/list-ddh !examples/incomplete examples/to-port +exclude = examples/MEE-CBC examples/exclude examples/old examples/old/list-ddh !examples/incomplete examples/to-port [test-mee-cbc] okdirs = examples/MEE-CBC diff --git a/dune b/dune index 7c8edf7096..6e918e80d4 100644 --- a/dune +++ b/dune @@ -1,4 +1,9 @@ -(dirs 3rdparty src etc theories examples assets scripts) +(env + (dev (flags -rectypes -warn-error -a+31 -w +28+33-9-23-32-58-67-69)) + (release (flags -rectypes -warn-error -a+31 -w +28+33-9-23-32-58-67-69) + (ocamlopt_flags -O3 -unbox-closures))) + +(dirs 3rdparty src etc libs theories examples assets scripts) (install (section (site (easycrypt commands))) diff --git a/dune-project b/dune-project index 85f142616e..64b6a5eaf7 100644 --- a/dune-project +++ b/dune-project @@ -13,7 +13,8 @@ (sites (lib theories) (libexec commands) (lib doc) (lib config)) (depends (ocaml (>= 4.08.0)) - (batteries (>= 3)) + (batteries (>= 3.9)) + bitwuzla (camlp-streams (>= 5)) camlzip dune @@ -22,6 +23,12 @@ markdown (pcre2 (>= 8)) (why3 (and (>= 1.8.0) (< 1.9))) + ppx_deriving + ppx_deriving_yojson + hex + iter + cmdliner + progress yojson (zarith (>= 1.10)) )) diff --git a/easycrypt.opam b/easycrypt.opam index 08bdb40eac..d957b69428 100644 --- a/easycrypt.opam +++ b/easycrypt.opam @@ -1,7 +1,8 @@ # This file is generated by dune, edit dune-project instead depends: [ "ocaml" {>= "4.08.0"} - "batteries" {>= "3"} + "batteries" {>= "3.9"} + "bitwuzla" "camlp-streams" {>= "5"} "camlzip" "dune" {>= "3.13"} @@ -10,6 +11,12 @@ depends: [ "markdown" "pcre2" {>= "8"} "why3" {>= "1.8.0" & < "1.9"} + "ppx_deriving" + "ppx_deriving_yojson" + "hex" + "iter" + "cmdliner" + "progress" "yojson" "zarith" {>= "1.10"} "odoc" {with-doc} diff --git a/examples/bindings.ec b/examples/bindings.ec new file mode 100644 index 0000000000..1dc74cb333 --- /dev/null +++ b/examples/bindings.ec @@ -0,0 +1,410 @@ +require import AllCore Bool IntDiv CoreMap List Distr QFABV. +from Jasmin require import JModel JArray. + +clone import PolyArray as Array2 with op size <- 2. + +bind array Array2."_.[_]" Array2."_.[_<-_]" Array2.to_list Array2.of_list Array2.t 2. +realize tolistP by admit. +realize eqP by admit. +realize get_setP by admit. +realize get_out by admit. + +export Array2. + +(* ----------- BEGIN BOOL BINDINGS ---------- *) +op bool2bits (b : bool) : bool list = [b]. +op bits2bool (b: bool list) : bool = List.nth false b 0. + +op i2b (i : int) = (i %% 2 <> 0). +op b2si (b: bool) = 0. + +bind bitstring bool2bits bits2bool b2i b2si i2b bool 1. +realize size_tolist by auto. +realize tolistP by auto. +realize oflistP by admit. +realize ofintP by admit. +realize touintP by admit. +realize tosintP by auto. + +bind op bool (&&) "mul". +realize bvmulP by admit. + +bind op bool (^^) "add". +realize bvaddP by admit. + +op sub (a : bool, b: bool) : bool = + a ^^ b. + +bind op bool sub "sub". +realize bvsubP by admit. + +(* bind op bool udiv "udiv". + realize bvudivP by admit. + +bind op bool umod "urem". +realize bvuremP by admit. *) + +bind op bool (/\) "and". +realize bvandP by admit. + +bind op bool (\/) "or". +realize bvorP by admit. + +bind op bool [!] "not". +realize bvnotP by admit. + +(* TODO: Add shifts once we have truncate/extend *) + + +(* ----------- BEGIN W8 BINDINGS ---------- *) +bind bitstring W8.w2bits W8.bits2w W8.to_uint W8.to_sint W8.of_int W8.t 8. +realize size_tolist by auto. +realize tolistP by auto. +realize oflistP by admit. +realize ofintP by admit. +realize touintP by admit. +realize tosintP by admit. + +bind op W8.t W8.( + ) "add". +realize bvaddP by admit. + +bind op W8.t W8.( * ) "mul". +realize bvmulP by admit. + +op W8_sub (a : W8.t, b: W8.t) : W8.t = + a - b. + +bind op W8.t W8_sub "sub". +realize bvsubP by admit. + +bind op W8.t W8.\udiv "udiv". +realize bvudivP by admit. + +bind op W8.t W8.\umod "urem". +realize bvuremP by admit. + +bind op W8.t W8.andw "and". +realize bvandP by admit. + +bind op W8.t W8.orw "or". +realize bvorP by admit. + +bind op W8.t W8.(+^) "xor". +realize bvxorP by admit. + +bind op W8.t W8.invw "not". +realize bvnotP by admit. + +bind op [bool & W8.t] W8.\ult "ult". +realize bvultP by admit. + +bind op [bool & W8.t] W8.\ule "ule". +realize bvuleP by admit. + +bind op [bool & W8.t] W8.\slt "slt". +realize bvsltP by admit. + +bind op [bool & W8.t] W8.\sle "sle". +realize bvsleP by admit. + +bind op W8.t W8.(`>>`) "shr". +realize bvshrP by admit. + +bind op W8.t W8.(`<<`) "shl". +realize bvshlP by admit. + +bind op W8.t W8.(`|>>`) "ashr". +realize bvashrP by admit. + + + +(* ----------- BEGIN W16 BINDINGS ---------- *) + +bind bitstring W16.w2bits W16.bits2w W16.to_uint W16.to_sint W16.of_int W16.t 16. +realize size_tolist by auto. +realize tolistP by auto. +realize oflistP by admit. +realize ofintP by admit. +realize touintP by admit. +realize tosintP by admit. + +bind op W16.t W16.( + ) "add". +realize bvaddP by admit. + +bind op W16.t W16.( * ) "mul". +realize bvmulP by admit. + +op W16_sub (a : W16.t, b: W16.t) : W16.t = + a - b. + +bind op W16.t W16_sub "sub". +realize bvsubP by admit. + +bind op W16.t W16.\udiv "udiv". +realize bvudivP by admit. + +bind op W16.t W16.\umod "urem". +realize bvuremP by admit. + +bind op W16.t W16.andw "and". +realize bvandP by admit. + +bind op W16.t W16.orw "or". +realize bvorP by admit. + +bind op W16.t W16.(+^) "xor". +realize bvxorP by admit. + +bind op W16.t W16.invw "not". +realize bvnotP by admit. + +bind op [bool & W16.t] W16.\ult "ult". +realize bvultP by admit. + +bind op [bool & W16.t] W16.\ule "ule". +realize bvuleP by admit. + +bind op [bool & W16.t] W16.\sle "sle". +realize bvsleP by admit. + +bind op [bool & W16.t] W16.\slt "slt". +realize bvsltP by admit. + +op uext8_16 (w: W8.t) : W16.t = + W16.of_int (W8.to_uint w). + +bind op [W8.t & W16.t] uext8_16 "zextend". +realize bvzextendP by admit. + +op sext8_16 (w: W8.t) : W16.t = + W16.of_int (W8.to_sint w). + +bind op [W8.t & W16.t] sext8_16 "sextend". +realize bvsextendP by admit. + +op concat8_8_16 (w: W8.t) (w: W8.t) : W16.t. + +bind op [W8.t & W8.t & W16.t] concat8_8_16 "concat". +realize bvconcatP by admit. + + +op shl16 (w: W16.t) (sa: W16.t) : W16.t. + +lemma shl_shift w sa : + W16.(`<<`) w sa = shl16 w (uext8_16 sa) by admit. + +bind op W16.t shl16 "shl". +realize bvshlP by admit. + +(* TODO: Add shifts once we have truncate/extend *) + + +(* ----------- BEGIN W32 BINDINGS ---------- *) +bind bitstring W32.w2bits W32.bits2w W32.to_uint W32.to_sint W32.of_int W32.t 32. +realize size_tolist by auto. +realize tolistP by auto. +realize oflistP by admit. +realize touintP by admit. +realize tosintP by admit. +realize ofintP by admit. + +bind op W32.t W32.( + ) "add". +realize bvaddP by admit. + +bind op W32.t W32.( * ) "mul". +realize bvmulP by admit. + +op W32_sub (a : W32.t, b: W32.t) : W32.t = + a - b. + +bind op W32.t W32_sub "sub". +realize bvsubP by admit. + +bind op W32.t W32.\udiv "udiv". +realize bvudivP by admit. + +bind op W32.t W32.\umod "urem". +realize bvuremP by admit. + +bind op W32.t W32.andw "and". +realize bvandP by admit. + +bind op W32.t W32.orw "or". +realize bvorP by admit. + +bind op W32.t W32.(+^) "xor". +realize bvxorP by admit. + +bind op W32.t W32.invw "not". +realize bvnotP by admit. + +bind op [W32.t & bool] W32."_.[_]" "get". +realize bvgetP by admit. + +(* TODO: Add shifts once we have truncate/extend *) + + +(* ----------- BEGIN W64 BINDINGS ---------- *) + +bind bitstring W64.w2bits W64.bits2w W64.to_uint W64.to_sint W64.of_int W64.t 64. +realize size_tolist by auto. +realize tolistP by auto. +realize oflistP by admit. +realize touintP by admit. +realize tosintP by admit. +realize ofintP by admit. + +bind op W64.t W64.( + ) "add". +realize bvaddP by admit. + +bind op W64.t W64.( * ) "mul". +realize bvmulP by admit. + +op W64_sub (a : W64.t, b: W64.t) : W64.t = + a - b. + +bind op W64.t W64_sub "sub". +realize bvsubP by admit. + +bind op W64.t W64.\udiv "udiv". +realize bvudivP by admit. + +bind op W64.t W64.\umod "urem". +realize bvuremP by admit. + +bind op W64.t W64.andw "and". +realize bvandP by admit. + +bind op W64.t W64.orw "or". +realize bvorP by admit. + +bind op W64.t W64.(+^) "xor". +realize bvxorP by admit. + +bind op W64.t W64.invw "not". +realize bvnotP by admit. + +(* TODO: Add shifts once we have truncate/extend *) + + +(* ----------- BEGIN W128 BINDINGS ---------- *) + +bind bitstring W128.w2bits W128.bits2w W128.to_uint W128.to_sint W128.of_int W128.t 128. +realize size_tolist by auto. +realize tolistP by auto. +realize oflistP by admit. +realize touintP by admit. +realize tosintP by admit. +realize ofintP by admit. + +bind op W128.t W128.( + ) "add". +realize bvaddP by admit. + +bind op W128.t W128.( * ) "mul". +realize bvmulP by admit. + +op W128_sub (a : W128.t, b: W128.t) : W128.t = + a - b. + +bind op W128.t W128_sub "sub". +realize bvsubP by admit. + +bind op W128.t W128.\udiv "udiv". +realize bvudivP by admit. + +bind op W128.t W128.\umod "urem". +realize bvuremP by admit. + +bind op W128.t W128.andw "and". +realize bvandP by admit. + +bind op W128.t W128.orw "or". +realize bvorP by admit. + +bind op W128.t W128.(+^) "xor". +realize bvxorP by admit. + +bind op W128.t W128.invw "not". +realize bvnotP by admit. + +(* TODO: Add shifts once we have truncate/extend *) + +(* ----------- BEGIN W256 BINDINGS ---------- *) + +bind bitstring W256.w2bits W256.bits2w W256.to_uint W256.to_sint W256.of_int W256.t 256. +realize size_tolist by auto. +realize tolistP by auto. +realize oflistP by admit. +realize touintP by admit. +realize tosintP by admit. +realize ofintP by admit. + +bind op W256.t W256.( + ) "add". +realize bvaddP by admit. + +bind op W256.t W256.( * ) "mul". +realize bvmulP by admit. + +op W256_sub (a : W256.t, b: W256.t) : W256.t = + a - b. + +bind op W256.t W256_sub "sub". +realize bvsubP by admit. + +bind op W256.t W256.\udiv "udiv". +realize bvudivP by admit. + +bind op W256.t W256.\umod "urem". +realize bvuremP by admit. + +bind op W256.t W256.andw "and". +realize bvandP by admit. + +bind op W256.t W256.orw "or". +realize bvorP by admit. + +bind op W256.t W256.(+^) "xor". +realize bvxorP by admit. + +bind op W256.t W256.invw "not". +realize bvnotP by admit. + +(* TODO: Add shifts once we have truncate/extend *) + +(* ----------- BEGIN SPEC FILE BINDINDS ---------- *) + + +(* +bind circuit W32.(`<<`) "LSHIFT32". + bind circuit W32.(`>>`) "RSHIFTL_32". + *) + +print VPSUB_16u16. + +(* -- AVX2 VECTORIZED -- *) +bind circuit VPSUB_16u16 "VPSUB_16u16". +bind circuit VPADD_16u16 "VPADD_16u16". +bind circuit VPBROADCAST_16u16 "VPBROADCAST_16u16". +bind circuit VPMULH_16u16 "VPMULH_16u16". +bind circuit VPMULL_16u16 "VPMULL_16u16". +bind circuit VPMULHRS_16u16 "VPMULHRS_16u16". +bind circuit VPACKUS_16u16 "VPACKUS_16u16". +bind circuit VPMADDUBSW_256 "VPMADDUBSW_256". +bind circuit VPERMD "VPERMD". + + +(* FIXME: Check new types *) +bind circuit VPSRA_16u16 "VPSRA_16u16_new". + + +bind op [bool & W16.t] W16.init "init". +realize bvinitP by admit. + +bind op [bool & W32.t] W32.init "init". +realize bvinitP by admit. + +op map_test (f: W16.t -> W16.t) (arr: W16.t Array2.t) : W16.t Array2.t = + Array2.map f arr. + +bind op [W16.t & W16.t & Array2.t] map_test "map". +realize mapP by admit. diff --git a/examples/circuit_test.ec b/examples/circuit_test.ec new file mode 100644 index 0000000000..123b8ad872 --- /dev/null +++ b/examples/circuit_test.ec @@ -0,0 +1,158 @@ +require import AllCore Bool IntDiv CoreMap List Distr QFABV. +from Jasmin require import JModel JArray. + +require import Bindings. + + +op sub16 (a b: W16.t) = a - b. + +bind op W16.t sub16 "sub". +realize bvsubP by admit. + +type word = W32.t. + +op ROR_W32(w1 w2: W32.t) = + w1 `|>>>|` (W32.to_uint w2). + +bind op W32.t ROR_W32 "ror". +realize bvrorP by admit. + +print (`|>>|`). + +op SHR_W32(w1 w2: W32.t) = + w1 `|>>|` (W8.of_int (W32.to_uint w2)). + +bind op W32.t SHR_W32 "shr". +realize bvshrP by admit. + +lemma rw_RORw (w1: W32.t) (i: int) : + w1 `|>>|` (W8.of_int i) = ROR_W32 w1 (W32.of_int i). +by admit. qed. + +lemma rw_SHLw (w1: W32.t) (i: int) : + w1 `>>` (W8.of_int i) = SHR_W32 w1 (W32.of_int i). +by admit. qed. + + +module M = { + proc and_or_test (a: W16.t) : W16.t = { + var b : W16.t; + b <- W16.andw a (W16.of_int 514); + b <- W16.orw b (W16.of_int 1028); + return b; + } + + proc vp_test (a: W256.t) : W256.t = { + a <- VPADD_16u16 a a; + return a; + } + + proc test_of_list (a: W16.t Array2.t) : W16.t Array2.t = { + a <- Array2.of_list witness [W16.of_int 2; W16.of_int 2]; + return a; + } + + proc test_bvinit (a: W16.t) : W16.t = { + a <- W16.init (fun i => a.[i] ^^ a.[i]); + return a; + } + + proc test_init (a: W16.t Array2.t) : W16.t Array2.t = { + a <- Array2.init (fun i => a.[i]); + return a; + } + + proc __sigma_0 (w:W32.t) : W32.t = { + var w1:W32.t; + var w2:W32.t; + w1 <- w; + w2 <- w; + w <- (w `|>>|` (W8.of_int 7)); + w1 <- (w1 `|>>|` (W8.of_int 18)); + w2 <- (w2 `>>` (W8.of_int 3)); + w <- (w `^` w1); + w <- (w `^` w2); + return w; + } +}. + + +op ident_W16 (w: W16.t) : W16.t = w. +op predT_W16 (w: W16.t) : bool = true. +op times2_W16 (w: W16.t) : W16.t = w + w. +op const2_W16 (w: W16.t) : W16.t = W16.of_int 2. +op const0_W16 (w: W16.t) : W16.t = W16.of_int 0. + +op predT_W32 (w: W32.t) : bool = true. + +bind op W32.t W32.(+^) "xor". +realize bvxorP by admit. + + +bind op [bool & W32.t] W32.init "init". +realize bvinitP by admit. + +bind op [W32.t & bool] W32."_.[_]" "get". +realize bvgetP by admit. + +op small_sig0 (w : word) : word = + let x = w `|>>>|` 7 in + let y = w `|>>>|` 18 in + let z = w `>>>` 3 in + x +^ y +^ z. + +lemma small_sig (w_: W32.t) : hoare [ M.__sigma_0 : w_ = w ==> res = small_sig0 w_]. +proof. +proc. +print (`|>>|`). +proc change 3 : (w `|>>>|` ((to_uint (W8.of_int 7)) %% 32)).auto. +proc change 4 : (w1 `|>>>|` ((to_uint (W8.of_int 18)) %% 32)). auto. +proc change 5 : (w2 `>>>` ((to_uint (W8.of_int 3)) %% 32)). auto. +proc rewrite 3 /=. +proc rewrite 4 /=. +proc rewrite 5 /=. +bdep 32 32 [w_] [w] [w] small_sig0 predT_W32. +admitted. + + + +lemma small_sig_orig (w_: W32.t) : hoare [ M.__sigma_0 : w_ = w ==> res = small_sig0 w_]. +proof. +proc. +bdep 32 32 [w_] [w] [w] small_sig0 predT_W32. + +op predT_W8 (w: W8.t) : bool = true. +op and2_W8 (w: W8.t) : W8.t = W8.orw (W8.andw w (W8.of_int 2)) (W8.of_int 4). + + +print W16.( [-] ). + +lemma test_add_sub (w_: W16.t) : +hoare [ M.and_or_test : (w_ = a) ==> res = w_ ]. + proof. + proc. + bdep 8 8 [w_] [a] [b] and2_W8 predT_W8. + admitted. + +lemma test_vp (w_: W256.t) : +hoare [ M.vp_test : (w_ = a) ==> res = w_ ]. + proof. + proc. + bdep 16 16 [w_] [a] [a] times2_W16 predT_W16. + admitted. + +lemma test_of_list (w_: W16.t Array2.t) : +hoare [ M.test_of_list : (w_ = a) ==> res = w_ ]. + proof. + proc. + bdep 16 16 [w_] [a] [a] const2_W16 predT_W16. + admitted. + +lemma test_bvinit (w_: W16.t) : +hoare [ M.test_bvinit : (w_ = a) ==> res = w_ ]. + proof. + proc. + bdep 16 16 [w_] [a] [a] const0_W16 predT_W16. + admitted. + + diff --git a/examples/exclude/rejection.ec b/examples/exclude/rejection.ec new file mode 100644 index 0000000000..cf163d88e8 --- /dev/null +++ b/examples/exclude/rejection.ec @@ -0,0 +1,156 @@ +(* -------------------------------------------------------------------- *) +require import AllCore List. + +(* -------------------------------------------------------------------- *) +from Jasmin require import JWord. + +(* -------------------------------------------------------------------- *) +type w8 = W8.t. +type w16 = W16.t. +type w32 = W32.t. +type w64 = W64.t. +type w128 = W128.t. +type w256 = W256.t. + +(* -------------------------------------------------------------------- *) +op VPERMQ : w256 -> w8 -> w256. +op VPSHUFB_256 : w256 -> w256 -> w256. +op VPSRL_16u16 : w256 -> w8 -> w256. +op VPBLEND_16u16 : w256 -> w256 -> w8 -> w256. +op VPBROADCAST_16u16 : w16 -> w256. +op VPAND_256 : w256 -> w256 -> w256. +op VPCMPGT_16u16 : w256 -> w256 -> w256. +op VPACKSS_16u16 : w256 -> w256 -> w256. +op VPMOVMSKB_u256u64 : w256 -> w64. +op VINSERTI128 : w256 -> w128 -> int -> w256. +op VEXTRACTI128 : w256 -> int -> w128. +op VPADD_32u8 : w256 -> w256 -> w256. +op VPUNPCKL_32u8 : w256 -> w256 -> w256. + +(* -------------------------------------------------------------------- *) +op sst : int -> W64.t. + +(* -------------------------------------------------------------------- *) +module M = { + proc gen_matrix_sample_iterate_x3_fast_filter48( + r0 : w64, + r1 : w64, + r2 : w64, + r3 : w64, + r4 : w64, + r5 : w64, + r6 : w64 + ) = { + var permq : w8; (* VPERMQ mask *) + var shfb : w256; (* VPSHUFB mask *) + var andm : w256; + var bounds : w256; + var ones : w256; + + var f0, f1, g0, g1, g : w256; + var good : w64; + + var t0_0, t0_1, t1_0, t1_1 : w64; + + var shuffle_0 : w256; + var shuffle_0_1 : w128; + + var shuffle_1 : w256; + var shuffle_1_1 : w128; + + var shuffle_t : w256; + + var counter : w64 <- W64.zero; + + permq <- W8.of_int 148; (* FIXME: hex/bin notations *) + shfb <- W32u8.pack32 (List.map W8.of_int [ + 0; 1; 1; 2; 3; 4; 4; 5; + 6; 7; 7; 8; 9; 10; 10; 11; + 4; 5; 5; 6; 7; 8; 8; 9; + 10; 11; 11; 12; 13; 14; 14; 15 + ]); + + f0 <- VPERMQ (W4u64.pack4 [r0; r1; r2; r3]) permq; + f1 <- VPERMQ (W4u64.pack4 [r3; r4; r5; r6]) permq; + + f0 <- VPSHUFB_256 f0 shfb; + f1 <- VPSHUFB_256 f1 shfb; + + g0 <- VPSRL_16u16 f0 (W8.of_int 4); + g1 <- VPSRL_16u16 f1 (W8.of_int 4); + + f0 <- VPBLEND_16u16 f0 g0 (W8.of_int 170); (* 0xaa *) + f1 <- VPBLEND_16u16 f1 g1 (W8.of_int 170); (* 0xaa *) + + andm <- VPBROADCAST_16u16 (W16.of_int 4095); (* 0x0fff *) + f0 <- VPAND_256 f0 andm; + f1 <- VPAND_256 f1 andm; + + bounds <- VPBROADCAST_16u16 (W16.of_int 3309); + g0 <- VPCMPGT_16u16 bounds f0; + g1 <- VPCMPGT_16u16 bounds f1; + + g <- VPACKSS_16u16 g0 g1; + good <- VPMOVMSKB_u256u64 g; + + t0_0 <- good; + t0_0 <- t0_0 `&` W64.of_int 255; + shuffle_0 <- W256.of_int (W64.to_sint (sst (W64.to_uint t0_0))); + t0_0 <- (POPCNT_64 t0_0).`6; + counter <- counter + t0_0; + + t0_1 <- good; + t0_1 <- t0_1 `>>>` 16; + t0_1 <- t0_1 `&` W64.of_int 255; + shuffle_0_1 <- W128.of_int (W64.to_sint (sst (W64.to_uint t0_1))); + t0_1 <- (POPCNT_64 t0_1).`6; + counter <- counter + t0_1; + t0_1 <- t0_1 + t0_0; + + t1_0 <- good; + t1_0 <- t1_0 `>>>` 8; + t1_0 <- t1_0 `&` W64.of_int 255; + shuffle_1 <- W256.of_int (W64.to_sint (sst (W64.to_uint t1_0))); + t1_0 <- (POPCNT_64 t1_0).`6; + counter <- counter + t1_0; + t1_0 <- t1_0 + t0_1; + + t1_1 <- good; + t1_1 <- t1_1 `>>>` 24; + t1_1 <- t1_1 `&` W64.of_int 255; + shuffle_1_1 <- W128.of_int (W64.to_sint (sst (W64.to_uint t1_1))); + t1_1 <- (POPCNT_64 t1_1).`6; + counter <- counter + t1_1; + t1_1 <- t1_1 + t1_0; + + shuffle_0 <- VINSERTI128 shuffle_0 shuffle_0_1 1; + shuffle_1 <- VINSERTI128 shuffle_1 shuffle_1_1 1; + + ones <- VPBROADCAST_16u16 (W16.of_int 1); + + shuffle_t <- VPADD_32u8 shuffle_0 ones; + shuffle_0 <- VPUNPCKL_32u8 shuffle_0 shuffle_t; + + shuffle_t <- VPADD_32u8 shuffle_1 ones; + shuffle_1 <- VPUNPCKL_32u8 shuffle_1 shuffle_t; + + f0 <- VPSHUFB_256 f0 shuffle_0; + f1 <- VPSHUFB_256 f1 shuffle_1; + + (* + matrix.[u128 2*(int) matrix_offset] = (128u)f0; + matrix.[u128 2*(int) t0_0] = #VEXTRACTI128(f0, 1); + matrix.[u128 2*(int) t0_1] = (128u)f1; + matrix.[u128 2*(int) t1_0] = #VEXTRACTI128(f1, 1); + matrix_offset = t1_1; + + return counter, matrix, matrix_offset; + *) + } +}. + +hoare H : M.gen_matrix_sample_iterate_x3_fast_filter48 : true ==> false. +proof. +proc. + +idassign ^t0_0<-{2} t0_0. diff --git a/examples/mapreduce_paper.ec b/examples/mapreduce_paper.ec new file mode 100644 index 0000000000..68dc6a1c9f --- /dev/null +++ b/examples/mapreduce_paper.ec @@ -0,0 +1,128 @@ +require import AllCore Bool IntDiv CoreMap List Distr QFABV. +from Jasmin require import JModel JArray. + + +bind bitstring W8.w2bits W8.bits2w W8.to_uint W8.to_sint W8.of_int W8.t 8. +realize size_tolist by auto. +realize tolistP by auto. +realize oflistP by admit. +realize ofintP by admit. +realize touintP by admit. +realize tosintP by admit. + +bind op W8.t W8.(+^) "xor". +realize bvxorP by admit. + +op bool2bits (b : bool) : bool list = [b]. +op bits2bool (b: bool list) : bool = List.nth false b 0. + +op i2b (i : int) = (i %% 2 <> 0). +op b2si (b: bool) = 0. + +bind bitstring bool2bits bits2bool b2i b2si i2b bool 1. +realize size_tolist by auto. +realize tolistP by auto. +realize oflistP by admit. +realize ofintP by admit. +realize touintP by admit. +realize tosintP by auto. + +bind op bool (^^) "add". +realize bvaddP by admit. + +op predT_bool : bool -> bool = fun _ => true. +op xor1_bool (b: bool) = b ^^ true. + +op xor_left (w1 : W8.t) = + (w1 +^ (W8.of_int 42)) +^ (W8.of_int 213). + +op xor_right (w1 : W8.t) = + w1 +^ ((W8.of_int 42)) +^ (W8.of_int 213). + +op xor_left_spec : W8.t -> W8.t. + +bind circuit xor_left_spec "XOR_LEFT8". + +op predT_W8 : W8.t -> bool = fun _ => true. + +module M = { + proc xor_left_proc (w1: W8.t) = { + w1 <- w1 +^ (W8.of_int 42); + w1 <- w1 +^ (W8.of_int 213); + return w1; + } + + proc xor_right_proc (w1: W8.t) = { + var w2 : W8.t; + w2 <- (W8.of_int 42); + w2 <- w2 +^ (W8.of_int 213); + w1 <-w1 +^ w2; + return w1; + } +}. + +lemma xor_left_corr (w: W8.t) : + hoare [ M.xor_left_proc : w = w1 ==> res = xor_left w]. +proof. +proc. +bdep 8 8 [w] [w1] [w1] xor_left predT_W8. +admit. +admit. +qed. + +lemma xor_left_equiv_xor_right_proc (w: W8.t) : + equiv [ M.xor_left_proc ~ M.xor_right_proc : w = arg{1} /\ arg{1} = arg{2} ==> res{1} = res{2} ]. +proof. +proc. +bdepeq 8 [w1] [w1] {8 : [w1 ~ w1]} predT_W8. +admit. +auto. +qed. + +lemma xor_left_equiv_xor_right_proc_lanes (w: W8.t) : + equiv [ M.xor_left_proc ~ M.xor_right_proc : w = arg{1} /\ arg{1} = arg{2} ==> res{1} = res{2} ]. +proof. +proc. +bdepeq 1 [w1] [w1] {1 : [w1 ~ w1]} predT_bool. +admit. +auto. +qed. + + +lemma xor_left_corr_lanes (w: W8.t) : + hoare [ M.xor_left_proc : w = w1 ==> res = xor_left w]. +proof. + proc. +bdep 1 1 [w] [w1] [w1] xor1_bool predT_bool. +admit. +admit. +qed. + +lemma xor_left_corr_spec (w: W8.t) : + hoare [ M.xor_left_proc : w = w1 ==> res = xor_left w]. +proof. +proc. +bdep 8 8 [w] [w1] [w1] xor_left_spec predT_W8. +admit. +admit. +qed. + +lemma xor_left_eq_xor_right (w: W8.t) : xor_left w = xor_right w. + proof. + bdep solve. + qed. + +lemma xor_left_corr_wp (w: W8.t) : + hoare [ M.xor_left_proc : w = w1 ==> res = xor_left w]. +proof. + proc. + wp; skip => &hr. by bdep solve. +qed. + +lemma xor_left_corr_wp_alt (w: W8.t) : + hoare [ M.xor_left_proc : w = w1 ==> res = xor_left w]. +proof. + proc. + wp; skip => &hr eq. + by bdep solve. +qed. diff --git a/flake.lock b/flake.lock index d66af42062..0ef29822ea 100644 --- a/flake.lock +++ b/flake.lock @@ -1,13 +1,32 @@ { "nodes": { + "emacs-overlay": { + "inputs": { + "nixpkgs": "nixpkgs", + "nixpkgs-stable": "nixpkgs-stable" + }, + "locked": { + "lastModified": 1757668180, + "narHash": "sha256-pqxwsvg8cVOY4bgEy5PUsWLVGDbgYFDnGP20bdWhjiM=", + "owner": "nix-community", + "repo": "emacs-overlay", + "rev": "b21511280c6e1ea516e551fc5e7bb27372f6c8c3", + "type": "github" + }, + "original": { + "owner": "nix-community", + "repo": "emacs-overlay", + "type": "github" + } + }, "flake-compat": { "flake": false, "locked": { - "lastModified": 1696426674, - "narHash": "sha256-kvjfFW7WAETZlt09AgDn1MrtKzP7t90Vf7vypd3OL1U=", + "lastModified": 1747046372, + "narHash": "sha256-CIVLLkVgvHYbgI2UpXvIIBJ12HWgX+fjA8Xf8PUmqCY=", "owner": "edolstra", "repo": "flake-compat", - "rev": "0f9255e01c2351cc7d116c072cb317785dd33b33", + "rev": "9100a0f413b0c601e0533d1d94ffd501ce2e7885", "type": "github" }, "original": { @@ -39,11 +58,11 @@ "systems": "systems_2" }, "locked": { - "lastModified": 1726560853, - "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=", + "lastModified": 1731533236, + "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", "owner": "numtide", "repo": "flake-utils", - "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a", + "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", "type": "github" }, "original": { @@ -70,11 +89,43 @@ }, "nixpkgs": { "locked": { - "lastModified": 1730785428, - "narHash": "sha256-Zwl8YgTVJTEum+L+0zVAWvXAGbWAuXHax3KzuejaDyo=", + "lastModified": 1757487488, + "narHash": "sha256-zwE/e7CuPJUWKdvvTCB7iunV4E/+G0lKfv4kk/5Izdg=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "ab0f3607a6c7486ea22229b92ed2d355f1482ee0", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-unstable", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs-stable": { + "locked": { + "lastModified": 1751274312, + "narHash": "sha256-/bVBlRpECLVzjV19t5KMdMFWSwKLtb5RyXdjz3LJT+g=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "50ab793786d9de88ee30ec4e4c24fb4236fc2674", + "type": "github" + }, + "original": { + "owner": "NixOS", + "ref": "nixos-24.11", + "repo": "nixpkgs", + "type": "github" + } + }, + "nixpkgs_2": { + "locked": { + "lastModified": 1751792365, + "narHash": "sha256-J1kI6oAj25IG4EdVlg2hQz8NZTBNYvIS0l4wpr9KcUo=", "owner": "nixos", "repo": "nixpkgs", - "rev": "4aa36568d413aca0ea84a1684d2d46f55dbabad7", + "rev": "1fd8bada0b6117e6c7eb54aad5813023eed37ccb", "type": "github" }, "original": { @@ -89,17 +140,17 @@ "flake-compat": "flake-compat", "flake-utils": "flake-utils_2", "mirage-opam-overlays": "mirage-opam-overlays", - "nixpkgs": "nixpkgs", + "nixpkgs": "nixpkgs_2", "opam-overlays": "opam-overlays", "opam-repository": "opam-repository", "opam2json": "opam2json" }, "locked": { - "lastModified": 1736955560, - "narHash": "sha256-9I42xwKXH7h+jQGJQ8t797j/mWylIItIljRLm44CHS8=", + "lastModified": 1756988401, + "narHash": "sha256-S+zc1RYWZBGKnbrEWbyJ6fGt8ft/9d4BzpigSN2PpqE=", "owner": "tweag", "repo": "opam-nix", - "rev": "5f760f445d6693eb086327fa7d7ae8e43c906718", + "rev": "0c9c0e0c058dfb8de56adff612f2c776530f7f1e", "type": "github" }, "original": { @@ -111,11 +162,11 @@ "opam-overlays": { "flake": false, "locked": { - "lastModified": 1726822209, - "narHash": "sha256-bwM18ydNT9fYq91xfn4gmS21q322NYrKwfq0ldG9GYw=", + "lastModified": 1741116009, + "narHash": "sha256-Z0PIW82fHJFvAv/JYpAffnp2DaOjLhsPutqyIrORZd0=", "owner": "dune-universe", "repo": "opam-overlays", - "rev": "f2bec38beca4aea9e481f2fd3ee319c519124649", + "rev": "e031bb64e33bf93be963e9a38b28962e6e14381f", "type": "github" }, "original": { @@ -127,11 +178,11 @@ "opam-repository": { "flake": false, "locked": { - "lastModified": 1736935757, - "narHash": "sha256-LNkGSkZJXJmxpUd+luDUIIV/1B5MZIBMTB1qZqypa4o=", + "lastModified": 1756946712, + "narHash": "sha256-jo24cfjG/Yf1yPppKtL5ogjw6YBCMaMNsfkktRUm018=", "owner": "ocaml", "repo": "opam-repository", - "rev": "a8b00ead922e2049581ab16994586ed4ddbdb784", + "rev": "e28312d8e0d10f256ec9998ff7e868cb6e010778", "type": "github" }, "original": { @@ -145,14 +196,15 @@ "nixpkgs": [ "opam-nix", "nixpkgs" - ] + ], + "systems": "systems_3" }, "locked": { - "lastModified": 1671540003, - "narHash": "sha256-5pXfbUfpVABtKbii6aaI2EdAZTjHJ2QntEf0QD2O5AM=", + "lastModified": 1749457947, + "narHash": "sha256-+QVm+HOYikF3wUhqSIV8qJbE/feSG+p48fgxIosbHS0=", "owner": "tweag", "repo": "opam2json", - "rev": "819d291ea95e271b0e6027679de6abb4d4f7f680", + "rev": "0ecd66fc2bfb25d910522c990dd36412259eac1f", "type": "github" }, "original": { @@ -178,42 +230,43 @@ "type": "github" } }, - "prover_cvc5_1_0_9": { + "prover_cvc5_1_3_0": { "flake": false, "locked": { - "lastModified": 1702998934, - "narHash": "sha256-AwUQHFftn51Xt6HtmDsWAdkOS8i64r2FhaHu31KYwZA=", + "lastModified": 1750292852, + "narHash": "sha256-w8rIGPG9BTEPV9HG2U40A4DYYnC6HaWbzqDKCRhaT00=", "owner": "cvc5", "repo": "cvc5", - "rev": "8fca72aebcb5293434c3207dca081a845ff8d6fe", + "rev": "02c4e43d191f86b67a8a6d615544630a8df0f18e", "type": "github" }, "original": { "owner": "cvc5", - "ref": "cvc5-1.0.9", + "ref": "cvc5-1.3.0", "repo": "cvc5", "type": "github" } }, - "prover_z3_4_12_6": { + "prover_z3_4_14_1": { "flake": false, "locked": { - "lastModified": 1708814107, - "narHash": "sha256-X4wfPWVSswENV0zXJp/5u9SQwGJWocLKJ/CNv57Bt+E=", + "lastModified": 1741647008, + "narHash": "sha256-pTsDzf6Frk4mYAgF81wlR5Kb1x56joFggO5Fa3G2s70=", "owner": "z3prover", "repo": "z3", - "rev": "fa2c0e027894a8d55d2b841e27cbeecc99692a3f", + "rev": "3c0d786e6e86b6a10cbc14703c3f863c568b85dd", "type": "github" }, "original": { "owner": "z3prover", - "ref": "z3-4.12.6", + "ref": "z3-4.14.1", "repo": "z3", "type": "github" } }, "root": { "inputs": { + "emacs-overlay": "emacs-overlay", "flake-utils": "flake-utils", "nixpkgs": [ "opam-nix", @@ -221,23 +274,23 @@ ], "opam-nix": "opam-nix", "prover_cvc4_1_8": "prover_cvc4_1_8", - "prover_cvc5_1_0_9": "prover_cvc5_1_0_9", - "prover_z3_4_12_6": "prover_z3_4_12_6", + "prover_cvc5_1_3_0": "prover_cvc5_1_3_0", + "prover_z3_4_14_1": "prover_z3_4_14_1", "stable": "stable" } }, "stable": { "locked": { - "lastModified": 1717179513, - "narHash": "sha256-vboIEwIQojofItm2xGCdZCzW96U85l9nDW3ifMuAIdM=", + "lastModified": 1751290243, + "narHash": "sha256-kNf+obkpJZWar7HZymXZbW+Rlk3HTEIMlpc6FCNz0Ds=", "owner": "nixos", "repo": "nixpkgs", - "rev": "63dacb46bf939521bdc93981b4cbb7ecb58427a0", + "rev": "5ab036a8d97cb9476fbe81b09076e6e91d15e1b6", "type": "github" }, "original": { "owner": "nixos", - "ref": "24.05", + "ref": "release-24.11", "repo": "nixpkgs", "type": "github" } @@ -271,6 +324,21 @@ "repo": "default", "type": "github" } + }, + "systems_3": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } } }, "root": "root", diff --git a/flake.nix b/flake.nix index 77d38a85ff..d43245edca 100644 --- a/flake.nix +++ b/flake.nix @@ -4,22 +4,23 @@ flake-utils.url = "github:numtide/flake-utils"; - nixpkgs.url = "github:nixos/nixpkgs/24.05"; - stable.url = "github:nixos/nixpkgs/24.05"; + # nixpkgs.url = "github:nixos/nixpkgs/release-24.11"; + stable.url = "github:nixos/nixpkgs/release-24.11"; nixpkgs.follows = "opam-nix/nixpkgs"; + emacs-overlay.url = "github:nix-community/emacs-overlay"; prover_cvc4_1_8 = { url = "github:CVC4/CVC4-archived/1.8"; flake = false; }; - prover_cvc5_1_0_9 = { - url = "github:cvc5/cvc5/cvc5-1.0.9"; + prover_cvc5_1_3_0 = { + url = "github:cvc5/cvc5/cvc5-1.3.0"; flake = false; }; - prover_z3_4_12_6 = { - url = "github:z3prover/z3/z3-4.12.6"; + prover_z3_4_14_1 = { + url = "github:z3prover/z3/z3-4.14.1"; flake = false; }; }; @@ -40,7 +41,7 @@ }; query = devPackagesQuery // { - ocaml-base-compiler = "4.14.2"; + ocaml-base-compiler = "4.14.1"; }; scope = on.buildOpamProject' { } ./. query; @@ -54,9 +55,23 @@ ''; doNixSupport = false; }); - conf-pkg-config = prev.conf-pkg-config.overrideAttrs (oa: { - nativeBuildInputs = oa.nativeBuildInputs ++ [pkgs.pkg-config]; + conf-zlib = prev.conf-zlib.overrideAttrs (finalAttrs: prevAttrs: rec { + nativeBuildInputs = prevAttrs.nativeBuildInputs + ++ (with pkgs; [ pkg-config ]); }); + conf-git = prev.conf-git.overrideAttrs (finalAttrs: prevAttrs: rec { + nativeBuildInputs = prevAttrs.nativeBuildInputs + ++ (with pkgs; [ git ]); + buildInputs = prevAttrs.buildInputs + ++ (with pkgs; [ git ]); + }); + alt-ergo = prev.alt-ergo.overrideAttrs (finalAttrs: prevAttrs: rec { + nativeBuildInputs = prevAttrs.nativeBuildInputs + ++ (with pkgs; [ darwin.sigtool ]); + }); + frama-c = prev.frama-c.overrideAttrs (finalAttrs: prevAttrs: rec { + configureFlags = (prevAttrs.configureFlags or []) ++ ["--prefix=${prev.frama-c}/lib"]; + }); }; scope' = scope.overrideScope overlay; @@ -78,20 +93,51 @@ src = inputs."${"prover_" + pkg + "_" + builtins.replaceStrings ["."] ["_"] version}"; }); - mkAltErgo = version: - ((on.queryToScope { } (query // { alt-ergo = version; })).overrideScope overlay).alt-ergo; + mkAltErgo = version: (on.queryToScope { } (query // { alt-ergo = version; })).alt-ergo; + + devTools = + (let + overlays = [ (import inputs.emacs-overlay) ]; + pkgs = import nixpkgs { + inherit system overlays; + }; + in + (with pkgs; [ + (emacsWithPackagesFromUsePackage { + config = '' + (setq easycrypt-prog-name "ec.native") + (electric-indent-mode -1) + ''; + defaultInitFile = true; + alwaysEnsure = true; + package = pkgs.emacs; + extraEmacsPackages = epkgs: [ epkgs.proof-general ]; + }) + bashInteractive + git + difftastic + ]) + ++ + (with pkgs; + lib.optionals (!stdenv.isDarwin) [ perf-tools ]) + ); in rec { legacyPackages = scope'; packages = rec { - z3 = mkProverPackage "z3" "4.12.6"; + z3 = mkProverPackage "z3" "4.14.1"; cvc4 = mkProverPackage "cvc4" "1.8"; - cvc5 = mkProverPackage "cvc5" "1.0.9"; - altErgo = mkAltErgo "2.4.3"; + cvc5 = mkProverPackage "cvc5" "1.3.0"; + altErgo = mkAltErgo "2.4.2"; provers = pkgs.symlinkJoin { name = "provers"; - paths = [ altErgo z3 cvc4 cvc5 ]; + paths = [ + altErgo + z3 + # cvc4 + cvc5 + ]; }; with_provers = pkgs.symlinkJoin { @@ -102,12 +148,40 @@ default = main; }; - devShells.default = pkgs.mkShell { + devShells.barebones = pkgs.mkShell { inputsFrom = [ scope'.easycrypt ]; buildInputs = - devPackages - ++ [ pkgs.git scope'.why3 packages.provers ] - ++ (with pkgs.python3Packages; [ pyyaml ]); + devPackages + ++ [ scope'.why3 ] + ++ (with pkgs.python3Packages; [ pyyaml ]); }; + + devShells.noProvers = pkgs.mkShell rec { + inputsFrom = [ scope'.easycrypt ]; + buildInputs = + devPackages + ++ devTools + ++ [ scope'.why3 ] + ++ (with pkgs.python3Packages; [ pyyaml ]); + SHELL = ''${pkgs.bashInteractive + "/bin/bash"}''; + shellHook = builtins.replaceStrings ["\n"] [" "] '' + export SHELL=${SHELL} && + export PATH=$PATH:`realpath .` + ''; + }; + + devShells.withDevTools = pkgs.mkShell rec { + inputsFrom = [ scope'.easycrypt ]; + buildInputs = + devPackages + ++ devTools + ++ [ scope'.why3 packages.provers ] + ++ (with pkgs.python3Packages; [ pyyaml ]); + SHELL = ''${pkgs.bashInteractive + "/bin/bash"}''; + shellHook = builtins.replaceStrings ["\n"] [" "] '' + export SHELL=${SHELL} && + export PATH=$PATH:`realpath .` + ''; + }; }); } diff --git a/libs/lospecs/aig.ml b/libs/lospecs/aig.ml new file mode 100644 index 0000000000..8968f52c88 --- /dev/null +++ b/libs/lospecs/aig.ml @@ -0,0 +1,687 @@ +(* -------------------------------------------------------------------- *) +type name = int +[@@deriving yojson] + +(* -------------------------------------------------------------------- *) +type var = name * int +[@@deriving yojson] + +(* -------------------------------------------------------------------- *) +type node_r = + | False + | Input of var + | And of node * node +[@@deriving yojson] + +and node = { + gate : node_r; + id : int; + neg : node; +} +[@@deriving yojson] + +(* -------------------------------------------------------------------- *) +let fresh = + let counter = ref 0 in + fun () -> incr counter; !counter + +(* -------------------------------------------------------------------- *) +type reg = node array +[@@deriving yojson] + +(* -------------------------------------------------------------------- *) +module HCons : sig + val hashcons : node_r -> node + + val clear : unit -> unit +end = struct + module H = Weak.Make(struct + type t = node + + let hash (x : t) : int = + match x.gate with + | False -> + Hashtbl.hash False + | Input v -> + Hashtbl.hash v + | And (n1, n2) -> + Hashtbl.hash (abs n1.id, abs n2.id) + + let equal (n1 : node) (n2 : node) = + match n1.gate, n2.gate with + | False, False -> + true + | Input v1, Input v2 -> + v1 = v2 + | And (n1, m1), And (n2, m2) -> + n1 == n2 && m1 == m2 + | _, _ -> + false + end) + + let tag = ref 1 + + let htable = H.create 5003 + + let clear = fun () -> H.clear htable + + let hashcons (n : node_r) = + let rec pos = { gate = n; id = !tag; neg = neg; } + and neg = { gate = n; id = - !tag; neg = pos; } in + + let o = H.merge htable pos in + + if o == pos then incr tag; o +end + +(* -------------------------------------------------------------------- *) +let rec pp_node ?(input_namer : int -> string =string_of_int) (fmt : Format.formatter) (n : node) = + let pp_node = pp_node ~input_namer in + match n with + | { gate = False; id } when 0 < id -> + Format.fprintf fmt "⊥" + + | { gate = False; } -> + Format.fprintf fmt "⊤" + + | { gate = Input (n, i); id; } -> + let s = input_namer n in + Format.fprintf fmt "%s%s#%0.4x" + (if 0 < id then "" else "¬") s i + + | { gate = And (n1, n2); id; } when 0 < id -> + Format.fprintf fmt "(%a) ∧ (%a)" pp_node n1 pp_node n2 + + | { gate = And (n1, n2); } -> + Format.fprintf fmt "¬((%a) ∧ (%a))" pp_node n1 pp_node n2 + +(* -------------------------------------------------------------------- *) +let mk (n : node_r) : node = + HCons.hashcons n + +(* -------------------------------------------------------------------- *) +let false_ : node = + mk False + +(* -------------------------------------------------------------------- *) +let true_ : node = + false_.neg + +(* -------------------------------------------------------------------- *) +let input (i : var) : node = + mk (Input i) + +(* -------------------------------------------------------------------- *) +let constant (b : bool) : node = + if b then true_ else false_ + +(* -------------------------------------------------------------------- *) +let neg (n : node) : node = + n.neg + +(* -------------------------------------------------------------------- *) +let and_ (n1 : node) (n2 : node) : node = + match () with + | _ when n1 == n2 -> n1 + | _ when n1 == n2.neg -> false_ + | _ when n1 == false_ -> false_ + | _ when n2 == false_ -> false_ + | _ when n1 == true_ -> n2 + | _ when n2 == true_ -> n1 + | _ -> mk (And (n1, n2)) + +(* -------------------------------------------------------------------- *) +let nand (n1 : node) (n2 : node) : node = + neg (and_ n1 n2) + +(* -------------------------------------------------------------------- *) +let or_ (n1 : node) (n2 : node) : node = + nand (neg n1) (neg n2) + +(* -------------------------------------------------------------------- *) +let xor (n1 : node) (n2 : node) : node = + let n = nand n1 n2 in nand (nand n1 n) (nand n2 n) + +(* -------------------------------------------------------------------- *) +let xnor (n1 : node) (n2 : node) : node = + neg (xor n1 n2) + +(* -------------------------------------------------------------------- *) +let get_bit (b : bytes) (i : int) = + Char.code (Bytes.get b (i / 8)) lsr (i mod 8) land 0b1 <> 0 + +(* -------------------------------------------------------------------- *) +let env_of_regs (rs : bytes list) = + let rs = Array.of_list rs in + fun ((n, i) : var) -> get_bit rs.(n) i + +(* ==================================================================== *) +let map (env : var -> node option) : node -> node = + let cache : (int, node) Hashtbl.t = Hashtbl.create 0 in + + let rec doit (n : node) : node = + let mn = + match Hashtbl.find_option cache (abs n.id) with + | None -> + let mn = doit_r n.gate in + Hashtbl.add cache (abs n.id) mn; + mn + | Some mn -> + mn + in + if 0 < n.id then mn else neg mn + + and doit_r (n : node_r) = + match n with + | False -> + false_ + | Input v -> + Option.default (input v) (env v) + | And (n1, n2) -> + and_ (doit n1) (doit n2) + + in fun (n : node) -> doit n + +(* -------------------------------------------------------------------- *) +let maps (env : var -> node option) : reg -> reg = + fun r -> Array.map (map env) r + +(* ==================================================================== *) +let equivs (inputs : (var * var) list) (c1 : reg) (c2 : reg) : bool = + let inputs = Map.of_seq (List.to_seq inputs) in + let env (v : var) = Option.map input (Map.find_opt v inputs) in + Array.for_all2 (==) (maps env c1) c2 + +(* ==================================================================== *) +let eval (env : var -> bool) = + let cache : (int, bool) Hashtbl.t = Hashtbl.create 0 in + + let rec for_node (n : node) = + let value = + match Hashtbl.find_option cache (abs n.id) with + | None -> + let value = for_node_r n.gate in + Hashtbl.add cache (abs n.id) value; + value + | Some value -> + value + + in if 0 < n.id then value else not value + + and for_node_r (n : node_r) = + match n with + | False -> false + | Input x -> env x + | And (n1, n2) -> for_node n1 && for_node n2 + + in fun (n : node) -> for_node n + +(* -------------------------------------------------------------------- *) +let evals (env : var -> bool) = + List.map (eval env) + +(* -------------------------------------------------------------------- *) +let eval0 (n : node) = + eval (fun (_ : var) -> false) n + +(* ==================================================================== *) +module VarRange : sig + type 'a t + + val empty : 'a t + + val push : 'a t -> ('a * int) -> 'a t + + val contents : 'a t -> ('a * (int * int) list) list + + val pp : + (Format.formatter -> 'a -> unit) + -> Format.formatter + -> 'a t + -> unit +end = struct + type range = int * int + + type ranges = range list + + type 'a dep1 = 'a * ranges + + type 'a t = ('a, ranges) Map.t + + let empty : 'a t = + Map.empty + + let rec add (rg : ranges) (v : int) = + match rg with + | [] -> + [(v, v)] + + (* join two segments *) + | (lo, hi) :: (lo', hi') :: tl when hi+1 = v && v+1 = lo' -> + (lo, hi') :: tl + + (* add to the front of a segment *) + | (lo, hi) :: tl when v+1 = lo -> + (v, hi) :: tl + + (* add to the back of a segment *) + | (lo, hi) :: tl when hi+1 = v -> + (lo, v) :: tl + + | hd :: tl -> + hd :: add tl v + + let push (r : 'a t) ((n, i) : 'a * int) : 'a t = + let change (rg : ranges option) = + Some (add (Option.default [] rg) i) + in Map.modify_opt n change r + + let contents (r : 'a t) : ('a * ranges) list = + Map.bindings r + + let pp + (pp : Format.formatter -> 'a -> unit) + (fmt : Format.formatter) + (r : 'a t) + = + let pp_range (fmt : Format.formatter) ((lo, hi) : range) = + if lo = hi then + Format.fprintf fmt "%d" lo + else + Format.fprintf fmt "%d-%d" lo hi in + + let pp_ranges (fmt : Format.formatter) (rgs : ranges) = + Format.fprintf fmt "%a" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",") + pp_range) + rgs in + + let pp_dep1 (fmt : Format.formatter) ((v, rgs) : 'a dep1) = + Format.fprintf fmt "%a#%a" pp v pp_ranges rgs in + + Format.fprintf fmt "%a" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") + pp_dep1) + (Map.bindings r) +end + +(* ==================================================================== *) +let deps_ () = + let cache : (int, var Set.t) Hashtbl.t = Hashtbl.create 0 in + + let rec doit_force (n : node) = + match n.gate with + | False -> Set.empty + | Input v -> Set.singleton v + | And (n1, n2) -> Set.union (doit n1) (doit n2) + + and doit (n : node) = + match Hashtbl.find_option cache (abs n.id) with + | Some value -> + value + | None -> + let value = doit_force n in + Hashtbl.add cache (abs n.id) value; value + + in fun (n : node) -> doit n + +(* -------------------------------------------------------------------- *) +let deps (r : reg) = + let out = ref [] in + + let push (hi : int) (dhi : var Set.t) = + match !out with + | _ when Set.is_empty dhi -> + () + | ((lo, v), dlo) :: tl when v+1 = hi && not (Set.disjoint dlo dhi) -> + out := ((lo, hi), Set.union dlo dhi) :: tl + | _ -> + out := ((hi, hi), dhi) :: !out in + + Array.iteri push (Array.map (deps_ ()) r); + !out + |> List.rev_map (fun (r, vs) -> + let vs = + Set.fold + (fun v vs -> VarRange.push vs v) + vs VarRange.empty + in (r, vs) + ) + |> List.sort (fun (r1, _) (r2, _) -> compare r1 r2) + +exception AigerError of string + +(* -------------------------------------------------------------------- *) +(* SERIALIZATION *) +(* Return map of indice renaming + list of and gates (increasing order) + (max variable index, and gate count, input gate count) *) +let aiger_preprocess ~(input_count: int) (r: reg) : (node -> int) * (node list) * (int * int * int) = + let cache : (int, int) Hashtbl.t = Hashtbl.create 0 in + let count_and = ref 0 in + let and_gates = ref [] in + + let rec doit (n: node) : unit = + match Hashtbl.find_option cache (abs n.id) with + | Some v -> () + | None -> + let value = doit_force n in + Hashtbl.add cache (abs n.id) value + + and doit_force (n: node) = + match n.gate with + | False -> 0 + | Input (v, i) -> 64*v + i + | And (n1, n2) -> + doit n1; doit n2; + incr count_and; + and_gates := n::(!and_gates); + !count_and + in + + Array.iter doit r; + let and_cnt = !count_and in + let inp_cnt = input_count in + let id_map = + Hashtbl.to_seq cache |> Map.of_seq + in + let id_map = (function + | { gate = False; id } -> (if 0 < id then 0 else 1) + | { gate = And _; id } -> ((Map.find (abs id) id_map) + inp_cnt) lsl 1 + (if 0 < id then 0 else 1) + | { gate = Input _; id } -> (Map.find (abs id) id_map) lsl 1 + (if 0 < id then 0 else 1) + ) in + id_map, + List.sort (fun n1 n2 -> compare (id_map n1) (id_map n2)) !and_gates, + (and_cnt + inp_cnt, and_cnt, inp_cnt) + +let aiger_serialize_int (id: int) : string = + if not (id > 0) then raise (AigerError "serialize_int"); + let mask = 0x7f in + let rec doit (id: int) : int list = + if id < 0x80 then + [id] + else + ((id land mask) lor (0x80))::(doit (id lsr 7)) + in + + List.fold_left (fun acc id -> (Format.sprintf "%c" (char_of_int id)) ^ acc) "" (List.rev (doit id)) + +let pp_aiger_int fmt (id: int) : unit = + Format.fprintf fmt "%s" (aiger_serialize_int id) + +(* FIXME PR: Look at correction of this and after making sure it is correct *) +(* we can remove or do something else with the asserts *) +(* but they should not be triggered on a normal execution *) +let pp_aiger_and fmt ((gid, id1, id2): int * int * int) : unit = + if not (gid > id1 && id1 > id2) then Format.eprintf "gid : %d | id1: %d | id2: %d@." gid id1 id2; + assert (gid > id1 && id1 > id2); + let delta0 = gid - id1 in + let delta1 = id1 - id2 in + assert(delta0 > 0 && delta1 > 0); + assert(id1 = gid - delta0); + assert(gid - delta0 - delta1 = id2); + Format.fprintf fmt "%a%a" pp_aiger_int (gid - id1) pp_aiger_int (id1 - id2) + +(* + mvi -> Max Variable Index + agc -> And Gate Count + igc -> Input Gate Count + lgc -> Latch Gate Count + ogc -> Output Gate Count +*) +let write_aiger_bin + ~(input_count: int) + ?(inp_name_map : int -> string = fun (i: int) -> "inp" ^ (string_of_int i)) + oc + (r: reg) = + let aiger_id_of_node, and_gates, (mvi, agc, igc) = aiger_preprocess ~input_count r in + + let ogc = Array.length r in + let lgc = 0 in + Printf.fprintf oc "aig %d %d %d %d %d\n" mvi igc lgc ogc agc; + Array.iter (fun n -> Printf.fprintf oc "%d\n" (aiger_id_of_node n)) r; + List.iter (function + | { gate = And (n1, n2); } as n -> + let id = aiger_id_of_node n in + let id1 = aiger_id_of_node n1 in + let id2 = aiger_id_of_node n2 in + let id = id - (id land 1) in + let id1, id2 = if id1 > id2 then id1, id2 else id2, id1 in + Printf.fprintf oc "%s" (Format.asprintf "%a" pp_aiger_and (id, id1, id2)) + | _ -> assert false (* Should not be triggered *) + ) and_gates; + for i = 0 to igc-1 do + Printf.fprintf oc "i%d %s@\n" i (inp_name_map i) + done + +let write_aiger_bin_temp + ~(input_count: int) + ?(inp_name_map: (int -> string) option) + ?(name: string = "circuit") + (r: reg) = + let tf_name, tf_oc = Filename.open_temp_file ~mode:[Open_binary] name ".aig" in + let tf_oc = BatIO.output_channel ~cleanup:true tf_oc in + write_aiger_bin ~input_count ?inp_name_map tf_oc r; + tf_name + +(* Assumes inputs are already matched *) +let abc_check_equiv + ?(r1_name = "r1") + ?(r2_name = "r2") + ~(input_count: int) + ?(inp_name_map: (int -> string) option) + (r1: reg) (r2: reg) : bool = + + let tf1_name, tf1_oc = Filename.open_temp_file ~mode:[Open_binary] r1_name ".aig" in + let tf2_name, tf2_oc = Filename.open_temp_file ~mode:[Open_binary] r2_name ".aig" in + Format.eprintf "Created temp files (%s) (%s)!@." tf1_name tf2_name; + let tf1_oc = BatIO.output_channel ~cleanup:true tf1_oc in + let tf2_oc = BatIO.output_channel ~cleanup:true tf2_oc in + write_aiger_bin ~input_count ?inp_name_map tf1_oc r1; + write_aiger_bin ~input_count ?inp_name_map tf2_oc r2; + Format.eprintf "Wrote aig files!@."; + BatIO.close_out tf1_oc; BatIO.close_out tf2_oc; + let abc_command = Format.sprintf "cec %s %s" tf1_name tf2_name in + Format.eprintf "Abc command: %s@." abc_command; + let abc_output_c, abc_in = Unix.open_process "abc" in +(* let abc_in = BatIO.output_channel ~cleanup:true abc_in in *) + BatIO.write_string abc_in (abc_command ^ "\n"); + BatIO.close_out abc_in; +(* let abc_output_c = BatIO.input_channel ~autoclose:true ~cleanup:true abc_output_c in *) + (* FIXME: Get the actual output in all cases from abc *) + let re = Str.regexp {|.*Networks are equivalent.*|} in + Format.eprintf "Before read@."; + let abc_output = BatIO.read_all abc_output_c in + Format.eprintf "====== BEGIN ABC OUTPUT =====@.%s@.======= END ABC OUTPUT =====@." abc_output; + let abc_output = String.replace_chars (function | '\n' -> "|" | c -> String.of_char c) abc_output in + if Str.string_match re abc_output 0 then true else false + +(* -------------------------------------------------------------------- *) +exception InvalidWire + +(* -------------------------------------------------------------------- *) +(* true -> positive wire *) +let u2si (u : int) : bool * int = + if u < 0 then raise InvalidWire; + let s = (u land 0b1) = 0 in + let i = u lsr 1 in (* We divide by 2 *) + (s, i) + +(* -------------------------------------------------------------------- *) +let si2u ((b, i) : bool * int) : int = + assert (0 <= i); + (i lsl 1) lor (match b with true -> 0 | false -> 1) + +(* -------------------------------------------------------------------- *) +exception InvalidAIG of string + +(* -------------------------------------------------------------------- *) +(* Load an aig file *) +let load (inp : IO.input) : reg * (Set.String.t * string array) option = + let parse_asuint = + let re = Str.regexp "^[0-9]+$" in + + let doit (x : string) = + if not (Str.string_match re x 0) then + raise (InvalidAIG ("not a valid uint: " ^ x)); + int_of_string x (* FIXME: overflow *) + in fun x -> doit x in + + let header = String.trim (IO.read_line inp) in + let header = Str.split (Str.regexp "[ \t]+") header in + let header = Array.of_list header in + + if Array.length header <> 6 || header.(0) <> "aig" then + raise (InvalidAIG "invalid header"); + + let c_m = parse_asuint header.(1) in (* maximum variable index *) + let c_i = parse_asuint header.(2) in (* number of inputs *) + let c_l = parse_asuint header.(3) in (* number of latches *) + let c_o = parse_asuint header.(4) in (* number of outputs *) + let c_a = parse_asuint header.(5) in (* number of AND gates *) + + (* We have c_l = 0 so /\ c_m = c_i + c_l + c_a + * + * Hence: c_m = c_i + c_a + *) + + if c_m <> c_i + c_l + c_a || c_l <> 0 then + raise (InvalidAIG "invalid header (sum)"); + + let outputs = ref [] in + + (* Reading outputs *) + for _ = 1 to c_o do + let output = String.trim (IO.read_line inp) in + let (_, u) as output = u2si (parse_asuint output) in + + if not (0 <= u && u <= c_m) then + raise (InvalidAIG "invalid output"); + + outputs := output :: !outputs + done; + + let outputs = Array.of_list (List.rev !outputs) in + + (* Reading arguments of AND gate *) + let read_uint () = + let exception Done in + + let i, o = ref 0, ref 0 in + try + while true do + assert (!o < 4); + let d = IO.read_byte inp in + i := !i lor ((d land 0x7f) lsl (7 * !o)); + o := !o + 1; + if (d land 0x80) = 0 then + raise Done + done; + assert false + with Done -> !i + in + + + let gates = List.fold_left (fun map -> function + | 0 -> + Map.add 0 false_ map + + | i when 0 < i && i <= c_i -> + Map.add i (input (0, i-1)) map + + | i when c_i < i && i <= c_i + c_a -> + let delta0 = read_uint () in + let delta1 = read_uint () in + + if delta0 = 0 then + raise (InvalidAIG "invalid delta0"); + + (* delta0 = lhs - rhs0, delta1 = rhs0 - rhs1 *) + + let lhs = 2 * i in + let rhs0_ = lhs - delta0 in + let rhs1_ = rhs0_ - delta1 in + + if lhs = c_i*2 + 2 then + Format.eprintf "Lhs: %d | Rhs0: %d | Rhs1: %d@." lhs rhs0_ rhs1_; + + let (b1, u1) = try + u2si rhs0_ + with InvalidWire -> + Format.eprintf "Invalid wire for rhs0 for params: lhs: %d | rhs0: %d | rhs1: %d@." lhs rhs0_ rhs1_; assert false + in + let (b2, u2) = try + u2si rhs1_ + with InvalidWire -> + Format.eprintf "Invalid wire for rhs1 for params: lhs: %d | rhs0: %d | rhs1: %d@." lhs rhs0_ rhs1_; assert false + in + + let n1 = Map.find u1 map in + let n1 = if b1 then n1 else n1.neg in + let n2 = Map.find u2 map in + let n2 = if b2 then n2 else n2.neg in + + if not (u1 <= c_m && u2 <= c_m) then + raise (InvalidAIG "invalid delta1"); + + Map.add i (and_ n1 n2) map + + | _ -> + assert false + ) Map.empty (List.init (c_i + c_a + 1) (fun i -> i)) in + + (* Reading annotations *) + let ainputs = Array.make c_i None in + + begin try + while true do + let exception Continue in + + try + let line = String.trim (IO.read_line inp) in + + if line = "" then + raise Continue; + if line = "c" then + raise IO.No_more_input; + + if not ( + Str.string_match + (Str.regexp "^i\\([0-9]+\\)[ \t]+\\(.*\\)$") + line 0 + ) then raise (InvalidAIG ("invalid annotation: " ^ line)); + + let s = Str.matched_group 2 line in + let i = parse_asuint (Str.matched_group 1 line) in + + if not (i < c_i) then + raise (InvalidAIG "invalid annotation (index)"); + + if Option.is_some ainputs.(i) then + raise (InvalidAIG "invalid annotation (dup. index)"); + + ainputs.(i) <- Some s + + with Continue -> () + done + + with IO.No_more_input -> () end; + + let ainputs = + if Array.for_all Option.is_none ainputs then + None + else if Array.exists Option.is_none ainputs then + raise (InvalidAIG "invalid annotation (partial)") + else + let ainputs = Array.map Option.get ainputs in + let keys = Set.String.of_array ainputs in + + if Set.String.cardinal keys <> Array.length ainputs then + raise (InvalidAIG "invalid annotation (dup)"); + Some (keys, ainputs) + in + + (* Construct network *) + Array.map (fun (b, i) -> + if b then (Map.find i gates).neg else Map.find i gates + ) outputs, ainputs diff --git a/libs/lospecs/ast.ml b/libs/lospecs/ast.ml new file mode 100644 index 0000000000..7df7bd130e --- /dev/null +++ b/libs/lospecs/ast.ml @@ -0,0 +1,104 @@ +(* -------------------------------------------------------------------- *) +type symbol = Ptree.symbol [@@deriving yojson] + +(* FIXME PR: Maybe get a decl file to declare errors and other common things? *) +exception DestrError of string + +(* -------------------------------------------------------------------- *) +module Ident : sig + type ident [@@deriving yojson] + + val create : string -> ident + val name : ident -> string + val id : ident -> int +end = struct + type ident = symbol * int [@@deriving yojson] + + let create (x : string) : ident = (x, Oo.id (object end)) + let name ((x, _) : ident) : string = x + let id ((_, i) : ident) : int = i +end + +module IdentMap = Map.Make(struct + type t = Ident.ident + let compare a b = (Ident.id a) - (Ident.id b) +end) + +(* -------------------------------------------------------------------- *) +type ident = Ident.ident [@@deriving yojson] + +(* -------------------------------------------------------------------- *) +type aword = [ `W of int ] [@@deriving yojson] + +(* -------------------------------------------------------------------- *) +type atype = [ aword | `Signed | `Unsigned ] [@@deriving yojson] + +(* -------------------------------------------------------------------- *) +type aarg = ident * aword [@@deriving yojson] + +(* -------------------------------------------------------------------- *) +type aargs = aarg list [@@deriving yojson] + +(* -------------------------------------------------------------------- *) +type lr = [`L | `R] [@@deriving yojson] +type la = [`L | `A] [@@deriving yojson] +type us = [`U | `S] [@@deriving yojson] +type hl = [`H | `L] [@@deriving yojson] +type hld = [hl | `D] [@@deriving yojson] +type mulk = [`U of hld | `S of hld | `US] [@@deriving yojson] + +(* -------------------------------------------------------------------- *) +type aexpr_ = + | EVar of ident + | EInt of int + | ESlice of aexpr * (aexpr * int * int) + | EAssign of aexpr * (aexpr * int * int) * aexpr + | EApp of ident * aexpr list + | EMap of (aword * aword) * (aargs * aexpr) * aexpr list + | EConcat of aword * aexpr list + | ERepeat of aword * (aexpr * int) + | EShift of lr * la * (aexpr * aexpr) + | EExtend of us * aword * aexpr + | ESat of us * aword * aexpr + | ELet of (ident * aargs option * aexpr) * aexpr + | ECond of aexpr * (aexpr * aexpr) + | ENot of aword * aexpr + | EIncr of aword * aexpr + | EAdd of aword * [`Sat of us | `Word] * (aexpr * aexpr) + | ESub of aword * (aexpr * aexpr) + | EMul of mulk * aword * (aexpr * aexpr) + | EOr of aword * (aexpr * aexpr) + | EXor of aword * (aexpr * aexpr) + | EAnd of aword * (aexpr * aexpr) + | ECmp of aword * us * [`Gt | `Ge] * (aexpr * aexpr) + | EPopCount of aword * aexpr +[@@deriving yojson] + +and aexpr = { node : aexpr_; type_ : atype } [@@deriving yojson] + +(* -------------------------------------------------------------------- *) +type adef = { + name: string; + arguments : aargs; + body : aexpr; + rettype : aword; +} [@@deriving yojson] + +(* -------------------------------------------------------------------- *) +let atype_as_aword (ty : atype) = + match ty with `W n -> n | _ -> raise (DestrError "atype_as_aword") + +(* -------------------------------------------------------------------- *) +let get_size (`W w : aword) : int = + w + +(* -------------------------------------------------------------------- *) +let pp_aword (fmt : Format.formatter) (`W n : aword) = + Format.fprintf fmt "@%d" n + +(* -------------------------------------------------------------------- *) +let pp_atype (fmt : Format.formatter) (t : atype) = + match t with + | `W _ as w -> Format.fprintf fmt "%a" pp_aword w + | `Unsigned -> Format.fprintf fmt "%s" "unsigned" + | `Signed -> Format.fprintf fmt "%s" "signed" diff --git a/libs/lospecs/circuit.ml b/libs/lospecs/circuit.ml new file mode 100644 index 0000000000..65f699f5b1 --- /dev/null +++ b/libs/lospecs/circuit.ml @@ -0,0 +1,773 @@ +(* ==================================================================== *) +open Aig + +(* ==================================================================== *) +let rec log2 n = + if n <= 1 then 0 else 1 + log2 (n lsr 1) + +(* ==================================================================== *) +let sint_of_bools (bs : bool array) : int = + assert (Array.length bs <= Sys.int_size); + + let bs = + match Array.length bs with + | 0 -> + Array.make Sys.int_size false + | n -> + Array.append (Array.left bs (n - 1)) (Array.make (Sys.int_size - (n-1)) (bs.(n - 1))) + in + + Array.fold_lefti + (fun v i b -> if b then (1 lsl i) lor v else v) + 0 bs + +let split_at_arr (type t) (n: int) (r: t array) : t array * t array = + Array.sub r 0 n, Array.right r (Array.length r - n) + +(* -------------------------------------------------------------------- *) +let uint_of_bools (bs : bool array) : int = + assert (Array.length bs <= Sys.int_size - 1); + + Array.fold_lefti + (fun v i b -> if b then (1 lsl i) lor v else v) + 0 bs + +(* -------------------------------------------------------------------- *) +let int32_of_bools (bs : bool array) : int32 = + Array.fold_lefti + (fun v i b -> + if b then + Int32.logor (Int32.shift_left 1l i) v + else + v) + 0l bs + +let int64_of_bools (bs : bool array) : int64 = + Array.fold_lefti + (fun v i b -> + if b then + Int64.(logor (shift_left 1L i) v) + else + v) + 0L bs + +let ubigint_of_bools (bs: bool array) : Z.t = + Array.fold_right + (fun b acc -> + Z.(+) (Z.shift_left acc 1) (if b then Z.one else Z.zero)) + bs + Z.zero + +(* FIXME: Check this *) +let sbigint_of_bools (bs: bool array) : Z.t = + let bs = Array.rev bs in + let msb = bs.(0) in + Array.fold_left + (fun acc b -> + Z.(+) (Z.shift_left acc 1) (if b then Z.one else Z.zero)) + (if msb then Z.neg Z.one else Z.zero) + bs + +(* -------------------------------------------------------------------- *) +let explode (type t) ~(size : int) (r : t array) = + assert (Array.length r mod size == 0); + + Array.init ((Array.length r) / size) (fun i -> + Array.init size (fun j -> r.(i * size + j))) + + +(* -------------------------------------------------------------------- *) +let bytes_of_bools (bs : bool array) : bytes = + let bs = (Array.to_seq (explode ~size:8 bs)) in + let bs = Seq.map (uint_of_bools %> Char.chr) bs in + Bytes.of_seq bs + +(* -------------------------------------------------------------------- *) +let bools_of_reg (r: reg) : bool array = + Array.map (function + | { gate = False; id } when id > 0 -> false + | { gate = False; id } -> true + | _ -> raise (Invalid_argument "Can't convert non constant reg to bool array") + ) r + +let bool_list_of_reg : reg -> bool list = fun r -> bools_of_reg r |> Array.to_list + +(* -------------------------------------------------------------------- *) +let pp_reg_ ~(size : int) (fmt : Format.formatter) (r : bool array) = + assert (Array.length r mod (size * 4) = 0); + + let r = explode ~size:(size * 4) r in +(* let r = explode ~size:(size * 4) r in *) + let r = Array.map int32_of_bools r in + + Format.fprintf fmt "%a" + (fun fmt arr -> Array.iteri (fun i x -> + Format.fprintf fmt "%0.8lx" x; + if i < Array.length arr - 1 then + Format.fprintf fmt "_" + ) arr) + r + +let pp_reg ~(size: int) (fmt: Format.formatter) (r: reg) = + assert (size mod 4 = 0); + pp_reg_ ~size:(size / 4) fmt (bools_of_reg r) + +(* ==================================================================== *) +let bit ~(position : int) (v : int) : bool = + (v lsr position) land 0b1 <> 0 + +(* -------------------------------------------------------------------- *) +let bit32 ~(position : int) (v : int32) : bool = + let open Int32 in + logand (shift_right v position) 0b1l <> 0l + +(* -------------------------------------------------------------------- *) +let bit64 ~(position : int) (v : int64) : bool = + let open Int64 in + logand (shift_right v position) 0b1L <> 0L + +(* ==================================================================== *) +let of_int ~(size : int) (v : int) : reg = + Array.init size (fun i -> constant (bit ~position:i v)) + +(* -------------------------------------------------------------------- *) +let of_int32 (v : int32) : reg = + Array.init 32 (fun i -> constant (bit32 ~position:i v)) + +(* -------------------------------------------------------------------- *) +let of_int64 (v : int64) : reg = + Array.init 64 (fun i -> constant (bit64 ~position:i v)) + +(* -------------------------------------------------------------------- *) +let of_int32s (vs : int32 array) : reg = + Array.reduce Array.append (Array.map of_int32 vs) + +(* -------------------------------------------------------------------- *) +let of_bigint ~(size : int) (v : Z.t) : reg = + assert (0 <= Z.compare v Z.zero); + assert (Z.numbits v <= size); + Array.init size (fun i -> constant (Z.testbit v i)) + +(* FIXME: Check *) +let of_bigint_all ~(size : int) (v : Z.t) : reg = + let mod_ = Z.(lsl) Z.one (size) in + let v = Z.rem v mod_ in + let v = if Z.sign v < 0 then Z.add mod_ v else v in + of_bigint ~size v + +(* FIXME: Check *) +let of_bigint_repr_size (v : Z.t) : reg = + let size = Z.numbits v + (if Z.sign v <= 0 then 1 else 0) in + of_bigint_all ~size v + +let of_int_repr_size (v: int) : reg = + of_bigint_repr_size (Z.of_int v) + +(* -------------------------------------------------------------------- *) +let of_string ~(size : int) (s : string) : reg = + of_bigint ~size (Z.of_string s) + +(* ==================================================================== *) +let w8 (i : int) : reg = + of_int ~size:8 i + +(* -------------------------------------------------------------------- *) +let w16 (i : int) : reg = + of_int ~size:16 i + +(* -------------------------------------------------------------------- *) +let w32 (i : int32) : reg = + of_int32 i + +(* -------------------------------------------------------------------- *) +let w64 (i : int64) : reg = + of_int64 i + +(* -------------------------------------------------------------------- *) +let w128 (s : string) : reg = + of_string ~size:128 s + +(* -------------------------------------------------------------------- *) +let w256 (s : string) : reg = + of_string ~size:256 s + +(* ==================================================================== *) +let reg ~(size : int) ~(name : int) : reg = + Array.init size (fun i -> input (name, i)) + +(* ==================================================================== *) +let split_msb (r : reg) : node * reg = + let n = Array.length r in + let msb = r.(n-1) in + let r = Array.sub r 0 (n-1) in + msb, r + +(* ==================================================================== *) +let lnot_ (r : reg) : reg = + Array.map neg r + +(* -------------------------------------------------------------------- *) +let lor_ (r1 : reg) (r2 : reg) : reg = + Array.map2 or_ r1 r2 + +(* -------------------------------------------------------------------- *) +let lxor_ (r1 : reg) (r2 : reg) : reg = + Array.map2 xor r1 r2 + +(* -------------------------------------------------------------------- *) +let lxnor_ (r1 : reg) (r2 : reg) : reg = + Array.map2 xnor r1 r2 + +(* -------------------------------------------------------------------- *) +let land_ (r1 : reg) (r2 : reg) : reg = + Array.map2 and_ r1 r2 + +(* -------------------------------------------------------------------- *) +let ors (r : node array) : node = + Array.fold_left or_ false_ r + +(* -------------------------------------------------------------------- *) +let ands (r : node array) : node = + Array.fold_left and_ true_ r + +(* -------------------------------------------------------------------- *) +let lshift ~(offset : int) (r : reg) : reg = + Array.append (Array.make offset false_) r + +(* -------------------------------------------------------------------- *) +let uextend ~(size : int) (r : reg) : reg = + Array.append r @@ Array.make (max 0 (size - Array.length r)) false_ + +(* -------------------------------------------------------------------- *) +let sextend ~(size : int) (r : reg) : reg = + let lr = Array.length r in + + if size > lr then + match Array.length r with + | 0 -> + Array.make size false_ + | _ -> + Array.append r (Array.make (size - lr) (r.(lr - 1))) + else + r + +(* -------------------------------------------------------------------- *) +let trunc ~(size: int) (r: reg) : reg = + Array.sub r 0 size + +(* -------------------------------------------------------------------- *) +let mux2 (n1 : node) (n2 : node) (c : node) = + or_ (and_ (neg c) n1) (and_ c n2) + +(* -------------------------------------------------------------------- *) +let mux2_reg (r1 : reg) (r2 : reg) (c : node) = + assert (Array.length r1 = Array.length r2); + Array.map2 (fun n1 n2 -> mux2 n1 n2 c) r1 r2 + +(* -------------------------------------------------------------------- *) +let mux2_2 + ~(k00 : node) + ~(k01 : node) + ~(k10 : node) + ~(k11 : node) + ((c1, c2) : node * node) += + mux2 + (mux2 k00 k01 c2) + (mux2 k10 k11 c2) + c1 + +(* -------------------------------------------------------------------- *) +let mux2_2reg + ~(k00 : reg) + ~(k01 : reg) + ~(k10 : reg) + ~(k11 : reg) + ((c1, c2) : node * node) += + mux2_reg + (mux2_reg k00 k01 c2) + (mux2_reg k10 k11 c2) + c1 + +(* -------------------------------------------------------------------- *) +let mux_reg (cr : (node * reg) array) (r : reg) : reg = + Array.fold_right (fun (c, r) s -> mux2_reg s r c) cr r + +(* -------------------------------------------------------------------- *) +let ite (c : node) (t : reg) (f : reg) : reg = + mux2_reg f t c + +(* -------------------------------------------------------------------- *) +let c_rshift ~(lg2o : int) ~(sign : node) (c : node) (r : reg) = + let len = Array.length r in + let clamp = log2 len in + let s = + if lg2o > clamp then + Array.make len sign + else + let offset = 1 lsl lg2o in + Array.append (Array.sub r (min offset len) (len - (min offset len))) (Array.make (min offset len) sign) + in + Array.map2 (fun r1 s1 -> mux2 r1 s1 c) r s + +(* TODO: change array appends into inits *) + +(* -------------------------------------------------------------------- *) +let arshift ~(offset : int) (r : reg) = + let sign = if Array.length r = 0 then false_ else r.(Array.length r - 1) in + let l = Array.length r in + Array.append (Array.sub r (min offset l) (l - (min offset l))) (Array.make (min offset l) sign) + +(* -------------------------------------------------------------------- *) +let lsr_ (r as r0 : reg) (s : reg) : reg = + let _, r = + Array.fold_left (fun (i, r) c -> + (i+1, c_rshift ~lg2o:i ~sign:false_ c r) + ) (0, r) s + in assert (Array.length r = Array.length r0); r + +(* -------------------------------------------------------------------- *) +let lsl_ (r : reg) (s : reg) : reg = + Array.rev (lsr_ (Array.rev r) s) + +(* -------------------------------------------------------------------- *) +let asl_ (r : reg) (s : reg) : reg = + lsl_ r s + +(* -------------------------------------------------------------------- *) +let asr_ (r : reg) (s : reg) : reg = + let sign = + if Array.length r = 0 then false_ else r.(Array.length r - 1) + in + let _, r = + Array.fold_left (fun (i, r) c -> + (i+1, c_rshift ~lg2o:i ~sign c r) + ) (0, r) s + in r + +(* -------------------------------------------------------------------- *) +let shift ~(side : [`L | `R]) ~(sign : [`L | `A]) = + match side, sign with + | `L, `L -> lsl_ + | `R, `L -> lsr_ + | `L, `A -> asl_ + | `R, `A -> asr_ + + +(* -------------------------------------------------------------------- *) +let halfadder (a : node) (b : node) : node * node = + (and_ a b, xor a b) + +(* -------------------------------------------------------------------- *) +let incr (r : reg) : node * reg = + Array.fold_left_map halfadder true_ r + +(* -------------------------------------------------------------------- *) +let incrc (r : reg) : reg = + let c, r = incr r in Array.append r [|c|] + +(* -------------------------------------------------------------------- *) +let incr_dropc (r : reg) : reg = + snd (Array.fold_left_map halfadder true_ r) + +(* -------------------------------------------------------------------- *) +let opp (r : reg) : reg = + incr_dropc (lnot_ r) + +(* -------------------------------------------------------------------- *) +let fulladder (c : node) (a : node) (b : node) : node * node = + let c1, s = halfadder a b in + let c2, s = halfadder c s in + (or_ c1 c2, s) + +(* -------------------------------------------------------------------- *) +let addsub (m : node) (r1 : reg) (r2 : reg) : node * reg = + assert(Array.length r1 = Array.length r2); + + Array.fold_left_map + (fun carry (a, b) -> fulladder carry a (xor b m)) + m (Array.combine r1 r2) + +(* -------------------------------------------------------------------- *) +let add (r1 : reg) (r2 : reg) : node * reg = + addsub false_ r1 r2 + +(* -------------------------------------------------------------------- *) +let addc (r1 : reg) (r2 : reg) : reg = + let c, r = add r1 r2 in Array.append r [|c|] + +(* -------------------------------------------------------------------- *) +let add_dropc (r1 : reg) (r2 : reg) : reg = + snd (add r1 r2) + +(* -------------------------------------------------------------------- *) +let sub (r1 : reg) (r2 : reg) : node * reg = + addsub true_ r1 r2 + +(* -------------------------------------------------------------------- *) +let sub_dropc (r1 : reg) (r2 : reg) : reg = + snd (sub r1 r2) + +(* -------------------------------------------------------------------- *) +let bmul (n : node) (r : reg) : reg = + Array.map (fun n' -> and_ n n') r + +(* -------------------------------------------------------------------- *) +let umul (r1 : reg) (r2 : reg) : reg = + let n1 = Array.length r1 in + let n2 = Array.length r2 in + + let prods = Array.mapi (fun i n -> lshift ~offset:i (bmul n r2)) r1 in + + let out = Array.fold_left addc (Array.make n2 false_) prods in + let out = Array.sub out 0 (n1 + n2) in + + out + +(* -------------------------------------------------------------------- *) +let umul_ (r1 : reg) (r2 : reg) : reg * reg = + let n = Array.length r2 in + let r = umul r1 r2 in + + split_at_arr n r + +(* -------------------------------------------------------------------- *) +let umull (r1 : reg) (r2 : reg) : reg = + fst (umul_ r1 r2) + +(* -------------------------------------------------------------------- *) +let umulh (r1 : reg) (r2 : reg) : reg = + snd (umul_ r1 r2) + +(* -------------------------------------------------------------------- *) +let smul (r1 : reg) (r2 : reg) : reg = + let nm, (r1, r2) = + let n1 = Array.length r1 in + let n2 = Array.length r2 in + let nm = max n1 n2 in + + let r1 = sextend ~size:nm r1 in + let r2 = sextend ~size:nm r2 in + + (nm, (r1, r2)) in + + let sbmul_r2 (n : node) = + Array.mapi (fun i n' -> + let out = and_ n n' in + if i+1 = nm then neg out else out + ) r2 in + + let prods = Array.mapi (fun i n -> + let out = sbmul_r2 n in + let out = + match () with + | _ when i = 0 -> Array.append out [|true_|] + | _ when i+1 = nm -> Array.append (lnot_ out) [|true_|] + | _ -> Array.append out [|false_|] + in + lshift ~offset:i out + ) r1 in + + let out = Array.fold_left addc (Array.make (nm+1) false_) prods in + + Array.left out (2 * nm) + +(* -------------------------------------------------------------------- *) +let smul_ (r1 : reg) (r2 : reg) : reg * reg = + let nm = max (Array.length r1) (Array.length r2) in + let s = smul r1 r2 in + split_at_arr nm s + +(* -------------------------------------------------------------------- *) +let smull (r1 : reg) (r2 : reg) : reg = + fst (smul_ r1 r2) + +(* -------------------------------------------------------------------- *) +let smulh (r1 : reg) (r2 : reg) : reg = + snd (smul_ r1 r2) + +(* -------------------------------------------------------------------- *) +let ssat ~(size : int) (r : reg) : reg = + assert (0 < size); + assert (size < Array.length r); + + let rl, rh = split_at_arr (size - 1) r in + let rh, msb = Array.sub rh 0 (Array.length rh - 1), rh.(Array.length rh - 1) in + + let rm = Array.append (Array.make (size - 1) false_) [|true_ |] in + let rM = Array.append (Array.make (size - 1) true_ ) [|false_|] in + let ro = Array.append rl [|msb|] in + + let cm = and_ msb (neg (ands rh)) in + let cM = and_ (neg msb) (ors rh) in + + mux_reg [|(cm, rm); (cM, rM)|] ro + +(* -------------------------------------------------------------------- *) +let usat ~(size : int) (r : reg) : reg = + assert (size < Array.length r); + + let rl, rh = split_at_arr size r in + let rh, msb = Array.left rh (Array.length rh - 1), rh.(Array.length rh - 1) in + + let rm = Array.make size false_ in + let rM = Array.make size true_ in + let ro = rl in + + let cm = msb in + let cM = and_ (neg msb) (ors rh) in + + mux_reg [|(cm, rm); (cM, rM)|] ro + +(* -------------------------------------------------------------------- *) +let sat ~(signed : bool) ~(size : int) (r : reg) : reg = + match signed with + | true -> ssat ~size r + | false -> usat ~size r + +(* -------------------------------------------------------------------- *) +let ssadd (r1 : reg) (r2 : reg) : reg = + let n1 = Array.length r1 in + let n2 = Array.length r2 in + let n = max n1 n2 in + + let r1 = sextend ~size:(n+1) r1 in + let r2 = sextend ~size:(n+1) r2 in + + ssat ~size:n (add_dropc r1 r2) + +(* -------------------------------------------------------------------- *) +let usadd (r1 : reg) (r2 : reg) : reg = + let r = addc r1 r2 in + usat ~size:(Array.length r - 1) r + +(* -------------------------------------------------------------------- *) +let usmul (r1 : reg) (r2 : reg) : reg = + let n1 = Array.length r1 in + let n2 = Array.length r2 in + let nm = max n1 n2 in + + let r1 = uextend ~size:(2*nm) r1 in + let r2 = sextend ~size:(2*nm) r2 in + + smull r1 r2 + +(* -------------------------------------------------------------------- *) +let ugte (eq : node) (r1 : reg) (r2 : reg) : node = + let n1 = Array.length r1 in + let n2 = Array.length r2 in + let n = max n1 n2 in + let r1 = uextend ~size:n r1 in + let r2 = uextend ~size:n r2 in + + Array.fold_left (fun ct (c1, c2) -> + mux2_2 (c1, c2) + ~k00:ct + ~k01:Aig.false_ + ~k10:Aig.true_ + ~k11:ct + ) eq (Array.combine r1 r2) + +(* -------------------------------------------------------------------- *) +let sgte (eq : node) (r1 : reg) (r2 : reg) : node = + let msb1, r1 = split_msb r1 in + let msb2, r2 = split_msb r2 in + + mux2_2 (msb1, msb2) + ~k00:(ugte eq r1 r2) + ~k01:Aig.true_ + ~k10:Aig.false_ + ~k11:(ugte eq r1 r2) + +(* -------------------------------------------------------------------- *) +let bvueq (r1 : reg) (r2 : reg) : node = + let n1 = Array.length r1 in + let n2 = Array.length r2 in + let n = max n1 n2 in + let r1 = uextend ~size:n r1 in + let r2 = uextend ~size:n r2 in + + Array.fold_left (fun ct (c1, c2) -> + mux2_2 (c1, c2) + ~k00:ct + ~k01:Aig.false_ + ~k10:Aig.false_ + ~k11:ct + ) Aig.true_ (Array.combine r1 r2) + +(* -------------------------------------------------------------------- *) +let bvseq (r1 : reg) (r2 : reg) : node = + let n1 = Array.length r1 in + let n2 = Array.length r2 in + let n = max n1 n2 in + let r1 = sextend ~size:n r1 in + let r2 = sextend ~size:n r2 in + + Array.fold_left (fun ct (c1, c2) -> + mux2_2 (c1, c2) + ~k00:ct + ~k01:Aig.false_ + ~k10:Aig.false_ + ~k11:ct + ) Aig.true_ (Array.combine r1 r2) + +(* -------------------------------------------------------------------- *) +let ugt (r1 : reg) (r2 : reg) : node = + ugte Aig.false_ r1 r2 + +(* -------------------------------------------------------------------- *) +let uge (r1 : reg) (r2 : reg) : node = + ugte Aig.true_ r1 r2 + +(* -------------------------------------------------------------------- *) +let ult (r1: reg) (r2 : reg) : node = + ugt r2 r1 + +(* -------------------------------------------------------------------- *) +let ule (r1 : reg) (r2 : reg) : node = + uge r2 r1 + +(* -------------------------------------------------------------------- *) +let sgt (r1 : reg) (r2 : reg) : node = + sgte Aig.false_ r1 r2 + +(* -------------------------------------------------------------------- *) +let sge (r1 : reg) (r2 : reg) : node = + sgte Aig.true_ r1 r2 + +(* -------------------------------------------------------------------- *) +let slt (r1 : reg) (r2 : reg) : node = + sgt r2 r1 + +(* -------------------------------------------------------------------- *) +let sle (r1 : reg) (r2 : reg) : node = + sge r2 r1 + +(* -------------------------------------------------------------------- *) +let iszero (r : reg) : node = + bvueq r (Array.map (fun _ -> false_) r) + +(* -------------------------------------------------------------------- *) +let abs (a : reg) : reg = + let msb_a, _ = split_msb a in + ite (msb_a) (opp a) a + +(* -------------------------------------------------------------------- *) +let udiv_ (a : reg) (b : reg) : reg * reg = + assert (Array.length a >= Array.length b); + + let n = Array.length b in + + let pu (a : node) (b : node) (cin : node) : node * (node -> node) = + let cout, s = fulladder cin (neg b) a in + let out (cc : node) = mux2 a s cc in + (cout, out) + in + + let create_line (i : int) (d : node) (a : reg) : node * reg = + let a = Array.append [|d|] (if i = n then a else snd (split_msb a)) in + let b = if i < n then b else Array.append b [|Aig.false_|] in + + let c, pus = + Array.fold_left_map + (fun c (a, b) -> pu a b c) + Aig.true_ (Array.combine a b) + in (c, Array.map (fun pu -> pu c) pus) + in + + Array.fold_lefti (fun (q, a) i d -> + let q', a = create_line i d a in (Array.append [|q'|] q, a) + ) ([||], Array.make n false_) (Array.rev a) + +(* -------------------------------------------------------------------- *) +let udiv (a : reg) (b : reg) : reg = + let m = max (Array.length a) (Array.length b) in + let a = uextend ~size:m a in + let b = uextend ~size:m b in + ite (iszero b) a (fst (udiv_ a b)) + +(* -------------------------------------------------------------------- *) +let sdiv (s : reg) (t : reg) : reg = + let msb_s, _ = split_msb s in + let msb_t, _ = split_msb t in + + mux2_2reg + ~k00:( (udiv ( s) ( t))) + ~k10:(opp (udiv (opp s) ( t))) + ~k01:(opp (udiv ( s) (opp t))) + ~k11:( (udiv (opp s) (opp t))) + (msb_s, msb_t) + +(* -------------------------------------------------------------------- *) +let umod (a : reg) (b : reg) : reg = + let m = max (Array.length a) (Array.length b) in + let a = uextend ~size:m a in + let b = uextend ~size:m b in + + ite + (iszero b) + (Array.map (fun _ -> false_) b) + (uextend ~size:m (snd (udiv_ a b))) + +(* -------------------------------------------------------------------- *) +let srem (s : reg) (t : reg) : reg = + let msb_s, _ = split_msb s in + let msb_t, _ = split_msb t in + + mux2_2reg + ~k00:( (umod ( s) ( t))) + ~k10:(opp (umod (opp s) ( t))) + ~k01:(opp (umod ( s) (opp t))) + ~k11:( (umod (opp s) (opp t))) + (msb_s, msb_t) + +(* -------------------------------------------------------------------- *) +let smod (s : reg) (t : reg) : reg = + ite (iszero t) s @@ + let msb_s, _ = split_msb s in + let msb_t, _ = split_msb t in + + let u = umod (abs s) (abs t) in + + ite (iszero u) + u + (mux2_2reg + ~k00:( u ) + ~k10:(add_dropc (opp u) t) + ~k01:(add_dropc ( u) t) + ~k11:( (opp u) ) + (msb_s, msb_t)) + +(* -------------------------------------------------------------------- *) +let rol (r: reg) (s: reg) : reg = + let size = Array.length r in + let s = umod s (of_int ~size size) in (* so 0 <= s < size *) + let s = Array.left s size |> uextend ~size in (* by above, ln s < size *) + lor_ (shift ~side:`L ~sign:`L r s) (shift ~side:`R ~sign:`L r (sub_dropc (of_int ~size size) s)) + +(* -------------------------------------------------------------------- *) +let ror (r: reg) (s: reg) : reg = + let size = Array.length r in + let s = umod s (of_int ~size size) in (* so 0 <= s < size *) + let s = Array.left s size |> uextend ~size in (* by above, ln s < size *) + lor_ (shift ~side:`R ~sign:`L r s) (shift ~side:`L ~sign:`L r (sub_dropc (of_int ~size size) s)) + +(* -------------------------------------------------------------------- *) +let popcount ~(size : int) (r : reg) : reg = + Array.fold_left (fun aout node -> + ite node (incr_dropc aout) aout + ) (Array.make size Aig.false_) r + +(* -------------------------------------------------------------------- *) +(* Assumes input is array of 16 bit words *) +(* FIXME: Maybe do something a bit more principled here? *) +let compute ?(input_block_size = 16) ?(output_block_size = 16) (r: reg) (inp: int array) : int array = + assert (input_block_size <= 32); + let m = (1 lsl input_block_size) - 1 in + let inp = Array.map (fun i -> i land m) inp in + let inp = Array.map (of_int ~size:input_block_size) inp |> Array.reduce Array.append in + maps (function + | (0, i) -> Some (inp.(i)) + | _ -> None) r |> bools_of_reg |> explode ~size:output_block_size |> Array.map (uint_of_bools) + diff --git a/libs/lospecs/circuit.mli b/libs/lospecs/circuit.mli new file mode 100644 index 0000000000..6f923966a3 --- /dev/null +++ b/libs/lospecs/circuit.mli @@ -0,0 +1,171 @@ +(* ==================================================================== *) +open Aig + +(* ==================================================================== *) +val log2 : int -> int + +(* ==================================================================== *) +val explode : size:int -> 'a array -> 'a array array + +(* ==================================================================== *) +val sint_of_bools : bool array -> int + +val uint_of_bools : bool array -> int + +val bytes_of_bools : bool array -> bytes + +val ubigint_of_bools : bool array -> Z.t + +val sbigint_of_bools : bool array -> Z.t + +val bools_of_reg : reg -> bool array + +val bool_list_of_reg : reg -> bool list + +(* ==================================================================== *) +val of_int : size:int -> int -> reg + +val of_bigint : size:int -> Z.t -> reg + +val of_int32s : int32 array -> reg + +(* ==================================================================== *) +val w8 : int -> reg + +val w16 : int -> reg + +val w32 : int32 -> reg + +val w64 : int64 -> reg + +val w128 : string -> reg + +val w256 : string -> reg + +(* ==================================================================== *) +val mux2 : node -> node -> node -> node + +val mux2_reg : reg -> reg -> node -> reg + +val mux_reg : (node * reg) array -> reg -> reg + +val ite : node -> reg -> reg -> reg + +(* ==================================================================== *) +val reg : size:int -> name:int -> reg + +(* ==================================================================== *) +val uextend : size:int -> reg -> reg + +val sextend : size:int -> reg -> reg + +(* ==================================================================== *) +val lnot_ : reg -> reg + +val lor_ : reg -> reg -> reg + +val land_ : reg -> reg -> reg + +val lxor_ : reg -> reg -> reg + +val lxnor_ : reg -> reg -> reg + +val ors : node array -> node + +val ands : node array -> node + +(* ==================================================================== *) +val arshift : offset:int -> reg -> reg + +val lsl_ : reg -> reg -> reg + +val lsr_ : reg -> reg -> reg + +val asl_ : reg -> reg -> reg + +val asr_ : reg -> reg -> reg + +val shift : side:[`L | `R] -> sign:[`L | `A] -> reg -> reg -> reg + +val rol : reg -> reg -> reg + +val ror : reg -> reg -> reg + +(* ==================================================================== *) +val incr : reg -> node * reg + +val incr_dropc : reg -> reg + +val incrc : reg -> reg + +(* ==================================================================== *) +val add : reg -> reg -> node * reg + +val addc : reg -> reg -> reg + +val add_dropc : reg -> reg -> reg + +val ssadd : reg -> reg -> reg + +val usadd : reg -> reg -> reg + +(* ==================================================================== *) +val opp : reg -> reg + +val sub : reg -> reg -> node * reg + +val sub_dropc : reg -> reg -> reg + +(* ==================================================================== *) +val umul : reg -> reg -> reg + +val umull : reg -> reg -> reg + +val umulh : reg -> reg -> reg + +val smul : reg -> reg -> reg + +val smull : reg -> reg -> reg + +val smulh : reg -> reg -> reg + +val usmul : reg -> reg -> reg + +(* ==================================================================== *) +val ugte : node -> reg -> reg -> node + +val ugt : reg -> reg -> node + +val uge : reg -> reg -> node + +val sgte : node -> reg -> reg -> node + +val sgt : reg -> reg -> node + +val sge : reg -> reg -> node + +val bvueq : reg -> reg -> node + +val bvseq : reg -> reg -> node + +(* ==================================================================== *) +val sat : signed:bool -> size:int -> reg -> reg + +val udiv_ : reg -> reg -> reg * reg + +val udiv : reg -> reg -> reg + +val umod : reg -> reg -> reg + +val sdiv : reg -> reg -> reg + +val srem : reg -> reg -> reg + +val smod : reg -> reg -> reg + +(* ==================================================================== *) +val popcount : size:int -> reg -> reg + +val of_bigint_all : size:int -> Z.t -> reg + +val compute : ?input_block_size:int -> ?output_block_size:int -> reg -> int array -> int array diff --git a/libs/lospecs/circuit_spec.ml b/libs/lospecs/circuit_spec.ml new file mode 100644 index 0000000000..fca87e49b0 --- /dev/null +++ b/libs/lospecs/circuit_spec.ml @@ -0,0 +1,279 @@ +(* ==================================================================== *) +open Ast +open Aig + +(* ==================================================================== *) +let load_from_file ~(filename : string) = + let specs = File.with_file_in filename (Io.parse filename) in + let specs = Typing.tt_program Typing.Env.empty specs in + specs + +(* FIXME: Duplicated from circuit.ml *) +let split_at_arr (type t) (n: int) (r: t array) : t array * t array = + Array.sub r 0 n, Array.right r (Array.length r - n) + +exception CircuitSpecError of symbol (* FIXME PR: Rename? *) + +(* ==================================================================== *) +module Env : sig + type env + + val empty : env + + module Fun : sig + val get : env -> ident -> aargs * aexpr + + val bind : env -> ident -> aargs * aexpr -> env + end + + module Var : sig + val get : env -> ident -> reg + + val bind : env -> ident -> reg -> env + + val bindall : env -> (ident * reg) list -> env + end +end = struct + type binding = Var of reg | Fun of aargs * aexpr + + type env = (ident, binding) Map.t + + let empty : env = + Map.empty + + module Fun = struct + let get (env : env) (x : ident) = + match Map.find_opt x env with + | Some (Fun (a, f)) -> (a, f) + | _ -> raise Not_found + + let bind (env : env) (x : ident) ((a, f): aargs * aexpr) : env = + Map.add x (Fun (a, f)) env + end + + module Var = struct + let get (env : env) (x : ident) = + match Map.find_opt x env with + | Some (Var r) -> r + | _ -> raise Not_found + + let bind (env : env) (x : ident) (r: reg) : env = + Map.add x (Var r) env + + let bindall (env : env) (xr : (ident * reg) list) : env = + List.fold_left (fun env (x, r) -> bind env x r) env xr + end +end + +type env = Env.env + +(* ==================================================================== *) +let circuit_of_specification (rs : reg list) (p : adef) : reg = + assert (List.length rs = List.length p.arguments); + assert (List.for_all2 (fun r (_, `W n) -> Array.length r = n) rs p.arguments); + + let rec of_expr_ (env : env) (e : aexpr) : reg = + match e.node with + | EIncr (_, e) -> + Circuit.incr_dropc (of_expr env e) + + | EAdd (_, c, (e1, e2)) -> begin + let e1 = of_expr env e1 in + let e2 = of_expr env e2 in + match c with + | `Word -> Circuit.add_dropc e1 e2 + | `Sat `S -> Circuit.ssadd e1 e2 + | `Sat `U -> Circuit.usadd e1 e2 + end + + | ESub (_, (e1, e2)) -> + let e1 = of_expr env e1 in + let e2 = of_expr env e2 in + Circuit.sub_dropc e1 e2 + + | EMul (k, _, (e1, e2)) -> begin + let e1 = of_expr env e1 in + let e2 = of_expr env e2 in + + match k with + | `U `D -> Circuit.umul e1 e2 + | `U `H -> Circuit.umulh e1 e2 + | `U `L -> Circuit.umull e1 e2 + | `S `D -> Circuit.smul e1 e2 + | `S `H -> Circuit.smulh e1 e2 + | `S `L -> Circuit.umull e1 e2 + | `US -> Circuit.usmul e1 e2 + end + + | ECmp (`W _, us, k, (e1, e2)) -> + let e1 = of_expr env e1 in + let e2 = of_expr env e2 in + let c = + match us, k with + | `S, `Gt -> Circuit.sgt e1 e2 + | `S, `Ge -> Circuit.sge e1 e2 + | `U, `Gt -> Circuit.ugt e1 e2 + | `U, `Ge -> Circuit.uge e1 e2 + in [|c|] + + | ENot (_, e) -> + Circuit.lnot_ (of_expr env e) + + | EOr (_, (e1, e2)) -> + let e1 = of_expr env e1 in + let e2 = of_expr env e2 in + Circuit.lor_ e1 e2 + + | EXor (_, (e1, e2)) -> + let e1 = of_expr env e1 in + let e2 = of_expr env e2 in + Circuit.lxor_ e1 e2 + + | EAnd (_, (e1, e2)) -> + let e1 = of_expr env e1 in + let e2 = of_expr env e2 in + Circuit.land_ e1 e2 + + | EShift (lr, la, (e1, e2)) -> + let e1 = of_expr env e1 in + let e2 = of_expr env e2 in + Circuit.shift ~side:lr ~sign:la e1 e2 + + | ESat (us, `W size, e) -> begin + let e = of_expr env e in + match us with + | `U -> Circuit.sat ~signed:false ~size e + | `S -> Circuit.sat ~signed:true ~size e + end + + | EExtend (us, `W size, e) -> begin + let e = of_expr env e in + match us with + | `U -> Circuit.uextend ~size e + | `S -> Circuit.sextend ~size e + end + + | EPopCount (size, e) -> + Circuit.popcount ~size:(get_size size) (of_expr env e) + + | ESlice (e, ({ node = EInt offset }, size, scale)) -> + let e = of_expr env e in + let offset = offset * scale in + let size = size * scale in + Array.sub e offset size + + | ESlice (e, (offset, size, scale)) -> + let lgscale = Circuit.log2 scale in + assert (1 lsl lgscale = scale); + + let e = of_expr env e in + let offset = of_expr env offset in + + let offset = Array.append (Array.make lgscale Aig.false_) offset in + let size = size * scale in + + Array.left (Circuit.lsr_ e offset) size + + | EAssign (e, ({ node = EInt offset }, size, scale), v) -> + let e = of_expr env e in + let v = of_expr env v in + let offset = offset * scale in + let size = size * scale in + let pre, e = split_at_arr offset e in + let e, post = split_at_arr size e in + Array.append pre (Array.append v post) + + | EAssign (e, (offset, size, scale), v) -> + let esz = atype_as_aword e.type_ in + + let lgscale = Circuit.log2 scale in + assert (1 lsl lgscale = scale); + + let e = of_expr env e in + let offset = of_expr env offset in + let v = of_expr env v in + + let offset = Array.append (Array.make lgscale Aig.false_) offset in + let size = size * scale in + + let m = Array.make size Aig.true_ in + let m = Circuit.uextend ~size:esz m in + let m = Circuit.lnot_ (Circuit.lsl_ m offset) in + + let v = Circuit.uextend ~size:esz v in + let v = Circuit.lsl_ v offset in + + Circuit.lor_ (Circuit.land_ e m) v + + | EConcat (_, es) -> + Array.reduce Array.append (List.map (of_expr env) es |> Array.of_list) + + | ERepeat (_, (e, n)) -> + Array.reduce Array.append (Array.make n (of_expr env e)) + + | EMap ((`W n, _), (a, f), es) -> + let anames = List.map fst a in + let es = List.map (of_expr env) es in + let es = List.map (Circuit.explode ~size:n %> Array.to_list) es in + let es = List.transpose es |> Array.of_list in + + let es = es |> Array.map (fun es -> + let env = Env.Var.bindall env (List.combine anames es) in + of_expr env f + ) + + in Array.reduce Array.append es + + | EApp (f, args) -> + let a, f = Env.Fun.get env f in + let anames = List.map fst a in + let args = List.map (of_expr env) args in + let env = Env.Var.bindall env (List.combine anames args) in + of_expr env f + + | ELet ((x, None, v), e) -> + let v = of_expr env v in + of_expr (Env.Var.bind env x v) e + + | ELet ((x, Some a, v), e) -> + let env = Env.Fun.bind env x (a, v) in + of_expr env e + + | ECond (c, (e1, e2)) -> + let c = of_expr env c in + let e1 = of_expr env e1 in + let e2 = of_expr env e2 in + + Circuit.mux2_reg e2 e1 (Circuit.ors c) + + | EVar x -> + Env.Var.get env x + + | EInt i -> begin + match e.type_ with + | `W n -> Circuit.of_int ~size:n i + | _ -> raise (CircuitSpecError (Format.asprintf "Expected int got %a" pp_atype e.type_)) + end + + and of_expr (env : env) (e : aexpr) : reg = + let r = of_expr_ env e in + + begin + match e.type_ with + | `W n -> + if Array.length r <> n then begin + Format.eprintf "%d %d@." (Array.length r) n; + Format.eprintf "%a@." + (Yojson.Safe.pretty_print ~std:true) + (Ast.aexpr_to_yojson e); + raise (CircuitSpecError (Format.asprintf "Bitstring length mismatch (expected %d, got %d)" n (Array.length r))) + end + | _ -> () + end; r + in + + let env = + let bindings = List.combine (List.map fst p.arguments) rs in + Env.Var.bindall Env.empty bindings in + + of_expr env p.body diff --git a/libs/lospecs/circuit_spec.mli b/libs/lospecs/circuit_spec.mli new file mode 100644 index 0000000000..89a558c677 --- /dev/null +++ b/libs/lospecs/circuit_spec.mli @@ -0,0 +1,3 @@ +(* ==================================================================== *) +val circuit_of_specification : Aig.reg list -> Ast.adef -> Aig.reg +val load_from_file : filename:string -> (string * Ast.adef) list diff --git a/libs/lospecs/deps.ml b/libs/lospecs/deps.ml new file mode 100644 index 0000000000..89f478d7e2 --- /dev/null +++ b/libs/lospecs/deps.ml @@ -0,0 +1,200 @@ +open Aig + +module Hashtbl = Batteries.Hashtbl + +(* ------------------------------------------------------------------------------- *) +(* FIXME: CHECK THIS *) +let rec inputs_of_node : _ -> Aig.var Set.t = + let cache : (int, Aig.var Set.t) Hashtbl.t = Hashtbl.create 0 in + + let rec doit (n : Aig.node) : Aig.var Set.t = + match Hashtbl.find_option cache (Int.abs n.id) with + | None -> + let mn = doit_r n.gate in + Hashtbl.add cache (Int.abs n.id) mn; + mn + | Some mn -> + mn + + and doit_r (n : Aig.node_r) = + match n with + | False -> Set.empty + | Input v -> Set.singleton v + | And (n1, n2) -> Set.union (doit n1) (doit n2) + + in fun n -> doit n + +(* ------------------------------------------------------------------------------- *) +let inputs_of_reg (r : Aig.reg) : Aig.var Set.t = + Array.fold_left (fun acc x -> Set.union acc (inputs_of_node x)) Set.empty r + +(* tdeps : int -> int set ; dependency for a single output bit + i |-> {j | output depends on bit j of var i }*) +type tdeps = (int, int Set.t) Map.t +(* tdblock (n, d) = merged dependencies as above for n bits + aka, the tdep represents dependencies for n bits rather than 1 +*) +type tdblock = (int * tdeps) + + +let cache : (int, tdeps) Hashtbl.t = Hashtbl.create 5003 + +let reset_state : unit -> unit = fun () -> Hashtbl.reset cache + +(* ==================================================================== *) +let rec dep : _ -> tdeps = + let cache : (int, tdeps) Hashtbl.t = Hashtbl.create 0 in + + let rec doit (n: Aig.node) : tdeps = + match Hashtbl.find_option cache (Int.abs n.id) with + | None -> let mn = doit_r n.gate in + Hashtbl.add cache (Int.abs n.id) mn; + mn + | Some mn -> + mn + + and doit_r (n: Aig.node_r) = + match n with + | False -> Map.empty + | Input (v, i) -> Map.add v (Set.add i (Set.empty)) Map.empty + | And (n1, n2) -> Map.union_stdlib (fun k s1 s2 -> Some (Set.union s1 s2)) (doit n1) (doit n2) + + in (fun n -> + let res = doit n in + Hashtbl.clear cache; + res) + +let deps (n: reg) : tdeps array = + Array.map dep n + +let block_deps (d: tdeps array) : tdblock list = + let drop_while_count (f: 'a -> bool) (l: 'a list) : int * ('a list) = + let rec doit (n: int) (l: 'a list) = + match l with + | [] -> (n, []) + | a::l' -> if f a then doit (n+1) l' else (n, l) + in + let n, tl = doit 0 l in + (n, tl) + in + let rec decompose (l: tdeps list) : tdblock list = + match l with + | [] -> [] + | h::_ -> let n, l' = + (drop_while_count (fun a -> Map.equal (Set.equal) h a) l) in + (n, h)::(decompose l') + in + decompose (Array.to_list d) + +let blocks_indep ((_,b):tdblock) ((_,d):tdblock) : bool = + let keys = Set.intersect (Set.of_enum @@ Map.keys b) (Set.of_enum @@ Map.keys d) in + let intersects = Set.map (fun k -> + let b1 = Map.find k b in + let d1 = Map.find k d in + (Set.cardinal @@ Set.intersect b1 d1) = 0 + ) keys in + Set.fold (&&) intersects true + +let block_list_indep (bs: tdblock list) : bool = + let rec doit (bs: tdblock list) (acc: tdblock list) : bool = + match bs with + | [] -> true + | b::bs -> List.for_all (blocks_indep b) acc && doit bs (b::acc) + in + doit bs [] + +let merge_deps (d1: tdeps) (d2: tdeps) : tdeps = + Map.union_stdlib (fun _ a b -> Option.some (Set.union a b)) d1 d2 + +let split_deps (n: int) (d: tdeps array) : tdblock list = + assert (Array.length d mod n = 0); + let combine (d: tdeps list) : tdeps = + List.reduce merge_deps d + in + let rec aggregate (acc: tdblock list) (d: tdeps array) : tdblock list = + match d with + | [| |] -> acc + | _ -> (aggregate ((n, combine (Array.head d n |> Array.to_list))::acc) (Array.tail d n)) + in + List.rev @@ aggregate [] d + +let check_dep_width ?(eq=false) (n: int) (d: tdeps) : bool = + Map.fold (fun s acc -> let m = (Set.cardinal s) in + if eq then + acc && (n = m) + else + acc && (m <= n) + ) d true + +(* maybe optimize this? *) +let tdblock_of_tdeps (d: tdeps list) : tdblock = + (List.length d, List.reduce merge_deps d) + +(* + Take a list of blocks and drop all but the first block if the + sizes are the same and the dependecy amounts are the same +*) +let compare_dep_size (a: tdeps) (b: tdeps) : bool = + (Map.fold (fun s acc -> acc + (Set.cardinal s)) a 0) = + (Map.fold (fun s acc -> acc + (Set.cardinal s)) b 0) + +let compare_tdblocks ((na, da): tdblock) ((nb, db): tdblock) : bool = + (na = nb) && compare_dep_size da db + +let collapse_blocks (d: tdblock list) : tdblock option = + match d with + | [] -> None + | h::t -> + List.fold_left + (fun a b -> + match a with + | None -> None + | Some a -> if compare_tdblocks a b + then Some a else None) + (Some h) t + +(* -------------------------------------------------------------------- *) +(* Uses dependency analysis to realign inputs to start at 0 *) +(* Corresponds to taking the relevant subcircuit to this output *) +(* Assumes that inputs are contiguous FIXME *) +let realign_inputs ?(renamings: (int -> int option) option) (n: node) : node * (int, int * int) Map.t = + let d = dep n in + let shifts = Map.map (fun s -> + Set.min_elt_opt s |> Option.default 0, + Set.max_elt_opt s |> Option.default 0 + ) d in + let map_ = + match renamings with + | Some renamings -> begin fun (v, i) -> + let v' = renamings v |> Option.default v in + match Map.find_opt v shifts with + | None -> None + | Some (k, _) -> Some (Aig.input (v', i-k)) + end + | None -> begin fun (v, i) -> + match Map.find_opt v shifts with + | None -> None + | Some (k, _) -> Some (Aig.input (v, i-k)) + end + in + let shifts = match renamings with + | None -> shifts + | Some renamings -> + Map.to_seq shifts |> Seq.map (fun (k, v) -> + Option.default k (renamings k), v) |> Map.of_seq + in + Aig.map map_ n, shifts + +let pp_dep ?(namer = string_of_int) (fmt : Format.formatter) (d: tdeps) : unit = + let print_set fmt s = Set.iter (Format.fprintf fmt "%d ") s in + Map.iter (fun id ints -> Format.fprintf fmt "%s: %a@." (namer id) print_set ints) d + +let pp_deps ?(namer = string_of_int) (fmt: Format.formatter) (ds: tdeps list) : unit = + List.iteri (fun i d -> Format.fprintf fmt "Output #%d:@.%a@." i (pp_dep ~namer) d) ds + +let pp_bdep ?(start_index = 0) ?(oname="") ?(namer=string_of_int) (fmt: Format.formatter) ((n, d): tdblock) : unit = + Format.fprintf fmt "[%d-%d]%s:@." start_index (start_index+n-1) oname; + pp_dep ~namer fmt d + +let pp_bdeps ?(oname="") ?(namer=string_of_int) (fmt: Format.formatter) (bs: tdblock list) : unit = + List.fold_left (fun acc (n,d) -> (pp_bdep ~start_index:acc ~oname ~namer fmt (n,d)); acc + n) 0 bs |> ignore diff --git a/libs/lospecs/deps.ml.bck b/libs/lospecs/deps.ml.bck new file mode 100644 index 0000000000..e9a77fe708 --- /dev/null +++ b/libs/lospecs/deps.ml.bck @@ -0,0 +1,196 @@ +(* -------------------------------------------------------------------- *) +open Ast + +(* -------------------------------------------------------------------- *) +type symbol = string + +(* -------------------------------------------------------------------- *) +type dep1 = Set.Int.t IdentMap.t +type deps = dep1 Map.Int.t + +(* -------------------------------------------------------------------- *) +let eq_dep1 (d1 : dep1) (d2 : dep1) : bool = + IdentMap.equal Set.Int.equal d1 d2 + +(* -------------------------------------------------------------------- *) +let eq_deps (d1 : deps) (d2 : deps) : bool = Map.Int.equal eq_dep1 d1 d2 + +(* -------------------------------------------------------------------- *) +let empty ~(size : int) : deps = + 0 --^ size |> Enum.map (fun i -> (i, IdentMap.empty)) |> Map.Int.of_enum + +(* -------------------------------------------------------------------- *) +let enlarge ~(min : int) ~(max : int) (d : deps) : deps = + let change = function None -> Some IdentMap.empty | Some _ as v -> v in + + min --^ max |> Enum.fold (fun d i -> Map.Int.modify_opt i change d) d + +(* -------------------------------------------------------------------- *) +let clearout ~(min : int) ~(max : int) (d : deps) : deps = + Map.Int.filter_map + (fun i d1 -> Some (if min <= i && i < max then d1 else IdentMap.empty)) + d + +(* -------------------------------------------------------------------- *) +let restrict ~(min : int) ~(max : int) (d : deps) : deps = + Map.Int.filter (fun i _ -> min <= i && i < max) d + +(* -------------------------------------------------------------------- *) +let recast ~(min : int) ~(max : int) (d : deps) : deps = + d |> restrict ~min ~max |> enlarge ~min ~max + +(* -------------------------------------------------------------------- *) +let merge1 (d1 : dep1) (d2 : dep1) : dep1 = + IdentMap.merge + (fun _ i1 i2 -> + Some (Set.Int.union (i1 |? Set.Int.empty) (i2 |? Set.Int.empty))) + d1 d2 + +(* -------------------------------------------------------------------- *) +let merge (d1 : deps) (d2 : deps) : deps = + Map.Int.merge + (fun _ m1 m2 -> + Some (merge1 (m1 |? IdentMap.empty) (m2 |? IdentMap.empty))) + d1 d2 + +(* -------------------------------------------------------------------- *) +let merge1_all (ds : dep1 Enum.t) : dep1 = Enum.reduce merge1 ds + +(* -------------------------------------------------------------------- *) +let merge_all (ds : deps Enum.t) : deps = Enum.reduce merge ds + +(* -------------------------------------------------------------------- *) +let copy ~(offset : int) ~(size : int) (x : ident) : deps = + 0 --^ size + |> Enum.map (fun i -> + let di = IdentMap.singleton x (Set.Int.singleton (i + offset)) in + (i, di)) + |> Map.Int.of_enum + +(* -------------------------------------------------------------------- *) +let chunk ~(csize : int) ~(count : int) (d : deps) : deps = + 0 --^ count + |> Enum.map (fun ci -> + let d1 = + 0 --^ csize + |> Enum.map (fun i -> i + (ci * csize)) + |> Enum.map (fun i -> Map.Int.find_opt i d |> Option.default IdentMap.empty) + |> merge1_all + in + 0 --^ csize |> Enum.map (fun i -> (i + (ci * csize), d1))) + |> Enum.flatten |> Map.Int.of_enum + +(* -------------------------------------------------------------------- *) +let perm ~(csize : int) ~(perm : int list) (d : deps) : deps = + List.enum perm + |> Enum.mapi (fun ci x -> + Enum.map + (fun i -> (i + (ci * csize), Map.Int.find_opt (i + (x * csize)) d |> Option.default IdentMap.empty)) + (0 --^ csize)) + |> Enum.flatten |> Map.Int.of_enum + +(* -------------------------------------------------------------------- *) +let collapse ~(csize : int) ~(count : int) (d : deps) : deps = + 0 --^ count + |> Enum.map (fun ci -> + let d1 = + 0 --^ csize + |> Enum.map (fun i -> i + (ci * csize)) + |> Enum.map (fun i -> Map.Int.find_opt i d |> Option.default IdentMap.empty) + |> merge1_all + in + (ci, d1)) + |> Map.Int.of_enum + +(* -------------------------------------------------------------------- *) +let merge_all_deps (d : deps) : dep1 = + Map.Int.enum d |> Enum.map snd |> merge1_all + +(* -------------------------------------------------------------------- *) +let constant ~(size : int) (d : dep1) : deps = + 0 --^ size |> Enum.map (fun i -> (i, d)) |> Map.Int.of_enum + +(* -------------------------------------------------------------------- *) +let offset ~(offset : int) (d : deps) : deps = + Map.Int.enum d |> Enum.map (fun (i, x) -> (i + offset, x)) |> Map.Int.of_enum + +(* -------------------------------------------------------------------- *) +let split ~(csize : int) ~(count : int) (d : deps) : deps Enum.t = + 0 --^ count + |> Enum.map (fun i -> + Map.Int.filter (fun x _ -> csize * i <= x && x < csize * (i + 1)) d + |> offset ~offset:(-i * csize)) + +(* -------------------------------------------------------------------- *) +let aggregate ~(csize : int) (ds : deps Enum.t) = + Enum.foldi + (fun i d1 d -> merge (offset ~offset:(i * csize) d1) d) + (empty ~size:0) ds + +(* ==================================================================== *) +type 'a pp = Format.formatter -> 'a -> unit + +(* -------------------------------------------------------------------- *) +let pp_bitset (fmt : Format.formatter) (d : Set.Int.t) = + Format.fprintf fmt "{%a}" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") + Format.pp_print_int) + (Set.Int.elements d) + +(* -------------------------------------------------------------------- *) +let pp_bitintv (fmt : Format.formatter) (d : (int * int) list) = + Format.fprintf fmt "%a" + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") + (fun fmt (i, j) -> Format.fprintf fmt "[%d..%d](%d)" i j (j - i + 1))) + d + +(* -------------------------------------------------------------------- *) +let bitintv_of_bitset (d : Set.Int.t) = + let aout = ref [] in + let current = ref None in + + d + |> Set.Int.iter (fun i -> + match !current with + | None -> current := Some (i, i) + | Some (v1, v2) -> + if i = v2 + 1 then current := Some (v1, i) + else ( + aout := (v1, v2) :: !aout; + current := Some (i, i))); + + Option.may (fun (v1, v2) -> aout := (v1, v2) :: !aout) !current; + + List.rev !aout + +(* -------------------------------------------------------------------- *) +let pp_dep1 (fmt : Format.formatter) (d : dep1) = + IdentMap.iter + (fun x bits -> + Format.fprintf fmt "%s.%d -> %a@\n" (Ident.name x) (Ident.id x) pp_bitintv (bitintv_of_bitset bits)) + d + +(* -------------------------------------------------------------------- *) +let pp_deps (fmt : Format.formatter) (d : deps) = + let display (v1, v2, d) = + Format.fprintf fmt "[%d..%d](%d) -> @[@\n%a@]@\n" v1 v2 + (v2 - v1 + 1) + pp_dep1 d + in + + let current = ref None in + + Map.Int.iter + (fun i d -> + match !current with + | None -> current := Some (i, i, d) + | Some (v1, v2, d') -> + if i = v2 + 1 && eq_dep1 d d' then current := Some (v1, i, d') + else ( + display (v1, v2, d'); + current := Some (i, i, d))) + d; + + Option.may display !current diff --git a/libs/lospecs/deps.mli.bck b/libs/lospecs/deps.mli.bck new file mode 100644 index 0000000000..7bdad64d48 --- /dev/null +++ b/libs/lospecs/deps.mli.bck @@ -0,0 +1,35 @@ +open Ast + +(* -------------------------------------------------------------------- *) +type symbol = string +type dep1 = Set.Int.t IdentMap.t +type deps = dep1 Map.Int.t + +(* -------------------------------------------------------------------- *) +val empty : size:int -> deps +val enlarge : min:int -> max:int -> deps -> deps +val clearout : min:int -> max:int -> deps -> deps +val restrict : min:int -> max:int -> deps -> deps +val recast : min:int -> max:int -> deps -> deps +val merge1 : dep1 -> dep1 -> dep1 +val merge : deps -> deps -> deps +val merge1_all : dep1 Enum.t -> dep1 +val merge_all : deps Enum.t -> deps +val copy : offset:int -> size:int -> ident -> deps +val chunk : csize:int -> count:int -> deps -> deps +val perm : csize:int -> perm:int list -> deps -> deps +val collapse : csize:int -> count:int -> deps -> deps +val merge_all_deps : deps -> dep1 +val constant : size:int -> dep1 -> deps +val offset : offset:int -> deps -> deps +val split : csize:int -> count:int -> deps -> deps Enum.t +val aggregate : csize:int -> deps Enum.t -> deps + +(* -------------------------------------------------------------------- *) +type 'a pp = Format.formatter -> 'a -> unit + +val bitintv_of_bitset : Set.Int.t -> (int * int) list +val pp_bitset : Set.Int.t pp +val pp_bitintv : (int * int) list pp +val pp_dep1 : dep1 pp +val pp_deps : deps pp diff --git a/libs/lospecs/dune b/libs/lospecs/dune new file mode 100644 index 0000000000..a723995e61 --- /dev/null +++ b/libs/lospecs/dune @@ -0,0 +1,15 @@ +(library + (name lospecs) + (public_name easycrypt.lospecs) + (flags + (:standard -open Batteries)) + (preprocess + (pps ppx_deriving_yojson)) + (libraries batteries bitwuzla menhirLib zarith)) + +(ocamllex lexer) + +(menhir + (modules parser) + (explain true) + (flags --table)) diff --git a/libs/lospecs/io.ml b/libs/lospecs/io.ml new file mode 100644 index 0000000000..dff9a0193c --- /dev/null +++ b/libs/lospecs/io.ml @@ -0,0 +1,38 @@ +(* -------------------------------------------------------------------- *) +open Ptree + +(* -------------------------------------------------------------------- *) +let parse (name : string) (input : IO.input) : Ptree.pprogram = + let lexbuf = Lexing.from_channel input in + Lexing.set_filename lexbuf name; + Parser.program Lexer.main lexbuf + +(* -------------------------------------------------------------------- *) +let print_source_for_range (fmt : Format.formatter) (range : range) (name : string) = + let lines = File.lines_of name in + let nlines = Enum.count lines in + + let begin_ = fst range.rg_begin - 1 in + let end_ = fst range.rg_end in + + let ctxt = 2 in + let ctxt_s = max 0 (begin_ - ctxt) in + let ctxt_e = min nlines (end_ + ctxt) in + + let lines = Enum.skip ctxt_s lines in + let lines = Enum.take (ctxt_e - ctxt_s) lines in + + let sz = int_of_float (ceil (log10 (float_of_int end_ +. 1.))) in + + begin + let doline (i : int) = Format.sprintf "%d---------" i in + Format.fprintf fmt "%*s | %s@." + sz "" + (String.concat "" (List.map doline (List.init 7 identity))); + end; + Enum.iteri + (fun i line -> + let lineno = ctxt_s + i in + let mark = if begin_ <= lineno && lineno < end_ then ">" else " " in + Format.fprintf fmt "%*d %s| %s@." sz (lineno + 1) mark line) + lines diff --git a/libs/lospecs/lexer.mll b/libs/lospecs/lexer.mll new file mode 100644 index 0000000000..21346fa2ad --- /dev/null +++ b/libs/lospecs/lexer.mll @@ -0,0 +1,75 @@ +{ + open Parser + + let keywords = [ + ("fun" , FUN ); + ("let" , LET ); + ("in" , IN ); + ] + + let keywords = + let table = Hashtbl.create 0 in + List.iter (fun (x, k) -> Hashtbl.add table x k) keywords; + table +} + +let lower = ['a'-'z'] +let upper = ['A'-'Z'] +let alpha = lower | upper +let digit = ['0'-'9'] +let hexdigit = digit | ['a'-'f'] | ['A'-'F'] +let alnum = alpha | digit + +let ident = (alpha | '_') (alnum | '_')* + +let decnum = digit+ +let hexnum = "0x" hexdigit+ + +let whitespace = [' ' '\t' '\r'] + +rule main = parse + | '<' { LT } + | '>' { GT } + | '(' { LPAREN } + | ')' { RPAREN } + | '[' { LBRACKET } + | ']' { RBRACKET } + | '@' { AT } + | "<-" { LARROW } + | "->" { RARROW } + | ',' { COMMA } + | '=' { EQUAL } + | ':' { COLON } + | '.' { DOT } + | '|' { PIPE } + | '?' { QMARK } + + | ident as x + { Hashtbl.find_default keywords x (IDENT x) } + + | decnum as d + { NUMBER (int_of_string d) } + + | hexnum as d + { NUMBER (int_of_string d) } + + | whitespace+ + { main lexbuf } + + | '\n' + { Lexing.new_line lexbuf; main lexbuf } + + | '#' [^'\n']* + { main lexbuf } + +(* DEBUG FEATURE: for binary searching for syntax errors + to be switched for better error output *) + | '^' _* + { main lexbuf } + + | eof + { EOF } + + | _ { + raise (Ptree.ParseError (Ptree.Lc.of_lexbuf lexbuf)) + } diff --git a/libs/lospecs/parser.mly b/libs/lospecs/parser.mly new file mode 100644 index 0000000000..dad00ee271 --- /dev/null +++ b/libs/lospecs/parser.mly @@ -0,0 +1,148 @@ +%{ + open Ptree + + let string_of_position ((p1, p2) : Lexing.position * Lexing.position) = + Format.sprintf "%d.%d:%d.%d" + p1.pos_lnum (p1.pos_cnum - p1.pos_bol + 1) + p2.pos_lnum (p2.pos_cnum - p2.pos_bol + 1) +%} + +%token AT +%token COLON +%token COMMA +%token DOT +%token EOF +%token EQUAL +%token FUN +%token GT +%token LARROW +%token LBRACKET +%token LET +%token LPAREN +%token LT +%token IN +%token PIPE +%token QMARK +%token RARROW +%token RBRACKET +%token RPAREN + +%token IDENT +%token NUMBER + +%type program + +%start program + +%nonassoc below_TERNARY +%left QMARK +%left COLON + +%% + +%inline vname: +| x=loc(IDENT) + { x } + +%inline wname: +| x=vname t=wtype + { (x, t) } + +%inline wtype_: +| AT x=NUMBER + { `W x } + +%inline wtype: +| w=loc(wtype_) { w } + +fname_: +| f=loc(IDENT) + { (f, None) } + +| f=loc(IDENT) p=angled(list0(loc(NUMBER), COMMA)) + { (f, Some (List.map (Lc.map (fun x -> `W x)) p)) } + +%inline fname: +| f=loc(fname_) { f } + +sexpr_: +| f=fname + { PEFName f } + +| f=fname args=parens(list0(loc(earg), COMMA)) + { PEApp (f, args) } + +| e=parens(expr) + { PEParens e } + +| i=NUMBER + { PEInt (i, None) } + +| i=NUMBER w=wtype + { PEInt (i, Some w) } + +%inline sexpr: +| e=loc(sexpr_) { e } + +expr_: +| e=sexpr_ + { e } + +| FUN args=wname* DOT body=expr %prec below_TERNARY + { PEFun (args, body) } + +| LET x=loc(IDENT) args=parens(list0(wname, COMMA))? EQUAL e1=expr IN e2=expr %prec below_TERNARY + { PELet ((x, args, e1), e2) } + +| e=sexpr LBRACKET + s=ioption(AT s=expr PIPE { s }) i=expr j=prefix(COLON, expr)? + RBRACKET + { PESlice (e, (i, j, s)) } + +| e=sexpr LBRACKET + s=ioption(AT s=expr PIPE { s }) i=expr j=prefix(COLON, expr)? + LARROW r=expr + RBRACKET + { PEAssign (e, (i, j, s), r) } + +| c=expr QMARK e1=expr COLON e2=expr + { PECond (c, (e1, e2)) } + +%inline expr: +| e=loc(expr_) { e } + +earg: +| DOT + { None } + +| e=expr + { Some e } + +def: +| name=IDENT args=parens(list0(wname, COMMA)) RARROW rty=wtype EQUAL body=expr + { { name; args; rty; body; } } + +program: +| defs=def* EOF + { defs } + +| error + { raise (ParseError (Lc.of_positions (fst $loc) (snd $loc))) } + +%inline parens(X): +| LPAREN x=X RPAREN { x } + +%inline angled(X): +| LT x=X GT { x } + +%inline list0(X, S): +| x=separated_list(S, X) { x } + +%inline prefix(S, X): +| S x=X { x } + +%inline loc(X): +| data=X { + let range = Lc.of_positions $startpos $endpos in + { range; data; } + } diff --git a/libs/lospecs/ptree.ml b/libs/lospecs/ptree.ml new file mode 100644 index 0000000000..6c1da94ce7 --- /dev/null +++ b/libs/lospecs/ptree.ml @@ -0,0 +1,107 @@ +(* -------------------------------------------------------------------- *) +open Lexing + +(* -------------------------------------------------------------------- *) +type range = { + rg_fname : string; + rg_begin : int * int; + rg_end : int * int; +} [@@deriving yojson] + +type 'a loced = { range : range; data : 'a; } [@@deriving yojson] + +(* -------------------------------------------------------------------- *) +module Lc = struct + let of_positions (p1 : position) (p2 : position) : range = + assert (p1.pos_fname = p2.pos_fname); + + let mk_range (p : position) = + (p.pos_lnum, p.pos_cnum - p.pos_bol) in + + { rg_fname = p1.pos_fname; rg_begin = mk_range p1; rg_end = mk_range p2; } + + let of_lexbuf (lx : Lexing.lexbuf) : range = + let p1 = Lexing.lexeme_start_p lx in + let p2 = Lexing.lexeme_end_p lx in + of_positions p1 p2 + + let merge (p1 : range) (p2 : range) = + assert (p1.rg_fname = p2.rg_fname); + { rg_fname = p1.rg_fname; + rg_begin = min p1.rg_begin p2.rg_begin; + rg_end = max p1.rg_end p2.rg_end; } + + (* Dead code? FIXME PR *) + let mergeall (p : range list) = + match p with + | [] -> assert false + | t :: ts -> List.fold_left merge t ts + + let unloc (x : 'a loced) : 'a = + x.data + + let range (x : 'a loced) : range = + x.range + + let mk (range : range) (data : 'a) : 'a loced = + { range; data; } + + let map (f : 'a -> 'b) (x : 'a loced) : 'b loced = + { x with data = f x.data } + + let string_of_range (range : range) = + let spos = + if range.rg_begin = range.rg_end then + Printf.sprintf "line %d (%d)" + (fst range.rg_begin) (snd range.rg_begin + 1) + else if fst range.rg_begin = fst range.rg_end then + Printf.sprintf "line %d (%d-%d)" + (fst range.rg_begin) (snd range.rg_begin + 1) (snd range.rg_end + 1) + else + Printf.sprintf "line %d (%d) to line %d (%d)" + (fst range.rg_begin) (snd range.rg_begin + 1) + (fst range.rg_end ) (snd range.rg_end + 1) + in + Printf.sprintf "%s: %s" range.rg_fname spos + + let pp_range (fmt : Format.formatter) (range : range) = + Format.fprintf fmt "%s" (string_of_range range) +end + +(* -------------------------------------------------------------------- *) +exception ParseError of range + +(* -------------------------------------------------------------------- *) +type symbol = string [@@deriving yojson] +type word = [ `W of int ] [@@deriving yojson] +type type_ = [ `Unsigned | `Signed | word ] [@@deriving yojson] + +(* -------------------------------------------------------------------- *) +type psymbol = symbol loced [@@deriving yojson] +type pword = word loced [@@deriving yojson] +type ptype = type_ loced [@@deriving yojson] +type parg = psymbol * pword [@@deriving yojson] +type pargs = parg list [@@deriving yojson] +type pfname = (psymbol * pword list option) loced [@@deriving yojson] + +(* -------------------------------------------------------------------- *) +type pexpr_ = + | PEParens of pexpr + | PEFName of pfname + | PEInt of int * pword option + | PECond of pexpr * (pexpr * pexpr) + | PEFun of pargs * pexpr + | PELet of (psymbol * pargs option * pexpr) * pexpr + | PESlice of pexpr * pslice + | PEAssign of pexpr * pslice * pexpr + | PEApp of pfname * pexpr option loced list +[@@deriving yojson] + +and pexpr = pexpr_ loced [@@deriving yojson] + +and pslice = (pexpr * pexpr option * pexpr option) [@@deriving yojson] + +type pdef = { name : symbol; args : pargs; rty : pword; body : pexpr } +[@@deriving yojson] + +type pprogram = pdef list [@@deriving yojson] diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml new file mode 100644 index 0000000000..5132250b3b --- /dev/null +++ b/libs/lospecs/smt.ml @@ -0,0 +1,274 @@ +open Aig +open Circuit + +module type SMTInstance = sig + type bvterm + + exception SMTError + + (* Expected params: sort, value *) + val bvterm_of_int : int -> int -> bvterm + + (* Expected params: sort, name *) + val bvterm_of_name : int -> string -> bvterm + + (* argument must be of size 1, assert it true *) + (* Should affect internal state of SMT *) + val assert' : bvterm -> unit + + (* Check satisfiability of current asserts *) + val check_sat : unit -> bool + + (* equality over bitvectors, res is a size 1 bitvector *) + val bvterm_equal : bvterm -> bvterm -> bvterm + + (* bvterm concat, res sort is sum of sorts *) + val bvterm_concat : bvterm -> bvterm -> bvterm + + (* bvand *) + val lognot : bvterm -> bvterm + + (* bvnot *) + val logand : bvterm -> bvterm -> bvterm + + val get_value : bvterm -> bvterm + + val pp_term : Format.formatter -> bvterm -> unit +end + +module type SMTInterface = sig + val circ_equiv : ?inps:(int * int) list -> reg -> reg -> node -> bool + + val circ_sat : ?inps:(int * int) list -> node -> bool + + val circ_taut : ?inps:(int * int) list -> node -> bool +end + +(* TODO Add model printing for circ_sat and circ_taut *) +(* Assumes circuit inputs have already been appropriately renamed *) +module MakeSMTInterface(SMT: SMTInstance) : SMTInterface = struct + let circ_equiv ?(inps: (int * int) list option) (r1 : Aig.reg) (r2 : Aig.reg) (pcond : Aig.node) : bool = + if not ((Array.length r1 > 0) && (Array.length r2 > 0)) then + (Format.eprintf "Sizes differ in circ_equiv"; false) + else + let bvvars : SMT.bvterm Map.String.t ref = ref Map.String.empty in + + let rec bvterm_of_node : Aig.node -> SMT.bvterm = + let cache = Hashtbl.create 0 in + + let rec doit (n : Aig.node) = + let mn = + match Hashtbl.find_option cache (Int.abs n.id) with + | None -> + let mn = doit_r n.gate in + Hashtbl.add cache (Int.abs n.id) mn; + mn + | Some mn -> + mn + in + if 0 < n.id then mn else SMT.lognot mn + + and doit_r (n : Aig.node_r) = + match n with + | False -> SMT.bvterm_of_int 1 0 + | Input v -> let name = ("BV_" ^ (fst v |> string_of_int) ^ "_" ^ (Printf.sprintf "%X" (snd v))) in + begin + match Map.String.find_opt name !bvvars with + | None -> + bvvars := Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars; + Map.String.find name !bvvars + | Some t -> t + end + | And (n1, n2) -> SMT.logand (doit n1) (doit n2) + + in fun n -> doit n + in + + let bvterm_of_reg (r: Aig.reg) : _ = + Array.map bvterm_of_node r |> Array.reduce (fun acc b -> SMT.bvterm_concat b acc) + in + + let bvinpt1 = (bvterm_of_reg r1) in + let bvinpt2 = (bvterm_of_reg r2) in + let formula = SMT.bvterm_equal bvinpt1 bvinpt2 in + let pcond = (bvterm_of_node pcond) in + let inps = Option.bind inps (fun l -> + if List.is_empty l then None + else Some l + ) in + + let inps = Option.map (fun inps -> + List.map (fun (id,sz) -> + List.init sz (fun i -> ("BV_" ^ (id |> string_of_int) ^ "_" ^ (Printf.sprintf "%X" (i))))) inps + ) inps in + let inps = Option.map (fun inps -> + List.map (List.map (fun name -> match Map.String.find_opt name !bvvars with + | Some bv -> bv + | None -> SMT.bvterm_of_name 1 name)) inps) inps + in + let bvinp = Option.map (fun inps -> + List.map (fun i -> List.reduce (SMT.bvterm_concat) i) inps) inps + in + + begin + SMT.assert' @@ SMT.logand pcond (SMT.lognot formula); + if SMT.check_sat () = false then true + else begin + Format.eprintf "bvout1: %a@." SMT.pp_term (SMT.get_value bvinpt1); + Format.eprintf "bvout2: %a@." SMT.pp_term (SMT.get_value bvinpt2); + Format.eprintf "Terms in formula: "; + List.iter (Format.eprintf "%s ") (List.of_enum @@ Map.String.keys !bvvars); + Format.eprintf "@\n"; + Option.may (fun bvinp -> + List.iteri (fun i bv -> + Format.eprintf "input[%d]: %a@." i SMT.pp_term (SMT.get_value bv) + ) bvinp) bvinp; + false + end + end + + + (* TODO: better encoding of smt terms ? *) + let circ_sat ?(inps: (int * int) list option) (n : Aig.node) : bool = + let bvvars : SMT.bvterm Map.String.t ref = ref Map.String.empty in + + begin match inps with + | None -> () + | Some inps -> List.iter (fun (id, sz) -> + List.iter (fun i -> + let name = ("BV_" ^ (string_of_int id) ^ "_" ^ (Printf.sprintf "%05X" i)) in + bvvars := Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars) + (List.init sz identity)) inps + end; + + let rec bvterm_of_node : Aig.node -> SMT.bvterm = + let cache = Hashtbl.create 0 in + + let rec doit (n : Aig.node) = + let mn = + match Hashtbl.find_option cache (Int.abs n.id) with + | None -> + let mn = doit_r n.gate in + Hashtbl.add cache (Int.abs n.id) mn; + mn + | Some mn -> + mn + in + if 0 < n.id then mn else SMT.lognot mn + + and doit_r (n : Aig.node_r) = + match n with + | False -> SMT.bvterm_of_int 1 0 + | Input v -> let name = ("BV_" ^ (fst v |> string_of_int) ^ "_" ^ (Printf.sprintf "%05X" (snd v))) in + begin + match Map.String.find_opt name !bvvars with + | None -> + bvvars := Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars; + Map.String.find name !bvvars + | Some t -> t + end + | And (n1, n2) -> SMT.logand (doit n1) (doit n2) + + in fun n -> doit n + in + + let form = bvterm_of_node n in + + let inps = Option.bind inps (fun l -> + if List.is_empty l then None + else Some l + ) in + + let inps = Option.map (fun inps -> + List.map (fun (id,sz) -> + List.init sz (fun i -> ("BV_" ^ (id |> string_of_int) ^ "_" ^ (Printf.sprintf "%05X" (i))))) inps + ) inps in + let inps = Option.map (fun inps -> + List.map (List.map (fun name -> match Map.String.find_opt name !bvvars with + | Some bv -> bv + | None -> SMT.bvterm_of_name 1 name)) inps) inps + in + let bvinp = Option.map (fun inps -> + List.map (fun i -> List.reduce (SMT.bvterm_concat) i) inps) inps + in + + begin + SMT.assert' @@ form; + if SMT.check_sat () = true then + begin + Format.eprintf "Input BVVars: "; + let () = Enum.iter (Format.eprintf "%s, ") (Map.String.keys !bvvars) in + Format.eprintf "@."; + Option.may (fun bvinp -> List.iteri (fun i bv -> + Format.eprintf "input[%d]: %a@." i SMT.pp_term (SMT.get_value bv) + ) bvinp) bvinp; + true + end + else false + end + + let circ_taut ?inps (n: Aig.node) : bool = + not @@ circ_sat ?inps (Aig.neg n) + +end + + +let makeBWZinstance () : (module SMTInstance) = + let module B = Bitwuzla.Once () in + let open B in + + (module struct + type bvterm = Term.Bv.t + + exception SMTError + + let bvterm_of_int (sort: int) (v: int) : bvterm = + Term.Bv.of_int (Sort.bv sort) v + + + let bvterm_of_name (sort: int) (name: string) : bvterm = + Term.const (Sort.bv sort) name + + + let assert' (f: bvterm) : unit = + assert' f + + + let check_sat () : bool = + match check_sat () with + | Sat -> true + | Unsat -> false + | Unknown -> raise SMTError + + + let bvterm_equal (bv1: bvterm) (bv2: bvterm) : bvterm = + Term.equal bv1 bv2 + + + let bvterm_concat (bv1: bvterm) (bv2: bvterm) : bvterm = + Term.Bv.concat [|bv1; bv2|] + + + let lognot (bv: bvterm) : bvterm = + Term.Bv.lognot bv + + + let logand (bv1: bvterm) (bv2: bvterm) : bvterm = + Term.Bv.logand bv1 bv2 + + + let get_value (bv: bvterm) : bvterm = + (get_value bv :> bvterm) + + + let pp_term (fmt: Format.formatter) (bv: bvterm) : unit = + Term.pp fmt bv + + end : SMTInstance) + + +let makeBWZinterface () : (module SMTInterface) = + (module MakeSMTInterface ((val makeBWZinstance () : SMTInstance))) + + + diff --git a/libs/lospecs/tests/avx2.ml b/libs/lospecs/tests/avx2.ml new file mode 100644 index 0000000000..d17d7f26e4 --- /dev/null +++ b/libs/lospecs/tests/avx2.ml @@ -0,0 +1,259 @@ +(* -------------------------------------------------------------- *) +type 'a pair = 'a * 'a +type 'a quad = 'a * 'a * 'a * 'a + +(* -------------------------------------------------------------- *) +type m64x2 = int64 pair +type m64x4 = int64 quad +type m32x4 = int32 pair pair +type m32x8 = int32 pair quad +type m16x8 = int pair pair pair +type m16x16 = int pair pair quad +type m8x16 = char pair pair pair pair +type m8x32 = char pair pair pair quad + +(* -------------------------------------------------------------- *) +type m128 = m64x2 +type m256 = m64x4 + +(* -------------------------------------------------------------- *) +type endianess = [`Little | `Big] + +(* -------------------------------------------------------------- *) +type size = [`U8 | `U16 | `U32 | `U64] + +let width_of_size (s : size) : int = + match s with + | `U8 -> 8 + | `U16 -> 16 + | `U32 -> 32 + | `U64 -> 64 + +(* -------------------------------------------------------------- *) +let pp_bytes + ~(size : size) + (fmt : Format.formatter) + (v : bytes) += + let w = width_of_size size / 8 in + + v |> Bytes.iteri (fun i b -> + if i <> 0 && i mod w = 0 then + Format.fprintf fmt "_"; + Format.fprintf fmt "%02x" (Char.code b) + ) + +(* -------------------------------------------------------------- *) +let map_quad (type a) (type b) + (f : a -> b) + ((x0, x1, x2, x3) : a quad) += + (f x0, f x1, f x2, f x3) + +(* -------------------------------------------------------------- *) +let map_pair (type a) (type b) (f : a -> b) ((x, y) : a pair) = + (f x, f y) + +(* -------------------------------------------------------------- *) +external m64_to_32x2 : int64 -> int32 pair = "m64_to_32x2" +external m32_to_16x2 : int32 -> int pair = "m32_to_16x2" +external m16_to_8x2 : int -> char pair = "m16_to_8x2" + +(* -------------------------------------------------------------- *) +external m64_of_32x2 : int32 pair -> int64 = "m64_of_32x2" +external m32_of_16x2 : int pair -> int32 = "m32_of_16x2" +external m16_of_8x2 : char pair -> int = "m16_of_8x2" + +(* -------------------------------------------------------------- *) +module M256 = struct + (* ------------------------------------------------------------ *) + external oftuple_64 : m64x4 -> m256 = "%identity" + external totuple_64 : m256 -> m64x4 = "%identity" + + (* ------------------------------------------------------------ *) + let to_bytes ~(endianess : endianess) (v : m256) : bytes = + let w0, w1, w2, w3 = totuple_64 v in + let b = Buffer.create 32 in + + let () = + match endianess with + | `Little -> + Buffer.add_int64_le b w0; + Buffer.add_int64_le b w1; + Buffer.add_int64_le b w2; + Buffer.add_int64_le b w3; + + | `Big -> + Buffer.add_int64_be b w3; + Buffer.add_int64_be b w2; + Buffer.add_int64_be b w1; + Buffer.add_int64_be b w0 + + in Buffer.to_bytes b + + (* ------------------------------------------------------------ *) + let of_bytes ~(endianess : endianess) (v : bytes) : m256 = + assert (Bytes.length v = 32); + + let w0, w1, w2, w3 = + match endianess with + | `Big -> ( + Bytes.get_int64_be v 24, + Bytes.get_int64_be v 16, + Bytes.get_int64_be v 8, + Bytes.get_int64_be v 0 + ) + | `Little -> ( + Bytes.get_int64_le v 0, + Bytes.get_int64_le v 8, + Bytes.get_int64_le v 16, + Bytes.get_int64_le v 24 + ) + + in oftuple_64 (w0, w1, w2, w3) + + (* ------------------------------------------------------------ *) + let pp + ~(size : size) + ~(endianess : endianess) + (fmt : Format.formatter) + (v : m256) + = + Format.fprintf fmt "%a" (pp_bytes ~size) (to_bytes ~endianess v) + + (* ------------------------------------------------------------ *) + let oftuple_32 (v : m32x8) : m256 = + oftuple_64 (map_quad m64_of_32x2 v) + + let totuple_32 (v : m256) : m32x8 = + map_quad m64_to_32x2 (totuple_64 v) + + (* ------------------------------------------------------------ *) + let oftuple_16 (v : m16x16) : m256 = + oftuple_32 (map_quad (map_pair m32_of_16x2) v) + + let totuple_16 (v : m256) : m16x16 = + map_quad (map_pair m32_to_16x2) (totuple_32 v) + + (* ------------------------------------------------------------ *) + let oftuple_8 (v : m8x32) : m256 = + oftuple_16 (map_quad (map_pair (map_pair m16_of_8x2)) v) + + let totuple_8 (v : m256) : m8x32 = + map_quad (map_pair (map_pair m16_to_8x2)) (totuple_16 v) + + (* ------------------------------------------------------------ *) + let random () : m256 = + let w0 = Random.bits64() in + let w1 = Random.bits64() in + let w2 = Random.bits64() in + let w3 = Random.bits64() in + oftuple_64 (w0, w1, w2, w3) +end + +(* -------------------------------------------------------------- *) +module M128 = struct + (* ------------------------------------------------------------ *) + external oftuple_64 : m64x2 -> m128 = "%identity" + external totuple_64 : m128 -> m64x2 = "%identity" + + (* ------------------------------------------------------------ *) + let to_bytes ~(endianess : endianess) (v : m128) : bytes = + let w0, w1 = totuple_64 v in + let b = Buffer.create 32 in + + let () = + match endianess with + | `Little -> + Buffer.add_int64_le b w0; + Buffer.add_int64_le b w1 + + | `Big -> + Buffer.add_int64_be b w1; + Buffer.add_int64_be b w0 + + in Buffer.to_bytes b + + (* ------------------------------------------------------------ *) + let of_bytes ~(endianess : endianess) (v : bytes) : m128 = + assert (Bytes.length v = 16); + + let w0, w1 = + match endianess with + | `Big -> ( + Bytes.get_int64_be v 8, + Bytes.get_int64_be v 0 + ) + | `Little -> ( + Bytes.get_int64_le v 0, + Bytes.get_int64_le v 8 + ) + + in oftuple_64 (w0, w1) + + (* ------------------------------------------------------------ *) + let pp + ~(size : size) + ~(endianess : endianess) + (fmt : Format.formatter) + (v : m128) + = + Format.fprintf fmt "%a" (pp_bytes ~size) (to_bytes ~endianess v) + + (* ------------------------------------------------------------ *) + let oftuple_32 (v : m32x4) : m128 = + oftuple_64 (map_pair m64_of_32x2 v) + + let totuple_32 (v : m128) : m32x4 = + map_pair m64_to_32x2 (totuple_64 v) + + (* ------------------------------------------------------------ *) + let oftuple_16 (v : m16x8) : m128 = + oftuple_32 (map_pair (map_pair m32_of_16x2) v) + + let totuple_16 (v : m128) : m16x8 = + map_pair (map_pair m32_to_16x2) (totuple_32 v) + + (* ------------------------------------------------------------ *) + let oftuple_8 (v : m8x16) : m128 = + oftuple_16 (map_pair (map_pair (map_pair m16_of_8x2)) v) + + let totuple_8 (v : m128) : m8x16 = + map_pair (map_pair (map_pair m16_to_8x2)) (totuple_16 v) + + (* ------------------------------------------------------------ *) + let random () : m128 = + let w0 = Random.bits64() in + let w1 = Random.bits64() in + oftuple_64 (w0, w1) +end + +(* -------------------------------------------------------------- *) +external mm256_and_si256 : m256 -> m256 -> m256 = "caml_simde_mm256_and_si256" +external mm256_andnot_si256 : m256 -> m256 -> m256 = "caml_simde_mm256_andnot_si256" +external mm256_add_epi8 : m256 -> m256 -> m256 = "caml_simde_mm256_add_epi8" +external mm256_add_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_add_epi16" +external mm256_sub_epi8 : m256 -> m256 -> m256 = "caml_simde_mm256_sub_epi8" +external mm256_sub_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_sub_epi16" +external mm256_mulhi_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_mulhi_epi16" +external mm256_mulhi_epu16 : m256 -> m256 -> m256 = "caml_simde_mm256_mulhi_epu16" +external mm256_mulhrs_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_mulhrs_epi16" +external mm256_packus_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_packus_epi16" +external mm256_packs_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_packs_epi16" +external mm256_maddubs_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_maddubs_epi16" +external mm256_permutevar8x32_epi32 : m256 -> m256 -> m256 = "caml_simde_mm256_permutevar8x32_epi32" +external mm256_permute4x64_epi64 : m256 -> int -> m256 = "caml_simde_mm256_permute4x64_epi64_dyn" +external mm256_permute2x128_si256 : m256 -> m256 -> int -> m256 = "caml_simde_mm256_permute2x128_si256_dyn" +external mm256_shuffle_epi8 : m256 -> m256 -> m256 = "caml_simde_mm256_shuffle_epi8" +external mm256_srai_epi16 : m256 -> int -> m256 = "caml_simde_mm256_srai_epi16" +external mm256_srli_epi16 : m256 -> int -> m256 = "caml_simde_mm256_srli_epi16" +external mm256_cmpgt_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_cmpgt_epi16" +external mm256_movemask_epi8 : m256 -> int32 = "caml_simde_mm256_movemask_epi8" +external mm256_unpacklo_epi8 : m256 -> m256 -> m256 = "caml_simde_mm256_unpacklo_epi8" +external mm256_unpacklo_epi64 : m256 -> m256 -> m256 = "caml_simde_mm256_unpacklo_epi64" +external mm256_unpackhi_epi64 : m256 -> m256 -> m256 = "caml_simde_mm256_unpackhi_epi64" +external mm256_blend_epi16 : m256 -> m256 -> int -> m256 = "caml_simde_mm256_blend_epi16_dyn" +external mm256_blend_epi32 : m256 -> m256 -> int -> m256 = "caml_simde_mm256_blend_epi32_dyn" +external mm256_moveldup_ps : m256 -> m256 = "caml_simde_mm256_moveldup_ps_dyn" +external mm256_inserti128_si256 : m256 -> m128 -> int -> m256 = "caml_simde_mm256_inserti128_si256_dyn" +external mm256_extracti128_si256 : m256 -> int -> m128 = "caml_simde_mm256_extracti128_si256_dyn" diff --git a/libs/lospecs/tests/avx2_runtime.cpp b/libs/lospecs/tests/avx2_runtime.cpp new file mode 100644 index 0000000000..0cbd3c7979 --- /dev/null +++ b/libs/lospecs/tests/avx2_runtime.cpp @@ -0,0 +1,534 @@ +/* ==================================================================== */ +#include +#include "avx2_runtime.h" + +/* -------------------------------------------------------------------- */ +#include + +/* -------------------------------------------------------------------- */ +#include +#include +#include +#include +#include + +/* ==================================================================== */ +extern "C" CAMLprim value m64_of_32x2(value lohi) { + CAMLparam1(lohi); + + const uint32_t lo = (uint32_t) Int32_val(Field(lohi, 0)); + const uint32_t hi = (uint32_t) Int32_val(Field(lohi, 1)); + + const uint64_t out = ((uint64_t) lo) | (((uint64_t) hi) << 32); + + CAMLreturn(caml_copy_int64((int64_t) out)); +} + +/* -------------------------------------------------------------------- */ +extern "C" CAMLprim value m64_to_32x2(value lohi) { + CAMLparam1(lohi); + CAMLlocal1(out); + + const uint64_t v = (uint64_t) Int64_val(lohi); + + const uint32_t lo = (v >> 0) & 0xffffffff; + const uint32_t hi = (v >> 32) & 0xffffffff; + + out = caml_alloc_tuple(2); + Field(out, 0) = caml_copy_int32(lo); + Field(out, 1) = caml_copy_int32(hi); + + CAMLreturn(out); +} + +/* -------------------------------------------------------------------- */ +extern "C" CAMLprim value m32_of_16x2(value lohi) { + CAMLparam1(lohi); + + const uint16_t lo = (uint16_t) Int_val(Field(lohi, 0)); + const uint16_t hi = (uint16_t) Int_val(Field(lohi, 1)); + + const uint32_t out = ((uint32_t) lo) | (((uint32_t) hi) << 16); + + CAMLreturn(caml_copy_int32((int32_t) out)); +} + +/* -------------------------------------------------------------------- */ +extern "C" CAMLprim value m32_to_16x2(value lohi) { + CAMLparam1(lohi); + CAMLlocal1(out); + + const uint32_t v = (uint32_t) Int32_val(lohi); + + const uint16_t lo = (v >> 0) & 0xffff; + const uint16_t hi = (v >> 16) & 0xffff; + + out = caml_alloc_tuple(2); + Field(out, 0) = Val_int(lo); + Field(out, 1) = Val_int(hi); + + CAMLreturn(out); +} + +/* -------------------------------------------------------------------- */ +extern "C" CAMLprim value m16_of_8x2(value lohi) { + CAMLparam1(lohi); + + const uint8_t lo = (uint8_t) Int_val(Field(lohi, 0)); + const uint8_t hi = (uint8_t) Int_val(Field(lohi, 1)); + + const uint16_t out = ((uint16_t) lo) | (((uint16_t) hi) << 8); + + CAMLreturn(Val_int(out)); +} + +/* -------------------------------------------------------------------- */ + extern "C" CAMLprim value m16_to_8x2(value lohi) { + CAMLparam1(lohi); + CAMLlocal1(out); + + const uint16_t v = (uint16_t) Int_val(lohi); + + const uint8_t lo = (v >> 0) & 0xff; + const uint8_t hi = (v >> 8) & 0xff; + + out = caml_alloc_tuple(2); + Field(out, 0) = Val_int(lo); + Field(out, 1) = Val_int(hi); + + CAMLreturn(out); +} + +/* ==================================================================== */ +#if defined(HAS_AVX) +/* -------------------------------------------------------------------- */ +value value_of_w256(simde__m256i x) { + CAMLparam0(); + CAMLlocal1(out); + + out = caml_alloc_tuple(4); + Store_field(out, 0, caml_copy_int64(simde_mm256_extract_epi64(x, 0))); + Store_field(out, 1, caml_copy_int64(simde_mm256_extract_epi64(x, 1))); + Store_field(out, 2, caml_copy_int64(simde_mm256_extract_epi64(x, 2))); + Store_field(out, 3, caml_copy_int64(simde_mm256_extract_epi64(x, 3))); + + CAMLreturn(out); +} + +/* -------------------------------------------------------------------- */ +simde__m256i w256_of_value(value x) { + CAMLparam1(x); + + simde__m256i out = simde_mm256_set_epi64x( + Int64_val(Field(x, 3)), + Int64_val(Field(x, 2)), + Int64_val(Field(x, 1)), + Int64_val(Field(x, 0)) + ); + + CAMLreturnT(simde__m256i, out); +} + +/* -------------------------------------------------------------------- */ +value value_of_w128(simde__m128i x) { + CAMLparam0(); + CAMLlocal1(out); + + out = caml_alloc_tuple(2); + Store_field(out, 0, caml_copy_int64(simde_mm_extract_epi64(x, 0))); + Store_field(out, 1, caml_copy_int64(simde_mm_extract_epi64(x, 1))); + + CAMLreturn(out); +} + +/* -------------------------------------------------------------------- */ +simde__m128i w128_of_value(value x) { + CAMLparam1(x); + + simde__m128i out = simde_mm_set_epi64x( + Int64_val(Field(x, 1)), + Int64_val(Field(x, 0)) + ); + + CAMLreturnT(simde__m128i, out); +} + +/* -------------------------------------------------------------------- */ +simde__m256i simde_mm256_inserti128_si256_dyn(simde__m256i a, simde__m128i b, const int imm8) { + switch (imm8 & 0x01) { + case 0: + return simde_mm256_inserti128_si256(a, b, 0); + case 1: + return simde_mm256_inserti128_si256(a, b, 1); + } + abort(); +} + +/* -------------------------------------------------------------------- */ +simde__m128i simde_mm256_extracti128_si256_dyn(simde__m256i a, const int imm8) { + switch (imm8 & 0x01) { + case 0: + return simde_mm256_extracti128_si256(a, 0); + case 1: + return simde_mm256_extracti128_si256(a, 1); + } + abort(); +} + +/* -------------------------------------------------------------------- */ +simde__m256i simde_mm256_blend_epi16_dyn(simde__m256i a, simde__m256i b, const int imm8) { +#define CASE(I) case I: return simde_mm256_blend_epi16(a, b, I) + + /* + * for i in range(0, 256, 4): + * print('; '.join(f'CASE(0x{j:02x})' for j in range(i, i+4)) + ';') + */ + switch (imm8 & 0xff) { + CASE(0x00); CASE(0x01); CASE(0x02); CASE(0x03); + CASE(0x04); CASE(0x05); CASE(0x06); CASE(0x07); + CASE(0x08); CASE(0x09); CASE(0x0a); CASE(0x0b); + CASE(0x0c); CASE(0x0d); CASE(0x0e); CASE(0x0f); + CASE(0x10); CASE(0x11); CASE(0x12); CASE(0x13); + CASE(0x14); CASE(0x15); CASE(0x16); CASE(0x17); + CASE(0x18); CASE(0x19); CASE(0x1a); CASE(0x1b); + CASE(0x1c); CASE(0x1d); CASE(0x1e); CASE(0x1f); + CASE(0x20); CASE(0x21); CASE(0x22); CASE(0x23); + CASE(0x24); CASE(0x25); CASE(0x26); CASE(0x27); + CASE(0x28); CASE(0x29); CASE(0x2a); CASE(0x2b); + CASE(0x2c); CASE(0x2d); CASE(0x2e); CASE(0x2f); + CASE(0x30); CASE(0x31); CASE(0x32); CASE(0x33); + CASE(0x34); CASE(0x35); CASE(0x36); CASE(0x37); + CASE(0x38); CASE(0x39); CASE(0x3a); CASE(0x3b); + CASE(0x3c); CASE(0x3d); CASE(0x3e); CASE(0x3f); + CASE(0x40); CASE(0x41); CASE(0x42); CASE(0x43); + CASE(0x44); CASE(0x45); CASE(0x46); CASE(0x47); + CASE(0x48); CASE(0x49); CASE(0x4a); CASE(0x4b); + CASE(0x4c); CASE(0x4d); CASE(0x4e); CASE(0x4f); + CASE(0x50); CASE(0x51); CASE(0x52); CASE(0x53); + CASE(0x54); CASE(0x55); CASE(0x56); CASE(0x57); + CASE(0x58); CASE(0x59); CASE(0x5a); CASE(0x5b); + CASE(0x5c); CASE(0x5d); CASE(0x5e); CASE(0x5f); + CASE(0x60); CASE(0x61); CASE(0x62); CASE(0x63); + CASE(0x64); CASE(0x65); CASE(0x66); CASE(0x67); + CASE(0x68); CASE(0x69); CASE(0x6a); CASE(0x6b); + CASE(0x6c); CASE(0x6d); CASE(0x6e); CASE(0x6f); + CASE(0x70); CASE(0x71); CASE(0x72); CASE(0x73); + CASE(0x74); CASE(0x75); CASE(0x76); CASE(0x77); + CASE(0x78); CASE(0x79); CASE(0x7a); CASE(0x7b); + CASE(0x7c); CASE(0x7d); CASE(0x7e); CASE(0x7f); + CASE(0x80); CASE(0x81); CASE(0x82); CASE(0x83); + CASE(0x84); CASE(0x85); CASE(0x86); CASE(0x87); + CASE(0x88); CASE(0x89); CASE(0x8a); CASE(0x8b); + CASE(0x8c); CASE(0x8d); CASE(0x8e); CASE(0x8f); + CASE(0x90); CASE(0x91); CASE(0x92); CASE(0x93); + CASE(0x94); CASE(0x95); CASE(0x96); CASE(0x97); + CASE(0x98); CASE(0x99); CASE(0x9a); CASE(0x9b); + CASE(0x9c); CASE(0x9d); CASE(0x9e); CASE(0x9f); + CASE(0xa0); CASE(0xa1); CASE(0xa2); CASE(0xa3); + CASE(0xa4); CASE(0xa5); CASE(0xa6); CASE(0xa7); + CASE(0xa8); CASE(0xa9); CASE(0xaa); CASE(0xab); + CASE(0xac); CASE(0xad); CASE(0xae); CASE(0xaf); + CASE(0xb0); CASE(0xb1); CASE(0xb2); CASE(0xb3); + CASE(0xb4); CASE(0xb5); CASE(0xb6); CASE(0xb7); + CASE(0xb8); CASE(0xb9); CASE(0xba); CASE(0xbb); + CASE(0xbc); CASE(0xbd); CASE(0xbe); CASE(0xbf); + CASE(0xc0); CASE(0xc1); CASE(0xc2); CASE(0xc3); + CASE(0xc4); CASE(0xc5); CASE(0xc6); CASE(0xc7); + CASE(0xc8); CASE(0xc9); CASE(0xca); CASE(0xcb); + CASE(0xcc); CASE(0xcd); CASE(0xce); CASE(0xcf); + CASE(0xd0); CASE(0xd1); CASE(0xd2); CASE(0xd3); + CASE(0xd4); CASE(0xd5); CASE(0xd6); CASE(0xd7); + CASE(0xd8); CASE(0xd9); CASE(0xda); CASE(0xdb); + CASE(0xdc); CASE(0xdd); CASE(0xde); CASE(0xdf); + CASE(0xe0); CASE(0xe1); CASE(0xe2); CASE(0xe3); + CASE(0xe4); CASE(0xe5); CASE(0xe6); CASE(0xe7); + CASE(0xe8); CASE(0xe9); CASE(0xea); CASE(0xeb); + CASE(0xec); CASE(0xed); CASE(0xee); CASE(0xef); + CASE(0xf0); CASE(0xf1); CASE(0xf2); CASE(0xf3); + CASE(0xf4); CASE(0xf5); CASE(0xf6); CASE(0xf7); + CASE(0xf8); CASE(0xf9); CASE(0xfa); CASE(0xfb); + CASE(0xfc); CASE(0xfd); CASE(0xfe); CASE(0xff); + } + abort(); +#undef CASE +} + +/* -------------------------------------------------------------------- */ +simde__m256i simde_mm256_blend_epi32_dyn(simde__m256i a, simde__m256i b, const int imm8) { +#define CASE(I) case I: return simde_mm256_blend_epi32(a, b, I) + + /* + * for i in range(0, 256, 4): + * print('; '.join(f'CASE(0x{j:02x})' for j in range(i, i+4)) + ';') + */ + switch (imm8 & 0xff) { + CASE(0x00); CASE(0x01); CASE(0x02); CASE(0x03); + CASE(0x04); CASE(0x05); CASE(0x06); CASE(0x07); + CASE(0x08); CASE(0x09); CASE(0x0a); CASE(0x0b); + CASE(0x0c); CASE(0x0d); CASE(0x0e); CASE(0x0f); + CASE(0x10); CASE(0x11); CASE(0x12); CASE(0x13); + CASE(0x14); CASE(0x15); CASE(0x16); CASE(0x17); + CASE(0x18); CASE(0x19); CASE(0x1a); CASE(0x1b); + CASE(0x1c); CASE(0x1d); CASE(0x1e); CASE(0x1f); + CASE(0x20); CASE(0x21); CASE(0x22); CASE(0x23); + CASE(0x24); CASE(0x25); CASE(0x26); CASE(0x27); + CASE(0x28); CASE(0x29); CASE(0x2a); CASE(0x2b); + CASE(0x2c); CASE(0x2d); CASE(0x2e); CASE(0x2f); + CASE(0x30); CASE(0x31); CASE(0x32); CASE(0x33); + CASE(0x34); CASE(0x35); CASE(0x36); CASE(0x37); + CASE(0x38); CASE(0x39); CASE(0x3a); CASE(0x3b); + CASE(0x3c); CASE(0x3d); CASE(0x3e); CASE(0x3f); + CASE(0x40); CASE(0x41); CASE(0x42); CASE(0x43); + CASE(0x44); CASE(0x45); CASE(0x46); CASE(0x47); + CASE(0x48); CASE(0x49); CASE(0x4a); CASE(0x4b); + CASE(0x4c); CASE(0x4d); CASE(0x4e); CASE(0x4f); + CASE(0x50); CASE(0x51); CASE(0x52); CASE(0x53); + CASE(0x54); CASE(0x55); CASE(0x56); CASE(0x57); + CASE(0x58); CASE(0x59); CASE(0x5a); CASE(0x5b); + CASE(0x5c); CASE(0x5d); CASE(0x5e); CASE(0x5f); + CASE(0x60); CASE(0x61); CASE(0x62); CASE(0x63); + CASE(0x64); CASE(0x65); CASE(0x66); CASE(0x67); + CASE(0x68); CASE(0x69); CASE(0x6a); CASE(0x6b); + CASE(0x6c); CASE(0x6d); CASE(0x6e); CASE(0x6f); + CASE(0x70); CASE(0x71); CASE(0x72); CASE(0x73); + CASE(0x74); CASE(0x75); CASE(0x76); CASE(0x77); + CASE(0x78); CASE(0x79); CASE(0x7a); CASE(0x7b); + CASE(0x7c); CASE(0x7d); CASE(0x7e); CASE(0x7f); + CASE(0x80); CASE(0x81); CASE(0x82); CASE(0x83); + CASE(0x84); CASE(0x85); CASE(0x86); CASE(0x87); + CASE(0x88); CASE(0x89); CASE(0x8a); CASE(0x8b); + CASE(0x8c); CASE(0x8d); CASE(0x8e); CASE(0x8f); + CASE(0x90); CASE(0x91); CASE(0x92); CASE(0x93); + CASE(0x94); CASE(0x95); CASE(0x96); CASE(0x97); + CASE(0x98); CASE(0x99); CASE(0x9a); CASE(0x9b); + CASE(0x9c); CASE(0x9d); CASE(0x9e); CASE(0x9f); + CASE(0xa0); CASE(0xa1); CASE(0xa2); CASE(0xa3); + CASE(0xa4); CASE(0xa5); CASE(0xa6); CASE(0xa7); + CASE(0xa8); CASE(0xa9); CASE(0xaa); CASE(0xab); + CASE(0xac); CASE(0xad); CASE(0xae); CASE(0xaf); + CASE(0xb0); CASE(0xb1); CASE(0xb2); CASE(0xb3); + CASE(0xb4); CASE(0xb5); CASE(0xb6); CASE(0xb7); + CASE(0xb8); CASE(0xb9); CASE(0xba); CASE(0xbb); + CASE(0xbc); CASE(0xbd); CASE(0xbe); CASE(0xbf); + CASE(0xc0); CASE(0xc1); CASE(0xc2); CASE(0xc3); + CASE(0xc4); CASE(0xc5); CASE(0xc6); CASE(0xc7); + CASE(0xc8); CASE(0xc9); CASE(0xca); CASE(0xcb); + CASE(0xcc); CASE(0xcd); CASE(0xce); CASE(0xcf); + CASE(0xd0); CASE(0xd1); CASE(0xd2); CASE(0xd3); + CASE(0xd4); CASE(0xd5); CASE(0xd6); CASE(0xd7); + CASE(0xd8); CASE(0xd9); CASE(0xda); CASE(0xdb); + CASE(0xdc); CASE(0xdd); CASE(0xde); CASE(0xdf); + CASE(0xe0); CASE(0xe1); CASE(0xe2); CASE(0xe3); + CASE(0xe4); CASE(0xe5); CASE(0xe6); CASE(0xe7); + CASE(0xe8); CASE(0xe9); CASE(0xea); CASE(0xeb); + CASE(0xec); CASE(0xed); CASE(0xee); CASE(0xef); + CASE(0xf0); CASE(0xf1); CASE(0xf2); CASE(0xf3); + CASE(0xf4); CASE(0xf5); CASE(0xf6); CASE(0xf7); + CASE(0xf8); CASE(0xf9); CASE(0xfa); CASE(0xfb); + CASE(0xfc); CASE(0xfd); CASE(0xfe); CASE(0xff); + } + abort(); +#undef CASE +} + +/* -------------------------------------------------------------------- */ +simde__m256i simde_mm256_permute4x64_epi64_dyn(simde__m256i a, const int imm8) { +#define CASE(I) case I: return simde_mm256_permute4x64_epi64(a, I) + + /* + * for i in range(0, 256, 4): + * print('; '.join(f'CASE(0x{j:02x})' for j in range(i, i+4)) + ';') + */ + switch (imm8 & 0xff) { + CASE(0x00); CASE(0x01); CASE(0x02); CASE(0x03); + CASE(0x04); CASE(0x05); CASE(0x06); CASE(0x07); + CASE(0x08); CASE(0x09); CASE(0x0a); CASE(0x0b); + CASE(0x0c); CASE(0x0d); CASE(0x0e); CASE(0x0f); + CASE(0x10); CASE(0x11); CASE(0x12); CASE(0x13); + CASE(0x14); CASE(0x15); CASE(0x16); CASE(0x17); + CASE(0x18); CASE(0x19); CASE(0x1a); CASE(0x1b); + CASE(0x1c); CASE(0x1d); CASE(0x1e); CASE(0x1f); + CASE(0x20); CASE(0x21); CASE(0x22); CASE(0x23); + CASE(0x24); CASE(0x25); CASE(0x26); CASE(0x27); + CASE(0x28); CASE(0x29); CASE(0x2a); CASE(0x2b); + CASE(0x2c); CASE(0x2d); CASE(0x2e); CASE(0x2f); + CASE(0x30); CASE(0x31); CASE(0x32); CASE(0x33); + CASE(0x34); CASE(0x35); CASE(0x36); CASE(0x37); + CASE(0x38); CASE(0x39); CASE(0x3a); CASE(0x3b); + CASE(0x3c); CASE(0x3d); CASE(0x3e); CASE(0x3f); + CASE(0x40); CASE(0x41); CASE(0x42); CASE(0x43); + CASE(0x44); CASE(0x45); CASE(0x46); CASE(0x47); + CASE(0x48); CASE(0x49); CASE(0x4a); CASE(0x4b); + CASE(0x4c); CASE(0x4d); CASE(0x4e); CASE(0x4f); + CASE(0x50); CASE(0x51); CASE(0x52); CASE(0x53); + CASE(0x54); CASE(0x55); CASE(0x56); CASE(0x57); + CASE(0x58); CASE(0x59); CASE(0x5a); CASE(0x5b); + CASE(0x5c); CASE(0x5d); CASE(0x5e); CASE(0x5f); + CASE(0x60); CASE(0x61); CASE(0x62); CASE(0x63); + CASE(0x64); CASE(0x65); CASE(0x66); CASE(0x67); + CASE(0x68); CASE(0x69); CASE(0x6a); CASE(0x6b); + CASE(0x6c); CASE(0x6d); CASE(0x6e); CASE(0x6f); + CASE(0x70); CASE(0x71); CASE(0x72); CASE(0x73); + CASE(0x74); CASE(0x75); CASE(0x76); CASE(0x77); + CASE(0x78); CASE(0x79); CASE(0x7a); CASE(0x7b); + CASE(0x7c); CASE(0x7d); CASE(0x7e); CASE(0x7f); + CASE(0x80); CASE(0x81); CASE(0x82); CASE(0x83); + CASE(0x84); CASE(0x85); CASE(0x86); CASE(0x87); + CASE(0x88); CASE(0x89); CASE(0x8a); CASE(0x8b); + CASE(0x8c); CASE(0x8d); CASE(0x8e); CASE(0x8f); + CASE(0x90); CASE(0x91); CASE(0x92); CASE(0x93); + CASE(0x94); CASE(0x95); CASE(0x96); CASE(0x97); + CASE(0x98); CASE(0x99); CASE(0x9a); CASE(0x9b); + CASE(0x9c); CASE(0x9d); CASE(0x9e); CASE(0x9f); + CASE(0xa0); CASE(0xa1); CASE(0xa2); CASE(0xa3); + CASE(0xa4); CASE(0xa5); CASE(0xa6); CASE(0xa7); + CASE(0xa8); CASE(0xa9); CASE(0xaa); CASE(0xab); + CASE(0xac); CASE(0xad); CASE(0xae); CASE(0xaf); + CASE(0xb0); CASE(0xb1); CASE(0xb2); CASE(0xb3); + CASE(0xb4); CASE(0xb5); CASE(0xb6); CASE(0xb7); + CASE(0xb8); CASE(0xb9); CASE(0xba); CASE(0xbb); + CASE(0xbc); CASE(0xbd); CASE(0xbe); CASE(0xbf); + CASE(0xc0); CASE(0xc1); CASE(0xc2); CASE(0xc3); + CASE(0xc4); CASE(0xc5); CASE(0xc6); CASE(0xc7); + CASE(0xc8); CASE(0xc9); CASE(0xca); CASE(0xcb); + CASE(0xcc); CASE(0xcd); CASE(0xce); CASE(0xcf); + CASE(0xd0); CASE(0xd1); CASE(0xd2); CASE(0xd3); + CASE(0xd4); CASE(0xd5); CASE(0xd6); CASE(0xd7); + CASE(0xd8); CASE(0xd9); CASE(0xda); CASE(0xdb); + CASE(0xdc); CASE(0xdd); CASE(0xde); CASE(0xdf); + CASE(0xe0); CASE(0xe1); CASE(0xe2); CASE(0xe3); + CASE(0xe4); CASE(0xe5); CASE(0xe6); CASE(0xe7); + CASE(0xe8); CASE(0xe9); CASE(0xea); CASE(0xeb); + CASE(0xec); CASE(0xed); CASE(0xee); CASE(0xef); + CASE(0xf0); CASE(0xf1); CASE(0xf2); CASE(0xf3); + CASE(0xf4); CASE(0xf5); CASE(0xf6); CASE(0xf7); + CASE(0xf8); CASE(0xf9); CASE(0xfa); CASE(0xfb); + CASE(0xfc); CASE(0xfd); CASE(0xfe); CASE(0xff); + } + abort(); +#undef CASE +} + +/* -------------------------------------------------------------------- */ +simde__m256i simde_mm256_permute2x128_si256_dyn(simde__m256i a, simde__m256i b, const int imm8) { +#define CASE(I) case I: return simde_mm256_permute2x128_si256(a, b, I) + + /* + * for i in range(0, 256, 4): + * print('; '.join(f'CASE(0x{j:02x})' for j in range(i, i+4)) + ';') + */ + switch (imm8 & 0xff) { + CASE(0x00); CASE(0x01); CASE(0x02); CASE(0x03); + CASE(0x04); CASE(0x05); CASE(0x06); CASE(0x07); + CASE(0x08); CASE(0x09); CASE(0x0a); CASE(0x0b); + CASE(0x0c); CASE(0x0d); CASE(0x0e); CASE(0x0f); + CASE(0x10); CASE(0x11); CASE(0x12); CASE(0x13); + CASE(0x14); CASE(0x15); CASE(0x16); CASE(0x17); + CASE(0x18); CASE(0x19); CASE(0x1a); CASE(0x1b); + CASE(0x1c); CASE(0x1d); CASE(0x1e); CASE(0x1f); + CASE(0x20); CASE(0x21); CASE(0x22); CASE(0x23); + CASE(0x24); CASE(0x25); CASE(0x26); CASE(0x27); + CASE(0x28); CASE(0x29); CASE(0x2a); CASE(0x2b); + CASE(0x2c); CASE(0x2d); CASE(0x2e); CASE(0x2f); + CASE(0x30); CASE(0x31); CASE(0x32); CASE(0x33); + CASE(0x34); CASE(0x35); CASE(0x36); CASE(0x37); + CASE(0x38); CASE(0x39); CASE(0x3a); CASE(0x3b); + CASE(0x3c); CASE(0x3d); CASE(0x3e); CASE(0x3f); + CASE(0x40); CASE(0x41); CASE(0x42); CASE(0x43); + CASE(0x44); CASE(0x45); CASE(0x46); CASE(0x47); + CASE(0x48); CASE(0x49); CASE(0x4a); CASE(0x4b); + CASE(0x4c); CASE(0x4d); CASE(0x4e); CASE(0x4f); + CASE(0x50); CASE(0x51); CASE(0x52); CASE(0x53); + CASE(0x54); CASE(0x55); CASE(0x56); CASE(0x57); + CASE(0x58); CASE(0x59); CASE(0x5a); CASE(0x5b); + CASE(0x5c); CASE(0x5d); CASE(0x5e); CASE(0x5f); + CASE(0x60); CASE(0x61); CASE(0x62); CASE(0x63); + CASE(0x64); CASE(0x65); CASE(0x66); CASE(0x67); + CASE(0x68); CASE(0x69); CASE(0x6a); CASE(0x6b); + CASE(0x6c); CASE(0x6d); CASE(0x6e); CASE(0x6f); + CASE(0x70); CASE(0x71); CASE(0x72); CASE(0x73); + CASE(0x74); CASE(0x75); CASE(0x76); CASE(0x77); + CASE(0x78); CASE(0x79); CASE(0x7a); CASE(0x7b); + CASE(0x7c); CASE(0x7d); CASE(0x7e); CASE(0x7f); + CASE(0x80); CASE(0x81); CASE(0x82); CASE(0x83); + CASE(0x84); CASE(0x85); CASE(0x86); CASE(0x87); + CASE(0x88); CASE(0x89); CASE(0x8a); CASE(0x8b); + CASE(0x8c); CASE(0x8d); CASE(0x8e); CASE(0x8f); + CASE(0x90); CASE(0x91); CASE(0x92); CASE(0x93); + CASE(0x94); CASE(0x95); CASE(0x96); CASE(0x97); + CASE(0x98); CASE(0x99); CASE(0x9a); CASE(0x9b); + CASE(0x9c); CASE(0x9d); CASE(0x9e); CASE(0x9f); + CASE(0xa0); CASE(0xa1); CASE(0xa2); CASE(0xa3); + CASE(0xa4); CASE(0xa5); CASE(0xa6); CASE(0xa7); + CASE(0xa8); CASE(0xa9); CASE(0xaa); CASE(0xab); + CASE(0xac); CASE(0xad); CASE(0xae); CASE(0xaf); + CASE(0xb0); CASE(0xb1); CASE(0xb2); CASE(0xb3); + CASE(0xb4); CASE(0xb5); CASE(0xb6); CASE(0xb7); + CASE(0xb8); CASE(0xb9); CASE(0xba); CASE(0xbb); + CASE(0xbc); CASE(0xbd); CASE(0xbe); CASE(0xbf); + CASE(0xc0); CASE(0xc1); CASE(0xc2); CASE(0xc3); + CASE(0xc4); CASE(0xc5); CASE(0xc6); CASE(0xc7); + CASE(0xc8); CASE(0xc9); CASE(0xca); CASE(0xcb); + CASE(0xcc); CASE(0xcd); CASE(0xce); CASE(0xcf); + CASE(0xd0); CASE(0xd1); CASE(0xd2); CASE(0xd3); + CASE(0xd4); CASE(0xd5); CASE(0xd6); CASE(0xd7); + CASE(0xd8); CASE(0xd9); CASE(0xda); CASE(0xdb); + CASE(0xdc); CASE(0xdd); CASE(0xde); CASE(0xdf); + CASE(0xe0); CASE(0xe1); CASE(0xe2); CASE(0xe3); + CASE(0xe4); CASE(0xe5); CASE(0xe6); CASE(0xe7); + CASE(0xe8); CASE(0xe9); CASE(0xea); CASE(0xeb); + CASE(0xec); CASE(0xed); CASE(0xee); CASE(0xef); + CASE(0xf0); CASE(0xf1); CASE(0xf2); CASE(0xf3); + CASE(0xf4); CASE(0xf5); CASE(0xf6); CASE(0xf7); + CASE(0xf8); CASE(0xf9); CASE(0xfa); CASE(0xfb); + CASE(0xfc); CASE(0xfd); CASE(0xfe); CASE(0xff); + } + abort(); +#undef CASE +} + +/* -------------------------------------------------------------------- */ +simde__m256i simde_mm256_moveldup_ps_dyn(simde__m256i a) { + return (simde__m256i)simde_mm256_moveldup_ps((simde__m256)a); +} + + +#endif + +extern "C" { +BIND_256x2_256(simde_mm256_permutevar8x32_epi32); +BIND2(simde_mm256_permute4x64_epi64_dyn, M256i, M256i, Long); +BIND3(simde_mm256_permute2x128_si256_dyn, M256i, M256i, M256i, Long); + +BIND_256x2_256(simde_mm256_and_si256); +BIND_256x2_256(simde_mm256_andnot_si256); +BIND_256x2_256(simde_mm256_add_epi8); +BIND_256x2_256(simde_mm256_add_epi16); +BIND_256x2_256(simde_mm256_sub_epi8); +BIND_256x2_256(simde_mm256_sub_epi16); +BIND_256x2_256(simde_mm256_maddubs_epi16); +BIND_256x2_256(simde_mm256_packus_epi16); +BIND_256x2_256(simde_mm256_packs_epi16); +BIND_256x2_256(simde_mm256_mulhi_epi16); +BIND_256x2_256(simde_mm256_mulhi_epu16); +BIND_256x2_256(simde_mm256_mulhrs_epi16); + +BIND_256x2_256(simde_mm256_shuffle_epi8); +BIND_256x2_256(simde_mm256_cmpgt_epi16); +BIND_256x2_256(simde_mm256_unpacklo_epi8); +BIND_256x2_256(simde_mm256_unpacklo_epi64); +BIND_256x2_256(simde_mm256_unpackhi_epi64); + +BIND2(simde_mm256_srai_epi16, M256i, M256i, Long); +BIND2(simde_mm256_srli_epi16, M256i, M256i, Long); + +BIND1(simde_mm256_movemask_epi8, Int32, M256i); +BIND1(simde_mm256_moveldup_ps_dyn, M256i, M256i); + +BIND3(simde_mm256_blend_epi16_dyn, M256i, M256i, M256i, Long); +BIND3(simde_mm256_blend_epi32_dyn, M256i, M256i, M256i, Long); + + +BIND3(simde_mm256_inserti128_si256_dyn, M256i, M256i, M128i, Long); +BIND2(simde_mm256_extracti128_si256_dyn, M128i, M256i, Long); +} diff --git a/libs/lospecs/tests/avx2_runtime.h b/libs/lospecs/tests/avx2_runtime.h new file mode 100644 index 0000000000..e5dd028584 --- /dev/null +++ b/libs/lospecs/tests/avx2_runtime.h @@ -0,0 +1,210 @@ +/* ==================================================================== */ +#if !defined(AVX2_RUNTIME__) +# define AVX2_RUNTIME__ 1 + +#if defined(__x86_64__) || defined(_M_X64) +# define HAS_AVX 1 +# include +#endif + +#define HAS_AVX + +/* -------------------------------------------------------------------- */ +#include +#include +#include +#include +#include + +/* -------------------------------------------------------------------- */ +extern "C" { +CAMLprim value caml_simde_mm256_permutevar8x32_epi32(value, value); +CAMLprim value caml_simde_mm256_permute4x64_epi64_dyn(value, value); +CAMLprim value caml_simde_mm256_permute2x128_si256_dyn(value, value, value); +CAMLprim value m64_of_32x2(value); +CAMLprim value m64_to_32x2(value); +CAMLprim value m32_of_16x2(value lohi); +CAMLprim value m32_to_16x2(value lohi); +CAMLprim value m16_of_8x2(value lohi); +CAMLprim value m16_to_8x2(value lohi); + +CAMLprim value caml_simde_mm256_and_si256(value, value); +CAMLprim value caml_simde_mm256_andnot_si256(value, value); +CAMLprim value caml_simde_mm256_add_epi8(value, value); +CAMLprim value caml_simde_mm256_add_epi16(value, value); +CAMLprim value caml_simde_mm256_sub_epi8(value, value); +CAMLprim value caml_simde_mm256_sub_epi16(value, value); +CAMLprim value caml_simde_mm256_maddubs_epi16(value, value); +CAMLprim value caml_simde_mm256_packus_epi16(value, value); +CAMLprim value caml_simde_mm256_packs_epi16(value, value); +CAMLprim value caml_simde_mm256_mulhi_epu16(value, value); +CAMLprim value caml_simde_mm256_mulhrs_epi16(value, value); +CAMLprim value caml_simde_mm256_shuffle_epi8(value, value); +CAMLprim value caml_simde_mm256_srai_epi16(value, value); +CAMLprim value caml_simde_mm256_srli_epi16(value, value); +CAMLprim value caml_simde_mm256_cmpgt_epi16(value, value); +CAMLprim value caml_simde_mm256_movemask_epi8(value); +CAMLprim value caml_simde_mm256_unpacklo_epi8(value, value); +CAMLprim value caml_simde_mm256_unpacklo_epi64(value, value); +CAMLprim value caml_simde_mm256_unpackhi_epi64(value, value); +CAMLprim value caml_simde_mm256_inserti128_si256_dyn(value, value, value); +CAMLprim value caml_simde_mm256_extracti128_si256_dyn(value, value); +CAMLprim value caml_simde_mm256_blend_epi16_dyn(value, value, value); +CAMLprim value caml_simde_mm256_blend_epi32_dyn(value, value, value); +CAMLprim value caml_simde_mm256_moveldup_ps(value); +} + +/* ==================================================================== */ +#if defined(HAS_AVX) + +/* -------------------------------------------------------------------- */ +extern value value_of_w256(simde__m256i x); +extern simde__m256i w256_of_value(value x); + +/* -------------------------------------------------------------------- */ +extern value value_of_w128(simde__m128i x); +extern simde__m128i w128_of_value(value x); + +/* -------------------------------------------------------------------- */ +struct M256i { + typedef simde__m256i type; + + static inline type ofocaml(value v) { + return w256_of_value(v); + } + + static inline value toocaml(type v) { + return value_of_w256(v); + } +}; + +/* -------------------------------------------------------------------- */ +struct M128i { + typedef simde__m128i type; + + static inline type ofocaml(value v) { + return w128_of_value(v); + } + + static inline value toocaml(type v) { + return value_of_w128(v); + } +}; + +/* -------------------------------------------------------------------- */ +struct Long { + typedef long type; + + static inline type ofocaml(value v) { + return Long_val(v); + } + + static inline value toocaml(type v) { + return Val_long(v); + } +}; + +/* -------------------------------------------------------------------- */ +struct Int32 { + typedef long type; + + static inline type ofocaml(value v) { + return Int32_val(v); + } + + static inline value toocaml(type v) { + return caml_copy_int32(v); + } +}; + +/* -------------------------------------------------------------------- */ +struct Int64 { + typedef long type; + + static inline type ofocaml(value v) { + return Int64_val(v); + } + + static inline value toocaml(type v) { + return caml_copy_int64(v); + } +}; + +/* -------------------------------------------------------------------- */ +template +static value bind(value arg) { + CAMLparam1(arg); + typename T::type varg = T::ofocaml(arg); + CAMLreturn(U::toocaml(F(varg))); +} + +/* -------------------------------------------------------------------- */ +template +static value bind(value arg1, value arg2) { + CAMLparam2(arg1, arg2); + typename T1::type varg1 = T1::ofocaml(arg1); + typename T2::type varg2 = T2::ofocaml(arg2); + CAMLreturn(U::toocaml(F(varg1, varg2))); +} + +/* -------------------------------------------------------------------- */ +template +static value bind(value arg1, value arg2, value arg3) { + CAMLparam3(arg1, arg2, arg3); + typename T1::type varg1 = T1::ofocaml(arg1); + typename T2::type varg2 = T2::ofocaml(arg2); + typename T3::type varg3 = T3::ofocaml(arg3); + CAMLreturn(U::toocaml(F(varg1, varg2, varg3))); +} + +/* -------------------------------------------------------------------- */ +# define BIND1(F, U, T) \ +CAMLprim value caml_##F(value a) { \ + return bind(a); \ +} + +/* -------------------------------------------------------------------- */ +# define BIND2(F, U, T1, T2) \ +CAMLprim value caml_##F(value a, value b) { \ + return bind(a, b); \ +} + +/* -------------------------------------------------------------------- */ +# define BIND3(F, U, T1, T2, T3) \ +CAMLprim value caml_##F(value a, value b, value c) { \ + return bind(a, b, c); \ +} + +/* ==================================================================== */ +#else + +/* -------------------------------------------------------------------- */ +# define BIND1(F, U, T) \ +CAMLprim value caml_##F(value a) { \ + CAMLparam1(a); \ + caml_failwith("not implemented: " #F); \ + CAMLreturn(Val_unit); \ +} + +/* -------------------------------------------------------------------- */ +# define BIND2(F, U, T1, T2) \ +CAMLprim value caml_##F(value a, value b) { \ + CAMLparam2(a, b); \ + caml_failwith("not implemented: " #F); \ + CAMLreturn(Val_unit); \ +} + +/* -------------------------------------------------------------------- */ +# define BIND3(F, U, T1, T2, T3) \ +CAMLprim value caml_##F(value a, value b, value c) { \ + CAMLparam3(a, b, c); \ + caml_failwith("not implemented: " #F); \ + CAMLreturn(Val_unit); \ +} + +#endif /* defined(HAS_AVX) */ + +#define BIND_256x2_256(F) BIND2(F, M256i, M256i, M256i) +#define BIND_256x3_256(F) BIND3(F, M256i, M256i, M256i, M256i) + +#endif /* !AVX2_RUNTIME__ */ diff --git a/libs/lospecs/tests/circuit_avx2.ml b/libs/lospecs/tests/circuit_avx2.ml new file mode 100644 index 0000000000..8792be5e0b --- /dev/null +++ b/libs/lospecs/tests/circuit_avx2.ml @@ -0,0 +1,265 @@ +(* ==================================================================== *) +open Lospecs +open Aig + +type symbol = string + +(* ==================================================================== *) +module type S = sig + val vpermd : reg -> reg -> reg + val vpermq : reg -> int -> reg + val vperm2i128 : reg -> reg -> int -> reg + val vpbroadcast_16u16 : reg -> reg + val vpadd_16u16 : reg -> reg -> reg + val vpadd_32u8 : reg -> reg -> reg + val vpsub_16u16 : reg -> reg -> reg + val vpsub_32u8 : reg -> reg -> reg + val vpand_256 : reg -> reg -> reg + val vpmaddubsw_256 : reg -> reg -> reg + val vpmulh_16u16 : reg -> reg -> reg + val vpmulhu_16u16 : reg -> reg -> reg + val vpmulhrs_16u16 : reg -> reg -> reg + val vpsra_16u16 : reg -> int -> reg + val vpsrl_16u16 : reg -> int -> reg + val vpsrl_4u64 : reg -> int -> reg + val vpsll_4u64 : reg -> int -> reg + val vpackus_16u16 : reg -> reg -> reg + val vpackss_16u16 : reg -> reg -> reg + val vpshufb_256 : reg -> reg -> reg + val vpcmpgt_16u16 : reg -> reg -> reg + val vpmovmskb_u256u64 : reg -> reg + val vpunpckl_32u8 : reg -> reg -> reg + val vpunpckl_4u64 : reg -> reg -> reg + val vpunpckh_4u64 : reg -> reg -> reg + val vpextracti128 : reg -> int -> reg + val vpinserti128 : reg -> reg -> int -> reg + val vpblend_16u16 : reg -> reg -> int -> reg + val vpblend_8u32 : reg -> reg -> int -> reg + val vpslldq_256 : reg -> int -> reg + val vpsrldq_256 : reg -> int -> reg + val vpslldq_128 : reg -> int -> reg + val vpsrldq_128 : reg -> int -> reg + val vmovsldup_256 : reg -> reg +end + +(* ==================================================================== *) +module FromSpec () : S = struct + (* ------------------------------------------------------------------ *) + let specs = + let specs = match Sys.getenv_opt "EC_AVX2_SPEC_FILE_PATH" with + | Some s -> s + | None -> Format.eprintf "Path to avx2 spec file not set, please set env var EC_AVX2_SPEC_FILE_PATH with the correct path to the file@."; + exit 1 + in + let specs = Circuit_spec.load_from_file ~filename:specs in + let specs = BatMap.of_seq (List.to_seq specs) in + specs + + let get_specification (name : symbol) : Ast.adef option = + BatMap.find_opt name specs + + (* ------------------------------------------------------------------ *) + let vpermd = Option.get (get_specification "VPERMD") + + let vpermd (r1 : reg) (r2 : reg) : reg = + Circuit_spec.circuit_of_specification [r1; r2] vpermd + + (* ------------------------------------------------------------------ *) + let vpermq = Option.get (get_specification "VPERMQ") + + let vpermq (r : reg) (i : int) : reg = + Circuit_spec.circuit_of_specification [r; Circuit.w8 i] vpermq + + (* ------------------------------------------------------------------ *) + let vperm2i128 = Option.get (get_specification "VPERM2I128") + + let vperm2i128 (r1 : reg) (r2 : reg) (i : int) : reg = + Circuit_spec.circuit_of_specification [r1; r2; Circuit.w8 i] vperm2i128 + + (* ------------------------------------------------------------------ *) + let vpbroadcast_16u16 = Option.get (get_specification "VPBROADCAST_16u16") + + let vpbroadcast_16u16 (r : reg) : reg = + Circuit_spec.circuit_of_specification [r] vpbroadcast_16u16 + + (* ------------------------------------------------------------------ *) + let vpadd_16u16 = Option.get (get_specification "VPADD_16u16") + + let vpadd_16u16 (r1 : reg) (r2 : reg) : reg = + Circuit_spec.circuit_of_specification [r1; r2] vpadd_16u16 + + (* ------------------------------------------------------------------ *) + let vpadd_32u8 = Option.get (get_specification "VPADD_32u8") + + let vpadd_32u8 (r1 : reg) (r2 : reg) : reg = + Circuit_spec.circuit_of_specification [r1; r2] vpadd_32u8 + + (* ----------------------------------------------------------------- *) + let vpsub_16u16 = Option.get (get_specification "VPSUB_16u16") + + let vpsub_16u16 (r1 : reg) (r2 : reg) : reg = + Circuit_spec.circuit_of_specification [r1; r2] vpsub_16u16 + + (* ------------------------------------------------------------------ *) + let vpsub_32u8 = Option.get (get_specification "VPSUB_32u8") + + let vpsub_32u8 (r1 : reg) (r2 : reg) : reg = + Circuit_spec.circuit_of_specification [r1; r2] vpsub_32u8 + + (* ------------------------------------------------------------------ *) + let vpand_256 = Option.get (get_specification "VPAND_256") + + let vpand_256 (r1 : reg) (r2 : reg) : reg = + Circuit_spec.circuit_of_specification [r1; r2] vpand_256 + + (* ------------------------------------------------------------------ *) + let vpmaddubsw_256 = Option.get (get_specification "VPMADDUBSW_256") + + let vpmaddubsw_256 (r1 : reg) (r2 : reg) : reg = + Circuit_spec.circuit_of_specification [r1; r2] vpmaddubsw_256 + + (* ------------------------------------------------------------------ *) + let vpmulh_16u16 = Option.get (get_specification "VPMULH_16u16") + + let vpmulh_16u16 (r1 : reg) (r2 : reg) : reg = + Circuit_spec.circuit_of_specification [r1; r2] vpmulh_16u16 + + (* ------------------------------------------------------------------ *) + let vpmulhu_16u16 = Option.get (get_specification "VPMULHU_16u16") + + let vpmulhu_16u16 (r1 : reg) (r2 : reg) : reg = + Circuit_spec.circuit_of_specification [r1; r2] vpmulhu_16u16 + + (* ------------------------------------------------------------------ *) + let vpmulhrs_16u16 = Option.get (get_specification "VPMULHRS_16u16") + + let vpmulhrs_16u16 (r1 : reg) (r2 : reg) : reg = + Circuit_spec.circuit_of_specification [r1; r2] vpmulhrs_16u16 + + (* ------------------------------------------------------------------ *) + let vpsra_16u16 = Option.get (get_specification "VPSRA_16u16") + + let vpsra_16u16 (r : reg) (n : int) : reg = + Circuit_spec.circuit_of_specification [r; Circuit.w128 (string_of_int n)] vpsra_16u16 + + (* ------------------------------------------------------------------ *) + let vpsrl_16u16 = Option.get (get_specification "VPSRL_16u16") + + let vpsrl_16u16 (r : reg) (n : int) : reg = + Circuit_spec.circuit_of_specification [r; Circuit.w128 (string_of_int n)] vpsrl_16u16 + + (* ------------------------------------------------------------------ *) + let vpsrl_4u64 = Option.get (get_specification "VPSRL_4u64") + + let vpsrl_4u64 (r : reg) (n : int) : reg = + Circuit_spec.circuit_of_specification [r; Circuit.w128 (string_of_int n)] vpsrl_4u64 + + (* ------------------------------------------------------------------ *) + let vpsll_4u64 = Option.get (get_specification "VPSLL_4u64") + + let vpsll_4u64 (r : reg) (n : int) : reg = + Circuit_spec.circuit_of_specification [r; Circuit.w128 (string_of_int n)] vpsll_4u64 + + (* ------------------------------------------------------------------ *) + let vpslldq_256 = Option.get (get_specification "VPSLLDQ_256") + + let vpslldq_256 (r : reg) (n : int) : reg = + Circuit_spec.circuit_of_specification [r; Circuit.w8 (8 * n)] vpslldq_256 + + (* ------------------------------------------------------------------ *) + let vpsrldq_256 = Option.get (get_specification "VPSRLDQ_256") + + let vpsrldq_256 (r : reg) (n : int) : reg = + Circuit_spec.circuit_of_specification [r; Circuit.w8 (8 * n)] vpsrldq_256 + + (* ------------------------------------------------------------------ *) + let vpslldq_128 = Option.get (get_specification "VPSLLDQ_128") + + let vpslldq_128 (r : reg) (n : int) : reg = + Circuit_spec.circuit_of_specification [r; Circuit.w8 (8 * n)] vpslldq_128 + + (* ------------------------------------------------------------------ *) + let vpsrldq_128 = Option.get (get_specification "VPSRLDQ_128") + + let vpsrldq_128 (r : reg) (n : int) : reg = + Circuit_spec.circuit_of_specification [r; Circuit.w8 (8 * n)] vpsrldq_128 + + (* ------------------------------------------------------------------ *) + let vpackus_16u16 = Option.get (get_specification "VPACKUS_16u16") + + let vpackus_16u16 (r1 : reg) (r2 : reg) : reg = + Circuit_spec.circuit_of_specification [r1; r2] vpackus_16u16 + + (* ------------------------------------------------------------------ *) + let vpackss_16u16 = Option.get (get_specification "VPACKSS_16u16") + + let vpackss_16u16 (r1 : reg) (r2 : reg) : reg = + Circuit_spec.circuit_of_specification [r1; r2] vpackss_16u16 + + (* ------------------------------------------------------------------ *) + let vpshufb_256 = Option.get (get_specification "VPSHUFB_256") + + let vpshufb_256 (r1 : reg) (r2 : reg) : reg = + Circuit_spec.circuit_of_specification [r1; r2] vpshufb_256 + + (* ------------------------------------------------------------------ *) + let vpcmpgt_16u16 = Option.get (get_specification "VPCMPGT_16u16") + + let vpcmpgt_16u16 (r1 : reg) (r2 : reg) : reg = + Circuit_spec.circuit_of_specification [r1; r2] vpcmpgt_16u16 + + (* ------------------------------------------------------------------ *) + let vpmovmskb_u256u64 = Option.get (get_specification "VPMOVMSKB_u256u64") + + let vpmovmskb_u256u64 (r : reg) : reg = + Circuit_spec.circuit_of_specification [r] vpmovmskb_u256u64 + + (* ------------------------------------------------------------------ *) + let vpunpckl_32u8 = Option.get (get_specification "VPUNPCKL_32u8") + + let vpunpckl_32u8 (r1 : reg) (r2 : reg): reg = + Circuit_spec.circuit_of_specification [r1; r2] vpunpckl_32u8 + + (* ------------------------------------------------------------------ *) + let vpunpckl_4u64 = Option.get (get_specification "VPUNPCKL_4u64") + + let vpunpckl_4u64 (r1 : reg) (r2 : reg): reg = + Circuit_spec.circuit_of_specification [r1; r2] vpunpckl_4u64 + + (* ------------------------------------------------------------------ *) + let vpunpckh_4u64 = Option.get (get_specification "VPUNPCKH_4u64") + + let vpunpckh_4u64 (r1 : reg) (r2 : reg): reg = + Circuit_spec.circuit_of_specification [r1; r2] vpunpckh_4u64 + + (* ------------------------------------------------------------------ *) + let vpextracti128 = Option.get (get_specification "VPEXTRACTI128") + + let vpextracti128 (r : reg) (i : int): reg = + Circuit_spec.circuit_of_specification [r; Circuit.w8 i] vpextracti128 + + (* ------------------------------------------------------------------ *) + let vpinserti128 = Option.get (get_specification "VPINSERTI128") + + let vpinserti128 (r1 : reg) (r2 : reg) (i : int): reg = + Circuit_spec.circuit_of_specification [r1; r2; Circuit.w8 i] vpinserti128 + + (* ------------------------------------------------------------------ *) + let vpblend_16u16 = Option.get (get_specification "VPBLEND_16u16") + + let vpblend_16u16 (r1 : reg) (r2 : reg) (i : int): reg = + Circuit_spec.circuit_of_specification [r1; r2; Circuit.w8 i] vpblend_16u16 + + (* ------------------------------------------------------------------ *) + let vpblend_8u32 = Option.get (get_specification "VPBLEND_8u32") + + let vpblend_8u32 (r1 : reg) (r2 : reg) (i : int): reg = + Circuit_spec.circuit_of_specification [r1; r2; Circuit.w8 i] vpblend_8u32 + + (* ------------------------------------------------------------------ *) + let vmovsldup_256 = Option.get (get_specification "VMOVSLDUP_256") + + let vmovsldup_256 (r : reg) : reg = + Circuit_spec.circuit_of_specification [r] vmovsldup_256 + +end diff --git a/libs/lospecs/tests/circuit_test.ml b/libs/lospecs/tests/circuit_test.ml new file mode 100644 index 0000000000..a9b205d9e3 --- /dev/null +++ b/libs/lospecs/tests/circuit_test.ml @@ -0,0 +1,1109 @@ +(* -------------------------------------------------------------------- *) +open Lospecs + +(* -------------------------------------------------------------------- *) +module C = struct + include Lospecs.Aig + include Lospecs.Circuit + include Circuit_avx2.FromSpec () +end + +(* -------------------------------------------------------------------- *) +let sign (i : int) = + match i with + | _ when i < 0 -> -1 + | _ when i > 0 -> 1 + | _ -> 0 + +(* -------------------------------------------------------------------- *) +let as_seq1 (type t) (xs : t list) = + match xs with [x] -> x | _ -> assert false + +(* -------------------------------------------------------------------- *) +let as_seq2 (type t) (xs : t list) = + match xs with [x; y] -> (x, y) | _ -> assert false + +(* -------------------------------------------------------------------- *) +let pp_bytes (fmt : Format.formatter) (b : bytes) = + Bytes.iter + (fun b -> Format.fprintf fmt "%02x" (Char.code b)) + b + +(* -------------------------------------------------------------------- *) +let srange_ (i : int) = + assert (0 < i && i <= Sys.int_size); + let v = (1 lsl (i - 1)) in + (-v, v-1) + +(* -------------------------------------------------------------------- *) +let srange (i : int) = + let vm, vM = srange_ i in Iter.(--) vm vM + +(* -------------------------------------------------------------------- *) +let urange_ (i : int) = + assert (0 < i && i <= Sys.int_size - 1); + (0, (1 lsl i) - 1) + +(* -------------------------------------------------------------------- *) +let urange (i : int) = + let vm, vM = urange_ i in Iter.(--) vm vM + +(* -------------------------------------------------------------------- *) +let product (type t) (s : t Iter.t list) = + let rec doit (s : t Iter.t list) : t list Iter.t = + match s with + | [] -> + Iter.of_list [[]] + | s1 :: s -> + Iter.map (fun (x, xs) -> x :: xs) (Iter.product s1 (doit s)) + in doit s + +(* -------------------------------------------------------------------- *) +type op = { + name : string; + args : (int * [`U | `S]) list; + out : [`U | `S]; + mk : C.reg list -> C.reg; + reff : int list -> int; +} + +(* -------------------------------------------------------------------- *) +let bar (name : string) (total : int) = + let open Progress.Line in + list [ + spinner ~color:(Progress.Color.ansi `green) () + ; rpad (max 20 (String.length name)) (const name) + ; bar total + ; lpad (2 * 7 + 1) (count_to total) + ] + +(* -------------------------------------------------------------------- *) +let test (op : op) = + let rs, vs = + let reg_of_arg (name : int) ((sz, s) : int * [`U | `S]) = + let r = C.reg ~size:sz ~name in + let v = match s with `U -> urange sz | `S -> srange sz in + (r, v) + in List.split (List.mapi reg_of_arg op.args) + in + + let sz = List.sum (List.map fst op.args) in + + assert (sz <= Sys.int_size - 1); + + let total = 1 lsl sz in + let bar = bar op.name total in + + let circuit = op.mk rs in + + let test (vs : int list) = + let vsa = Array.of_list vs in + let env ((n, k) : C.var) = (vsa.(n) lsr k) land 0b1 <> 0 in + let out = Array.map (C.eval env) circuit in + let out = + match op.out with + | `S -> C.sint_of_bools out + | `U -> C.uint_of_bools out in + let exp = op.reff vs in + + if out <> exp then begin + Progress.interject_with (fun () -> + Format.eprintf "%s(%a) = out: %d / exp: %d@." + op.name + (Format.pp_print_list + ~pp_sep:(fun fmt () -> Format.pp_print_string fmt ", ") + Format.pp_print_int) + vs + out + exp + ); + assert false + end + in + + Progress.with_reporter bar (fun f -> + Iter.iter + (fun vs -> test vs; f 1) + (product vs) + ) + +(* -------------------------------------------------------------------- *) +let test_uextend () = + let op (isize : int) (osize : int) : op = + { name = (Format.sprintf "uextend<%d,%d>" isize osize) + ; args = [(isize, `U)] + ; out = `U + ; mk = (fun rs -> C.uextend ~size:osize (as_seq1 rs)) + ; reff = (fun vs -> as_seq1 vs) + } + + in test (op 8 16) + +(* -------------------------------------------------------------------- *) +let test_ite () = + let op () : op = + { name = (Format.sprintf "ite") + ; args = [(1, `U)] + ; out = `U + ; mk = (fun rs -> C.ite ((as_seq1 rs).(0)) [|C.true_|] [|C.false_|]) + ; reff = (fun vs -> as_seq1 vs) + } + + in test (op ()) + +(* -------------------------------------------------------------------- *) +let test_sextend () = + let op (isize : int) (osize : int) : op = + { name = (Format.sprintf "sextend<%d,%d>" isize osize) + ; args = [(isize, `S)] + ; out = `S + ; mk = (fun rs -> C.sextend ~size:osize (as_seq1 rs)) + ; reff = (fun vs -> as_seq1 vs) + } + + in test (op 8 16) + +(* -------------------------------------------------------------------- *) +let test_shift ~(side : [`L | `R]) ~(sign : [`U | `S]) = + let str_side = match side with `L -> "left" | `R -> "right" in + let str_sign = match sign with `U -> "u" | `S -> "s" in + + let op (size : int) : op = + let module M = (val Word.word ~sign ~size) in + + let sim (v : int) (i : int) = + M.to_int (match side with + | `L -> M.shiftl (M.of_int v) i + | `R -> M.shiftr (M.of_int v) i + ) + in + + let asign = match sign with `U -> `L | `S -> `A in + + { name = (Format.sprintf "shift<%s,%s,%d>" str_side str_sign size) + ; args = [(size, sign); (4, `U)] + ; out = sign + ; mk = (fun rs -> let x, y = as_seq2 rs in C.shift ~side ~sign:asign x y) + ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) + } + + in + + for i = 1 to 14 do + test (op i) + done + +(* -------------------------------------------------------------------- *) +let test_rot ~(side : [`L | `R]) = + let str_side = match side with `L -> "left" | `R -> "right" in + + let op (size : int) : op = + let module M = (val Word.word ~sign:`U ~size) in + + let sim (v : int) (i : int) = + let i = i mod size in + let m = (1 lsl size) - 1 in + let v = v land m in + match side with + | `L -> ((v lsl i) lor (v lsr (size - i))) land m + | `R -> ((v lsr i) lor (v lsl (size - i))) land m + in + + { name = (Format.sprintf "rot<%s,%d>" str_side size) + ; args = [(size, `U); (4, `U)] + ; out = `U + ; mk = (fun rs -> let x, y = as_seq2 rs in match side with + | `L -> C.rol x y + | `R -> C.ror x y + ) + ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) + } + + in + + for i = 1 to 14 do + test (op i) + done + +(* -------------------------------------------------------------------- *) +let test_opp () = + let op (size : int) : op = + let module M = (val Word.sword ~size) in + + let sim (x : int) : int = + M.to_int (M.neg (M.of_int x)) in + + { name = (Format.sprintf "opp<%d>" size) + ; args = [(size, `S)] + ; out = `S + ; mk = (fun rs -> C.opp (as_seq1 rs)) + ; reff = (fun vs -> sim (as_seq1 vs)) + } + + in test (op 13) + +(* -------------------------------------------------------------------- *) +let test_add () = + let op (size : int) : op = + let module M = (val Word.sword ~size) in + + let sim (x : int) (y : int) : int = + M.to_int (M.add (M.of_int x) (M.of_int y)) in + + { name = (Format.sprintf "add<%d>" size) + ; args = List.make 2 (size, `S) + ; out = `S + ; mk = (fun rs -> let x, y = as_seq2 rs in C.add_dropc x y) + ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) + } + + in test (op 9) + +(* -------------------------------------------------------------------- *) +let test_incr () = + let op (size : int) : op = + let module M = (val Word.uword ~size) in + + let sim (x : int) : int = + M.to_int (M.add (M.of_int x) M.one) in + + { name = (Format.sprintf "incr<%d>" size) + ; args = [(size, `U)] + ; out = `U + ; mk = (fun rs -> C.incr_dropc (as_seq1 rs)) + ; reff = (fun vs -> sim (as_seq1 vs)); + } + + in test (op 11) + +(* -------------------------------------------------------------------- *) +let test_sub () = + let op (size : int) : op = + let module M = (val Word.sword ~size) in + + let sim (x : int) (y : int) : int = + M.to_int (M.sub (M.of_int x) (M.of_int y)) in + + { name = (Format.sprintf "sub<%d>" size) + ; args = List.make 2 (size, `S) + ; out = `S + ; mk = (fun rs -> let x, y = as_seq2 rs in C.sub_dropc x y) + ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) + } + + in test (op 9) + +(* -------------------------------------------------------------------- *) +let test_umul () = + let op (sz1 : int) (sz2 : int) : op = { + name = (Format.sprintf "umul<%d,%d>" sz1 sz2); + args = [(sz1, `U); (sz2, `U)]; + out = `U; + mk = (fun rs -> let x, y = as_seq2 rs in C.umul x y); + reff = (fun vs -> let x, y = as_seq2 vs in (x * y)); + } in + + test (op 10 8) + +(* -------------------------------------------------------------------- *) +let test_smul () = + let op (sz1 : int) (sz2 : int) : op = { + name = (Format.sprintf "smul<%d,%d>" sz1 sz2); + args = [(sz1, `S); (sz2, `S)]; + out = `S; + mk = (fun rs -> let x, y = as_seq2 rs in C.smul x y); + reff = (fun vs -> let x, y = as_seq2 vs in (x * y)); + } in + + test (op 10 8) + +(* -------------------------------------------------------------------- *) +let test_smul_u8_s8 () = + let op () : op = { + name = "smul_u8_s8"; + args = [(8, `U); (8, `S)]; + out = `S; + mk = (fun rs -> + let x, y = as_seq2 rs in + C.smul + (C.uextend ~size:16 x) + (C.sextend ~size:16 y)); + reff = (fun vs -> let x, y = as_seq2 vs in (x * y)); + } in + + test (op ()) + +(* -------------------------------------------------------------------- *) +let test_udiv () = + let op (size : int) : op = + let sim (x : int) (y : int) : int = + if y = 0 then x else x / y + in + + { name = (Format.sprintf "udiv<%d>" size) + ; args = List.make 2 (size, `U) + ; out = `U + ; mk = (fun rs -> let x, y = as_seq2 rs in C.udiv x y) + ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) + } + + in + test (op 4); + test (op 9) + +(* -------------------------------------------------------------------- *) +let test_umod () = + let op (size : int) : op = + let sim (x : int) (y : int) : int = + if y = 0 then 0 else x mod y + in + + { name = (Format.sprintf "umod<%d>" size) + ; args = List.make 2 (size, `U) + ; out = `U + ; mk = (fun rs -> let x, y = as_seq2 rs in C.umod x y) + ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) + } + + in + test (op 4); + test (op 9) + +(* -------------------------------------------------------------------- *) +let test_sdiv () = + let op (size : int) : op = + let module M = (val Word.sword ~size) in + + let sim (x : int) (y : int) : int = + if y = 0 then x else M.to_int (M.div (M.of_int x) (M.of_int y)) + in + + { name = (Format.sprintf "sdiv<%d>" size) + ; args = List.make 2 (size, `S) + ; out = `S + ; mk = (fun rs -> let x, y = as_seq2 rs in C.sdiv x y) + ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) + } + + in + test (op 4); + test (op 9) + +(* -------------------------------------------------------------------- *) +let test_ssat () = + let op (isize : int) (osize: int) : op = + let saturate = + let vm, vM = srange_ osize in + fun (i : int) -> min vM (max vm i) + in + + { name = (Format.sprintf "ssat<%d,%d>" isize osize); + args = [(isize, `S)]; + out = `S; + mk = (fun rs -> C.sat ~signed:true ~size:osize (as_seq1 rs)); + reff = (fun vs -> saturate (as_seq1 vs)); } in + + test (op 10 4); + test (op 15 7); + test (op 17 16) + +(* -------------------------------------------------------------------- *) +let test_usat () = + let op (isize : int) (osize: int) : op = + let saturate = + let vm, vM = urange_ osize in + fun (i : int) -> min vM (max vm i) + in + + { name = (Format.sprintf "usat<%d,%d>" isize osize); + args = [(isize, `S)]; + out = `U; + mk = (fun rs -> C.sat ~signed:false ~size:osize (as_seq1 rs)); + reff = (fun vs -> saturate (as_seq1 vs)); } in + + test (op 10 4); + test (op 15 7) + +(* -------------------------------------------------------------------- *) +let test_sgt () = + let op (size : int) = + { name = Format.sprintf "sgt<%d>" size; + args = [(size, `S); (size, `S)]; + out = `U; + mk = (fun rs -> let x, y = as_seq2 rs in [|C.sgt x y|]); + reff = (fun vs -> let x, y = as_seq2 vs in if x > y then 1 else 0); } + + in + test (op 10) + +(* -------------------------------------------------------------------- *) +let test_sge () = + let op (size : int) = + { name = Format.sprintf "sge<%d>" size; + args = [(size, `S); (size, `S)]; + out = `U; + mk = (fun rs -> let x, y = as_seq2 rs in [|C.sge x y|]); + reff = (fun vs -> let x, y = as_seq2 vs in if x >= y then 1 else 0); } + + in + test (op 10) + +(* -------------------------------------------------------------------- *) +let test_ugt () = + let op (size : int) = + { name = Format.sprintf "ugt<%d>" size; + args = [(size, `U); (size, `U)]; + out = `U; + mk = (fun rs -> let x, y = as_seq2 rs in [|C.ugt x y|]); + reff = (fun vs -> let x, y = as_seq2 vs in if x > y then 1 else 0); } + + in + test (op 10) + +(* -------------------------------------------------------------------- *) +let test_uge () = + let op (size : int) = + { name = Format.sprintf "uge<%d>" size; + args = [(size, `U); (size, `U)]; + out = `U; + mk = (fun rs -> let x, y = as_seq2 rs in [|C.uge x y|]); + reff = (fun vs -> let x, y = as_seq2 vs in if x >= y then 1 else 0); } + + in + test (op 10) + +(* -------------------------------------------------------------------- *) +let test_popcount () = + let op (size : int) = + { name = Format.sprintf "popcount<%d>" size; + args = [(size, `U)]; + out = `U; + mk = (fun rs -> let x = as_seq1 rs in C.popcount ~size x); + reff = (fun vs -> let x = as_seq1 vs in Z.popcount (Z.of_int x)); } + + in + test (op 16) + +(* -------------------------------------------------------------------- *) +type mvalue = M256 of Avx2.m256 | M128 of Avx2.m128 + +module MValue : sig + type kind = [`M256 | `M128] + + val random : kind -> mvalue + + val to_bytes : endianess:Avx2.endianess -> mvalue -> bytes + + val of_bytes : endianess:Avx2.endianess -> bytes -> mvalue + + val pp : + endianess:Avx2.endianess -> + size:Avx2.size -> + Format.formatter -> + mvalue -> + unit +end = struct + type kind = [`M256 | `M128] + + let random (k : kind) = + match k with + | `M256 -> M256 (Avx2.M256.random ()) + | `M128 -> M128 (Avx2.M128.random ()) + + let to_bytes ~(endianess : Avx2.endianess) (m : mvalue) = + match m with + | M256 v -> Avx2.M256.to_bytes ~endianess:`Little v + | M128 v -> Avx2.M128.to_bytes ~endianess:`Little v + + let of_bytes ~(endianess : Avx2.endianess) (m : bytes) = + match Bytes.length m with + | 32 -> M256 (Avx2.M256.of_bytes ~endianess m) + | 16 -> M128 (Avx2.M128.of_bytes ~endianess m) + | _ -> assert false + + let pp + ~(endianess : Avx2.endianess) + ~(size : Avx2.size) + (fmt : Format.formatter) + (m : mvalue) + = + match m with + | M256 v -> Avx2.M256.pp ~endianess ~size fmt v + | M128 v -> Avx2.M128.pp ~endianess ~size fmt v +end + +(* -------------------------------------------------------------------- *) +type vpop = { + name : string; + args : MValue.kind list; + mk : C.reg list -> C.reg; + reff : mvalue list -> mvalue; +} + +(* -------------------------------------------------------------------- *) +let call_m256_m256 + (f : Avx2.m256 -> Avx2.m256) + (vs : mvalue list) + : mvalue += + match vs with + | [M256 v] -> M256 (f v) + | _ -> assert false + +(* -------------------------------------------------------------------- *) +let call_m256_m128 + (f : Avx2.m256 -> Avx2.m128) + (vs : mvalue list) + : mvalue += + match vs with + | [M256 v] -> M128 (f v) + | _ -> assert false + +(* -------------------------------------------------------------------- *) +let call_m256_m128_m256 + (f : Avx2.m256 -> Avx2.m128 -> Avx2.m256) + (vs : mvalue list) + : mvalue += + match vs with + | [M256 v1; M128 v2] -> M256 (f v1 v2) + | _ -> assert false + +(* -------------------------------------------------------------------- *) +let call_m256x2_m256 + (f : Avx2.m256 -> Avx2.m256 -> Avx2.m256) + (vs : mvalue list) + : mvalue += + match vs with + | [M256 v1; M256 v2] -> M256 (f v1 v2) + | _ -> assert false + +(* -------------------------------------------------------------------- *) +let test_vp (total : int) (op : vpop) = + let rs = op.args |> List.mapi (fun i arg -> + match arg with + | `M256 -> C.reg ~size:256 ~name:i + | `M128 -> C.reg ~size:128 ~name:i + ) in + + let circuit = op.mk rs in + + let test () = + let vs = List.map MValue.random op.args in + let avs = Array.of_list vs in + let avs = Array.map (MValue.to_bytes ~endianess:`Little) avs in + + let env ((n, i) : C.var) = C.get_bit avs.(n) i in + + let o = + match op.reff vs with + | M256 v -> Avx2.M256.to_bytes ~endianess:`Little v + | M128 v -> Avx2.M128.to_bytes ~endianess:`Little v + in + + let o' = Array.map (C.eval env) circuit in + let o' = C.bytes_of_bools o' in + + if o <> o' then begin + Progress.interject_with (fun () -> + vs |> List.iter (fun v -> + Format.eprintf "%a@." + (MValue.pp ~endianess:`Big ~size:`U32) + v + ); + Format.eprintf "%a@." + (MValue.pp ~endianess:`Big ~size:`U32) + (MValue.of_bytes ~endianess:`Little o); + Format.eprintf "%a@." + (MValue.pp ~endianess:`Big ~size:`U32) + (MValue.of_bytes ~endianess:`Little o') + ); + assert false + end + in + + Progress.with_reporter (bar op.name total) (fun f -> + Iter.iter + (fun _ -> test (); f 1) + (Iter.(--) 0 (total-1)) + ) + +(* -------------------------------------------------------------------- *) +let test_vpadd_16u16 () = + let op = { + name = "vpadd_16u16"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpadd_16u16 x y); + reff = call_m256x2_m256 Avx2.mm256_add_epi16; + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vpadd_32u8 () = + let op = { + name = "vpadd_32u8"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpadd_32u8 x y); + reff = call_m256x2_m256 Avx2.mm256_add_epi8; + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vpsub_16u16 () = + let op = { + name = "vpsub_16u16"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpsub_16u16 x y); + reff = call_m256x2_m256 Avx2.mm256_sub_epi16; + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vpsub_32u8 () = + let op = { + name = "vpsub_32u8"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpsub_32u8 x y); + reff = call_m256x2_m256 Avx2.mm256_sub_epi8; + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vpsra_16u16 () = + let op (offset : int) = { + name = Format.sprintf "vpsra_16u16<%d>" offset; + args = [`M256]; + mk = (fun rs -> C.vpsra_16u16 (as_seq1 rs) offset); + reff = call_m256_m256 (fun x -> Avx2.mm256_srai_epi16 x offset); + } in + + Iter.iter (fun i -> test_vp 10000 (op i)) (Iter.(--) 0x00 0x10) + +(* -------------------------------------------------------------------- *) +let test_vpsrl_16u16 () = + let op (offset : int) = { + name = Format.sprintf "vpsrl_16u16<%d>" offset; + args = [`M256]; + mk = (fun rs -> C.vpsrl_16u16 (as_seq1 rs) offset); + reff = call_m256_m256 (fun x -> Avx2.mm256_srli_epi16 x offset); + } in + + Iter.iter (fun i -> test_vp 10000 (op i)) (Iter.(--) 0x00 0x10) + +(* -------------------------------------------------------------------- *) +let test_vpand_256 () = + let op = { + name = "vpand_256"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpand_256 x y); + reff = call_m256x2_m256 Avx2.mm256_and_si256; + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vpmulh_16u16 () = + let op = { + name = "vpmulh_16u16"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpmulh_16u16 x y); + reff = call_m256x2_m256 Avx2.mm256_mulhi_epi16; + } in + + test_vp 200 op + +(* -------------------------------------------------------------------- *) +let test_vpmulhu_16u16 () = + let op = { + name = "vpmulhu_16u16"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpmulhu_16u16 x y); + reff = call_m256x2_m256 Avx2.mm256_mulhi_epu16; + } in + + test_vp 200 op + +(* -------------------------------------------------------------------- *) +let test_vpmulhrs_16u16 () = + let op = { + name = "vpmulhrs_16u16"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpmulhrs_16u16 x y); + reff = call_m256x2_m256 Avx2.mm256_mulhrs_epi16; + } in + + test_vp 200 op + +(* -------------------------------------------------------------------- *) +let test_vpackus_16u16 () = + let op = { + name = "vpackus_16u16"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpackus_16u16 x y); + reff = call_m256x2_m256 Avx2.mm256_packus_epi16; + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vpackss_16u16 () = + let op = { + name = "vpackss_16u16"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpackss_16u16 x y); + reff = call_m256x2_m256 Avx2.mm256_packs_epi16; + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vpmaddubsw_256 () = + let op = { + name = "vpmaddubsw_256"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpmaddubsw_256 x y); + reff = call_m256x2_m256 Avx2.mm256_maddubs_epi16; + } in + + test_vp 200 op + +(* -------------------------------------------------------------------- *) +let test_vpermd () = + let op = { + name = "vpermd"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpermd x y); + reff = call_m256x2_m256 (fun x y -> Avx2.mm256_permutevar8x32_epi32 y x); + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vpermq () = + let op (imm8 : int) = { + name = Format.sprintf "vpermq<%d>" imm8; + args = [`M256]; + mk = (fun rs -> C.vpermq (as_seq1 rs) imm8); + reff = call_m256_m256 (fun x -> Avx2.mm256_permute4x64_epi64 x imm8); + } in + + test_vp 10000 (op 0x23); + test_vp 10000 (op 0xf7) + +(* -------------------------------------------------------------------- *) +let test_vbshufb_256 () = + let op = { + name = "vbshufb_256"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpshufb_256 x y); + reff = call_m256x2_m256 Avx2.mm256_shuffle_epi8; + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vpcmpgt_16u16 () = + let op = { + name = "vpcmpgt_16u16"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpcmpgt_16u16 x y); + reff = call_m256x2_m256 Avx2.mm256_cmpgt_epi16; + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vpmovmskb_u256u64 () = + let op = { + name = "vpmovmskb_u256u64"; + args = [`M256]; + mk = (fun rs -> C.uextend ~size:256 (C.vpmovmskb_u256u64 (as_seq1 rs))); + reff = (fun vs -> + match vs with + | [M256 v] -> + let out = Avx2.mm256_movemask_epi8 v in + let out = Int64.logand (Int64.of_int32 out) 0xffffffffL in + M256 (Avx2.M256.oftuple_64 (out, 0L, 0L, 0L)) + | _ -> + assert false + ) + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vpunpckl_32u8 () = + let op = { + name = "test_vpunpckl_32u8"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpunpckl_32u8 x y); + reff = call_m256x2_m256 Avx2.mm256_unpacklo_epi8; + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vpunpckl_4u64 () = + let op = { + name = "test_vpunpckl_4u64"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpunpckl_4u64 x y); + reff = call_m256x2_m256 Avx2.mm256_unpacklo_epi64; + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vpunpckh_4u64 () = + let op = { + name = "test_vpunpckh_4u64"; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpunpckh_4u64 x y); + reff = call_m256x2_m256 Avx2.mm256_unpackhi_epi64; + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vmovsldup_256 () = + let op = { + name = "test_vmovsldup_256"; + args = List.make 1 `M256; + mk = (fun rs -> let x = as_seq1 rs in C.vmovsldup_256 x); + reff = call_m256_m256 Avx2.mm256_moveldup_ps; + } in + + test_vp 10000 op + +(* -------------------------------------------------------------------- *) +let test_vpblend_16u16 () = + let op (imm8 : int) = { + name = Format.sprintf "test_vpblend_16u16<%d>" imm8; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpblend_16u16 x y imm8); + reff = call_m256x2_m256 (fun x y -> Avx2.mm256_blend_epi16 x y imm8); + } in + + test_vp 10000 (op 0x00); + test_vp 10000 (op 0x3f); + test_vp 10000 (op 0xaa) + +(* -------------------------------------------------------------------- *) +let test_vpblend_8u32 () = + let op (imm8 : int) = { + name = Format.sprintf "test_vpblend_8u32<%d>" imm8; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpblend_8u32 x y imm8); + reff = call_m256x2_m256 (fun x y -> Avx2.mm256_blend_epi32 x y imm8); + } in + + test_vp 10000 (op 0xaa) + + (* -------------------------------------------------------------------- *) +let test_vperm2i128 () = + let op (imm8 : int) = { + name = Format.sprintf "test_vperm2i128<%d>" imm8; + args = List.make 2 `M256; + mk = (fun rs -> let x, y = as_seq2 rs in C.vperm2i128 x y imm8); + reff = call_m256x2_m256 (fun x y -> Avx2.mm256_permute2x128_si256 x y imm8); + } in + + test_vp 10000 (op 32); + test_vp 10000 (op 49) + +(* -------------------------------------------------------------------- *) +let test_extracti128 () = + let op (i : int) = { + name = Format.sprintf "test_extracti128<%d>" i; + args = [`M256]; + mk = (fun rs -> C.vpextracti128 (as_seq1 rs) i); + reff = call_m256_m128 (fun x -> Avx2.mm256_extracti128_si256 x i); + } in + + test_vp 10000 (op 0); + test_vp 10000 (op 1) + +(* -------------------------------------------------------------------- *) +let test_inserti128 () = + let op (i : int) = { + name = Format.sprintf "test_inserti128<%d>" i; + args = [`M256; `M128]; + mk = (fun rs -> let x, y = as_seq2 rs in C.vpinserti128 x y i); + reff = call_m256_m128_m256 (fun x y -> Avx2.mm256_inserti128_si256 x y i); + } in + + test_vp 10000 (op 0); + test_vp 10000 (op 1) + +(* -------------------------------------------------------------------- *) +let test_bvueq () = + let op (size : int) : op = + let module M = (val Word.sword ~size) in + + let sim (x : int) (y : int) : int = + if x = y then 1 else 0 + in + + { name = (Format.sprintf "bvueq<%d>" size) + ; args = List.make 2 (size, `U) + ; out = `U + ; mk = (fun rs -> let x, y = as_seq2 rs in [|C.bvueq x y|]) + ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) + } + + in test (op 9) + +(* -------------------------------------------------------------------- *) +let test_bvseq () = + let op (size : int) : op = + let module M = (val Word.sword ~size) in + + let sim (x : int) (y : int) : int = + if x = y then 1 else 0 + in + + { name = (Format.sprintf "bvseq<%d>" size) + ; args = List.make 2 (size, `S) + ; out = `U + ; mk = (fun rs -> let x, y = as_seq2 rs in [|C.bvseq x y|]) + ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) + } + + in test (op 9) + +(* -------------------------------------------------------------------- *) +let test_mod () = + let op (size : int) : op = + let module M = (val Word.uword ~size) in + + let sim (x : int) (y : int) : int = + M.to_int @@ M.mod_ (M.of_int x) (M.of_int y) + in + + { name = (Format.sprintf "mod<%d>" size) + ; args = List.make 2 (size, `U) + ; out = `U + ; mk = (fun rs -> let x, y = as_seq2 rs in C.umod x y) + ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) + } + + in test (op 9) + +(* -------------------------------------------------------------------- *) +let test_smod () = + let op (size : int) : op = + let module M = (val Word.sword ~size) in + + let sim (x : int) (y : int) : int = + M.to_int @@ M.mod_ (M.of_int x) (M.of_int y) + in + + { name = (Format.sprintf "smod<%d>" size) + ; args = List.make 2 (size, `S) + ; out = `S + ; mk = (fun rs -> let x, y = as_seq2 rs in C.smod x y) + ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) + } + + in + for i = 1 to 9 do + test (op i) + done + +(* -------------------------------------------------------------------- *) +let tests = [ +(* + ("opp" , test_opp ); + ("incr", test_incr); + ("add" , test_add ); + ("sub" , test_sub ); + ("umul", test_umul); + ("smul", test_smul); + ("ssat", test_ssat); + ("usat", test_usat); + + ("sgt", test_sgt); + ("sge", test_sge); + + ("ugt", test_ugt); + ("uge", test_uge); + + ("lsl", (fun () -> test_shift ~side:`L ~sign:`U)); + ("lsr", (fun () -> test_shift ~side:`R ~sign:`U)); + ("rol", (fun () -> test_rot ~side:`L)); + ("ror", (fun () -> test_rot ~side:`R)); + + ("asl", (fun () -> test_shift ~side:`L ~sign:`S)); + ("asr", (fun () -> test_shift ~side:`R ~sign:`S)); + + ("smul_u8_s8", test_smul_u8_s8); + + ("uextend", test_uextend); + ("sextend", test_sextend); + + ("ite", test_ite); + + ("udiv", test_udiv); + ("sdiv", test_sdiv); + + ("umod", test_umod); + ("smod", test_smod); + + ("bvueq", test_bvueq); + ("bvseq", test_bvseq); + + ("popcount", test_popcount); +*) + ("vpadd_16u16" , test_vpadd_16u16 ); + ("vpadd_32u8" , test_vpadd_32u8 ); + ("vpsub_16u16" , test_vpsub_16u16 ); + ("vpsub_32u8" , test_vpsub_32u8 ); + ("vmovsldup_256" , test_vmovsldup_256 ); + ("vpblend_8u32" , test_vpblend_8u32 ); + ("vpunpckh_4u64" , test_vpunpckh_4u64 ); + ("vpunpckl_4u64" , test_vpunpckl_4u64 ); + ("vperm2i128" , test_vperm2i128 ); + ("vpsra_16u16" , test_vpsra_16u16 ); + ("vpsrl_16u16" , test_vpsrl_16u16 ); + ("vpand_256" , test_vpand_256 ); + ("vpmulh_16u16" , test_vpmulh_16u16 ); + ("vpmulhu_16u16" , test_vpmulhu_16u16 ); + ("vpmulhrs_16u16" , test_vpmulhrs_16u16 ); + ("vpackus_16u16" , test_vpackus_16u16 ); + ("vpackss_16u16" , test_vpackss_16u16 ); + ("vpmaddubsw_256" , test_vpmaddubsw_256 ); + ("vpermd" , test_vpermd ); + ("vpermq" , test_vpermq ); + ("vbshufb_256" , test_vbshufb_256 ); + ("vpcmpgt_16u16" , test_vpcmpgt_16u16 ); + ("vpmovmskb_u256u64", test_vpmovmskb_u256u64); + ("vpunpckl_32u8" , test_vpunpckl_32u8 ); + ("vpblend_16u16" , test_vpblend_16u16 ); + ("vpextracti128" , test_extracti128 ); + ("vpinserti128" , test_inserti128 ); +] + +(* -------------------------------------------------------------------- *) +let main () = + let tests = + let n = Array.length Sys.argv in + if n <= 1 then + List.map snd tests + else + let names = Array.sub Sys.argv 1 (n - 1) in + let names = Set.of_array names in + let tests = List.filter (fun (x, _) -> Set.mem x names) tests in + List.map snd tests in + + Random.self_init (); + + List.iter (fun f -> f ()) tests + +(* -------------------------------------------------------------------- *) +let () = main () diff --git a/libs/lospecs/tests/simde b/libs/lospecs/tests/simde new file mode 160000 index 0000000000..0efee69e5c --- /dev/null +++ b/libs/lospecs/tests/simde @@ -0,0 +1 @@ +Subproject commit 0efee69e5c16185cad512aefe503b812167e15fe diff --git a/libs/lospecs/typing.ml b/libs/lospecs/typing.ml new file mode 100644 index 0000000000..9601b67f2a --- /dev/null +++ b/libs/lospecs/typing.ml @@ -0,0 +1,646 @@ +(* -------------------------------------------------------------------- *) +open Ptree +open Ast + +exception DestrError of string + +(* -------------------------------------------------------------------- *) +let as_seq1 (type t) (xs : t list) : t = + match xs with [ x ] -> x | _ -> raise (DestrError "as_seq1") + +(* -------------------------------------------------------------------- *) +let as_seq2 (type t) (xs : t list) : t * t = + match xs with [ x; y ] -> (x, y) | _ -> raise (DestrError "as_seq2") + +(* FIXME: check where used and catch error if needed *) + +(* -------------------------------------------------------------------- *) +module Env : sig + type env + + type sig_ = aword list option * atype + + val empty : env + val lookup : env -> symbol -> (ident * sig_) option + val push : env -> symbol -> sig_ -> env * ident + val export : env -> (symbol, ident * sig_) Map.t +end = struct + type sig_ = aword list option * atype + + type env = { vars : (symbol, ident * sig_) Map.t } + + let empty : env = { vars = Map.empty } + + let lookup (env : env) (x : symbol) = Map.find_opt x env.vars + + let push (env : env) (x : symbol) (sig_ : sig_) = + let idx = Ident.create x in + let env = { vars = Map.add x (idx, sig_) env.vars } in + (env, idx) + + let export (env : env) : (symbol, ident * sig_) Map.t = env.vars +end + +(* -------------------------------------------------------------------- *) +type env = Env.env + +(* -------------------------------------------------------------------- *) +let tt_pword (_ : env) ({ data = `W ty } : pword) : aword = `W ty + +(* -------------------------------------------------------------------- *) +exception TypingError of range * string + +(* -------------------------------------------------------------------- *) +let mk_tyerror_r (rg : range) (f : exn -> 'a) msg = + let buf = Buffer.create 0 in + let fbuf = Format.formatter_of_buffer buf in + Format.kfprintf + (fun _ -> + Format.pp_print_flush fbuf (); + f (TypingError (rg, Buffer.contents buf))) + fbuf msg + +(* -------------------------------------------------------------------- *) +let mk_tyerror (range : range) msg = + mk_tyerror_r range identity msg + +(* -------------------------------------------------------------------- *) +let tyerror (range : range) msg = + mk_tyerror_r range (fun e -> raise e) msg + +(* -------------------------------------------------------------------- *) +let tt_type (_ : env) (t : ptype) : atype = + (t.data :> atype) + +(* -------------------------------------------------------------------- *) +let tt_type_parameters + (env : env) + (range : range) + (who : symbol) + ~(expected : int) + (tp : pword list option) += + match tp with + | None -> tyerror range "missing type parameters annotation" + | Some tp -> + let tplen = List.length tp in + if expected <> tplen then begin + tyerror range + "invalid number of type parameters for `%s': expected %d, got %d" + who expected tplen + end; + (List.map (tt_pword env) tp) + +(* -------------------------------------------------------------------- *) +let check_arguments_count (range : range) ~(expected : int) (args : pexpr list) = + if List.length args <> expected then + tyerror range "invalid number of arguments"; + args + +(* -------------------------------------------------------------------- *) +let check_plain_arg (_ : env) (arg : pexpr option loced) = + match arg.data with + | None -> begin + tyerror + arg.range + "this argument cannot be generalized (not in a higher-order context)" + end + | Some arg -> + arg + +(* -------------------------------------------------------------------- *) +let as_int_constant (e : pexpr) : int = + match e.data with + | PEInt (i, None) -> i + | _ -> tyerror e.range "integer constant expected" + +(* -------------------------------------------------------------------- *) +type sig_ = { + s_name : string; + s_ntyparams : int; + s_argsty : aword list -> aword list; + s_retty : aword list -> aword; + s_mk : aword list -> aexpr list -> aexpr_; +} + +(* -------------------------------------------------------------------- *) +module Sigs : sig + val sla : sig_ + val sra : sig_ + val sll : sig_ + val srl : sig_ + val usat : sig_ + val ssat : sig_ + val uextend : sig_ + val sextend : sig_ + val not : sig_ + val incr : sig_ + val add : sig_ + val ssadd : sig_ + val usadd : sig_ + val sub : sig_ + val and_ : sig_ + val or_ : sig_ + val xor_ : sig_ + val umul : sig_ + val umullo : sig_ + val umulhi : sig_ + val smul : sig_ + val smullo : sig_ + val smulhi : sig_ + val usmul : sig_ + val sgt : sig_ + val sge : sig_ + val ugt : sig_ + val uge : sig_ + val popcount : sig_ +end = struct + let mk1 (f : aexpr -> aexpr_) (a : aexpr list) = + f (as_seq1 a) + + let mk2 (f : aexpr -> aexpr -> aexpr_) (a : aexpr list) = + let x, y = as_seq2 a in f x y + + let uniop ?(ret = fun x -> x) ~(name : string) mk = { + s_name = name; + s_ntyparams = 1; + s_argsty = (fun ws -> [as_seq1 ws]); + s_retty = (fun ws -> `W (ret (get_size (as_seq1 ws)))); + s_mk = fun ws -> mk1 (mk ws); + } + + let binop ?(ret = fun x -> x) ~(name : string) mk = { + s_name = name; + s_ntyparams = 1; + s_argsty = (fun ws -> List.make 2 (as_seq1 ws)); + s_retty = (fun ws -> `W (ret (get_size (as_seq1 ws)))); + s_mk = fun ws -> mk2 (mk ws); + } + + let satop ~(name : string) (k : us) = { + s_name = name; + s_ntyparams = 2; + s_argsty = (fun ws -> [fst (as_seq2 ws)]); + s_retty = (fun ws -> snd (as_seq2 ws)); + s_mk = (fun ws -> mk1 (fun x -> ESat (k, snd (as_seq2 ws), x))); + } + + let extendop ~(name : string) (k : us) = { + s_name = name; + s_ntyparams = 2; + s_argsty = (fun ws -> [fst (as_seq2 ws)]); + s_retty = (fun ws -> snd (as_seq2 ws)); + s_mk = (fun ws -> mk1 (fun x -> EExtend (k, snd (as_seq2 ws), x))); + } + + let shiftop ~(name : string) (d : lr) (k : la) = { + s_name = name; + s_ntyparams = 1; + s_argsty = (fun ws -> [as_seq1 ws; `W 8]); + s_retty = (fun ws -> as_seq1 ws); + s_mk = (fun _ -> mk2 (fun x y -> EShift (d, k, (x, y)))); + } + + let mulop ?ret ~(name : string) (k : mulk) = + let mk = fun ws x y -> + let w = as_seq1 ws in + EMul (k, w, (x, y)) + in + binop ?ret ~name mk + + let sla : sig_ = + shiftop ~name:"sla" `L `A + + let sra : sig_ = + shiftop ~name:"sra" `R `A + + let sll : sig_ = + shiftop ~name:"sll" `L `L + + let srl : sig_ = + shiftop ~name:"srl" `R `L + + let usat : sig_ = + satop ~name:"usat" `U + + let ssat : sig_ = + satop ~name:"ssat" `S + + let uextend : sig_ = + extendop ~name:"uextend" `U + + let sextend : sig_ = + extendop ~name:"sextend" `S + + let not : sig_ = + let mk = fun ws x -> ENot (as_seq1 ws, x) in + uniop ~name:"not" mk + + let incr : sig_ = + let mk = fun ws x -> EIncr (as_seq1 ws, x) in + uniop ~name:"incr" mk + + let add : sig_ = + let mk = fun ws x y -> EAdd (as_seq1 ws, `Word, (x, y)) in + binop ~name:"add" mk + + let ssadd : sig_ = + let mk = fun ws x y -> EAdd (as_seq1 ws, `Sat `S, (x, y)) in + binop ~name:"ssadd" mk + + let usadd : sig_ = + let mk = fun ws x y -> EAdd (as_seq1 ws, `Sat `U, (x, y)) in + binop ~name:"usadd" mk + + let sub : sig_ = + let mk = fun ws x y -> ESub (as_seq1 ws, (x, y)) in + binop ~name:"sub" mk + + let and_ : sig_ = + let mk = fun ws x y -> EAnd (as_seq1 ws, (x, y)) in + binop ~name:"and" mk + + let or_ : sig_ = + let mk = fun ws x y -> EOr (as_seq1 ws, (x, y)) in + binop ~name:"or" mk + + let umul : sig_ = + mulop ~ret:(fun n -> 2 * n) ~name:"umul" (`U `D) + + let umulhi : sig_ = + mulop ~name:"umulhi" (`U `H) + + let umullo : sig_ = + mulop ~name:"umullo" (`U `L) + + let smul : sig_ = + mulop ~ret:(fun n -> 2 * n) ~name:"smul" (`S `D) + + let smulhi : sig_ = + mulop ~name:"smulhi" (`S `H) + + let smullo : sig_ = + mulop ~name:"smullo" (`S `L) + + let usmul : sig_ = + mulop ~ret:(fun n -> 2 * n) ~name:"usmul" `US + + let sgt : sig_ = + let mk = fun ws x y -> ECmp (as_seq1 ws, `S, `Gt, (x, y)) in + binop ~ret:(fun _ -> 1) ~name:"sgt" mk + + let sge : sig_ = + let mk = fun ws x y -> ECmp (as_seq1 ws, `S, `Ge, (x, y)) in + binop ~ret:(fun _ -> 1) ~name:"sge" mk + + let ugt : sig_ = + let mk = fun ws x y -> ECmp (as_seq1 ws, `U, `Gt, (x, y)) in + binop ~ret:(fun _ -> 1) ~name:"ugt" mk + + let uge : sig_ = + let mk = fun ws x y -> ECmp (as_seq1 ws, `U, `Ge, (x, y)) in + binop ~ret:(fun _ -> 1) ~name:"uge" mk + + let xor_ : sig_ = + let mk = fun ws x y -> EXor (as_seq1 ws, (x, y)) in + binop ~name:"xor" mk + + let popcount = { + s_name = "popcount"; + s_ntyparams = 2; + s_argsty = (fun ws -> [fst (as_seq2 ws)]); + s_retty = (fun ws -> snd (as_seq2 ws)); + s_mk = (fun ws -> mk1 (fun x -> EPopCount (snd (as_seq2 ws), x))); + } +end + +(* -------------------------------------------------------------------- *) +let sigs : sig_ list = [ + Sigs.sla; + Sigs.sra; + Sigs.sll; + Sigs.srl; + Sigs.usat; + Sigs.ssat; + Sigs.uextend; + Sigs.sextend; + Sigs.not; + Sigs.incr; + Sigs.add; + Sigs.ssadd; + Sigs.usadd; + Sigs.sub; + Sigs.and_; + Sigs.or_; + Sigs.xor_; + Sigs.umul; + Sigs.umullo; + Sigs.umulhi; + Sigs.smul; + Sigs.smullo; + Sigs.smulhi; + Sigs.usmul; + Sigs.sgt; + Sigs.sge; + Sigs.ugt; + Sigs.uge; + Sigs.popcount; +] + +(* -------------------------------------------------------------------- *) +let get_sig_of_name (name : string) : sig_ option = + List.find_opt (fun x -> x.s_name = name) sigs + +(* -------------------------------------------------------------------- *) +let ty_compatible ~(src : atype) ~(dst : atype) : bool = + match src, dst with + | (`Signed | `Unsigned), `W _ -> true + | _, _ -> src = dst + +(* -------------------------------------------------------------------- *) +let join_types (ty1 : atype loced) (ty2 : atype loced) = + match ty1.data, ty2.data with + | `Unsigned, `W n -> `W n + | `W n, `Unsigned -> `W n + | _, _ -> + if ty1.data <> ty2.data then + tyerror + (Lc.merge ty1.range ty2.range) + "the branches of the conditional have incompatible types: %a / %a" + pp_atype ty1.data pp_atype ty2.data + else ty1.data + +(* -------------------------------------------------------------------- *) +let rec tt_expr_ (env : env) (e : pexpr) : aargs option * aexpr = + match e.data with + | PEParens e -> + (None, tt_expr env e) + + | PEInt (i, w) -> + let w = Option.map (tt_pword env) w in + let type_ = Option.default `Unsigned (w :> atype option) in + let e = { node = EInt i; type_; } in + (None, e) + + | PEFun (fargs, f) -> + let benv, args = tt_args env fargs in + (Some args, tt_expr benv f) + + | PEFName { data = (v, None) } -> begin + let (vid, (targs, vt)) = Option.get_exn + (Env.lookup env (Lc.unloc v)) + (mk_tyerror v.range "unknown variable: %s" (Lc.unloc v)) in + + match targs with + | None -> + (None, { node = EVar vid; type_ = vt; }) + + | Some targs -> + let ftargs = + List.map (fun ty -> (Ident.create "_", ty)) targs in + let args = + List.map + (fun (x, ty) -> { node = EVar x; type_ = (ty :> atype) }) + ftargs in + (Some ftargs, { node = EApp (vid, args); type_ = vt; }) + end + + | PEFName { data = (v, Some ws) } -> + let sig_ = + Option.get_exn + (get_sig_of_name (Lc.unloc v)) + (mk_tyerror v.range "unkown symbol: %s" (Lc.unloc v)) + in + + let ws = List.map (tt_pword env) ws in + let args = sig_.s_argsty ws in + let retty = sig_.s_retty ws in + let args = List.map (fun ty -> (Ident.create "_", ty)) args in + + let eargs = + List.map (fun (x, ty) -> + { node = EVar x; type_ = (ty :> atype); } + ) args + in + let node = sig_.s_mk ws eargs in + (Some args, { node; type_ = (retty :> atype); }) + + | PELet ((v, args, e1), e2) -> + let args, e1 = + let env, args = + args + |> Option.map (tt_args env) + |> Option.map (fun (e, a) -> (e, Some a)) + |> Option.default (env, None) in + let e1 = tt_expr env e1 in + (args, e1) + in + + let ebody, vid = + let targs = Option.map (List.map snd) args in + Env.push env (Lc.unloc v) (targs, e1.type_) in + + let e2 = tt_expr ebody e2 in + + let node = ELet ((vid, args, e1), e2) in + let type_ = e2.type_ in + + (None, { node; type_; }) + + | PECond (c, (pe1, pe2)) -> + let c = tt_expr env c in (* FIXME: must be a word *) + let e1 = tt_expr env pe1 in + let e2 = tt_expr env pe2 in + + let type_ = + join_types + (Lc.mk pe1.range e1.type_) + (Lc.mk pe2.range e2.type_) + in + + let e1 = { e1 with type_ } in + let e2 = { e2 with type_ } in + + let node = ECond (c, (e1, e2)) in + + (None, { node; type_; }) + + | PESlice (ev, (start, len, scale)) -> + let ev = tt_expr env ev in + let start = tt_expr env start in + let len = Option.default 1 (Option.map as_int_constant len) in + let scale = Option.default 1 (Option.map as_int_constant scale) in + let node = ESlice (ev, (start, len, scale)) + and type_ = `W (len * scale) in + (None, { node; type_; }) + + | PEAssign (ev, (start, len, scale), v) -> + let ev = tt_expr env ev in + let start = tt_expr env start in + let len = Option.default 1 (Option.map as_int_constant len) in + let scale = Option.default 1 (Option.map as_int_constant scale) in + let v = tt_expr env ~check:(`W (len * scale)) v in + let node = EAssign (ev, (start, len, scale), v) in + (None, { node; type_ = ev.type_; }) + + | PEApp ({ data = (f, None) }, args) -> + let (vid, (targs, vt)) = Option.get_exn + (Env.lookup env (Lc.unloc f)) + (mk_tyerror f.range "unknown symbol: %s" (Lc.unloc f)) in + + let targs = + Option.get_exn + targs + (mk_tyerror f.range "the symbol `%s' cannot be applied" (Lc.unloc f)) in + + if List.length args <> List.length targs then begin + tyerror e.range + "invalid number of arguments: expected %d, got %d" + (List.length targs) (List.length args) + end; + + let bds, args = List.fold_left_map (fun bds (a, ety) -> + match a.data with + | None -> + let x = Ident.create "_" in + let a = { node = EVar x; type_ = (ety :> atype); } in + ((x, ety) :: bds, a) + | Some a -> + (bds, tt_expr env ~check:(ety :> atype) a) + ) [] (List.combine args targs) + in + + let bds = if List.is_empty bds then None else Some (List.rev bds) in + let node = EApp (vid, args) in + + (bds, { node; type_ = vt; }) + + | PEApp ({ data = ({ data = "concat" as f }, w) } as fn, args) -> + let (`W w) = as_seq1 (tt_type_parameters env fn.range f ~expected:1 w) in + let args = List.map (check_plain_arg env) args in + let targs = List.map (tt_expr env ~check:(`W w)) args in + let wsz = `W (w * List.length targs) in + (None, { node = EConcat (wsz, targs); type_ = wsz; }) + + | PEApp ({ data = ({ data = "repeat" as f }, w) } as fn, args) -> + let (`W w) = as_seq1 (tt_type_parameters env fn.range f ~expected:1 w) in + let args = List.map (check_plain_arg env) args in + let e, n = as_seq2 (check_arguments_count e.range ~expected:2 args) in + let n = as_int_constant n in + let ne = tt_expr env ~check:(`W w) e in + (None, { node = ERepeat (`W (w * n), (ne, n)); type_ = `W (w * n); }) + + | PEApp ({ data = ({ data = "map" as c }, w) } as cn, args) -> + let `W w, `W n = as_seq2 (tt_type_parameters env cn.range c ~expected:2 w) in + let args = List.map (check_plain_arg env) args in + + if List.is_empty args then + tyerror e.range "the combinator `map' takes at least one argument"; + + let f, args = (List.hd args, List.tl args) in + let nargs = List.map (tt_expr ~check:(`W (w * n)) env) args in + + let ftargs, ftbody = tt_expr_ env f in + + let ftype = + match ftbody.type_ with + | `W k -> k + | _ -> tyerror f.range "the mapped function should return a word" in + + let ftargs = + Option.get_exn + ftargs + (mk_tyerror f.range "this expression must be higher-order") in + + let targs = List.map snd ftargs in + + if targs <> List.make (List.length args) (`W w) then begin + tyerror e.range + "the mapped function must take exactly %d arguments of type @%d" + (List.length targs) w + end; + + let node = EMap ((`W w, `W n), (ftargs, ftbody), nargs) + and type_ = `W (n * ftype) in + (None, { node; type_; }) + + | PEApp ({ data = (f, Some ws) } as fn, args) -> + let sig_ = + Option.get_exn + (get_sig_of_name (Lc.unloc f)) + (mk_tyerror f.range "unknown symbol: %s" (Lc.unloc f)) + in + tt_fname_app env e.range sig_ (Lc.mk fn.range ws) args + +(* -------------------------------------------------------------------- *) +and tt_fname_app + (env : env) + (range : range) + (sig_ : sig_) + (ws : pword list loced) + (args : pexpr option loced list) += + let ws = + tt_type_parameters + env ws.range sig_.s_name ~expected:sig_.s_ntyparams + (Some ws.data) + in + + let targs = sig_.s_argsty ws in + + if List.length args <> List.length targs then begin + tyerror range + "invalid number of arguments for `%s': expected %d, get %d" + sig_.s_name (List.length targs) (List.length args) + end; + + let bds, args = List.fold_left_map (fun bds (a, ety) -> + match a.data with + | None -> + let x = Ident.create "_" in + let a = { node = EVar x; type_ = (ety :> atype); } in + ((x, ety) :: bds, a) + | Some a -> + (bds, tt_expr env ~check:(ety :> atype) a) + ) [] (List.combine args targs) + in + + let bds = if List.is_empty bds then None else Some (List.rev bds) in + + let node = sig_.s_mk ws args in + let type_ = (sig_.s_retty ws :> atype) in + + (bds, { node; type_; }) + +(* -------------------------------------------------------------------- *) +and tt_expr (env : env) ?(check : atype option) (p : pexpr) : aexpr = + let (args, {node = n_; type_ = t;}) = tt_expr_ env p in + if not (Option.is_none args) then + tyerror p.range "high-order functions not allowed here"; + check |> Option.may (fun dst -> + if not (ty_compatible ~src:t ~dst) then begin + tyerror p.range + "this expression has type %a but is expected to have type %a" + pp_atype t pp_atype dst + end); + { node = n_; type_ = Option.default t check; } + +(* -------------------------------------------------------------------- *) +and tt_arg (env : env) ((x, { data = `W ty }) : parg) : env * aarg = + let env, idx = Env.push env (Lc.unloc x) (None, `W ty) in + (env, (idx, `W ty)) + +(* -------------------------------------------------------------------- *) +and tt_args (env : env) (args : pargs) : env * aargs = + List.fold_left_map tt_arg env args + +(* -------------------------------------------------------------------- *) +let tt_def (env : env) (p : pdef) : symbol * adef = + let env, args = tt_args env p.args in + let rty = tt_pword env p.rty in + let bod = tt_expr env ~check:(rty :> atype) p.body in + (p.name, { name = p.name; arguments = args; body = bod; rettype = rty; }) + +(* -------------------------------------------------------------------- *) +let tt_program (env : env) (p : pprogram) : (symbol * adef) list = + List.map (tt_def env) p diff --git a/libs/lospecs/word.ml b/libs/lospecs/word.ml new file mode 100644 index 0000000000..70601c824d --- /dev/null +++ b/libs/lospecs/word.ml @@ -0,0 +1,193 @@ +(* -------------------------------------------------------------------- *) +module type S = sig + type t + + val nbits : int + + val zero : t + val one : t + + val neg : t -> t + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val div : t -> t -> t + + val lognot : t -> t + val logand : t -> t -> t + val logor : t -> t -> t + val logxor : t -> t -> t + + val shiftl : t -> int -> t + val shiftr : t -> int -> t + + val abs : t -> t + + val of_int : int -> t + val to_int : t -> int + + val mod_ : t -> t -> t +end + +(* -------------------------------------------------------------------- *) +module type Size = sig + val nbits : int +end + +(* -------------------------------------------------------------------- *) +module SWord(I : Size) : S = struct + type t = int + + let () = assert (I.nbits < Sys.int_size) + + let nbits = I.nbits + + let of_int (x : int) : t = + x lsl (Sys.int_size - nbits) + + let to_int (x : t) : int = + x asr (Sys.int_size - nbits) + + let mask : int = + (1 lsl nbits) - 1 + + let zero : t = + of_int 0 + + let one : t = + of_int 1 + + let add (x : t) (y : t) = + x + y + + let sub (x : t) (y : t) = + x - y + + let neg (x : t) : t = + -x + + let mul (x : t) (y : t) : t = + (to_int x) * y + + let div (x : t) (y : t) : t = + of_int (x / y) + + let logand (x : t) (y : t) : t = + x land y + + let logor (x : t) (y : t) : t = + x lor y + + let logxor (x : t) (y : t) : t = + (x lxor y) land (of_int mask) + + let lognot (x : t) : t = + logxor x (of_int (-1)) + + let shiftl (x : t) (y : int) : t = + x lsl y + + let shiftr (x : t) (y : t) : t = + (x asr y) land (of_int mask) + + let abs (x : t) : t = + abs x + + (* Careful with size *) + let urem (x : t) (y : t) : t = + assert (Sys.int_size - nbits >= 1); + let x = x lsr 1 in + let y = y lsr 1 in + (x mod y) lsl 1 + + let mod_ (x: t) (y: t) : t = + if y = zero then x else + let u = urem (abs x) (abs y) in + if u = zero + then u + else if (x >= zero) && (y >= zero) + then u + else if (x < zero) && (y >= zero) + then (-u + y) + else if (x >= zero) && (y < zero) + then (u + y) + else -u + +end + +(* -------------------------------------------------------------------- *) +module UWord(I : Size) : S = struct + type t = int + + let () = assert (I.nbits < Sys.int_size) + + let nbits = I.nbits + + let mask : int = + (1 lsl nbits) - 1 + + let of_int (x : int) : t = + x land mask + + let to_int (x : t) : int = + x + + let zero : t = + of_int 0 + + let one : t = + of_int 1 + + let add (x : t) (y : t) = + of_int (x + y) + + let sub (x : t) (y : t) = + of_int (x - y) + + let neg (x : t) : t = + of_int (-x) + + let mul (x : t) (y : t) = + of_int (x * y) + + let div (x : t) (y : t) : t = + of_int (x / y) + + let logand (x : t) (y : t) : t = + x land y + + let logor (x : t) (y : t) : t = + x lor y + + let logxor (x : t) (y : t) = + x lxor y + + let lognot (x : t) : t = + x lxor mask + + let shiftl (x : t) (y : int) = + of_int (x lsl y) + + let shiftr (x : t) (y : int) = + x lsr y + + let abs (x : t) : t = + x + + let mod_ (x: t) (y : t) : t = + if y = 0 then x else x mod y +end + +(* -------------------------------------------------------------------- *) +let sword ~(size : int) : (module S) = + (module SWord(struct let nbits = size end)) + +(* -------------------------------------------------------------------- *) +let uword ~(size : int) : (module S) = + (module UWord(struct let nbits = size end)) + +(* -------------------------------------------------------------------- *) +let word ~(sign : [`U | `S]) ~(size : int) : (module S) = + match sign with + | `U -> uword ~size + | `S -> sword ~size diff --git a/libs/lospecs/word.mli b/libs/lospecs/word.mli new file mode 100644 index 0000000000..6871239ed9 --- /dev/null +++ b/libs/lospecs/word.mli @@ -0,0 +1,37 @@ +(* -------------------------------------------------------------------- *) +module type S = sig + type t + + val nbits : int + + val zero : t + val one : t + + val neg : t -> t + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val div : t -> t -> t + + val lognot : t -> t + val logand : t -> t -> t + val logor : t -> t -> t + val logxor : t -> t -> t + + val shiftl : t -> int -> t + val shiftr : t -> int -> t + + val abs : t -> t + + val of_int : int -> t + val to_int : t -> int + + val mod_ : t -> t -> t +end + +(* -------------------------------------------------------------------- *) +val sword : size:int -> (module S) +val uword : size:int -> (module S) + +(* -------------------------------------------------------------------- *) +val word : sign:[`U | `S] -> size:int -> (module S) diff --git a/src/dune b/src/dune index 487e9cfcf5..3f4943859c 100644 --- a/src/dune +++ b/src/dune @@ -16,7 +16,7 @@ (public_name easycrypt.ecLib) (foreign_stubs (language c) (names eunix)) (modules :standard \ ec) - (libraries batteries camlp-streams dune-build-info dune-site inifiles markdown markdown.html pcre2 tyxml why3 yojson zarith) + (libraries batteries camlp-streams dune-build-info dune-site inifiles lospecs markdown markdown.html pcre2 tyxml why3 yojson zarith) ) (executable diff --git a/src/ec.ml b/src/ec.ml index 627d25b81b..763c709aa5 100644 --- a/src/ec.ml +++ b/src/ec.ml @@ -415,6 +415,7 @@ let main () = (*---*) gccompact : int option; (*---*) docgen : bool; (*---*) outdirp : string option; + (*---*) specs : spec_options; mutable trace : trace1 list option; } @@ -493,6 +494,7 @@ let main () = ; gccompact = None ; docgen = false ; outdirp = None + ; specs = cliopts.clio_specs ; trace = None } end @@ -528,6 +530,7 @@ let main () = ; gccompact = cmpopts.cmpo_compact ; docgen = false ; outdirp = None + ; specs = cmpopts.cmpo_specs ; trace = trace0 } end @@ -564,6 +567,10 @@ let main () = lazy (T.from_channel ~name (open_in name)) in + let nospec = { + files = []; + } in + { prvopts = prvoff ; input = Some name ; terminal = terminal @@ -572,6 +579,7 @@ let main () = ; gccompact = None ; docgen = true ; outdirp = docopts.doco_outdirp + ; specs = nospec ; trace = None } end @@ -693,6 +701,7 @@ let main () = EcCommands.cm_provers = state.prvopts.prvo_provers; EcCommands.cm_profile = state.prvopts.prvo_profile; EcCommands.cm_iterate = state.prvopts.prvo_iterate; + EcCommands.cm_specs = state.specs.files; } in let checkproof = not state.docgen in diff --git a/src/ecBigInt.ml b/src/ecBigInt.ml index a9a8b5a845..8788ce3035 100644 --- a/src/ecBigInt.ml +++ b/src/ecBigInt.ml @@ -74,6 +74,12 @@ module ZImpl : EcBigIntCore.TheInterface = struct let to_why3 (x : zint) = Why3.BigInt.of_string (to_string x) + + let to_zt (x: zint) : Z.t = + x + + let of_zt (z: Z.t) : zint = + z end (* -------------------------------------------------------------------- *) @@ -150,6 +156,12 @@ module BigNumImpl : EcBigIntCore.TheInterface = struct let to_why3 (x : zint) = Why3.BigInt.of_string (to_string x) + + let to_zt (x: zint) : Z.t = + x |> to_string |> Z.of_string + + let of_zt (z: Z.t) : zint = + z |> Z.to_string |> of_string end (* -------------------------------------------------------------------- *) diff --git a/src/ecBigIntCore.ml b/src/ecBigIntCore.ml index 39d9391478..07ee40d242 100644 --- a/src/ecBigIntCore.ml +++ b/src/ecBigIntCore.ml @@ -64,4 +64,6 @@ module type TheInterface = sig val pp_print : Format.formatter -> zint -> unit val to_why3 : zint -> Why3.BigInt.t + val to_zt: zint -> Z.t + val of_zt: Z.t -> zint end diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml new file mode 100644 index 0000000000..c17750048b --- /dev/null +++ b/src/ecCircuits.ml @@ -0,0 +1,1114 @@ +(* -------------------------------------------------------------------- *) +open EcUtils +open EcBigInt +open EcPath +open EcEnv +open EcAst +open EcCoreFol +open EcIdent +open LDecl +open EcLowCircuits + +(* -------------------------------------------------------------------- *) +module Map = Batteries.Map +module Hashtbl = Batteries.Hashtbl +module Set = Batteries.Set +module Option = Batteries.Option + +(* -------------------------------------------------------------------- *) +let debug : bool = EcLowCircuits.debug + +(* -------------------------------------------------------------------- *) +let circ_red (hyps: hyps) = let base_red = EcReduction.full_red in + {base_red with delta_p = (fun pth -> + if (EcEnv.Circuit.reverse_operator (LDecl.toenv hyps) pth |> List.is_empty) then + base_red.delta_p pth + else + `No) +} + +(* FIXME: should change to a decent direct hash of this + store the forms *) +(* also move the cache here? *) +module AInvFHash = struct + type t = form + + let known_hashes : (int, int) Map.t ref = ref Map.empty + + let clean_known : unit -> unit = + fun () -> known_hashes := Map.empty + + let bruijn_idents : (int, ident) Map.t ref = ref Map.empty + + let clean_bruijn_idents : unit -> unit = + fun () -> bruijn_idents := Map.empty + + let form_storage : (int, form) Map.t ref = ref Map.empty + + let clean_form_storage : unit -> unit = + fun () -> form_storage := Map.empty + + let nuke_state_from_orbit : unit -> unit = + fun () -> + clean_known (); + clean_bruijn_idents (); + clean_form_storage () + + let ident_of_debruijn_level (i: int) : ident = + match Map.find_opt i !bruijn_idents with + | Some id -> id + | None -> let id = create (string_of_int i) in + bruijn_idents := Map.add i id !bruijn_idents; + id + + type state = { + level: int; + subst: EcSubst.subst; + } + + + let add_to_state (id: ident) (ty: ty) (st: state) = + let new_id = ident_of_debruijn_level st.level in + let level = st.level + 1 in + let subst = EcSubst.add_flocal st.subst id (f_local new_id ty) in + { level; subst }, new_id + + + let to_debruijn (f: form) : form = + let rec doit (st: state) (f: form) = + match f.f_node with + | Fquant (qnt, bnds, f) -> + let st, bnds = + List.fold_left_map (fun st (orig_id, gty) -> + match gty with + | GTty ty -> + let st, new_id = add_to_state orig_id ty st in + st, (new_id, gty) + | _ -> + st, (orig_id, gty) + ) st bnds + in f_quant qnt bnds (doit st (EcSubst.subst_form st.subst f)) + | Fif (cond, tb, fb) -> + let doit = doit st in + f_if (doit cond) (doit tb) (doit fb) + | Fmatch (_, _, _) -> assert false + | Flet (lp, value, body) -> + begin match lp with + | LSymbol (orig_id, ty) -> + let nval = doit st value in + let st, new_id = add_to_state orig_id ty st in + let nbody = doit st (EcSubst.subst_form st.subst body) in + f_let (LSymbol (new_id, ty)) nval nbody + | LTuple bnds -> + let nval = doit st value in + let st, new_ids = List.fold_left_map (fun st (id, ty) -> add_to_state id ty st) st bnds in + let nbody = doit st (EcSubst.subst_form st.subst body) in + let nbinds = List.combine new_ids (List.snd bnds) in + f_let (LTuple nbinds) nval nbody + | LRecord (_, _) -> assert false + end + | Fapp (op, args) -> + let nargs = List.map (doit st) args in + let nop = doit st op in + f_app nop nargs f.f_ty + | Ftuple comps -> + f_tuple (List.map (doit st) comps) + | Fproj (tp, i) -> + f_proj (doit st tp) i f.f_ty + | FhoareF { hf_m; hf_pr; hf_f; hf_po } -> + let npre = doit st hf_pr in + let npo = doit st hf_po in + let m = hf_m in + f_hoareF {inv=npre;m} hf_f {inv=npo;m} + | FhoareS { hs_m=(m, me); hs_pr; hs_s; hs_po } -> + let npre = doit st hs_pr in + let npo = doit st hs_po in + f_hoareS me {inv=npre;m} hs_s {inv=npo;m} + | FbdHoareF _ -> assert false + | FbdHoareS _ -> assert false + | FeHoareF _ -> assert false + | FeHoareS _ -> assert false + | FequivF { ef_ml; ef_mr; ef_pr; ef_fl; ef_fr; ef_po } -> + let npre = doit st ef_pr in + let npo = doit st ef_po in + f_equivF {inv=npre;ml=ef_ml;mr=ef_mr} ef_fl ef_fr {inv=npo;ml=ef_ml;mr=ef_mr} + | FequivS { es_ml=(ml, mel); es_mr=(mr, mer); es_pr; es_sl; es_sr; es_po } -> + let npre = doit st es_pr in + let npo = doit st es_po in + f_equivS mel mer {inv=npre;ml;mr} es_sl es_sr {inv=npo;ml;mr} + | FeagerF _ -> assert false + | Fpr _ -> assert false + | Fint _ + | Flocal _ + | Fpvar (_, _) + | Fglob (_, _) + | Fop (_, _) -> f + in + doit {level = 0; subst = EcSubst.empty} f + + (* FIXME: Check that this does not incur false positives *) + let hash_form (f: form) = + match Map.find_opt f.f_tag !known_hashes with + | Some hash -> hash + | None -> let fnorm = to_debruijn f in + form_storage := Map.add f.f_tag fnorm !form_storage; + known_hashes := Map.add f.f_tag fnorm.f_tag !known_hashes; + fnorm.f_tag +end + +(* -------------------------------------------------------------------- *) +type width = int +exception MissingTyBinding of ty +exception AbstractTyBinding of ty +exception InvalidArgument +exception MissingOpBinding of path +exception MissingOpSpec of path +exception IntConversionFailure +exception DestrError of string (* FIXME: change this one *) +exception MissingOpBody (* FIXME: rename? *) +exception BadFormForArg (* FIXME: rename *) +exception CantConvertToConstant +exception CantReadWriteGlobs +exception CantConvertToCirc of + [ `Int + | `OpK of EcFol.op_kind + | `Op of path + | `Quantif of quantif + | `Match + | `Glob + | `Record + | `Hoare + | `Instr +] + +let ty_of_path (p: path) : ty = + EcTypes.tconstr p [] + +let rec ctype_of_ty (env: env) (ty: ty) : ctype = + match ty.ty_node with + | Ttuple tys -> CTuple (List.map (ctype_of_ty env) tys) + | Tconstr (pth, []) when pth = EcCoreLib.CI_Bool.p_bool -> CBool + | _ -> begin + match EcEnv.Circuit.lookup_array_and_bitstring env ty with + | Some ({size=(_, Some size_arr)}, {size=(_, Some size_bs)}) -> CArray {width=size_bs; count=size_arr} + | None -> + begin match EcEnv.Circuit.lookup_bitstring_size env ty with + | Some sz -> CBitstring sz + | _ -> + raise (MissingTyBinding ty) + end + | Some ({size = (_, None)}, _) -> + raise (AbstractTyBinding ty) + | Some (_, {size = (_, None)}) -> + raise (AbstractTyBinding ty) + end + +let width_of_type (env: env) (t: ty) : int = + let cty = ctype_of_ty env t in + EcLowCircuits.size_of_ctype cty + +(* FIXME: Fix an order for array size parameters, this one goes against the rest *) +let shape_of_array_type (env: env) (t: ty) : (int * int) = + match ctype_of_ty env t with + | CArray {width=w; count=n} -> (n, w) + | _ -> raise InvalidArgument + +let input_of_type ~name (env: env) (t: ty) : circuit = + let ct = ctype_of_ty env t in + input_of_ctype ~name ct + +(* Should correspond to QF_ABV *) +module BVOps = struct + let temp_symbol = "temp_circ_input" + + let is_of_int (env: env) (p: path) : bool = + match EcEnv.Circuit.reverse_bitstring_operator env p with + | Some (_, `OfInt) -> true + | _ -> false + + let op_is_parametric_bvop (env: env) (op: path) : bool = + match EcEnv.Circuit.lookup_bvoperator_path env op with + | Some { kind = `ASliceGet _ } + | Some { kind = `ASliceSet _ } + | Some { kind = `Extract _ } + | Some { kind = `Insert _ } + | Some { kind = `Map _ } + | Some { kind = `Get _ } + | Some { kind = `AInit _ } + | Some { kind = `Init _ } -> true + | _ -> false + + let circuit_of_parametric_bvop (env : env) (op: [`Path of path | `BvBind of EcDecl.crb_bvoperator]) (args: arg list) : circuit = + let op = match op with + | `BvBind op -> op + | `Path p -> begin match EcEnv.Circuit.lookup_bvoperator_path env p with + | Some op -> op + | None -> raise (MissingOpBinding p) + end + in + circuit_of_parametric_bvop op args + + let op_is_bvop (env: env) (op : path) : bool = + match EcEnv.Circuit.lookup_bvoperator_path env op with + | Some { kind = `Add _ } | Some { kind = `Sub _ } + | Some { kind = `Mul _ } | Some { kind = `Div _ } + | Some { kind = `Rem _ } | Some { kind = `Shl _ } + | Some { kind = `Shr _ } | Some { kind = `Rol _ } + | Some { kind = `Shrs _ } | Some { kind = `Shls _ } + | Some { kind = `Ror _ } | Some { kind = `And _ } + | Some { kind = `Or _ } | Some { kind = `Xor _ } + | Some { kind = `Not _ } | Some { kind = `Lt _ } + | Some { kind = `Le _ } | Some { kind = `Extend _ } + | Some { kind = `Truncate _ } | Some { kind = `Concat _ } + | Some { kind = `A2B _ } | Some { kind = `B2A _ } + | Some { kind = `Opp _ } -> true + | Some { kind = + `ASliceGet _ + | `ASliceSet _ + | `Extract _ + | `Insert _ + | `Map _ + | `AInit _ + | `Get _ + | `Init _ } + | None -> false + + let circuit_of_bvop (env: env) (op: [`Path of path | `BvBind of EcDecl.crb_bvoperator]) : circuit = + let op = match op with + | `BvBind op -> op + | `Path p -> begin match EcEnv.Circuit.lookup_bvoperator_path env p with + | Some op -> op + | None -> raise (MissingOpBinding p) + end + in + circuit_of_bvop op +end +open BVOps + +module BitstringOps = struct + type binding = crb_bitstring_operator + + let op_is_bsop (env: env) (op: path) : bool = + match EcEnv.Circuit.reverse_bitstring_operator env op with + | Some (_, `OfInt) -> true + | _ -> false + + let circuit_of_bsop (env: env) (op: [`Path of path | `BSBinding of binding]) (args: arg list) : circuit = + let bnd = match op with + | `BSBinding bnd -> bnd + | `Path p -> begin match EcEnv.Circuit.reverse_bitstring_operator env p with + | Some bnd -> bnd + | None -> raise (MissingOpBinding p) + end + in + (* assert false => should be guarded by a previous call to op_is_bsop *) + match bnd with + | _bs, `From -> assert false (* doesn't translate to circuit *) + | {size = (_, Some size)}, `OfInt -> begin match args with + | [ `Constant i ] -> + circuit_of_zint ~size i + | _args -> raise InvalidArgument + end + | {size = (_, None); type_=ty}, `OfInt -> + raise (AbstractTyBinding (ty_of_path ty)) (* FIXME: check this, might want to add generic path -> ty conversion *) + | _bs, `To -> assert false (* doesn't translate to circuit *) + | _bs, `ToSInt -> assert false (* doesn't translate to circuit *) + | _bs, `ToUInt -> assert false (* doesn't translate to circuit *) +end +open BitstringOps + +module ArrayOps = struct + type binding = crb_array_operator + + + let op_is_arrayop (env: env) (op: path) : bool = + match EcEnv.Circuit.reverse_array_operator env op with + | Some (_, `Get) -> true + | Some (_, `Set) -> true + | Some (_, `OfList) -> true + | _ -> false + + let circuit_of_arrayop (env: env) (op: [`Path of path | `ABinding of binding]) (args: arg list) : circuit = + let op = match op with + | `ABinding bnd -> bnd + | `Path p -> begin match EcEnv.Circuit.reverse_array_operator env p with + | Some bnd -> bnd + | None -> raise (MissingOpBinding p) + end + in + (* assert false => should be guarded by a call to op_is_arrayop *) + match op with + | (_arr, `ToList) -> assert false (* We do not translate this to circuit *) + | (_arr, `Get) -> begin match args with + | [ `Circuit (({type_ = CArray _}, _inps) as arr); `Constant i] -> + array_get arr (BI.to_int i) + | _args -> raise InvalidArgument + end + | ({size = (_, Some size)}, `OfList) -> begin match args with + | [ `Circuit dfl; `List cs ] -> array_oflist cs dfl size + | _args -> raise InvalidArgument + end + | ({size = (_, None); type_=ty}, `OfList) -> raise (AbstractTyBinding (ty_of_path ty)) + | (_arr, `Set) -> begin match args with + | [ `Circuit (({type_ = CArray _}, _) as arr); + `Constant i; + `Circuit (({type_ = CBitstring _}, _) as bs) ] -> + array_set arr (BI.to_int i) bs + | _args -> raise InvalidArgument + end +end +open ArrayOps + +(* Functions for dealing with uninitialized inputs *) +let circuit_uninit (env:env) (t: ty) : circuit = + circuit_uninit (ctype_of_ty env t) + +module CircuitSpec = struct + let circuit_from_spec env (c : [`Path of path | `Bind of EcDecl.crb_circuit ] ) : circuit = + let c = match c with + | `Path p -> begin match EcEnv.Circuit.reverse_circuit env p with + | Some c -> c + | None -> raise (MissingOpSpec p) + end + | `Bind c -> c + in + let _, name = (EcPath.toqsymbol c.operator) in + let op = EcEnv.Op.by_path c.operator env in + + let unroll_fty (ty: ty) : ty list * ty = + let rec doit (acc: ty list) (ty: ty) : ty list * ty = + try + let a, b = EcTypes.tfrom_tfun2 ty in + (doit (a::acc) b) + with + | EcTypes.TyDestrError "fun" -> List.rev acc, ty + in doit [] ty + in + + let arg_tys, ret_ty = unroll_fty op.op_ty in + let arg_tys = List.map (ctype_of_ty env) arg_tys in + let ret_ty = ctype_of_ty env ret_ty in + circuit_from_spec ~name (arg_tys, ret_ty) c.circuit + + let op_has_spec env pth = + Option.is_some @@ EcEnv.Circuit.reverse_circuit env pth +end +open CircuitSpec + +let op_is_base (env: env) (p: path) : bool = + op_is_bvop env p || + op_has_spec env p + +let circuit_of_baseop (env: env) (p: path) : circuit = + if op_is_bvop env p then + circuit_of_bvop env (`Path p) + else if op_has_spec env p then + circuit_from_spec env (`Path p) + else + assert false (* Should be guarded by call to op_is_base *) + +let op_is_parametric_base (env: env) (p: path) = + op_is_parametric_bvop env p || + op_is_arrayop env p || + op_is_bsop env p + +let circuit_of_parametric_baseop (env: env) (p: path) (args: arg list) : circuit = + if op_is_parametric_bvop env p then + circuit_of_parametric_bvop env (`Path p) args + else if op_is_arrayop env p then + circuit_of_arrayop env (`Path p) args + else if op_is_bsop env p then + circuit_of_bsop env (`Path p) args + else + assert false (* Should be guarded by call to op_is_parametric_base *) + +let circuit_of_op (env: env) (p: path) : circuit = + let op = try + EcEnv.Circuit.reverse_operator env p |> List.hd + with Failure _ -> + raise (MissingOpBinding p) + in + match op with + | `Bitstring (_bs, _op) -> assert false (* Should be guarded by a call to op_is_base *) + | `Array _ -> assert false (* Should be guarded by a call to op_is_parametric_base *) + | `BvOperator bvbnd -> circuit_of_bvop env (`BvBind bvbnd) + | `Circuit c -> circuit_from_spec env (`Bind c) + +let circuit_of_op_with_args (env: env) (p: path) (args: arg list) : circuit = + let op = try + EcEnv.Circuit.reverse_operator env p |> List.hd + with Failure _ -> + raise (MissingOpBinding p) + in + match op with + | `Bitstring bsbnd -> circuit_of_bsop env (`BSBinding bsbnd) args + | `Array abnd -> circuit_of_arrayop env (`ABinding abnd) args + | `BvOperator bvbnd -> circuit_of_parametric_bvop env (`BvBind bvbnd) args + | `Circuit _c -> assert false (* FIXME PR: Do we want to have parametric operators coming from the spec? *) + + +let type_has_bindings (env: env) (t: ty) : bool = + (Option.is_some (EcEnv.Circuit.lookup_array_and_bitstring env t)) || + (Option.is_some (EcEnv.Circuit.lookup_bitstring env t)) + +let int_of_form ?(redmode = EcReduction.full_red) (hyps: hyps) (f: form) : zint = + match f.f_node with + | Fint i -> i + | _ -> + begin try + destr_int @@ EcCallbyValue.norm_cbv redmode hyps f + with + DestrError "int" + | DestrError "destr_int" -> raise IntConversionFailure + end + +let rec form_list_of_form ?(ppe: EcPrinting.PPEnv.t option) (f: form) : form list = + match destr_op_app f with + | (pc, _), [h; {f_node = Fop(p, _)}] when + pc = EcCoreLib.CI_List.p_cons && + p = EcCoreLib.CI_List.p_empty -> + [h] + | (pc, _), [h; t] when + pc = EcCoreLib.CI_List.p_cons -> + h::(form_list_of_form t) + | _ -> + if debug then Option.may (fun ppenv -> Format.eprintf "Failed to destructure claimed list: %a@." (EcPrinting.pp_form ppenv) f) ppe; + raise (DestrError "list") + +let form_is_iter (f: form) : bool = + match f.f_node with + | Fapp ({f_node = Fop (p, _)}, _) when + p = EcCoreLib.CI_Int.p_iter || + p = EcCoreLib.CI_Int.p_fold || + p = EcCoreLib.CI_Int.p_iteri -> true + | _ -> false + +(* Expands iter, fold and iteri (for integer arguments) *) +let expand_iter_form (hyps: hyps) (f: form) : form = + let redmode = circ_red hyps in + let env = toenv hyps in + let ppenv = EcPrinting.PPEnv.ofenv env in + let (@!!) f fs = + EcTypesafeFol.fapply_safe ~redmode hyps f fs + in + + let res = match f.f_node with + | Fapp ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iteri -> + let rep = int_of_form hyps rep in + let is = List.init (BI.to_int rep) BI.of_int in + if debug then Format.eprintf "Done generating functions!@."; + let f = List.fold_left (fun f i -> + if debug then Format.eprintf "Expanding iter... Step #%d@.Form: %a@." (BI.to_int i) + (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (toenv hyps))) f + ; + fn @!! [f_int i; f] + ) base is in + f + | Fapp ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iter -> + let rep = int_of_form hyps rep in + let is = List.init (BI.to_int rep) BI.of_int in + let f = List.fold_left (fun f _i -> fn @!! [f]) base is in + f + | Fapp ({f_node = Fop (p, _)}, [fn; base; rep]) when p = EcCoreLib.CI_Int.p_fold -> + let rep = int_of_form hyps rep in + let is = List.init (BI.to_int rep) BI.of_int in + let f = List.fold_left (fun f _i -> fn @!! [f]) base is in + f + | _ -> raise (DestrError "iter") + in + if debug then Format.eprintf "Expanded iter form: @.%a@." EcPrinting.(pp_form ppenv) res; + res + +let circuit_of_form + ?(st : state = empty_state) (* Program variable values *) + (hyps : hyps) + (f_ : EcAst.form) + : circuit = + + (* Form level cache, local to each high-level call *) + let cache : (int, circuit) Map.t ref = ref Map.empty in + let fhash = AInvFHash.hash_form in + let op_cache : circuit Mp.t ref = ref Mp.empty in + let redmode = circ_red hyps in + let env = toenv hyps in + let ppe = EcPrinting.PPEnv.ofenv env in + let fapply_safe f fs = + let res = EcTypesafeFol.fapply_safe ~redmode hyps f fs in + res + in + let int_of_form (f: form) : zint = + int_of_form hyps f + in + + (* Supposed to be called on an apply *) + let propagate_integer_arguments (op: form) (args: form list) : form = + let op = + let pth, _ = destr_op op in + match (EcEnv.Op.by_path pth env).op_kind with + | OB_oper (Some (OP_Plain f)) -> + f + | _ -> + if debug then Format.eprintf "Failed to get body for op: %a (args: %a)\n" + (EcPrinting.pp_form ppe) op + (EcPrinting.(pp_list "," (pp_form ppe))) args; + raise MissingOpBody + in + let res = fapply_safe op args in + res + in + let rec arg_of_form (st: state) (f: form) : arg = + match f.f_ty with + (* FIXME: check this (does this corrently detect ints?) *) + | t when t.ty_node = EcTypes.tint.ty_node -> arg_of_zint (int_of_form f) + | t when type_has_bindings env t -> + let f = doit st f in + arg_of_circuit f + | {ty_node = Tfun(i_t, c_t)} when + i_t.ty_node = EcTypes.tint.ty_node && + type_has_bindings env c_t -> + arg_of_init (fun i -> + let f = (fapply_safe f [f_int (BI.of_int i)]) in + doit st f + ) + | {ty_node = Tconstr(p, [t])} when + p = EcCoreLib.CI_List.p_list && + type_has_bindings env t -> + let cs = List.map (fun f -> doit st f) (form_list_of_form ~ppe f) in + arg_of_circuits cs + | _ -> Format.eprintf "Failed to convert form to arg: %a@." EcPrinting.(pp_form ppe) f; + raise BadFormForArg + + (* State does not get backward propagated so it is not returned *) + and doit (st: state) (f_: form) : circuit = + try begin + match f_.f_node with + | Fint _z -> raise (CantConvertToCirc `Int) + + | Fif (c_f, t_f, f_f) -> + let t = doit st t_f in + let f = doit st f_f in + let c = doit st c_f in + circuit_ite ~strict:true ~c ~t ~f + + | Flocal idn -> + state_get st idn + + | Fop (pth, _) -> + begin + if pth = EcCoreLib.CI_Witness.p_witness then + (if debug then Format.eprintf "Assigning witness to var of type %a@." + EcPrinting.(pp_type ppe) f_.f_ty; + circuit_uninit env (f_.f_ty)) + else + match Mp.find_opt pth !op_cache with + | Some op -> + op + | None -> + if op_is_base env pth then + let circ = try + circuit_of_op env pth + with + | CircError le -> Format.eprintf "(%s ->)" (EcPath.tostring pth); raise (CircError le) + in + op_cache := Mp.add pth circ !op_cache; + circ + else + let circ = match (EcEnv.Op.by_path pth env).op_kind with + | OB_oper (Some (OP_Plain f)) -> + doit st f + | _ -> + begin match EcFol.op_kind (destr_op f_ |> fst) with + | Some `True -> + (circuit_true :> circuit) + | Some `False -> + (circuit_false :> circuit) + | Some opk -> raise (CantConvertToCirc (`OpK opk)) + | None -> raise (CantConvertToCirc (`Op (destr_op f_ |> fst))) + end + in + op_cache := Mp.add pth circ !op_cache; + circ + end + | Fapp (f, fs) -> begin try + begin match Map.find_opt (fhash f_) !cache with (* TODO: Maybe add cache statistics? *) + | Some circ -> circ + | None -> let circ = + begin match f with + | {f_node = Fop (pth, _)} when op_is_parametric_base env pth -> + let args = List.map (arg_of_form st) fs in + circuit_of_op_with_args env pth args + + (* For dealing with iter cases: *) + | {f_node = Fop _} when form_is_iter f_ -> + trans_iter st hyps f fs + + | {f_node = Fop (_p, _)} when not (List.for_all (fun f -> f.f_ty.ty_node <> EcTypes.tint.ty_node) fs) -> + doit st (propagate_integer_arguments f fs) + + | {f_node = Fop _} -> + (* Assuming correct types coming from EC *) + (* FIXME: Add some extra info about errors when something here throws *) + begin match EcFol.op_kind (destr_op f |> fst), fs with + | Some `Eq, [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_eq c1 c2 :> circuit) + | Some `Not, [f] -> + let c = doit st f in + circuit_not c + | Some `True, [] -> + (circuit_true :> circuit) + | Some `False, [] -> + (circuit_false :> circuit) + | Some `Imp, [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_or (circuit_not c1) c2 :> circuit) + | Some (`And _), [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_and c1 c2 :> circuit) + | Some (`Or _), [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_or c1 c2 :> circuit) + | Some `Iff, [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_or (circuit_and c1 c2) (circuit_and (circuit_not c1) (circuit_not c2)) :> circuit) + (* Recurse down into definition *) + | _ -> + let f_c = doit st f in + let fcs = List.map (doit st) fs in + circuit_compose f_c fcs + end + (* Recurse down into definition *) + | _ -> + let f_c = doit st f in + let fcs = List.map (doit st) fs in + circuit_compose f_c fcs + end + in + cache := Map.add (fhash f_) circ !cache; + circ + end + (* FIXME: Redo call chain on error *) + (* with CircError le -> + let err = lazy (Format.asprintf "Call %a\n%s" EcPrinting.(pp_form ppe) f (Lazy.force le)) in + raise (CircError err) *) + with e -> raise e + end + + | Fquant (qnt, binds, f) -> + let binds = List.map (fun (idn, t) -> (idn, gty_as_ty t |> ctype_of_ty env)) binds in (* FIXME *) + begin match qnt with + | Lforall + | Llambda -> circ_lambda_oneshot st binds (fun st -> doit st f) (* FIXME: look at this interaction *) + | Lexists -> raise (CantConvertToCirc (`Quantif qnt)) + (* TODO: figure out how to handle quantifiers. Maybe just dont? *) + end + + | Fproj (f, i) -> + let ftp = doit st f in + (circuit_tuple_proj ftp i :> circuit) + + | Fmatch (_f, _fs, _ty) -> raise (CantConvertToCirc `Match) + + | Flet (LSymbol (id, _t), v, f) -> + let vc = doit st v in + let st = update_state st id vc in + doit st f + + | Flet (LTuple vs, v, f) -> + let vc = doit st v in + let comps = circuits_of_circuit_tuple vc in + let st = List.fold_left2 (fun st (id, _t) vc -> + update_state st id vc) + st + vs + comps + in doit st f + + | Flet (LRecord _, _, _) -> raise (CantConvertToCirc `Record) + + | Fpvar (pv, mem) -> + let v = match pv with + | PVloc v -> v + (* FIXME: Should globals be supported? *) + | _ -> raise (CantConvertToCirc `Glob) + in + let v = match state_get_pv_opt st mem v with + | Some v -> v + | None -> + if debug then Format.eprintf "Assigning unassigned program variable %a of type %a@." EcPrinting.(pp_pv ppe) pv EcPrinting.(pp_type ppe) f_.f_ty; + circuit_uninit env f_.f_ty (* Allow uninitialized program variables *) + in + v + + | Fglob (_id, _mem) -> raise (CantConvertToCirc `Glob) + + | Ftuple comps -> + let comps = + List.map (fun comp -> doit st comp) comps + in + (circuit_tuple_of_circuits comps :> circuit) + + | FhoareF _ + | FhoareS _ + | FbdHoareF _ + | FbdHoareS _ + | FeHoareF _ + | FeHoareS _ + | FequivF _ + | FequivS _ + | FeagerF _ + | Fpr _ -> raise (CantConvertToCirc `Hoare) + end + with + | (CantConvertToCirc _) as e -> + Format.eprintf "Failed on form %a with error %s@." + EcPrinting.(pp_form ppe) f_ + (Printexc.to_string e); + assert false + | (MissingTyBinding ty) -> + Format.eprintf "Failed on form %a because of missing type binding for type %a@." + EcPrinting.(pp_form ppe) f_ + EcPrinting.(pp_type ppe) ty; + assert false + | e -> + Format.eprintf "Failed on %a with exception %s@." + EcPrinting.(pp_form ppe) f_ + (Printexc.to_string e); + assert false + + and trans_iter (st: state) (hyps: hyps) (f: form) (fs: form list) : circuit = + (* FIXME: move auxiliary function out of the definitions *) + let redmode = circ_red hyps in + let env = toenv hyps in + let ppenv = EcPrinting.PPEnv.ofenv env in + let fapply_safe f fs = + let res = EcTypesafeFol.fapply_safe ~redmode hyps f fs in + res + in + match f, fs with + | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iteri -> + let rep = int_of_form rep in + let fs = List.init (BI.to_int rep) (fun i -> + fapply_safe fn [f_int (BI.of_int i)] + ) in + List.fold_lefti (fun f i fn -> + if debug then Format.eprintf "Translating iteri... Step #%d@." i; + let fn = doit st fn in + circuit_compose fn [f] + ) (doit st base) fs + (* FIXME PR: this is currently being implemented directly on circuits, do we want this case as well? *) + | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iter -> assert false + | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_fold -> assert false + | _ -> raise (DestrError "iter") + in + doit st f_ + +let circuit_simplify_equality ?(do_time = true) ~(st: state) ~(hyps: hyps) ~(pres: circuit list) (f1: form) (f2: form) : bool = + let tm = ref (Unix.gettimeofday ()) in + let env = toenv hyps in + let time (env: env) (t: float ref) (msg: string) : unit = + let new_t = Unix.gettimeofday () in +(* EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. !t); *) + Format.eprintf "[W] %s, took %f s@." msg (new_t -. !t); + t := new_t + in + + if debug then Format.eprintf "Filletting circuit...@."; + let c1 = circuit_of_form ~st hyps f1 |> state_close_circuit st in + if do_time then time env tm "Left side circuit generation done"; + let c2 = circuit_of_form ~st hyps f2 |> state_close_circuit st in + if do_time then time env tm "Right side circuit generation done"; + + let pres = List.map (state_close_circuit st) pres in (* Assumes pres come open *) + assert (Option.is_none @@ circuit_has_uninitialized c1); + assert (Option.is_none @@ circuit_has_uninitialized c2); + let posts = circuit_eqs c1 c2 in + if do_time then time env tm "Done with postcondition circuit generation"; + + if debug then Format.eprintf "Number of checks before batching: %d@." (List.length posts); + let posts = batch_checks ~mode:`BySub posts in + if debug then Format.eprintf "Number of checks after batching: %d@." (List.length posts); + if do_time then time env tm "Done with lane compression"; + if fillet_tauts pres posts then + begin + if do_time then time env tm "Done with equivalence checking (structural equality + SMT)"; + true + end + else + begin + if do_time then time env tm "Failed equivalence check"; + false + end + +(* FIXME: add support for spec bindings for abstract/opaque operators *) +let circuit_of_path (hyps: hyps) (p: path) : circuit = + let f = EcEnv.Op.by_path p (toenv hyps) in + let f = match f.op_kind with + | OB_oper (Some (OP_Plain f)) -> f + | _ -> raise MissingOpBody + in + circuit_of_form hyps f + +let vars_of_memtype (mt : memtype) = + let Lmt_concrete lmt = mt in + List.filter_map (function + | { ov_name = Some name; ov_type = ty } -> + Some { v_name = name; v_type = ty; } + | _ -> None + ) (Option.get lmt).lmt_decl + + +let process_instr ?me (hyps: hyps) (mem: memory) ~(st: state) (inst: instr) : state = + let env = toenv hyps in + let env = match me with + | Some me -> EcEnv.Memory.push_active_ss me env + | None -> env + in +(* if debug then Format.eprintf "[W] Processing : %a@." (EcPrinting.pp_instr (EcPrinting.PPEnv.ofenv env)) inst; *) + (* let start = Unix.gettimeofday () in *) + try + match inst.i_node with + | Sasgn (LvVar (PVloc v, _ty), e) -> +(* + if debug then Format.eprintf "Assigning form %a to var %s@\n" + (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (LDecl.toenv hyps))) (form_of_expr mem e) v; +*) + let c = ((ss_inv_of_expr mem e).inv |> circuit_of_form ~st hyps) in + let st = update_state_pv st mem v c in + st + (* if debug then Format.eprintf "[W] Took %f seconds@." (Unix.gettimeofday() -. start); *) + | Sasgn (LvTuple (vs), {e_node = Etuple es; _}) when List.compare_lengths vs es = 0 -> + let st = List.fold_left (fun st (v, e) -> + let c = ((ss_inv_of_expr mem e).inv |> circuit_of_form ~st hyps) in + let st = update_state_pv st mem v c in + st + ) st + (List.combine + (List.map (function + | (PVloc v, _ty) -> v + | _ -> raise (CantConvertToCirc `Glob)) vs) + es) in + st + | Sasgn (LvTuple (vs), e) -> + let tp = ((ss_inv_of_expr mem e).inv |> circuit_of_form ~st hyps) in + let comps = circuits_of_circuit_tuple tp in + let st = List.fold_left2 (fun st (pv, _ty) c -> + let v = match pv with + | PVloc v -> v + | _ -> raise (CantConvertToCirc `Glob) + in + update_state_pv st mem v c + ) st vs (comps :> circuit list) + in + st + | _ -> + raise (CantConvertToCirc `Instr) + with + | e -> + (* FIXME: Bad handling, use new exceptions *) + Format.eprintf "BDep failed on instr: %a@.Exception thrown: %s@.BACKTRACE: %s@.@." + (EcPrinting.pp_instr (EcPrinting.PPEnv.ofenv env)) inst + (Printexc.to_string e) + (Printexc.get_backtrace ()); + raise e + +(* FIXME: check if memory is the right one in calls to state *) +let instrs_equiv + (hyps : hyps ) + ((mem, mt) : memenv ) + ?(keep : EcPV.PV.t option ) + ?(st : state = empty_state ) + (s1 : instr list ) + (s2 : instr list ) : bool += + let env = LDecl.toenv hyps in + + let rd, rglobs = EcPV.PV.elements (EcPV.is_read env (s1 @ s2)) in + let wr, wglobs = EcPV.PV.elements (EcPV.is_write env (s1 @ s2)) in + + if not (List.is_empty rglobs && List.is_empty wglobs) then + raise CantReadWriteGlobs; + + if not (List.for_all (EcTypes.is_loc |- fst) (rd @ wr)) then + raise CantReadWriteGlobs; + + let inputs = List.map (fun (pv, ty) -> { v_name = EcTypes.get_loc pv; v_type = ty; }) (rd @ wr) in + let inputs = List.map (fun {v_name; v_type} -> (create v_name, ctype_of_ty env v_type)) inputs in + let st = open_circ_lambda st inputs in + + let st1 = List.fold_left (fun st -> process_instr hyps mem ~st) st s1 in + let st2 = List.fold_left (fun st -> process_instr hyps mem ~st) st s2 in + + let st1 = close_circ_lambda st1 in + let st2 = close_circ_lambda st2 in + (* FIXME: what was the intended behaviour for keep? *) + match keep with + | Some pv -> + let vs = EcPV.PV.elements pv |> fst in + let vs = List.map (function + | (PVloc v, ty) -> (v, ty) + | _ -> raise (CantConvertToCirc `Glob) + ) vs + in List.for_all (fun (var, ty) -> + let circ1 = state_get_pv_opt st1 mem var in + let circ2 = state_get_pv_opt st2 mem var in + match circ1, circ2 with + | None, None -> true + | None, Some _ + | Some _, None -> false (* Variable only defined on one of the blocks (and not in the prelude) *) + | Some circ1, Some circ2 -> circ_equiv circ1 circ2 + ) vs + | None -> state_get_all_memory st mem |> List.for_all (fun (var, _) -> + let circ1 = state_get_pv st1 mem var in + let circ2 = state_get_pv st2 mem var in + circ_equiv circ1 circ2 + ) + +(* FIXME: remove variable list from the arguments *) +(* FIXME: change memory -> memenv *) +let state_of_prog ?(close = false) ?me (hyps: hyps) (mem: memory) ?(st: state = empty_state) (proc: instr list) : state = + let st = + List.fold_left (fun st -> process_instr ?me hyps mem ~st) st proc + in + if close then + close_circ_lambda st + else st + +let rec circ_simplify_form_bitstring_equality + ?(st: state = empty_state) + ?(pres: circuit list = []) + (hyps: hyps) + (f: form) + : form = + let env = toenv hyps in + + let rec check (f : form) = + match EcFol.sform_of_form f with + | SFeq (f1, f2) + when (Option.is_some @@ EcEnv.Circuit.lookup_bitstring env f1.f_ty) + || (Option.is_some @@ EcEnv.Circuit.lookup_array env f1.f_ty) + -> + f_bool (circuit_simplify_equality ~st ~hyps ~pres f1 f2) + | _ -> f_map (fun ty -> ty) check f + in check f + + +(* Mli stuff needed: *) +let compute ~(sign: bool) (c: circuit) (args: zint list) : zint = + match compute ~sign c (List.map (fun z -> arg_of_zint z) args) with + | Some z -> z + | None -> raise CantConvertToConstant + +let circ_equiv ?(pcond: circuit option) c1 c2 = + circ_equiv ?pcond c1 c2 + +let circ_sat = circ_sat +let circ_taut = circ_taut + +let circuit_to_string ((circ, inps): circuit) : string = Format.asprintf "(%a => %a)" EcPrinting.(pp_list ", " pp_cinp) inps pp_circ circ +let circuit_ueq = (fun c1 c2 -> (circuit_eq c1 c2 :> circuit)) +let circuit_has_uninitialized = circuit_has_uninitialized + +let circuit_to_file = circuit_to_file + +let circuit_slice (c: circuit) (size: int) (offset: int) = + circuit_slice ~size c offset + +let circuit_flatten ((circ, inps) as c: circuit) = + convert_type (CBitstring (size_of_ctype circ.type_)) c + +let state_get = state_get_pv +let state_get_opt = state_get_pv_opt +let state_get_all = fun st -> state_get_all_pv st |> List.snd + +let circuit_state_of_memenv ~(st: state) (env:env) ((m, mt): memenv) : state = + match mt with + | (Lmt_concrete Some {lmt_decl=decls}) -> + let bnds = List.map (fun {ov_name; ov_type} -> + match ov_name with + | Some v -> + begin try + Some ((m, v), ctype_of_ty env ov_type) + with e -> + raise e (* FIXME *) + (* (CircError (lazy ( + (Format.asprintf "Failed for decl for var %s@." v) ^ Lazy.force err + ))) *) + end + | None -> None + ) decls in + open_circ_lambda_pv st (List.filter_map identity bnds) + | Lmt_concrete None -> st + +(* Generally called without the optional argument, here just to see if we need it, + maybe remove later? FIXME *) +let circuit_state_of_hyps ?(strict = false) ?(use_mem = false) ?(st = empty_state) hyps : state = + let env = toenv hyps in + let ppe = EcPrinting.PPEnv.ofenv env in + let st = List.fold_left (fun st (id, lk) -> + if debug then Format.eprintf "Processing hyp: %s@." (id.id_symb); + match lk with +(* FIXME: Reasoning here is that we do not directly process program variables in the hyps + They are either given a value by assignment in the program or if they are used + before that they are implicitly initialized to BAD + + FIXME: Find a good way to handle this +*) + + | EcBaseLogic.LD_mem mt when use_mem -> circuit_state_of_memenv ~st env (id, mt) + + (* Initialized variable. + Check if body is convertible to circuit, if not just process it as uninitialized. + TODO: Maybe do a first pass on this, check convertibility and remove duplicates? *) + | EcBaseLogic.LD_var (t, Some f) -> + if debug then Format.eprintf "Assigning %a to %a@." EcPrinting.(pp_form ppe) f EcIdent.pp_ident id; + begin try + update_state st id (circuit_of_form ~st hyps f) + (* FIXME PR: Should only catch circuit translation errors, hack *) + with e -> + try + open_circ_lambda st [(id, ctype_of_ty env t)] + (* FIXME PR: Should only catch circuit translation errors, hack *) + with e -> + if strict then raise e else st + end + + (* Uninitialized variable. + Treat as input *) + | EcBaseLogic.LD_var (t, None) -> + begin try + open_circ_lambda st [(id, ctype_of_ty env t)] + (* FIXME PR: Should only catch circuit translation errors, hack *) + with e -> + if strict then raise e else st end + + (* For things of the form a_ = a{&hr}, we assume the local variable takes precedence *) + | EcBaseLogic.LD_hyp f -> + if debug then Format.eprintf "Form hyp: %a@.Simplified: %a@." + EcPrinting.(pp_form ppe) f + EcPrinting.(pp_form ppe) (EcCallbyValue.norm_cbv (circ_red hyps) hyps f) + ; + begin match (EcCallbyValue.norm_cbv (circ_red hyps) hyps f) with + | {f_node=Fapp ({f_node = Fop (p, _); _}, [{f_node = Fpvar (PVloc pv, m); _}; fv])} + | {f_node=Fapp ({f_node = Fop (p, _); _}, [fv; {f_node = Fpvar (PVloc pv, m); _}])} when EcFol.op_kind p = Some `Eq -> + begin try + update_state_pv st m pv (circuit_of_form ~st hyps fv) + (* FIXME PR: Should only catch circuit translation errors, hack *) + with e -> + st + end + | _ -> st + end + + | _ -> st + ) st (List.rev (tohyps hyps).h_local) + in + st + +let clear_translation_caches () = + EcLowCircuits.reset_backend_state (); + AInvFHash.nuke_state_from_orbit () diff --git a/src/ecCircuits.mli b/src/ecCircuits.mli new file mode 100644 index 0000000000..1f4b0d4cbb --- /dev/null +++ b/src/ecCircuits.mli @@ -0,0 +1,87 @@ +(* -------------------------------------------------------------------- *) +open EcIdent +open EcSymbols +open EcAst +open EcEnv +open LDecl +open EcPath +open EcLowCircuits + +(* -------------------------------------------------------------------- *) +module Map = Batteries.Map + +(* -------------------------------------------------------------------- *) +exception MissingTyBinding of ty +exception AbstractTyBinding of ty +exception InvalidArgument +exception MissingOpBinding of path +exception MissingOpSpec of path +exception IntConversionFailure +exception DestrError of string (* FIXME: change this one *) +exception MissingOpBody (* FIXME: rename? *) +exception BadFormForArg (* FIXME: rename *) +exception CantConvertToConstant +exception CantConvertToCirc of + [`Int + | `OpK of EcFol.op_kind + | `Op of path + | `Quantif of quantif + | `Match + | `Glob + | `Record + | `Hoare + | `Instr +] + +(* -------------------------------------------------------------------- *) +(* Utilities (figure out better name) *) +val circ_red : hyps -> EcReduction.reduction_info +val width_of_type : env -> ty -> int +val circuit_to_string : circuit -> string +val ctype_of_ty : env -> ty -> ctype +val int_of_form : ?redmode:EcReduction.reduction_info -> hyps -> form -> BI.zint + +(* State utilities *) +val state_get : state -> memory -> symbol -> circuit +val state_get_opt : state -> memory -> symbol -> circuit option +val state_get_all : state -> circuit list + +(* Create circuits *) +val input_of_type : name:[`Str of string | `Idn of ident | `Bad] -> env -> ty -> circuit + +(* Transform circuits *) +val circuit_ueq : circuit -> circuit -> circuit +val circuit_flatten : circuit -> circuit + +(* Use circuits *) +val compute : sign:bool -> circuit -> BI.zint list -> BI.zint +val circ_equiv : ?pcond:circuit -> circuit -> circuit -> bool +val circ_sat : circuit -> bool +val circ_taut : circuit -> bool + +(* Generate circuits *) +(* Form processors *) +val circuit_of_form : ?st:state -> hyps -> form -> circuit +val circuit_simplify_equality : ?do_time:bool -> st:state -> hyps:hyps -> pres:circuit list -> form -> form -> bool +val circ_simplify_form_bitstring_equality : + ?st:state -> + ?pres:circuit list -> hyps -> form -> form + +(* Proc processors *) +val state_of_prog : ?close:bool -> ?me:memenv -> hyps -> memory -> ?st:state -> instr list -> state +val instrs_equiv : hyps -> memenv -> ?keep:EcPV.PV.t -> ?st:state -> instr list -> instr list -> bool +val process_instr : ?me:memenv -> hyps -> memory -> st:state -> instr -> state +(* val pstate_of_memtype : ?pstate:pstate -> env -> memtype -> pstate * cinput list *) + +val circuit_state_of_memenv : st:state -> env -> memenv -> state +val circuit_state_of_hyps : ?strict:bool -> ?use_mem:bool -> ?st:state -> hyps -> state + +(* Check for uninitialized inputs *) +val circuit_has_uninitialized : circuit -> int option + +val circuit_slice : circuit -> int -> int -> circuit + +val circuit_to_file : name:string -> circuit -> symbol + +(* Imperative state clearing *) +val clear_translation_caches : unit -> unit diff --git a/src/ecCommands.ml b/src/ecCommands.ml index 135a2b3de3..f454e542e5 100644 --- a/src/ecCommands.ml +++ b/src/ecCommands.ml @@ -749,6 +749,14 @@ and process_dump scope (source, tc) = scope +(* -------------------------------------------------------------------- *) +and process_crbind (scope : EcScope.scope) (binding : pcrbinding) = + match binding.binding with + | CRB_Bitstring bs -> EcScope.Circuit.add_bitstring scope binding.locality bs + | CRB_Array ba -> EcScope.Circuit.add_array scope binding.locality ba + | CRB_BvOperator op -> EcScope.Circuit.add_bvoperator scope binding.locality op + | CRB_Circuit cr -> EcScope.Circuit.add_circuits scope binding.locality cr + (* -------------------------------------------------------------------- *) and process ?(src : string option) (ld : Loader.loader) (scope : EcScope.scope) g = let loc = g.pl_loc in @@ -793,6 +801,7 @@ and process ?(src : string option) (ld : Loader.loader) (scope : EcScope.scope) | Greduction red -> `Fct (fun scope -> process_reduction scope red) | Ghint hint -> `Fct (fun scope -> process_hint scope hint) | GdumpWhy3 file -> `Fct (fun scope -> process_dump_why3 scope file) + | Gcrbinding bind -> `Fct (fun scope -> process_crbind scope bind) with | `Fct f -> Some (f scope) | `State f -> f scope; None @@ -827,6 +836,7 @@ type checkmode = { cm_provers : string list option; cm_profile : bool; cm_iterate : bool; + cm_specs : string list; } let initial ~checkmode ~boot ~checkproof = @@ -852,6 +862,7 @@ let initial ~checkmode ~boot ~checkproof = scope [tactics; prelude] in let scope = EcScope.Prover.set_default scope poptions in + let scope = EcScope.Circuit.register_spec_files scope checkmode.cm_specs in let scope = if checkproof then begin if checkall then diff --git a/src/ecCommands.mli b/src/ecCommands.mli index a72d31a437..14e8de181a 100644 --- a/src/ecCommands.mli +++ b/src/ecCommands.mli @@ -22,6 +22,7 @@ type checkmode = { cm_provers : string list option; cm_profile : bool; cm_iterate : bool; + cm_specs : string list; } val initial : checkmode:checkmode -> boot:bool -> checkproof:bool -> EcScope.scope diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index 03dd1f64ec..aad1c1af43 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -182,6 +182,35 @@ let f_true = f_op EcCoreLib.CI_Bool.p_true [] tbool let f_false = f_op EcCoreLib.CI_Bool.p_false [] tbool let f_bool = fun b -> if b then f_true else f_false +(* -------------------------------------------------------------------- *) +(* TODO: check types here *) +(* FIXME CIRCUIT PR: do we want to keep this? *) +let ty_ftlist1 ty = toarrow (List.make 1 ty) (tlist ty) +let ty_ftlist2 ty = toarrow ([ty; (tlist ty)]) (tlist ty) +let ty_flist1 ty = toarrow (List.make 1 (tlist ty)) (tlist ty) +let ty_flist2 ty = toarrow (List.make 2 (tlist ty)) (tlist ty) +let ty_fllist ty = toarrow (List.make 1 (tlist @@ tlist ty)) (tlist ty) +let ty_lmap ty1 ty2 = toarrow ([toarrow [ty1] ty2; tlist ty1]) (tlist ty2) +let ty_chunk ty = toarrow [tint; tlist ty] (tlist @@ tlist ty) +let ty_all ty = toarrow [(toarrow [ty] tbool); tlist ty] tbool + +let fop_empty ty = f_op EcCoreLib.CI_List.p_empty [ty] (tlist ty) +let fop_cons ty = f_op EcCoreLib.CI_List.p_cons [ty] (ty_ftlist2 ty) +let fop_append ty = f_op EcCoreLib.CI_List.p_append [ty] (ty_flist2 ty) +let fop_flatten ty = f_op EcCoreLib.CI_List.p_flatten [ty] (ty_fllist ty) +let fop_lmap ty1 ty2 = f_op EcCoreLib.CI_List.p_map [ty2; ty1] (ty_lmap ty1 ty2) +let fop_chunk ty = f_op EcCoreLib.CI_List.p_chunk [ty] (ty_chunk ty) +let fop_all ty = f_op EcCoreLib.CI_List.p_all [ty] (ty_all ty) + +let f_append a b ty = f_app (fop_append ty) [a; b] (tlist ty) +let f_cons a b ty = f_app (fop_cons ty) [a; b] (tlist ty) +let f_flatten a ty = f_app (fop_flatten ty) [a] (tlist ty) +let f_lmap f a ty1 ty2 = f_app (fop_lmap ty1 ty2) [f;a] (tlist ty2) +let f_chunk a (n: int) ty2 = + let ty = tfrom_tlist a.f_ty in + f_app (fop_chunk ty) [mk_form (Fint (BI.of_int n)) tint; a] (tlist @@ tlist ty) +let f_all f a ty = f_app (fop_all ty) [f; a] tbool + (* -------------------------------------------------------------------- *) let f_tuple args = match args with @@ -785,6 +814,8 @@ let is_op_not p = EcPath.p_equal EcCoreLib.CI_Bool.p_not p let is_op_imp p = EcPath.p_equal EcCoreLib.CI_Bool.p_imp p let is_op_iff p = EcPath.p_equal EcCoreLib.CI_Bool.p_iff p let is_op_eq p = EcPath.p_equal EcCoreLib.CI_Bool.p_eq p +let is_op_cons p = EcPath.p_equal EcCoreLib.CI_List.p_cons p +let is_op_witness p = EcPath.p_equal EcCoreLib.CI_Witness.p_witness p (* -------------------------------------------------------------------- *) let destr_op = function @@ -866,6 +897,22 @@ let destr_nots form = | Some form -> aux (not b) form in aux true form +let destr_cons form = + match destr_app form with + | {f_node = Fop (p, _)}, [h;t] when is_op_cons p -> (h, t) + | _ -> destr_error "cons" + +let destr_list form = + let rec aux form = + match try Some (destr_cons form) with DestrError "cons" -> None with + | Some (h, t) -> h::(aux t) + | None -> [] + in + try + let h, t = destr_cons form in + h::(aux t) + with DestrError "cons" -> raise (DestrError "list") + (* -------------------------------------------------------------------- *) let is_from_destr dt f = try ignore (dt f); true with DestrError _ -> false @@ -900,6 +947,8 @@ let is_bdHoareF f = is_from_destr destr_bdHoareF f let is_pr f = is_from_destr destr_pr f let is_eq_or_iff f = (is_eq f) || (is_iff f) +let is_witness f = is_from_destr (fun f -> destr_op f |> fst |> is_op_witness) f + (* -------------------------------------------------------------------- *) let split_args f = match f_node f with @@ -939,7 +988,8 @@ let rec form_of_expr_r ?m (e : expr) = | Evar pv -> begin match m with - | None -> failwith "expecting memory" + | None -> + failwith "expecting memory" | Some m -> (f_pvar pv e.e_ty m).inv end diff --git a/src/ecCoreFol.mli b/src/ecCoreFol.mli index 0977a33a50..1951e169da 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -133,6 +133,33 @@ val f_eagerF : ts_inv -> stmt -> xpath -> xpath -> stmt -> ts_inv -> form val f_pr_r : pr -> form val f_pr : memory -> xpath -> form -> ss_inv -> form +(* FIXME: Check this V *) +(* FIXME CIRCUIT PR: do we want to keep this? *) +val ty_ftlist1 : ty -> ty +val ty_ftlist2 : ty -> ty +val ty_flist1 : ty -> ty +val ty_flist2 : ty -> ty +val ty_lmap : ty -> ty -> ty +val ty_chunk : ty -> ty +val ty_all : ty -> ty + +(* FIXME CIRCUIT PR: if keeping, maybe change names *) +val fop_empty : ty -> form +val fop_cons : ty -> form +val fop_append : ty -> form +val fop_flatten : ty -> form +val fop_lmap : ty -> ty -> form +val fop_chunk : ty -> form +val fop_all : ty -> form + +val f_append : form -> form -> ty -> form +val f_cons : form -> form -> ty -> form +val f_flatten : form -> ty -> form +val f_lmap : form -> form -> ty -> ty -> form +val f_chunk : form -> int -> ty -> form +val f_all : form -> form -> ty -> form + + (* soft-constructors - unit *) val f_tt : form @@ -272,6 +299,10 @@ val destr_int : form -> zint val destr_glob : form -> EcIdent.t * memory val destr_pvar : form -> EcTypes.prog_var * memory +val destr_cons : form -> form * form +val destr_list : form -> form list +val is_witness : form -> bool + (* -------------------------------------------------------------------- *) val is_true : form -> bool val is_false : form -> bool diff --git a/src/ecCoreGoal.ml b/src/ecCoreGoal.ml index 74ff095f5b..6c5a3024d3 100644 --- a/src/ecCoreGoal.ml +++ b/src/ecCoreGoal.ml @@ -157,6 +157,7 @@ and validation = | VRewrite of (handle * rwproofterm) (* rewrite *) | VApply of proofterm (* modus ponens *) | VShuffle of ident list (* goal shuffling *) +| VBdep (* map-reduce *) (* external (hl/phl/prhl/...) proof-node *) | VExtern : 'a * handle list -> validation diff --git a/src/ecCoreGoal.mli b/src/ecCoreGoal.mli index f574b49bf3..d045b8f935 100644 --- a/src/ecCoreGoal.mli +++ b/src/ecCoreGoal.mli @@ -155,6 +155,7 @@ type validation = | VRewrite of (handle * rwproofterm) (* rewrite *) | VApply of proofterm (* modus ponens *) | VShuffle of ident list (* goal shuffling *) +| VBdep (* map-reduce *) (* external (hl/phl/prhl/...) proof-node *) | VExtern : 'a * handle list -> validation diff --git a/src/ecCoreLib.ml b/src/ecCoreLib.ml index 6e884a4e8c..e758718b53 100644 --- a/src/ecCoreLib.ml +++ b/src/ecCoreLib.ml @@ -48,6 +48,31 @@ module CI_Bool = struct let p_eq = _Pervasive "=" end +(* -------------------------------------------------------------------- *) +module CI_List = struct + let i_List = "List" + let p_List = EcPath.pqname p_top i_List + let _List = fun x -> EcPath.pqname p_List x + let p_list = _List "list" + + let p_empty = _List "[]" + let p_cons = _List "::" + let p_head = _List "head" + let p_behead = _List "behead" + let p_tail = p_behead + let p_append = _List "++" + let p_flatten = EcPath.pqname p_List "flatten" + let p_map = _List "map" + let p_mapi = _List "mapi" + let p_chunk = EcPath.pqname (EcPath.pqname (EcPath.pqname p_top "BitEncoding") "BitChunking") "chunk" + let p_all = _List "all" + let p_nth = _List "nth" + let p_size = _List "size" + let p_mkseq = _List "mkseq" + let p_mem = _List "mem" + let p_iota = EcPath.extend p_top ["List"; "Iota"; "iota_"] +end + (* -------------------------------------------------------------------- *) module CI_Option = struct let i_Option = "Logic" @@ -83,6 +108,8 @@ module CI_Int = struct let p_int_edivz = _IntDiv "edivz" let p_int_max = _IntDiv "max" let p_iteri = EcPath.extend p_top ["Int"; "IterOp"; "iteri"] + let p_iter = EcPath.extend p_top ["Int"; "IterOp"; "iter"] + let p_fold = EcPath.extend p_top ["Int"; "fold"] end (* -------------------------------------------------------------------- *) diff --git a/src/ecCoreLib.mli b/src/ecCoreLib.mli index 49ff1a9405..79f8d07936 100644 --- a/src/ecCoreLib.mli +++ b/src/ecCoreLib.mli @@ -49,6 +49,31 @@ module CI_Option : sig val p_oget : path end + +(*-------------------------------------------------------------------- *) +module CI_List : sig + val i_List : symbol + val p_List : path + val p_list : path + + val p_empty : path + val p_cons : path + val p_head : path + val p_behead : path + val p_tail : path + val p_append : path + val p_flatten : path + val p_map : path + val p_mapi : path + val p_chunk : path + val p_all : path + val p_size : path + val p_nth : path + val p_mkseq : path + val p_mem : path + val p_iota : path + end + (*-------------------------------------------------------------------- *) module CI_Bool : sig val i_Bool : symbol @@ -84,6 +109,8 @@ module CI_Int : sig val p_int_pow : path val p_int_edivz : path val p_iteri : path + val p_iter : path + val p_fold : path end (* -------------------------------------------------------------------- *) diff --git a/src/ecDecl.ml b/src/ecDecl.ml index 5636641acc..a9d8f8fc66 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -16,9 +16,10 @@ type ty_params = ty_param list type ty_pctor = [ `Int of int | `Named of ty_params ] type tydecl = { - tyd_params : ty_params; - tyd_type : ty_body; - tyd_loca : locality; + tyd_params : ty_params; + tyd_type : ty_body; + tyd_loca : locality; + tyd_clinline : bool; } and ty_body = [ @@ -65,7 +66,10 @@ let abs_tydecl ?(tc = Sp.empty) ?(params = `Int 0) lc = (EcUid.NameGen.bulk ~fmt n) in - { tyd_params = params; tyd_type = `Abstract tc; tyd_loca = lc; } + { tyd_params = params + ; tyd_type = `Abstract tc + ; tyd_loca = lc + ; tyd_clinline = false } (* -------------------------------------------------------------------- *) let ty_instanciate (params : ty_params) (args : ty list) (ty : ty) = @@ -348,3 +352,77 @@ let field_equal f1 f2 = ring_equal f1.f_ring f2.f_ring && EcPath.p_equal f1.f_inv f2.f_inv && EcUtils.oall2 EcPath.p_equal f1.f_div f2.f_div + +(* -------------------------------------------------------------------- *) +type binding_size = form * (int option) + +type crb_bitstring = + { type_ : EcPath.path + ; from_ : EcPath.path + ; to_ : EcPath.path + ; ofint : EcPath.path + ; touint : EcPath.path + ; tosint : EcPath.path + ; size : binding_size + ; theory : EcPath.path } + +type crb_array = + { type_ : EcPath.path + ; get : EcPath.path + ; set : EcPath.path + ; tolist : EcPath.path + ; oflist : EcPath.path + ; size : binding_size + ; theory : EcPath.path } + +type bv_opkind = [ + | `Add of binding_size (* size *) + | `Sub of binding_size (* size *) + | `Mul of binding_size (* size *) + | `Div of binding_size * bool (* size + sign *) + | `Rem of binding_size * bool (* size + sign *) + | `Shl of binding_size (* size *) + | `Shr of binding_size * bool (* size + sign *) + | `Shls of binding_size * binding_size (* size *) + | `Shrs of binding_size * binding_size * bool (* size + sign *) + | `Rol of binding_size (* size *) + | `Rol of binding_size (* size *) + | `Ror of binding_size (* size *) + | `And of binding_size (* size *) + | `Or of binding_size (* size *) + | `Xor of binding_size (* size *) + | `Not of binding_size (* size *) + | `Opp of binding_size (* size *) + | `Lt of binding_size * bool (* size + sign *) + | `Le of binding_size * bool (* size + sign *) + | `Extend of binding_size * binding_size * bool (* size in + size out + sign *) + | `Truncate of binding_size * binding_size (* size in + size out *) + | `Extract of binding_size * binding_size (* size in + size out *) + | `Insert of binding_size * binding_size (* size in + size out *) + | `Concat of binding_size * binding_size * binding_size (* size in1 + size in2 *) + | `Init of binding_size (* size_out *) + | `Get of binding_size (* size_in *) + | `AInit of binding_size * binding_size (* arr_len + size_out *) + | `Map of binding_size * binding_size * binding_size (* size_in + size_out + arr_size *) + | `A2B of (binding_size * binding_size) * binding_size (* (arr_len, elem_sz), out_size *) + | `B2A of binding_size * (binding_size * binding_size) (* size in, (arr_len, elem_sz) *) + | `ASliceGet of (binding_size * binding_size) * binding_size (* arr_len + el_sz + sz_out *) + | `ASliceSet of (binding_size * binding_size) * binding_size (* arr_len + el_sz + sz_in *) +] + +type crb_bvoperator = + { kind : bv_opkind + ; types : EcPath.path list + ; operator : EcPath.path + ; theory : EcPath.path } + +type crb_circuit = +{ name : string +; circuit : Lospecs.Ast.adef +; operator : EcPath.path } + +type crbinding = +| CRB_Bitstring of crb_bitstring +| CRB_Array of crb_array +| CRB_BvOperator of crb_bvoperator +| CRB_Circuit of crb_circuit diff --git a/src/ecDecl.mli b/src/ecDecl.mli index 7864a0e0de..953d0ef00f 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -12,9 +12,10 @@ type ty_params = ty_param list type ty_pctor = [ `Int of int | `Named of ty_params ] type tydecl = { - tyd_params : ty_params; - tyd_type : ty_body; - tyd_loca : locality; + tyd_params : ty_params; + tyd_type : ty_body; + tyd_loca : locality; + tyd_clinline : bool; } and ty_body = [ @@ -198,3 +199,77 @@ type field = { f_div : EcPath.path option; } val field_equal : field -> field -> bool + +(* -------------------------------------------------------------------- *) +type binding_size = form * (int option) + +type crb_bitstring = + { type_ : EcPath.path + ; from_ : EcPath.path + ; to_ : EcPath.path + ; ofint : EcPath.path + ; touint : EcPath.path + ; tosint : EcPath.path + ; size : binding_size + ; theory : EcPath.path } + +type crb_array = + { type_ : EcPath.path + ; get : EcPath.path + ; set : EcPath.path + ; tolist : EcPath.path + ; oflist : EcPath.path + ; size : binding_size + ; theory : EcPath.path } + +type bv_opkind = [ + | `Add of binding_size (* size *) + | `Sub of binding_size (* size *) + | `Mul of binding_size (* size *) + | `Div of binding_size * bool (* size + sign *) + | `Rem of binding_size * bool (* size + sign *) + | `Shl of binding_size (* size *) + | `Shr of binding_size * bool (* size + sign *) + | `Shls of binding_size * binding_size (* size *) + | `Shrs of binding_size * binding_size * bool (* size + sign *) + | `Rol of binding_size (* size *) + | `Rol of binding_size (* size *) + | `Ror of binding_size (* size *) + | `And of binding_size (* size *) + | `Or of binding_size (* size *) + | `Xor of binding_size (* size *) + | `Not of binding_size (* size *) + | `Opp of binding_size (* size *) + | `Lt of binding_size * bool (* size + sign *) + | `Le of binding_size * bool (* size + sign *) + | `Extend of binding_size * binding_size * bool (* size in + size out + sign *) + | `Truncate of binding_size * binding_size (* size in + size out *) + | `Extract of binding_size * binding_size (* size in + size out *) + | `Insert of binding_size * binding_size (* size in + size out *) + | `Concat of binding_size * binding_size * binding_size (* size in1 + size in2 *) + | `Init of binding_size (* size_out *) + | `Get of binding_size (* size_in *) + | `AInit of binding_size * binding_size (* arr_len + size_out *) + | `Map of binding_size * binding_size * binding_size (* size_in + size_out + arr_size *) + | `A2B of (binding_size * binding_size) * binding_size (* (arr_len, elem_sz), out_size *) + | `B2A of binding_size * (binding_size * binding_size) (* size in, (arr_len, elem_sz) *) + | `ASliceGet of (binding_size * binding_size) * binding_size (* arr_len + el_sz + sz_out *) + | `ASliceSet of (binding_size * binding_size) * binding_size (* arr_len + el_sz + sz_in *) +] + +type crb_bvoperator = + { kind : bv_opkind + ; types : EcPath.path list + ; operator : EcPath.path + ; theory : EcPath.path } + +type crb_circuit = +{ name : string +; circuit : Lospecs.Ast.adef +; operator : EcPath.path } + +type crbinding = +| CRB_Bitstring of crb_bitstring +| CRB_Array of crb_array +| CRB_BvOperator of crb_bvoperator +| CRB_Circuit of crb_circuit diff --git a/src/ecEnv.ml b/src/ecEnv.ml index a4a5c8a7ca..e0ca417fd6 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -27,7 +27,6 @@ type 'a suspension = { sp_params : int * (EcIdent.t * module_type) list; } - (* -------------------------------------------------------------------- *) let check_not_suspended (params, obj) = if not (List.for_all (fun x -> x = None) params) then @@ -172,6 +171,36 @@ type actmem = [ | `TS of EcMemory.memory * EcMemory.memory ] +(* -------------------------------------------------------------------- *) +type crb_tyrev_binding = [ + | `Bitstring of crb_bitstring + | `Array of crb_array +] + +(* FIXME: rename `To ? *) +type crb_bitstring_operator = crb_bitstring * [`From | `To | `OfInt | `ToUInt | `ToSInt ] + +type crb_array_operator = crb_array * [`Get | `Set | `ToList | `OfList] + +type crb_oprev_binding = [ + | `Bitstring of crb_bitstring_operator + | `Array of crb_array_operator + | `BvOperator of crb_bvoperator + | `Circuit of crb_circuit +] + +type crb_tyrev_map = crb_tyrev_binding list Mp.t +type crb_oprev_map = crb_oprev_binding list Mp.t + +type crbindings = { + bitstrings : crb_bitstring Mp.t; + arrays : crb_array Mp.t; + bvoperators : crb_bvoperator Mp.t; + circuits : crb_circuit Mp.t; + opreverse : crb_oprev_map; + tyreverse : crb_tyrev_map; +} + (* -------------------------------------------------------------------- *) type preenv = { env_top : EcPath.path option; @@ -193,6 +222,7 @@ type preenv = { env_modlcs : Sid.t; (* declared modules *) env_item : theory_item list; (* in reverse order *) env_norm : env_norm ref; + env_crbds : crbindings; (* Map theory paths to their env before just before theory was closed. *) (* The environment should be incuded for all theories, including *) (* abstract ones. The purpose of this map is to simplify the code *) @@ -303,6 +333,14 @@ let empty gstate = let icomps = MMsym.add name (IPPath path) MMsym.empty in { (empty_mc None) with mc_components = icomps } in + let empty_crbindings : crbindings = + { bitstrings = Mp.empty + ; arrays = Mp.empty + ; bvoperators = Mp.empty + ; circuits = Mp.empty + ; opreverse = Mp.empty + ; tyreverse = Mp.empty } in + { env_top = None; env_gstate = gstate; env_scope = { ec_path = path; ec_scope = `Theory; }; @@ -321,7 +359,8 @@ let empty gstate = env_albase = Mp.empty; env_modlcs = Sid.empty; env_item = []; - env_norm = ref empty_norm_cache; + env_norm = ref empty_norm_cache; + env_crbds = empty_crbindings; env_thenvs = Mp.empty; } (* -------------------------------------------------------------------- *) @@ -1116,10 +1155,12 @@ module MC = struct | Th_alias _ -> (* FIXME:ALIAS *) (mc, None) - - | Th_export _ | Th_addrw _ | Th_instance _ - | Th_auto _ | Th_reduction _ -> - (mc, None) + | Th_export _ + | Th_addrw _ + | Th_instance _ + | Th_auto _ + | Th_reduction _ + | Th_crbinding _ -> (mc, None) in let (mc, submcs) = @@ -2844,774 +2885,988 @@ module Algebra = struct end (* -------------------------------------------------------------------- *) -module Theory = struct - type t = ctheory - type mode = [`All | thmode] +let initial gstate = empty gstate - type compiled = env Mp.t +(* -------------------------------------------------------------------- *) +type ebinding = [ + | `Variable of EcTypes.ty + | `Function of function_ + | `Module of module_expr + | `ModType of module_sig +] - type compiled_theory = { - name : symbol; - ctheory : t; - compiled : compiled; - } +(* FIXME section : Global ? *) +let bind1 ((x, eb) : symbol * ebinding) (env : env) = + match eb with + | `Variable ty -> Var .bind_pvglob x ty env + | `Function f -> Fun .bind x f env + | `Module m -> Mod .bind x {tme_expr = m; tme_loca = `Global} env + | `ModType i -> ModTy .bind x {tms_sig = i; tms_loca = `Global} env - (* ------------------------------------------------------------------ *) - let enter name env = - enter `Theory name env +let bindall (items : (symbol * ebinding) list) (env : env) = + List.fold_left ((^~) bind1) env items - (* ------------------------------------------------------------------ *) - let by_path_opt ?(mode = `All)(p : EcPath.path) (env : env) = - let obj = - match MC.by_path (fun mc -> mc.mc_theories) (IPPath p) env, mode with - | (Some (_, {cth_mode = `Concrete })) as obj, (`All | `Concrete) -> obj - | (Some (_, {cth_mode = `Abstract })) as obj, (`All | `Abstract) -> obj - | _, _ -> None +(* -------------------------------------------------------------------- *) +module LDecl = struct + type error = + | InvalidKind of EcIdent.t * [`Variable | `Hypothesis] + | CannotClear of EcIdent.t * EcIdent.t + | NameClash of [`Ident of EcIdent.t | `Symbol of symbol] + | LookupError of [`Ident of EcIdent.t | `Symbol of symbol] - in omap check_not_suspended obj + exception LdeclError of error - let by_path ?mode (p : EcPath.path) (env : env) = - match by_path_opt ?mode p env with - | None -> lookup_error (`Path p) - | Some obj -> obj + let pp_error fmt (exn : error) = + match exn with + | LookupError (`Symbol s) -> + Format.fprintf fmt "unknown symbol %s" s - let add (p : EcPath.path) (env : env) = - let obj = by_path p env in - MC.import_theory p obj env + | NameClash (`Symbol s) -> + Format.fprintf fmt + "an hypothesis or variable named `%s` already exists" s - let lookup ?(mode = `Concrete) qname (env : env) = - match MC.lookup_theory qname env, mode with - | (_, { cth_mode = `Concrete }) as obj, (`All | `Concrete) -> obj - | (_, { cth_mode = `Abstract }) as obj, (`All | `Abstract) -> obj - | _ -> lookup_error (`QSymbol qname) + | InvalidKind (x, `Variable) -> + Format.fprintf fmt "`%s` is not a variable" (EcIdent.name x) - let lookup_opt ?mode name env = - try_lf (fun () -> lookup ?mode name env) + | InvalidKind (x, `Hypothesis) -> + Format.fprintf fmt "`%s` is not an hypothesis" (EcIdent.name x) - let lookup_path ?mode name env = - fst (lookup ?mode name env) + | CannotClear (id1,id2) -> + Format.fprintf fmt "cannot clear %s as it is used in %s" + (EcIdent.name id1) (EcIdent.name id2) - (* ------------------------------------------------------------------ *) - let env_of_theory (p : EcPath.path) (env : env) = - if EcPath.isprefix ~prefix:p ~path:env.env_scope.ec_path then - env - else - Option.get (Mp.find_opt p env.env_thenvs) + | LookupError (`Ident id) -> + Format.fprintf fmt "unknown identifier `%s`, please report" + (EcIdent.tostring_internal id) - (* ------------------------------------------------------------------ *) - let rebind_alias (name : symbol) (path : path) (env : env) = - let th = by_path path env in - let src = EcPath.pqname (root env) name in - let env = MC.import_theory ~name path th env in - let env = MC.import_mc ~name (IPPath path) env in - let env = { env with env_albase = Mp.add path src env.env_albase } in - env + | NameClash (`Ident id) -> + Format.fprintf fmt "name clash for `%s`, please report" + (EcIdent.tostring_internal id) - (* ------------------------------------------------------------------ *) - let alias ?(import = true) (name : symbol) (path : path) (env : env) = - let env = if import then rebind_alias name path env else env in - { env with env_item = mkitem ~import (Th_alias (name, path)) :: env.env_item } + let _ = EcPException.register (fun fmt exn -> + match exn with + | LdeclError e -> pp_error fmt e + | _ -> raise exn) - (* ------------------------------------------------------------------ *) - let aliases (env : env) = - env.env_albase + let error e = raise (LdeclError e) (* ------------------------------------------------------------------ *) - let rec bind_instance_th path inst cth = - List.fold_left (bind_instance_th_item path) inst cth - - and bind_instance_th_item path inst item = - if not item.ti_import then inst else + let ld_subst s ld = + match ld with + | LD_var (ty, body) -> + LD_var (ty_subst s ty, body |> omap (Fsubst.f_subst s)) - let xpath x = EcPath.pqname path x in + | LD_mem mt -> + LD_mem (EcMemory.mt_subst (ty_subst s) mt) - match item.ti_item with - | Th_instance (ty, k, _) -> - TypeClass.bind_instance ty k inst + | LD_modty mty -> + LD_modty (Fsubst.mty_mr_subst s mty) - | Th_theory (x, cth) when cth.cth_mode = `Concrete -> - bind_instance_th (xpath x) inst cth.cth_items + | LD_hyp f -> + LD_hyp (Fsubst.f_subst s f) - | Th_type (x, tyd) -> begin - match tyd.tyd_type with - | `Abstract tc -> - let myty = - let typ = List.map (fst_map EcIdent.fresh) tyd.tyd_params in - (typ, EcTypes.tconstr (xpath x) (List.map (tvar |- fst) typ)) - in - Sp.fold - (fun p inst -> TypeClass.bind_instance myty (`General p) inst) - tc inst + | LD_abs_st _ -> (* FIXME *) + assert false - | _ -> inst - end + (* ------------------------------------------------------------------ *) + let ld_fv = function + | LD_var (ty, None) -> + ty.ty_fv + | LD_var (ty,Some f) -> + EcIdent.fv_union ty.ty_fv f.f_fv + | LD_mem mt -> + EcMemory.mt_fv mt + | LD_hyp f -> + f.f_fv + | LD_modty p -> + gty_fv (GTmodty p) + | LD_abs_st us -> + let add fv (x,_) = match x with + | PVglob x -> EcPath.x_fv fv x + | PVloc _ -> fv in - | _ -> inst + let fv = Mid.empty in + let fv = List.fold_left add fv us.aus_reads in + let fv = List.fold_left add fv us.aus_writes in + List.fold_left EcPath.x_fv fv us.aus_calls (* ------------------------------------------------------------------ *) - let rec bind_base_th tx path base cth = - List.fold_left (bind_base_th_item tx path) base cth + let by_name s hyps = + match List.ofind ((=) s |- EcIdent.name |- fst) hyps.h_local with + | None -> error (LookupError (`Symbol s)) + | Some h -> h - and bind_base_th_item tx path base item = - if not item.ti_import then base else + let by_id id hyps = + match List.ofind (EcIdent.id_equal id |- fst) hyps.h_local with + | None -> error (LookupError (`Ident id)) + | Some x -> snd x - let xpath x = EcPath.pqname path x in + (* ------------------------------------------------------------------ *) + let as_hyp = function + | (id, LD_hyp f) -> (id, f) + | (id, _) -> error (InvalidKind (id, `Hypothesis)) - match item.ti_item with - | Th_theory (x, cth) -> begin - match cth.cth_mode with - | `Concrete -> - bind_base_th tx (xpath x) base cth.cth_items - | `Abstract -> base - end - | _ -> odfl base (tx path base item.ti_item) + let as_var = function + | (id, LD_var (ty, _)) -> (id, ty) + | (id, _) -> error (InvalidKind (id, `Variable)) (* ------------------------------------------------------------------ *) - let bind_tc_th = - let for1 path base = function - | Th_typeclass (x, tc) -> - tc.tc_prt |> omap (fun prt -> - let src = EcPath.pqname path x in - TC.Graph.add ~src ~dst:prt base) - | _ -> None + let hyp_by_name s hyps = as_hyp (by_name s hyps) + let var_by_name s hyps = as_var (by_name s hyps) - in bind_base_th for1 + (* ------------------------------------------------------------------ *) + let hyp_by_id x hyps = as_hyp (x, by_id x hyps) + let var_by_id x hyps = as_var (x, by_id x hyps) (* ------------------------------------------------------------------ *) - let bind_br_th = - let for1 path base = function - | Th_baserw (x,_) -> - let ip = IPPath (EcPath.pqname path x) in - assert (not (Mip.mem ip base)); - Some (Mip.add ip Sp.empty base) + let has_gen dcast s hyps = + try ignore (dcast (by_name s hyps)); true + with LdeclError (InvalidKind _ | LookupError _) -> false - | Th_addrw (b, r, _) -> - let change = function - | None -> assert false - | Some s -> Some (List.fold_left (fun s r -> Sp.add r s) s r) + let hyp_exists s hyps = has_gen as_hyp s hyps + let var_exists s hyps = has_gen as_var s hyps - in Some (Mip.change change (IPPath b) base) + (* ------------------------------------------------------------------ *) + let has_id x hyps = + try ignore (by_id x hyps); true + with LdeclError (LookupError _) -> false - | _ -> None + let has_inld s = function + | LD_mem mt -> is_bound s mt + | _ -> false - in bind_base_th for1 + let has_name ?(dep = false) s hyps = + let test (id, k) = + EcIdent.name id = s || (dep && has_inld s k) + in List.exists test hyps.h_local (* ------------------------------------------------------------------ *) - let bind_at_th = - let for1 _path db = function - | Th_auto {level; base; axioms; _} -> - Some (Auto.updatedb ?base ~level axioms db) - | _ -> None - - in bind_base_th for1 + let can_unfold id hyps = + try match by_id id hyps with LD_var (_, Some _) -> true | _ -> false + with LdeclError _ -> false - (* ------------------------------------------------------------------ *) - let bind_nt_th = - let for1 path base = function - | Th_operator (x, ({ op_kind = OB_nott _ } as op)) -> - Some (Op.update_ntbase path (x, op) base) - | _ -> None + let unfold id hyps = + try + match by_id id hyps with + | LD_var (_, Some f) -> f + | _ -> raise NotReducible + with LdeclError _ -> raise NotReducible - in bind_base_th for1 + (* ------------------------------------------------------------------ *) + let check_name_clash id hyps = + if has_id id hyps + then error (NameClash (`Ident id)) + else + let s = EcIdent.name id in + if s <> "_" && has_name ~dep:false s hyps then + error (NameClash (`Symbol s)) + + let add_local id ld hyps = + check_name_clash id hyps; + { hyps with h_local = (id, ld) :: hyps.h_local } (* ------------------------------------------------------------------ *) - let bind_rd_th = - let for1 _path db = function - | Th_reduction rules -> - let rules = List.map (fun (x, _, y) -> (x, y)) rules in - Some (Reduction.add_rules rules db) - | _ -> None + let fresh_id hyps s = + let s = + if s = "_" || not (has_name ~dep:true s hyps) + then s + else + let rec aux n = + let s = Printf.sprintf "%s%d" s n in + if has_name ~dep:true s hyps then aux (n+1) else s + in aux 0 - in bind_base_th for1 + in EcIdent.create s + + let fresh_ids hyps names = + let do1 hyps s = + let id = fresh_id hyps s in + (add_local id (LD_var (tbool, None)) hyps, id) + in List.map_fold do1 hyps names (* ------------------------------------------------------------------ *) - let add_restr_th = - let for1 path env = function - | Th_module me -> Some (Mod.add_restr_to_declared path me env) - | _ -> None - in bind_base_th for1 + type hyps = { + le_init : env; + le_env : env; + le_hyps : EcBaseLogic.hyps; + } + + let tohyps lenv = lenv.le_hyps + let toenv lenv = lenv.le_env + let baseenv lenv = lenv.le_init + + let add_local_env x k env = + match k with + | LD_var (ty, _) -> Var.bind_local x ty env + | LD_mem mt -> Memory.push (x, mt) env + | LD_modty i -> Mod.bind_local x i env + | LD_hyp _ -> env + | LD_abs_st us -> AbsStmt.bind x us env (* ------------------------------------------------------------------ *) - let bind - ?(import = true) - (cth : compiled_theory) - (env : env) - = - let { cth_items = items; cth_mode = mode; } = cth.ctheory in - let env = MC.bind_theory cth.name cth.ctheory env in - let env = { - env with - env_item = mkitem ~import (Th_theory (cth.name, cth.ctheory)) :: env.env_item } + let add_local x k h = + let le_hyps = add_local x k (tohyps h) in + let le_env = add_local_env x k h.le_env in + { h with le_hyps; le_env; } + + (* ------------------------------------------------------------------ *) + let init env ?(locals = []) tparams = + let buildenv env = + List.fold_right + (fun (x, k) env -> add_local_env x k env) + locals env in - let env = - match import, mode with - | _, `Concrete -> - let thname = EcPath.pqname (root env) cth.name in - let env_tci = bind_instance_th thname env.env_tci items in - let env_tc = bind_tc_th thname env.env_tc items in - let env_rwbase = bind_br_th thname env.env_rwbase items in - let env_atbase = bind_at_th thname env.env_atbase items in - let env_ntbase = bind_nt_th thname env.env_ntbase items in - let env_redbase = bind_rd_th thname env.env_redbase items in - let env = - { env with - env_tci ; env_tc ; env_rwbase; - env_atbase; env_ntbase; env_redbase; } - in - add_restr_th thname env items + { le_init = env; + le_env = buildenv env; + le_hyps = { h_tvar = tparams; h_local = locals; }; } - | _, _ -> - env + (* ------------------------------------------------------------------ *) + let clear ?(leniant = false) ids hyps = + let rec filter ids hyps = + match hyps with [] -> [] | ((id, lk) as bd) :: hyps -> + + let ids, bd = + if EcIdent.Sid.mem id ids then (ids, None) else + + let fv = ld_fv lk in + + if Mid.set_disjoint ids fv then + (ids, Some bd) + else + if leniant then + (Mid.set_diff ids fv, Some bd) + else + let inter = Mid.set_inter ids fv in + error (CannotClear (Sid.choose inter, id)) + in List.ocons bd (filter ids hyps) in - { env with - env_thenvs = Mp.set_union env.env_thenvs cth.compiled } + let locals = filter ids hyps.le_hyps.h_local in - (* ------------------------------------------------------------------ *) - let rebind name th env = - MC.bind_theory name th env + init hyps.le_init ~locals hyps.le_hyps.h_tvar (* ------------------------------------------------------------------ *) - let import (path : EcPath.path) (env : env) = - let rec import (env : env) path (th : theory) = - let xpath x = EcPath.pqname path x in - let import_th_item (env : env) (item : theory_item) = - if not item.ti_import then env else + let hyp_convert x check hyps = + let module E = struct exception NoOp end in - match item.ti_item with - | Th_type (x, ty) -> - MC.import_tydecl (xpath x) ty env + let init locals = init hyps.le_init ~locals hyps.le_hyps.h_tvar in - | Th_operator (x, op) -> - MC.import_operator (xpath x) op env + let rec doit locals = + match locals with + | (y, LD_hyp fp) :: locals when EcIdent.id_equal x y -> begin + let fp' = check (lazy (init locals)) fp in + if fp == fp' then raise E.NoOp else (x, LD_hyp fp') :: locals + end - | Th_axiom (x, ax) -> - MC.import_axiom (xpath x) ax env + | [] -> error (LookupError (`Ident x)) + | ld :: locals -> ld :: (doit locals) - | Th_modtype (x, mty) -> - MC.import_modty (xpath x) mty env + in (try Some (doit hyps.le_hyps.h_local) with E.NoOp -> None) |> omap init - | Th_module ({ tme_expr = me; tme_loca = lc; }) -> - let env = MC.import_mod (IPPath (xpath me.me_name)) (me, Some lc) env in - let env = MC.import_mc (IPPath (xpath me.me_name)) env in - env + (* ------------------------------------------------------------------ *) + let local_hyps x hyps = + let rec doit locals = + match locals with + | (y, _) :: locals -> + if EcIdent.id_equal x y then locals else doit locals + | [] -> + error (LookupError (`Ident x)) in - | Th_export (p, _) -> - import env p (by_path ~mode:`Concrete p env).cth_items + let locals = doit hyps.le_hyps.h_local in + init hyps.le_init ~locals hyps.le_hyps.h_tvar - | Th_theory (x, ({cth_mode = `Concrete} as th)) -> - let env = MC.import_theory (xpath x) th env in - let env = MC.import_mc (IPPath (xpath x)) env in - env + (* ------------------------------------------------------------------ *) + let by_name s hyps = by_name s (tohyps hyps) + let by_id x hyps = by_id x (tohyps hyps) - | Th_theory (x, ({cth_mode = `Abstract} as th)) -> - MC.import_theory (xpath x) th env + let has_name s hyps = has_name ~dep:false s (tohyps hyps) + let has_id x hyps = has_id x (tohyps hyps) - | Th_typeclass (x, tc) -> - MC.import_typeclass (xpath x) tc env + let hyp_by_name s hyps = hyp_by_name s (tohyps hyps) + let hyp_exists s hyps = hyp_exists s (tohyps hyps) + let hyp_by_id x hyps = snd (hyp_by_id x (tohyps hyps)) - | Th_baserw (x, _) -> - MC.import_rwbase (xpath x) env + let var_by_name s hyps = var_by_name s (tohyps hyps) + let var_exists s hyps = var_exists s (tohyps hyps) + let var_by_id x hyps = snd (var_by_id x (tohyps hyps)) - | Th_alias (name, path) -> - rebind_alias name path env + let can_unfold x hyps = can_unfold x (tohyps hyps) + let unfold x hyps = unfold x (tohyps hyps) - | Th_addrw _ | Th_instance _ | Th_auto _ | Th_reduction _ -> - env + let fresh_id hyps s = fresh_id (tohyps hyps) s + let fresh_ids hyps s = snd (fresh_ids (tohyps hyps) s) - in - List.fold_left import_th_item env th + (* ------------------------------------------------------------------ *) + let push_active_ss m lenv = + { lenv with le_env = Memory.push_active_ss m lenv.le_env } - in - import env path (by_path ~mode:`Concrete path env).cth_items + let push_active_ts ml mr lenv = + { lenv with le_env = Memory.push_active_ts ml mr lenv.le_env } - (* ------------------------------------------------------------------ *) - let export (path : EcPath.path) lc (env : env) = - let env = import path env in - { env with env_item = mkitem ~import:true (Th_export (path, lc)) :: env.env_item } + let push_all l lenv = + { lenv with le_env = Memory.push_all l lenv.le_env } - (* ------------------------------------------------------------------ *) - let rec filter clears root cleared items = - snd_map (List.pmap identity) - (List.map_fold (filter1 clears root) cleared items) + let hoareF mem xp lenv = + let env1, env2 = Fun.hoareF mem xp lenv.le_env in + { lenv with le_env = env1}, {lenv with le_env = env2 } - and filter_th clears root cleared items = - let mempty = List.exists (EcPath.p_equal root) clears in - let cleared, items = filter clears root cleared items in + let equivF ml mr xp1 xp2 lenv = + let env1, env2 = Fun.equivF ml mr xp1 xp2 lenv.le_env in + { lenv with le_env = env1}, {lenv with le_env = env2 } - if mempty && List.is_empty items - then (Sp.add root cleared, None) - else (cleared, Some items) + let inv_memenv ml mr lenv = + { lenv with le_env = Fun.inv_memenv ml mr lenv.le_env } - and filter1 clears root = - let inclear p = List.exists (EcPath.p_equal p) clears in - let thclear = inclear root in + let inv_memenv1 m lenv = + { lenv with le_env = Fun.inv_memenv1 m lenv.le_env } +end - fun cleared item -> - let cleared, item_r = - match item.ti_item with - | Th_theory (x, cth) -> - let cleared, items = - let xpath = EcPath.pqname root x in - filter_th clears xpath cleared cth.cth_items in - let item = items |> omap (fun items -> - let cth = { cth with cth_items = items } in - Th_theory (x, cth)) in - (cleared, item) +(* -------------------------------------------------------------------- *) +module Circuit = struct + let push_tyreverse (reverse : crb_tyrev_map) (p : path) (v : crb_tyrev_binding) = + Mp.change + (fun vs -> Some (v :: Option.value ~default:[] vs)) + p reverse + + let push_all_tyreverse (reverse : crb_tyrev_map) (pvs : (path * crb_tyrev_binding) list) = + List.fold_left (fun rv (p, v) -> push_tyreverse rv p v) reverse pvs + + let push_opreverse (reverse : crb_oprev_map) (p : path) (v : crb_oprev_binding) = + Mp.change + (fun vs -> Some (v :: Option.value ~default:[] vs)) + p reverse + + let push_all_opreverse (reverse : crb_oprev_map) (pvs : (path * crb_oprev_binding) list) = + List.fold_left (fun rv (p, v) -> push_opreverse rv p v) reverse pvs + + let rebind_bitstring_ (bs : crb_bitstring) (bindings : crbindings) = + { bindings with + bitstrings = Mp.add bs.type_ bs bindings.bitstrings; + tyreverse = push_tyreverse bindings.tyreverse bs.type_ (`Bitstring bs); + opreverse = + push_all_opreverse + bindings.opreverse + [ (bs.from_, `Bitstring (bs, `From )) + ; (bs.to_ , `Bitstring (bs, `To )) + ; (bs.touint, `Bitstring (bs, `ToUInt)) + ; (bs.tosint, `Bitstring (bs, `ToSInt)) + ; (bs.ofint, `Bitstring (bs, `OfInt)) ]; } + + let rebind_bitstring (bs : crb_bitstring) (env : env) : env = + { env with env_crbds = rebind_bitstring_ bs env.env_crbds } + + let bind_bitstring ?(import = true) (lc : is_local) (bs : crb_bitstring) (env : env) = + let env = if import then rebind_bitstring bs env else env in + { env with env_item = + mkitem ~import (Th_crbinding (CRB_Bitstring bs, lc)) :: env.env_item; } + + let rebind_array_ (ba : crb_array) (bindings : crbindings) = + { bindings with + arrays = Mp.add ba.type_ ba bindings.arrays; + tyreverse = push_tyreverse bindings.tyreverse ba.type_ (`Array ba); + opreverse = + push_all_opreverse + bindings.opreverse + [ (ba.set , `Array (ba, `Set)) + ; (ba.get , `Array (ba, `Get)) + ; (ba.tolist, `Array (ba, `ToList)) + ; (ba.oflist, `Array (ba, `OfList)) ]} + + let rebind_array (ba : crb_array) (env : env) : env = + { env with env_crbds = rebind_array_ ba env.env_crbds } + + let bind_array ?(import = true) (lc : is_local) (ba : crb_array) (env : env) = + let env = if import then rebind_array ba env else env in + { env with env_item = + mkitem ~import (Th_crbinding (CRB_Array ba, lc)) :: env.env_item; } - | _ -> let item_r = match item.ti_item with + let rebind_bvoperator_ (op : crb_bvoperator) (bindings : crbindings) = + { bindings with + bvoperators = Mp.add op.operator op bindings.bvoperators; + opreverse = push_opreverse bindings.opreverse op.operator (`BvOperator op); } - | Th_axiom (_, { ax_kind = `Lemma }) when thclear -> - None + let rebind_bvoperator (op : crb_bvoperator) (env : env) = + { env with env_crbds = rebind_bvoperator_ op env.env_crbds } - | Th_axiom (x, ({ ax_kind = `Axiom (tags, false) } as ax)) when thclear -> - Some (Th_axiom (x, { ax with ax_kind = `Axiom (tags, true) })) + let bind_bvoperator ?(import = true) (lc : is_local) (op : crb_bvoperator) (env : env) = + let env = if import then rebind_bvoperator op env else env in + { env with env_item = + mkitem ~import (Th_crbinding (CRB_BvOperator op, lc)) :: env.env_item; } + + let rebind_circuit_ (cr : crb_circuit) (bindings : crbindings) = + { bindings with + circuits = Mp.add cr.operator cr bindings.circuits; + opreverse = push_opreverse bindings.opreverse cr.operator (`Circuit cr); } + + let rebind_circuit (cr : crb_circuit) (env : env) = + { env with env_crbds = rebind_circuit_ cr env.env_crbds } + + let bind_circuit ?(import = true) (lc : is_local) (cr : crb_circuit) (env : env) = + let env = if import then rebind_circuit cr env else env in + { env with env_item = + mkitem ~import (Th_crbinding (CRB_Circuit cr, lc)) :: env.env_item; } + + let bind_crbinding ?import (lc : is_local) (crb : crbinding) (env : env) = + match crb with + | CRB_Bitstring bs -> bind_bitstring ?import lc bs env + | CRB_Array ba -> bind_array ?import lc ba env + | CRB_BvOperator op -> bind_bvoperator ?import lc op env + | CRB_Circuit cr -> bind_circuit ?import lc cr env + + let rec lookup_bitstring_path (env : env) (k : path) : crb_bitstring option = +(* Format.eprintf "Looking up bitstring binding for type with path %s@." (EcPath.tostring k); *) + let k, _ = Ty.lookup (EcPath.toqsymbol k) (env) in + match Mp.find_opt k env.env_crbds.bitstrings with + | Some _ as bs -> bs + | None -> try lookup_bitstring env (Ty.unfold k [] env) + with LookupFailure _ -> None + + and lookup_bitstring (env : env) (ty : ty) : crb_bitstring option = + match ty.ty_node with + | Tconstr (p, []) -> lookup_bitstring_path env p + | _ -> None + + let lookup_bitstring_size_path (env : env) (pth : path) : int option = + Option.bind (Option.map (fun (c : crb_bitstring) -> c.size) (lookup_bitstring_path env pth)) snd + + let lookup_circuit_path (env : env) (v : path) : Lospecs.Ast.adef option = + Mp.find_opt v env.env_crbds.circuits + |> Option.map (fun cr -> cr.circuit) + + let lookup_bitstring_size (env : env) (ty : ty) : int option = + Option.bind (Option.map (fun (c : crb_bitstring) -> c.size) (lookup_bitstring env ty)) snd + + let rec lookup_array_path (env : env) (pth : path) : crb_array option = + let k, _ = Ty.lookup (EcPath.toqsymbol pth) (env) in + match Mp.find_opt k env.env_crbds.arrays with + | Some arr -> Some arr + | None -> try + lookup_array env (Ty.unfold pth [] env) + with LookupFailure e -> None + + and lookup_array (env : env) (ty : ty) : crb_array option = + match ty.ty_node with + | Tconstr (p, [w]) -> lookup_array_path env p + | _ -> None - | Th_addrw (p, ps, lc) -> - let ps = List.filter ((not) |- inclear |- oget |- EcPath.prefix) ps in - if List.is_empty ps then None else Some (Th_addrw (p, ps,lc)) + let rec lookup_array_and_bitstring (env: env) (ty: ty) : (crb_array * crb_bitstring) option = + match ty.ty_node with + | Tconstr (p, [w]) -> +(* Format.eprintf "Unfolding parametric type with path %s@." (EcPath.tostring p); *) + let arr = lookup_array_path env p in + let bs = lookup_bitstring env w in + begin match arr, bs with + | Some arr, Some bs -> Some (arr, bs) + | _ -> None + end + | Tconstr (p, []) -> +(* Format.eprintf "Unfolding non parametric type with path %s@." (EcPath.tostring p); *) + (try + lookup_array_and_bitstring env (Ty.unfold p [] env) + with LookupFailure _ -> None) + | _ -> None - | Th_auto ({ axioms } as auto_rl) -> - let axioms = List.filter (fun (p, _) -> - let p = oget (EcPath.prefix p) in - not (inclear p) - ) axioms in - if List.is_empty axioms then None else Some (Th_auto {auto_rl with axioms}) + let lookup_array_size (env : env) (ty : ty) : int option = + Option.bind (Option.map (fun c -> c.size) (lookup_array env ty)) snd - | (Th_export (p, _)) as item -> - if Sp.mem p cleared then None else Some item + let lookup_bvoperator_path (env : env) (v : path) : crb_bvoperator option = + Mp.find_opt v env.env_crbds.bvoperators - | _ as item -> Some item + let lookup_bvoperator (env : env) (o : qsymbol) : crb_bvoperator option = + let p, _o = Op.lookup o env in + lookup_bvoperator_path env p - in (cleared, item_r) + let lookup_circuit (env : env) (o : qsymbol) : Lospecs.Ast.adef option = + let p, _o = Op.lookup o env in + lookup_circuit_path env p - in (cleared, omap (fun item_r -> { item with ti_item = item_r; }) item_r) + let reverse_type (env : env) (p : path) : crb_tyrev_binding list = + Mp.find_def [] p env.env_crbds.tyreverse - (* ------------------------------------------------------------------ *) - type clear_mode = [`Full | `ClearOnly | `No] + let reverse_operator (env: env) (p : path) : crb_oprev_binding list = + Mp.find_def [] p env.env_crbds.opreverse - let close - ?(clears : path list = []) - ?(pempty : clear_mode = `No) - (loca : is_local) - (mode : thmode) - (env : env) + let reverse_and_filter_operator + ~(filter : crb_oprev_binding -> 'a option) (env : env) (p : path) = - let items = List.rev env.env_item in - let items = - if List.is_empty clears - then (if List.is_empty items then None else Some items) - else snd (filter_th clears (root env) Sp.empty items) in + List.find_map_opt filter (reverse_operator env p) - let items = - match items, pempty with - | None, (`No | `ClearOnly) -> Some [] - | _, _ -> items - in + let reverse_bitstring_operator = + reverse_and_filter_operator + ~filter:(function `Bitstring x -> Some x | _ -> None) - items |> omap (fun items -> - let ctheory = - { cth_items = items - ; cth_source = None - ; cth_loca = loca - ; cth_mode = mode - } in + let reverse_array_operator = + reverse_and_filter_operator + ~filter:(function `Array x -> Some x | _ -> None) - let root = env.env_scope.ec_path in - let name = EcPath.basename root in + let reverse_bvoperator = + reverse_and_filter_operator + ~filter:(function `BvOperator x -> Some x | _ -> None) - let compiled = - Mp.filter - (fun path _ -> EcPath.isprefix ~prefix:root ~path) - env.env_thenvs in - let compiled = Mp.add env.env_scope.ec_path env compiled in + let reverse_circuit = + reverse_and_filter_operator + ~filter:(function `Circuit x -> Some x | _ -> None) - { name; ctheory; compiled; } - ) + (* FIXME: Remove env argument? *) + let get_specification_by_name (env : env) ~(filename : string) (name : symbol) : Lospecs.Ast.adef option = + let specs = Lospecs.Circuit_spec.load_from_file ~filename in + List.Exceptionless.assoc name specs +end + +(* -------------------------------------------------------------------- *) +module Theory = struct + type t = ctheory + type mode = [`All | thmode] + + type compiled = env Mp.t + + type compiled_theory = { + name : symbol; + ctheory : t; + compiled : compiled; + } (* ------------------------------------------------------------------ *) - let require (compiled : compiled_theory) (env : env) = - let cth = compiled.ctheory in - let rootnm = EcCoreLib.p_top in - let thpath = EcPath.pqname rootnm compiled.name in + let enter name env = + enter `Theory name env - let env = - match cth.cth_mode with - | `Concrete -> - let (_, thmc), submcs = - MC.mc_of_theory_r rootnm (compiled.name, cth) - in MC.bind_submc env rootnm ((compiled.name, thmc), submcs) + (* ------------------------------------------------------------------ *) + let by_path_opt ?(mode = `All)(p : EcPath.path) (env : env) = + let obj = + match MC.by_path (fun mc -> mc.mc_theories) (IPPath p) env, mode with + | (Some (_, {cth_mode = `Concrete })) as obj, (`All | `Concrete) -> obj + | (Some (_, {cth_mode = `Abstract })) as obj, (`All | `Abstract) -> obj + | _, _ -> None - | `Abstract -> env - in + in omap check_not_suspended obj - let topmc = Mip.find (IPPath rootnm) env.env_comps in - let topmc = MC._up_theory false topmc compiled.name (IPPath thpath, cth) in - let topmc = MC._up_mc false topmc (IPPath thpath) in + let by_path ?mode (p : EcPath.path) (env : env) = + match by_path_opt ?mode p env with + | None -> lookup_error (`Path p) + | Some obj -> obj - let current = env.env_current in - let current = MC._up_theory true current compiled.name (IPPath thpath, cth) in - let current = MC._up_mc true current (IPPath thpath) in + let add (p : EcPath.path) (env : env) = + let obj = by_path p env in + MC.import_theory p obj env - let comps = env.env_comps in - let comps = Mip.add (IPPath rootnm) topmc comps in + let lookup ?(mode = `Concrete) qname (env : env) = + match MC.lookup_theory qname env, mode with + | (_, { cth_mode = `Concrete }) as obj, (`All | `Concrete) -> obj + | (_, { cth_mode = `Abstract }) as obj, (`All | `Abstract) -> obj + | _ -> lookup_error (`QSymbol qname) - let env = { env with env_current = current; env_comps = comps; } in + let lookup_opt ?mode name env = + try_lf (fun () -> lookup ?mode name env) - match cth.cth_mode with - | `Abstract -> - { env with - env_thenvs = Mp.set_union env.env_thenvs compiled.compiled; } + let lookup_path ?mode name env = + fst (lookup ?mode name env) - | `Concrete -> - { env with - env_tci = bind_instance_th thpath env.env_tci cth.cth_items; - env_tc = bind_tc_th thpath env.env_tc cth.cth_items; - env_rwbase = bind_br_th thpath env.env_rwbase cth.cth_items; - env_atbase = bind_at_th thpath env.env_atbase cth.cth_items; - env_ntbase = bind_nt_th thpath env.env_ntbase cth.cth_items; - env_redbase = bind_rd_th thpath env.env_redbase cth.cth_items; - env_thenvs = Mp.set_union env.env_thenvs compiled.compiled; } -end + (* ------------------------------------------------------------------ *) + let env_of_theory (p : EcPath.path) (env : env) = + if EcPath.isprefix ~prefix:p ~path:env.env_scope.ec_path then + env + else + Option.get (Mp.find_opt p env.env_thenvs) -(* -------------------------------------------------------------------- *) -let initial gstate = empty gstate +(* ------------------------------------------------------------------ *) + let rebind_alias (name : symbol) (path : path) (env : env) = + let th = by_path path env in + let src = EcPath.pqname (root env) name in + let env = MC.import_theory ~name path th env in + let env = MC.import_mc ~name (IPPath path) env in + let env = { env with env_albase = Mp.add path src env.env_albase } in + env -(* -------------------------------------------------------------------- *) -type ebinding = [ - | `Variable of EcTypes.ty - | `Function of function_ - | `Module of module_expr - | `ModType of module_sig -] + (* ------------------------------------------------------------------ *) + let alias ?(import = true) (name : symbol) (path : path) (env : env) = + let env = if import then rebind_alias name path env else env in + { env with env_item = mkitem ~import (Th_alias (name, path)) :: env.env_item } -(* FIXME section : Global ? *) -let bind1 ((x, eb) : symbol * ebinding) (env : env) = - match eb with - | `Variable ty -> Var .bind_pvglob x ty env - | `Function f -> Fun .bind x f env - | `Module m -> Mod .bind x {tme_expr = m; tme_loca = `Global} env - | `ModType i -> ModTy .bind x {tms_sig = i; tms_loca = `Global} env + (* ------------------------------------------------------------------ *) + let aliases (env : env) = + env.env_albase + + (* ------------------------------------------------------------------ *) + let rec bind_instance_th path inst cth = + List.fold_left (bind_instance_th_item path) inst cth + + and bind_instance_th_item path inst item = + if not item.ti_import then inst else -let bindall (items : (symbol * ebinding) list) (env : env) = - List.fold_left ((^~) bind1) env items + let xpath x = EcPath.pqname path x in -(* -------------------------------------------------------------------- *) -module LDecl = struct - type error = - | InvalidKind of EcIdent.t * [`Variable | `Hypothesis] - | CannotClear of EcIdent.t * EcIdent.t - | NameClash of [`Ident of EcIdent.t | `Symbol of symbol] - | LookupError of [`Ident of EcIdent.t | `Symbol of symbol] + match item.ti_item with + | Th_instance (ty, k, _) -> + TypeClass.bind_instance ty k inst - exception LdeclError of error + | Th_theory (x, cth) when cth.cth_mode = `Concrete -> + bind_instance_th (xpath x) inst cth.cth_items - let pp_error fmt (exn : error) = - match exn with - | LookupError (`Symbol s) -> - Format.fprintf fmt "unknown symbol %s" s + | Th_type (x, tyd) -> begin + match tyd.tyd_type with + | `Abstract tc -> + let myty = + let typ = List.map (fst_map EcIdent.fresh) tyd.tyd_params in + (typ, EcTypes.tconstr (xpath x) (List.map (tvar |- fst) typ)) + in + Sp.fold + (fun p inst -> TypeClass.bind_instance myty (`General p) inst) + tc inst - | NameClash (`Symbol s) -> - Format.fprintf fmt - "an hypothesis or variable named `%s` already exists" s + | _ -> inst + end - | InvalidKind (x, `Variable) -> - Format.fprintf fmt "`%s` is not a variable" (EcIdent.name x) + | _ -> inst - | InvalidKind (x, `Hypothesis) -> - Format.fprintf fmt "`%s` is not an hypothesis" (EcIdent.name x) + (* ------------------------------------------------------------------ *) + let rec bind_base_th tx path base cth = + List.fold_left (bind_base_th_item tx path) base cth - | CannotClear (id1,id2) -> - Format.fprintf fmt "cannot clear %s as it is used in %s" - (EcIdent.name id1) (EcIdent.name id2) + and bind_base_th_item tx path base item = + if not item.ti_import then base else - | LookupError (`Ident id) -> - Format.fprintf fmt "unknown identifier `%s`, please report" - (EcIdent.tostring_internal id) + let xpath x = EcPath.pqname path x in - | NameClash (`Ident id) -> - Format.fprintf fmt "name clash for `%s`, please report" - (EcIdent.tostring_internal id) + match item.ti_item with + | Th_theory (x, cth) -> begin + match cth.cth_mode with + | `Concrete -> + bind_base_th tx (xpath x) base cth.cth_items + | `Abstract -> base + end + | _ -> odfl base (tx path base item.ti_item) - let _ = EcPException.register (fun fmt exn -> - match exn with - | LdeclError e -> pp_error fmt e - | _ -> raise exn) + (* ------------------------------------------------------------------ *) + let bind_tc_th = + let for1 path base = function + | Th_typeclass (x, tc) -> + tc.tc_prt |> omap (fun prt -> + let src = EcPath.pqname path x in + TC.Graph.add ~src ~dst:prt base) + | _ -> None - let error e = raise (LdeclError e) + in bind_base_th for1 (* ------------------------------------------------------------------ *) - let ld_subst s ld = - match ld with - | LD_var (ty, body) -> - LD_var (ty_subst s ty, body |> omap (Fsubst.f_subst s)) + let bind_br_th = + let for1 path base = function + | Th_baserw (x,_) -> + let ip = IPPath (EcPath.pqname path x) in + assert (not (Mip.mem ip base)); + Some (Mip.add ip Sp.empty base) - | LD_mem mt -> - LD_mem (EcMemory.mt_subst (ty_subst s) mt) + | Th_addrw (b, r, _) -> + let change = function + | None -> assert false + | Some s -> Some (List.fold_left (fun s r -> Sp.add r s) s r) - | LD_modty mty -> - LD_modty (Fsubst.mty_mr_subst s mty) + in Some (Mip.change change (IPPath b) base) - | LD_hyp f -> - LD_hyp (Fsubst.f_subst s f) + | _ -> None - | LD_abs_st _ -> (* FIXME *) - assert false + in bind_base_th for1 (* ------------------------------------------------------------------ *) - let ld_fv = function - | LD_var (ty, None) -> - ty.ty_fv - | LD_var (ty,Some f) -> - EcIdent.fv_union ty.ty_fv f.f_fv - | LD_mem mt -> - EcMemory.mt_fv mt - | LD_hyp f -> - f.f_fv - | LD_modty p -> - gty_fv (GTmodty p) - | LD_abs_st us -> - let add fv (x,_) = match x with - | PVglob x -> EcPath.x_fv fv x - | PVloc _ -> fv in + let bind_at_th = + let for1 _path db = function + | Th_auto {level; base; axioms; _} -> + Some (Auto.updatedb ?base ~level axioms db) + | _ -> None - let fv = Mid.empty in - let fv = List.fold_left add fv us.aus_reads in - let fv = List.fold_left add fv us.aus_writes in - List.fold_left EcPath.x_fv fv us.aus_calls + in bind_base_th for1 (* ------------------------------------------------------------------ *) - let by_name s hyps = - match List.ofind ((=) s |- EcIdent.name |- fst) hyps.h_local with - | None -> error (LookupError (`Symbol s)) - | Some h -> h + let bind_nt_th = + let for1 path base = function + | Th_operator (x, ({ op_kind = OB_nott _ } as op)) -> + Some (Op.update_ntbase path (x, op) base) + | _ -> None - let by_id id hyps = - match List.ofind (EcIdent.id_equal id |- fst) hyps.h_local with - | None -> error (LookupError (`Ident id)) - | Some x -> snd x + in bind_base_th for1 (* ------------------------------------------------------------------ *) - let as_hyp = function - | (id, LD_hyp f) -> (id, f) - | (id, _) -> error (InvalidKind (id, `Hypothesis)) + let bind_rd_th = + let for1 _path db = function + | Th_reduction rules -> + let rules = List.map (fun (x, _, y) -> (x, y)) rules in + Some (Reduction.add_rules rules db) + | _ -> None - let as_var = function - | (id, LD_var (ty, _)) -> (id, ty) - | (id, _) -> error (InvalidKind (id, `Variable)) + in bind_base_th for1 (* ------------------------------------------------------------------ *) - let hyp_by_name s hyps = as_hyp (by_name s hyps) - let var_by_name s hyps = as_var (by_name s hyps) + let add_restr_th = + let for1 path env = function + | Th_module me -> Some (Mod.add_restr_to_declared path me env) + | _ -> None + in bind_base_th for1 (* ------------------------------------------------------------------ *) - let hyp_by_id x hyps = as_hyp (x, by_id x hyps) - let var_by_id x hyps = as_var (x, by_id x hyps) + let bind_cr_th = + let for1 (_ : path) (bindings : crbindings) = function + | Th_crbinding (CRB_Bitstring bs, _) -> + Some (Circuit.rebind_bitstring_ bs bindings) - (* ------------------------------------------------------------------ *) - let has_gen dcast s hyps = - try ignore (dcast (by_name s hyps)); true - with LdeclError (InvalidKind _ | LookupError _) -> false + | Th_crbinding (CRB_Array ba, _) -> + Some (Circuit.rebind_array_ ba bindings) - let hyp_exists s hyps = has_gen as_hyp s hyps - let var_exists s hyps = has_gen as_var s hyps + | Th_crbinding (CRB_BvOperator op, _) -> + Some (Circuit.rebind_bvoperator_ op bindings) + + | Th_crbinding (CRB_Circuit cr, _) -> + Some (Circuit.rebind_circuit_ cr bindings) + + | _ -> None + in bind_base_th for1 (* ------------------------------------------------------------------ *) - let has_id x hyps = - try ignore (by_id x hyps); true - with LdeclError (LookupError _) -> false + let bind + ?(import = true) + (cth : compiled_theory) + (env : env) + = + let { cth_items = items; cth_mode = mode; } = cth.ctheory in + let env = MC.bind_theory cth.name cth.ctheory env in + let env = { + env with + env_item = mkitem ~import (Th_theory (cth.name, cth.ctheory)) :: env.env_item } + in - let has_inld s = function - | LD_mem mt -> is_bound s mt - | _ -> false + let env = + match import, mode with + | _, `Concrete -> + let thname = EcPath.pqname (root env) cth.name in + let env_tci = bind_instance_th thname env.env_tci items in + let env_tc = bind_tc_th thname env.env_tc items in + let env_rwbase = bind_br_th thname env.env_rwbase items in + let env_atbase = bind_at_th thname env.env_atbase items in + let env_ntbase = bind_nt_th thname env.env_ntbase items in + let env_redbase = bind_rd_th thname env.env_redbase items in + let env_crbds = bind_cr_th thname env.env_crbds items in + let env = + { env with + env_tci ; env_tc ; env_rwbase; + env_atbase; env_ntbase; env_redbase; + env_crbds ; } + in + add_restr_th thname env items - let has_name ?(dep = false) s hyps = - let test (id, k) = - EcIdent.name id = s || (dep && has_inld s k) - in List.exists test hyps.h_local + | _, _ -> + env + in - (* ------------------------------------------------------------------ *) - let can_unfold id hyps = - try match by_id id hyps with LD_var (_, Some _) -> true | _ -> false - with LdeclError _ -> false + { env with + env_thenvs = Mp.set_union env.env_thenvs cth.compiled } - let unfold id hyps = - try - match by_id id hyps with - | LD_var (_, Some f) -> f - | _ -> raise NotReducible - with LdeclError _ -> raise NotReducible + (* ------------------------------------------------------------------ *) + let rebind name th env = + MC.bind_theory name th env (* ------------------------------------------------------------------ *) - let check_name_clash id hyps = - if has_id id hyps - then error (NameClash (`Ident id)) - else - let s = EcIdent.name id in - if s <> "_" && has_name ~dep:false s hyps then - error (NameClash (`Symbol s)) + let import (path : EcPath.path) (env : env) = + let rec import (env : env) path (th : theory) = + let xpath x = EcPath.pqname path x in + let import_th_item (env : env) (item : theory_item) = + if not item.ti_import then env else - let add_local id ld hyps = - check_name_clash id hyps; - { hyps with h_local = (id, ld) :: hyps.h_local } + match item.ti_item with + | Th_type (x, ty) -> + MC.import_tydecl (xpath x) ty env + + | Th_operator (x, op) -> + MC.import_operator (xpath x) op env + + | Th_axiom (x, ax) -> + MC.import_axiom (xpath x) ax env + + | Th_modtype (x, mty) -> + MC.import_modty (xpath x) mty env + + | Th_module ({ tme_expr = me; tme_loca = lc; }) -> + let env = MC.import_mod (IPPath (xpath me.me_name)) (me, Some lc) env in + let env = MC.import_mc (IPPath (xpath me.me_name)) env in + env - (* ------------------------------------------------------------------ *) - let fresh_id hyps s = - let s = - if s = "_" || not (has_name ~dep:true s hyps) - then s - else - let rec aux n = - let s = Printf.sprintf "%s%d" s n in - if has_name ~dep:true s hyps then aux (n+1) else s - in aux 0 + | Th_export (p, _) -> + import env p (by_path ~mode:`Concrete p env).cth_items - in EcIdent.create s + | Th_theory (x, ({cth_mode = `Concrete} as th)) -> + let env = MC.import_theory (xpath x) th env in + let env = MC.import_mc (IPPath (xpath x)) env in + env - let fresh_ids hyps names = - let do1 hyps s = - let id = fresh_id hyps s in - (add_local id (LD_var (tbool, None)) hyps, id) - in List.map_fold do1 hyps names + | Th_theory (x, ({cth_mode = `Abstract} as th)) -> + MC.import_theory (xpath x) th env - (* ------------------------------------------------------------------ *) - type hyps = { - le_init : env; - le_env : env; - le_hyps : EcBaseLogic.hyps; - } + | Th_typeclass (x, tc) -> + MC.import_typeclass (xpath x) tc env - let tohyps lenv = lenv.le_hyps - let toenv lenv = lenv.le_env - let baseenv lenv = lenv.le_init + | Th_baserw (x, _) -> + MC.import_rwbase (xpath x) env - let add_local_env x k env = - match k with - | LD_var (ty, _) -> Var.bind_local x ty env - | LD_mem mt -> Memory.push (x, mt) env - | LD_modty i -> Mod.bind_local x i env - | LD_hyp _ -> env - | LD_abs_st us -> AbsStmt.bind x us env + | Th_alias (name, path) -> + rebind_alias name path env - (* ------------------------------------------------------------------ *) - let add_local x k h = - let le_hyps = add_local x k (tohyps h) in - let le_env = add_local_env x k h.le_env in - { h with le_hyps; le_env; } + | Th_addrw _ + | Th_instance _ + | Th_auto _ + | Th_reduction _ + | Th_crbinding _ -> env + in + List.fold_left import_th_item env th - (* ------------------------------------------------------------------ *) - let init env ?(locals = []) tparams = - let buildenv env = - List.fold_right - (fun (x, k) env -> add_local_env x k env) - locals env in + import env path (by_path ~mode:`Concrete path env).cth_items - { le_init = env; - le_env = buildenv env; - le_hyps = { h_tvar = tparams; h_local = locals; }; } + (* ------------------------------------------------------------------ *) + let export (path : EcPath.path) lc (env : env) = + let env = import path env in + { env with env_item = mkitem ~import:true (Th_export (path, lc)) :: env.env_item } (* ------------------------------------------------------------------ *) - let clear ?(leniant = false) ids hyps = - let rec filter ids hyps = - match hyps with [] -> [] | ((id, lk) as bd) :: hyps -> + let rec filter clears root cleared items = + snd_map (List.pmap identity) + (List.map_fold (filter1 clears root) cleared items) - let ids, bd = - if EcIdent.Sid.mem id ids then (ids, None) else + and filter_th clears root cleared items = + let mempty = List.exists (EcPath.p_equal root) clears in + let cleared, items = filter clears root cleared items in - let fv = ld_fv lk in + if mempty && List.is_empty items + then (Sp.add root cleared, None) + else (cleared, Some items) - if Mid.set_disjoint ids fv then - (ids, Some bd) - else - if leniant then - (Mid.set_diff ids fv, Some bd) - else - let inter = Mid.set_inter ids fv in - error (CannotClear (Sid.choose inter, id)) - in List.ocons bd (filter ids hyps) - in + and filter1 clears root = + let inclear p = List.exists (EcPath.p_equal p) clears in + let thclear = inclear root in - let locals = filter ids hyps.le_hyps.h_local in + fun cleared item -> + let cleared, item_r = + match item.ti_item with + | Th_theory (x, cth) -> + let cleared, items = + let xpath = EcPath.pqname root x in + filter_th clears xpath cleared cth.cth_items in + let item = items |> omap (fun items -> + let cth = { cth with cth_items = items } in + Th_theory (x, cth)) in + (cleared, item) - init hyps.le_init ~locals hyps.le_hyps.h_tvar + | _ -> let item_r = match item.ti_item with - (* ------------------------------------------------------------------ *) - let hyp_convert x check hyps = - let module E = struct exception NoOp end in + | Th_axiom (_, { ax_kind = `Lemma }) when thclear -> + None - let init locals = init hyps.le_init ~locals hyps.le_hyps.h_tvar in + | Th_axiom (x, ({ ax_kind = `Axiom (tags, false) } as ax)) when thclear -> + Some (Th_axiom (x, { ax with ax_kind = `Axiom (tags, true) })) - let rec doit locals = - match locals with - | (y, LD_hyp fp) :: locals when EcIdent.id_equal x y -> begin - let fp' = check (lazy (init locals)) fp in - if fp == fp' then raise E.NoOp else (x, LD_hyp fp') :: locals - end + | Th_addrw (p, ps, lc) -> + let ps = List.filter ((not) |- inclear |- oget |- EcPath.prefix) ps in + if List.is_empty ps then None else Some (Th_addrw (p, ps,lc)) - | [] -> error (LookupError (`Ident x)) - | ld :: locals -> ld :: (doit locals) + | Th_auto ({ axioms } as auto_rl) -> + let axioms = List.filter (fun (p, _) -> + let p = oget (EcPath.prefix p) in + not (inclear p) + ) axioms in + if List.is_empty axioms then None else Some (Th_auto {auto_rl with axioms}) - in (try Some (doit hyps.le_hyps.h_local) with E.NoOp -> None) |> omap init + | (Th_export (p, _)) as item -> + if Sp.mem p cleared then None else Some item - (* ------------------------------------------------------------------ *) - let local_hyps x hyps = - let rec doit locals = - match locals with - | (y, _) :: locals -> - if EcIdent.id_equal x y then locals else doit locals - | [] -> - error (LookupError (`Ident x)) in + | _ as item -> Some item - let locals = doit hyps.le_hyps.h_local in - init hyps.le_init ~locals hyps.le_hyps.h_tvar + in (cleared, item_r) + + in (cleared, omap (fun item_r -> { item with ti_item = item_r; }) item_r) (* ------------------------------------------------------------------ *) - let by_name s hyps = by_name s (tohyps hyps) - let by_id x hyps = by_id x (tohyps hyps) + type clear_mode = [`Full | `ClearOnly | `No] - let has_name s hyps = has_name ~dep:false s (tohyps hyps) - let has_id x hyps = has_id x (tohyps hyps) + let close + ?(clears : path list = []) + ?(pempty : clear_mode = `No) + (loca : is_local) + (mode : thmode) + (env : env) + = + let items = List.rev env.env_item in + let items = + if List.is_empty clears + then (if List.is_empty items then None else Some items) + else snd (filter_th clears (root env) Sp.empty items) in - let hyp_by_name s hyps = hyp_by_name s (tohyps hyps) - let hyp_exists s hyps = hyp_exists s (tohyps hyps) - let hyp_by_id x hyps = snd (hyp_by_id x (tohyps hyps)) + let items = + match items, pempty with + | None, (`No | `ClearOnly) -> Some [] + | _, _ -> items + in - let var_by_name s hyps = var_by_name s (tohyps hyps) - let var_exists s hyps = var_exists s (tohyps hyps) - let var_by_id x hyps = snd (var_by_id x (tohyps hyps)) + items |> omap (fun items -> + let ctheory = + { cth_items = items + ; cth_source = None + ; cth_loca = loca + ; cth_mode = mode + } in - let can_unfold x hyps = can_unfold x (tohyps hyps) - let unfold x hyps = unfold x (tohyps hyps) + let root = env.env_scope.ec_path in + let name = EcPath.basename root in - let fresh_id hyps s = fresh_id (tohyps hyps) s - let fresh_ids hyps s = snd (fresh_ids (tohyps hyps) s) + let compiled = + Mp.filter + (fun path _ -> EcPath.isprefix ~prefix:root ~path) + env.env_thenvs in + let compiled = Mp.add env.env_scope.ec_path env compiled in + + { name; ctheory; compiled; } + ) (* ------------------------------------------------------------------ *) - let push_active_ss m lenv = - { lenv with le_env = Memory.push_active_ss m lenv.le_env } + let require (compiled : compiled_theory) (env : env) = + let cth = compiled.ctheory in + let rootnm = EcCoreLib.p_top in + let thpath = EcPath.pqname rootnm compiled.name in - let push_active_ts ml mr lenv = - { lenv with le_env = Memory.push_active_ts ml mr lenv.le_env } + let env = + match cth.cth_mode with + | `Concrete -> + let (_, thmc), submcs = + MC.mc_of_theory_r rootnm (compiled.name, cth) + in MC.bind_submc env rootnm ((compiled.name, thmc), submcs) - let push_all l lenv = - { lenv with le_env = Memory.push_all l lenv.le_env } + | `Abstract -> env + in - let hoareF mem xp lenv = - let env1, env2 = Fun.hoareF mem xp lenv.le_env in - { lenv with le_env = env1}, {lenv with le_env = env2 } + let topmc = Mip.find (IPPath rootnm) env.env_comps in + let topmc = MC._up_theory false topmc compiled.name (IPPath thpath, cth) in + let topmc = MC._up_mc false topmc (IPPath thpath) in - let equivF ml mr xp1 xp2 lenv = - let env1, env2 = Fun.equivF ml mr xp1 xp2 lenv.le_env in - { lenv with le_env = env1}, {lenv with le_env = env2 } + let current = env.env_current in + let current = MC._up_theory true current compiled.name (IPPath thpath, cth) in + let current = MC._up_mc true current (IPPath thpath) in - let inv_memenv ml mr lenv = - { lenv with le_env = Fun.inv_memenv ml mr lenv.le_env } + let comps = env.env_comps in + let comps = Mip.add (IPPath rootnm) topmc comps in - let inv_memenv1 m lenv = - { lenv with le_env = Fun.inv_memenv1 m lenv.le_env } -end + let env = { env with env_current = current; env_comps = comps; } in + + match cth.cth_mode with + | `Abstract -> + { env with + env_thenvs = Mp.set_union env.env_thenvs compiled.compiled; } + | `Concrete -> + { env with + env_tci = bind_instance_th thpath env.env_tci cth.cth_items; + env_tc = bind_tc_th thpath env.env_tc cth.cth_items; + env_rwbase = bind_br_th thpath env.env_rwbase cth.cth_items; + env_atbase = bind_at_th thpath env.env_atbase cth.cth_items; + env_ntbase = bind_nt_th thpath env.env_ntbase cth.cth_items; + env_redbase = bind_rd_th thpath env.env_redbase cth.cth_items; + env_crbds = bind_cr_th thpath env.env_crbds cth.cth_items; + env_thenvs = Mp.set_union env.env_thenvs compiled.compiled; } +end let pp_debug_form = ref (fun _env _f -> assert false) diff --git a/src/ecEnv.mli b/src/ecEnv.mli index 5a1d5bf602..55ab3b2b0c 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -16,8 +16,26 @@ type 'a suspension = { sp_params : int * (EcIdent.t * module_type) list; } +(* -------------------------------------------------------------------- *) +type crb_tyrev_binding = [ + | `Bitstring of crb_bitstring + | `Array of crb_array +] + +type crb_bitstring_operator = crb_bitstring * [`From | `To | `OfInt | `ToUInt | `ToSInt ] + +type crb_array_operator = crb_array * [`Get | `Set | `ToList | `OfList] + +type crb_oprev_binding = [ + | `Bitstring of crb_bitstring_operator + | `Array of crb_array_operator + | `BvOperator of crb_bvoperator + | `Circuit of crb_circuit +] + (* -------------------------------------------------------------------- *) type env + type scope = [ | `Theory | `Module of EcPath.mpath @@ -515,4 +533,40 @@ module LDecl : sig val inv_memenv1 : memory -> hyps -> hyps end +(* -------------------------------------------------------------------- *) +module Circuit : sig + val bind_bitstring : ?import:bool -> is_local -> crb_bitstring -> env -> env + val bind_array : ?import:bool -> is_local -> crb_array -> env -> env + val bind_bvoperator : ?import:bool -> is_local -> crb_bvoperator -> env -> env + val bind_circuit : ?import:bool -> is_local -> crb_circuit -> env -> env + val bind_crbinding : ?import:bool -> is_local -> crbinding -> env -> env + + val lookup_bitstring : env -> ty -> crb_bitstring option + val lookup_bitstring_path : env -> path -> crb_bitstring option + val lookup_bitstring_size : env -> ty -> int option + val lookup_bitstring_size_path : env -> path -> int option + + val lookup_bvoperator_path : env -> path -> crb_bvoperator option + val lookup_bvoperator : env -> qsymbol -> crb_bvoperator option + + val lookup_array : env -> ty -> crb_array option + val lookup_array_path : env -> path -> crb_array option + val lookup_array_size : env -> ty -> int option + + val lookup_array_and_bitstring : env -> ty -> (crb_array * crb_bitstring) option + + val lookup_circuit : env -> qsymbol -> Lospecs.Ast.adef option + val lookup_circuit_path : env -> path -> Lospecs.Ast.adef option + + val reverse_type : env -> path -> crb_tyrev_binding list + val reverse_operator : env -> path -> crb_oprev_binding list + + val reverse_bitstring_operator : env -> path -> crb_bitstring_operator option + val reverse_array_operator : env -> path -> crb_array_operator option + val reverse_bvoperator : env -> path -> crb_bvoperator option + val reverse_circuit : env -> path -> crb_circuit option + + val get_specification_by_name : env -> filename:string -> symbol -> Lospecs.Ast.adef option +end + val pp_debug_form : (env -> form -> unit) ref diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index a51dede082..981fca12d1 100644 --- a/src/ecHiInductive.ml +++ b/src/ecHiInductive.ml @@ -83,9 +83,10 @@ let trans_datatype (env : EcEnv.env) (name : ptydname) (dt : pdatatype) = let tpath = EcPath.pqname (EcEnv.root env) (unloc name) in let env0 = let myself = { - tyd_params = EcUnify.UniEnv.tparams ue; - tyd_type = `Abstract EcPath.Sp.empty; - tyd_loca = lc; + tyd_params = EcUnify.UniEnv.tparams ue; + tyd_type = `Abstract EcPath.Sp.empty; + tyd_loca = lc; + tyd_clinline = false; } in EcEnv.Ty.bind (unloc name) myself env in diff --git a/src/ecHiTacticals.ml b/src/ecHiTacticals.ml index 9eb6521e35..eb017cfc61 100644 --- a/src/ecHiTacticals.ml +++ b/src/ecHiTacticals.ml @@ -53,6 +53,12 @@ and process1_or (ttenv : ttenv) (t1 : ptactic) (t2 : ptactic) (tc : tcenv1) = and process1_try (ttenv : ttenv) (t : ptactic_core) (tc : tcenv1) = FApi.t_try (process1_core ttenv t) tc +(* -------------------------------------------------------------------- *) +(* FIXME: Maybe move the extens tactic to this file as well? *) +and process1_extens (ttenv : ttenv) ((t, v) : ptactic_core * psymbol option) (tc : tcenv1) = + let v = Option.map unloc v in + EcPhlBDep.t_extens v (process1_core ttenv t) tc + (* -------------------------------------------------------------------- *) and process1_admit (_ : ttenv) (tc : tcenv1) = EcLowGoal.t_admit tc @@ -231,7 +237,9 @@ and process1_phl (_ : ttenv) (t : phltactic located) (tc : tcenv1) = | Plossless -> EcPhlHiAuto.t_lossless | Prepl_stmt infos -> EcPhlTrans.process_equiv_trans infos | Pprocrewrite (s, p, f) -> EcPhlRewrite.process_rewrite s p f - | Pchangestmt (s, p, c) -> EcPhlRewrite.process_change_stmt s p c + | Pchangestmt (s, b, p, c) -> EcPhlRewrite.process_change_stmt s b p c + | Pcircuit `Solve -> EcPhlBDep.t_bdep_solve + | Pcircuit `Simplify -> EcPhlBDep.t_bdep_simplify | Prwprgm infos -> EcPhlRwPrgm.process_rw_prgm infos in @@ -318,6 +326,7 @@ and process_core (ttenv : ttenv) ({ pl_loc = loc } as t : ptactic_core) (tc : tc | Psolve t -> `One (process1_solve ttenv t) | Pdo ((b, n), t) -> `One (process1_do ttenv (b, n) t) | Ptry t -> `One (process1_try ttenv t) + | Pextens (t, v) -> `One (process1_extens ttenv (t, v)) | Por (t1, t2) -> `One (process1_or ttenv t1 t2) | Pseq ts -> `One (process1_seq ttenv ts) | Pcase es -> `One (process1_case ttenv es) diff --git a/src/ecLexer.mll b/src/ecLexer.mll index 19536eaae7..1efc179b78 100644 --- a/src/ecLexer.mll +++ b/src/ecLexer.mll @@ -68,6 +68,7 @@ "last" , LAST ; (* KW: tactical *) "do" , DO ; (* KW: tactical *) "expect" , EXPECT ; (* KW: tactical *) + "extens" , EXTENS ; (* KW: tactical *) (* Lambda tactics *) "beta" , BETA ; (* KW: tactic *) @@ -168,7 +169,11 @@ "splitwhile" , SPLITWHILE ; (* KW: tactic *) "kill" , KILL ; (* KW: tactic *) "eager" , EAGER ; (* KW: tactic *) - + + "array" , ARRAY ; (* KW: global *) + "bind" , BIND ; (* KW: global *) + "circuit" , CIRCUIT ; (* KW: global *) + "bitstring" , BITSTRING ; (* KW: global *) "axiom" , AXIOM ; (* KW: global *) "axiomatized" , AXIOMATIZED; (* KW: global *) "lemma" , LEMMA ; (* KW: global *) diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml new file mode 100644 index 0000000000..d96b28cbac --- /dev/null +++ b/src/ecLowCircuits.ml @@ -0,0 +1,1807 @@ +open EcBigInt +open EcUtils +open EcSymbols +open EcDecl +open EcIdent +open EcMemory + +(* -------------------------------------------------------------------- *) +module C = struct + include Lospecs.Aig + include Lospecs.Circuit + include Lospecs.Circuit_spec +end + +module CDeps = struct + include Lospecs.Deps +end + +module CSMT = struct + include Lospecs.Smt +end + +module Map = Batteries.Map +module Hashtbl = Batteries.Hashtbl +module Set = Batteries.Set +module Option = Batteries.Option + +exception CircError of string + +let debug : bool = true + +(* Backend implementing minimal functions needed for the translation *) +(* Minimal expected functionality is QF_ABV *) +(* Input are: some identifier + some bit *) +module type CBackend = sig + type node (* Corresponds to a single output node *) + type reg + (* Id + offset, both assumed starting at 0 *) + type inp = int * int + + val pp_node : Format.formatter -> node -> unit + + exception NonConstantCircuit (* FIXME: Rename later *) + exception GetOutOfRange (* FIXME: Do we even need this? *) + exception BadSlice of [`Get | `Set] + + val true_ : node + val false_ : node + + val nodes_eq : node -> node -> bool + + val bad : node + val bad_reg : int -> reg + val has_bad : node -> bool + val have_bad : reg -> int option + + val node_array_of_reg : reg -> node array + val node_list_of_reg : reg -> node list + val reg_of_node_list : node list -> reg + val reg_of_node_array : node array -> reg + val reg_of_node : node -> reg + val node_of_reg : reg -> node + + val input_node : id:int -> int -> node + val input_of_size : ?offset:int -> id:int -> int -> reg + + val reg_of_zint : size:int -> zint -> reg + val bool_array_of_reg : reg -> bool array + val bool_list_of_reg : reg -> bool list + val szint_of_reg : reg -> zint + val uzint_of_reg : reg -> zint + val size_of_reg : reg -> int + + val apply : (inp -> node option) -> node -> node + val applys : (inp -> node option) -> reg -> reg + val circuit_from_spec : Lospecs.Ast.adef -> reg list -> reg + val equiv : ?inps:inp list -> pcond:node -> reg -> reg -> bool + val sat : ?inps:inp list -> node -> bool + val taut : ?inps:inp list -> node -> bool + + val slice : reg -> int -> int -> reg + val subcirc : reg -> (int list) -> reg + val insert : reg -> int -> reg -> reg + val get : reg -> int -> node + val permute : int -> (int -> int) -> reg -> reg + + val node_eq : node -> node -> node + val reg_eq : reg -> reg -> node + val node_ite : node -> node -> node -> node + val reg_ite : node -> reg -> reg -> reg + + val band : node -> node -> node + val bor : node -> node -> node + val bxor : node -> node -> node + val bnot : node -> node + val bxnor : node -> node -> node + val bnand : node -> node -> node + val bnor : node -> node -> node + + (* SMTLib Base Operations *) + (* FIXME: decide if boolean ops are going to be defined + on registers or on nodes *) + val add : reg -> reg -> reg + val sub : reg -> reg -> reg + val opp : reg -> reg + val mul : reg -> reg -> reg + val udiv : reg -> reg -> reg + val sdiv : reg -> reg -> reg + val umod : reg -> reg -> reg (* FIXME: mod or rem here? *) + val smod : reg -> reg -> reg + val lshl : reg -> reg -> reg + val lshr : reg -> reg -> reg + val ashr : reg -> reg -> reg + val rol : reg -> reg -> reg + val ror : reg -> reg -> reg + val land_ : reg -> reg -> reg + val lor_ : reg -> reg -> reg + val lxor_ : reg -> reg -> reg + val lnot_ : reg -> reg + val ult: reg -> reg -> node + val slt : reg -> reg -> node + val ule : reg -> reg -> node + val sle : reg -> reg -> node + val uext : reg -> int -> reg + val sext : reg -> int -> reg + val trunc : reg -> int -> reg + val concat : reg -> reg -> reg + + val flatten : reg list -> reg + + val reg_to_file : input_count:int -> ?inp_name_map:(int -> string) -> name:string -> reg -> symbol + + module Deps : sig + type dep = (int, int Set.t) Map.t + type deps = dep array + type block_deps + + val dep_of_node : node -> dep + val deps_of_reg : reg -> deps + val block_deps_of_deps : int -> deps -> block_deps + val block_deps_of_reg : int -> reg -> block_deps + + val pp_dep : Format.formatter -> dep -> unit + val pp_deps : Format.formatter -> deps -> unit + val pp_block_deps : Format.formatter -> block_deps -> unit + + val dep_var_count : deps -> int + (* Assumes single_dep *) + val dep_ranges : deps -> (int, int * int) Map.t + (* Checks if first dep is a subset of second dep *) + val dep_contained : dep -> dep -> bool + (* Checks if two dep sets are equal *) + val deps_equal : dep -> dep -> bool + (* Checks if two dep sets intersect *) + val deps_intersect : dep -> dep -> bool + (* Checks if all the deps are in a given list of inputs *) + val check_inputs : reg -> (int * int) list -> bool + + val forall_inputs : (int -> int -> bool) -> reg -> bool + val rename_inputs : ((int * int) -> (int * int) option) -> reg -> reg + (* TODO: Rename *) + val excise_bit : ?renamings:(int -> int option) -> node -> node * (int, int * int) Map.t + end +end + +module LospecsBack : CBackend = struct + type node = C.node + type reg = C.node array + type inp = int * int + + let pp_node (fmt : Format.formatter) (n: node) = + Format.fprintf fmt "%a" (fun fmt -> Lospecs.Aig.pp_node fmt) n + + exception NonConstantCircuit (* FIXME: Rename later *) + exception GetOutOfRange (* FIXME: Do we even need this? *) + exception BadSlice of [`Get | `Set] + + let true_ = C.true_ + let false_ = C.false_ + let nodes_eq ({id=id1; _}: node) ({id=id2; _}: node) = id1 = id2 + let size_of_reg = Array.length + let bad = C.input (-1, -1) + let bad_reg = fun i -> Array.make i bad + let has_bad : node -> bool = + let cache : (int, bool) Hashtbl.t = Hashtbl.create 0 in + let rec doit (n: node) : bool = + match Hashtbl.find_option cache (Int.abs n.id) with + | Some b -> b + | None -> let b = doit_r n.gate in + Hashtbl.add cache (Int.abs n.id) b; + b + and doit_r (n: C.node_r) : bool = + match n with + | C.Input (-1, -1) -> true + | C.Input _ + | C.False -> false + | C.And (n1, n2) -> (doit n1) || (doit n2) + in + fun b -> doit b + + let have_bad (r: reg) : int option = + Array.find_opt (fun (_, r) -> has_bad r) (Array.mapi (fun i r -> (i,r)) r) |> Option.map fst + + let node_array_of_reg : reg -> node array = fun x -> x + + let node_list_of_reg : reg -> node list = fun x -> Array.to_list x + + let reg_of_node_list : node list -> reg = fun x -> Array.of_list x + + let reg_of_node_array : node array -> reg = fun x -> x + + let reg_of_node : node -> reg = fun x -> [| x |] + (* FIXME: throws array error, error handling TODO + Maybe leave as is? This throwing is a programming error + not a user error + *) + let node_of_reg : reg -> node = fun x -> x.(0) + + let reg_of_zint ~(size: int) (v: zint) : reg = + C.of_bigint_all ~size (to_zt v) + + let bool_array_of_reg (r: reg) : bool array = + C.bools_of_reg r + + let bool_list_of_reg (r: reg) = + C.bool_list_of_reg r + + let szint_of_reg (r: reg) : zint = + C.bools_of_reg r |> C.sbigint_of_bools |> of_zt + + let uzint_of_reg (r: reg) : zint = + C.bools_of_reg r |> C.ubigint_of_bools |> of_zt + + let node_eq (n1: node) (n2: node) = C.xnor n1 n2 + let reg_eq (r1: reg) (r2: reg) = + Array.fold (fun acc r -> + C.and_ acc r) + C.true_ + (Array.map2 node_eq r1 r2) + let node_ite (c: node) (t: node) (f: node) = C.mux2 f t c + let reg_ite (c: node) = Array.map2 (node_ite c) + + let equiv ?(inps: inp list option) ~(pcond: node) (r1: reg) (r2: reg) : bool = + let open CSMT in + let module BWZ = (val makeBWZinterface ()) in + BWZ.circ_equiv ?inps r1 r2 pcond + + let sat ?(inps: inp list option) (n: node) : bool = + let open CSMT in + let module BWZ = (val makeBWZinterface ()) in + BWZ.circ_sat ?inps n + + let taut ?(inps: inp list option) (n: node) : bool = + let open CSMT in + let module BWZ = (val makeBWZinterface ()) in + BWZ.circ_taut ?inps n + + let slice (r: reg) (idx: int) (len: int) : reg = + try Array.sub r idx len + with Invalid_argument _ -> + raise (BadSlice `Get) + + let subcirc (r: reg) (outs: int list) : reg = + try + List.map (fun i -> r.(i)) outs |> Array.of_list + with Invalid_argument _ -> + raise (BadSlice `Get) + + let insert (r: reg) (idx: int) (r_in: reg) : reg = + try + let ret = Array.copy r in + Array.blit r_in 0 ret idx (Array.length r_in); + ret + with Invalid_argument _ -> + raise (BadSlice `Set) + + (* FIXME: Error handling *) + let get (r: reg) (idx: int) = + try + r.(idx) + with Invalid_argument _ -> + raise GetOutOfRange + + let permute (w: int) (perm: int -> int) (r: reg) : reg = + if debug then Format.eprintf "Applying permutation to reg of size %d with block size of %d@." (size_of_reg r) w; + Array.init (size_of_reg r) (fun i -> + let block_idx, bit_idx = perm (i / w), (i mod w) in + if block_idx < 0 then None + else + let idx = block_idx*w + bit_idx in + try + Some r.(idx) + with Invalid_argument _ -> + raise GetOutOfRange + ) |> Array.filter_map (fun x -> x) + + + (* Node operations *) + let band : node -> node -> node = C.and_ + let bor : node -> node -> node = C.or_ + let bxor : node -> node -> node = C.xor + let bnot : node -> node = C.neg + let bxnor : node -> node -> node = C.xnor + let bnand : node -> node -> node = C.nand + let bnor : node -> node -> node = fun n1 n2 -> C.neg @@ C.or_ n1 n2 + + (* FIXME: maybe convert to BigInt? *) + let input_node ~id i = C.input (id, i) + let input_of_size ?(offset = 0) ~id (i: int) = Array.init i (fun i -> C.input (id, offset + i)) + + let apply (map_: inp -> node option) (n: node) : node= + C.map map_ n + + let applys (map_: inp -> node option) : reg -> reg = + fun r -> Array.map (C.map map_) r + + let circuit_from_spec (def: Lospecs.Ast.adef) (args: reg list) : reg = + C.circuit_of_specification args def + + (* SMTLib Base Ops *) + let add (r1: reg) (r2: reg) : reg = C.add_dropc r1 r2 + let sub (r1: reg) (r2: reg) : reg = C.sub_dropc r1 r2 + let opp (r: reg) : reg = C.opp r + let mul (r1: reg) (r2: reg) : reg = C.umull r1 r2 + let udiv (r1: reg) (r2: reg) : reg = C.udiv r1 r2 + let sdiv (r1: reg) (r2: reg) : reg = C.sdiv r1 r2 + (* FIXME: mod or rem here? *) + let umod (r1: reg) (r2: reg) : reg = C.umod r1 r2 + let smod (r1: reg) (r2: reg) : reg = C.smod r1 r2 + let lshl (r1: reg) (r2: reg) : reg = C.shift ~side:`L ~sign:`L r1 r2 + let lshr (r1: reg) (r2: reg) : reg = C.shift ~side:`R ~sign:`L r1 r2 + let ashr (r1: reg) (r2: reg) : reg = C.shift ~side:`R ~sign:`A r1 r2 + let rol (r1: reg) (r2: reg) : reg = C.rol r1 r2 + let ror (r1: reg) (r2: reg) : reg = C.ror r1 r2 + let land_ (r1: reg) (r2: reg) : reg = C.land_ r1 r2 + let lor_ (r1: reg) (r2: reg) : reg = C.lor_ r1 r2 + let lxor_ (r1: reg) (r2: reg) : reg = C.lxor_ r1 r2 + let lnot_ (r1: reg) : reg = C.lnot_ r1 + let ult (r1: reg) (r2: reg) : node = C.ugt r2 r1 + let slt (r1: reg) (r2: reg) : node = C.sgt r2 r1 + let ule (r1: reg) (r2: reg) : node = C.uge r2 r1 + let sle (r1: reg) (r2: reg) : node = C.sge r2 r1 + let uext (r1: reg) (size: int) : reg = C.uextend ~size r1 + let sext (r1: reg) (size: int) : reg = C.sextend ~size r1 + let trunc (r1: reg) (size: int) : reg = Array.sub r1 0 size + let concat (r1: reg) (r2: reg) : reg = Array.append r1 r2 + let flatten (rs: reg list) : reg = Array.concat rs + + let reg_to_file ~(input_count: int) ?(inp_name_map: (int -> string) option) ~(name: string) (r: reg) : symbol = + C.write_aiger_bin_temp ~input_count ?inp_name_map ~name r + + module Deps = struct + type dep = (int, int Set.t) Map.t + type deps = dep array + type block_deps = (int * dep) array + + let dep_of_node = fun n -> CDeps.dep n + let deps_of_reg = fun r -> CDeps.deps r + let block_deps_of_deps (w: int) (d: deps) : block_deps = + assert (Array.length d mod w = 0); + Array.init (Array.length d / w) (fun i -> + let deps = Array.sub d (i*w) w in + let block = Array.fold_left (fun acc m -> + Map.merge (fun _idx d1 d2 -> + match d1, d2 with + | None, None -> None + | None, Some d | Some d, None -> Some d + | Some d1, Some d2 -> Some (Set.union d1 d2) + ) acc m) Map.empty deps in + (w, block) + ) + + let block_deps_of_reg (w: int) (r: reg) : block_deps = + let deps = deps_of_reg r in + block_deps_of_deps w deps + + let pp_dep (fmt: Format.formatter) (d: dep) : unit = + Map.iter (fun id bits -> + Format.fprintf fmt "%d: " id; + Set.iter (fun bit -> Format.fprintf fmt "%d " bit) bits; + Format.fprintf fmt "@\n" + ) d + + let pp_deps (fmt: Format.formatter) (d: deps) : unit = + Array.iteri (fun i d -> + Format.fprintf fmt "@[[%d]:@\n%a@]@\n" i + pp_dep d + ) d + + let pp_block_deps (fmt: Format.formatter) (bd: block_deps) : unit = + ignore @@ Array.fold_left (fun idx (w, d) -> + Format.fprintf fmt "@[[%d..%d]:@\n%a@]@\n" idx (idx + w - 1) + pp_dep d; + idx + w + ) 0 bd + + (* FIXME: Some of these are unused as of now, but they seem useful + as part of the library, do we keep them? *) + let dep_var_count (d: deps) : int = + Set.cardinal + (Array.fold_left (Set.union) Set.empty + (Array.map (fun dep -> Map.keys dep |> Set.of_enum) d)) + + let merge_deps (d: deps) : dep = + match Array.length d with + | 0 -> Map.empty + | _ -> Array.reduce (CDeps.merge_deps) d + + (* Assumes single_dep, returns range (bot, top) such that valid idxs are bot <= i < top *) + let dep_ranges (d: deps) : (int, int * int) Map.t = + let d = merge_deps d in + Map.map (fun ds -> (Set.min_elt_opt ds |> Option.default (-1), + Set.max_elt_opt ds |> Option.default (-1))) d + + (* Checks that all dependencies of r are in the set inps *) + (* Each elements of inps is (id, width) *) + let check_inputs (r: reg) (inps: (int * int) list) : bool = + let ds = deps_of_reg r in + Array.for_all (fun d -> + Map.for_all (fun id b -> + match List.find_opt (fun (id_, _) -> id = id_) inps with + | Some (_, b_) -> Set.for_all (fun b -> 0 <= b && b < b_) b + | None -> false + ) d + ) ds + + (* Checks if the first argument dependencies are contained in the second *) + let dep_contained (subd: dep) (superd: dep) : bool = + Map.for_all (fun id bits -> + match Map.find_opt id superd with + | None -> false + | Some superbits -> Set.subset bits superbits + ) subd + + let deps_equal (d1: dep) (d2: dep) : bool = + (Map.equal (Set.equal) d1 d2) + + let deps_intersect (d1: dep) (d2: dep) : bool = + not @@ Map.for_all (fun id bits1 -> + match Map.find_opt id d2 with + | None -> true + | Some bits2 -> Set.is_empty @@ Set.intersect bits1 bits2) d1 + + let forall_inputs (check: int -> int -> bool) (r: reg) : bool = + let d = deps_of_reg r in + Array.for_all (fun d -> + Map.for_all (fun id bs -> Set.for_all (check id) bs) d) + d + + let rename_inputs (renamer: (int * int) -> (int * int) option) (r: reg) : reg = + C.maps (fun (id, b) -> + Option.map (fun (id, b) -> input_node ~id b) (renamer (id, b)) + ) r + + let excise_bit ?renamings (n: node) : node * (int, int * int) Map.t = + CDeps.realign_inputs ?renamings n + end +end + +module type CircuitInterface = sig + type flatcirc + type ctype = + CArray of {width: int; count: int} + | CBitstring of int + | CTuple of ctype list + | CBool + type cinp = { + type_ : ctype; + id: int + } + type circ = { + reg: flatcirc ; + type_: ctype ; + } + type 'a cfun = 'a * (cinp list) + type circuit = circ cfun + + val pp_flatcirc : Format.formatter -> flatcirc -> unit + + module CArgs : sig + type arg = + [ `Circuit of circuit + | `Constant of zint + | `Init of int -> circuit + | `List of circuit list ] + + val arg_of_circuit : circuit -> arg + val arg_of_zint : zint -> arg + val arg_of_circuits : circuit list -> arg + val arg_of_init : (int -> circuit) -> arg + val pp_arg : Format.formatter -> arg -> unit + end + open CArgs + + module TranslationState : sig + type state + + val empty_state : state + + val update_state_pv : state -> memory -> symbol -> circuit -> state + val state_get_pv_opt : state -> memory -> symbol -> circuit option + val state_get_pv : state -> memory -> symbol -> circuit + val state_get_all_memory : state -> memory -> (symbol * circuit) list + val state_get_all_pv : state -> ((memory * symbol) * circuit) list + + val update_state : state -> ident -> circuit -> state + val state_get_opt : state -> ident -> circuit option + val state_get : state -> ident -> circuit + val state_bindings : state -> (ident * circuit) list + val state_lambdas : state -> cinp list + val state_is_closed : state -> bool + val state_close_circuit : state -> circuit -> circuit + val map_state_var : (ident -> circuit -> circuit) -> state -> state + + (* Circuit lambdas, for managing inputs *) + val open_circ_lambda : state -> (ident * ctype) list -> state + val open_circ_lambda_pv : state -> ((memory * symbol) * ctype) list -> state + val close_circ_lambda : state -> state + val circ_lambda_oneshot : state -> (ident * ctype) list -> (state -> circuit) -> circuit (* FIXME: rename or redo *) + end + + module BVOps : sig + val circuit_of_bvop : EcDecl.crb_bvoperator -> circuit + val circuit_of_parametric_bvop : EcDecl.crb_bvoperator -> arg list -> circuit + end + + module ArrayOps : sig + val array_get : circuit -> int -> circuit + val array_set : circuit -> int -> circuit -> circuit + val array_oflist : circuit list -> circuit -> int -> circuit + end + + (* Circuit type utilities *) + val size_of_ctype : ctype -> int + val convert_type : ctype -> circuit -> circuit + val can_convert_input_type : ctype -> ctype -> bool + + (* Pretty Printers *) + val pp_ctype : Format.formatter -> ctype -> unit + val pp_cinp : Format.formatter -> cinp -> unit + val pp_circ : Format.formatter -> circ -> unit + val pp_circuit : Format.formatter -> circuit -> unit + + (* General utilities *) + val circ_of_zint : size:int -> zint -> circ + val circuit_of_zint : size:int -> zint -> circuit + + (* Type constructors *) + val new_cbool_inp : ?name:[`Str of string | `Idn of ident] -> unit -> circ * cinp + val new_cbitstring_inp : ?name:[`Str of string | `Idn of ident] -> int -> circ * cinp + val new_carray_inp : ?name:[`Str of string | `Idn of ident] -> int -> int -> circ * cinp + val new_ctuple_inp : ?name:[`Str of string | `Idn of ident] -> ctype list -> circ * cinp + + (* Construct an input *) + val input_of_ctype : ?name:[`Str of string | `Idn of ident | `Bad] -> ctype -> circuit + + (* Aggregation functions *) + val circuit_aggregate : circuit list -> circuit + val circuit_aggregate_inputs : circuit -> circuit + + (* Circuits representing booleans *) + val circuit_true : circuit + val circuit_false : circuit + val circuit_and : circuit -> circuit -> circuit + val circuit_or : circuit -> circuit -> circuit + val circuit_not : circuit -> circuit + + (* <=> circuit has not inputs (every input is unbound) *) + val circuit_is_free : circuit -> bool + + (* Direct circuuit constructions *) + val circuit_ite : ?strict:bool -> c:circuit -> t:circuit -> f:circuit -> circuit + val circuit_eq : circuit -> circuit -> circuit + val circuit_eqs : circuit -> circuit -> circuit list + + + (* Circuit tuples *) + val circuit_tuple_proj : circuit -> int -> circuit + val circuit_tuple_of_circuits : circuit list -> circuit + val circuits_of_circuit_tuple : circuit -> circuit list + + (* Avoid nodes for uninitialized inputs *) + val circuit_uninit : ctype -> circuit + val circuit_has_uninitialized : circuit -> int option + + (* Logical reasoning over circuits *) + val circ_equiv : ?pcond:circuit -> circuit -> circuit -> bool + val circ_sat : circuit -> bool + val circ_taut : circuit -> bool + + (* Composition of circuit functions, should deal with inputs and call some backend *) + val circuit_compose : circuit -> circuit list -> circuit + + (* Computing the function given by a circuit *) + val compute : sign:bool -> circuit -> arg list -> zint option + + (* Mapreduce/Dependecy analysis related functions *) + val circuit_slice : size:int -> circuit -> int -> circuit + val circuit_slice_insert : circuit -> int -> circuit -> circuit + val fillet_circuit : circuit -> circuit list + val fillet_tauts : ?mode:[`Seq | `Quad] -> circuit list -> circuit list -> bool + val batch_checks : ?sort:bool -> ?mode:[`ByEq | `BySub ] -> circuit list -> circuit list + + (* Wraps the backend call to deal with args/inputs *) + val circuit_to_file : name:string -> circuit -> symbol + + val circuit_from_spec : ?name:symbol -> (ctype list * ctype) -> Lospecs.Ast.adef -> circuit +end + +module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = struct + (* Module Types *) + type flatcirc = Backend.reg + type width = int + type count = int + type ctype = + CArray of {width: int; count: int; } + | CBitstring of width + | CTuple of ctype list + | CBool + type circ = { + reg: flatcirc; + type_: ctype; +} + type cinp = { + type_ : ctype; + id : int; + } + type 'a cfun = 'a * (cinp list) + type circuit = circ cfun + + (* Exceptions *) + exception MissingPVFromState (* FIXME: Do we keep? if so rename *) + exception CircInputUnificationFailure of (cinp * cinp) + exception CircTyConversionFailure + exception CircConstructorInvalidArguments + (* FIXME : Might signal a programming mistake? *) + (* FIXME : Might be guarded by EC typechecking *) + (* FIXME : Might need a parameter to specify case *) + + + exception CircComposeInvalidArguments + exception CircComposeBadNumberOfArguments + exception CircEquivNonBoolPCond + exception CircSmtNonBoolCirc + exception CircComputeBadNumberOfArguments + exception CircComputeInvalidArguments + exception UnsupportedTypeForFileOutput + + (* Helper functions *) + let (|->) ((a,b)) ((f,g)) = (f a, g b) + let idnt = fun x -> x + + let pp_flatcirc fmt fc = + let r = Backend.node_list_of_reg fc in + List.iter (fun n -> + Format.fprintf fmt "%a@." Backend.pp_node n + ) r + + let circ_of_zint ~(size: int) (i: zint) : circ = + {reg = Backend.reg_of_zint ~size i; type_= CBitstring size } + + let circuit_of_zint ~(size: int) (i: zint) : circuit = + ((circ_of_zint ~size i, []) :> circuit) + + let rec size_of_ctype (t: ctype) : int = + match t with + | CBitstring n -> n + | CArray {width; count} -> width * count + | CTuple tys -> List.sum (List.map size_of_ctype tys) + | CBool -> 1 + + (* Pretty printers *) + let rec pp_ctype (fmt: Format.formatter) (t: ctype) : unit = + match t with + | CArray {width; count} -> Format.fprintf fmt "Array(%d@%d)" count width + | CBool -> Format.fprintf fmt "Bool" + | CTuple szs -> Format.fprintf fmt "Tuple(%a)" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.pp_print_string fmt ", ") pp_ctype) szs + | CBitstring w -> Format.fprintf fmt "Bitstring@%d" w + + let pp_cinp (fmt: Format.formatter) (inp: cinp) : unit = + Format.fprintf fmt "Input(id: %d, type = %a)" inp.id pp_ctype inp.type_ + + let pp_circ (fmt : Format.formatter) (c: circ) : unit = + Format.fprintf fmt "Circ(%a)" pp_ctype c.type_ + + let pp_circuit (fmt: Format.formatter) ((c, inps) : circuit) : unit = + Format.fprintf fmt "@[Circuit:@\nOut type %a@\nInputs: %a@]" + pp_circ c + (fun fmt inps -> List.iter (fun inp -> Format.fprintf fmt "%a@\n" pp_cinp inp) inps) inps + + (* arg for circuit construction *) + module CArgs = struct + type arg = + [ `Circuit of circuit + | `Constant of zint + | `Init of int -> circuit + | `List of circuit list ] + let arg_of_circuit c = + `Circuit c + let arg_of_zint z = + `Constant z + let arg_of_circuits cs = + `List cs + let arg_of_init f = + `Init f + let pp_arg fmt arg : unit = + match arg with + | `Circuit c -> Format.fprintf fmt "%a" pp_circuit c + | `Constant i -> Format.fprintf fmt "Constant: %s" (to_string i) + | `Init f -> Format.fprintf fmt "Init: Type of f(0): %a" pp_circuit (f 0) + | `List cs -> Format.fprintf fmt "@[ Circuit list: @\n%a@]" + (fun fmt cs -> List.iter (Format.fprintf fmt "%a@\n" pp_circuit) cs) cs + end + open CArgs + + module TranslationState = struct + type state = { + circs : circuit Mid.t; + lambdas : cinp list list; (* actually a stack *) + pv_ids : (ident * symbol, ident) Map.t; (* can be changed to int Msym.t if needed *) + } + + let empty_state : state = { + circs = Mid.empty; + lambdas = []; + pv_ids = Map.empty; (* can be changed to int Msym.t if needed *) + } + + let update_state_pv (st: state) (m: memory) (s: symbol) (c: circuit) : state = + match Map.find_opt (m, s) st.pv_ids with + | Some id -> {st with circs = Mid.add id c st.circs} + | None -> let id = EcIdent.create s in + { st with + pv_ids = Map.add (m, s) id st.pv_ids; + circs = Mid.add id c st.circs } + + let state_get_pv_opt (st: state) (m:memory) (s: symbol) : circuit option = + Option.bind (Map.find_opt (m, s) st.pv_ids) (fun id -> Mid.find_opt id st.circs) + + (* FIXME : Error handling *) + let state_get_pv (st: state) (m: memory) (pv: symbol) : circuit = + match state_get_pv_opt st m pv with + | Some circ -> circ + | None -> raise MissingPVFromState + + let state_get_all_pv (st: state) : ((memory * symbol) * circuit) list = + let pvs = Map.bindings st.pv_ids in + List.filter_map (fun (pv, id) -> match Mid.find_opt id st.circs with | None -> None | Some c -> Some (pv, c)) pvs + + let state_get_all_memory (st: state) (m: memory) : (symbol * circuit) list = + List.filter_map (fun ((m_, s), c) -> if m = m_ then Some (s, c) else None) + (state_get_all_pv st) + + let update_state (st: state) (id: ident) (c: circuit) : state = + { st with circs = Mid.add id c st.circs } + + let state_get_opt (st: state) (id: ident) : circuit option = Mid.find_opt id st.circs + let state_get (st: state) (id: ident) : circuit = Mid.find id st.circs + let state_bindings (st: state) : (ident * circuit) list = Mid.bindings st.circs + let state_lambdas (st: state) : cinp list = st.lambdas |> List.rev |> List.flatten + let state_is_closed (st: state) : bool = List.is_empty st.lambdas + let state_close_circuit (st: state) ((c, inps): circuit) : circuit = + c, List.fold_left (fun inps lamb -> lamb @ inps) inps st.lambdas + + let map_state_var (f: (ident -> circuit -> circuit)) (st: state) : state = + {st with circs = Mid.mapi f st.circs} + + let cinput_of_type (name: [`Idn of ident | `Str of string]) (t: ctype) : cinp * circuit = + let name = match name with + | `Idn id -> id + | `Str s -> EcIdent.create s + in + { id = name.id_tag; type_ = t}, + ({ reg = Backend.input_of_size ~id:name.id_tag (size_of_ctype t); type_ = t}, []) + + (* Circuit lambdas, for managing inputs *) + let open_circ_lambda (st: state) (bnds: (ident * ctype) list) : state = + let inps, cs = List.map (fun (id, t) -> + if debug then Format.eprintf "Opening circuit lambda for ident: (%s, %d)@." (name id) (tag id); + let inp, c = cinput_of_type (`Idn id) t + in inp, (id, c)) bnds |> List.split in + {st with + lambdas = inps::st.lambdas; + circs = List.fold_left (fun circs (id, c) -> Mid.add id c circs) st.circs cs } + + let open_circ_lambda_pv (st: state) (bnds : ((memory * symbol) * ctype) list) : state = + let st, bnds = List.fold_left_map (fun st ((m, s), t) -> + match Map.find_opt (m, s) st.pv_ids with + | Some id -> st, (id, t) + | None -> let id = EcIdent.create s in + { st with pv_ids = Map.add (m, s) id st.pv_ids}, (id, t)) st bnds + in open_circ_lambda st bnds + + (* FIXME: should we remove id from the mapping? *) + let close_circ_lambda (st: state) : state = + match st.lambdas with + | [] -> raise (CircError "no lambda to close in state") + | inps::lambdas -> + {st with lambdas = lambdas; + circs = Mid.map (fun (c, cinps) -> (c, inps @ cinps)) st.circs } + + (* FIXME: Rename. *) + let circ_lambda_oneshot (st: state) (bnds : (ident * ctype) list) (c: state -> circuit) : circuit = + let st' = open_circ_lambda st bnds in + let (c, inps) = c st' in + (c, (List.hd st'.lambdas) @ inps) + end + + (* Inputs helper functions *) + (* FIXME: maybe do something a bit more principled here ? *) + let merge_inputs (cs: cinp list) (ds: cinp list) : cinp list = +(* if List.for_all2 (fun {id=id1; type_=ct1} {id=id2; type_=ct2} -> id1 = id2 && ct1 = ct2) cs ds then cs *) + if cs = ds then cs + else cs @ ds + + let merge_inputs_list (cs: cinp list list) : cinp list = + List.fold_right (merge_inputs) cs [] + + let merge_circuit_inputs (c: circuit) (d: circuit) : cinp list = + merge_inputs (snd c) (snd d) + + let unify_inputs_renamer (target: cinp list) (inps: cinp list) : Backend.inp -> Backend.node option = + let map = List.fold_left2 (fun map inp1 inp2 -> match inp1, inp2 with + | {type_ = CBitstring w ; id=id_tgt}, + {type_ = CBitstring w'; id=id_orig} when w = w' -> + List.fold_left (fun map i -> Map.add (id_orig, i) (Backend.input_node ~id:id_tgt i) map) + map (List.init w (fun i -> i)) + | {type_ = CArray {width=w; count=n}; id=id_tgt}, + {type_ = CArray {width=w'; count=n'}; id=id_orig} when w = w' && n = n' -> + List.fold_left (fun map i -> Map.add (id_orig, i) (Backend.input_node ~id:id_tgt i) map) + map (List.init (w*n) (fun i -> i)) + | {type_ = CTuple tys ; id=id_tgt}, + {type_ = CTuple tys'; id=id_orig} when List.for_all2 (=) tys tys' -> + let w = List.sum (List.map size_of_ctype tys) in + List.fold_left (fun map i -> Map.add (id_orig, i) (Backend.input_node ~id:id_tgt i) map) + map (List.init (w) (fun i -> i)) + | {type_ = CBool; id=id_tgt}, + {type_ = CBool; id=id_orig} -> + Map.add (id_orig, 0) (Backend.input_node ~id:id_tgt 0) map + | _ -> raise (CircInputUnificationFailure (inp1, inp2)) + ) Map.empty target inps in + fun inp -> Map.find_opt inp map + + (* Renames circuit2 inputs to match circuit 1 *) + let unify_inputs (target: cinp list) ((c, inps): circuit) : circ = + let map_ = unify_inputs_renamer target inps in + {c with reg = Backend.applys map_ c.reg} + + let inputs_contained (subi: cinp list) (supi: cinp list) : bool = + List.compare_lengths subi supi < 0 && + List.for_all2 (=) (subi) (List.take (List.length subi) supi) + + let circuit_input_compatible ?(strict = false) ((c, _): circuit) (cinp: cinp) : bool = + match c.type_, cinp with + | CBitstring n, { type_ = CBitstring n' } when n = n' -> true + | CArray {width=w; count=n}, { type_ = CArray {width=w'; count=n'}} when w = w' && n = n' -> true + | CTuple (szs), { type_ = CTuple szs' } when List.all2 (=) szs szs' -> true + | CBool, { type_ = CBool } -> true + | CBool, { type_ = CBitstring 1 } when not strict -> true + | CBitstring 1, { type_ = CBool } when not strict -> true + | _ -> false + + (* Circuit tuples *) + let circuit_tuple_proj (({reg = r; type_= CTuple tys}, inps): circuit) (i: int) = + let idx, ty = List.takedrop i tys in + let ty = List.hd ty in + let idx = List.fold_left (+) 0 (List.map size_of_ctype idx) in + {reg = (Backend.slice r idx (size_of_ctype ty)); type_ = ty}, inps + + let circuit_tuple_of_circuits (cs: circuit list) : circuit = + let tys = (List.map (fun (c : circuit) -> (fst c).type_) cs) in + let circ = Backend.flatten (List.map (fun (c : circuit) -> (fst c).reg) cs) in + let inps = List.snd cs in + {reg = circ; type_= CTuple tys}, merge_inputs_list inps + + let circuits_of_circuit_tuple (({reg= tp; type_=CTuple szs}, tpinps) : circuit) : circuit list = + snd @@ List.fold_left_map + (fun idx ty -> + let sz = (size_of_ctype ty) in + (idx + sz, + ({reg = (Backend.slice tp idx sz); type_ = ty}, tpinps))) + 0 szs + + (* Convert a circuit's output to a given circuit type *) + (* FIXME: rewrite and simplify this *) + let convert_type (t: ctype) (({type_;_} as c, inps) as circ: circuit) : circuit = + match t, type_ with + (* When types are the same, do nothing *) + | (CArray {width=w; count=n}, CArray {width=w'; count=n'}) when w = w' && n = n' -> circ + | (CBitstring n, CBitstring n') when n = n' -> circ + | (CTuple tys, CTuple tys') when List.for_all2 (=) tys tys' -> circ + | (CBool, CBool) -> circ + + (* Bistring => Type conversions *) + | (CArray {width=w; count=n}, CBitstring n') when w * n = n' -> { c with type_ = t }, inps + | (CTuple tys, CBitstring n) when List.sum @@ List.map size_of_ctype tys = n -> { c with type_ = t}, inps + | (CBool, CBitstring 1) -> { c with type_ = t}, inps + + (* Type => Bitstring conversions *) + | (CBitstring n, CArray {width=w'; count=n'}) when n = w' * n' -> { c with type_ = t}, inps + | (CBitstring n, CTuple tys') when n = List.sum @@ List.map size_of_ctype tys' -> { c with type_ = t}, inps + | (CBitstring 1, CBool) -> {c with type_ = t}, inps + + (* Fail on everything else *) + | _ -> + raise CircTyConversionFailure + + let can_convert_input_type (t1: ctype) (t2: ctype) : bool = + size_of_ctype t1 = size_of_ctype t2 + + let convert_input_types ((c, inps) : circuit) (tys: ctype list) : circuit = + c, List.map2 (fun inp ty -> + if can_convert_input_type inp.type_ ty then + { inp with type_ = ty } + else raise CircTyConversionFailure + ) inps tys + + (* Input Helper Functions *) + (* FIXME: maybe change name from inp -> input? *) + let new_cbool_inp ?(name = `Str "input") () : circ * cinp = + let id, inp = match name with + | `Str name -> let id = EcIdent.create name |> tag in + id, Backend.input_node ~id 0 + | `Idn idn -> let id = tag idn in + id, Backend.input_node ~id 0 + | `Bad -> + -1, Backend.bad + in + { reg = Backend.reg_of_node inp; type_= CBool }, { type_ = CBool; id; } + + let new_cbitstring_inp ?(name = `Str "input") (sz: int) : circ * cinp = + let id, r = match name with + | `Str name -> let id = EcIdent.create name |> tag in + id, Backend.input_of_size ~id sz + | `Idn idn -> let id = tag idn in + id, Backend.input_of_size ~id sz + | `Bad -> + -1, Backend.bad_reg sz + in + { reg = r; type_ = CBitstring sz}, + { type_ = CBitstring sz; id; } + + let new_cbitstring_inp_reg ?name (sz: int) : flatcirc * cinp = + let c, inp = new_cbitstring_inp ?name sz in + (c.reg, inp) + + let new_carray_inp ?(name = `Str "input") (el_sz: int) (arr_sz: int) : circ * cinp = + let id, arr = match name with + | `Str name -> let id = EcIdent.create name |> tag in + id, Backend.input_of_size ~id (el_sz * arr_sz) + | `Idn idn -> let id = tag idn in + id, Backend.input_of_size ~id (el_sz * arr_sz) + | `Bad -> + -1, Backend.bad_reg (el_sz * arr_sz) + in + { reg = arr; type_ = CArray {width=el_sz; count=arr_sz}}, + { type_ = CArray {width=el_sz; count=arr_sz}; id; } + + let new_ctuple_inp ?(name = `Str "input") (tys: ctype list) : circ * cinp = + let id, tp = match name with + | `Str name -> let id = EcIdent.create name |> tag in + id, Backend.input_of_size ~id (List.sum @@ List.map size_of_ctype tys) + | `Idn idn -> let id = tag idn in + id, Backend.input_of_size ~id (List.sum @@ List.map size_of_ctype tys) + | `Bad -> + -1, Backend.bad_reg (List.sum @@ List.map size_of_ctype tys) + in + { reg = tp; type_ = CTuple tys}, + { type_ = CTuple tys; id; } + + let input_of_ctype ?(name : [`Str of string | `Idn of ident | `Bad ] = `Str "input") (ct: ctype) : circuit = + let id, c = match name with + | `Str name -> let id = EcIdent.create name |> tag in + id, Backend.input_of_size ~id (size_of_ctype ct) + | `Idn idn -> let id = idn.id_tag in + id, Backend.input_of_size ~id (size_of_ctype ct) + | `Bad -> + -1, Backend.bad_reg (size_of_ctype ct) + in + { reg = c; type_ = ct; }, [{ id; type_ = ct; }] + + let circuit_true = {reg = Backend.reg_of_node Backend.true_; type_ = CBool}, [] + let circuit_false = {reg = Backend.reg_of_node Backend.false_; type_ = CBool}, [] + + let circuit_and ((c, cinps): circuit) ((d, dinps): circuit) = + if c.type_ = d.type_ then + { reg = Backend.land_ c.reg d.reg; type_ = c.type_ }, merge_inputs cinps dinps + else + raise CircConstructorInvalidArguments + + let circuit_or ((c, cinps): circuit) ((d, dinps): circuit) = + if c.type_ = d.type_ then + { reg = Backend.lor_ c.reg d.reg; type_ = c.type_ }, merge_inputs cinps dinps + else + raise CircConstructorInvalidArguments + + let circuit_not ((c, cinps): circuit) = + {c with reg = Backend.lnot_ c.reg}, cinps + + let circuit_is_free (f: circuit) : bool = List.is_empty @@ snd f + + let circuit_ite ?(strict = false) ~(c: circuit) ~(t: circuit) ~(f: circuit) : circuit = + let inps = match c, t, f with + | (_, []), (_, []), (_, []) when strict -> [] + | (_, cinps), (_, tinps), (_, finps) when (not strict) && cinps = tinps && cinps = finps -> cinps + | _ -> assert false + in + let c = match (fst c).type_ with + | CBool -> Backend.node_of_reg (fst c).reg + | _ -> assert false + in + let res_r = Backend.reg_ite c (fst t).reg (fst f).reg in + match ((fst t).type_, (fst f).type_) with + | CBitstring nt, CBitstring nf when nt = nf -> {reg = res_r; type_ = (fst t).type_}, inps + | CArray {width=wt; count=nt}, CArray {width=wf; count=nf} when wt = wf && nt = nf -> {reg = res_r; type_ = (fst t).type_}, inps + | CTuple szs_t, CTuple szs_f when List.all2 (=) szs_t szs_f -> {reg = res_r; type_ = (fst t).type_}, inps + | CBool, CBool -> {reg = res_r; type_ = (fst t).type_}, inps + | _ -> raise CircConstructorInvalidArguments + + (* TODO: type check? *) + let circuit_eq (c: circuit) (d: circuit) : circuit = + match (fst c).type_, (fst d).type_ with + | (CArray _), (CArray _) + | (CTuple _), (CTuple _) + | (CBitstring _), (CBitstring _) -> + {reg = (Backend.reg_eq (fst c).reg (fst d).reg |> Backend.reg_of_node); type_ = CBool}, merge_inputs (snd c) (snd d) + | CBool, CBool -> + {reg = (Backend.reg_eq (fst c).reg (fst d).reg |> Backend.reg_of_node); type_ = CBool}, merge_inputs (snd c) (snd d) + | CBool, CBitstring 1 -> + {reg = (Backend.reg_eq (fst c).reg (fst d).reg |> Backend.reg_of_node); type_ = CBool}, merge_inputs (snd c) (snd d) + | CBitstring 1, CBool -> + {reg = (Backend.reg_eq (fst c).reg (fst d).reg |> Backend.reg_of_node); type_ = CBool}, merge_inputs (snd c) (snd d) + | _ -> raise CircConstructorInvalidArguments + + (* Ignore types, do extensionally over bits, return the circuits evaluating to the condition *) + let circuit_eqs ((c, cinps): circuit) ((d, dinps): circuit) : circuit list = + let inps = merge_inputs cinps dinps in + + if (size_of_ctype c.type_ <> size_of_ctype d.type_) then + raise CircConstructorInvalidArguments; + + let cs = Backend.node_list_of_reg c.reg in + let ds = Backend.node_list_of_reg d.reg in + List.map2 (fun c d -> + let r = Backend.node_eq c d |> Backend.reg_of_node in + {reg = r; type_ = CBool}, inps) cs ds + + + let circuit_compose (c: circuit) (args: circuit list) : circuit = + ( + try + if not (List.for_all2 (fun c cinp -> circuit_input_compatible c cinp) args (snd c)) then raise CircComposeInvalidArguments; + with + | Invalid_argument _ -> raise CircComposeBadNumberOfArguments); + let map = List.fold_left2 (fun map {id} c -> Map.add id c map) Map.empty (snd c) (List.fst args) in + let map_ (id, idx) = + let circ = Map.find_opt id map in + Option.bind circ (fun c -> + match c.type_ with + | CArray _ | CTuple _ | CBitstring _ -> + begin try + Some (Backend.get c.reg idx) + with Invalid_argument _ -> None + end + | CBool when idx = 0 -> Some (Backend.node_of_reg c.reg) + | _ -> None + ) + in + + let circ = {(fst c) with reg = Backend.applys map_ (fst c).reg} in + let inps = merge_inputs_list (List.snd args) in + (circ, inps) + + (* Circuit Lambda functions *) + + (* Functions for dealing with uninitialized inputs *) + let circuit_uninit (t: ctype) : circuit = + match t with + | CTuple szs -> + let ctp, _cinp = new_ctuple_inp ~name:`Bad szs in + ((ctp, []) :> circuit) + | CArray {width=el_sz; count=arr_sz} -> + let carr, _cinp = new_carray_inp ~name:`Bad el_sz arr_sz in + ((carr, []) :> circuit) + | CBitstring sz -> + let c, _cinp = new_cbitstring_inp ~name:`Bad sz in + ((c, []) :> circuit) + | CBool -> + let c, _cinp = new_cbool_inp ~name:`Bad () in + ((c, []) :> circuit) + + let circuit_has_uninitialized (c: circuit) : int option = + Backend.have_bad (fst c).reg + + let circ_equiv ?(pcond:circuit option) ((c1, inps1): circuit) ((c2, inps2): circuit) : bool = + let pcond = Option.map (convert_type CBool) pcond in (* Try to convert to bool *) (* FIXME: duplicated check *) + let pcc = match pcond with + | Some ({reg = b; type_ = CBool}, pcinps) -> + Backend.apply (unify_inputs_renamer inps1 pcinps) (Backend.node_of_reg b) + | None -> Backend.true_ + | _ -> raise CircEquivNonBoolPCond + in + let c2 = try + unify_inputs inps1 (c2, inps2) + with (CircInputUnificationFailure _) as e -> + raise e (* FIXME: Do something here? *) + in + let inps = List.map (function + | { type_ = CBool; id } -> (id, 1) + | { type_ = CBitstring w; id } -> (id, w) + | { type_ = CArray {width=w1; count=w2}; id } -> (id, w1*w2) + | { type_ = CTuple tys; id } -> (id, List.sum @@ List.map size_of_ctype tys) + + ) inps1 in + if (c1.type_ = c2.type_) then + Backend.equiv ~inps ~pcond:pcc c1.reg c2.reg + else false + + let circ_sat ((c, inps): circuit) : bool = + if debug then Format.eprintf "Calling circ_sat on circuit: %a@." pp_circuit (c, inps); + let c = match c with + | {type_ = CBool; reg} -> Backend.node_of_reg reg + | _ -> raise CircSmtNonBoolCirc + in + let inps = List.map (function + | { type_ = CBool; id } -> (id, 1) + | { type_ = CBitstring w; id } -> (id, w) + | { type_ = CArray {width=w1; count=w2}; id } -> (id, w1*w2) + | { type_ = CTuple tys; id } -> (id, List.sum @@ List.map size_of_ctype tys) + + ) inps in + Backend.sat ~inps c + + let circ_taut ((c, inps): circuit) : bool = + if debug then Format.eprintf "Calling circ_taut on circuit: %a@." pp_circuit (c, inps); + let c = match c with + | {type_ = CBool; reg} -> Backend.node_of_reg reg + | _ -> raise CircSmtNonBoolCirc + in + let inps = List.map (function + | { type_ = CBool; id } -> (id, 1) + | { type_ = CBitstring w; id } -> (id, w) + | { type_ = CArray {width=w1; count=w2}; id } -> (id, w1*w2) + | { type_ = CTuple tys; id } -> (id, List.sum @@ List.map size_of_ctype tys) + + ) inps in + Backend.taut ~inps c + + (* Inputs mean different things depending on circuit type *) + (* FIXME PR: maybe differentiate the two functions ? *) + let circuit_slice ~(size:int) ((c, inps): circuit) (offset: int) : circuit = + assert (size >= 0); + assert (offset >= 0); + match c.type_ with + | CArray {width=w; count=n} when size mod w = 0 && offset mod w = 0 && offset / w < n -> {reg = Backend.slice c.reg offset size; type_ = CArray {width=w; count=size}}, inps + | CArray _ -> raise CircConstructorInvalidArguments + | CBitstring _w -> + { reg = (Backend.slice c.reg offset size); type_ = CBitstring size}, inps + | CTuple tys -> + assert (List.length tys >= offset + size); + let offset, tys = List.takedrop offset tys in + let offset = List.sum @@ List.map size_of_ctype offset in + let tys = (List.take size tys) in + let sz = List.sum @@ List.map size_of_ctype tys in + {reg = (Backend.slice c.reg offset sz); type_ = CTuple tys}, inps + | CBool -> + raise CircConstructorInvalidArguments + + (* Does not type check *) + let circuit_slice_insert ((orig_c, orig_inps): circuit) (idx: int) ((new_c, new_inps): circuit) : circuit = + try + { orig_c with reg = (Backend.insert orig_c.reg idx new_c.reg)}, merge_inputs orig_inps new_inps + with Backend.BadSlice `Set -> + raise CircConstructorInvalidArguments + + (* + Takes a circuit and uses dependency analysis to separate it into + subcircuits corresponding to the output bits + + In particular, equivalence between two circuits is equivalent + to equivalence between the subcircuits + + Implicitly flattens everything to bitstrings + + TODO: add functionality for user specified lane size + *) + let fillet_circuit ((c, inps) : circuit) : circuit list = + let r = c.reg |> Backend.node_list_of_reg in + List.map (fun n -> + let new_inps = List.map (fun {id;type_} -> + {id=EcIdent.create "_" |> tag; type_}) inps + in + let renamings = List.combine + (List.map (fun {id} -> id) inps) + (List.map (fun {id} -> id) new_inps) + |> List.to_seq |> Map.of_seq + in + let renamings = fun v -> Map.find_opt v renamings in + let n', shifts = Backend.Deps.excise_bit ~renamings n in + + let new_inps = List.filter_map (fun {id;_} -> + match Map.find_opt id shifts with + | Some (low, hi) -> Some {id; type_ = CBitstring (hi - low + 1)} + | None -> None + ) new_inps in + { reg = Backend.reg_of_node n'; + type_ = CBool }, + new_inps + ) r + +(* + Correct order is: + - Build two sided equality + - Dependency collapse (into lanes) + - Attach preconditions + - Realign inputs + - Structural equality check + - SMT check + + FIXME: might be unsound on very specific cases where a precondition applies + on only part of the input (the part thats left over after structural equality) + check if this is the case. + Does not affect current examples => MLKEM +*) + (* Batches circuit checks by dependencies. Assumes equivalent checks are contiguous *) + let batch_checks ?(sort = true) ?(mode : [`ByEq | `BySub] = `ByEq) (checks: circuit list) : circuit list = + (* Order by dependencies *) + let checks = if sort then begin + + let checks = List.map (fun (c, inps) -> + (c, inps), Backend.(Deps.dep_of_node (node_of_reg c.reg))) checks in + let checks = List.stable_sort (fun (_, d1) (_, d2) -> + let m1 = (Map.keys d1 |> Set.of_enum |> Set.min_elt_opt) in + let m2 = (Map.keys d2 |> Set.of_enum |> Set.min_elt_opt) in + (* FIXME: Check this *) + match m1, m2 with + | None, None -> 0 + | None, Some _ -> -1 + | Some _, None -> 1 + | Some m1, Some m2 -> + let c1 = Int.compare m1 m2 in + if c1 = 0 then (* FIXME: check default value V V *) + Int.compare (Map.find m1 d1 |> Set.min_elt_opt |> Option.default (-1)) (Map.find m1 d2 |> Set.min_elt_opt |> Option.default (-1)) + else + c1 + ) checks in + checks + end else + List.map (fun c -> + c, Backend.(Deps.dep_of_node (node_of_reg (fst c).reg))) checks + in + + let rec doit (acc: circuit list) (cur, d: circuit * Backend.Deps.dep) (cs: (circuit * Backend.Deps.dep) list) : circuit list = + match cs with + | [] -> (cur::acc) + | (c, d')::cs -> + if debug && false then Format.eprintf "Comparing deps:@.%a@.To deps:@.%a@." + Backend.Deps.pp_dep d + Backend.Deps.pp_dep d'; + begin match mode with + | `ByEq when Backend.Deps.deps_equal d d' -> + doit acc ((circuit_and cur c), d) cs + | `BySub when Backend.Deps.(dep_contained d d') -> + doit acc ((circuit_and cur c), d') cs + | `BySub when Backend.Deps.(dep_contained d' d) -> + doit acc ((circuit_and cur c), d) cs + | _ -> + Format.eprintf "Consolidated lane deps: %a@." Backend.Deps.pp_dep d; + doit (cur::acc) (c, d') cs + end + in + + match checks with + | [] -> [] + | c::cs -> doit [] c cs + + + let attach_compatible_pres ?(mode: [`Cont | `Eq | `Int] = `Cont) (pres: (circuit * Backend.Deps.dep) list) ((post_circ, _) as post: circuit) : circuit = + let d = Backend.(Deps.dep_of_node (node_of_reg post_circ.reg)) in + let compat_pres = List.filteri (fun _i (_c, pre_dep) -> + match mode with + | `Cont -> Backend.Deps.dep_contained pre_dep d + | `Eq -> Backend.Deps.deps_equal pre_dep d + | `Int -> Backend.Deps.deps_intersect pre_dep d + ) pres in + let compat_pres = List.fst compat_pres in + let pre = List.fold_left circuit_and circuit_true compat_pres in + circuit_or (circuit_not pre) post + + (* Assumes all the pre and post have been split, takes all the pres and one post *) + let fillet_taut (pres: (circuit * Backend.Deps.dep) list) ((post_circ, post_inps): circuit) : bool = + let pres = List.map (fun ((c, inps), d) -> + assert (inputs_contained inps post_inps); + ((c, post_inps), d) + ) pres in + (* FIXME: removable *) + assert (List.for_all (fun ((_c, inps), _) -> inps = post_inps) pres); + assert (List.for_all (fun (({type_;reg}, _), _) -> type_ = CBool) pres); + assert (post_circ.type_ = CBool); + let d = Backend.(Deps.dep_of_node (node_of_reg post_circ.reg)) in + let compat_pres = List.filteri (fun i (c, pre_dep) -> + Backend.Deps.dep_contained pre_dep d + ) pres in + let compat_pres = List.fst compat_pres in + let node_post = Backend.node_of_reg post_circ.reg in + let nodes_pre = List.map (fun (c, _) -> Backend.node_of_reg c.reg) compat_pres in + let node_post, shifts = Backend.Deps.excise_bit node_post in + let inps = List.filter_map (fun {id; type_} -> + match Map.find_opt id shifts with + | Some (low, hi) -> Some {id; type_ = CBitstring (hi - low + 1)} + | None -> None + ) post_inps in + let inp_map = fun (id, v) -> + match Map.find_opt id shifts with + | Some (min, max) -> + let new_id = v - min in + assert (new_id <= max); + Some (id, v - min) + | None -> assert false + in + let nodes_pre = Backend.Deps.rename_inputs inp_map (Backend.reg_of_node_list nodes_pre) in + let pre = List.fold_left Backend.band Backend.true_ (Backend.node_list_of_reg nodes_pre) |> Backend.reg_of_node in + let pre = {reg = pre; type_ = CBool}, inps in + let post = Backend.reg_of_node node_post in + let post = {reg = post; type_ = CBool}, inps in + let cond = circuit_or (circuit_not pre) post in + circ_taut cond + + let sublimate_inputs ((c, cinps): circuit) : circuit = + assert (c.type_ = CBool); + let node_c = Backend.node_of_reg c.reg in + let node_c, shifts = Backend.Deps.excise_bit node_c in + let inps = List.filter_map (fun {id; type_} -> + match Map.find_opt id shifts with + | Some (low, hi) -> Some {id; type_ = CBitstring (hi - low + 1)} + | None -> None + ) cinps in + let c = Backend.reg_of_node node_c in + { reg = c; type_ = CBool}, inps + + + (* Review later? *) + let collapse_lanes (lanes: circuit list) = + (* Circuit structural equality after renaming *) + let (===) (c1: circ) (c2: circ) : bool = + let n', _ = Backend.node_of_reg c1.reg |> Backend.Deps.excise_bit in + let n, _ = Backend.node_of_reg c2.reg |> Backend.Deps.excise_bit in + Backend.nodes_eq n n' + in + let rec collapse (acc: circuit list) (cur: circuit) (cs: circuit list) : circuit list = + match cs with + | [] -> cur::acc + | c::cs -> + if (fst c) === (fst cur) then + collapse acc cur cs + else + collapse (cur::acc) c cs + in + (* FIXME: optimize later *) + let rec doit (cs: circuit list) : circuit list = + match cs with + | [] -> [] + | c::[] -> c::[] + | c::cs -> begin try + let idx, _ = List.findi (fun _ c2 -> (fst c) === (fst c2)) cs in + let idx = idx + 1 in (* Length of the list to merge *) + if idx = 1 then + doit (collapse [] c cs) + else + if (List.length (cs) + 1) mod idx != 0 then + (Format.eprintf "Cannot correctly infer lanes, defaulting to bruteforce checking@."; + (c::cs)) + else + let cs = List.chunkify idx (c::cs) |> List.map (List.reduce circuit_and) in + doit cs + with Not_found -> + c::cs + end + in + doit lanes + + (* + - Attaches preconditions to postconditions + - Realigns inputs + - Checks for structural equality of circuits + - SMT check for any remainings ones + *) + (* FIXME: current lane collapse is always quadratic, add toggle option? + or remove arg *) + let fillet_tauts ?(mode: [`Seq | `Quad] = `Seq) (pres: circuit list) (posts: circuit list) : bool = + (* Assumes everything is single bit outputs. FIXME: does it? *) + let posts = List.filter_map (fun ((postc, _) as post) -> + if Backend.nodes_eq (Backend.node_of_reg postc.reg) Backend.true_ then None + else Some post + ) posts in + + match posts with + | [] -> true + | posts -> + if (not (List.for_all (fun ({type_;reg=_}, _) -> type_ = CBool) pres)) + || (not (List.for_all (fun ({type_;reg=_}, _) -> type_ = CBool) posts)) then + raise CircSmtNonBoolCirc; + let pres = List.map (fun ((c, _) as circ) -> circ, + Backend.Deps.dep_of_node (Backend.node_of_reg c.reg)) pres in + let posts = List.map (attach_compatible_pres ~mode:`Int pres) posts in + let posts = collapse_lanes posts in + + if debug then Format.eprintf "%d conditions to check after structural equality collapse@." (List.length posts); + + List.mapi (fun i post -> + if debug then Format.eprintf "Checking equivalence for bit %d@." i; (* FIXME *) + +(* let res = fillet_taut pres post in *) + let post = sublimate_inputs post in + let res = circ_taut post in + if not res then Format.eprintf "Failed for bit %d@." i; + + res) posts |> + List.for_all identity + + let compute ~(sign: bool) ((r, inps) as c: circuit) (args: arg list) : zint option = + begin match r.type_ with + | CBitstring _ -> () + | _ -> assert false (* TODO: FIXME Add functionality for other or add exception *) + end; + + if List.compare_lengths args inps <> 0 + then raise CircComputeBadNumberOfArguments; + let args = List.map2i (fun i arg inp -> + match arg, inp with + | `Circuit c, inp when circuit_input_compatible c inp -> c + | `Constant i, {type_ = CBitstring size} -> { reg = (Backend.reg_of_zint ~size i); type_ = CBitstring size}, [] + | _ -> raise CircComputeInvalidArguments + ) args inps + in + match circuit_compose c args with + | {reg = r; type_ = CBitstring _}, [] -> + begin try + Some (if sign + then Backend.szint_of_reg r + else Backend.uzint_of_reg r) + with Backend.NonConstantCircuit -> None + end + | _, _::_ -> assert false (* Should not happen *) + | _ -> assert false (* Should not happen *) + + let circuit_aggregate (cs: circuit list) : circuit = + let inps = List.snd cs in + let cs = List.map (fun c -> (fst c).reg) cs in + let c = Backend.flatten cs in + let inps = merge_inputs_list inps in + {reg = c; type_ = CBitstring (Backend.size_of_reg c)}, inps + + let input_aggregate_renamer (inps: cinp list) : cinp * (Backend.inp -> Backend.node option) = + let new_id = create "aggregated" |> tag in + let (size, map) = List.fold_left (fun (size, map) inp -> + match inp with + | { type_ = CBitstring w; id} -> + (size + w, Map.add id (size, w) map) + | { type_ = CArray {width=w; count=n}; id} -> + (size + (w*n), Map.add id (size, w*n) map) + | { type_ = CTuple tys; id} -> + let w = List.sum @@ List.map size_of_ctype tys in + (size + w, Map.add id (size, w) map) + | { type_ = CBool; id} -> + (size + 1, Map.add id (size, 1) map) + ) (0, Map.empty) inps + in + {type_ = CBitstring size; id=new_id}, + fun (id, bit) -> + let base_sz = Map.find_opt id map in + Option.bind base_sz (fun (base, sz) -> + let idx = bit + base in + if bit >= 0 && bit < sz then + Some (Backend.input_node ~id:new_id idx) + else None + ) + + let circuit_aggregate_inputs ((c, inps): circuit) : circuit = + let inp, renamer = input_aggregate_renamer inps in + {c with reg = Backend.applys renamer c.reg}, [inp] + + let circuit_to_file ~(name: string) ((c, inps): circuit) : symbol = + match c, inps with + | {reg = r; type_ = CBitstring _}, {type_ = CBitstring w; id}::[] -> (* TODO: rename inputs? *) + Backend.reg_to_file ~input_count:w ~name (Backend.applys (fun (id_, i) -> if id_ = id then Some (Backend.input_node ~id:0 (i+1)) else None) r) + | _ -> raise UnsupportedTypeForFileOutput + + let circuit_from_spec ?(name: symbol option) ((arg_tys, ret_ty) : (ctype list * ctype)) (spec: Lospecs.Ast.adef) : circuit = + let c = Backend.circuit_from_spec spec in + + let name = match name with + | Some name -> name ^ "_spec_input" + | None -> "spec_input" + in + + let cinps, inps = List.mapi (fun i ty -> + let id = EcIdent.create (name ^ "_" ^ (string_of_int i)) |> tag in + let size : int = size_of_ctype ty in + (Backend.input_of_size ~id size, { type_ = ty; id = id; } ) + ) arg_tys |> List.split in + let c = c cinps in + { reg = c; type_ = ret_ty}, inps (* TODO: type checking ? *) +(* { reg = c; CBitstring c, inps) |> convert_type ret_ty *) + + module BVOps = struct + let circuit_of_parametric_bvop (op: EcDecl.crb_bvoperator) (args: arg list) : circuit = + match op with + | { kind = `ASliceGet (((_, Some n), (_, Some w)), (_, Some m)) } -> + begin match args with + (* Assume type checking from EC? *) + | [ `Circuit (({type_ = CArray _}, _) as circ) ; `Constant i ] -> + begin + match (fst circ).type_ with + | CArray {width=w'; count=n'} when n' = n && w = w' -> + circuit_slice ~size:m ({reg = (fst circ).reg; type_ = CBitstring (w' * n')}, (snd circ)) (to_int i) + | CArray _ -> + raise CircConstructorInvalidArguments + | _ -> assert false (* Does not happen, guarded by match above *) + end + | _ -> raise CircConstructorInvalidArguments + end + | { kind = `ASliceSet (((_, Some n), (_, Some w)), (_, Some m)) } -> + begin match args with + | [ `Circuit (({type_ = CArray _}, _) as arr_circ) ; `Constant i ; `Circuit (({type_ = CBitstring _}, _) as bs_circ) ] -> + begin match (fst arr_circ).type_, (fst bs_circ).type_ with + | CArray {width=w'; count=n'}, CBitstring m' when n' = n && w' = w && m = m' -> + circuit_slice_insert arr_circ (to_int i) bs_circ + | _ -> raise CircConstructorInvalidArguments + end + | _ -> raise CircConstructorInvalidArguments + end + + (* FIXME: what do we want for out of bounds extract? Decide later *) + | { kind = `Extract ((_, Some w_in), (_, Some w_out)) } -> + begin match args with + | [ `Circuit (({type_ = CBitstring _}, _ ) as c) ; `Constant i ] -> + circuit_slice ~size:w_out c (to_int i) + | _ -> raise CircConstructorInvalidArguments + end + | { kind = `Insert ((_, Some w_orig), (_, Some w_ins)) } -> + begin match args with + | [ `Circuit (({type_ = CBitstring _}, _) as orig_c) ; `Constant i ; `Circuit (({ type_=CBitstring _}, _) as new_c) ] -> + (circuit_slice_insert orig_c (to_int i) new_c :> circuit) + | _ -> raise CircConstructorInvalidArguments + end + + | { kind = `Map ((_, Some w_i), (_, Some w_o), (_, Some n)) } -> + begin match args with + | [ `Circuit (({ type_=CBitstring _}, [{type_=CBitstring w_i'}; _]) as cf); `Circuit ({reg = arr; type_ = CArray {width=w_i''; count=n_i''}}, arr_inps) ] when (w_i' = w_i && w_i'' = w_i') && (n_i'' = n) -> + let circs, inps = List.split @@ List.map (fun c -> + match circuit_compose cf [c] with + | { type_ = CBitstring _; reg}, inps -> reg, inps + | c, _ -> raise CircConstructorInvalidArguments (* Wrong map return type *) + ) + (List.init n (fun i -> {reg = (Backend.slice arr (i*w_i) w_i); type_ = CBitstring w_i}, [])) + in + (* Inputs of all components should match after map *) + if not (List.for_all ((=) (List.hd inps)) inps) then + raise CircConstructorInvalidArguments; + let inps = List.hd inps in + let circ = { reg = (Backend.flatten circs); type_ = CArray {width=w_o; count=n}} in + (circ, inps) + | _ -> raise CircConstructorInvalidArguments + end + | { kind = `Get (_, Some w_in) } -> + begin match args with + | [ `Circuit ({reg = bs; type_ = CBitstring _}, cinps); `Constant i ] -> + {type_ = CBool; reg = Backend.reg_of_node (Backend.get bs (to_int i))}, cinps + | _ -> raise CircConstructorInvalidArguments + end + | { kind = `AInit ((_, Some n), (_, Some w_o)) } -> + begin match args with + | [ `Init init_f ] -> + let circs, cinps = List.split @@ List.init n init_f in + let circs = List.map + (function + | {type_ = CBitstring _; reg = r} when Backend.size_of_reg r = w_o -> r + (* Invalid type for init component *) + | _ -> raise CircConstructorInvalidArguments) + circs in + (* Inputs should be uniform across components after mapping *) + (if not (List.for_all ((=) (List.hd cinps)) cinps) then + raise CircConstructorInvalidArguments); + let cinps = List.hd cinps in + {type_ = CArray {width=w_o; count=n} ; reg = Backend.flatten circs}, cinps + | _ -> raise CircConstructorInvalidArguments + end + | { kind = `Init (_, Some w) } -> + begin match args with + | [ `Init init_f ] -> + let circs, cinps = List.split @@ List.init w init_f in + let circs = List.map + (function + | {type_ = CBool; reg = b} -> Backend.node_of_reg b + (* Return type should be bool (= bit) for components *) + | _ -> raise CircConstructorInvalidArguments) circs in + (if not (List.for_all ((=) (List.hd cinps)) cinps) then + raise CircConstructorInvalidArguments); + let cinps = List.hd cinps in + {type_ = CBitstring w; reg = (Backend.reg_of_node_list circs)}, cinps + | _ -> raise CircConstructorInvalidArguments + end + | _ -> assert false (* Should not happen because calls should be guarded by call to op_is_parametric_bvop *) + + + let circuit_of_bvop (op: EcDecl.crb_bvoperator) : circuit = + match op with + | { kind = `Add (_, Some size) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.add c1 c2 )}, [inp1; inp2] + + | { kind = `Sub (_, Some size) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.sub c1 c2)}, [inp1; inp2] + + | { kind = `Mul (_, Some size) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.mul c1 c2)}, [inp1; inp2] + + | { kind = `Div ((_, Some size), false) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.udiv c1 c2)}, [inp1; inp2] + + | { kind = `Div ((_, Some size), true) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.sdiv c1 c2)}, [inp1; inp2] + + | { kind = `Rem ((_, Some size), false) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.umod c1 c2)}, [inp1; inp2] + + | { kind = `Rem ((_, Some size), true) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.smod c1 c2)}, [inp1; inp2] + (* Should this be mod or rem? TODO FIXME*) + + | { kind = `Shl (_, Some size) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.lshl c1 c2)}, [inp1; inp2] + + | { kind = `Shr ((_, Some size), false) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.lshr c1 c2)}, [inp1; inp2] + + | { kind = `Shr ((_, Some size), true) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.ashr c1 c2)}, [inp1; inp2] + + | { kind = `Shls ((_, Some size1), (_, Some size2)) } -> + let c1, inp1 = new_cbitstring_inp_reg size1 in + let c2, inp2 = new_cbitstring_inp_reg size2 in + {type_ = CBitstring size1; reg = (Backend.lshl c1 c2)}, [inp1; inp2] + + | { kind = `Shrs ((_, Some size1), (_, Some size2), false) } -> + let c1, inp1 = new_cbitstring_inp_reg size1 in + let c2, inp2 = new_cbitstring_inp_reg size2 in + {type_ = CBitstring size1; reg = (Backend.lshr c1 c2)}, [inp1; inp2] + + | { kind = `Shrs ((_, Some size1), (_, Some size2), true) } -> + let c1, inp1 = new_cbitstring_inp_reg size1 in + let c2, inp2 = new_cbitstring_inp_reg size2 in + {type_ = CBitstring size1; reg = (Backend.ashr c1 c2)}, [inp1; inp2] + + | { kind = `Rol (_, Some size) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.rol c1 c2)}, [inp1; inp2] + + | { kind = `Ror (_, Some size) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.ror c1 c2)}, [inp1; inp2] + + | { kind = `And (_, Some size) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.land_ c1 c2)}, [inp1; inp2] + + | { kind = `Or (_, Some size) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.lor_ c1 c2)}, [inp1; inp2] + + | { kind = `Xor (_, Some size) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.lxor_ c1 c2)}, [inp1; inp2] + + | { kind = `Not (_, Some size) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.lnot_ c1)}, [inp1] + + | { kind = `Opp (_, Some size) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + {type_ = CBitstring size; reg = (Backend.opp c1)}, [inp1] + + | { kind = `Lt ((_, Some size), false) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBool; reg = Backend.reg_of_node (Backend.ult c1 c2)}, [inp1; inp2] + + | { kind = `Lt ((_, Some size), true) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBool; reg = Backend.reg_of_node (Backend.slt c1 c2)}, [inp1; inp2] + + | { kind = `Le ((_, Some size), false) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBool; reg = Backend.reg_of_node (Backend.ule c1 c2)}, [inp1; inp2] + + | { kind = `Le ((_, Some size), true) } -> + let c1, inp1 = new_cbitstring_inp_reg size in + let c2, inp2 = new_cbitstring_inp_reg size in + {type_ = CBool; reg = Backend.reg_of_node (Backend.sle c1 c2)}, [inp1; inp2] + + | { kind = `Extend ((_, Some size), (_, Some out_size), false) } -> + (* assert (size <= out_size); *) + let c1, inp1 = new_cbitstring_inp_reg size in + {type_ = CBitstring out_size; reg = (Backend.uext c1 out_size)}, [inp1] + + | { kind = `Extend ((_, Some size), (_, Some out_size), true) } -> + (* assert (size <= out_size); *) + let c1, inp1 = new_cbitstring_inp_reg size in + {type_ = CBitstring out_size; reg = (Backend.sext c1 out_size)}, [inp1] + + | { kind = `Truncate ((_, Some size), (_, Some out_sz)) } -> + (* assert (size >= out_sz); *) + let c1, inp1 = new_cbitstring_inp_reg size in + {type_ = CBitstring out_sz; reg = (Backend.trunc c1 out_sz)}, [inp1] + + | { kind = `Concat ((_, Some sz1), (_, Some sz2), (_, Some szo)) } -> + (* assert (sz1 + sz2 = szo); *) + let c1, inp1 = new_cbitstring_inp_reg sz1 in + let c2, inp2 = new_cbitstring_inp_reg sz2 in + {type_ = CBitstring szo; reg = (Backend.concat c1 c2)}, [inp1; inp2] + + | { kind = `A2B (((_, Some w), (_, Some n)), (_, Some m))} -> + (* assert (n * w = m); *) + let c1, inp1 = new_carray_inp w n in + {c1 with type_ = CBitstring m}, [inp1] + + | { kind = `B2A ((_, Some m), ((_, Some w), (_, Some n)))} -> + (* assert (n * w = m); *) + let c1, inp1 = new_cbitstring_inp m in + {c1 with type_ = CArray {width=w; count=n}}, [inp1] + + | { kind = `ASliceGet _ | `ASliceSet _ | `Extract _ | `Insert _ | `Map _ | `AInit _ | `Get _ | `Init _ } + | _ + -> assert false (* Should be guarded by call to op_is_bvop *) + end + + module ArrayOps = struct + let array_get (({reg = c; type_ = CArray {width=w; count=n}}, inps) : circuit) (i: int) : circuit = + try + { type_ = CBitstring w; reg = (Backend.slice c (i*w) w)}, inps + with Invalid_argument _ -> + raise CircConstructorInvalidArguments + + let array_set (({reg = arr; type_ = CArray {width=w; count=n}}, inps) : circuit) (pos: int) (({reg = bs; type_ = CBitstring w'}, cinps): circuit) : circuit = + let exception SizeMismatch in + try + assert (w = w'); + { type_ = CArray {width=w; count=n}; reg = (Backend.insert arr (pos * w) bs)}, + merge_inputs inps cinps + with Invalid_argument _ -> + raise CircConstructorInvalidArguments + | SizeMismatch -> + raise CircConstructorInvalidArguments + + (* FIXME: review this functiono | FIXME: Not axiomatized in QFABV.ec file *) + let array_oflist (circs : circuit list) (dfl: circuit) (len: int) : circuit = + let circs, inps = List.split circs in + let dif = len - List.length circs in assert (dif >= 0); + (* if debug then Format.eprintf "Len, Dif in array_oflist: %d, %d@." len dif; *) + let circs = circs @ (List.init dif (fun _ -> fst dfl)) in + let inps = if dif > 0 then inps @ [snd dfl] else inps in + let circs = List.map + (function + | {type_ = CBitstring _; reg = r} -> r + | _ -> raise CircConstructorInvalidArguments + ) circs + in + { type_ = CArray {width=Backend.size_of_reg (List.hd circs); count=len}; reg = (Backend.flatten circs)}, merge_inputs_list inps + end +end + +include MakeCircuitInterfaceFromCBackend(LospecsBack) +include CArgs +include TranslationState +include BVOps +include ArrayOps + +let reset_backend_state () = + C.HCons.clear (); + CDeps.reset_state () diff --git a/src/ecLowPhlGoal.ml b/src/ecLowPhlGoal.ml index 97fe5f0b46..75b103beba 100644 --- a/src/ecLowPhlGoal.ml +++ b/src/ecLowPhlGoal.ml @@ -194,16 +194,16 @@ let is_program_logic (f : form) (ks : hlkind list) = let tc1_get_stmt side tc = let concl = FApi.tc1_goal tc in match side, concl.f_node with - | None, FhoareS hs -> hs.hs_m, hs.hs_s - | None, FeHoareS hs -> hs.ehs_m, hs.ehs_s - | None, FbdHoareS hs -> hs.bhs_m, hs.bhs_s + | None, FhoareS hs -> (hs.hs_m, hs.hs_s) + | None, FeHoareS hs -> (hs.ehs_m, hs.ehs_s) + | None, FbdHoareS hs -> (hs.bhs_m, hs.bhs_s) | Some _ , (FhoareS _ | FbdHoareS _) -> tc_error_noXhl ~kinds:[`Hoare `Stmt; `PHoare `Stmt] !!tc - | Some `Left, FequivS es -> es.es_ml, es.es_sl - | Some `Right, FequivS es -> es.es_mr, es.es_sr + | Some `Left, FequivS es -> (es.es_ml, es.es_sl) + | Some `Right, FequivS es -> (es.es_mr, es.es_sr) | None, FequivS _ -> tc_error_noXhl ~kinds:[`Equiv `Stmt] !!tc - | _ -> + | _ -> tc_error_noXhl ~kinds:(hlkinds_Xhl_r `Stmt) !!tc (* ------------------------------------------------------------------ *) diff --git a/src/ecOptions.ml b/src/ecOptions.ml index f012e8e8d6..a1d30f4e35 100644 --- a/src/ecOptions.ml +++ b/src/ecOptions.ml @@ -25,12 +25,14 @@ and cmp_option = { cmpo_tstats : string option; cmpo_noeco : bool; cmpo_script : bool; + cmpo_specs : spec_options; cmpo_trace : bool; } and cli_option = { clio_emacs : bool; clio_provers : prv_options; + clio_specs : spec_options; } and run_option = { @@ -40,6 +42,7 @@ and run_option = { runo_provers : prv_options; runo_jobs : int option; runo_rawargs : string list; + runo_specs : spec_options; } and doc_option = { @@ -60,6 +63,10 @@ and prv_options = { prvo_why3server : string option; } +and spec_options = { + files : string list; +} + and ldr_options = { ldro_idirs : (string option * string * bool) list; ldro_boot : bool; @@ -81,6 +88,7 @@ type ini_options = { ini_timeout : int option; ini_idirs : (string option * string) list; ini_rdirs : (string option * string) list; + ini_specs : string list; } type ini_context = { @@ -99,6 +107,8 @@ module Ini : sig val get_provers : ini_context -> string list + val get_specs : ini_context -> string list + val get_timeout : ini_context -> int option val get_idirs : ini_context -> (string option * string) list @@ -114,6 +124,8 @@ module Ini : sig val get_all_provers : ini_context list -> string list + val get_all_specs : ini_context list -> string list + val get_all_timeout : ini_context list -> int option val get_all_idirs : ini_context list -> (string option * string) list @@ -145,6 +157,10 @@ end = struct let get_provers (ini : ini_context) = ini.inic_ini.ini_provers + let get_specs (ini : ini_context) = + List.map (absolute ?root:ini.inic_root) + ini.inic_ini.ini_specs + let get_timeout (ini : ini_context) = ini.inic_ini.ini_timeout @@ -171,6 +187,9 @@ end = struct let get_all_provers (ini : ini_context list) = List.flatten (List.map get_provers ini) + let get_all_specs (ini : ini_context list) = + List.flatten (List.map get_specs ini) + let get_all_timeout (ini : ini_context list) = List.find_map_opt get_timeout ini @@ -507,9 +526,14 @@ let prv_options_of_values ini values = prvo_why3server = get_string "why3server" values; } +let spec_options_of_values ini values = + { files = (Ini.get_all_specs ini) @ (get_strings "spec" values); } + let cli_options_of_values ini values = { clio_emacs = get_flag "emacs" values; - clio_provers = prv_options_of_values ini values; } + clio_provers = prv_options_of_values ini values; + clio_specs = spec_options_of_values ini values; + } let cmp_options_of_values ini values input = { cmpo_input = input; @@ -518,8 +542,10 @@ let cmp_options_of_values ini values input = cmpo_compact = get_int "compact" values; cmpo_tstats = get_string "tstats" values; cmpo_noeco = get_flag "no-eco" values; - cmpo_script = get_flag "script" values; - cmpo_trace = get_flag "trace" values; } + cmpo_script = get_flag "script" values; + cmpo_specs = spec_options_of_values ini values; + cmpo_trace = get_flag "trace" values; + } let runtest_options_of_values ini values (input, scenarios) = { runo_input = input; @@ -527,7 +553,9 @@ let runtest_options_of_values ini values (input, scenarios) = runo_report = get_string "report" values; runo_provers = prv_options_of_values ini values; runo_jobs = get_int "jobs" values; - runo_rawargs = get_strings "raw-args" values; } + runo_rawargs = get_strings "raw-args" values; + runo_specs = spec_options_of_values ini values; + } let doc_options_of_values values input = { doco_input = input; @@ -685,7 +713,9 @@ let read_ini_file (filename : string) = ini_provers = trylist "provers" ; ini_timeout = tryint "timeout" ; ini_idirs = List.map parse_idir (trylist "idirs"); - ini_rdirs = List.map parse_idir (trylist "rdirs"); } in + ini_rdirs = List.map parse_idir (trylist "rdirs"); + ini_specs = trylist "spec"; + } in { ini_ppwidth = ini.ini_ppwidth; ini_why3 = omap expand ini.ini_why3; @@ -693,4 +723,6 @@ let read_ini_file (filename : string) = ini_provers = ini.ini_provers; ini_timeout = ini.ini_timeout; ini_idirs = ini.ini_idirs; - ini_rdirs = ini.ini_rdirs; } + ini_rdirs = ini.ini_rdirs; + ini_specs = ini.ini_specs; + } diff --git a/src/ecOptions.mli b/src/ecOptions.mli index 59009718ad..8bf076f06c 100644 --- a/src/ecOptions.mli +++ b/src/ecOptions.mli @@ -21,12 +21,14 @@ and cmp_option = { cmpo_tstats : string option; cmpo_noeco : bool; cmpo_script : bool; + cmpo_specs : spec_options; cmpo_trace : bool; } and cli_option = { clio_emacs : bool; clio_provers : prv_options; + clio_specs : spec_options; } and run_option = { @@ -36,6 +38,7 @@ and run_option = { runo_provers : prv_options; runo_jobs : int option; runo_rawargs : string list; + runo_specs : spec_options; } and doc_option = { @@ -56,6 +59,10 @@ and prv_options = { prvo_why3server : string option; } +and spec_options = { + files : string list; +} + and ldr_options = { ldro_idirs : (string option * string * bool) list; ldro_boot : bool; @@ -77,6 +84,7 @@ type ini_options = { ini_timeout : int option; ini_idirs : (string option * string) list; ini_rdirs : (string option * string) list; + ini_specs : string list; } type ini_context = { diff --git a/src/ecPV.ml b/src/ecPV.ml index 6d5c5bd5e1..e2da2dfa2a 100644 --- a/src/ecPV.ml +++ b/src/ecPV.ml @@ -111,6 +111,8 @@ module Mpv = struct check_glob env mp m; raise Not_found + let pvs { s_pv } = s_pv + type esubst = (expr, unit) t let rec esubst env (s : esubst) e = diff --git a/src/ecPV.mli b/src/ecPV.mli index 6821864cc3..0e9df4354b 100644 --- a/src/ecPV.mli +++ b/src/ecPV.mli @@ -53,10 +53,12 @@ module Mpv : sig val find_glob : env -> mpath -> ('a,'b) t -> 'b - val esubst : env -> (expr, unit) t -> expr -> expr + val pvs : ('a,'b) t -> 'a Mnpv.t + + val esubst : env -> (expr, unit) t -> expr -> expr val issubst : env -> (expr, unit) t -> instr list -> instr list - val isubst : env -> (expr, unit) t -> instr -> instr - val ssubst : env -> (expr, unit) t -> stmt -> stmt + val isubst : env -> (expr, unit) t -> instr -> instr + val ssubst : env -> (expr, unit) t -> stmt -> stmt end (* -------------------------------------------------------------------- *) diff --git a/src/ecParser.mly b/src/ecParser.mly index 46205d02b5..5a0fd066ce 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -383,6 +383,7 @@ %token ALIAS %token AMP %token APPLY +%token ARRAY %token AS %token ASSERT %token ASSUMPTION @@ -394,6 +395,8 @@ %token BACKS %token BACKSLASH %token BETA +%token BITSTRING +%token BIND %token BY %token BYEQUIV %token BYPHOARE @@ -402,6 +405,7 @@ %token BYUPTO %token CALL %token CASE +%token CIRCUIT %token CBV %token CEQ %token CFOLD @@ -449,6 +453,7 @@ %token EXLIM %token EXPECT %token EXPORT +%token EXTENS %token FAIL %token FEL %token FIRST @@ -659,7 +664,10 @@ _lident: | x=LIDENT { x } | ABORT { "abort" } | ADMITTED { "admitted" } +| ARRAY { "array" } | ASYNC { "async" } +| BIND { "bind" } +| BITSTRING { "bitstring" } | DEBUG { "debug" } | DUMP { "dump" } | EXPECT { "expect" } @@ -715,6 +723,7 @@ _lident: %inline sword: | n=word { n } +| PLUS n=word { n } | MINUS n=word { -n } (* -------------------------------------------------------------------- *) @@ -2572,7 +2581,7 @@ codepos: codepos_range: | LBRACKET cps=codepos DOTDOT cpe=codepos RBRACKET { (cps, `Base cpe) } -| LBRACKET cps=codepos MINUS cpe=codepos1 RBRACKET { (cps, `Offset cpe) } +| LBRACKET cps=codepos PLUS cpe=codepos1 RBRACKET { (cps, `Offset cpe) } codepos_or_range: | cp=codepos { (cp, `Offset (0, `ByPos 0)) } @@ -3061,8 +3070,13 @@ interleave_info: | FUSION s=side? o=codepos NOT i=word AT d1=word COMMA d2=word { Pfusion (s, o, (i, (d1, d2))) } -| UNROLL b=boption(FOR) s=side? o=codepos - { Punroll (s, o, b) } +(* FIXME CIRCUIT PR: Do we keep this separated or do we take the + version from main? *) +| UNROLL s=side? o=codepos + { Punroll (s, o, `While) } + +| UNROLL FOR b=boption(STAR) s=side? o=codepos + { Punroll (s, o, `For b) } | SPLITWHILE s=side? o=codepos COLON c=expr %prec prec_tactic { Psplitwhile (c, s, o) } @@ -3196,8 +3210,8 @@ interleave_info: | LOSSLESS { Plossless } -| PROC CHANGE side=side? pos=loc(codepos_or_range) COLON s=brace(stmt) - { Pchangestmt (side, (unloc pos), s) } +| PROC CHANGE side=side? pos=loc(codepos_or_range) COLON b=option(bracket(ptybindings)) s=brace(stmt) + { Pchangestmt (side, b, (unloc pos), s) } | PROC REWRITE side=side? pos=codepos f=pterm { Pprocrewrite (side, pos, `Rw f) } @@ -3205,9 +3219,19 @@ interleave_info: | PROC REWRITE side=side? pos=codepos SLASHEQ { Pprocrewrite (side, pos, `Simpl) } +| PROC CHANGE CIRCUIT b=option(bracket(ptybindings)) o=codepos PLUS w=word s=brace(stmt) + { Prwprgm (`Change (o, b, w, s)) } + | IDASSIGN o=codepos x=lvalue_var { Prwprgm (`IdAssign (o, x)) } +%public phltactic: +| CIRCUIT + { Pcircuit (`Solve ) } + +| CIRCUIT SIMPLIFY + { Pcircuit (`Simplify ) } + bdhoare_split: | b1=sform b2=sform b3=sform? { BDH_split_bop (b1,b2,b3) } @@ -3271,9 +3295,9 @@ eqobs_in_eqpost: eqobs_in: | pos=eqobs_in_pos? i=eqobs_in_eqinv p=eqobs_in_eqpost? { - { sim_pos = pos; - sim_hint = i; - sim_eqs = p; } + { psim_pos = pos; + psim_hint = i; + psim_eqs = p; } } pgoptionkw: @@ -3375,6 +3399,9 @@ tactic_core_r: { Pcase (odfl false eq, odfl [] opts, { pr_view = vw; pr_rev = gp; } ) } +| EXTENS v=option(bracket(lident)) COLON t=tactic_core + { Pextens (t, v) } + | PROGRESS opts=pgoptions? t=tactic_core? { Pprogress (odfl [] opts, t) } @@ -3821,6 +3848,35 @@ user_red_option: (Some ("invalid option: " ^ (unloc x))) } +(* -------------------------------------------------------------------- *) +(* Circuit & bo bindings *) + +(* FIXME:merge-bdep generic option parser *) + +spec_binding: +| op=qoident LARROW circ=loc(STRING) + { (op, circ) } + +cr_binding_r: +| BIND BITSTRING from_=qoident to_=qoident touint=qoident tosint=qoident ofint=qoident type_=loc(simpl_type_exp) size=sform + { CRB_Bitstring { from_; to_; touint; tosint; ofint; type_; size; } } + +| BIND ARRAY get=qoident set=qoident tolist=qoident oflist=qoident type_=qoident size=sform + { CRB_Array { get; set; tolist; oflist; type_; size; } } + +| BIND OP type_=qident operator=qoident name=loc(STRING) + { CRB_BvOperator { types = [type_]; operator; name; } } + +| BIND OP types=bracket(plist1(qident, AMP)) operator=qoident name=loc(STRING) + { CRB_BvOperator { types; operator; name; } } + +| BIND CIRCUIT bindings=plist1(spec_binding, COMMA) + { CRB_Circuit { bindings } } + +%inline cr_binding: +| locality=is_local binding=cr_binding_r + { { locality; binding; }} + (* -------------------------------------------------------------------- *) (* Search pattern *) %inline search: x=sform_h { x } @@ -3859,6 +3915,7 @@ global_action: | gprover_info { Gprover_info $1 } | addrw { Gaddrw $1 } | hint { Ghint $1 } +| cr_binding { Gcrbinding $1 } | x=loc(proofend) { Gsave x } | PRINT p=print { Gprint p } | SEARCH x=search+ { Gsearch x } diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 0189383d61..98a746df4c 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -694,10 +694,10 @@ type conseq_info = type conseq_ppterm = ((pformula option pair) * (conseq_info) option) gppterm (* -------------------------------------------------------------------- *) -type sim_info = { - sim_pos : pcodepos1 pair option; - sim_hint : (pgamepath option pair * pformula) list * pformula option; - sim_eqs : pformula option +type psim_info = { + psim_pos : pcodepos1 pair option; + psim_hint : (pgamepath option pair * pformula) list * pformula option; + psim_eqs : pformula option } (* -------------------------------------------------------------------- *) @@ -722,6 +722,38 @@ type matchmode = [ | `SSided of side ] +(* -------------------------------------------------------------------- *) +type bdepvar = [`Var of psymbol | `VarRange of psymbol * int | `Slice of psymbol * (pqsymbol * zint)] + +type bdep_info = + { n : int + ; m : int + ; invs : bdepvar list + ; inpvs : bdepvar list + ; outvs : bdepvar list + ; pcond : psymbol + ; lane : psymbol + ; perm : psymbol option + ; debug : bool } + +type bdep_eval_info = + { in_ty : pty + ; out_ty : pty + ; invs : bdepvar list + ; inpvs : bdepvar list + ; outvs : bdepvar list + ; lane : psymbol + ; range : pformula + ; sign : bool } + +type bdepeq_info = + { n : int + ; inpvs_l : bdepvar list + ; inpvs_r : bdepvar list + ; out_blocks : (int * bdepvar list * bdepvar list) list + ; pcond : psymbol option + ; preprocess : bool } + (* -------------------------------------------------------------------- *) type prrewrite = [`Rw of ppterm | `Simpl] @@ -737,7 +769,7 @@ type phltactic = | Pasyncwhile of async_while_info | Pfission of (oside * pcodepos * (int * (int * int))) | Pfusion of (oside * pcodepos * (int * (int * int))) - | Punroll of (oside * pcodepos * bool) + | Punroll of (oside * pcodepos * [`While | `For of bool]) | Psplitwhile of (pexpr * oside * pcodepos) | Pcall of oside * call_info gppterm | Pcallconcave of (pformula * call_info gppterm) @@ -771,14 +803,13 @@ type phltactic = | Pfel of (pcodepos1 * fel_info) | Phoare | Pprbounded - | Psim of crushmode option* sim_info + | Psim of crushmode option* psim_info | Ptrans_stmt of trans_info | Prw_equiv of rw_eqv_info | Psymmetry | Pbdhoare_split of bdh_split - | Prwprgm of rwprgm | Pprocrewrite of side option * pcodepos * prrewrite - | Pchangestmt of side option * pcodepos_range * pstmt + | Pchangestmt of side option * ptybindings option * pcodepos_range * pstmt (* Eager *) @@ -797,8 +828,20 @@ type phltactic = | Pauto | Plossless + (* Map-reduce *) + | Pcircuit of circuit_mode + + (* Program rewriting *) + | Prwprgm of rwprgm + and rwprgm = [ | `IdAssign of pcodepos * pqsymbol + | `Change of pcodepos * ptybindings option * int * pstmt +] + +and circuit_mode = [ + | `Simplify + | `Solve ] (* -------------------------------------------------------------------- *) @@ -1016,6 +1059,7 @@ and ptactic_core_r = | Por of ptactic * ptactic | Pseq of ptactics | Pcase of (bool * pcaseoptions * prevertv) + | Pextens of (ptactic_core * psymbol option) | Plogic of logtactic | PPhl of phltactic | Pprogress of ppgoptions * ptactic_core option @@ -1274,6 +1318,45 @@ type puserred = type threquire = psymbol option * (psymbol * psymbol option) list * [`Import|`Export] option +(* -------------------------------------------------------------------- *) +type pbind_bitstring = + { from_ : pqsymbol + ; to_ : pqsymbol + ; touint : pqsymbol + ; tosint : pqsymbol + ; ofint : pqsymbol + ; type_ : pty + ; size : pformula } + +(* -------------------------------------------------------------------- *) +type pbind_array = + { get : pqsymbol + ; set : pqsymbol + ; tolist : pqsymbol + ; oflist : pqsymbol + ; type_ : pqsymbol + ; size : pformula } + +(* -------------------------------------------------------------------- *) +type pbind_bvoperator = + { name : string located + ; types : pqsymbol list + ; operator : pqsymbol } + +(* -------------------------------------------------------------------- *) +type pbind_circuit = + { bindings : (pqsymbol * string located) list } + +(* -------------------------------------------------------------------- *) +type pcrbinding_r = + | CRB_Bitstring of pbind_bitstring + | CRB_Array of pbind_array + | CRB_BvOperator of pbind_bvoperator + | CRB_Circuit of pbind_circuit + +(* -------------------------------------------------------------------- *) +type pcrbinding = { locality : is_local; binding : pcrbinding_r } + (* -------------------------------------------------------------------- *) type global_action = | Gmodule of pmodule_def_or_decl @@ -1313,6 +1396,7 @@ type global_action = | Gpragma of psymbol | Goption of (psymbol * [`Bool of bool | `Int of int]) | GdumpWhy3 of string + | Gcrbinding of pcrbinding type global = { gl_action : global_action located; diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index a9f63997db..2e0d94e757 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -3656,6 +3656,80 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = level (odfl "" base) (pp_list "@ " (pp_axhnt ppe)) axioms + | EcTheory.Th_crbinding (binding, lc) -> begin + match binding with + | CRB_Bitstring bs -> + Format.fprintf fmt "%abind bitstring %a %a %a %a%s." + pp_locality lc + (pp_opname ppe) bs.to_ + (pp_opname ppe) bs.from_ + (pp_tyname ppe) bs.type_ + (pp_form ppe) (fst bs.size) + (if Option.is_some (snd bs.size) then " (concrete)" else " (abstract)") + + | CRB_Array ba -> + Format.fprintf fmt "%abind array %a %a %a %a %a %a%s." + pp_locality lc + (pp_tyname ppe) ba.type_ + (pp_opname ppe) ba.get + (pp_opname ppe) ba.set + (pp_opname ppe) ba.tolist + (pp_opname ppe) ba.oflist + (pp_form ppe) (fst ba.size) + (if Option.is_some (snd ba.size) then " (concrete)" else " (abstract)") + + | CRB_BvOperator op -> + let kind = + match op.kind with + | `Add _ -> "add" + | `Sub _ -> "sub" + | `Mul _ -> "mul" + | `Div (_, false) -> "udiv" + | `Div (_, true ) -> "sdiv" + | `Rem (_, false) -> "urem" + | `Rem (_, true ) -> "srem" + | `Shl _ -> "shl" + | `Shls _ -> "shls" + | `Rol _ -> "rol" + | `Ror _ -> "ror" + | `Shr (_, false) -> "shr" + | `Shr (_, true ) -> "ashr" + | `Shrs (_, _, false) -> "shrs" + | `Shrs (_, _, true ) -> "ashrs" + | `Not _ -> "not" + | `Opp _ -> "opp" + | `And _ -> "and" + | `Or _ -> "or" + | `Xor _ -> "xor" + | `Lt (_, false) -> "ult" + | `Lt (_, true ) -> "slt" + | `Le (_, false) -> "ule" + | `Le (_, true ) -> "sle" + | `Init _ -> "init" + | `Get _ -> "get" + | `AInit _ -> "ainit" + | `Extend (_, _, false) -> "zextend" + | `Extend (_, _, true ) -> "sextend" + | `Extract _ -> "extract" + | `Insert _ -> "insert" + | `Concat _ -> "concat" + | `Truncate _ -> "truncate" + | `A2B _ -> "a2b" + | `B2A _ -> "b2a" + | `Map _ -> "map" + | `ASliceGet _ -> "asliceget" + | `ASliceSet _ -> "asliceset" + in + Format.fprintf fmt "%abind op [%a] %a \"%s\"." + pp_locality lc + (pp_list " & " (pp_tyname ppe)) op.types + (pp_opname ppe) op.operator + kind + + | CRB_Circuit cr -> + Format.fprintf fmt "%abind circuit %a \"%s\"." + pp_locality lc (pp_opname ppe) cr.operator cr.name + end | EcTheory.Th_alias (name, target) -> Format.fprintf fmt "theory %s = %a." name (pp_thname ~alias:false ppe) target diff --git a/src/ecScope.ml b/src/ecScope.ml index d8a4676f14..3ee0cd9bba 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -339,6 +339,7 @@ type scope = { sc_options : GenOptions.options; sc_globdoc : string list; sc_locdoc : docstate; + sc_specs : string list; } and docstate = { @@ -449,7 +450,8 @@ let empty (gstate : EcGState.gstate) = sc_pr_uc = None; sc_options = GenOptions.freeze (); sc_globdoc = []; - sc_locdoc = DocState.empty; } + sc_locdoc = DocState.empty; + sc_specs = []; } (* -------------------------------------------------------------------- *) let env (scope : scope) = @@ -570,7 +572,8 @@ let for_loading (scope : scope) = sc_pr_uc = None; sc_options = GenOptions.for_loading scope.sc_options; sc_globdoc = []; - sc_locdoc = DocState.empty; } + sc_locdoc = DocState.empty; + sc_specs = scope.sc_specs; } (* FIXME: is this correct? *) (* -------------------------------------------------------------------- *) let subscope (scope : scope) (mode : EcTheory.thmode) (name : symbol) lc = @@ -587,6 +590,7 @@ let subscope (scope : scope) (mode : EcTheory.thmode) (name : symbol) lc = sc_options = GenOptions.for_subscope scope.sc_options; sc_globdoc = []; sc_locdoc = DocState.empty; + sc_specs = scope.sc_specs; } (* -------------------------------------------------------------------- *) @@ -2260,7 +2264,11 @@ module Ty = struct record.ELI.rc_tparams, `Record (scheme, record.ELI.rc_fields) in - bind scope (unloc name, { tyd_params; tyd_type; tyd_loca; }) + let tydecl = + { tyd_params; tyd_type; tyd_loca; + tyd_clinline = false; } in + + bind scope (unloc name, tydecl) (* ------------------------------------------------------------------ *) let add_subtype (scope : scope) ({ pl_desc = subtype } : psubtype located) = @@ -2269,9 +2277,10 @@ module Ty = struct let scope = let decl = EcDecl.{ - tyd_params = []; - tyd_type = `Abstract Sp.empty; - tyd_loca = `Global; (* FIXME:SUBTYPE *) + tyd_params = []; + tyd_type = `Abstract Sp.empty; + tyd_loca = `Global; (* FIXME:SUBTYPE *) + tyd_clinline = false; (* FIXME: tyd_clinline PR *) } in bind scope (unloc subtype.pst_name, decl) in let carrier = @@ -2364,9 +2373,10 @@ module Ty = struct let asty = let body = ofold (fun p tc -> Sp.add p tc) Sp.empty uptc in - { tyd_params = []; - tyd_type = `Abstract body; - tyd_loca = (lc :> locality); } in + { tyd_params = []; + tyd_type = `Abstract body; + tyd_loca = (lc :> locality); + tyd_clinline = false; } in let scenv = EcEnv.Ty.bind name asty scenv in (* Check for duplicated field names *) @@ -2691,7 +2701,518 @@ module Ty = struct failwith "unsupported" (* FIXME *) end -(* -------------------------------------------------------------------- *)module Search = struct +(* -------------------------------------------------------------------- *) +module Circuit = struct + type preoperator = [`Path of path | `Form of pformula] + + type clone = { + path : EcPath.path; + name : symbol; + local : is_local; + theories : (symbol * path) list; + types_ : (symbol * path) list; + operators : (symbol * preoperator) list; + proofs : symbol list; + } + + let doclone (scope : scope) (clone : clone) = + let loced x = mk_loc _dummy x in + let env = env scope in + + let evclone = + let do_type ((x, type_) : symbol * path) : symbol * ty_override located = + (x, loced (`ByPath type_, `Inline `Keep)) in + + let do_operator ((x, operator) : symbol * preoperator) : symbol * op_override located = + let operator = + match operator with + | `Path name -> `ByPath name + | `Form f -> + `BySyntax + { opov_tyvars = None + ; opov_args = [] + ; opov_retty = loced PTunivar + ; opov_body = f } + in (x, loced (operator, `Inline `Keep)) + in + + let do_theory (x : symbol) (theory : path) : EcThCloning.evclone = + let thenv = EcEnv.Theory.env_of_theory clone.path env in + let atheory = EcEnv.Theory.by_path (pqname clone.path x) thenv in + + List.fold_left (fun (evc : EcThCloning.evclone) (item : EcTheory.theory_item) -> + match item.ti_item with + | Th_operator (x, opdecl) -> begin + match opdecl.op_kind with + | OB_oper None -> + let ovrd = (`ByPath (pqname theory x), `Inline `Clear) in + { evc with evc_ops = Msym.add x (loced ovrd) evc.evc_ops } + | _ -> evc + end + | Th_type (x, _) -> + let ovrd = (`ByPath (pqname theory x), `Inline `Clear) in + { evc with evc_types = Msym.add x (loced ovrd) evc.evc_types } + | Th_axiom (x, _) -> + let evc_lemmas = + let proof = loced (EcPath.toqsymbol (pqname theory x)) in + let proof = Papply (`ExactType proof, None) in + let proof = loced (Plogic proof) in + let proof = (Some proof, `Inline `Clear, false) in + { evc.evc_lemmas with + ev_bynames = Msym.add x proof evc.evc_lemmas.ev_bynames } + in { evc with evc_lemmas } + | _ -> assert false + ) EcThCloning.evc_empty atheory.cth_items in + + { EcThCloning.evc_empty with + (* FIXME: PR: what to do here? *) + evc_types = (Msym.of_list (List.map do_type clone.types_) :> (EcThCloning.xty_override located MSym.t)); + (* FIXME: PR: what to do here? *) + evc_ops = (Msym.of_list (List.map do_operator clone.operators) :> (EcThCloning.xop_override located MSym.t)); + evc_ths = Msym.of_list (List.map (fun (x, th) -> (x, (do_theory x th, false))) clone.theories); (* FIXME PR: is the false here correct? *) + evc_lemmas = { + ev_bynames = + clone.proofs + |> List.map (fun name -> (name, (Some (loced (Ptry (loced (Pby None)))), `Alias, false))) + |> Msym.of_list; + ev_global = + (* FIXME PR: get this to work *) + [ +(* (Some (loced (Pby None)), Some [`Include, "bydone"]) *) + (None, None) + ; (None, None) ]; } } in + + let npath = EcPath.pqname (EcEnv.root env) clone.name in + let theory = EcEnv.Theory.by_path clone.path env in + + let (proofs, scope) = + EcTheoryReplay.replay (Cloning.hooks ~override_locality:(Some clone.local)) + ~abstract:false ~override_locality:(Some clone.local) ~incl:false + ~clears:Sp.empty ~renames:[] ~opath:clone.path ~npath + evclone scope (EcPath.basename npath, false, theory.cth_items, clone.local) (* FIXME PR: check extra arguments here *) + in + + let proofs = Cloning.replay_proofs scope `Check proofs in + + (proofs, scope) + + let add_bitstring (scope : scope) (local : is_local) (bs : pbind_bitstring) : scope = + let env = env scope in + + let type_ = + let ue = EcUnify.UniEnv.create None in + let ty = EcTyping.transty tp_tydecl env ue bs.type_ in + assert (EcUnify.UniEnv.closed ue); + ty_subst (Tuni.subst (EcUnify.UniEnv.close ue)) ty in + + let bspath = + match (EcEnv.ty_hnorm type_ env).ty_node with + | Tconstr (p, []) -> p + | _ -> + hierror ~loc:(bs.type_.pl_loc) + "bit-string type must be a monomorphic named type" in + + let from_, _ = EcEnv.Op.lookup bs.to_.pl_desc env in + let to_ , _ = EcEnv.Op.lookup bs.from_.pl_desc env in + let touint, _ = EcEnv.Op.lookup bs.touint.pl_desc env in + let tosint, _ = EcEnv.Op.lookup bs.tosint.pl_desc env in + let ofint, _ = EcEnv.Op.lookup bs.ofint.pl_desc env in + let name = String.concat "_" ("BVA" :: EcPath.tolist bspath) (* FIXME: not stable*) in + + let preclone = + { path = EcPath.fromqsymbol (["Top"; "QFABV"], "BV") + ; name = name + ; local = local + ; theories = [] + ; types_ = ["bv", bspath] + ; operators = + [ ("size" , `Form bs.size) + ; ("tolist", `Path to_) + ; ("oflist", `Path from_) + ; ("touint", `Path touint) + ; ("tosint", `Path tosint) + ; ("ofint" , `Path ofint) ] + ; proofs = [] } in + + let proofs, scope = doclone scope preclone in + + let size_f = EcTyping.trans_form env (EcUnify.UniEnv.create None) bs.size tint in + let size_i = try + Some (EcCallbyValue.norm_cbv EcReduction.full_red (EcEnv.LDecl.init env []) size_f |> destr_int |> BI.to_int) + with + | DestrError "destr_int" -> None + | EcEnv.NotReducible -> None + in + + let item = CRB_Bitstring + { from_; to_; touint; tosint; ofint; + type_ = bspath; + size = (size_f, size_i); + theory = pqname (EcEnv.root env) name; } in + + let item = EcTheory.mkitem ~import:true (EcTheory.Th_crbinding (item, local)) in + + let scope = { scope with sc_env = EcSection.add_item item scope.sc_env } in + + Ax.add_defer scope proofs + + let add_array (scope : scope) (local : is_local) (ba : pbind_array) : scope = + let env = env scope in + + let bspath = + match EcEnv.Ty.lookup_opt (unloc ba.type_) env with + | None -> + hierror ~loc:(loc ba.type_) + "cannot find named type: `%s'" + (string_of_qsymbol (unloc ba.type_)) + + | Some (path, decl) -> (* FIXME: normalize? *) + if List.length decl.tyd_params <> 1 then + hierror ~loc:(loc ba.type_) + "type constructor should take exactly one parameter: `%s'" + (string_of_qsymbol (unloc ba.type_)); + path in + + let get , _ = EcEnv.Op.lookup ba.get.pl_desc env in + let set , _ = EcEnv.Op.lookup ba.set.pl_desc env in + let tolist, _ = EcEnv.Op.lookup ba.tolist.pl_desc env in + let oflist, _ = EcEnv.Op.lookup ba.oflist.pl_desc env in + let name = String.concat "_" ("BVA" :: EcPath.tolist bspath) in + + let preclone = + { path = EcPath.fromqsymbol (["Top"; "QFABV"], "A") + ; name = name + ; local = local + ; theories = [] + ; types_ = ["t", bspath] + ; operators = + [ ("size" , `Form ba.size) + ; ("get" , `Path get) + ; ("set" , `Path set) + ; ("to_list", `Path tolist) + ; ("of_list", `Path oflist) ] + ; proofs = [] } in + + let proofs, scope = doclone scope preclone in + + let size_f = EcTyping.trans_form env (EcUnify.UniEnv.create None) ba.size tint in + let size_i = try + Some (EcCallbyValue.norm_cbv EcReduction.full_red (EcEnv.LDecl.init env []) size_f |> destr_int |> BI.to_int) + with + | DestrError "destr_int" -> None + | EcEnv.NotReducible -> None + in + + let item = CRB_Array + { get; set; tolist; oflist; + type_ = bspath; + size = (size_f, size_i); + theory = pqname (EcEnv.root env) name; } in + + let item = EcTheory.mkitem ~import:true (Th_crbinding (item, local)) in + + let scope = { scope with sc_env = EcSection.add_item item scope.sc_env } in + + Ax.add_defer scope proofs + + let add_bvoperator (scope : scope) (local : is_local) (op : pbind_bvoperator) : scope = + let env = env scope in + + let (kind, sig_, subname) : (_ -> EcDecl.bv_opkind) * _ * _ = + match unloc op.name with + | "add" -> (fun sz -> `Add (as_seq1 sz )), [`BV None], "Add" + | "sub" -> (fun sz -> `Sub (as_seq1 sz )), [`BV None], "Sub" + | "mul" -> (fun sz -> `Mul (as_seq1 sz )), [`BV None], "Mul" + | "udiv" -> (fun sz -> `Div (as_seq1 sz, false)), [`BV None], "UDiv" + | "sdiv" -> (fun sz -> `Div (as_seq1 sz, true )), [`BV None], "SDiv" + | "urem" -> (fun sz -> `Rem (as_seq1 sz, false)), [`BV None], "URem" + | "srem" -> (fun sz -> `Rem (as_seq1 sz, true )), [`BV None], "SRem" + | "shl" -> (fun sz -> `Shl (as_seq1 sz )), [`BV None], "SHL" + | "rol" -> (fun sz -> `Rol (as_seq1 sz )), [`BV None], "ROL" + | "ror" -> (fun sz -> `Ror (as_seq1 sz )), [`BV None], "ROR" + | "shr" -> (fun sz -> `Shr (as_seq1 sz, false)), [`BV None], "SHR" + | "ashr" -> (fun sz -> `Shr (as_seq1 sz, true )), [`BV None], "ASHR" + | "and" -> (fun sz -> `And (as_seq1 sz )), [`BV None], "And" + | "or" -> (fun sz -> `Or (as_seq1 sz )), [`BV None], "Or" + | "xor" -> (fun sz -> `Xor (as_seq1 sz )), [`BV None], "Xor" + | "not" -> (fun sz -> `Not (as_seq1 sz )), [`BV None], "Not" + | "opp" -> (fun sz -> `Opp (as_seq1 sz )), [`BV None], "Opp" + + | "ult" -> (fun sz -> `Lt (snd (as_seq2 sz), false)), [`BV (Some 1); `BV None], "ULt" + | "slt" -> (fun sz -> `Lt (snd (as_seq2 sz), true )), [`BV (Some 1); `BV None], "SLt" + | "ule" -> (fun sz -> `Le (snd (as_seq2 sz), false)), [`BV (Some 1); `BV None], "ULe" + | "sle" -> (fun sz -> `Le (snd (as_seq2 sz), true )), [`BV (Some 1); `BV None], "SLe" + + | "init" -> (fun sz -> `Init (snd (as_seq2 sz))), [`BV (Some 1); `BV None], "Init" + | "get" -> (fun sz -> `Get (fst (as_seq2 sz))), [`BV None; `BV (Some 1)], "Get" + + | "ainit" -> (fun sz -> `AInit (as_seq2 (sz |> List.rev))), [`BV None; `A], "AInit" + + | "shls" -> + let mk sz = let sz1, sz2 = as_seq2 sz in `Shls (sz1, sz2) in + mk, [`BV None; `BV None], "SHLS" + + | "shrs" -> + let mk sz = let sz1, sz2 = as_seq2 sz in `Shrs (sz1, sz2, false) in + mk, [`BV None; `BV None], "SHRS" + + | "ashrs" -> + let mk sz = let sz1, sz2 = as_seq2 sz in `Shrs (sz1, sz2, true) in + mk, [`BV None; `BV None], "ASHRS" + + | "zextend" -> + let mk sz = let sz1, sz2 = as_seq2 sz in `Extend (sz1, sz2, false) in + mk, [`BV None; `BV None], "ZExtend" + + | "sextend" -> + let mk sz = let sz1, sz2 = as_seq2 sz in `Extend (sz1, sz2, true) in + mk, [`BV None; `BV None], "SExtend" + + | "truncate" -> + let mk sz = let sz1, sz2 = as_seq2 sz in `Truncate (sz1, sz2) in + mk, [`BV None; `BV None], "Truncate" + + | "insert" -> + let mk sz = let sz1, sz2 = as_seq2 sz in `Insert (sz1, sz2) in + mk, [`BV None; `BV None], "Insert" + + | "extract" -> + let mk sz = let sz1, sz2 = as_seq2 sz in `Extract (sz1, sz2) in + mk, [`BV None; `BV None], "Extract" + + | "asliceget" -> + let mk sz = let sz1, sz2, arr_sz = as_seq3 sz in `ASliceGet ((arr_sz, sz1), sz2) in + mk, [`BV None; `BV None; `A], "ASliceGet" + + | "asliceset" -> + let mk sz = let sz1, sz2, arr_sz = as_seq3 sz in `ASliceSet ((arr_sz, sz1), sz2) in + mk, [`BV None; `BV None; `A], "ASliceSet" + + | "concat" -> + let mk sz = let sz1, sz2, sz3 = as_seq3 sz in `Concat (sz1, sz2, sz3) in + mk, [`BV None; `BV None; `BV None], "Concat" + + | "a2b" -> + let mk sz = + let sz1, sz2, asz = as_seq3 sz in `A2B ((sz2, asz), sz1) in + mk, [`BV None; `BV None; `A], "A2B" + + | "b2a" -> + let mk sz = + let sz1, sz2, asz = as_seq3 sz in `B2A (sz1, (sz2, asz)) in + mk, [`BV None; `BV None; `A], "B2A" + + | "map" -> + let mk sz = + let sz1, sz2, asz = as_seq3 sz in `Map (sz1, sz2, asz) in + mk, [`BV None; `BV None; `A], "Map" + + | _ -> + hierror ~loc:(loc op.name) + "invalid bv operator name: %s" (unloc op.name) in + + if List.compare_lengths sig_ op.types <> 0 then + hierror ~loc:(loc op.operator) + "%d type(s) should be provided" (List.length sig_); + + let check_type (mode : [`BV of int option | `A]) (ty : pqsymbol) = + let path = + match EcEnv.Ty.lookup_opt (unloc ty) env, mode with + | None, _ -> + hierror ~loc:(loc ty) + "cannot find named type: `%s'" + (string_of_qsymbol (unloc ty)) + + | Some (path, decl), `BV _ -> (* FIXME: normalize? *) + if List.length decl.tyd_params <> 0 then + hierror ~loc:(loc ty) + "a bit-string type must be a monomorphic named type"; + path + + | Some (path, decl), `A -> + if List.length decl.tyd_params <> 1 then + hierror ~loc:(ty.pl_loc) + "an array type must be a 1-polymorphic named type"; + path + in + + let (size, theory) = + match mode with + | `BV osize -> begin + match EcEnv.Circuit.lookup_bitstring_path env path with + | None -> + hierror ~loc:(ty.pl_loc) + "this type is not bound to a bitstring type" + | Some {size = (_ , Some csize) as size; theory} -> + osize |> Option.iter (fun osize -> + if osize <> csize then + hierror ~loc:(ty.pl_loc) + "this type is not bound to a bitstring type of size %d (but of size %d)" + osize csize + ); + (size, theory) + | Some { size = (_, None) as size; theory} -> + osize |> Option.iter (fun osize -> + hierror ~loc:(ty.pl_loc) + "This type is not bound to a concrete bitstring of size %d (it is abstract)" + osize + ); + (size, theory) + end + | `A -> begin + match EcEnv.Circuit.lookup_array_path env path with + | None -> + hierror ~loc:(ty.pl_loc) + "this type is not bound to an array type" + | Some ba -> (ba.size, ba.theory) + end + in (path, size, (mode, theory)) + + in + + let types = List.map2 check_type sig_ op.types in + let subname = "BV" ^ subname in + + let operator, _ = EcEnv.Op.lookup op.operator.pl_desc env in + let name = + let suffix = List.map (EcPath.tolist |- proj3_1) types in + let suffix = List.flatten suffix in + String.concat "_" ("BVA" :: unloc op.name :: suffix) (* FIXME: not stable*) in + + let _, cltheories = + let string_of_mode = function `A -> "A" | `BV -> "BV" in + let strip_mode_arg = function `A -> `A | `BV _ -> `BV in + + let counts0 = + [`A; `BV] + |> List.to_seq + |> Seq.map (fun mode -> (mode, 0)) + |> BatMap.of_seq in + + let maxs = + List.fold_left (fun counts mode -> + let mode = strip_mode_arg mode in + BatMap.modify mode ((+) 1) counts + ) counts0 sig_ in + + List.fold_left_map (fun counts (_, _, (mode, theory)) -> + let mode = strip_mode_arg mode in + let prefix = string_of_mode mode in + + let counts, name = + if BatMap.find mode maxs < 2 then + (counts, prefix) + else + let counts = BatMap.modify mode ((+) 1) counts in + let name = Format.sprintf "%s%d" prefix (BatMap.find mode counts) in + (counts, name) + in (counts, (name, theory)) + ) counts0 types in + + let preclone = + { path = EcPath.fromqsymbol (["Top"; "QFABV"; "BVOperators"], subname) + ; name = name + ; local = local + ; theories = cltheories + ; types_ = [] + ; operators = ["bv" ^ unloc op.name, `Path operator] + ; proofs = [] } in + + let proofs, scope = doclone scope preclone in + + let item = CRB_BvOperator + { kind = kind (List.map proj3_2 types); + types = List.map proj3_1 types; + operator = operator; + theory = EcPath.pqname (EcEnv.root env) subname; } in + + let item = EcTheory.mkitem ~import:true (Th_crbinding (item, local)) in + + let scope = + { scope with sc_env = EcSection.add_item item scope.sc_env } in + + Ax.add_defer scope proofs + + (* FIXME CIRCUIT PR: decide how we want to handle multiple spec files in easycrypt.project(s) *) + let add_circuit1 (scope : scope) (local : is_local) ((op, circ) : (pqsymbol * string located)) : scope = + let env = env scope in + let operator, opdecl = EcEnv.Op.lookup op.pl_desc env in + + if not (List.is_empty opdecl.op_tparams) then + hierror ~loc:(loc op) "operator must be monomorphic"; + + let matches = List.filteri_map (fun i filename -> + EcEnv.Circuit.get_specification_by_name ~filename env (unloc circ)) scope.sc_specs + in + + match matches with + | [] -> + hierror ~loc:(loc circ) + "unknown circuit: %s" (unloc circ) + + | circuit::[] -> + let sig_ = List.map (fun (_, `W i) -> i) circuit.arguments in + let ret = Lospecs.Ast.get_size circuit.rettype in + let dom, codom = EcEnv.Ty.decompose_fun opdecl.op_ty env in + + if List.length dom <> List.length sig_ then + hierror ~loc:(loc op) + "the given operator must take %d arguments" + (List.length sig_); + + List.iteri (fun position (ty, size) -> + match EcEnv.Circuit.lookup_bitstring env ty with + | Some {size = (_, Some bs_size)} when bs_size = size -> () + | Some {size = (_, bs_size)} -> + let ppe = EcPrinting.PPEnv.ofenv env in + hierror ~loc:(loc op) + "%d-th argument (of type %a) must be a bitstring of size %d, not %s" + (position + 1) (EcPrinting.pp_type ppe) ty + size (Option.value (Option.map string_of_int bs_size) ~default:("abstract")) + | None -> + let ppe = EcPrinting.PPEnv.ofenv env in + hierror ~loc:(loc op) + "%d-th argument (of type %a) must be a bitstring" + (position + 1) (EcPrinting.pp_type ppe) ty + ) (List.combine dom sig_); + + begin + match EcEnv.Circuit.lookup_bitstring env codom with + | Some {size = (_, Some bs_size)} when bs_size = ret -> () + | Some {size = (_, bs_size)} -> + let ppe = EcPrinting.PPEnv.ofenv env in + hierror ~loc:(loc op) + "operator return type (%a) must be a bitstring of size %d, not %s" + (EcPrinting.pp_type ppe) codom ret + (Option.value (Option.map string_of_int bs_size) ~default:("abstract")) + | None -> + let ppe = EcPrinting.PPEnv.ofenv env in + hierror ~loc:(loc op) + "operator return type (%a) must be a bitstring of size %d" + (EcPrinting.pp_type ppe) codom ret + end; + + let item = CRB_Circuit { operator; circuit; name = unloc circ; } in + + let item = + EcTheory.mkitem ~import:true + (EcTheory.Th_crbinding (item, local)) in + { scope with sc_env = EcSection.add_item item scope.sc_env } + | circs -> Format.eprintf "Multiple matches found (%d) for circuit %s" (List.length circs) (unloc circ); assert false + (* FIXME *) + + (* FIXME: Decide if we want set or append here *) + let register_spec_files (scope : scope) (files : string list) : scope = + { scope with sc_specs = files } + + let add_circuits (scope : scope) (local : is_local) (binds : pbind_circuit) : scope = + List.fold_left (fun scope bnd -> + add_circuit1 scope local bnd) + scope binds.bindings +end + +(* -------------------------------------------------------------------- *) +module Search = struct let search (scope : scope) qs = let env = env scope in let paths = diff --git a/src/ecScope.mli b/src/ecScope.mli index d64007674c..9f916b17c9 100644 --- a/src/ecScope.mli +++ b/src/ecScope.mli @@ -266,6 +266,16 @@ module Reduction : sig val add_reduction : scope -> puserred -> scope end +(* -------------------------------------------------------------------- *) +module Circuit : sig + val add_bitstring : scope -> EcTypes.is_local -> pbind_bitstring -> scope + val add_array : scope -> EcTypes.is_local -> pbind_array -> scope + val add_bvoperator : scope -> EcTypes.is_local -> pbind_bvoperator -> scope + val add_circuits : scope -> EcTypes.is_local -> pbind_circuit -> scope + + val register_spec_files : scope -> string list -> scope +end + (* -------------------------------------------------------------------- *) module Cloning : sig val clone : scope -> Ax.proofmode -> theory_cloning -> scope diff --git a/src/ecSection.ml b/src/ecSection.ml index 51d65680d3..039b5108c6 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -22,6 +22,7 @@ type cbarg = [ | `ModuleType of path | `Typeclass of path | `Instance of tcinstance + | `Crbind of crbinding * is_local ] type cb = cbarg -> unit @@ -53,11 +54,20 @@ let pp_cbarg env fmt (who : cbarg) = Format.fprintf fmt "module type %a" (EcPrinting.pp_modtype1 ppe) mty | `Typeclass p -> Format.fprintf fmt "typeclass %a" (EcPrinting.pp_tcname ppe) p - | `Instance tci -> + | `Instance tci -> begin match tci with | `Ring _ -> Format.fprintf fmt "ring instance" | `Field _ -> Format.fprintf fmt "field instance" | `General _ -> Format.fprintf fmt "instance" + end + | `Crbind (CRB_Bitstring _, _) -> + Format.fprintf fmt "bitstring binding" + | `Crbind (CRB_Array _, _) -> + Format.fprintf fmt "array binding" + | `Crbind (CRB_BvOperator _, _) -> + Format.fprintf fmt "bitstring operator binding" + | `Crbind (CRB_Circuit _, _) -> + Format.fprintf fmt "circuit binding" let pp_locality fmt = function | `Local -> Format.fprintf fmt "local" @@ -593,6 +603,7 @@ let locality (env : EcEnv.env) (who : cbarg) = if EcEnv.Mod.is_declared id env then `Declare else `Global end | `ModuleType p -> ((EcEnv.ModTy.by_path p env).tms_loca :> locality) + | `Crbind (_, lc) -> (lc :> locality) | `Instance _ -> assert false (* -------------------------------------------------------------------- *) @@ -864,7 +875,8 @@ let generalize_tydecl to_gen prefix (name, tydecl) = let to_gen = { to_gen with tg_subst} in let tydecl = { tyd_params; tyd_type; - tyd_loca = `Global; } in + tyd_loca = `Global; + tyd_clinline = tydecl.tyd_clinline; } in to_gen, Some (Th_type (name, tydecl)) | `Declare -> @@ -1105,6 +1117,13 @@ let generalize_auto to_gen auto_rl = else to_gen, Some (Th_auto {auto_rl with axioms}) +let generalize_crbinding (to_gen : to_gen) ((bd, lc) : crbinding * is_local) = + (* FIXME: not complete? *) + let bd = EcSubst.subst_crbinding to_gen.tg_subst bd in + let item = + if lc = `Local then None else Some (Th_crbinding (bd, lc)) + in to_gen, item + (* --------------------------------------------------------------- *) let get_locality scenv = scenv.sc_loca @@ -1131,6 +1150,7 @@ let rec set_lc_item lc_override item = | Th_baserw (s,lc) -> Th_baserw (s, set_lc lc_override lc) | Th_addrw (p,ps,lc) -> Th_addrw (p, ps, set_lc lc_override lc) | Th_reduction r -> Th_reduction r + | Th_crbinding (bd, lc) -> Th_crbinding (bd, set_lc lc_override lc) | Th_auto auto_rl -> Th_auto {auto_rl with locality=set_lc lc_override auto_rl.locality} | Th_alias alias -> Th_alias alias @@ -1143,7 +1163,6 @@ and set_local_th lc_override th = let sc_decl_mod (id,mt) = SC_decl_mod (id,mt) (* ---------------------------------------------------------------- *) - let is_abstract_ty = function | `Abstract _ -> true | _ -> false @@ -1196,16 +1215,16 @@ let cd_glob = d_tc = [`Global]; } -let can_depend (cd : can_depend) = function +let can_depend (cd : can_depend) (who : cbarg) = + match who with | `Type _ -> cd.d_ty | `Op _ -> cd.d_op | `Ax _ -> cd.d_ax - | `Sc _ -> cd.d_sc | `Module _ -> cd.d_mod | `ModuleType _ -> cd.d_modty | `Typeclass _ -> cd.d_tc | `Instance _ -> assert false - + | `Crbind _ -> assert false (* FIXME *) let cb scenv from cd who = let env = scenv.sc_env in @@ -1371,6 +1390,47 @@ let check_instance scenv ty tci lc = let cd = { cd_glob with d_ty = [`Declare; `Global]; } in on_instance (mkaenv scenv.sc_env (cb scenv from cd)) ty tci +let check_crb_bitstring (scenv : scenv) ((bs, lc) : crb_bitstring * is_local) = + let from = (lc :> locality), `Crbind (CRB_Bitstring bs, lc) in + if lc = `Local then + check_section scenv from + else if scenv.sc_insec then begin + List.iter (fun p -> cb scenv from cd_glob (`Op p)) [bs.from_; bs.to_]; + cb scenv from cd_glob (`Type bs.type_) + end + +let check_crb_array (scenv : scenv) ((ba, lc) : crb_array * is_local) = + let from = (lc :> locality), `Crbind (CRB_Array ba, lc) in + if lc = `Local then + check_section scenv from + else if scenv.sc_insec then begin + List.iter (fun p -> cb scenv from cd_glob (`Op p)) [ba.get; ba.set; ba.tolist; ba.oflist]; + cb scenv from cd_glob (`Type ba.type_) + end + +let check_crb_bvoperator (scenv : scenv) ((op, lc) : crb_bvoperator * is_local) = + let from = (lc :> locality), `Crbind (CRB_BvOperator op, lc) in + if lc = `Local then + check_section scenv from + else if scenv.sc_insec then begin + cb scenv from cd_glob (`Op op.operator); + List.iter (fun ty -> cb scenv from cd_glob (`Type ty)) op.types + end + +let check_crb_circuit (scenv : scenv) ((cr, lc) : crb_circuit * is_local) = + let from = (lc :> locality), `Crbind (CRB_Circuit cr, lc) in + if lc = `Local then + check_section scenv from + else if scenv.sc_insec then + cb scenv from cd_glob (`Op cr.operator) + +let check_crbinding (scenv : scenv) ((crb, lc) : crbinding * is_local) = + match crb with + | CRB_Bitstring bs -> check_crb_bitstring scenv (bs, lc) + | CRB_Array ba -> check_crb_array scenv (ba, lc) + | CRB_BvOperator op -> check_crb_bvoperator scenv (op, lc) + | CRB_Circuit cr -> check_crb_circuit scenv (cr, lc) + (* -----------------------------------------------------------*) let enter_theory (name:symbol) (lc:is_local) (mode:thmode) scenv : scenv = if not scenv.sc_insec && lc = `Local then @@ -1409,6 +1469,8 @@ let add_item_ ?(override_locality=None) (item : theory_item) (scenv:scenv) = | Th_module me -> EcEnv.Mod.bind ~import me.tme_expr.me_name me env | Th_typeclass(s,tc) -> EcEnv.TypeClass.bind ~import s tc env | Th_export (p, lc) -> EcEnv.Theory.export p lc env + | Th_crbinding (bd, lc) -> EcEnv.Circuit.bind_crbinding lc bd env + | Th_theory _ -> assert false | Th_instance (tys,i,lc) -> EcEnv.TypeClass.add_instance ~import tys i lc env (*FIXME: import? *) | Th_baserw (s,lc) -> EcEnv.BaseRw.add ~import s lc env | Th_addrw (p,ps,lc) -> EcEnv.BaseRw.addto ~import p ps lc env @@ -1417,7 +1479,6 @@ let add_item_ ?(override_locality=None) (item : theory_item) (scenv:scenv) = auto.axioms auto.locality env | Th_alias (n,p) -> EcEnv.Theory.alias ~import n p env | Th_reduction r -> EcEnv.Reduction.add ~import r env - | _ -> assert false in (item, { scenv with sc_env = env; @@ -1431,6 +1492,7 @@ let add_th ~import (cth : EcEnv.Theory.compiled_theory) scenv = let rec generalize_th_item (to_gen : to_gen) (prefix : path) (th_item : theory_item) = let to_gen, item = match th_item.ti_item with + | Th_crbinding (bd, lc) -> generalize_crbinding to_gen (bd, lc) | Th_type tydecl -> generalize_tydecl to_gen prefix tydecl | Th_operator opdecl -> generalize_opdecl to_gen prefix opdecl | Th_axiom ax -> generalize_axiom to_gen prefix ax @@ -1445,7 +1507,6 @@ let rec generalize_th_item (to_gen : to_gen) (prefix : path) (th_item : theory_i | Th_reduction rl -> generalize_reduction to_gen rl | Th_auto hints -> generalize_auto to_gen hints | Th_alias _ -> (to_gen, None) (* FIXME:ALIAS *) - in let scenv = @@ -1552,7 +1613,8 @@ let check_item scenv item = | Th_auto { locality } -> if (locality = `Local && not scenv.sc_insec) then hierror "local hint can only be declared inside section"; - | Th_reduction _ -> () + | Th_reduction _ -> () (* FIXME *) + | Th_crbinding (crb, lc) -> check_crbinding scenv (crb, lc) | Th_theory _ -> assert false | Th_alias _ -> () (* FIXME:ALIAS *) diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 45bdb2f747..6b22d34938 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -862,9 +862,10 @@ let subst_tydecl (s : subst) (tyd : tydecl) = let s, tparams = fresh_tparams s tyd.tyd_params in let body = subst_tydecl_body s tyd.tyd_type in - { tyd_params = tparams; - tyd_type = body; - tyd_loca = tyd.tyd_loca; } + { tyd_params = tparams; + tyd_type = body; + tyd_loca = tyd.tyd_loca; + tyd_clinline = tyd.tyd_clinline; } (* -------------------------------------------------------------------- *) let rec subst_op_kind (s : subst) (kind : operator_kind) = @@ -1014,6 +1015,101 @@ let subst_tc (s : subst) tc = let tc_axs = List.map (snd_map (subst_form s)) tc.tc_axs in { tc_prt; tc_ops; tc_axs; tc_loca = tc.tc_loca } +let subst_binding_size ?(red: (form -> int option) option) (s: subst) (bsize: binding_size) = + (* FIXME: add reduction? *) + let fsize = subst_form s (fst bsize) in + let csize = match red with + | Some red when Option.is_none (snd bsize) -> red fsize + | _ -> (snd bsize) + in (fsize, csize) + +let subst_bv_opkind ?(red: (form -> int option) option) (s: subst) (opk: bv_opkind) = + let ssize = subst_binding_size ?red s in + match opk with + | `Extend (s1, s2, sgn) -> `Extend (ssize s1, ssize s2, sgn) + | `Rem (s, sgn) -> `Rem (ssize s, sgn) + | `Div (s, sgn) -> `Div (ssize s, sgn) + | `Add (s) -> `Add (ssize s) + | `Lt (s, sgn) -> `Lt (ssize s, sgn) + | `Shl (s) -> `Shl (ssize s) + | `Shls (s1, s2) -> `Shls (ssize s1, ssize s2) + | `ASliceSet ((s1, s2), s3) -> `ASliceSet ((ssize s1, ssize s2), ssize s3) + | `And s -> `And (ssize s) + | `Extract (s1, s2) -> `Extract (ssize s1, ssize s2) + | `Map (s1, s2, s3) -> `Map (ssize s1, ssize s2, ssize s3) + | `AInit (s1, s2) -> `AInit (ssize s1, ssize s2) + | `Sub s -> `Sub (ssize s) + | `Get s -> `Get (ssize s) + | `Ror s -> `Ror (ssize s) + | `Le (s, sgn) -> `Le (ssize s, sgn) + | `Concat (s1, s2, s3) -> `Concat (ssize s1, ssize s2, ssize s3) + | `Truncate (s1, s2) -> `Truncate (ssize s1, ssize s2) + | `Not (s) -> `Not (ssize s) + | `Opp (s) -> `Opp (ssize s) + | `Or (s) -> `Or (ssize s) + | `Init (s) -> `Init (ssize s) + | `Insert (s1, s2) -> `Insert (ssize s1, ssize s2) + | `Xor (s) -> `Xor (ssize s) + | `Shr (s, sgn) -> `Shr (ssize s, sgn) + | `Shrs (s1, s2, sgn) -> `Shrs (ssize s1, ssize s2, sgn) + | `Mul (s) -> `Mul (ssize s) + | `Rol (s) -> `Rol (ssize s) + | `A2B ((s1, s2), s3) -> `A2B ((ssize s1, ssize s2), ssize s3) + | `ASliceGet ((s1, s2), s3) -> `ASliceGet ((ssize s1, ssize s2), ssize s3) + | `B2A (s1, (s2, s3)) -> `B2A (ssize s1, (ssize s2, ssize s3)) + +(* -------------------------------------------------------------------- *) +let subst_crbinding ?(red: (form -> int option) option) (s : subst) (crb : crbinding) = + match crb with + | CRB_Bitstring bs -> + assert (not (Mp.mem bs.type_ s.sb_tydef)); + assert (not (Mp.mem bs.from_ s.sb_def)); + assert (not (Mp.mem bs.to_ s.sb_def)); + assert (not (Mp.mem bs.touint s.sb_def)); + assert (not (Mp.mem bs.tosint s.sb_def)); + assert (not (Mp.mem bs.ofint s.sb_def)); + (* FIXME : maybe add an assert here? *) + CRB_Bitstring { + type_ = subst_path s bs.type_; + from_ = subst_path s bs.from_; + to_ = subst_path s bs.to_; + touint = subst_path s bs.touint; + tosint = subst_path s bs.tosint; + ofint = subst_path s bs.ofint; + size = subst_binding_size ?red s bs.size; + theory = subst_path s bs.theory; } + + | CRB_Array ba -> + assert (not (Mp.mem ba.type_ s.sb_tydef)); + assert (not (Mp.mem ba.get s.sb_def)); + assert (not (Mp.mem ba.set s.sb_def)); + assert (not (Mp.mem ba.tolist s.sb_def)); + assert (not (Mp.mem ba.oflist s.sb_def)); + CRB_Array { + type_ = subst_path s ba.type_; + get = subst_path s ba.get; + set = subst_path s ba.set; + tolist = subst_path s ba.tolist; + oflist = subst_path s ba.oflist; + size = subst_binding_size ?red s ba.size; + theory = subst_path s ba.theory } + + | CRB_BvOperator op -> + assert (List.for_all (fun ty -> not (Mp.mem ty s.sb_tydef)) op.types); + assert (not (Mp.mem op.operator s.sb_def)); + CRB_BvOperator { + kind = subst_bv_opkind ?red s op.kind; + types = List.map (subst_path s) op.types; + operator = subst_path s op.operator; + theory = subst_path s op.theory; } + + | CRB_Circuit cr -> + assert (not (Mp.mem cr.operator s.sb_def)); + CRB_Circuit { + name = cr.name; + circuit = cr.circuit; + operator = subst_path s cr.operator; } + (* -------------------------------------------------------------------- *) (* SUBSTITUTION OVER THEORIES *) let rec subst_theory_item_r (s : subst) (item : theory_item_r) = @@ -1060,6 +1156,9 @@ let rec subst_theory_item_r (s : subst) (item : theory_item_r) = Th_auto { auto_rl with axioms = List.map (fst_map (subst_path s)) axioms } + | Th_crbinding (bd, lc) -> + Th_crbinding (subst_crbinding s bd, lc) + | Th_alias (name, target) -> Th_alias (name, subst_path s target) @@ -1181,4 +1280,4 @@ let ss_inv_forall_ml_ts_inv menvl inv = let ss_inv_forall_mr_ts_inv menvr inv = let inv' = f_forall_mems [menvr] (ts_inv_rebind_right inv (fst menvr)).inv in - { inv=inv'; m=inv.ml } \ No newline at end of file + { inv=inv'; m=inv.ml } diff --git a/src/ecSubst.mli b/src/ecSubst.mli index 5ad3879db6..85c2e6a6ff 100644 --- a/src/ecSubst.mli +++ b/src/ecSubst.mli @@ -79,6 +79,11 @@ val subst_ss_inv : subst -> ss_inv -> ss_inv val subst_ts_inv : subst -> ts_inv -> ts_inv val subst_inv : subst -> inv -> inv +(* -------------------------------------------------------------------- *) +val subst_crbinding : ?red:(form -> int option) -> subst -> crbinding -> crbinding +val subst_bv_opkind : ?red:(form -> int option) -> subst -> bv_opkind -> bv_opkind +val subst_binding_size : ?red:(form -> int option) -> subst -> binding_size -> binding_size + (* -------------------------------------------------------------------- *) val open_oper : operator -> ty list -> ty * operator_kind val open_tydecl : tydecl -> ty list -> ty_body diff --git a/src/ecThCloning.ml b/src/ecThCloning.ml index 2731d928b9..c6fe7d903a 100644 --- a/src/ecThCloning.ml +++ b/src/ecThCloning.ml @@ -464,6 +464,7 @@ end = struct | Th_addrw _ -> (proofs, evc) | Th_reduction _ -> (proofs, evc) | Th_auto _ -> (proofs, evc) + | Th_crbinding _ -> (proofs, evc) | Th_alias _ -> (proofs, evc) and doit prefix (proofs, evc) dth = diff --git a/src/ecTheory.ml b/src/ecTheory.ml index ffe226d060..4aac273460 100644 --- a/src/ecTheory.ml +++ b/src/ecTheory.ml @@ -31,6 +31,7 @@ and theory_item_r = | Th_baserw of symbol * is_local | Th_addrw of EcPath.path * EcPath.path list * is_local | Th_reduction of (EcPath.path * rule_option * rule option) list + | Th_crbinding of crbinding * is_local | Th_auto of auto_rule | Th_alias of (symbol * path) (* FIXME: currently, only theories *) diff --git a/src/ecTheory.mli b/src/ecTheory.mli index f246ee3f40..d16cb910ca 100644 --- a/src/ecTheory.mli +++ b/src/ecTheory.mli @@ -28,6 +28,7 @@ and theory_item_r = | Th_addrw of EcPath.path * EcPath.path list * is_local (* reduction rule does not survive to section so no locality *) | Th_reduction of (EcPath.path * rule_option * rule option) list + | Th_crbinding of crbinding * is_local | Th_auto of auto_rule | Th_alias of (symbol * path) diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 8347cce431..0a53479093 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -407,6 +407,41 @@ let rename ?(fold = true) ove subst (kind, name) = with Not_found -> (subst, name) +(* -------------------------------------------------------------------- *) +exception InvInstPath + +(* -------------------------------------------------------------------- *) +let forpath ~(opath : EcPath.path) ~(npath : EcPath.path) ~(ops : _ Mp.t) (p : EcPath.path) = + match EcPath.remprefix ~prefix:opath ~path:p |> omap List.rev with + | None | Some [] -> None + | Some (x::px) -> + let q = EcPath.fromqsymbol (List.rev px, x) in + + match Mp.find_opt q ops with + | None -> + Some (EcPath.pappend npath q) + | Some (op, alias) -> + match alias with + | true -> Some (EcPath.pappend npath q) + | false -> + match op.EcDecl.op_kind with + | OB_pred _ + | OB_nott _ -> assert false + | OB_oper None -> None + | OB_oper (Some (OP_Constr _)) + | OB_oper (Some (OP_Record _)) + | OB_oper (Some (OP_Proj _)) + | OB_oper (Some (OP_Fix _)) + | OB_oper (Some (OP_TC )) -> + Some (EcPath.pappend npath q) + | OB_oper (Some (OP_Plain f)) -> + match f.f_node with + | Fop (r, _) -> Some r + | _ -> raise InvInstPath + +let forpath ~opath ~npath ~ops p = + odfl p (forpath ~opath ~npath ~ops p) + (* -------------------------------------------------------------------- *) let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd) = let scenv = ove.ovre_hooks.henv scope in @@ -428,18 +463,29 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd let ue = EcUnify.UniEnv.create (Some nargs) in let ntyd = EcTyping.transty EcTyping.tp_tydecl env ue ntyd in let decl = - { tyd_params = nargs; - tyd_type = `Concrete ntyd; - tyd_loca = otyd.tyd_loca; } + { tyd_params = nargs; + tyd_type = `Concrete ntyd; + tyd_loca = otyd.tyd_loca; + tyd_clinline = (mode <> `Alias); } in (decl, ntyd) | `ByPath p -> begin match EcEnv.Ty.by_path_opt p env with | Some reftyd -> - let tyargs = List.map (fun (x, _) -> EcTypes.tvar x) reftyd.tyd_params in - let body = tconstr p tyargs in - let decl = { reftyd with tyd_type = `Concrete body; } in + let body = + if reftyd.tyd_clinline then + (match reftyd.tyd_type with + | `Concrete body -> body + | _ -> assert false) + else + let tyargs = + List.map (fun (x, _) -> EcTypes.tvar x) reftyd.tyd_params in + tconstr p tyargs in + let decl = + { reftyd with + tyd_type = `Concrete body; + tyd_clinline = (mode <> `Alias); } in (decl, body) | _ -> assert false @@ -448,10 +494,11 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd | `Direct ty -> begin assert (List.is_empty otyd.tyd_params); let decl = - { tyd_params = []; - tyd_type = `Concrete ty; - tyd_loca = otyd.tyd_loca; } - + { tyd_params = []; + tyd_type = `Concrete ty; + tyd_loca = otyd.tyd_loca; + tyd_clinline = false; (* FIXME: check value here tyd_clinline PR *) + } in (decl, ty) end in @@ -955,39 +1002,7 @@ and replay_instance = let opath = ove.ovre_opath in let npath = ove.ovre_npath in - - let module E = struct exception InvInstPath end in - - let forpath (p : EcPath.path) = - match EcPath.remprefix ~prefix:opath ~path:p |> omap List.rev with - | None | Some [] -> None - | Some (x::px) -> - let q = EcPath.fromqsymbol (List.rev px, x) in - - match Mp.find_opt q ops with - | None -> - Some (EcPath.pappend npath q) - | Some (op, alias) -> - match alias with - | true -> Some (EcPath.pappend npath q) - | false -> - match op.EcDecl.op_kind with - | OB_pred _ - | OB_nott _ -> assert false - | OB_oper None -> None - | OB_oper (Some (OP_Constr _)) - | OB_oper (Some (OP_Record _)) - | OB_oper (Some (OP_Proj _)) - | OB_oper (Some (OP_Fix _)) - | OB_oper (Some (OP_TC )) -> - Some (EcPath.pappend npath q) - | OB_oper (Some (OP_Plain f)) -> - match f.f_node with - | Fop (r, _) -> Some r - | _ -> raise E.InvInstPath - in - - let forpath p = odfl p (forpath p) in + let forpath = forpath ~npath ~opath ~ops in try let (typ, ty) = EcSubst.subst_genty subst (typ, ty) in @@ -1023,9 +1038,144 @@ and replay_instance let scope = ove.ovre_hooks.hadd_item scope ~import (Th_instance ((typ, ty), tc, lc)) in (subst, ops, proofs, scope) - with E.InvInstPath -> + with InvInstPath -> + (subst, ops, proofs, scope) + +(* -------------------------------------------------------------------- *) +and replay_crb_bitstring (ove : _ ovrenv) (subst, ops, proofs, scope) (import, bs, lc) = + let opath = ove.ovre_opath in + let npath = ove.ovre_npath in + let forpath = forpath ~npath ~opath ~ops in + + let env = EcSection.env (ove.ovre_hooks.henv scope) in + let hyps = EcEnv.LDecl.init env [] in + let red f = try + Some (EcCallbyValue.norm_cbv EcReduction.full_red hyps f |> EcCoreFol.destr_int |> BI.to_int) + with + | EcCoreFol.DestrError "destr_int" -> None + | EcEnv.NotReducible -> None + in + + try + let to_ = forpath bs.to_ in + let from_ = forpath bs.from_ in + let touint = forpath bs.touint in + let tosint = forpath bs.tosint in + let ofint = forpath bs.ofint in + let type_ = match (EcSubst.subst_ty subst (tconstr bs.type_ [])).ty_node with + | Tconstr (p, []) -> p + | _ -> forpath bs.type_ (* FIXME: fallback *) + in + let theory = EcSubst.subst_path subst bs.theory in (* FIXME *) + let size = EcSubst.subst_binding_size ~red subst bs.size in + + let bs = CRB_Bitstring { to_; from_; touint; tosint; ofint; type_; theory; size; } in + let scope = ove.ovre_hooks.hadd_item scope ~import (Th_crbinding (bs, lc)) in + + (subst, ops, proofs, scope) + + with InvInstPath -> + (subst, ops, proofs, scope) + +(* -------------------------------------------------------------------- *) +and replay_crb_array (ove : _ ovrenv) (subst, ops, proofs, scope) (import, ba, lc) = + let opath = ove.ovre_opath in + let npath = ove.ovre_npath in + let forpath = forpath ~npath ~opath ~ops in + + let env = EcSection.env (ove.ovre_hooks.henv scope) in + let hyps = EcEnv.LDecl.init env [] in + let red f = try + Some (EcCallbyValue.norm_cbv EcReduction.full_red hyps f |> EcCoreFol.destr_int |> BI.to_int) + with + | EcCoreFol.DestrError "destr_int" -> None + | EcEnv.NotReducible -> None + in + + try + let get = forpath ba.get in + let set = forpath ba.set in + let tolist = forpath ba.tolist in + let oflist = forpath ba.oflist in + let type_ = match (EcSubst.subst_ty subst (tconstr ba.type_ [tint])).ty_node with (* FIXME: hack *) + | Tconstr (p, x::[]) -> p + | _ -> assert false; forpath ba.type_ + in + let size = EcSubst.subst_binding_size ~red subst ba.size in + let theory = EcSubst.subst_path subst ba.theory in (* FIXME *) + + let ba = CRB_Array { get; set; tolist; oflist; type_; size; theory; } in + let scope = ove.ovre_hooks.hadd_item scope ~import (Th_crbinding (ba, lc)) in + + (subst, ops, proofs, scope) + + + with InvInstPath -> + (subst, ops, proofs, scope) + +(* -------------------------------------------------------------------- *) +and replay_crb_bvoperator (ove : _ ovrenv) (subst, ops, proofs, scope) (import, op, lc) = + let opath = ove.ovre_opath in + let npath = ove.ovre_npath in + let forpath = forpath ~npath ~opath ~ops in + + let env = EcSection.env (ove.ovre_hooks.henv scope) in + let hyps = EcEnv.LDecl.init env [] in + let red f = try + Some (EcCallbyValue.norm_cbv EcReduction.full_red hyps f |> EcCoreFol.destr_int |> BI.to_int) + with + | EcCoreFol.DestrError "destr_int" -> None + | EcEnv.NotReducible -> None + in + + try + let kind = EcSubst.subst_bv_opkind ~red subst op.kind in + let operator = forpath op.operator in + let types = List.map forpath op.types in (* FIXME *) + let theory = forpath op.theory in (* FIXME *) + + let op = CRB_BvOperator { kind; operator; types; theory; } in + let scope = ove.ovre_hooks.hadd_item scope ~import (Th_crbinding (op, lc)) in + + (subst, ops, proofs, scope) + + with InvInstPath -> (subst, ops, proofs, scope) +(* -------------------------------------------------------------------- *) +and replay_crb_circuit (ove : _ ovrenv) (subst, ops, proofs, scope) (import, cr, lc) = + let opath = ove.ovre_opath in + let npath = ove.ovre_npath in + let forpath = forpath ~npath ~opath ~ops in + + try + let name = cr.name in + let circuit = cr.circuit in + let operator = forpath cr.operator in + + let cr = CRB_Circuit { name; circuit; operator; } in + let scope = ove.ovre_hooks.hadd_item scope ~import (Th_crbinding (cr, lc)) in + + (subst, ops, proofs, scope) + + with InvInstPath -> + (subst, ops, proofs, scope) + +(* -------------------------------------------------------------------- *) +and replay_crbinding (ove : _ ovrenv) (subst, ops, proofs, scope) (import, binding, lc) = + match binding with + | CRB_Bitstring bs -> + replay_crb_bitstring ove (subst, ops, proofs, scope) (import, bs, lc) + + | CRB_Array ba -> + replay_crb_array ove (subst, ops, proofs, scope) (import, ba, lc) + + | CRB_BvOperator op -> + replay_crb_bvoperator ove (subst, ops, proofs, scope) (import, op, lc) + + | CRB_Circuit cr -> + replay_crb_circuit ove (subst, ops, proofs, scope) (import, cr, lc) + (* -------------------------------------------------------------------- *) and replay_alias (ove : _ ovrenv) (subst, ops, proofs, scope) (import, name, target) @@ -1090,6 +1240,9 @@ and replay1 (ove : _ ovrenv) (subst, ops, proofs, scope) (hidden, item) = | Th_alias (name, target) -> replay_alias ove (subst, ops, proofs, scope) (item.ti_import, name, target) + | Th_crbinding (binding, lc) -> + replay_crbinding ove (subst, ops, proofs, scope) (item.ti_import, binding, lc) + | Th_theory (ox, cth) -> begin let thmode = cth.cth_mode in let (subst, x) = rename ove subst (`Theory, ox) in diff --git a/src/ecTypes.ml b/src/ecTypes.ml index 87efc57bee..11a6912b7d 100644 --- a/src/ecTypes.ml +++ b/src/ecTypes.ml @@ -65,13 +65,14 @@ let tfun t1 t2 = mk_ty (Tfun (t1, t2)) let tglob m = mk_ty (Tglob m) (* -------------------------------------------------------------------- *) -let tunit = tconstr EcCoreLib.CI_Unit .p_unit [] -let tbool = tconstr EcCoreLib.CI_Bool .p_bool [] -let tint = tconstr EcCoreLib.CI_Int .p_int [] -let txint = tconstr EcCoreLib.CI_xint .p_xint [] +let tunit = tconstr EcCoreLib.CI_Unit.p_unit [] +let tbool = tconstr EcCoreLib.CI_Bool.p_bool [] +let tint = tconstr EcCoreLib.CI_Int.p_int [] +let txint = tconstr EcCoreLib.CI_xint.p_xint [] let tdistr ty = tconstr EcCoreLib.CI_Distr.p_distr [ty] let toption ty = tconstr EcCoreLib.CI_Option.p_option [ty] +let tlist ty = tconstr EcCoreLib.CI_List.p_list [ty] let treal = tconstr EcCoreLib.CI_Real .p_real [] let tcpred ty = tfun ty tbool @@ -87,6 +88,18 @@ let ttuple lt = let toarrow dom ty = List.fold_right tfun dom ty +exception TyDestrError of string + +let tfrom_tlist ty = + match ty.ty_node with + | Tconstr (p, [ty]) when EcPath.p_equal p EcCoreLib.CI_List.p_list -> ty + | _ -> raise (TyDestrError "list") + +let tfrom_tfun2 ty = + match ty.ty_node with + | Tfun (a, b) -> (a, b) + | _ -> raise (TyDestrError "fun") + let tpred t = tfun t tbool (* -------------------------------------------------------------------- *) diff --git a/src/ecTypes.mli b/src/ecTypes.mli index 34b7b4cbf2..62fc9d4107 100644 --- a/src/ecTypes.mli +++ b/src/ecTypes.mli @@ -45,12 +45,18 @@ val txint : ty val treal : ty val tdistr : ty -> ty val toption : ty -> ty +val tlist : ty -> ty val tcpred : ty -> ty val toarrow : ty list -> ty -> ty val trealp : ty val txreal : ty +exception TyDestrError of string + +val tfrom_tlist : ty -> ty +val tfrom_tfun2 : ty -> ty * ty + val tytuple_flat : ty -> ty list val tyfun_flat : ty -> (dom * ty) diff --git a/src/ecTypesafeFol.ml b/src/ecTypesafeFol.ml new file mode 100644 index 0000000000..23b0df017b --- /dev/null +++ b/src/ecTypesafeFol.ml @@ -0,0 +1,152 @@ +open EcUtils +open EcAst +open EcTypes +open EcCoreFol +open EcUnify +open EcSubst +open EcEnv + +module Map = Batteries.Map + +module BI = EcBigInt +module Mp = EcPath.Mp +module Sp = EcPath.Sp +module Sm = EcPath.Sm +module Sx = EcPath.Sx +module UE = EcUnify.UniEnv + +type form = EcAst.form +type f_node = EcAst.f_node +type ty = EcTypes.ty + +let (%) f g = fun x -> f (g x) + +exception InsufficientArguments + +let tfrom_tlist ty = + let p_list = EcCoreLib.CI_List.p_list in + match ty.ty_node with + | Tconstr (p, [ty]) when p = p_list -> ty + | _ -> assert false + +let tfrom_tfun2 ty = + match ty.ty_node with + | Tfun (a, b) -> (a, b) + | _ -> assert false + +let unroll_ftype (ty:ty) : ty list * ty = + let rec doit (tys: ty list) (ty: ty) : ty list * ty = + match ty.ty_node with + | Tfun _ -> let t1, t2 = tfrom_tfun2 ty in doit (t1::tys) t2 + | _ -> (List.rev tys, ty) + in + + doit [] ty + +let ty_var_from_ty (ty:ty) : ty list = + match ty.ty_node with + | Tconstr (_, args) -> args + | _ -> assert false (* FIXME: how to handle this case ? *) + +(* Returned list is (tyvar, ty) *) +let rec match_ty_tyargs (ty: ty) (tyargs: ty) : (ty * ty) list = + match (ty.ty_node, tyargs.ty_node) with + | (Tconstr (p1, args1), Tconstr (p2, args2)) when p1 = p2 && (List.compare_lengths args1 args2 = 0) -> + List.flatten @@ List.map2 match_ty_tyargs args1 args2 + | (Ttuple args1, Ttuple args2) when (List.compare_lengths args1 args2 = 0) -> + List.flatten @@ List.map2 match_ty_tyargs args1 args2 + | (Tfun (ty11, ty12), Tfun (ty21, ty22)) -> + (match_ty_tyargs ty11 ty21) @ (match_ty_tyargs ty12 ty22) + | (_, Tvar _) -> [(ty, tyargs)] + | (_, Tunivar _) -> [(ty, tyargs)] + | _ -> assert false + +let rec sub_ty_tyargs (vals: (ty, ty) Map.t) (ty: ty) : ty = + match ty.ty_node with + | (Tconstr (p1, args1)) -> tconstr p1 (List.map (sub_ty_tyargs vals) args1) + | (Ttuple args1) -> ttuple (List.map (sub_ty_tyargs vals) args1) + | (Tfun (ty_arg, ty_ret)) -> tfun (sub_ty_tyargs vals ty_arg) (sub_ty_tyargs vals ty_ret) + | (Tvar _) -> Map.find ty vals + | (Tunivar _) -> Map.find ty vals + | (Tglob _) -> assert false + +let open_oper_ue op ue = + (* Maybe list map works fine because ue is imperative? *) + let open EcDecl in + let ue, tys = List.fold_left_map (fun ue _ -> (ue, EcUnify.UniEnv.fresh ue)) ue op.op_tparams in + (tys, open_oper op tys) + +let fop_from_path (env: env) (f: EcPath.path) : form = + let ue = UE.create None in + let p_f, o_f = EcEnv.Op.lookup (EcPath.toqsymbol f) env in + let tvars,(newt, _f_kind) = open_oper_ue o_f ue in + f_op f tvars newt + +let f_app_safe ?(full=true) (env: env) (f: EcPath.path) (args: form list) = + let ue = UE.create None in + let p_f, o_f = EcEnv.Op.lookup (EcPath.toqsymbol f) env in + let tvars,(newt,f_kind) = open_oper_ue o_f ue in + let rty = UE.fresh ue in + let fty = toarrow (List.map (fun f -> f.f_ty) args) rty in + let () = begin + try + (EcUnify.unify env ue fty newt) + with + | UnificationFailure (`TcCtt (ty, sp)) -> raise (UnificationFailure (`TcCtt (ty, sp))) + | UnificationFailure (`TyUni (ty1, ty2)) -> + let pp_type = (EcPrinting.pp_type (EcPrinting.PPEnv.ofenv env)) in + Format.eprintf "Failed to unify types (%a, %a) in call to %s@." pp_type ty1 pp_type ty2 + (let h,t = EcPath.toqsymbol f in List.fold_right (fun a b -> a ^ "." ^ b) h t); + raise (UnificationFailure (`TyUni (ty1, ty2))) + end + in + let uidmap = UE.assubst ue in + let subst = EcCoreSubst.Tuni.subst uidmap in + let rty = EcCoreSubst.ty_subst subst rty in + let newt = EcCoreSubst.ty_subst subst newt in + let tvars = List.map (EcCoreSubst.ty_subst subst) tvars in + let op = f_op p_f tvars newt in + if full then + match rty.ty_node with + | Tfun _ -> Format.eprintf "op: %a@.args: " (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv env)) op; + List.iter (fun a -> Format.eprintf "%a, " (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv env)) a) args; Format.eprintf "@."; + raise InsufficientArguments + | _ -> f_app op args rty + else + f_app op args rty + +let rec fapply_safe ?(redmode = EcReduction.full_red) (hyps: LDecl.hyps) (f: form) (fs: form list) : form = +(* + Format.eprintf "Applying forms:@.%a@.To form: %a@." + (fun fmt fs -> List.iter (fun f -> Format.fprintf fmt "%a@." (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (LDecl.toenv hyps))) f) fs) fs + (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (LDecl.toenv hyps))) f; +*) + match f.f_node with + | Fop (pth, _) -> + f_app_safe ~full:false (LDecl.toenv hyps) pth fs |> EcCallbyValue.norm_cbv redmode hyps + | Fapp (fop, args) -> + (* let new_args = args @ fs in *) + (* let pp_form = EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (LDecl.toenv hyps)) in *) + (* let pp_forms fmt = List.iter (Format.fprintf fmt "%a, " pp_form) in *) + (* Format.eprintf "new_args: %a@." pp_forms new_args; *) + fapply_safe ~redmode hyps fop (args @ fs) + | Fquant (Llambda, binds, f) -> + assert (List.compare_lengths binds fs >= 0); + let subst_bnds, rem_bnds = List.takedrop (List.length fs) binds in + let subst = + List.fold_left2 + (fun subst b f -> EcSubst.add_flocal subst (fst b) f) EcSubst.empty subst_bnds fs + in + let f = f_quant Llambda rem_bnds (EcSubst.subst_form subst f) in + EcCallbyValue.norm_cbv redmode hyps f + | Fquant (qtf, _, _) -> assert false + | Fif (f, ft, ff) -> assert false + | Fmatch (f, fs, t) -> assert false + | Flet (lpat, f, fb) -> assert false + | Fint (i) -> assert false + | Flocal (id) -> assert false + | Fpvar (pv, m) -> assert false + | Fglob (id, m) -> assert false + | Ftuple (fs) -> assert false + | Fproj (f, i) -> assert false + | _ -> assert false diff --git a/src/ecTyping.ml b/src/ecTyping.ml index 75f594a105..6ed6a52eb6 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -3637,6 +3637,13 @@ and trans_cp_base ?(memory : memory option) (env : EcEnv.env) (p : pcp_base) : c and trans_codepos1 ?(memory : memory option) (env : EcEnv.env) (p : pcodepos1) : codepos1 = snd_map (trans_cp_base ?memory env) p +(* -------------------------------------------------------------------- *) +(* FIXME: PR: Should this be kept? *) +and trans_codeoffset1 ?(memory : memory option) (env : EcEnv.env) (o : pcodeoffset1) : codeoffset1 = + match o with + | `ByOffset i -> `ByOffset i + | `ByPosition p -> `ByPosition (trans_codepos1 ?memory env p) + (* -------------------------------------------------------------------- *) and trans_codepos_brsel (bs : pbranch_select) : codepos_brsel = match bs with @@ -3665,11 +3672,6 @@ and trans_codepos_range ?(memory : memory option) (env : EcEnv.env) ((cps, cpe) and trans_dcodepos1 ?(memory : memory option) (env : EcEnv.env) (p : pcodepos1 doption) : codepos1 doption = DOption.map (trans_codepos1 ?memory env) p -and trans_codeoffset1 ?(memory: memory option) (env : EcEnv.env) (o : pcodeoffset1) : codeoffset1 = - match o with - | `ByOffset i -> `ByOffset i - | `ByPosition p -> `ByPosition (trans_codepos1 ?memory env p) - (* -------------------------------------------------------------------- *) let get_instances (tvi, bty) env = let inst = List.pmap diff --git a/src/ecTyping.mli b/src/ecTyping.mli index bf2da3aa21..0ac79f41be 100644 --- a/src/ecTyping.mli +++ b/src/ecTyping.mli @@ -231,6 +231,7 @@ val trans_codepos1 : ?memory:EcMemory.memory -> env -> pcodepos1 -> codepos1 val trans_codepos : ?memory:EcMemory.memory -> env -> pcodepos -> codepos val trans_dcodepos1 : ?memory:EcMemory.memory -> env -> pcodepos1 doption -> codepos1 doption val trans_codeoffset1 : ?memory:EcMemory.memory -> env -> pcodeoffset1 -> codeoffset1 +(* FIXME: trans_codeoffset to remove? *) (* -------------------------------------------------------------------- *) type ptnmap = ty EcIdent.Mid.t ref diff --git a/src/ecUtils.ml b/src/ecUtils.ml index e852ce0c09..801fcfe574 100644 --- a/src/ecUtils.ml +++ b/src/ecUtils.ml @@ -236,7 +236,8 @@ let oif (test : 'a -> bool) (x : 'a option) = let oget ?exn (x : 'a option) = match x, exn with - | None , None -> assert false + | None , None -> (* FIXME PR: Remove before merge *) + Printexc.get_callstack 100 |> Printexc.print_raw_backtrace stderr; assert false | None , Some exn -> raise exn | Some x, _ -> x @@ -600,6 +601,21 @@ module List = struct let has_dup ?(cmp = Stdlib.compare) (xs : 'a list) = Option.is_some (find_dup ~cmp xs) + let collapse ?(eq : 'a -> 'a -> bool = (=)) (xs : 'a list) = + match xs with + | [] -> None + | x :: xs -> if List.for_all (eq x) xs then Some x else None + + (* List of size n*w into list of n lists of size w *) + let chunkify (w : int) = + let rec doit (acc : 'a list list) (xs : 'a list) = + if is_empty xs then + rev acc + else + let hd, tl = takedrop w xs in + doit (hd :: acc) tl + in fun (xs : 'a list) -> doit [] xs + (* Separate list into a prefix for which p is true and the rest *) let takedrop_while (p: 'a -> bool) (xs : 'a list) = let rec doit (acc: 'a list) (xs : 'a list) = @@ -608,7 +624,6 @@ module List = struct | x::xs -> if p x then doit (x::acc) xs else (List.rev acc, x::xs) in doit [] xs - type 'a interruptible = [`Interrupt | `Continue of 'a] let fold_left_map_while (f : 'a -> 'b -> ('a * 'c) interruptible) = diff --git a/src/ecUtils.mli b/src/ecUtils.mli index 7d0a4c3c80..0098f0d4d3 100644 --- a/src/ecUtils.mli +++ b/src/ecUtils.mli @@ -300,6 +300,8 @@ module List : sig val reduce1 : ('a list -> 'a) -> 'a list -> 'a val find_dup : ?cmp:('a -> 'a -> int) -> 'a list -> 'a option val has_dup : ?cmp:('a -> 'a -> int) -> 'a list -> bool + val collapse : ?eq:('a -> 'a -> bool) -> 'a list -> 'a option + val chunkify : int -> 'a list -> 'a list list val takedrop_while : ('a -> bool) -> 'a list -> 'a list * 'a list diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml new file mode 100644 index 0000000000..4bd179b71c --- /dev/null +++ b/src/phl/ecPhlBDep.ml @@ -0,0 +1,445 @@ +(* -------------------------------------------------------------------- *) +open EcUtils +open EcIdent +open EcSymbols +open EcLocation +open EcParsetree +open EcAst +open EcEnv +open EcTypes +open EcCoreGoal +open EcFol +open EcLowCircuits +open EcCircuits +open LDecl + +(* -------------------------------------------------------------------- *) +module Map = Batteries.Map +module Hashtbl = Batteries.Hashtbl +module Set = Batteries.Set +module Option = Batteries.Option + +(* -------------------------------------------------------------------- *) +exception BDepError of string Lazy.t +exception BDepUninitializedInputs +exception BadTypeForConstructor +exception TyLookupError +exception BDepVerifyFail + +(* TODO: Refactor error printing and checking? Lots of duplicated code *) + +let int_of_form = EcCircuits.int_of_form + +let time (env: env) (t: float) (msg: string) : float = + let new_t = Unix.gettimeofday () in + EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. t); + new_t + +(* + f => arr_t.init (fun i => f.(i + offset)) + Assumes f has an array type binding + Assumes f has enough positions so that + arr_t.size + offset < size f (as array) +*) +let array_init_from_form (env: env) (f: form) ((arr_t, offset): qsymbol * BI.zint) : form = + let ppe = EcPrinting.PPEnv.ofenv env in + let tpath = match EcEnv.Ty.lookup_opt arr_t env with + | None -> raise TyLookupError + | Some (path, decl) when List.length decl.tyd_params = 1 -> + path + | Some ((_path, decl) as tdecl) -> + raise BadTypeForConstructor + in + let get = match EcEnv.Circuit.lookup_array env f.f_ty with + | Some { get } -> get + | None -> raise (MissingTyBinding f.f_ty) + in + let init = EcEnv.Op.lookup_path (fst (tpath |> EcPath.toqsymbol), "init") env in + let idx = create "i" in + let f = f_lambda [(idx, GTty tint)] + (EcTypesafeFol.f_app_safe env get [f; f_int_add (f_local idx tint) (f_int offset)]) + in EcTypesafeFol.f_app_safe env init [f] + +(* FIXME: move? V *) +let form_list_from_iota (hyps: hyps) (f: form) : form list = + match f.f_node with + | Fapp ({f_node = Fop(p, _)}, [n; m]) when p = EcCoreLib.CI_List.p_iota -> + let n = int_of_form hyps n in + let m = int_of_form hyps m in + List.init (BI.to_int m) (fun i -> f_int (BI.(add n (of_int i)))) + | _ -> + raise (DestrError "iota") + +let rec form_list_of_form ?(ppenv: EcPrinting.PPEnv.t option) (f: form) : form list = + match destr_op_app f with + | (pc, _), [h; {f_node = Fop(p, _)}] when + pc = EcCoreLib.CI_List.p_cons && + p = EcCoreLib.CI_List.p_empty -> + [h] + | (pc, _), [h; t] when + pc = EcCoreLib.CI_List.p_cons -> + h::(form_list_of_form t) + | _ -> + raise (DestrError "list") + +(* FIXME: move? A *) + +let rec destr_conj (hyps: hyps) (f: form) : form list = + let redmode = {(circ_red hyps) with zeta = false} in + let f = (EcCallbyValue.norm_cbv redmode hyps f) in + match f.f_node with + | Fapp ({f_node = Fop (p, _)}, fs) -> begin match (EcFol.op_kind p, fs) with + | Some (`And _), _ -> List.flatten @@ List.map (destr_conj hyps) fs + | (None, [f;fs]) when p = EcCoreLib.CI_List.p_all -> + let fs = form_list_from_iota hyps fs in + List.map (fun farg -> f_app f (farg::[]) tbool) fs + | _ -> f::[] + end + | _ -> f::[] + + +(* Should return a list of circuits corresponding to the atomic parts of the pre *) +(* + This means: + /\ p_i => [p_i]_i, + a = b => [a.[i] = b.[i]]_i +*) +(* Returns _open_ circuits *) +let process_pre ?(st : state option) (tc: tcenv1) (f: form) : state * circuit list = + let debug = false in + let env = FApi.tc1_env tc in + let ppe = EcPrinting.PPEnv.ofenv env in + let hyps = FApi.tc1_hyps tc in (* FIXME: should target be specified here? *) + + (* Maybe move this to be a parameter and just supply it from outside *) + let st = match st with + | Some st -> st + | None -> circuit_state_of_hyps hyps + in + + (* Takes in a form of the form /\_i f_i + and returns a list of the conjunction terms [ f_i ]*) + let destr_conj = destr_conj hyps in + + let fs = destr_conj f in + + if debug then Format.eprintf "Destructured conj, obtained:@.%a@." + (EcPrinting.pp_list ";@\n" EcPrinting.(pp_form PPEnv.(ofenv env))) fs; + + (* If f is of the form (a_ = a) (aka prog_var = log_var) + then add it to the state, otherwise do nothing *) + (* FIXME: are all the simplifications necessary ? *) + let rec process_equality (s: state) (f: form) : state = + let f = (EcCallbyValue.norm_cbv (circ_red hyps) hyps f) in + match f.f_node with + | Fapp ({f_node = Fop (p, _);_}, [a; b]) -> begin match EcFol.op_kind p, (EcCallbyValue.norm_cbv (circ_red hyps) hyps a), (EcCallbyValue.norm_cbv (circ_red hyps) hyps b) with + | Some `Eq, {f_node = Fpvar (PVloc pv, m); _}, fv + | Some `Eq, fv, {f_node = Fpvar (PVloc pv, m); _} -> + if debug then Format.eprintf "Adding equality to known information for translation: %a@." EcPrinting.(pp_form PPEnv.(ofenv env)) f; + update_state_pv s m pv (circuit_of_form ~st hyps fv) + | _ -> s + end + | _ -> s + in + + let st = List.fold_left process_equality st fs in + + (* If convertible to circuit then add to precondition conjunction. + Use state from previous as well *) + let rec process_form (f: form) : circuit list = + match f.f_node with + | Fapp ({f_node = Fop (p, _);_}, [f1; f2]) when EcFol.op_kind p = Some `Eq -> + let c1 = circuit_of_form ~st hyps (EcCallbyValue.norm_cbv (circ_red hyps) hyps f1) in + let c2 = circuit_of_form ~st hyps (EcCallbyValue.norm_cbv (circ_red hyps) hyps f2) in + circuit_eqs c1 c2 + | _ -> + begin + if debug then + Format.eprintf "Processing form: %a@.Simplified version: %a@." + EcPrinting.(pp_form ppe) f + EcPrinting.(pp_form ppe) (EcCallbyValue.norm_cbv (circ_red hyps) hyps f); + try (circuit_of_form ~st hyps (EcCallbyValue.norm_cbv (circ_red hyps) hyps f))::[] with + e -> begin + if debug then Format.eprintf "Encountered exception when converting part of the pre to circuit: %s@." (Printexc.to_string e); + [] end + end + in + + let cs = List.fold_left (fun acc f -> List.rev_append (process_form f) acc) [] fs |> List.rev in +(* + if debug then Format.eprintf "Translated as much as possible from pre to circuits, got:@.%a@\n" + (EcPrinting.pp_list "@\n@\n" pp_circuit) cs; +*) + + if debug then Format.eprintf "In the context of the following bindings in the environment:@\n%a@\n" + (EcPrinting.pp_list "@\n@\n" (fun fmt cinp -> Format.eprintf "%a@." pp_cinp cinp)) (state_lambdas st); + st, cs + +let solve_post ~(st: state) ~(pres: circuit list) (hyps: hyps) (post: form) : bool = + let destr_conj = destr_conj hyps in + let posts = destr_conj post in + + List.for_all (fun post -> + if debug then Format.eprintf "Solving post: %a@." + EcPrinting.(pp_form PPEnv.(ofenv (toenv hyps))) post; + match post.f_node with + | Fapp ({f_node= Fop(p, _); _}, [f1; f2]) -> + begin match EcFol.op_kind p with + | Some `Eq -> + circuit_simplify_equality ~st ~hyps ~pres f1 f2 + | _ -> circuit_of_form ~st hyps post |> state_close_circuit st |> circ_taut + end + | _ -> circuit_of_form ~st hyps post |> state_close_circuit st |> circ_taut + ) posts + +(* TODO: Figure out how to not repeat computations here? *) +let t_bdep_solve + (tc : tcenv1) = + let time (env: env) (t: float) (msg: string) : float = + let new_t = Unix.gettimeofday () in + EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. t); + new_t + in + + begin + let hyps = (FApi.tc1_hyps tc) in + let goal = (FApi.tc1_goal tc) in + match goal.f_node with + | FhoareS {hs_m; hs_pr; hs_po; hs_s} -> begin try + let tm = Unix.gettimeofday () in + let st, cpres = process_pre tc hs_pr in + let tm = time (toenv hyps) tm "Done with precondition processing" in + + (* Get open state *) + let st = state_of_prog hyps (fst hs_m) ~st hs_s.s_node in + let _tm = time (toenv hyps) tm "Done with program circuit gen" in + + let res = solve_post ~st ~pres:cpres hyps hs_po in + EcCircuits.clear_translation_caches (); + if res then + FApi.close (!@ tc) VBdep + else + raise BDepVerifyFail (* FIXME: this is tactic failure, maybe should be done differently? *) + with + (* FIXME: not catching anything, redo *) + | BDepError le -> + tc_error (FApi.tc1_penv tc) "%s" (Lazy.force le) + end + | FequivS { es_ml; es_mr; es_pr; es_sl; es_sr; es_po } -> + begin + try ( + let tm = Unix.gettimeofday () in + (* FIXME: rework this *) + let st = circuit_state_of_memenv ~st:empty_state (FApi.tc1_env tc) es_ml in + let st = circuit_state_of_memenv ~st (FApi.tc1_env tc) es_mr in +(* let st = circuit_state_of_hyps ~st (FApi.tc1_hyps tc) in *) + let st, cpres = process_pre ~st tc es_pr in + let tm = time (toenv hyps) tm "Done with precondition processing" in + + (* Circuits from pvars are tagged by memory so we can just put everything in one state *) + let st = state_of_prog ~me:es_ml hyps (fst es_ml) ~st es_sl.s_node in + let tm = time (toenv hyps) tm "Done with left program circuit gen" in + let st = state_of_prog ~me:es_mr hyps (fst es_mr) ~st es_sr.s_node in + let _tm = time (toenv hyps) tm "Done with right program circuit gen" in + + (if solve_post ~st ~pres:cpres hyps es_po + then FApi.close (!@ tc) VBdep else + raise BDepVerifyFail) + ) + with + (* FIXME: not catching anything, redo *) + | BDepError le -> + tc_error (FApi.tc1_penv tc) "%s" (Lazy.force le) + end + | _ -> + let ctxt = tohyps hyps in + assert (ctxt.h_tvar = []); + let st = circuit_state_of_hyps hyps in + let cgoal = (circuit_of_form ~st hyps goal |> state_close_circuit st) in + if debug then Format.eprintf "goal: %a@." pp_flatcirc (fst cgoal).reg; + if circ_taut cgoal then + FApi.close (!@ tc) VBdep + else + tc_error (FApi.tc1_penv tc) "Failed to solve goal through circuit reasoning@\n" + end + +let t_bdep_simplify (tc: tcenv1) = + let time (env: env) (t: float) (msg: string) : float = + let new_t = Unix.gettimeofday () in + EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. t); + Format.eprintf "[W] %s, took %f s@." msg (new_t -. t); + new_t + in + let hyps = (FApi.tc1_hyps tc) in + let goal = (FApi.tc1_goal tc) in + let env = (FApi.tc1_env tc) in + match goal.f_node with + | FhoareS {hs_m=(m, me) as hs_m; hs_pr; hs_po; hs_s} -> +(* begin try *) + let tm = Unix.gettimeofday () in + let st = circuit_state_of_hyps ~use_mem:true hyps in + let st = circuit_state_of_memenv ~st env hs_m in + let st, pres = process_pre ~st tc hs_pr in + let tm = time env tm "Done with precondition processing" in + + + (* FIXME: line below throws, should handle exceptions *) + let st = EcCircuits.state_of_prog ~st hyps (fst hs_m) hs_s.s_node in + let post = EcCallbyValue.norm_cbv (circ_red hyps) hyps hs_po in + (* + if debug then Format.eprintf "[W] Post after simplify (before circuit pass):@. %a@." + EcPrinting.(pp_form PPEnv.(ofenv env)) post; + *) + let tm = time env tm "Done with first simplify" in + let f = EcCircuits.circ_simplify_form_bitstring_equality ~st ~pres hyps post in + let tm = time env tm "Done with circuit simplify" in + let f = EcCallbyValue.norm_cbv (EcReduction.full_red) hyps f in + let _tm = time env tm "Done with second simplify" in + let new_goal = f_hoareS (snd hs_m) {inv=hs_pr; m} hs_s {inv=f; m} in + (* + if debug then Format.eprintf "[W] Goal after simplify:@. %a@." + EcPrinting.(pp_form PPEnv.(ofenv env)) new_goal; + *) + + FApi.mutate1 tc (fun _ -> VBdep) new_goal |> FApi.tcenv_of_tcenv1 +(* + with CircError err -> + tc_error (FApi.tc1_penv tc) "CircError: %s@." (Lazy.force err) + end +*) + | _ -> assert false (* FIXME : TODO *) + +(* ================ EXTENS TACTIC ==================== *) +(* FIXME: Maybe move later? *) +open FApi +let t_extens (v: string option) (tt : backward) (tc : tcenv1) = + (* Find goal shape + -> generate one goal for each value + -> solve goal by applying the tactic + *) + + let open EcAst in + + let tm = Unix.gettimeofday () in + + let solved = ref 0 in + + let rec do_all (goals: form list) = + match goals with + | [] -> None + | goal::goals -> + let new_tc = mutate1 tc (fun _ -> VBdep) goal in + match (t_try_base tt new_tc) with + | `Failure e -> + tc_error_exn (tc1_penv tc) e + | `Success new_tc -> + match tc_opened new_tc with + | [] -> + incr solved; + (* EcEnv.notify ~immediate:true (tc1_env tc) `Warning "Solved goal %d@." !solved; *) + do_all goals + | hd::_ -> + Some (get_pregoal_by_id hd (tc_penv new_tc)).g_concl + in + + let subst_pv_stmt ?(redmode: EcReduction.reduction_info option) (hyps: LDecl.hyps) (mem: memory) (sb: EcPV.PVM.subst) (s: stmt) = + let redmode = Option.default (circ_red hyps) redmode in + let env = LDecl.toenv hyps in + stmt (List.map (fun i -> + match i.i_node with + | Sasgn (lv, e) -> + let f = (ss_inv_of_expr mem e) in + let fi = EcPV.PVM.subst env sb f.inv in + let fi = EcCallbyValue.norm_cbv redmode hyps fi in + let e = try expr_of_ss_inv {f with inv=fi} + with CannotTranslate -> + Format.eprintf "Failed on form : %a@." + EcPrinting.(pp_form PPEnv.(ofenv env)) fi; + raise CannotTranslate + in + EcCoreModules.i_asgn (lv, e) + | _ -> raise (CannotTranslate) (* FIXME: Errors *) + + ) s.s_node) + in + + let goals = match (tc1_goal tc).f_node, v with + | Fapp ({f_node = Fop (p, [tint]); _}, [fpred; flist]), None when p = EcCoreLib.CI_List.p_all -> + Format.eprintf "[W] Found list all@."; + begin match flist.f_node with + | Fapp ({f_node = Fop (p, []); _}, [fstart; flen]) when p = EcCoreLib.CI_List.p_iota -> + let start = match fstart.f_node with + | Fint i -> EcBigInt.to_int i + | _ -> tc_error (tc1_penv tc) "Iota start should be constant" + in + + let len = match flen.f_node with + | Fint i -> EcBigInt.to_int i + | _ -> tc_error (tc1_penv tc) "Iota length should be constant" + in + + let goals = List.init len (fun i -> + EcTypesafeFol.fapply_safe (tc1_hyps tc) fpred [f_int EcBigInt.(of_int (i + start))] + ) in + + Format.eprintf "[w] Got iota => [%d, %d)@.Goals: %a@." start len + EcPrinting.(pp_list " | " (pp_form PPEnv.(ofenv (tc1_env tc)))) goals; + goals + + | _ -> tc_error (tc1_penv tc) "Unsupported List pattern" + end + | FhoareS ({ hs_m=(m, mt); hs_s; hs_pr; hs_po }), Some v -> + let v = match EcMemory.lookup v mt with + | Some (v, _, _) -> v + | None -> tc_error (tc1_penv tc) "Failed to find var %s in memory %s" v (EcIdent.name m) + in + (* FIXME: Assumes is not array, fix later *) + let size = match EcEnv.Circuit.lookup_bitstring_size (tc1_env tc) v.v_type with + | Some size -> size + | None -> tc_error (tc1_penv tc) "Failed to get size for type %a (is it finite and does it have a binding?)" + EcPrinting.(pp_type PPEnv.(ofenv (tc1_env tc))) v.v_type + in + let tpath = match v.v_type.ty_node with + | Tconstr (p, _ ) -> p + | _ -> tc_error (tc1_penv tc) "Failed to destructure var type" + in + let of_int = match EcEnv.Circuit.reverse_type (tc1_env tc) tpath with + | [] -> tc_error (tc1_penv tc) "No bindings found for type of var" + | `Bitstring { ofint }::_ -> ofint + | _ -> tc_error (tc1_penv tc) "FIXME: Unhandled case" + in + let ngoals = 1 lsl size in +(* let ngoals = min ngoals 5 in *) + List.init ngoals (fun i -> (* FIXME FIXME this is bad *) + let subst = EcPV.PVM.(add (tc1_env tc) (PVloc v.v_name) m + (EcTypesafeFol.f_app_safe (tc1_env tc) of_int [f_int BI.(of_int i)]) empty) + in + let s = subst_pv_stmt (tc1_hyps tc) m subst hs_s in + let subst = EcPV.PVM.subst (tc1_env tc) subst in + let pr = subst hs_pr in + let po = subst hs_po in + let goal = f_hoareS mt ({inv=pr;m}) s ({inv=po;m}) in + if debug then + ( + Format.eprintf "[W] Generated goal %d@." i; +(* + Format.eprintf "%a@." + EcPrinting.(pp_form PPEnv.(ofenv (tc1_env tc))) goal +*) + ); + goal + ) + + | _ -> tc_error (tc1_penv tc) "Wrong goal shape@." + in + + match do_all goals with + | None -> + EcEnv.notify ~immediate:true (tc1_env tc) `Warning "[W] Extens took %f seconds@." (Unix.gettimeofday () -. tm); + close (tcenv_of_tcenv1 tc) VBdep + | Some gfail -> + tc_error (tc1_penv tc) "Failed to close goal:@. %a@." + EcPrinting.(pp_form PPEnv.(ofenv (tc1_env tc))) gfail + false + + diff --git a/src/phl/ecPhlBDep.mli b/src/phl/ecPhlBDep.mli new file mode 100644 index 0000000000..c7898b90d6 --- /dev/null +++ b/src/phl/ecPhlBDep.mli @@ -0,0 +1,11 @@ +(* -------------------------------------------------------------------- *) +open EcParsetree +open EcCoreGoal +open EcAst + +(* -------------------------------------------------------------------- *) +val t_bdep_solve : tcenv1 -> tcenv + +val t_bdep_simplify : tcenv1 -> tcenv + +val t_extens : string option -> FApi.backward -> FApi.backward diff --git a/src/phl/ecPhlCodeTx.ml b/src/phl/ecPhlCodeTx.ml index f3ec2c513c..191344a0a8 100644 --- a/src/phl/ecPhlCodeTx.ml +++ b/src/phl/ecPhlCodeTx.ml @@ -185,6 +185,7 @@ let t_set_match_r (side : oside) (cpos : Position.codepos) (id : symbol) pattern (t_zip (set_match_stmt id pattern)) tc (* -------------------------------------------------------------------- *) +(* FIXME: have a better handling of PV *) let cfold_stmt ?(simplify = true) (pf, hyps) (me : memenv) (olen : int option) (zpr : Zpr.zipper) = let env = LDecl.toenv hyps in @@ -196,19 +197,23 @@ let cfold_stmt ?(simplify = true) (pf, hyps) (me : memenv) (olen : int option) ( e ) else identity in - let is_const_expression (e : expr) = - PV.is_empty (e_read env e) in - let for_instruction ((subst as subst0) : (expr, unit) Mpv.t) (i : instr) = let wr = EcPV.i_write env i in let i = Mpv.isubst env subst i in let (subst, asgn) = - List.fold_left_map (fun subst ((pv, _) as pvty) -> - match Mpv.find env pv subst with - | e -> Mpv.remove env pv subst, Some (pvty, e) - | exception Not_found -> subst, None - ) subst (fst (PV.elements wr)) in + List.fold_left_map (fun subst (pv, e) -> + let exception Remove in + + try + if PV.mem_pv env pv wr then raise Remove; + let rd = EcPV.e_read env e in + if PV.mem_pv env pv rd then raise Remove; + subst, None + + with Remove -> + Mpv.remove env pv subst, Some ((pv, e.e_ty), e) + ) subst (EcPV.Mnpv.bindings (Mpv.pvs subst)) in let asgn = List.filter_map identity asgn in @@ -227,7 +232,7 @@ let cfold_stmt ?(simplify = true) (pf, hyps) (me : memenv) (olen : int option) ( try match i.i_node with | Sasgn (lv, e) -> - (* We already removed the variables of `lv` from the substitution *) + (* We already removed the variables of `lv` & the rhs from the substitution *) (* We are only interested in the variables of `lv` that are in `wr` *) let es = match simplify e, lv with @@ -238,7 +243,7 @@ let cfold_stmt ?(simplify = true) (pf, hyps) (me : memenv) (olen : int option) ( let lv = lv_to_ty_list lv in let tosubst, asgn2 = List.partition (fun ((pv, _), e) -> - Mpv.mem env pv subst0 && is_const_expression e + Mpv.mem env pv subst0 ) (List.combine lv es) in let subst = @@ -292,9 +297,6 @@ let cfold_stmt ?(simplify = true) (pf, hyps) (me : memenv) (olen : int option) ( | e, _ -> [e] in let lv = lv_to_ty_list lv in - if not (List.for_all is_const_expression es) then - tc_error pf "right-values are not closed expressions"; - if not (List.for_all (is_loc |- fst) lv) then tc_error pf "left-values must be made of local variables only"; @@ -435,7 +437,14 @@ let process_case ((side, pos) : side option * pcodepos) (tc : tcenv1) = let lv, e = destr_asgn i in - let pvl = EcPV.lp_write env lv in + let pvl = (* FIXME: do we want to do this TCB-wise? *) + match lv with + | LvVar _ -> PV.empty + | LvTuple lvs -> + let lvs = List.tl (List.rev lvs) in + let lvs = Option.get (lv_of_list lvs) in + EcPV.lp_write env lvs in + let pve = EcPV.e_read env e in let lv = lv_to_list lv in @@ -446,7 +455,11 @@ let process_case ((side, pos) : side option * pcodepos) (tc : tcenv1) = match lv, e.e_node with | [_], _ -> [e] | _ , Etuple es -> es - | _ ,_ -> assert false in + | _ ,_ -> + let tys = + match (EcEnv.Ty.hnorm e.e_ty env).ty_node with + | Ttuple tys -> tys | _ -> assert false in + List.mapi (fun i ty -> e_proj e i ty) tys in let s = List.map2 (fun pv e -> i_asgn (LvVar (pv, e.e_ty), e)) lv e in diff --git a/src/phl/ecPhlEqobs.ml b/src/phl/ecPhlEqobs.ml index 8466ac9351..b13c46c607 100644 --- a/src/phl/ecPhlEqobs.ml +++ b/src/phl/ecPhlEqobs.ml @@ -1,6 +1,9 @@ (* -------------------------------------------------------------------- *) open EcUtils +open EcPath +open EcParsetree open EcAst +open EcMatching.Position open EcTypes open EcModules open EcFol @@ -13,6 +16,16 @@ open EcLowPhlGoal module TTC = EcProofTyping +(* -------------------------------------------------------------------- *) +type sim_info = { + sim_pos : codepos1 pair option; + sim_hint : (xpath option * xpath option * EcPV.Mpv2.t) list * ts_inv option; + sim_eqs : EcPV.Mpv2.t option; +} + +let empty_sim_info : sim_info = + { sim_pos = None; sim_hint = ([], None); sim_eqs = None; } + (* -------------------------------------------------------------------- *) let extend_body fsig body = let arg = pv_arg in @@ -398,7 +411,7 @@ let t_eqobs_inS_r sim eqo tc = tc_error !!tc "cannot apply sim"; let sg = List.map (mk_inv_spec env inv) sim.needed_spec in - let concl = f_equivS (snd es.es_ml) (snd es.es_mr) (es_pr es) sl sr pre in + let concl = f_equivS (snd es.es_ml) (snd es.es_mr) (es_pr es) sl sr pre in FApi.xmutate1 tc `EqobsIn (sg @ [concl]) @@ -424,53 +437,62 @@ let t_eqobs_inF_r sim eqo tc = let t_eqobs_inF = FApi.t_low2 "eqobs-in" t_eqobs_inF_r (* -------------------------------------------------------------------- *) -let process_eqs env tc f = - try - Mpv2.of_form env f - with Not_found -> - tc_error_lazy !!tc (fun fmt -> - let ppe = EcPrinting.PPEnv.ofenv env in - Format.fprintf fmt - "cannot recognize %a as a set of equalities" - (EcPrinting.pp_form ppe) f.inv) +let process_eqs (pe : proofenv) (env : env) (f : ts_inv) = + try + Mpv2.of_form env f + with Not_found -> + tc_error_lazy pe (fun fmt -> + let ppe = EcPrinting.PPEnv.ofenv env in + Format.fprintf fmt + "cannot recognize %a as a set of equalities" + (EcPrinting.pp_form ppe) f.inv) (* -------------------------------------------------------------------- *) -let process_hint ml mr tc hyps (feqs, inv) = +let process_hint ml mr (pe : proofenv) (hyps : LDecl.hyps) (feqs, inv : _ * _) = let env = LDecl.toenv hyps in let ienv = LDecl.push_active_ts (EcMemory.abstract ml) (EcMemory.abstract mr) hyps in - let doinv pf = {ml;mr;inv=TTC.pf_process_form !!tc ienv tbool pf} in - let doeq pf = process_eqs env tc (doinv pf) in + let doinv pf = {ml;mr;inv=TTC.pf_process_form pe ienv tbool pf} in + let doeq pf = process_eqs pe env (doinv pf) in let dof g = omap (EcTyping.trans_gamepath env) g in let geqs = - List.map (fun ((f1,f2),geq) -> dof f1, dof f2, doeq geq) + List.map + (fun ((f1, f2), geq) -> dof f1, dof f2, doeq geq) feqs in - let ginv = odfl {ml;mr;inv=f_true} (omap doinv inv) in + let ginv = (omap doinv inv) in (* FIXME: check *) geqs, ginv (* -------------------------------------------------------------------- *) -let process_eqobs_inS info tc = +let pre_eqobs (cm : crushmode) (tc : tcenv1) = + let dt, ts = EcHiGoal.process_crushmode cm in + EcPhlConseq.t_conseqauto ~delta:dt ?tsolve:ts tc + +(* -------------------------------------------------------------------- *) +let t_eqobs_inS_ (info : sim_info) (tc : tcenv1) = let env, hyps, _ = FApi.tc1_eflat tc in let es = tc1_as_equivS tc in - let ml, mr = fst es.es_ml, fst es.es_mr in - let spec, inv = process_hint ml mr tc hyps info.EcParsetree.sim_hint in + let spec, inv = info.sim_hint in + + let inv = match inv with + | Some inv -> inv + | None -> let ml, mr = fst es.es_ml, fst es.es_mr in + {ml;mr;inv=f_true} + in + let eqo = - match info.EcParsetree.sim_eqs with - | Some pf -> - process_eqs env tc (TTC.tc1_process_prhl_formula tc pf) - | None -> - try Mpv2.needed_eq env (es_po es) - with Not_found -> tc_error !!tc "cannot infer the set of equalities" in - let post = Mpv2.to_form_ts_inv eqo inv in + match info.sim_eqs with Some eqo -> eqo | None -> + try Mpv2.needed_eq env (es_po es) + with _ -> tc_error !!tc "cannot infer the set of equalities" in + let sim = init_sim env spec inv in + let post = Mpv2.to_form_ts_inv eqo inv in + let t_main tc = - match info.EcParsetree.sim_pos with + match info.sim_pos with | None -> FApi.t_last (FApi.t_try (FApi.t_seq EcPhlSkip.t_skip t_trivial)) (t_eqobs_inS sim eqo tc) | Some(p1,p2) -> - let p1 = EcLowPhlGoal.tc1_process_codepos1 tc (Some `Left , p1) in - let p2 = EcLowPhlGoal.tc1_process_codepos1 tc (Some `Right, p2) in let _,sl2 = s_split env p1 es.es_sl in let _,sr2 = s_split env p2 es.es_sr in let _, eqi = @@ -485,49 +507,106 @@ let process_eqobs_inS info tc = ]) tc in (EcPhlConseq.t_equivS_conseq (es_pr es) post @+ [t_trivial; - t_trivial; - t_main]) tc + t_trivial; + t_main]) tc + +(* -------------------------------------------------------------------- *) +let t_eqobs_inS (cm : crushmode option) (info : sim_info) (tc : tcenv1) = + FApi.t_last (t_eqobs_inS_ info) ((omap pre_eqobs cm |> odfl t_id) tc) (* -------------------------------------------------------------------- *) -let process_eqobs_inF info tc = - if info.EcParsetree.sim_pos <> None then - tc_error !!tc "no positions excepted"; +let process_eqobs_inS (cm : crushmode option) (info : psim_info) (tc : tcenv1) = + let env, hyps, _ = FApi.tc1_eflat tc in + let es = tc1_as_equivS tc in + let ml, mr = fst es.es_ml, fst es.es_mr in + let sim_hint = process_hint ml mr !!tc hyps info.psim_hint in + let sim_eqs = + let process pf = + process_eqs !!tc env (TTC.tc1_process_prhl_formula tc pf) + in Option.map process info.psim_eqs in + let sim_pos = + info.psim_pos + |> Option.map (pair_map (EcTyping.trans_codepos1 env)) + in + + let info = { sim_pos; sim_hint; sim_eqs; } in + + t_eqobs_inS cm info tc + +(* -------------------------------------------------------------------- *) +let t_eqobs_inF_ (info : sim_info) (tc : tcenv1) = + assert (Option.is_none info.sim_pos); + let env, hyps, _ = FApi.tc1_eflat tc in let ef = tc1_as_equivF tc in - let ml, mr = ef.ef_ml, ef.ef_mr in - let spec, inv = process_hint ml mr tc hyps info.EcParsetree.sim_hint in let fl = ef.ef_fl and fr = ef.ef_fr in + + let spec, inv = info.sim_hint in + let eqo = - match info.EcParsetree.sim_eqs with - | Some pf -> - let _,(mle,mre) = Fun.equivF_memenv ml mr fl fr env in - let hyps = LDecl.push_active_ts mle mre hyps in - process_eqs env tc {ml; mr; inv=TTC.pf_process_form !!tc hyps tbool pf} - | None -> + match info.sim_eqs with Some eqo -> eqo | None -> try Mpv2.needed_eq env (ef_po ef) with _ -> tc_error !!tc "cannot infer the set of equalities" in + let eqo = Mpv2.remove env pv_res pv_res eqo in + + let inv = match inv with + | Some inv -> inv + | None -> let ml, mr = ef.ef_ml, ef.ef_mr in + {ml;mr;inv=f_true} + in + let sim = init_sim env spec inv in let _, eqi = try f_eqobs_in fl fr sim eqo with EqObsInError -> tc_error !!tc "not able to process" in let ef' = destr_equivF (mk_inv_spec2 env inv (fl, fr, eqi, eqo)) in + (EcPhlConseq.t_equivF_conseq (ef_pr ef') (ef_po ef') @+ [ t_trivial; t_trivial; t_eqobs_inF sim eqo]) tc (* -------------------------------------------------------------------- *) -let process_eqobs_in cm info tc = - let prett cm tc = - let dt, ts = EcHiGoal.process_crushmode cm in - EcPhlConseq.t_conseqauto ~delta:dt ?tsolve:ts tc in - let tt tc = - let concl = FApi.tc1_goal tc in - match concl.f_node with - | FequivF _ -> process_eqobs_inF info tc - | FequivS _ -> process_eqobs_inS info tc - | _ -> tc_error_noXhl ~kinds:[`Equiv `Any] !!tc - in +let t_eqobs_inF (cm : crushmode option) (info : sim_info) (tc : tcenv1) = + FApi.t_last (t_eqobs_inF_ info) ((omap pre_eqobs cm |> odfl t_id) tc) + +(* -------------------------------------------------------------------- *) +let process_eqobs_inF (cm : crushmode option) (info : psim_info) (tc : tcenv1) = + if Option.is_some info.psim_pos then + tc_error !!tc "no positions excepted"; - FApi.t_last tt ((omap prett cm |> odfl t_id) tc) + let env, hyps, _ = FApi.tc1_eflat tc in + let ef = tc1_as_equivF tc in + let ml, mr = ef.ef_ml, ef.ef_mr in + let sim_hint = process_hint ml mr !!tc hyps info.psim_hint in + let fl = ef.ef_fl and fr = ef.ef_fr in + let sim_eqs = + let process pf = + let _,(mle,mre) = Fun.equivF_memenv ml mr fl fr env in + let hyps = LDecl.push_active_ts mle mre hyps in + process_eqs !!tc env {ml; mr; inv=TTC.pf_process_form !!tc hyps tbool pf} + in Option.map process info.psim_eqs in + + let info = { sim_pos = None; sim_hint; sim_eqs; } in + + t_eqobs_inF cm info tc + +(* -------------------------------------------------------------------- *) +let process_eqobs_in (cm : crushmode option) (info : psim_info) (tc : tcenv1) = + let concl = FApi.tc1_goal tc in + match concl.f_node with + | FequivF _ -> process_eqobs_inF cm info tc + | FequivS _ -> process_eqobs_inS cm info tc + | _ -> tc_error_noXhl ~kinds:[`Equiv `Any] !!tc + +(* -------------------------------------------------------------------- *) +let t_eqobs_in_r (cm : crushmode option) (info : sim_info) (tc : tcenv1) = + let concl = FApi.tc1_goal tc in + match concl.f_node with + | FequivF _ -> t_eqobs_inF cm info tc + | FequivS _ -> t_eqobs_inS cm info tc + | _ -> tc_error_noXhl ~kinds:[`Equiv `Any] !!tc + +(* -------------------------------------------------------------------- *) +let t_eqobs_in = FApi.t_low2 "eqobs-in" t_eqobs_in_r diff --git a/src/phl/ecPhlEqobs.mli b/src/phl/ecPhlEqobs.mli index d210124949..2da8b44476 100644 --- a/src/phl/ecPhlEqobs.mli +++ b/src/phl/ecPhlEqobs.mli @@ -1,7 +1,20 @@ (* -------------------------------------------------------------------- *) - +open EcUtils +open EcPath open EcParsetree +open EcAst +open EcMatching.Position open EcCoreGoal.FApi (* -------------------------------------------------------------------- *) -val process_eqobs_in : crushmode option -> sim_info -> backward +type sim_info = { + sim_pos : codepos1 pair option; + sim_hint : (xpath option * xpath option * EcPV.Mpv2.t) list * ts_inv option; + sim_eqs : EcPV.Mpv2.t option; +} + +val empty_sim_info : sim_info + +(* -------------------------------------------------------------------- *) +val t_eqobs_in : crushmode option -> sim_info -> backward +val process_eqobs_in : crushmode option -> psim_info -> backward diff --git a/src/phl/ecPhlLoopTx.ml b/src/phl/ecPhlLoopTx.ml index 434dece2ce..7eb8105155 100644 --- a/src/phl/ecPhlLoopTx.ml +++ b/src/phl/ecPhlLoopTx.ml @@ -20,7 +20,7 @@ module TTC = EcProofTyping (* -------------------------------------------------------------------- *) type fission_t = oside * pcodepos * (int * (int * int)) type fusion_t = oside * pcodepos * (int * (int * int)) -type unroll_t = oside * pcodepos * bool +type unroll_t = oside * pcodepos * [`While | `For of bool] type splitwhile_t = pexpr * oside * pcodepos (* -------------------------------------------------------------------- *) @@ -220,7 +220,7 @@ let process_splitwhile (b, side, cpos) tc = t_splitwhile b side cpos tc (* -------------------------------------------------------------------- *) -let process_unroll_for side cpos tc = +let process_unroll_for ~cfold side cpos tc = let env = FApi.tc1_env tc in let hyps = FApi.tc1_hyps tc in let (goal_m, _), c = EcLowPhlGoal.tc1_get_stmt side tc in @@ -305,7 +305,7 @@ let process_unroll_for side cpos tc = let t_conseq_nm tc = match (tc1_get_pre tc) with - | Inv_ss inv -> + | Inv_ss inv -> (EcPhlConseq.t_hoareS_conseq_nm inv {m=inv.m;inv=f_true} @+ [ t_trivial; t_trivial; EcPhlTAuto.t_hoare_true]) tc | _ -> tc_error !!tc "expecting single sided precondition" in @@ -327,16 +327,19 @@ let process_unroll_for side cpos tc = let tcenv = t_doit 0 pos zs tc in let tcenv = FApi.t_onalli doi tcenv in - let cpos = EcMatching.Position.shift ~offset:(-1) cpos in - let clen = blen * (List.length zs - 1) in + if cfold then begin + let cpos = EcMatching.Position.shift ~offset:(-1) cpos in + let clen = blen * (List.length zs - 1) in - FApi.t_last (EcPhlCodeTx.t_cfold side cpos (Some clen)) tcenv + FApi.t_last (EcPhlCodeTx.t_cfold side cpos (Some clen)) tcenv + end else tcenv (* -------------------------------------------------------------------- *) let process_unroll (side, cpos, for_) tc = - if for_ then - process_unroll_for side cpos tc - else begin + match for_ with + | `While -> let cpos = EcLowPhlGoal.tc1_process_codepos tc (side, cpos) in t_unroll side cpos tc - end + + | `For cfold -> + process_unroll_for ~cfold:(not cfold) side cpos tc diff --git a/src/phl/ecPhlLoopTx.mli b/src/phl/ecPhlLoopTx.mli index 8d619f9afd..994b447db2 100644 --- a/src/phl/ecPhlLoopTx.mli +++ b/src/phl/ecPhlLoopTx.mli @@ -13,10 +13,10 @@ val t_splitwhile : expr -> oside -> codepos -> backward (* -------------------------------------------------------------------- *) type fission_t = oside * pcodepos * (int * (int * int)) type fusion_t = oside * pcodepos * (int * (int * int)) -type unroll_t = oside * pcodepos * bool +type unroll_t = oside * pcodepos * [`While | `For of bool] type splitwhile_t = pexpr * oside * pcodepos -val process_unroll_for : oside -> pcodepos -> backward +val process_unroll_for : cfold:bool -> oside -> pcodepos -> backward val process_fission : fission_t -> backward val process_fusion : fusion_t -> backward val process_unroll : unroll_t -> backward diff --git a/src/phl/ecPhlOutline.ml b/src/phl/ecPhlOutline.ml index 2898a138b5..11b9181f03 100644 --- a/src/phl/ecPhlOutline.ml +++ b/src/phl/ecPhlOutline.ml @@ -7,12 +7,46 @@ open EcCoreGoal.FApi open EcLowPhlGoal (*---------------------------------------------------------------------------------------*) +(* FIXME PR: Remove? *) +let t_outline_stmt side start_pos end_pos s tc = + let env = FApi.tc1_env tc in + let goal = tc1_as_equivS tc in + + (* Check which memory/program we are outlining *) + let code = match side with + | `Left -> goal.es_sl + | `Right -> goal.es_sr + in + + (* Extract the program prefix and suffix *) + let rest, code_suff = s_split env end_pos code in + let code_pref, _, _ = s_split_i env start_pos (stmt rest) in + + let new_prog = s_seq (s_seq (stmt code_pref) s) (stmt code_suff) in + let tc = EcPhlTrans.t_equivS_trans_eq side new_prog tc in + + (* The middle goal, showing equivalence with the replaced code, ideally solves. *) + let tp = match side with | `Left -> 1 | `Right -> 2 in + let p = EcHiGoal.process_tfocus tc (Some [Some tp, Some tp], None) in + let tc = + t_onselect + p + (t_try ( + t_seqs [ + EcPhlInline.process_inline (`ByName (None, None, ([], None))); + EcPhlEqobs.t_eqobs_in None EcPhlEqobs.empty_sim_info; + EcPhlAuto.t_auto; + EcHiGoal.process_done; + ])) + tc + in + tc (* `by inline; sim; auto=> />` *) let t_auto_equiv_sim = t_seqs [ EcPhlInline.process_inline (`ByName (None, None, ([], None))); - EcPhlEqobs.process_eqobs_in None {sim_pos = None; sim_hint = ([], None); sim_eqs = None}; + EcPhlEqobs.process_eqobs_in None {psim_pos = None; psim_hint = ([], None); psim_eqs = None}; EcPhlAuto.t_auto; EcLowGoal.t_crush; EcHiGoal.process_done; diff --git a/src/phl/ecPhlRCond.mli b/src/phl/ecPhlRCond.mli index 87306ed994..099093971f 100644 --- a/src/phl/ecPhlRCond.mli +++ b/src/phl/ecPhlRCond.mli @@ -24,5 +24,5 @@ val t_rcond : oside -> bool -> codepos1 -> backward val process_rcond : oside -> bool -> pcodepos1 -> backward (* -------------------------------------------------------------------- *) +val t_rcond_match : oside -> symbol -> codepos1 -> backward val process_rcond_match : oside -> symbol -> pcodepos1 -> backward -val t_rcond_match : oside -> symbol -> codepos1 -> backward diff --git a/src/phl/ecPhlRewrite.ml b/src/phl/ecPhlRewrite.ml index 57abab3d51..bc28749e7c 100644 --- a/src/phl/ecPhlRewrite.ml +++ b/src/phl/ecPhlRewrite.ml @@ -1,11 +1,13 @@ (* -------------------------------------------------------------------- *) open EcParsetree +open EcUtils open EcAst open EcCoreGoal open EcEnv open EcModules open EcFol open Batteries +open EcLowPhlGoal (* -------------------------------------------------------------------- *) let t_change @@ -169,26 +171,71 @@ let process_rewrite | `Rw rw -> process_rewrite_rw side pos rw tc | `Simpl -> process_rewrite_simpl side pos tc +let rec pvtail (env: env) (pvs : EcPV.PV.t) (zp : Zpr.ipath) = + let parent = + match zp with + | Zpr.ZTop -> None + | Zpr.ZWhile (_, p) -> Some p + | Zpr.ZIfThen (e, p, _) -> Some p + | Zpr.ZIfElse (e, _, p) -> Some p + | Zpr.ZMatch (e, p, _) -> Some p in + match parent with + | None -> pvs + | Some ((_, tl), p) -> pvtail env (EcPV.PV.union pvs (EcPV.is_read env tl)) p + (* -------------------------------------------------------------------- *) let t_change_stmt (side : side option) - (pos : EcMatching.Position.codepos_range) + (pos : EcMatching.Position.codepos_range) + ((me, bindings) : memenv * ovariable list) (s : stmt) (tc : tcenv1) = let env = FApi.tc1_env tc in - let me, stmt = EcLowPhlGoal.tc1_get_stmt side tc in + let goal = (FApi.tc1_goal tc) in + let post = match goal.f_node with + | FhoareS { hs_po } -> hs_po + | FbdHoareS { bhs_po } -> bhs_po + | FeHoareS { ehs_po } -> ehs_po + | FequivS { es_po } -> es_po + | _ -> assert false + in + let _, stmt = EcLowPhlGoal.tc1_get_stmt side tc in + + let env = EcEnv.Memory.push_active_ts me me env in (* FIXME *) + + let zpr, epos = Zpr.zipper_of_cpos_range env pos stmt in + let stmt, epilog = match zpr.z_tail with + | [] -> raise Zpr.InvalidCPos + | i::tl -> let s, tl = Zpr.split_at_cpos1 env epos (EcAst.stmt tl) in + (i::s), tl + in - let (zpr, _), (stmt, epilog) = EcMatching.Zipper.zipper_and_split_of_cpos_range env pos stmt in + let keep = pvtail env (EcPV.is_read env epilog) zpr.z_path in + let keep = EcPV.PV.union keep (EcPV.PV.fv env (EcMemory.memory me) post) in let pvs = EcPV.is_write env (stmt @ s.s_node) in - let pvs, globs = EcPV.PV.elements pvs in + let _pvs, globs = EcPV.PV.elements pvs in + + let pvs, _ = EcPV.PV.elements (EcPV.PV.inter keep pvs) in - let pre_pvs, pre_globs = EcPV.PV.elements @@ EcPV.PV.inter - (EcPV.is_read env stmt) + let pre_pvs = EcPV.PV.inter + (EcPV.is_read env stmt) (EcPV.is_read env s.s_node) in + (* FIXME: Check | Do we need this? *) +(* + let pre_pvs = EcPV.PV.union pre_pvs ( + pvtail env (EcPV.is_read env epilog) zpr.z_path + ) in +*) + + (* Do we need this? *) +(* let pre_pvs = EcPV.PV.union pre_pvs (EcPV.PV.fv env (EcMemory.memory me) post) in *) + + let pre_pvs, pre_globs = EcPV.PV.elements pre_pvs in + let mleft = EcIdent.create "&1" in (* FIXME: PR: is this how we want to do this? *) let mright = EcIdent.create "&2" in @@ -221,20 +268,26 @@ let t_change_stmt let stmt = EcMatching.Zipper.zip { zpr with z_tail = s.s_node @ epilog } in - let goal2 = - EcLowPhlGoal.hl_set_stmt - side (FApi.tc1_goal tc) - stmt in + let goal2 = match side, goal.f_node with + | None, FhoareS hs -> f_hoareS (snd me) (hs_pr hs) stmt (hs_po hs) + | None, FbdHoareS bhs -> f_bdHoareS (snd me) (bhs_pr bhs) stmt (bhs_po bhs) (bhs.bhs_cmp) (bhs_bd bhs) + | None, FeHoareS ehs -> f_eHoareS (snd me) (ehs_pr ehs) stmt (ehs_po ehs) + | Some `Left, FequivS es -> f_equivS (snd me) (snd es.es_mr) (es_pr es) stmt (es.es_sr) (es_po es) + | Some `Right, FequivS es -> f_equivS (snd es.es_ml) (snd me) (es_pr es) (es.es_sl) stmt (es_po es) + | _ -> assert false + in FApi.xmutate1 tc `ProcChangeStmt [goal1; goal2] (* -------------------------------------------------------------------- *) let process_change_stmt (side : side option) + (binds : ptybindings option) (pos : pcodepos_range) (s : pstmt) (tc : tcenv1) = + let hyps = FApi.tc1_hyps tc in let env = FApi.tc1_env tc in begin match side, (FApi.tc1_goal tc).f_node with @@ -255,14 +308,46 @@ let process_change_stmt let me, _ = EcLowPhlGoal.tc1_get_stmt side tc in - let pos = + let pos = let env = EcEnv.Memory.push_active_ss me env in - EcTyping.trans_codepos_range ~memory:(fst me) env pos + EcTyping.trans_codepos_range ~memory:(fst me) env pos in - let s = match side with +(* + let s = match side with | Some side -> EcProofTyping.tc1_process_prhl_stmt tc side s | None -> EcProofTyping.tc1_process_Xhl_stmt tc s in +*) + + let bindings = + binds + |> Option.default [] + |> List.map (fun (xs, ty) -> List.map (fun x -> (x, ty)) xs) + |> List.flatten + |> List.map (fun (x, ty) -> + let ue = EcUnify.UniEnv.create (Some (EcEnv.LDecl.tohyps hyps).h_tvar) in + let ty = EcTyping.transty EcTyping.tp_tydecl env ue ty in + assert (EcUnify.UniEnv.closed ue); + let ty = + let subst = EcCoreSubst.Tuni.subst (EcUnify.UniEnv.close ue) in + EcCoreSubst.ty_subst subst ty in + let x = Option.map EcLocation.unloc (EcLocation.unloc x) in + let vr = EcAst.{ ov_name = x; ov_type = ty; } in + vr + ) + in + let me, bindings = EcMemory.bindall_fresh bindings me in + + let env = EcEnv.Memory.push_active_ss me env in + let s = + let ue = EcProofTyping.unienv_of_hyps hyps in + let s = EcTyping.transstmt env ue s in + + assert (EcUnify.UniEnv.closed ue); + + let sb = EcCoreSubst.Tuni.subst (EcUnify.UniEnv.close ue) in + EcCoreSubst.s_subst sb s + in - t_change_stmt side pos s tc + t_change_stmt side pos (me, bindings) s tc diff --git a/src/phl/ecPhlRewrite.mli b/src/phl/ecPhlRewrite.mli index 9640d3a1fc..b25f49a895 100644 --- a/src/phl/ecPhlRewrite.mli +++ b/src/phl/ecPhlRewrite.mli @@ -5,7 +5,8 @@ open EcCoreGoal.FApi (* -------------------------------------------------------------------- *) val process_change : side option -> pcodepos -> pexpr -> backward +(* -------------------------------------------------------------------- *) val process_rewrite_rw : side option -> pcodepos -> ppterm -> backward val process_rewrite_simpl : side option -> pcodepos -> backward val process_rewrite : side option -> pcodepos -> prrewrite -> backward -val process_change_stmt : side option -> pcodepos_range -> pstmt -> backward +val process_change_stmt : side option -> ptybindings option -> pcodepos_range -> pstmt -> backward diff --git a/src/phl/ecPhlRwEquiv.ml b/src/phl/ecPhlRwEquiv.ml index 777b93c165..35dc5dec4d 100644 --- a/src/phl/ecPhlRwEquiv.ml +++ b/src/phl/ecPhlRwEquiv.ml @@ -1,6 +1,8 @@ +(* -------------------------------------------------------------------- *) open EcUtils open EcLocation open EcParsetree +open EcAst open EcFol open EcModules open EcPath @@ -11,7 +13,7 @@ open EcCoreGoal.FApi open EcLowGoal open EcLowPhlGoal -(*---------------------------------------------------------------------------------------*) +(* -------------------------------------------------------------------- *) type rwe_error = | RWE_InvalidFunction of xpath * xpath | RWE_InvalidPosition @@ -20,7 +22,7 @@ exception RwEquivError of rwe_error let rwe_error e = raise (RwEquivError e) -(*---------------------------------------------------------------------------------------*) +(* -------------------------------------------------------------------- *) (* `rewrite equiv` - replace a call to a procedure with an equivalent call, using an equiv @@ -34,7 +36,15 @@ let rwe_error e = raise (RwEquivError e) and return value. *) (* FIXME: What is a good interface for this tactic? *) -let t_rewrite_equiv side dir cp (equiv : equivF) equiv_pt rargslv tc = +let t_rewrite_equiv + (side : side) + (dir : [`LtoR | `RtoL]) + (cp : EcMatching.Position.codepos1) + (equiv : equivF) + (equiv_pt : proofterm) + (rargslv : (expr list * lvalue option) option) + (tc : tcenv1) += let env = tc1_env tc in let goal = tc1_as_equivS tc in @@ -56,7 +66,6 @@ let t_rewrite_equiv side dir cp (equiv : equivF) equiv_pt rargslv tc = (* Extract the call statement and surrounding code *) let prefix, (llv, func, largs), suffix = - let cp = EcLowPhlGoal.tc1_process_codepos1 tc (Some side, cp) in let p, i, s = s_split_i env cp code in if not (is_call i) then rwe_error RWE_InvalidPosition; @@ -80,7 +89,8 @@ let t_rewrite_equiv side dir cp (equiv : equivF) equiv_pt rargslv tc = t_onselect p (t_seqs [ - EcPhlEqobs.process_eqobs_in none {sim_pos = some (cp, cp); sim_hint = ([], none); sim_eqs = none}; + EcPhlEqobs.t_eqobs_in + None EcPhlEqobs.{ empty_sim_info with sim_pos = Some (cp, cp) }; (match side, dir with | `Left, `LtoR -> t_id | `Left, `RtoL -> EcPhlSym.t_equiv_sym @@ -96,7 +106,7 @@ let t_rewrite_equiv side dir cp (equiv : equivF) equiv_pt rargslv tc = ]) tc -(*---------------------------------------------------------------------------------------*) +(* -------------------------------------------------------------------- *) (* Proccess a user call to rewrite equiv *) let process_rewrite_equiv info tc = @@ -151,6 +161,8 @@ let process_rewrite_equiv info tc = end in + let cp = EcTyping.trans_codepos1 env cp in + (* Offload to the tactic *) try t_rewrite_equiv side dir cp equiv eqv_pt rargslv tc diff --git a/src/phl/ecPhlRwEquiv.mli b/src/phl/ecPhlRwEquiv.mli index eee53c6091..0504c28b7e 100644 --- a/src/phl/ecPhlRwEquiv.mli +++ b/src/phl/ecPhlRwEquiv.mli @@ -1,12 +1,15 @@ +(* -------------------------------------------------------------------- *) open EcCoreGoal.FApi +open EcAst open EcParsetree open EcCoreGoal -open EcAst +open EcMatching.Position +(* -------------------------------------------------------------------- *) val t_rewrite_equiv : side -> [`LtoR | `RtoL ] -> - pcodepos1 -> + codepos1 -> equivF -> proofterm -> (expr list * lvalue option) option -> diff --git a/src/phl/ecPhlRwPrgm.ml b/src/phl/ecPhlRwPrgm.ml index c249539240..f970e42161 100644 --- a/src/phl/ecPhlRwPrgm.ml +++ b/src/phl/ecPhlRwPrgm.ml @@ -1,12 +1,83 @@ (* -------------------------------------------------------------------- *) +open EcUtils open EcParsetree open EcCoreGoal open EcLowPhlGoal -open EcAst (* -------------------------------------------------------------------- *) type change_t = pcodepos * ptybindings option * int * pstmt +(* -------------------------------------------------------------------- *) +let process_change ((cpos, bindings, i, s) : change_t) (tc : tcenv1) = + let hyps = FApi.tc1_hyps tc in + let env = EcEnv.LDecl.toenv hyps in + let hs = EcLowPhlGoal.tc1_as_hoareS tc in + let cpos = EcLowPhlGoal.tc1_process_codepos tc (None, cpos) in + + let mem, _ = + let bindings = + bindings + |> Option.value ~default:[] + |> List.map (fun (xs, ty) -> List.map (fun x -> (x, ty)) xs) + |> List.flatten in + List.fold_left_map (fun mem (x, ty) -> + let ue = EcUnify.UniEnv.create (Some (EcEnv.LDecl.tohyps hyps).h_tvar) in + let ty = EcTyping.transty EcTyping.tp_tydecl env ue ty in + assert (EcUnify.UniEnv.closed ue); + let ty = + let subst = EcCoreSubst.Tuni.subst (EcUnify.UniEnv.close ue) in + EcCoreSubst.ty_subst subst ty in + let x = Option.map EcLocation.unloc (EcLocation.unloc x) in + let vr = EcAst.{ ov_name = x; ov_type = ty; } in + let (mem, _) = EcMemory.bind_fresh vr mem in + (mem, (EcTypes.pv_loc (oget x), ty)) (* FIXME *) + ) hs.hs_m bindings in + + let env = EcEnv.Memory.push_active_ss mem env in + + let s = + let ue = EcProofTyping.unienv_of_hyps (FApi.tc1_hyps tc) in + let s = EcTyping.transstmt env ue s in + + assert (EcUnify.UniEnv.closed ue); (* FIXME *) + + let sb = EcCoreSubst.Tuni.subst (EcUnify.UniEnv.close ue) in + EcCoreSubst.s_subst sb s in + + let zp = Zpr.zipper_of_cpos env cpos hs.hs_s in + + let rec pvtail (pvs : EcPV.PV.t) (zp : Zpr.ipath) = + let parent = + match zp with + | Zpr.ZTop -> None + | Zpr.ZWhile (_, p) -> Some p + | Zpr.ZIfThen (e, p, _) -> Some p + | Zpr.ZIfElse (e, _, p) -> Some p + | Zpr.ZMatch (e, p, _) -> Some p in + match parent with + | None -> pvs + | Some ((_, tl), p) -> pvtail (EcPV.PV.union pvs (EcPV.is_read env tl)) p + in + + let zp = + let target, tl = List.split_at i zp.z_tail in + + let keep = pvtail (EcPV.is_read env tl) zp.z_path in + let keep = EcPV.PV.union keep (EcPV.PV.fv env (EcMemory.memory mem) (EcAst.hs_po hs).inv) in + + begin + try + if not (EcCircuits.instrs_equiv (FApi.tc1_hyps tc) ~keep mem target s.s_node) then + tc_error !!tc "statements are not circuit-equivalent" + with e -> + tc_error !!tc "circuit-equivalence checker error: %s" (Printexc.to_string e) + end; + { zp with z_tail = s.s_node @ tl } in + + let hs = { hs with hs_s = Zpr.zip zp; hs_m = mem; } in + + FApi.xmutate1 tc `BChange EcAst.[EcFol.f_hoareS (hs.hs_m |> snd) (hs_pr hs) (hs.hs_s) (hs_po hs)] + (* -------------------------------------------------------------------- *) type idassign_t = pcodepos * pqsymbol @@ -23,10 +94,13 @@ let process_idassign ((cpos, pv) : idassign_t) (tc : tcenv1) = let s = Zpr.zipper_of_cpos env cpos hs.hs_s in let s = { s with z_tail = sasgn :: s.z_tail } in { hs with hs_s = Zpr.zip s } in - FApi.xmutate1 tc `IdAssign [EcFol.f_hoareS (snd hs.hs_m) (hs_pr hs) (hs.hs_s) (hs_po hs)] + FApi.xmutate1 tc `IdAssign EcAst.[EcFol.f_hoareS (hs.hs_m |> snd) (hs_pr hs) (hs.hs_s) (hs_po hs)] (* -------------------------------------------------------------------- *) let process_rw_prgm (mode : rwprgm) (tc : tcenv1) = match mode with | `IdAssign (cpos, pv) -> process_idassign (cpos, pv) tc + | `Change (cpos, bindings, i, s) -> + process_change (cpos, bindings, i, s) tc + diff --git a/tests/abstract_bind.ec b/tests/abstract_bind.ec new file mode 100644 index 0000000000..fb04b44def --- /dev/null +++ b/tests/abstract_bind.ec @@ -0,0 +1,70 @@ +require import AllCore List Int IntDiv CoreMap Real Number Bool. + +require import QFABV. + +abstract theory Test. +type t. + +op size : int. + +axiom size_gt0 : 0 < size. + +op add : t -> t -> t. + +op w2bits : t -> bool list. + +op bits2w : bool list -> t. + +op touint : t -> int. + +op tosint : t -> int. + +op ofint : int -> t. + +(* +axiom t_tolistP: forall (bv : t), bits2w (w2bits bv) = bv. +axiom t_oflistP: forall (xs : bool list), + size xs = Test.size => w2bits (bits2w xs) = xs. +axiom t_touintP: forall (bv : t), + Test.touint bv = BitEncoding.BS2Int.bs2int (w2bits bv). +axiom t_tosintP: forall (bv : t), + Test.size = 1 \/ + let v = BitEncoding.BS2Int.bs2int (w2bits bv) in + if msb bv then Test.tosint bv = v - 2 ^ Test.size + else Test.tosint bv = v. +axiom t_ofintP: forall (i : int), + Test.ofint i = bits2w (BitEncoding.BS2Int.int2bs Test.size i). +*) + +bind bitstring w2bits bits2w touint tosint ofint t size. + +realize gt0_size. by apply size_gt0. qed. + +realize tolistP by admit. + +realize touintP by admit. + +realize size_tolist by admit. + +realize oflistP by admit. + +realize tosintP by admit. + +realize ofintP by admit. + +bind op t add "add". + +realize bvaddP by admit. + +end Test. + +clone import Test as CTest + with type t <- bool, + op size <- 1, + op add <- (^^). + +print CTest. + +lemma xor2_false (b: bool) : b ^^ b = CTest.ofint 0. + +bdep solve. qed. diff --git a/tests/circuit_test.ec b/tests/circuit_test.ec new file mode 100644 index 0000000000..8552d8f83e --- /dev/null +++ b/tests/circuit_test.ec @@ -0,0 +1,176 @@ +require import AllCore List QFABV IntDiv. + + +theory FakeWord. +type W. +op size : int. + +op to_bits : W -> bool list. +op from_bits : bool list -> W. +op of_int : int -> W. +op to_uint : W -> int. +op to_sint : W -> int. + +bind bitstring + to_bits + from_bits + to_uint + to_sint + of_int + W + size. + +realize gt0_size by admit. +realize tolistP by admit. +realize oflistP by admit. +realize touintP by admit. +realize tosintP by admit. +realize ofintP by admit. +realize size_tolist by admit. + + + +op bool2bits (b : bool) : bool list = [b]. +op bits2bool (b: bool list) : bool = List.nth false b 0. + +op i2b : int -> bool. +op b2si (b: bool) = 0. + +bind bitstring bool2bits bits2bool b2i b2si i2b bool 1. +realize size_tolist by auto. +realize tolistP by auto. + +realize oflistP by rewrite /bool2bits /bits2bool;smt(size_eq1). +realize ofintP by admit. +realize touintP by admit. +realize tosintP by move => bv => //. +realize gt0_size by done. + +op (+^) : W -> W -> W. + +bind op W (+^) "xor". +realize bvxorP by admit. + +end FakeWord. + +type W8. + +clone include FakeWord with + op size <- 8, + type W <- W8. + +module M = { + proc test (a: W8, b: W8) = { + var c : W8; + c <- a +^ b; + return c; + } +}. + +op "_.[_]" : W8 -> int -> bool. + +bind op [W8 & bool] "_.[_]" "get". +realize le_size by auto. +realize eq1_size by auto. +realize bvgetP by admit. + +lemma W8_ext (a: W8) : List.all (fun i => a.[i] = a.[i]) (iota_ 0 8). +proof. +extens : circuit. +qed. + + + +lemma W8_xor_ext (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. +proc. +(* extens [a] : (wp; skip; smt()). *) +(* FIXME : while debugging fhash *) admit. +qed. + + +lemma W8_xor_simp (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. +proc. +(* circuit simplify; trivial. *) admit. +qed. + + +lemma W8_xor_ext2 (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. +proc. +admit. +(* extens [a] : circuit. *) +qed. + +lemma W8_xor_ext_simp (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. +proc. +(* extens [a] : by circuit simplify; trivial. (* FIXME: without by does not work *) *) admit. +qed. + + +(* +lemma xor_0 (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b /\ a_ = b_ ==> res = of_int 0]. +proof. + proc. + proc change 1 : { c <- b +^ a; }. + wp. skip. move => &h1 &h2. + have : a{h1} = a_ by admit. + have : b{h1} = b_ by admit. + move => A B [] C D. + have : a{h2} = a_ by smt(). + have : b{h2} = b_ by smt(). + (* move : A B C D. (* Comment or uncomment this line for different modes of working *) *) + bdep solve. +bdep solve. +qed. +*) + + +lemma xor_com (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b /\ a_ = b_ ==> res = b_ +^ a_]. +proof. + proc. + proc change 1 : [ d : W8 ] { d <- of_int 0; d <- a +^ d; c <- d +^ b; }. + circuit. + circuit. +qed. + +theory Array8. +type 'a t. + +op tolist : 'a t -> 'a list. +op oflist : 'a list -> 'a t. +op "_.[_]" : 'a t -> int -> 'a. +op "_.[_<-_]" : 'a t -> int -> 'a -> 'a t. + +end Array8. + +bind array Array8."_.[_]" Array8."_.[_<-_]" Array8.tolist Array8.oflist Array8.t 8. +realize gt0_size by auto. +realize tolistP by admit. +realize eqP by admit. +realize get_setP by admit. +realize get_out by admit. + + +op init_8_8 (f: int -> W8) : W8 Array8.t. + +bind op [W8 & Array8.t] init_8_8 "ainit". +realize bvainitP by admit. + +print Array8."_.[_]". + +op get : W8 Array8.t -> int -> W8 = Array8."_.[_]". + +lemma init_test (_aw: W8 Array8.t) : + init_8_8 (fun i => get _aw ((i * -1) %% 8)) = + init_8_8 (fun i => + get (init_8_8 + (get (init_8_8 (fun k => + get (init_8_8 (fun (l: int) => + get _aw ((l*5)%%8))) ((k * 3) %% 8))))) i ). +proof. +circuit. +qed. + diff --git a/tests/ext_test.ec b/tests/ext_test.ec new file mode 100644 index 0000000000..b6e679925b --- /dev/null +++ b/tests/ext_test.ec @@ -0,0 +1,13 @@ +require import AllCore Int List. + +print List.Iota.iota_. +print List.all. +print List.Iota. + +lemma random : List.all (fun i => i = i) + (List.Iota.iota_ 0 10). + proof. + + extens trivial. + qed. + diff --git a/tests/procchange.ec b/tests/procchange.ec index 6863802f09..cdc2924952 100644 --- a/tests/procchange.ec +++ b/tests/procchange.ec @@ -14,8 +14,7 @@ theory ProcChangeAssignEquiv. lemma L : equiv[M.f ~ M.f: true ==> true]. proof. proc. - proc change {1} [1..3] : { x <- 3; }. - + proc change {1} [1..3] : [y : int] { y <- 3; x <- y; }. wp. skip. smt(). abort. end ProcChangeAssignEquiv. @@ -93,9 +92,13 @@ theory ProcChangeWhileEquiv. x <- x + 1 + 0; } }. + (* proc rewrite {1} 1 /=. *) + admit. (* FIXME *) + (* proc rewrite {1} 1 /=. proc rewrite {2} 1.1 /=. sim. + *) abort. end ProcChangeWhileEquiv. diff --git a/theories/algebra/StdBigop.ec b/theories/algebra/StdBigop.ec index c3c9821ddf..9e246deef4 100644 --- a/theories/algebra/StdBigop.ec +++ b/theories/algebra/StdBigop.ec @@ -86,6 +86,13 @@ lemma big_constz (P : 'a -> bool) x s: BIA.big P (fun i => x) s = x * (count P s). proof. by rewrite BIA.sumr_const -IntID.intmulz. qed. +lemma sumz_nseq (n v : int) : 0 <= n => sumz (nseq n v) = n * v. +proof. +move=> ge0_n; rewrite sumzE (_ : n = size (iota_ 0 n)). +- by rewrite size_iota lez_maxr. +by rewrite -map_nseq BIA.big_map /(\o) /= big_constz count_predT mulzC. +qed. + lemma bigi_constz x (n m:int): n <= m => BIA.bigi predT (fun i => x) n m = x * (m - n). diff --git a/theories/datatypes/List.ec b/theories/datatypes/List.ec index 7d8d0c2aa0..480c72ecdb 100644 --- a/theories/datatypes/List.ec +++ b/theories/datatypes/List.ec @@ -1890,6 +1890,13 @@ lemma map_comp (f1 : 'b -> 'c) (f2 : 'a -> 'b) s: map (f1 \o f2) s = map f1 (map f2 s). proof. by elim: s => //= x s ->. qed. +lemma map_nseq ['a 'b] (x : 'b) (s : 'a list) : + map (fun _ => x) s = nseq (size s) x. +proof. +elim: s => /= [|s ih]; first by rewrite nseq0. +by rewrite addzC nseqS 1:size_ge0 ih. +qed. + lemma map_id (s : 'a list): map idfun s = s. proof. by elim: s => //= x s ->. qed. diff --git a/theories/datatypes/QFABV.ec b/theories/datatypes/QFABV.ec new file mode 100644 index 0000000000..cd904a4185 --- /dev/null +++ b/theories/datatypes/QFABV.ec @@ -0,0 +1,552 @@ +(* -------------------------------------------------------------------- *) +require import AllCore List Int IntDiv BitEncoding. +(* - *) import BS2Int. + +(* ==================================================================== *) +abstract theory BV. + op size : int. + + axiom [bydone] gt0_size : 0 < size. + + type bv. + + op tolist : bv -> bool list. + op oflist : bool list -> bv. + + op touint : bv -> int. + op tosint : bv -> int. + op ofint : int -> bv. + + op get (b: bv) (n: int) : bool = + List.nth false (tolist b) n. + + op msb (b: bv) : bool = + List.nth false (tolist b) (size - 1). + + axiom size_tolist (bv : bv): List.size (tolist bv) = size. + + axiom tolistP (bv : bv) : oflist (tolist bv) = bv. + axiom oflistP (xs : bool list) : size xs = size => tolist (oflist xs) = xs. + + axiom touintP (bv : bv) : + touint bv = bs2int (tolist bv). + + axiom tosintP (bv : bv) : + (size = 1) \/ + let v = bs2int (tolist bv) in + if (msb bv) then + tosint bv = v - 2^size + else + tosint bv = v. + + axiom ofintP (i : int) : + ofint i = oflist (int2bs size i). +end BV. + +(* ==================================================================== *) +(* FIXME: Missing of_list axiomatization *) +abstract theory A. + op size : int. + + axiom [bydone] gt0_size : 0 < size. + + type 'a t. + + op get ['a] : 'a t -> int -> 'a. + + op set ['a] : 'a t -> int -> 'a -> 'a t. + + op to_list ['a] : 'a t -> 'a list. + + axiom tolistP ['a] (a : 'a t) : + to_list a = mkseq (fun i => get a i) size. + + axiom eqP ['a] (a1 a2 : 'a t) : + (forall i, 0 <= i < size => get a1 i = get a2 i) + <=> (a1 = a2). + + axiom get_setP ['a] (a : 'a t) (i j : int) (v : 'a) : + 0 <= i < size + => 0 <= j < size + => get (set a j v) i = if i = j then v else get a i. + + axiom get_out ['a] (a1 a2 : 'a t) (i : int) : + !(0 <= i < size) => get a1 i = get a2 i. +end A. + +(* ==================================================================== *) +theory BVOperators. + (* ------------------------------------------------------------------ *) + abstract theory BVAdd. + clone import BV. + + op bvadd : bv -> bv -> bv. + + axiom bvaddP (bv1 bv2 : bv) : + touint (bvadd bv1 bv2) = (touint bv1 + touint bv2) %% 2^BV.size. + end BVAdd. + + (* ------------------------------------------------------------------ *) + abstract theory BVSub. + clone import BV. + + op bvsub : bv -> bv -> bv. + + axiom bvsubP (bv1 bv2 : bv) : + touint (bvsub bv1 bv2) = (touint bv1 - touint bv2) %% 2^BV.size. + end BVSub. + + abstract theory BVOpp. + clone import BV. + + op bvopp : bv -> bv. + + axiom bvoppP (bv : bv) : + tosint (bvopp bv) = -(tosint bv). + end BVOpp. + + (* ------------------------------------------------------------------ *) + abstract theory BVMul. + clone import BV. + + op bvmul : bv -> bv -> bv. + + axiom bvmulP (bv1 bv2 : bv) : + touint (bvmul bv1 bv2) = (touint bv1 * touint bv2) %% 2^BV.size. + end BVMul. + + (* ------------------------------------------------------------------ *) + abstract theory BVUDiv. + clone import BV. + + op bvudiv : bv -> bv -> bv. + + axiom bvudivP (bv1 bv2 : bv) : touint bv2 <> 0 => + touint (bvudiv bv1 bv2) = touint bv1 %/ touint bv2. + end BVUDiv. + + (* ------------------------------------------------------------------ *) + abstract theory BVURem. + clone import BV. + + op bvurem : bv -> bv -> bv. + + axiom bvuremP (bv1 bv2 : bv) : + touint (bvurem bv1 bv2) = touint bv1 %% touint bv2. + end BVURem. + + (* ------------------------------------------------------------------ *) + abstract theory BVSHL. + clone import BV. + + op bvshl : bv -> bv -> bv. + + axiom bvshlP (bv1 bv2 : bv) : touint (bvshl bv1 bv2) = + (touint bv1 * 2 ^ (touint bv2)) %% (2 ^ BV.size). + end BVSHL. + + (* ------------------------------------------------------------------ *) + abstract theory BVSHR. + clone import BV. + + op bvshr : bv -> bv -> bv. + + axiom bvshrP (bv1 bv2 : bv) : touint (bvshr bv1 bv2) = + touint bv1 %/ 2 ^ (touint bv2). + end BVSHR. + + (* ------------------------------------------------------------------ *) + abstract theory BVASHR. + clone import BV. + + op bvashr : bv -> bv -> bv. + + axiom bvashrP (bv1 bv2 : bv) : tosint (bvashr bv1 bv2) = + tosint bv1 %/ 2 ^ (touint bv2). + end BVASHR. + + (* ------------------------------------------------------------------ *) + abstract theory BVSHLS. + clone import BV as BV1. + clone import BV as BV2. + + op bvshls : BV1.bv -> BV2.bv -> BV1.bv. + + axiom bvshlsP (bv1 : BV1.bv) (bv2 : BV2.bv) : touint (bvshls bv1 bv2) = + (touint bv1 * 2 ^ (touint bv2)) %% (2 ^ BV1.size). + end BVSHLS. + + (* ------------------------------------------------------------------ *) + abstract theory BVSHRS. + clone import BV as BV1. + clone import BV as BV2. + + op bvshrs : BV1.bv -> BV2.bv -> BV1.bv. + + axiom bvshrsP (bv1 : BV1.bv) (bv2 : BV2.bv) : touint (bvshrs bv1 bv2) = + touint bv1 %/ 2 ^ (touint bv2). + end BVSHRS. + + (* ------------------------------------------------------------------ *) + abstract theory BVASHRS. + clone import BV as BV1. + clone import BV as BV2. + + op bvashrs : BV1.bv -> BV2.bv -> BV1.bv. + + axiom bvashrsP (bv1 : BV1.bv) (bv2 : BV2.bv) : tosint (bvashrs bv1 bv2) = + tosint bv1 %/ 2 ^ (touint bv2). + end BVASHRS. + + (* ------------------------------------------------------------------ *) + abstract theory BVROL. + clone import BV. + + op bvrol : bv -> bv -> bv. + + axiom bvrolP (bv1 bv2 : bv) (i: int) : + 0 <= i < BV.size => + List.nth false (tolist (bvrol bv1 bv2)) i = + List.nth false (tolist bv1) ((i-touint bv2)%%BV.size). + + end BVROL. + + (* ------------------------------------------------------------------ *) + abstract theory BVROR. + clone import BV. + + op bvror : bv -> bv -> bv. + + axiom bvrorP (bv1 bv2 : bv) (i: int): + 0 <= i < BV.size => + List.nth false (tolist (bvror bv1 bv2)) i = + List.nth false (tolist bv1) ((i+touint bv2)%%BV.size). + + end BVROR. + + (* ------------------------------------------------------------------ *) + abstract theory BVAnd. + clone import BV. + + op bvand : bv -> bv -> bv. + + axiom bvandP (bv1 bv2 : bv) : tolist (bvand bv1 bv2) = + map (fun (b : _ * _) => b.`1 /\ b.`2) (zip (tolist bv1) (tolist bv2)). + end BVAnd. + + (* ------------------------------------------------------------------ *) + abstract theory BVOr. + clone import BV. + + op bvor : bv -> bv -> bv. + + axiom bvorP (bv1 bv2 : bv) : tolist (bvor bv1 bv2) = + map (fun (b : _ * _) => b.`1 \/ b.`2) (zip (tolist bv1) (tolist bv2)). + end BVOr. + + (* ------------------------------------------------------------------ *) + abstract theory BVXor. + clone import BV. + + op bvxor: bv -> bv -> bv. + + axiom bvxorP (bv1 bv2 : bv) : tolist (bvxor bv1 bv2) = + map (fun (b : _ * _) => Bool.(^^) b.`1 b.`2)%Bool (zip (tolist bv1) (tolist bv2)). + end BVXor. + + (* ------------------------------------------------------------------ *) + abstract theory BVNot. + clone import BV. + + op bvnot : bv -> bv. + + axiom bvnotP (bv : bv) : tolist (bvnot bv) = + map (fun b => !b) (tolist bv). + end BVNot. + + (* ------------------------------------------------------------------ *) + abstract theory BVULt. + clone import BV as BV1 with op size <= 1. + clone import BV as BV2. + + op bvult : BV2.bv -> BV2.bv -> BV1.bv. + + axiom bvultP (bv1 bv2 : BV2.bv) : + BV1.touint (bvult bv1 bv2) <> 0 <=> (BV2.touint bv1 < BV2.touint bv2). + end BVULt. + +(* ------------------------------------------------------------------ *) + abstract theory BVSLt. + clone import BV as BV1 with op size <= 1. + clone import BV as BV2. + + op bvslt : BV2.bv -> BV2.bv -> BV1.bv. + + axiom bvsltP (bv1 bv2 : BV2.bv) : + BV1.touint (bvslt bv1 bv2) <> 0 <=> (BV2.tosint bv1 < BV2.tosint bv2). + end BVSLt. + + + (* ------------------------------------------------------------------ *) + abstract theory BVULe. + clone import BV as BV1 with op size <= 1. + clone import BV as BV2. + + op bvule : BV2.bv -> BV2.bv -> BV1.bv. + + axiom bvuleP (bv1 bv2 : BV2.bv) : + BV1.touint (bvule bv1 bv2) <> 0 <=> (BV2.touint bv1 <= BV2.touint bv2). + end BVULe. + +(* ------------------------------------------------------------------ *) + abstract theory BVSLe. + clone import BV as BV1 with op size <= 1. + clone import BV as BV2. + + op bvsle : BV2.bv -> BV2.bv -> BV1.bv. + + axiom bvsleP (bv1 bv2 : BV2.bv) : + BV1.touint (bvsle bv1 bv2) <> 0 <=> (BV2.tosint bv1 <= BV2.tosint bv2). + end BVSLe. + + + (* ------------------------------------------------------------------ *) + abstract theory BVZExtend. + clone BV as BV1. + clone BV as BV2. + + axiom [bydone] le_size : BV1.size <= BV2.size. + + op bvzextend : BV1.bv -> BV2.bv. + + axiom bvzextendP (bv : BV1.bv) : + BV1.touint bv = BV2.touint (bvzextend bv). + end BVZExtend. + +(* ------------------------------------------------------------------ *) + abstract theory BVSExtend. + clone BV as BV1. + clone BV as BV2. + + axiom [bydone] le_size : BV1.size <= BV2.size. + + op bvsextend : BV1.bv -> BV2.bv. + + axiom bvsextendP (bv : BV1.bv) : + BV1.tosint bv = BV2.tosint (bvsextend bv). + end BVSExtend. + + (* ------------------------------------------------------------------ *) + abstract theory BVTruncate. + clone BV as BV1. + clone BV as BV2. + + axiom [bydone] le_size : BV2.size <= BV1.size. + + op bvtruncate : BV1.bv -> BV2.bv. + + axiom bvtruncateP (bv : BV1.bv) : + take BV2.size (BV1.tolist bv) = BV2.tolist (bvtruncate bv). + end BVTruncate. + + (* ------------------------------------------------------------------ *) + abstract theory BVExtract. + clone BV as BV1. + clone BV as BV2. + + axiom [bydone] le_size : BV2.size <= BV1.size. + + op bvextract : BV1.bv -> int -> BV2.bv. + + axiom bvextractP (bv : BV1.bv) (base : int) : 0 <= base => base + BV2.size <= BV1.size => + take BV2.size (drop base (BV1.tolist bv)) = BV2.tolist (bvextract bv base). + end BVExtract. + +print List.mkseq. + +(* ------------------------------------------------------------------ *) + abstract theory BVInsert. + clone BV as BV1. + clone BV as BV2. + + axiom [bydone] le_size : BV2.size <= BV1.size. + + op bvinsert : BV1.bv -> int -> BV2.bv -> BV1.bv. + + axiom bvinsertP (bv : BV1.bv) (base : int) (bvins: BV2.bv) : 0 <= base => base + BV2.size <= BV1.size => + let orig = BV1.tolist bv in + let new = BV2.tolist bvins in + List.mkseq (fun i => if i < base || base + BV2.size <= i + then List.nth witness orig i + else List.nth witness new (i - base)) + BV1.size + = BV1.tolist (bvinsert bv base bvins). + end BVInsert. + +(* ------------------------------------------------------------------ *) + abstract theory BVGet. + clone BV as BV1. + clone BV as BV2. + + axiom [bydone] le_size : BV2.size <= BV1.size. + axiom [bydone] eq1_size : BV2.size = 1. + + op bvget : BV1.bv -> int -> BV2.bv. + + axiom bvgetP (bv : BV1.bv) (idx: int) : + List.nth false (BV2.tolist (bvget bv idx)) 0 = List.nth false (BV1.tolist bv) idx. + end BVGet. + + (* ------------------------------------------------------------------ *) + abstract theory BVASliceGet. + clone BV as BV1. + clone BV as BV2. + clone A. + + axiom [bydone] le_size : BV2.size <= BV1.size * A.size. + + op bvasliceget : (BV1.bv A.t) -> int -> BV2.bv. + + (* We need the definition of target semantic to allow + a rewrite without conditions, but the binding just + needs to be correct for valid offsets *) + axiom bvaslicegetP (arr : BV1.bv A.t) (offset : int) : + 0 <= offset <= BV1.size * A.size - BV2.size => + let base = List.flatten (List.map BV1.tolist (A.to_list arr)) in + let ret = bvasliceget arr offset in + forall i, 0 <= i < BV2.size => + nth false (BV2.tolist ret) i = nth false (take BV2.size (List.drop offset base)) i. + end BVASliceGet. + + (* ------------------------------------------------------------------ *) + abstract theory BVASliceSet. + clone BV as BV1. + clone BV as BV2. + clone A. + + axiom [bydone] le_size : BV2.size <= BV1.size * A.size. + + op bvasliceset : (BV1.bv A.t) -> int -> (BV2.bv) -> BV1.bv A.t. + + (* We need the definition of target semantic to allow + a rewrite without conditions, but the binding just + needs to be correct for valid offsets *) + axiom bvaslicesetP (arr : BV1.bv A.t) (offset : int) (bv: BV2.bv): + 0 <= offset <= BV1.size * A.size - BV2.size => + let input_arr = List.flatten (List.map (BV1.tolist) (A.to_list arr)) in + let input_bv = BV2.tolist bv in + let output_arr = List.flatten (List.map BV1.tolist (A.to_list (bvasliceset arr offset bv))) in + forall i, 0 <= i < BV1.size * A.size => + List.nth false output_arr i = + if offset <= i < offset + BV2.size then + List.nth false input_bv (i - offset) + else + List.nth false input_arr i. + end BVASliceSet. + + (* ------------------------------------------------------------------ *) + abstract theory BVConcat. + clone BV as BV1. + clone BV as BV2. + clone BV as BV3. + + axiom [bydone] eq_size : BV1.size + BV2.size = BV3.size. + + op bvconcat : BV1.bv -> BV2.bv -> BV3.bv. + + axiom bvconcatP (bv1 : BV1.bv) (bv2 : BV2.bv) : + BV3.tolist (bvconcat bv1 bv2) = BV1.tolist bv1 ++ BV2.tolist bv2. + end BVConcat. + + (* ------------------------------------------------------------------ *) + abstract theory BVInit. + clone BV as BV1. + clone BV as BV2. + + axiom [bydone] size_1 : BV1.size = 1. + + op bvinit : (int -> BV1.bv) -> BV2.bv. + + axiom bvinitP (f : int -> BV1.bv) : + BV2.tolist (bvinit f) = List.flatten (List.mkseq (fun i => BV1.tolist (f i)) BV2.size). + end BVInit. + + (* ------------------------------------------------------------------ *) + abstract theory BVAInit. + clone BV. + clone A. + + op bvainit : (int -> BV.bv) -> BV.bv A.t. + + axiom bvainitP (f : int -> BV.bv) : + A.to_list (bvainit f) = List.mkseq (fun i => (f i)) A.size. + end BVAInit. + + (* ------------------------------------------------------------------ *) + abstract theory BVMap. + clone BV as BV1. + clone BV as BV2. + clone A. + + op map (f: BV1.bv -> BV2.bv) (abv: BV1.bv A.t) : BV2.bv A.t. + + axiom mapP (f: BV1.bv -> BV2.bv) (abv: BV1.bv A.t) : + A.to_list (map f abv) = List.map f (A.to_list abv). + end BVMap. + + (* ------------------------------------------------------------------ *) + abstract theory BVA2B. + clone BV as BV1. + clone BV as BV2. + clone A. + + axiom [bydone] size_ok : A.size * BV2.size = BV1.size. + + op bva2b : BV2.bv A.t -> BV1.bv. + + axiom a2bP (bva : BV2.bv A.t) : + flatten (map BV2.tolist (A.to_list bva)) = BV1.tolist (bva2b bva). + end BVA2B. + + (* ------------------------------------------------------------------ *) + abstract theory BVB2A. + clone BV as BV1. + clone BV as BV2. + clone A. + + axiom [bydone] size_ok : A.size * BV2.size = BV1.size. + + op bvb2a : BV1.bv -> BV2.bv A.t. + + axiom b2aP (bva : BV1.bv) : + BV1.tolist bva = flatten (map BV2.tolist (A.to_list (bvb2a bva))). + end BVB2A. + + (* ------------------------------------------------------------------ *) + abstract theory A2B2A. (* choubidoubidou *) + clone BV as BV1. + clone BV as BV2. + clone import A. + + axiom [bydone] size_ok : A.size * BV2.size = BV1.size. + + clone import BVA2B with + theory BV1 <- BV1, + theory BV2 <- BV2, + theory A <- A + proof size_ok by exact/size_ok. + + clone import BVB2A with + theory BV1 <- BV1, + theory BV2 <- BV2, + theory A <- A + proof size_ok by exact/size_ok. + + lemma a2bK : cancel bva2b bvb2a. + proof. admitted. + + lemma b2aK : cancel bva2b bvb2a. + proof. admitted. + end A2B2A. +end BVOperators. + diff --git a/theories/dune b/theories/dune index ef2fab8389..ec4b5757c2 100644 --- a/theories/dune +++ b/theories/dune @@ -1,4 +1,3 @@ (install (section (site (easycrypt theories))) (files (glob_files_rec *.{ec,eca}))) - From 1cbd638f9746bee61e75d3b9907938fbf779fd1a Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Thu, 22 Jan 2026 20:34:16 +0000 Subject: [PATCH 002/145] First pass on new error reporting --- src/ecCircuits.ml | 391 +++++++++++++++++++++++++------------------ src/ecCircuits.mli | 44 +++-- src/ecLowCircuits.ml | 268 ++++++++++++++++++----------- src/phl/ecPhlBDep.ml | 177 ++++++++++---------- 4 files changed, 519 insertions(+), 361 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index c17750048b..ff2c79a519 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -114,27 +114,30 @@ module AInvFHash = struct f_tuple (List.map (doit st) comps) | Fproj (tp, i) -> f_proj (doit st tp) i f.f_ty - | FhoareF { hf_m; hf_pr; hf_f; hf_po } -> - let npre = doit st hf_pr in - let npo = doit st hf_po in - let m = hf_m in - f_hoareF {inv=npre;m} hf_f {inv=npo;m} - | FhoareS { hs_m=(m, me); hs_pr; hs_s; hs_po } -> - let npre = doit st hs_pr in - let npo = doit st hs_po in - f_hoareS me {inv=npre;m} hs_s {inv=npo;m} + | FhoareF hf -> + let npre = doit st (hf_pr hf).inv in + let npo = doit st (hf_po hf).inv in + let m = hf.hf_m in + f_hoareF {inv=npre;m} hf.hf_f {inv=npo;m} + | FhoareS hs -> + let m, me = hs.hs_m in + let npre = doit st (hs_pr hs).inv in + let npo = doit st (hs_po hs).inv in + f_hoareS me {inv=npre;m} hs.hs_s {inv=npo;m} | FbdHoareF _ -> assert false | FbdHoareS _ -> assert false | FeHoareF _ -> assert false | FeHoareS _ -> assert false - | FequivF { ef_ml; ef_mr; ef_pr; ef_fl; ef_fr; ef_po } -> - let npre = doit st ef_pr in - let npo = doit st ef_po in - f_equivF {inv=npre;ml=ef_ml;mr=ef_mr} ef_fl ef_fr {inv=npo;ml=ef_ml;mr=ef_mr} - | FequivS { es_ml=(ml, mel); es_mr=(mr, mer); es_pr; es_sl; es_sr; es_po } -> - let npre = doit st es_pr in - let npo = doit st es_po in - f_equivS mel mer {inv=npre;ml;mr} es_sl es_sr {inv=npo;ml;mr} + | FequivF ef -> + let npre = doit st (ef_pr ef).inv in + let npo = doit st (ef_po ef).inv in + f_equivF {inv=npre;ml=ef.ef_ml;mr=ef.ef_mr} ef.ef_fl ef.ef_fr {inv=npo;ml=ef.ef_ml;mr=ef.ef_mr} + | FequivS es -> + let ml, mel = es.es_ml in + let mr, mer = es.es_mr in + let npre = doit st (es_pr es).inv in + let npo = doit st (es_po es).inv in + f_equivS mel mer {inv=npre;ml;mr} es.es_sl es.es_sr {inv=npo;ml;mr} | FeagerF _ -> assert false | Fpr _ -> assert false | Fint _ @@ -157,28 +160,111 @@ end (* -------------------------------------------------------------------- *) type width = int -exception MissingTyBinding of ty -exception AbstractTyBinding of ty -exception InvalidArgument -exception MissingOpBinding of path -exception MissingOpSpec of path -exception IntConversionFailure -exception DestrError of string (* FIXME: change this one *) -exception MissingOpBody (* FIXME: rename? *) -exception BadFormForArg (* FIXME: rename *) -exception CantConvertToConstant -exception CantReadWriteGlobs -exception CantConvertToCirc of + +type circuit_conversion_call = [ + | `Convert of form + | `ToArg of form + | `ExpandIter of form * form list + | `Instr of instr +] + +type circuit_error = +| MissingTyBinding of [`Ty of ty | `Path of path] +| AbstractTyBinding of [`Ty of ty | `Path of path] +| InvalidArgument +| MissingOpBinding of path +| MissingOpSpec of path +| IntConversionFailure +| DestrError of string (* FIXME: change this one *) +| MissingOpBody of path (* FIXME: rename? *) +| CantConvertToConstant +| CantReadWriteGlobs +| BadFormForArg of form +| CantConvertToCirc of [ `Int | `OpK of EcFol.op_kind | `Op of path | `Quantif of quantif | `Match | `Glob + | `ModGlob | `Record | `Hoare | `Instr ] +| PropagateError of circuit_conversion_call * circuit_error (* FIXME: make this lazy *) + +exception CircError of circuit_error + +let circ_error (err: circuit_error) = + raise (CircError err) + +let propagate_circ_error (call: circuit_conversion_call) (err: circuit_error) = + raise (CircError (PropagateError (call, err))) + +let rec pp_circ_error ppe fmt (err: circuit_error) = + let open EcPrinting in + match err with + | MissingTyBinding t -> + Format.fprintf fmt "Missing type binding for "; + begin match t with + | `Path pth -> Format.fprintf fmt "type at path %a" pp_path pth + | `Ty ty -> Format.fprintf fmt "type %a" (pp_type ppe) ty + end + | AbstractTyBinding t -> + Format.fprintf fmt "No concrete (only abstract) type binding for "; + begin match t with + | `Path pth -> Format.fprintf fmt "type at path %a" pp_path pth + | `Ty ty -> Format.fprintf fmt "type %a" (pp_type ppe) ty + end + | InvalidArgument -> assert false + | MissingOpBinding pth -> + Format.fprintf fmt "Missing op binding for operator at path %a" pp_path pth + | MissingOpSpec pth -> + Format.fprintf fmt "Missing op spec binding for operator at path %a" pp_path pth + | IntConversionFailure -> + (* FIXME: check that this actually prints the form, otherwise add it *) + Format.fprintf fmt "Failed to convert form to concrete integer" + | DestrError _ -> assert false + | MissingOpBody pth -> + Format.fprintf fmt "No body for operator at path %a" pp_path pth + | CantConvertToConstant -> + Format.fprintf fmt "Failed to reduce circuit to constant after composition (while attempting to compute)" + | CantReadWriteGlobs -> + Format.fprintf fmt "Cannot reason about programs which write to global variables using circuits" + | BadFormForArg f -> + Format.fprintf fmt "Form %a does not match any known conversion pattern from form to argument" (pp_form ppe) f + | CantConvertToCirc reason -> + Format.fprintf fmt "Failed circuit conversion due to: "; + begin match reason with + | `Int -> Format.fprintf fmt "Encountered unexpected integer (maybe you are missing a binding?)" + | `OpK opk -> Format.fprintf fmt "Don't know how to translate op kind: %a" (fun _ _ -> assert false) opk + | `Op pth -> Format.fprintf fmt "Don't know how to convert operator at path %a to circuit (not concrete and does not match any known operator kind)" pp_path pth + | `Quantif qnt -> + Format.fprintf fmt "Encountered unexpected quantifier %s" + (* FIXME: put into pp_quantif function *) + begin match qnt with + | Lforall -> "Forall" + | Lexists -> "Exists" + | Llambda -> "Lambda" + end + | `Match -> Format.fprintf fmt "Conversion of match statements not supported" + | `Glob -> Format.fprintf fmt "Global variables not supported in conversion" + | `ModGlob -> Format.fprintf fmt "Conversion of module globals not supported" + | `Record -> Format.fprintf fmt "Conversion of records not supported" + | `Hoare -> Format.fprintf fmt "Direct conversion of hoare statements not supported" + | `Instr -> assert false + end + | PropagateError (call, e) -> + pp_circ_error ppe fmt e; + Format.fprintf fmt "@\nWhile attemping "; + begin match call with + | `Convert f -> Format.fprintf fmt "conversion of form %a" (pp_form ppe) f + | `ToArg f -> Format.fprintf fmt "conversion to arg of form %a" (pp_form ppe) f + | `ExpandIter (f, args) -> Format.eprintf "expansion of iter %a(%a)" (pp_form ppe) f (pp_list ", " (pp_form ppe)) args + | `Instr inst -> Format.eprintf "processing of instruction %a" (pp_instr ppe) inst + end + let ty_of_path (p: path) : ty = EcTypes.tconstr p [] @@ -194,24 +280,18 @@ let rec ctype_of_ty (env: env) (ty: ty) : ctype = begin match EcEnv.Circuit.lookup_bitstring_size env ty with | Some sz -> CBitstring sz | _ -> - raise (MissingTyBinding ty) + circ_error (MissingTyBinding (`Ty ty)) end | Some ({size = (_, None)}, _) -> - raise (AbstractTyBinding ty) + circ_error (AbstractTyBinding (`Ty ty)) | Some (_, {size = (_, None)}) -> - raise (AbstractTyBinding ty) + circ_error (AbstractTyBinding (`Ty ty)) end let width_of_type (env: env) (t: ty) : int = let cty = ctype_of_ty env t in EcLowCircuits.size_of_ctype cty -(* FIXME: Fix an order for array size parameters, this one goes against the rest *) -let shape_of_array_type (env: env) (t: ty) : (int * int) = - match ctype_of_ty env t with - | CArray {width=w; count=n} -> (n, w) - | _ -> raise InvalidArgument - let input_of_type ~name (env: env) (t: ty) : circuit = let ct = ctype_of_ty env t in input_of_ctype ~name ct @@ -242,7 +322,7 @@ module BVOps = struct | `BvBind op -> op | `Path p -> begin match EcEnv.Circuit.lookup_bvoperator_path env p with | Some op -> op - | None -> raise (MissingOpBinding p) + | None -> circ_error (MissingOpBinding p) end in circuit_of_parametric_bvop op args @@ -277,7 +357,7 @@ module BVOps = struct | `BvBind op -> op | `Path p -> begin match EcEnv.Circuit.lookup_bvoperator_path env p with | Some op -> op - | None -> raise (MissingOpBinding p) + | None -> circ_error (MissingOpBinding p) end in circuit_of_bvop op @@ -297,7 +377,7 @@ module BitstringOps = struct | `BSBinding bnd -> bnd | `Path p -> begin match EcEnv.Circuit.reverse_bitstring_operator env p with | Some bnd -> bnd - | None -> raise (MissingOpBinding p) + | None -> circ_error (MissingOpBinding p) end in (* assert false => should be guarded by a previous call to op_is_bsop *) @@ -306,10 +386,10 @@ module BitstringOps = struct | {size = (_, Some size)}, `OfInt -> begin match args with | [ `Constant i ] -> circuit_of_zint ~size i - | _args -> raise InvalidArgument + | _args -> assert false (* Should be caught by EC typechecking + binding correctness *) end | {size = (_, None); type_=ty}, `OfInt -> - raise (AbstractTyBinding (ty_of_path ty)) (* FIXME: check this, might want to add generic path -> ty conversion *) + circ_error (AbstractTyBinding (`Path ty)) (* FIXME: check this, might want to add generic path -> ty conversion *) | _bs, `To -> assert false (* doesn't translate to circuit *) | _bs, `ToSInt -> assert false (* doesn't translate to circuit *) | _bs, `ToUInt -> assert false (* doesn't translate to circuit *) @@ -332,7 +412,7 @@ module ArrayOps = struct | `ABinding bnd -> bnd | `Path p -> begin match EcEnv.Circuit.reverse_array_operator env p with | Some bnd -> bnd - | None -> raise (MissingOpBinding p) + | None -> circ_error (MissingOpBinding p) end in (* assert false => should be guarded by a call to op_is_arrayop *) @@ -341,19 +421,19 @@ module ArrayOps = struct | (_arr, `Get) -> begin match args with | [ `Circuit (({type_ = CArray _}, _inps) as arr); `Constant i] -> array_get arr (BI.to_int i) - | _args -> raise InvalidArgument + | _args -> assert false (* Should be caught by EC typechecking + binding correctness *) end | ({size = (_, Some size)}, `OfList) -> begin match args with | [ `Circuit dfl; `List cs ] -> array_oflist cs dfl size - | _args -> raise InvalidArgument + | _args -> assert false (* Should be caught by EC typechecking + binding correctness *) end - | ({size = (_, None); type_=ty}, `OfList) -> raise (AbstractTyBinding (ty_of_path ty)) + | ({size = (_, None); type_=ty}, `OfList) -> circ_error (AbstractTyBinding (`Path ty)) | (_arr, `Set) -> begin match args with | [ `Circuit (({type_ = CArray _}, _) as arr); `Constant i; `Circuit (({type_ = CBitstring _}, _) as bs) ] -> array_set arr (BI.to_int i) bs - | _args -> raise InvalidArgument + | _args -> assert false (* Should be caught by EC typechecking + binding correctness *) end end open ArrayOps @@ -367,7 +447,7 @@ module CircuitSpec = struct let c = match c with | `Path p -> begin match EcEnv.Circuit.reverse_circuit env p with | Some c -> c - | None -> raise (MissingOpSpec p) + | None -> circ_error (MissingOpSpec p) (* Will generally never happen *) end | `Bind c -> c in @@ -425,7 +505,7 @@ let circuit_of_op (env: env) (p: path) : circuit = let op = try EcEnv.Circuit.reverse_operator env p |> List.hd with Failure _ -> - raise (MissingOpBinding p) + circ_error (MissingOpBinding p) (* Will generally never happen *) in match op with | `Bitstring (_bs, _op) -> assert false (* Should be guarded by a call to op_is_base *) @@ -437,7 +517,7 @@ let circuit_of_op_with_args (env: env) (p: path) (args: arg list) : circuit = let op = try EcEnv.Circuit.reverse_operator env p |> List.hd with Failure _ -> - raise (MissingOpBinding p) + circ_error (MissingOpBinding p) (* Will generally never happen *) in match op with | `Bitstring bsbnd -> circuit_of_bsop env (`BSBinding bsbnd) args @@ -458,7 +538,7 @@ let int_of_form ?(redmode = EcReduction.full_red) (hyps: hyps) (f: form) : zint destr_int @@ EcCallbyValue.norm_cbv redmode hyps f with DestrError "int" - | DestrError "destr_int" -> raise IntConversionFailure + | DestrError "destr_int" -> circ_error IntConversionFailure end let rec form_list_of_form ?(ppe: EcPrinting.PPEnv.t option) (f: form) : form list = @@ -547,47 +627,47 @@ let circuit_of_form | OB_oper (Some (OP_Plain f)) -> f | _ -> - if debug then Format.eprintf "Failed to get body for op: %a (args: %a)\n" - (EcPrinting.pp_form ppe) op - (EcPrinting.(pp_list "," (pp_form ppe))) args; - raise MissingOpBody + circ_error (MissingOpBody pth) (* FIXME: how to actually print this? *) in let res = fapply_safe op args in res in let rec arg_of_form (st: state) (f: form) : arg = - match f.f_ty with - (* FIXME: check this (does this corrently detect ints?) *) - | t when t.ty_node = EcTypes.tint.ty_node -> arg_of_zint (int_of_form f) - | t when type_has_bindings env t -> - let f = doit st f in - arg_of_circuit f - | {ty_node = Tfun(i_t, c_t)} when - i_t.ty_node = EcTypes.tint.ty_node && - type_has_bindings env c_t -> - arg_of_init (fun i -> - let f = (fapply_safe f [f_int (BI.of_int i)]) in - doit st f - ) - | {ty_node = Tconstr(p, [t])} when - p = EcCoreLib.CI_List.p_list && - type_has_bindings env t -> - let cs = List.map (fun f -> doit st f) (form_list_of_form ~ppe f) in - arg_of_circuits cs - | _ -> Format.eprintf "Failed to convert form to arg: %a@." EcPrinting.(pp_form ppe) f; - raise BadFormForArg + try + match f.f_ty with + (* FIXME: check this (does this corrently detect ints?) *) + | t when t.ty_node = EcTypes.tint.ty_node -> arg_of_zint (int_of_form f) + | t when type_has_bindings env t -> + let f = doit st f in + arg_of_circuit f + | {ty_node = Tfun(i_t, c_t)} when + i_t.ty_node = EcTypes.tint.ty_node && + type_has_bindings env c_t -> + arg_of_init (fun i -> + let f = (fapply_safe f [f_int (BI.of_int i)]) in + doit st f + ) + | {ty_node = Tconstr(p, [t])} when + p = EcCoreLib.CI_List.p_list && + type_has_bindings env t -> + let cs = List.map (fun f -> doit st f) (form_list_of_form ~ppe f) in + arg_of_circuits cs + | _ -> Format.eprintf "Failed to convert form to arg: %a@." EcPrinting.(pp_form ppe) f; + circ_error (BadFormForArg f) + with CircError e -> + propagate_circ_error (`ToArg f) e (* State does not get backward propagated so it is not returned *) and doit (st: state) (f_: form) : circuit = try begin match f_.f_node with - | Fint _z -> raise (CantConvertToCirc `Int) + | Fint _z -> circ_error (CantConvertToCirc `Int) | Fif (c_f, t_f, f_f) -> let t = doit st t_f in let f = doit st f_f in let c = doit st c_f in - circuit_ite ~strict:true ~c ~t ~f + circuit_ite ~c ~t ~f | Flocal idn -> state_get st idn @@ -621,8 +701,8 @@ let circuit_of_form (circuit_true :> circuit) | Some `False -> (circuit_false :> circuit) - | Some opk -> raise (CantConvertToCirc (`OpK opk)) - | None -> raise (CantConvertToCirc (`Op (destr_op f_ |> fst))) + | Some opk -> circ_error (CantConvertToCirc (`OpK opk)) + | None -> circ_error (CantConvertToCirc (`Op (destr_op f_ |> fst))) end in op_cache := Mp.add pth circ !op_cache; @@ -703,7 +783,7 @@ let circuit_of_form begin match qnt with | Lforall | Llambda -> circ_lambda_oneshot st binds (fun st -> doit st f) (* FIXME: look at this interaction *) - | Lexists -> raise (CantConvertToCirc (`Quantif qnt)) + | Lexists -> circ_error (CantConvertToCirc (`Quantif qnt)) (* TODO: figure out how to handle quantifiers. Maybe just dont? *) end @@ -711,7 +791,7 @@ let circuit_of_form let ftp = doit st f in (circuit_tuple_proj ftp i :> circuit) - | Fmatch (_f, _fs, _ty) -> raise (CantConvertToCirc `Match) + | Fmatch (_f, _fs, _ty) -> circ_error (CantConvertToCirc `Match) | Flet (LSymbol (id, _t), v, f) -> let vc = doit st v in @@ -728,13 +808,13 @@ let circuit_of_form comps in doit st f - | Flet (LRecord _, _, _) -> raise (CantConvertToCirc `Record) + | Flet (LRecord _, _, _) -> circ_error (CantConvertToCirc `Record) | Fpvar (pv, mem) -> let v = match pv with | PVloc v -> v (* FIXME: Should globals be supported? *) - | _ -> raise (CantConvertToCirc `Glob) + | _ -> circ_error (CantConvertToCirc `Glob) in let v = match state_get_pv_opt st mem v with | Some v -> v @@ -744,7 +824,7 @@ let circuit_of_form in v - | Fglob (_id, _mem) -> raise (CantConvertToCirc `Glob) + | Fglob (_id, _mem) -> circ_error (CantConvertToCirc `ModGlob) | Ftuple comps -> let comps = @@ -761,49 +841,37 @@ let circuit_of_form | FequivF _ | FequivS _ | FeagerF _ - | Fpr _ -> raise (CantConvertToCirc `Hoare) + | Fpr _ -> circ_error (CantConvertToCirc `Hoare) (* FIXME: do we want to allow conversion of hoare statements? *) end with - | (CantConvertToCirc _) as e -> - Format.eprintf "Failed on form %a with error %s@." - EcPrinting.(pp_form ppe) f_ - (Printexc.to_string e); - assert false - | (MissingTyBinding ty) -> - Format.eprintf "Failed on form %a because of missing type binding for type %a@." - EcPrinting.(pp_form ppe) f_ - EcPrinting.(pp_type ppe) ty; - assert false - | e -> - Format.eprintf "Failed on %a with exception %s@." - EcPrinting.(pp_form ppe) f_ - (Printexc.to_string e); - assert false + | CircError e -> + propagate_circ_error (`Convert f_) e and trans_iter (st: state) (hyps: hyps) (f: form) (fs: form list) : circuit = - (* FIXME: move auxiliary function out of the definitions *) - let redmode = circ_red hyps in - let env = toenv hyps in - let ppenv = EcPrinting.PPEnv.ofenv env in - let fapply_safe f fs = - let res = EcTypesafeFol.fapply_safe ~redmode hyps f fs in - res - in - match f, fs with - | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iteri -> - let rep = int_of_form rep in - let fs = List.init (BI.to_int rep) (fun i -> - fapply_safe fn [f_int (BI.of_int i)] - ) in - List.fold_lefti (fun f i fn -> - if debug then Format.eprintf "Translating iteri... Step #%d@." i; - let fn = doit st fn in - circuit_compose fn [f] - ) (doit st base) fs - (* FIXME PR: this is currently being implemented directly on circuits, do we want this case as well? *) - | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iter -> assert false - | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_fold -> assert false - | _ -> raise (DestrError "iter") + try + (* FIXME: move auxiliary function out of the definitions *) + let redmode = circ_red hyps in + let fapply_safe f fs = + let res = EcTypesafeFol.fapply_safe ~redmode hyps f fs in + res + in + match f, fs with + | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iteri -> + let rep = int_of_form rep in + let fs = List.init (BI.to_int rep) (fun i -> + fapply_safe fn [f_int (BI.of_int i)] + ) in + List.fold_lefti (fun f i fn -> + if debug then Format.eprintf "Translating iteri... Step #%d@." i; + let fn = doit st fn in + circuit_compose fn [f] + ) (doit st base) fs + (* FIXME PR: this is currently being implemented directly on circuits, do we want this case as well? *) + | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iter -> assert false + | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_fold -> assert false + | _ -> raise (DestrError "iter") + with CircError e -> + propagate_circ_error (`ExpandIter (f, fs)) e in doit st f_ @@ -849,7 +917,7 @@ let circuit_of_path (hyps: hyps) (p: path) : circuit = let f = EcEnv.Op.by_path p (toenv hyps) in let f = match f.op_kind with | OB_oper (Some (OP_Plain f)) -> f - | _ -> raise MissingOpBody + | _ -> circ_error (MissingOpBody p) in circuit_of_form hyps f @@ -862,12 +930,7 @@ let vars_of_memtype (mt : memtype) = ) (Option.get lmt).lmt_decl -let process_instr ?me (hyps: hyps) (mem: memory) ~(st: state) (inst: instr) : state = - let env = toenv hyps in - let env = match me with - | Some me -> EcEnv.Memory.push_active_ss me env - | None -> env - in +let process_instr (hyps: hyps) (mem: memory) ~(st: state) (inst: instr) : state = (* if debug then Format.eprintf "[W] Processing : %a@." (EcPrinting.pp_instr (EcPrinting.PPEnv.ofenv env)) inst; *) (* let start = Unix.gettimeofday () in *) try @@ -890,7 +953,7 @@ let process_instr ?me (hyps: hyps) (mem: memory) ~(st: state) (inst: instr) : st (List.combine (List.map (function | (PVloc v, _ty) -> v - | _ -> raise (CantConvertToCirc `Glob)) vs) + | _ -> circ_error (CantConvertToCirc `Glob)) vs) es) in st | Sasgn (LvTuple (vs), e) -> @@ -899,27 +962,22 @@ let process_instr ?me (hyps: hyps) (mem: memory) ~(st: state) (inst: instr) : st let st = List.fold_left2 (fun st (pv, _ty) c -> let v = match pv with | PVloc v -> v - | _ -> raise (CantConvertToCirc `Glob) + | _ -> circ_error (CantConvertToCirc `Glob) in update_state_pv st mem v c ) st vs (comps :> circuit list) in st | _ -> - raise (CantConvertToCirc `Instr) + circ_error (CantConvertToCirc `Instr) with - | e -> - (* FIXME: Bad handling, use new exceptions *) - Format.eprintf "BDep failed on instr: %a@.Exception thrown: %s@.BACKTRACE: %s@.@." - (EcPrinting.pp_instr (EcPrinting.PPEnv.ofenv env)) inst - (Printexc.to_string e) - (Printexc.get_backtrace ()); - raise e + | CircError e -> + propagate_circ_error (`Instr inst) e (* FIXME: check if memory is the right one in calls to state *) let instrs_equiv (hyps : hyps ) - ((mem, mt) : memenv ) + ((mem, _mt) : memenv ) ?(keep : EcPV.PV.t option ) ?(st : state = empty_state ) (s1 : instr list ) @@ -931,10 +989,10 @@ let instrs_equiv let wr, wglobs = EcPV.PV.elements (EcPV.is_write env (s1 @ s2)) in if not (List.is_empty rglobs && List.is_empty wglobs) then - raise CantReadWriteGlobs; + circ_error CantReadWriteGlobs; if not (List.for_all (EcTypes.is_loc |- fst) (rd @ wr)) then - raise CantReadWriteGlobs; + circ_error CantReadWriteGlobs; let inputs = List.map (fun (pv, ty) -> { v_name = EcTypes.get_loc pv; v_type = ty; }) (rd @ wr) in let inputs = List.map (fun {v_name; v_type} -> (create v_name, ctype_of_ty env v_type)) inputs in @@ -951,9 +1009,9 @@ let instrs_equiv let vs = EcPV.PV.elements pv |> fst in let vs = List.map (function | (PVloc v, ty) -> (v, ty) - | _ -> raise (CantConvertToCirc `Glob) + | _ -> circ_error (CantConvertToCirc `Glob) ) vs - in List.for_all (fun (var, ty) -> + in List.for_all (fun (var, _ty) -> let circ1 = state_get_pv_opt st1 mem var in let circ2 = state_get_pv_opt st2 mem var in match circ1, circ2 with @@ -968,17 +1026,16 @@ let instrs_equiv circ_equiv circ1 circ2 ) -(* FIXME: remove variable list from the arguments *) (* FIXME: change memory -> memenv *) -let state_of_prog ?(close = false) ?me (hyps: hyps) (mem: memory) ?(st: state = empty_state) (proc: instr list) : state = +let state_of_prog ?(close = false) (hyps: hyps) (mem: memory) ?(st: state = empty_state) (proc: instr list) : state = let st = - List.fold_left (fun st -> process_instr ?me hyps mem ~st) st proc + List.fold_left (fun st -> process_instr hyps mem ~st) st proc in if close then close_circ_lambda st else st -let rec circ_simplify_form_bitstring_equality +let circ_simplify_form_bitstring_equality ?(st: state = empty_state) ?(pres: circuit list = []) (hyps: hyps) @@ -1001,7 +1058,7 @@ let rec circ_simplify_form_bitstring_equality let compute ~(sign: bool) (c: circuit) (args: zint list) : zint = match compute ~sign c (List.map (fun z -> arg_of_zint z) args) with | Some z -> z - | None -> raise CantConvertToConstant + | None -> circ_error CantConvertToConstant let circ_equiv ?(pcond: circuit option) c1 c2 = circ_equiv ?pcond c1 c2 @@ -1018,8 +1075,8 @@ let circuit_to_file = circuit_to_file let circuit_slice (c: circuit) (size: int) (offset: int) = circuit_slice ~size c offset -let circuit_flatten ((circ, inps) as c: circuit) = - convert_type (CBitstring (size_of_ctype circ.type_)) c +let circuit_flatten (({type_; _}, _) as c: circuit) = + convert_type (CBitstring (size_of_ctype type_)) c let state_get = state_get_pv let state_get_opt = state_get_pv_opt @@ -1069,11 +1126,14 @@ let circuit_state_of_hyps ?(strict = false) ?(use_mem = false) ?(st = empty_stat begin try update_state st id (circuit_of_form ~st hyps f) (* FIXME PR: Should only catch circuit translation errors, hack *) - with e -> + with CircError e -> + EcEnv.notify env EcGState.(`Debug) "Failed to translate hypothesis for var %s with error %a, skipping@." (tostring_internal id) (pp_circ_error ppe) e; try open_circ_lambda st [(id, ctype_of_ty env t)] (* FIXME PR: Should only catch circuit translation errors, hack *) - with e -> + with + | CircError (AbstractTyBinding _) + | CircError (MissingTyBinding _) as e -> if strict then raise e else st end @@ -1082,26 +1142,29 @@ let circuit_state_of_hyps ?(strict = false) ?(use_mem = false) ?(st = empty_stat | EcBaseLogic.LD_var (t, None) -> begin try open_circ_lambda st [(id, ctype_of_ty env t)] - (* FIXME PR: Should only catch circuit translation errors, hack *) - with e -> - if strict then raise e else st end + with + | CircError (AbstractTyBinding _) + | CircError (MissingTyBinding _) as e -> + if strict then raise e else st + end (* For things of the form a_ = a{&hr}, we assume the local variable takes precedence *) | EcBaseLogic.LD_hyp f -> - if debug then Format.eprintf "Form hyp: %a@.Simplified: %a@." - EcPrinting.(pp_form ppe) f - EcPrinting.(pp_form ppe) (EcCallbyValue.norm_cbv (circ_red hyps) hyps f) - ; begin match (EcCallbyValue.norm_cbv (circ_red hyps) hyps f) with | {f_node=Fapp ({f_node = Fop (p, _); _}, [{f_node = Fpvar (PVloc pv, m); _}; fv])} | {f_node=Fapp ({f_node = Fop (p, _); _}, [fv; {f_node = Fpvar (PVloc pv, m); _}])} when EcFol.op_kind p = Some `Eq -> begin try update_state_pv st m pv (circuit_of_form ~st hyps fv) (* FIXME PR: Should only catch circuit translation errors, hack *) - with e -> + with CircError e -> + EcEnv.notify env EcGState.(`Debug) "Failed to translate hypothesis %s => %a@\nWith error: %a@\nSkipping...@\n" + id.id_symb EcPrinting.(pp_form ppe) f (pp_circ_error ppe) e; st end - | _ -> st + | _ -> + EcEnv.notify env EcGState.(`Debug) "Hypothesis %s: %a does not match any circuit translation patterns, skipping...@\n" + id.id_symb EcPrinting.(pp_form ppe) f; + st end | _ -> st diff --git a/src/ecCircuits.mli b/src/ecCircuits.mli index 1f4b0d4cbb..7e10a8f45e 100644 --- a/src/ecCircuits.mli +++ b/src/ecCircuits.mli @@ -11,27 +11,43 @@ open EcLowCircuits module Map = Batteries.Map (* -------------------------------------------------------------------- *) -exception MissingTyBinding of ty -exception AbstractTyBinding of ty -exception InvalidArgument -exception MissingOpBinding of path -exception MissingOpSpec of path -exception IntConversionFailure -exception DestrError of string (* FIXME: change this one *) -exception MissingOpBody (* FIXME: rename? *) -exception BadFormForArg (* FIXME: rename *) -exception CantConvertToConstant -exception CantConvertToCirc of - [`Int +type circuit_conversion_call = [ + | `Convert of form + | `ToArg of form + | `ExpandIter of form * form list + | `Instr of instr +] + +type circuit_error = +| MissingTyBinding of [`Ty of ty | `Path of path] +| AbstractTyBinding of [`Ty of ty | `Path of path] +| InvalidArgument +| MissingOpBinding of path +| MissingOpSpec of path +| IntConversionFailure +| DestrError of string (* FIXME: change this one *) +| MissingOpBody of path (* FIXME: rename? *) +| CantConvertToConstant +| CantReadWriteGlobs +| BadFormForArg of form +| CantConvertToCirc of + [ `Int | `OpK of EcFol.op_kind | `Op of path | `Quantif of quantif | `Match | `Glob + | `ModGlob | `Record | `Hoare | `Instr ] +| PropagateError of circuit_conversion_call * circuit_error (* FIXME: make this lazy *) + +exception CircError of circuit_error + +val circ_error : circuit_error -> 'a +val pp_circ_error : EcPrinting.PPEnv.t -> Format.formatter -> circuit_error -> unit (* -------------------------------------------------------------------- *) (* Utilities (figure out better name) *) @@ -68,9 +84,9 @@ val circ_simplify_form_bitstring_equality : ?pres:circuit list -> hyps -> form -> form (* Proc processors *) -val state_of_prog : ?close:bool -> ?me:memenv -> hyps -> memory -> ?st:state -> instr list -> state +val state_of_prog : ?close:bool -> hyps -> memory -> ?st:state -> instr list -> state val instrs_equiv : hyps -> memenv -> ?keep:EcPV.PV.t -> ?st:state -> instr list -> instr list -> bool -val process_instr : ?me:memenv -> hyps -> memory -> st:state -> instr -> state +val process_instr : hyps -> memory -> st:state -> instr -> state (* val pstate_of_memtype : ?pstate:pstate -> env -> memtype -> pstate * cinput list *) val circuit_state_of_memenv : st:state -> env -> memenv -> state diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index d96b28cbac..a6ab285a47 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -25,8 +25,6 @@ module Hashtbl = Batteries.Hashtbl module Set = Batteries.Set module Option = Batteries.Option -exception CircError of string - let debug : bool = true (* Backend implementing minimal functions needed for the translation *) @@ -569,7 +567,7 @@ module type CircuitInterface = sig val circuit_is_free : circuit -> bool (* Direct circuuit constructions *) - val circuit_ite : ?strict:bool -> c:circuit -> t:circuit -> f:circuit -> circuit + val circuit_ite : c:circuit -> t:circuit -> f:circuit -> circuit val circuit_eq : circuit -> circuit -> circuit val circuit_eqs : circuit -> circuit -> circuit list @@ -598,7 +596,7 @@ module type CircuitInterface = sig val circuit_slice : size:int -> circuit -> int -> circuit val circuit_slice_insert : circuit -> int -> circuit -> circuit val fillet_circuit : circuit -> circuit list - val fillet_tauts : ?mode:[`Seq | `Quad] -> circuit list -> circuit list -> bool + val fillet_tauts : circuit list -> circuit list -> bool val batch_checks : ?sort:bool -> ?mode:[`ByEq | `BySub ] -> circuit list -> circuit list (* Wraps the backend call to deal with args/inputs *) @@ -629,23 +627,46 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = type circuit = circ cfun (* Exceptions *) - exception MissingPVFromState (* FIXME: Do we keep? if so rename *) - exception CircInputUnificationFailure of (cinp * cinp) - exception CircTyConversionFailure - exception CircConstructorInvalidArguments (* FIXME : Might signal a programming mistake? *) (* FIXME : Might be guarded by EC typechecking *) (* FIXME : Might need a parameter to specify case *) + type circconstructor = + | Slice of { slice_size: int; bitstring_size: int; offset: int } + | ASlice of { slice_size: int; container_size: int; offset: int } + | ASliceTy of ctype + | SliceSet of { slice_size: int; bitstring_size: int; offset: int } + | AGet of { container_size: int; index: int } + | Get of { bitstring_size: int; index: int } + | ASet of { container_size: int; index: int } + | Set of { bitstring_size: int; index: int } + | And + | Or + | Ite + | Eq + | Eqs + - exception CircComposeInvalidArguments - exception CircComposeBadNumberOfArguments - exception CircEquivNonBoolPCond - exception CircSmtNonBoolCirc - exception CircComputeBadNumberOfArguments - exception CircComputeInvalidArguments - exception UnsupportedTypeForFileOutput + type lowcircerror = + | MissingPVFromState + | CircInputUnificationFailure of (cinp * cinp) + | CircTyConversionFailure + | CircConstructorInvalidArguments of circconstructor + | CircComposeInvalidArguments (* FIXME: what is a useful error to print here ? *) + | CircComposeBadNumberOfArguments of { expected: int; received: int} + | CircEquivNonBoolPCond + | CircSmtNonBoolCirc + | CircComputeBadNumberOfArguments of { expected: int; received: int} + | CircComputeInvalidArguments of int + | UnsupportedTypeForFileOutput + | CloseWithoutLambda + + exception LowCircError of lowcircerror + + let lowcircerror (err: lowcircerror) = + raise (LowCircError err) + (* Helper functions *) let (|->) ((a,b)) ((f,g)) = (f a, g b) let idnt = fun x -> x @@ -741,7 +762,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let state_get_pv (st: state) (m: memory) (pv: symbol) : circuit = match state_get_pv_opt st m pv with | Some circ -> circ - | None -> raise MissingPVFromState + | None -> lowcircerror (MissingPVFromState) let state_get_all_pv (st: state) : ((memory * symbol) * circuit) list = let pvs = Map.bindings st.pv_ids in @@ -794,7 +815,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (* FIXME: should we remove id from the mapping? *) let close_circ_lambda (st: state) : state = match st.lambdas with - | [] -> raise (CircError "no lambda to close in state") + | [] -> lowcircerror (CloseWithoutLambda) | inps::lambdas -> {st with lambdas = lambdas; circs = Mid.map (fun (c, cinps) -> (c, inps @ cinps)) st.circs } @@ -837,7 +858,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = | {type_ = CBool; id=id_tgt}, {type_ = CBool; id=id_orig} -> Map.add (id_orig, 0) (Backend.input_node ~id:id_tgt 0) map - | _ -> raise (CircInputUnificationFailure (inp1, inp2)) + | _ -> lowcircerror (CircInputUnificationFailure (inp1, inp2)) ) Map.empty target inps in fun inp -> Map.find_opt inp map @@ -861,7 +882,11 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = | _ -> false (* Circuit tuples *) - let circuit_tuple_proj (({reg = r; type_= CTuple tys}, inps): circuit) (i: int) = + let circuit_tuple_proj ((c, inps): circuit) (i: int) = + let r, tys = match c with + | {reg = r; type_= CTuple tys} -> r, tys + | _ -> assert false (* Programming error *) + in let idx, ty = List.takedrop i tys in let ty = List.hd ty in let idx = List.fold_left (+) 0 (List.map size_of_ctype idx) in @@ -873,7 +898,11 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let inps = List.snd cs in {reg = circ; type_= CTuple tys}, merge_inputs_list inps - let circuits_of_circuit_tuple (({reg= tp; type_=CTuple szs}, tpinps) : circuit) : circuit list = + let circuits_of_circuit_tuple ((c, tpinps) : circuit) : circuit list = + let tp, szs = match c with + | {reg= tp; type_=CTuple szs} -> tp, szs + | _ -> assert false (* Programming error *) + in snd @@ List.fold_left_map (fun idx ty -> let sz = (size_of_ctype ty) in @@ -903,7 +932,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (* Fail on everything else *) | _ -> - raise CircTyConversionFailure + lowcircerror CircTyConversionFailure let can_convert_input_type (t1: ctype) (t2: ctype) : bool = size_of_ctype t1 = size_of_ctype t2 @@ -912,7 +941,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = c, List.map2 (fun inp ty -> if can_convert_input_type inp.type_ ty then { inp with type_ = ty } - else raise CircTyConversionFailure + else lowcircerror CircTyConversionFailure ) inps tys (* Input Helper Functions *) @@ -986,20 +1015,21 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = if c.type_ = d.type_ then { reg = Backend.land_ c.reg d.reg; type_ = c.type_ }, merge_inputs cinps dinps else - raise CircConstructorInvalidArguments + lowcircerror @@ CircConstructorInvalidArguments And let circuit_or ((c, cinps): circuit) ((d, dinps): circuit) = if c.type_ = d.type_ then { reg = Backend.lor_ c.reg d.reg; type_ = c.type_ }, merge_inputs cinps dinps else - raise CircConstructorInvalidArguments + lowcircerror @@ CircConstructorInvalidArguments Or let circuit_not ((c, cinps): circuit) = {c with reg = Backend.lnot_ c.reg}, cinps let circuit_is_free (f: circuit) : bool = List.is_empty @@ snd f - let circuit_ite ?(strict = false) ~(c: circuit) ~(t: circuit) ~(f: circuit) : circuit = + let circuit_ite ~(c: circuit) ~(t: circuit) ~(f: circuit) : circuit = + let strict = true in (* FIXME: Decide which behaviour we want, post PR *) let inps = match c, t, f with | (_, []), (_, []), (_, []) when strict -> [] | (_, cinps), (_, tinps), (_, finps) when (not strict) && cinps = tinps && cinps = finps -> cinps @@ -1015,7 +1045,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = | CArray {width=wt; count=nt}, CArray {width=wf; count=nf} when wt = wf && nt = nf -> {reg = res_r; type_ = (fst t).type_}, inps | CTuple szs_t, CTuple szs_f when List.all2 (=) szs_t szs_f -> {reg = res_r; type_ = (fst t).type_}, inps | CBool, CBool -> {reg = res_r; type_ = (fst t).type_}, inps - | _ -> raise CircConstructorInvalidArguments + | _ -> lowcircerror @@ CircConstructorInvalidArguments Ite (* TODO: type check? *) let circuit_eq (c: circuit) (d: circuit) : circuit = @@ -1030,14 +1060,14 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = {reg = (Backend.reg_eq (fst c).reg (fst d).reg |> Backend.reg_of_node); type_ = CBool}, merge_inputs (snd c) (snd d) | CBitstring 1, CBool -> {reg = (Backend.reg_eq (fst c).reg (fst d).reg |> Backend.reg_of_node); type_ = CBool}, merge_inputs (snd c) (snd d) - | _ -> raise CircConstructorInvalidArguments + | _ -> lowcircerror @@ CircConstructorInvalidArguments Eq (* Ignore types, do extensionally over bits, return the circuits evaluating to the condition *) let circuit_eqs ((c, cinps): circuit) ((d, dinps): circuit) : circuit list = let inps = merge_inputs cinps dinps in if (size_of_ctype c.type_ <> size_of_ctype d.type_) then - raise CircConstructorInvalidArguments; + lowcircerror @@ CircConstructorInvalidArguments Eqs; let cs = Backend.node_list_of_reg c.reg in let ds = Backend.node_list_of_reg d.reg in @@ -1047,11 +1077,16 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let circuit_compose (c: circuit) (args: circuit list) : circuit = - ( - try - if not (List.for_all2 (fun c cinp -> circuit_input_compatible c cinp) args (snd c)) then raise CircComposeInvalidArguments; + begin try + if not (List.for_all2 (fun c cinp -> circuit_input_compatible c cinp) args (snd c)) + then lowcircerror CircComposeInvalidArguments; with - | Invalid_argument _ -> raise CircComposeBadNumberOfArguments); + | Invalid_argument _ -> lowcircerror @@ + CircComposeBadNumberOfArguments { + expected = List.length (snd c); + received = List.length args; + } + end; let map = List.fold_left2 (fun map {id} c -> Map.add id c map) Map.empty (snd c) (List.fst args) in let map_ (id, idx) = let circ = Map.find_opt id map in @@ -1098,13 +1133,10 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = | Some ({reg = b; type_ = CBool}, pcinps) -> Backend.apply (unify_inputs_renamer inps1 pcinps) (Backend.node_of_reg b) | None -> Backend.true_ - | _ -> raise CircEquivNonBoolPCond - in - let c2 = try - unify_inputs inps1 (c2, inps2) - with (CircInputUnificationFailure _) as e -> - raise e (* FIXME: Do something here? *) + | _ -> lowcircerror CircEquivNonBoolPCond in + (* This throws, but we let it propagate upwards *) + let c2 = unify_inputs inps1 (c2, inps2) in let inps = List.map (function | { type_ = CBool; id } -> (id, 1) | { type_ = CBitstring w; id } -> (id, w) @@ -1120,7 +1152,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = if debug then Format.eprintf "Calling circ_sat on circuit: %a@." pp_circuit (c, inps); let c = match c with | {type_ = CBool; reg} -> Backend.node_of_reg reg - | _ -> raise CircSmtNonBoolCirc + | _ -> lowcircerror CircSmtNonBoolCirc in let inps = List.map (function | { type_ = CBool; id } -> (id, 1) @@ -1135,7 +1167,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = if debug then Format.eprintf "Calling circ_taut on circuit: %a@." pp_circuit (c, inps); let c = match c with | {type_ = CBool; reg} -> Backend.node_of_reg reg - | _ -> raise CircSmtNonBoolCirc + | _ -> lowcircerror CircSmtNonBoolCirc in let inps = List.map (function | { type_ = CBool; id } -> (id, 1) @@ -1147,31 +1179,60 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = Backend.taut ~inps c (* Inputs mean different things depending on circuit type *) - (* FIXME PR: maybe differentiate the two functions ? *) + (* Allow unaligned slices *) let circuit_slice ~(size:int) ((c, inps): circuit) (offset: int) : circuit = - assert (size >= 0); - assert (offset >= 0); + try + {reg = Backend.slice c.reg offset size; type_ = CBitstring size}, inps + with Backend.BadSlice `Get -> + lowcircerror @@ CircConstructorInvalidArguments (Slice { + slice_size = size; + bitstring_size = Backend.size_of_reg c.reg; + offset; + }) + + (* Slice by container index *) + let circuit_aslice ~(size:int) ((c, inps): circuit) (offset: int) : circuit = match c.type_ with - | CArray {width=w; count=n} when size mod w = 0 && offset mod w = 0 && offset / w < n -> {reg = Backend.slice c.reg offset size; type_ = CArray {width=w; count=size}}, inps - | CArray _ -> raise CircConstructorInvalidArguments - | CBitstring _w -> - { reg = (Backend.slice c.reg offset size); type_ = CBitstring size}, inps + | CArray {width=w; count=n} -> + if (n < size + offset) || size < 0 || offset < 0 then + lowcircerror @@ CircConstructorInvalidArguments (ASlice { + slice_size = size; + container_size = n; + offset; + }); + + {reg = Backend.slice c.reg offset size; type_ = CArray {width=w; count=size}}, inps + + | CBitstring w -> lowcircerror @@ CircConstructorInvalidArguments (ASliceTy (CBitstring w)) | CTuple tys -> - assert (List.length tys >= offset + size); + if List.compare_length_with tys (offset + size) < 0 + || offset < 0 || size < 0 then + lowcircerror @@ CircConstructorInvalidArguments (ASlice { + slice_size = size; + container_size = List.length tys; + offset; + }); + let offset, tys = List.takedrop offset tys in let offset = List.sum @@ List.map size_of_ctype offset in let tys = (List.take size tys) in let sz = List.sum @@ List.map size_of_ctype tys in {reg = (Backend.slice c.reg offset sz); type_ = CTuple tys}, inps + | CBool -> - raise CircConstructorInvalidArguments + lowcircerror @@ CircConstructorInvalidArguments (ASliceTy CBool) + (* Does not type check *) let circuit_slice_insert ((orig_c, orig_inps): circuit) (idx: int) ((new_c, new_inps): circuit) : circuit = try { orig_c with reg = (Backend.insert orig_c.reg idx new_c.reg)}, merge_inputs orig_inps new_inps with Backend.BadSlice `Set -> - raise CircConstructorInvalidArguments + lowcircerror @@ CircConstructorInvalidArguments (SliceSet { + slice_size = Backend.size_of_reg new_c.reg; + bitstring_size = Backend.size_of_reg orig_c.reg; + offset = idx; + }) (* Takes a circuit and uses dependency analysis to separate it into @@ -1187,7 +1248,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let fillet_circuit ((c, inps) : circuit) : circuit list = let r = c.reg |> Backend.node_list_of_reg in List.map (fun n -> - let new_inps = List.map (fun {id;type_} -> + let new_inps = List.map (fun {id=_;type_} -> {id=EcIdent.create "_" |> tag; type_}) inps in let renamings = List.combine @@ -1288,6 +1349,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = circuit_or (circuit_not pre) post (* Assumes all the pre and post have been split, takes all the pres and one post *) + (* DEAD CODE? let fillet_taut (pres: (circuit * Backend.Deps.dep) list) ((post_circ, post_inps): circuit) : bool = let pres = List.map (fun ((c, inps), d) -> assert (inputs_contained inps post_inps); @@ -1295,7 +1357,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = ) pres in (* FIXME: removable *) assert (List.for_all (fun ((_c, inps), _) -> inps = post_inps) pres); - assert (List.for_all (fun (({type_;reg}, _), _) -> type_ = CBool) pres); + assert (List.for_all (fun (({type_;_}, _), _) -> type_ = CBool) pres); assert (post_circ.type_ = CBool); let d = Backend.(Deps.dep_of_node (node_of_reg post_circ.reg)) in let compat_pres = List.filteri (fun i (c, pre_dep) -> @@ -1305,7 +1367,8 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let node_post = Backend.node_of_reg post_circ.reg in let nodes_pre = List.map (fun (c, _) -> Backend.node_of_reg c.reg) compat_pres in let node_post, shifts = Backend.Deps.excise_bit node_post in - let inps = List.filter_map (fun {id; type_} -> + (* FIXME: do this in a more principled way (the types) after merge *) + let inps = List.filter_map (fun {id; _} -> match Map.find_opt id shifts with | Some (low, hi) -> Some {id; type_ = CBitstring (hi - low + 1)} | None -> None @@ -1325,12 +1388,14 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let post = {reg = post; type_ = CBool}, inps in let cond = circuit_or (circuit_not pre) post in circ_taut cond + *) let sublimate_inputs ((c, cinps): circuit) : circuit = assert (c.type_ = CBool); let node_c = Backend.node_of_reg c.reg in let node_c, shifts = Backend.Deps.excise_bit node_c in - let inps = List.filter_map (fun {id; type_} -> + (* FIXME: do this in a more principled way (the types) after merge *) + let inps = List.filter_map (fun {id; _} -> match Map.find_opt id shifts with | Some (low, hi) -> Some {id; type_ = CBitstring (hi - low + 1)} | None -> None @@ -1387,7 +1452,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = *) (* FIXME: current lane collapse is always quadratic, add toggle option? or remove arg *) - let fillet_tauts ?(mode: [`Seq | `Quad] = `Seq) (pres: circuit list) (posts: circuit list) : bool = + let fillet_tauts (pres: circuit list) (posts: circuit list) : bool = (* Assumes everything is single bit outputs. FIXME: does it? *) let posts = List.filter_map (fun ((postc, _) as post) -> if Backend.nodes_eq (Backend.node_of_reg postc.reg) Backend.true_ then None @@ -1399,7 +1464,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = | posts -> if (not (List.for_all (fun ({type_;reg=_}, _) -> type_ = CBool) pres)) || (not (List.for_all (fun ({type_;reg=_}, _) -> type_ = CBool) posts)) then - raise CircSmtNonBoolCirc; + lowcircerror CircSmtNonBoolCirc; let pres = List.map (fun ((c, _) as circ) -> circ, Backend.Deps.dep_of_node (Backend.node_of_reg c.reg)) pres in let posts = List.map (attach_compatible_pres ~mode:`Int pres) posts in @@ -1425,12 +1490,15 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = end; if List.compare_lengths args inps <> 0 - then raise CircComputeBadNumberOfArguments; + then lowcircerror @@ CircComputeBadNumberOfArguments + { expected = List.length inps; + received = List.length args; }; + let args = List.map2i (fun i arg inp -> match arg, inp with | `Circuit c, inp when circuit_input_compatible c inp -> c | `Constant i, {type_ = CBitstring size} -> { reg = (Backend.reg_of_zint ~size i); type_ = CBitstring size}, [] - | _ -> raise CircComputeInvalidArguments + | _ -> lowcircerror @@ CircComputeInvalidArguments i ) args inps in match circuit_compose c args with @@ -1480,11 +1548,12 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let inp, renamer = input_aggregate_renamer inps in {c with reg = Backend.applys renamer c.reg}, [inp] + (* FIXME: do implicit conversion to this type before writing or enforce explicit conversion ? *) let circuit_to_file ~(name: string) ((c, inps): circuit) : symbol = match c, inps with | {reg = r; type_ = CBitstring _}, {type_ = CBitstring w; id}::[] -> (* TODO: rename inputs? *) Backend.reg_to_file ~input_count:w ~name (Backend.applys (fun (id_, i) -> if id_ = id then Some (Backend.input_node ~id:0 (i+1)) else None) r) - | _ -> raise UnsupportedTypeForFileOutput + | _ -> lowcircerror @@ UnsupportedTypeForFileOutput let circuit_from_spec ?(name: symbol option) ((arg_tys, ret_ty) : (ctype list * ctype)) (spec: Lospecs.Ast.adef) : circuit = let c = Backend.circuit_from_spec spec in @@ -1506,68 +1575,70 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = module BVOps = struct let circuit_of_parametric_bvop (op: EcDecl.crb_bvoperator) (args: arg list) : circuit = match op with - | { kind = `ASliceGet (((_, Some n), (_, Some w)), (_, Some m)) } -> + | { kind = `ASliceGet (((_, Some _), (_, Some _)), (_, Some m)) } -> begin match args with (* Assume type checking from EC? *) | [ `Circuit (({type_ = CArray _}, _) as circ) ; `Constant i ] -> begin match (fst circ).type_ with - | CArray {width=w'; count=n'} when n' = n && w = w' -> + | CArray {width=w'; count=n'} -> circuit_slice ~size:m ({reg = (fst circ).reg; type_ = CBitstring (w' * n')}, (snd circ)) (to_int i) - | CArray _ -> - raise CircConstructorInvalidArguments | _ -> assert false (* Does not happen, guarded by match above *) end - | _ -> raise CircConstructorInvalidArguments + | _ -> assert false (* Should be caught by EC typechecking + binding correctness *) end - | { kind = `ASliceSet (((_, Some n), (_, Some w)), (_, Some m)) } -> + | { kind = `ASliceSet (((_, Some _), (_, Some _)), (_, Some _)) } -> begin match args with | [ `Circuit (({type_ = CArray _}, _) as arr_circ) ; `Constant i ; `Circuit (({type_ = CBitstring _}, _) as bs_circ) ] -> begin match (fst arr_circ).type_, (fst bs_circ).type_ with - | CArray {width=w'; count=n'}, CBitstring m' when n' = n && w' = w && m = m' -> + | CArray _, CBitstring _ -> circuit_slice_insert arr_circ (to_int i) bs_circ - | _ -> raise CircConstructorInvalidArguments + + (* If this fails, then we have an inconsistent binding, should be prevented by EC *) + | _ -> assert false end - | _ -> raise CircConstructorInvalidArguments + | _ -> assert false (* Should be caught by EC typechecking + binding correctness *) end (* FIXME: what do we want for out of bounds extract? Decide later *) - | { kind = `Extract ((_, Some w_in), (_, Some w_out)) } -> + | { kind = `Extract ((_, Some _), (_, Some w_out)) } -> begin match args with | [ `Circuit (({type_ = CBitstring _}, _ ) as c) ; `Constant i ] -> circuit_slice ~size:w_out c (to_int i) - | _ -> raise CircConstructorInvalidArguments + | _ -> assert false (* Should be caught by EC typechecking + binding correctness *) end - | { kind = `Insert ((_, Some w_orig), (_, Some w_ins)) } -> + | { kind = `Insert ((_, Some _), (_, Some _)) } -> begin match args with | [ `Circuit (({type_ = CBitstring _}, _) as orig_c) ; `Constant i ; `Circuit (({ type_=CBitstring _}, _) as new_c) ] -> (circuit_slice_insert orig_c (to_int i) new_c :> circuit) - | _ -> raise CircConstructorInvalidArguments + | _ -> assert false (* Should be caught by EC typechecking + binding correctness *) end | { kind = `Map ((_, Some w_i), (_, Some w_o), (_, Some n)) } -> begin match args with - | [ `Circuit (({ type_=CBitstring _}, [{type_=CBitstring w_i'}; _]) as cf); `Circuit ({reg = arr; type_ = CArray {width=w_i''; count=n_i''}}, arr_inps) ] when (w_i' = w_i && w_i'' = w_i') && (n_i'' = n) -> + | [ `Circuit cf; `Circuit ({reg = arr; type_ = CArray {width=_; count=_}}, _) ] -> let circs, inps = List.split @@ List.map (fun c -> match circuit_compose cf [c] with | { type_ = CBitstring _; reg}, inps -> reg, inps - | c, _ -> raise CircConstructorInvalidArguments (* Wrong map return type *) + | _ -> assert false (* Should be caught by EC typechecking + binding correctness *) ) (List.init n (fun i -> {reg = (Backend.slice arr (i*w_i) w_i); type_ = CBitstring w_i}, [])) in (* Inputs of all components should match after map *) if not (List.for_all ((=) (List.hd inps)) inps) then - raise CircConstructorInvalidArguments; + (* FIXME: Careful with input modelling, if abstraction breaks this breaks + post PR work *) + assert false; (* Should be caught by EC typechecking + binding correctness *) let inps = List.hd inps in let circ = { reg = (Backend.flatten circs); type_ = CArray {width=w_o; count=n}} in (circ, inps) - | _ -> raise CircConstructorInvalidArguments + | _ -> assert false (* Should be caught by EC typechecking + binding correctness *) end - | { kind = `Get (_, Some w_in) } -> + | { kind = `Get (_, Some _) } -> begin match args with | [ `Circuit ({reg = bs; type_ = CBitstring _}, cinps); `Constant i ] -> {type_ = CBool; reg = Backend.reg_of_node (Backend.get bs (to_int i))}, cinps - | _ -> raise CircConstructorInvalidArguments + | _ -> assert false (* Should be caught by EC typechecking + binding correctness *) end | { kind = `AInit ((_, Some n), (_, Some w_o)) } -> begin match args with @@ -1577,14 +1648,16 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (function | {type_ = CBitstring _; reg = r} when Backend.size_of_reg r = w_o -> r (* Invalid type for init component *) - | _ -> raise CircConstructorInvalidArguments) + | _ -> assert false) (* Should be caught by EC typechecking + binding correctness *) circs in (* Inputs should be uniform across components after mapping *) - (if not (List.for_all ((=) (List.hd cinps)) cinps) then - raise CircConstructorInvalidArguments); + if not (List.for_all ((=) (List.hd cinps)) cinps) then + (* FIXME: Careful with input modelling, if abstraction breaks this breaks + post PR work *) + assert false; (* Should be caught by EC typechecking + binding correctness *) let cinps = List.hd cinps in {type_ = CArray {width=w_o; count=n} ; reg = Backend.flatten circs}, cinps - | _ -> raise CircConstructorInvalidArguments + | _ -> assert false (* Should be caught by EC typechecking + binding correctness *) end | { kind = `Init (_, Some w) } -> begin match args with @@ -1594,12 +1667,16 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (function | {type_ = CBool; reg = b} -> Backend.node_of_reg b (* Return type should be bool (= bit) for components *) - | _ -> raise CircConstructorInvalidArguments) circs in - (if not (List.for_all ((=) (List.hd cinps)) cinps) then - raise CircConstructorInvalidArguments); + | _ -> assert false) (* Should be caught by EC typechecking + binding correctness *) + circs + in + if not (List.for_all ((=) (List.hd cinps)) cinps) then + (* FIXME: Careful with input modelling, if abstraction breaks this breaks + post PR work *) + assert false; (* Should be caught by EC typechecking + binding correctness *) let cinps = List.hd cinps in {type_ = CBitstring w; reg = (Backend.reg_of_node_list circs)}, cinps - | _ -> raise CircConstructorInvalidArguments + | _ -> assert false (* Should be caught by EC typechecking + binding correctness *) end | _ -> assert false (* Should not happen because calls should be guarded by call to op_is_parametric_bvop *) @@ -1765,19 +1842,22 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let array_get (({reg = c; type_ = CArray {width=w; count=n}}, inps) : circuit) (i: int) : circuit = try { type_ = CBitstring w; reg = (Backend.slice c (i*w) w)}, inps - with Invalid_argument _ -> - raise CircConstructorInvalidArguments + with Backend.BadSlice `Get -> + lowcircerror @@ CircConstructorInvalidArguments (AGet { + container_size = n; + index = i; + }) let array_set (({reg = arr; type_ = CArray {width=w; count=n}}, inps) : circuit) (pos: int) (({reg = bs; type_ = CBitstring w'}, cinps): circuit) : circuit = - let exception SizeMismatch in try assert (w = w'); { type_ = CArray {width=w; count=n}; reg = (Backend.insert arr (pos * w) bs)}, merge_inputs inps cinps - with Invalid_argument _ -> - raise CircConstructorInvalidArguments - | SizeMismatch -> - raise CircConstructorInvalidArguments + with Backend.BadSlice `Set -> + lowcircerror @@ CircConstructorInvalidArguments (ASet { + container_size = n; + index = pos; + }) (* FIXME: review this functiono | FIXME: Not axiomatized in QFABV.ec file *) let array_oflist (circs : circuit list) (dfl: circuit) (len: int) : circuit = @@ -1789,7 +1869,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let circs = List.map (function | {type_ = CBitstring _; reg = r} -> r - | _ -> raise CircConstructorInvalidArguments + | _ -> assert false (* Should be caught by EC typechecking + binding correctness *) ) circs in { type_ = CArray {width=Backend.size_of_reg (List.hd circs); count=len}; reg = (Backend.flatten circs)}, merge_inputs_list inps diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index 4bd179b71c..81267697e5 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -41,18 +41,18 @@ let time (env: env) (t: float) (msg: string) : float = Assumes f has enough positions so that arr_t.size + offset < size f (as array) *) +(* FIXME: error handdling for this function *) let array_init_from_form (env: env) (f: form) ((arr_t, offset): qsymbol * BI.zint) : form = - let ppe = EcPrinting.PPEnv.ofenv env in let tpath = match EcEnv.Ty.lookup_opt arr_t env with | None -> raise TyLookupError | Some (path, decl) when List.length decl.tyd_params = 1 -> path - | Some ((_path, decl) as tdecl) -> + | Some _ -> raise BadTypeForConstructor in let get = match EcEnv.Circuit.lookup_array env f.f_ty with | Some { get } -> get - | None -> raise (MissingTyBinding f.f_ty) + | None -> circ_error (MissingTyBinding (`Ty f.f_ty)) in let init = EcEnv.Op.lookup_path (fst (tpath |> EcPath.toqsymbol), "init") env in let idx = create "i" in @@ -70,7 +70,7 @@ let form_list_from_iota (hyps: hyps) (f: form) : form list = | _ -> raise (DestrError "iota") -let rec form_list_of_form ?(ppenv: EcPrinting.PPEnv.t option) (f: form) : form list = +let rec form_list_of_form (f: form) : form list = match destr_op_app f with | (pc, _), [h; {f_node = Fop(p, _)}] when pc = EcCoreLib.CI_List.p_cons && @@ -80,7 +80,8 @@ let rec form_list_of_form ?(ppenv: EcPrinting.PPEnv.t option) (f: form) : form l pc = EcCoreLib.CI_List.p_cons -> h::(form_list_of_form t) | _ -> - raise (DestrError "list") + (* FIXME: Bad error? *) + raise (DestrError "list") (* FIXME: move? A *) @@ -106,7 +107,6 @@ let rec destr_conj (hyps: hyps) (f: form) : form list = *) (* Returns _open_ circuits *) let process_pre ?(st : state option) (tc: tcenv1) (f: form) : state * circuit list = - let debug = false in let env = FApi.tc1_env tc in let ppe = EcPrinting.PPEnv.ofenv env in let hyps = FApi.tc1_hyps tc in (* FIXME: should target be specified here? *) @@ -123,19 +123,19 @@ let process_pre ?(st : state option) (tc: tcenv1) (f: form) : state * circuit li let fs = destr_conj f in - if debug then Format.eprintf "Destructured conj, obtained:@.%a@." + EcEnv.notify env EcGState.(`Debug) "Destructured conj, obtained:@.%a@." (EcPrinting.pp_list ";@\n" EcPrinting.(pp_form PPEnv.(ofenv env))) fs; (* If f is of the form (a_ = a) (aka prog_var = log_var) then add it to the state, otherwise do nothing *) (* FIXME: are all the simplifications necessary ? *) - let rec process_equality (s: state) (f: form) : state = + let process_equality (s: state) (f: form) : state = let f = (EcCallbyValue.norm_cbv (circ_red hyps) hyps f) in match f.f_node with | Fapp ({f_node = Fop (p, _);_}, [a; b]) -> begin match EcFol.op_kind p, (EcCallbyValue.norm_cbv (circ_red hyps) hyps a), (EcCallbyValue.norm_cbv (circ_red hyps) hyps b) with | Some `Eq, {f_node = Fpvar (PVloc pv, m); _}, fv | Some `Eq, fv, {f_node = Fpvar (PVloc pv, m); _} -> - if debug then Format.eprintf "Adding equality to known information for translation: %a@." EcPrinting.(pp_form PPEnv.(ofenv env)) f; + EcEnv.notify env EcGState.(`Debug) "Adding equality to known information for translation: %a@." EcPrinting.(pp_form PPEnv.(ofenv env)) f; update_state_pv s m pv (circuit_of_form ~st hyps fv) | _ -> s end @@ -146,7 +146,7 @@ let process_pre ?(st : state option) (tc: tcenv1) (f: form) : state * circuit li (* If convertible to circuit then add to precondition conjunction. Use state from previous as well *) - let rec process_form (f: form) : circuit list = + let process_form (f: form) : circuit list = match f.f_node with | Fapp ({f_node = Fop (p, _);_}, [f1; f2]) when EcFol.op_kind p = Some `Eq -> let c1 = circuit_of_form ~st hyps (EcCallbyValue.norm_cbv (circ_red hyps) hyps f1) in @@ -154,13 +154,13 @@ let process_pre ?(st : state option) (tc: tcenv1) (f: form) : state * circuit li circuit_eqs c1 c2 | _ -> begin - if debug then - Format.eprintf "Processing form: %a@.Simplified version: %a@." + EcEnv.notify env EcGState.(`Debug) + "Processing form: %a@.Simplified version: %a@." EcPrinting.(pp_form ppe) f EcPrinting.(pp_form ppe) (EcCallbyValue.norm_cbv (circ_red hyps) hyps f); try (circuit_of_form ~st hyps (EcCallbyValue.norm_cbv (circ_red hyps) hyps f))::[] with e -> begin - if debug then Format.eprintf "Encountered exception when converting part of the pre to circuit: %s@." (Printexc.to_string e); + EcEnv.notify env EcGState.(`Debug) "Encountered exception when converting part of the pre to circuit: %s@." (Printexc.to_string e); [] end end in @@ -171,8 +171,8 @@ let process_pre ?(st : state option) (tc: tcenv1) (f: form) : state * circuit li (EcPrinting.pp_list "@\n@\n" pp_circuit) cs; *) - if debug then Format.eprintf "In the context of the following bindings in the environment:@\n%a@\n" - (EcPrinting.pp_list "@\n@\n" (fun fmt cinp -> Format.eprintf "%a@." pp_cinp cinp)) (state_lambdas st); + EcEnv.notify env EcGState.(`Debug) "In the context of the following bindings in the environment:@\n%a@\n" + (EcPrinting.pp_list "@\n@\n" (fun fmt cinp -> Format.fprintf fmt "%a@." pp_cinp cinp)) (state_lambdas st); st, cs let solve_post ~(st: state) ~(pres: circuit list) (hyps: hyps) (post: form) : bool = @@ -180,7 +180,7 @@ let solve_post ~(st: state) ~(pres: circuit list) (hyps: hyps) (post: form) : bo let posts = destr_conj post in List.for_all (fun post -> - if debug then Format.eprintf "Solving post: %a@." + EcEnv.notify (toenv hyps) EcGState.(`Debug) "Solving post: %a@." EcPrinting.(pp_form PPEnv.(ofenv (toenv hyps))) post; match post.f_node with | Fapp ({f_node= Fop(p, _); _}, [f1; f2]) -> @@ -201,112 +201,111 @@ let t_bdep_solve new_t in - begin - let hyps = (FApi.tc1_hyps tc) in - let goal = (FApi.tc1_goal tc) in - match goal.f_node with - | FhoareS {hs_m; hs_pr; hs_po; hs_s} -> begin try + let hyps = (FApi.tc1_hyps tc) in + let goal = (FApi.tc1_goal tc) in + let env = (FApi.tc1_env tc) in + match goal.f_node with + | FhoareS hs -> begin try + let tm = Unix.gettimeofday () in + let st, cpres = process_pre tc (hs_pr hs).inv in + let tm = time (toenv hyps) tm "Done with precondition processing" in + + (* Get open state *) + let st = state_of_prog hyps (fst hs.hs_m) ~st hs.hs_s.s_node in + let _tm = time (toenv hyps) tm "Done with program circuit gen" in + + let res = solve_post ~st ~pres:cpres hyps (hs_po hs).inv in + EcCircuits.clear_translation_caches (); + if res then + FApi.close (!@ tc) VBdep + else + tc_error (FApi.tc1_penv tc) "failed to verify postcondition" + with + (* FIXME: not catching anything, redo *) + | CircError err -> + tc_error (FApi.tc1_penv tc) "circuit solve failed with error: %a" (pp_circ_error EcPrinting.PPEnv.(ofenv env)) err + end + | FequivS es -> begin try let tm = Unix.gettimeofday () in - let st, cpres = process_pre tc hs_pr in + + (* FIXME: rework this *) + let st = circuit_state_of_memenv ~st:empty_state (FApi.tc1_env tc) es.es_ml in + let st = circuit_state_of_memenv ~st (FApi.tc1_env tc) es.es_mr in + (* let st = circuit_state_of_hyps ~st (FApi.tc1_hyps tc) in *) + + let st, cpres = process_pre ~st tc (es_pr es).inv in let tm = time (toenv hyps) tm "Done with precondition processing" in - (* Get open state *) - let st = state_of_prog hyps (fst hs_m) ~st hs_s.s_node in - let _tm = time (toenv hyps) tm "Done with program circuit gen" in + (* Circuits from pvars are tagged by memory so we can just put everything in one state *) + let st = state_of_prog hyps (fst es.es_ml) ~st es.es_sl.s_node in + let tm = time (toenv hyps) tm "Done with left program circuit gen" in + let st = state_of_prog hyps (fst es.es_mr) ~st es.es_sr.s_node in + let _tm = time (toenv hyps) tm "Done with right program circuit gen" in - let res = solve_post ~st ~pres:cpres hyps hs_po in - EcCircuits.clear_translation_caches (); - if res then + if solve_post ~st ~pres:cpres hyps (es_po es).inv + then FApi.close (!@ tc) VBdep else - raise BDepVerifyFail (* FIXME: this is tactic failure, maybe should be done differently? *) - with - (* FIXME: not catching anything, redo *) - | BDepError le -> - tc_error (FApi.tc1_penv tc) "%s" (Lazy.force le) - end - | FequivS { es_ml; es_mr; es_pr; es_sl; es_sr; es_po } -> - begin - try ( - let tm = Unix.gettimeofday () in - (* FIXME: rework this *) - let st = circuit_state_of_memenv ~st:empty_state (FApi.tc1_env tc) es_ml in - let st = circuit_state_of_memenv ~st (FApi.tc1_env tc) es_mr in -(* let st = circuit_state_of_hyps ~st (FApi.tc1_hyps tc) in *) - let st, cpres = process_pre ~st tc es_pr in - let tm = time (toenv hyps) tm "Done with precondition processing" in - - (* Circuits from pvars are tagged by memory so we can just put everything in one state *) - let st = state_of_prog ~me:es_ml hyps (fst es_ml) ~st es_sl.s_node in - let tm = time (toenv hyps) tm "Done with left program circuit gen" in - let st = state_of_prog ~me:es_mr hyps (fst es_mr) ~st es_sr.s_node in - let _tm = time (toenv hyps) tm "Done with right program circuit gen" in - - (if solve_post ~st ~pres:cpres hyps es_po - then FApi.close (!@ tc) VBdep else - raise BDepVerifyFail) - ) - with - (* FIXME: not catching anything, redo *) - | BDepError le -> - tc_error (FApi.tc1_penv tc) "%s" (Lazy.force le) - end - | _ -> - let ctxt = tohyps hyps in - assert (ctxt.h_tvar = []); - let st = circuit_state_of_hyps hyps in - let cgoal = (circuit_of_form ~st hyps goal |> state_close_circuit st) in - if debug then Format.eprintf "goal: %a@." pp_flatcirc (fst cgoal).reg; - if circ_taut cgoal then - FApi.close (!@ tc) VBdep - else - tc_error (FApi.tc1_penv tc) "Failed to solve goal through circuit reasoning@\n" + tc_error (FApi.tc1_penv tc) "failed to verify postcondition" + with CircError err -> + tc_error (FApi.tc1_penv tc) "circuit solve failed with error: %a" (pp_circ_error EcPrinting.PPEnv.(ofenv env)) err end + | _ -> + begin try + let ctxt = tohyps hyps in + assert (ctxt.h_tvar = []); + let st = circuit_state_of_hyps hyps in + let cgoal = (circuit_of_form ~st hyps goal |> state_close_circuit st) in + if debug then Format.eprintf "goal: %a@." pp_flatcirc (fst cgoal).reg; + if circ_taut cgoal then + FApi.close (!@ tc) VBdep + else + tc_error (FApi.tc1_penv tc) "Failed to solve goal through circuit reasoning@\n" + with CircError err -> + tc_error (FApi.tc1_penv tc) "circuit solve failed with error: %a" (pp_circ_error EcPrinting.PPEnv.(ofenv env)) err + end let t_bdep_simplify (tc: tcenv1) = let time (env: env) (t: float) (msg: string) : float = let new_t = Unix.gettimeofday () in EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. t); - Format.eprintf "[W] %s, took %f s@." msg (new_t -. t); + (* Format.eprintf "[W] %s, took %f s@." msg (new_t -. t); *) new_t in let hyps = (FApi.tc1_hyps tc) in let goal = (FApi.tc1_goal tc) in let env = (FApi.tc1_env tc) in match goal.f_node with - | FhoareS {hs_m=(m, me) as hs_m; hs_pr; hs_po; hs_s} -> -(* begin try *) + | FhoareS hs -> + begin try + let m = fst hs.hs_m in let tm = Unix.gettimeofday () in let st = circuit_state_of_hyps ~use_mem:true hyps in - let st = circuit_state_of_memenv ~st env hs_m in - let st, pres = process_pre ~st tc hs_pr in + let st = circuit_state_of_memenv ~st env hs.hs_m in + let st, pres = process_pre ~st tc (hs_pr hs).inv in let tm = time env tm "Done with precondition processing" in - (* FIXME: line below throws, should handle exceptions *) - let st = EcCircuits.state_of_prog ~st hyps (fst hs_m) hs_s.s_node in - let post = EcCallbyValue.norm_cbv (circ_red hyps) hyps hs_po in - (* - if debug then Format.eprintf "[W] Post after simplify (before circuit pass):@. %a@." + let st = EcCircuits.state_of_prog ~st hyps (fst hs.hs_m) hs.hs_s.s_node in + let post = EcCallbyValue.norm_cbv (circ_red hyps) hyps (hs_po hs).inv in + + EcEnv.notify env EcGState.(`Debug) "[W] Post after simplify (before circuit pass):@. %a@." EcPrinting.(pp_form PPEnv.(ofenv env)) post; - *) + let tm = time env tm "Done with first simplify" in let f = EcCircuits.circ_simplify_form_bitstring_equality ~st ~pres hyps post in let tm = time env tm "Done with circuit simplify" in let f = EcCallbyValue.norm_cbv (EcReduction.full_red) hyps f in let _tm = time env tm "Done with second simplify" in - let new_goal = f_hoareS (snd hs_m) {inv=hs_pr; m} hs_s {inv=f; m} in - (* - if debug then Format.eprintf "[W] Goal after simplify:@. %a@." + let new_goal = f_hoareS (snd hs.hs_m) {inv=(hs_pr hs).inv; m} hs.hs_s {inv=f; m} in + + EcEnv.notify env EcGState.(`Debug) "[W] Goal after simplify:@. %a@." EcPrinting.(pp_form PPEnv.(ofenv env)) new_goal; - *) FApi.mutate1 tc (fun _ -> VBdep) new_goal |> FApi.tcenv_of_tcenv1 -(* with CircError err -> - tc_error (FApi.tc1_penv tc) "CircError: %s@." (Lazy.force err) + tc_error (FApi.tc1_penv tc) "Circuit simplify failed with error: %a" (pp_circ_error EcPrinting.PPEnv.(ofenv env)) err end -*) | _ -> assert false (* FIXME : TODO *) (* ================ EXTENS TACTIC ==================== *) @@ -364,7 +363,7 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = in let goals = match (tc1_goal tc).f_node, v with - | Fapp ({f_node = Fop (p, [tint]); _}, [fpred; flist]), None when p = EcCoreLib.CI_List.p_all -> + | Fapp ({f_node = Fop (p, [tp]); _}, [fpred; flist]), None when p = EcCoreLib.CI_List.p_all && tp = tint-> Format.eprintf "[W] Found list all@."; begin match flist.f_node with | Fapp ({f_node = Fop (p, []); _}, [fstart; flen]) when p = EcCoreLib.CI_List.p_iota -> From 60eb802c8bc46032e96e233c9c4cf98be2cafe35 Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Thu, 22 Jan 2026 20:44:57 +0000 Subject: [PATCH 003/145] Added implicit type translation --- src/ecLowCircuits.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index a6ab285a47..e01ece17c8 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -608,11 +608,9 @@ end module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = struct (* Module Types *) type flatcirc = Backend.reg - type width = int - type count = int type ctype = CArray of {width: int; count: int; } - | CBitstring of width + | CBitstring of int | CTuple of ctype list | CBool type circ = { @@ -1665,6 +1663,8 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let circs, cinps = List.split @@ List.init w init_f in let circs = List.map (function + (* FIXME: bad abstraction, fix after PR *) + | {type_ = CBitstring 1; reg = b} | {type_ = CBool; reg = b} -> Backend.node_of_reg b (* Return type should be bool (= bit) for components *) | _ -> assert false) (* Should be caught by EC typechecking + binding correctness *) From 267854c3046de96f498f2ff10ca439390a1bb6fb Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Fri, 23 Jan 2026 16:05:26 +0000 Subject: [PATCH 004/145] Added duplicate checking for spec files and general cleanup --- libs/lospecs/smt.ml | 1 - src/ecCircuits.ml | 52 ++++++++++++++++++++++++-------------------- src/ecLowCircuits.ml | 3 +++ src/ecScope.ml | 22 ++++++++++++++++--- src/phl/ecPhlBDep.ml | 27 ++++++++++------------- 5 files changed, 63 insertions(+), 42 deletions(-) diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index 5132250b3b..4f7b3c38ab 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -1,5 +1,4 @@ open Aig -open Circuit module type SMTInstance = sig type bvterm diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index ff2c79a519..2a2ad36563 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -541,7 +541,7 @@ let int_of_form ?(redmode = EcReduction.full_red) (hyps: hyps) (f: form) : zint | DestrError "destr_int" -> circ_error IntConversionFailure end -let rec form_list_of_form ?(ppe: EcPrinting.PPEnv.t option) (f: form) : form list = +let rec form_list_of_form ?(env: env option) (f: form) : form list = match destr_op_app f with | (pc, _), [h; {f_node = Fop(p, _)}] when pc = EcCoreLib.CI_List.p_cons && @@ -551,8 +551,9 @@ let rec form_list_of_form ?(ppe: EcPrinting.PPEnv.t option) (f: form) : form lis pc = EcCoreLib.CI_List.p_cons -> h::(form_list_of_form t) | _ -> - if debug then Option.may (fun ppenv -> Format.eprintf "Failed to destructure claimed list: %a@." (EcPrinting.pp_form ppenv) f) ppe; - raise (DestrError "list") + Option.may (fun env -> + EcEnv.notify env EcGState.(`Debug) "Failed to destructure claimed list: %a@." (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv env)) f) env; + raise (DestrError "list") let form_is_iter (f: form) : bool = match f.f_node with @@ -575,9 +576,9 @@ let expand_iter_form (hyps: hyps) (f: form) : form = | Fapp ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iteri -> let rep = int_of_form hyps rep in let is = List.init (BI.to_int rep) BI.of_int in - if debug then Format.eprintf "Done generating functions!@."; + EcEnv.notify env EcGState.(`Debug) "Done generating functions!@."; let f = List.fold_left (fun f i -> - if debug then Format.eprintf "Expanding iter... Step #%d@.Form: %a@." (BI.to_int i) + EcEnv.notify env EcGState.(`Debug) "Expanding iter... Step #%d@.Form: %a@." (BI.to_int i) (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (toenv hyps))) f ; fn @!! [f_int i; f] @@ -595,7 +596,7 @@ let expand_iter_form (hyps: hyps) (f: form) : form = f | _ -> raise (DestrError "iter") in - if debug then Format.eprintf "Expanded iter form: @.%a@." EcPrinting.(pp_form ppenv) res; + EcEnv.notify env EcGState.(`Debug) "Expanded iter form: @.%a@." EcPrinting.(pp_form ppenv) res; res let circuit_of_form @@ -650,7 +651,7 @@ let circuit_of_form | {ty_node = Tconstr(p, [t])} when p = EcCoreLib.CI_List.p_list && type_has_bindings env t -> - let cs = List.map (fun f -> doit st f) (form_list_of_form ~ppe f) in + let cs = List.map (fun f -> doit st f) (form_list_of_form ~env f) in arg_of_circuits cs | _ -> Format.eprintf "Failed to convert form to arg: %a@." EcPrinting.(pp_form ppe) f; circ_error (BadFormForArg f) @@ -675,7 +676,7 @@ let circuit_of_form | Fop (pth, _) -> begin if pth = EcCoreLib.CI_Witness.p_witness then - (if debug then Format.eprintf "Assigning witness to var of type %a@." + (EcEnv.notify env EcGState.(`Debug) "Assigning witness to var of type %a@." EcPrinting.(pp_type ppe) f_.f_ty; circuit_uninit env (f_.f_ty)) else @@ -819,7 +820,7 @@ let circuit_of_form let v = match state_get_pv_opt st mem v with | Some v -> v | None -> - if debug then Format.eprintf "Assigning unassigned program variable %a of type %a@." EcPrinting.(pp_pv ppe) pv EcPrinting.(pp_type ppe) f_.f_ty; + EcEnv.notify env EcGState.(`Debug) "Assigning unassigned program variable %a of type %a@." EcPrinting.(pp_pv ppe) pv EcPrinting.(pp_type ppe) f_.f_ty; circuit_uninit env f_.f_ty (* Allow uninitialized program variables *) in v @@ -862,13 +863,19 @@ let circuit_of_form fapply_safe fn [f_int (BI.of_int i)] ) in List.fold_lefti (fun f i fn -> - if debug then Format.eprintf "Translating iteri... Step #%d@." i; + EcEnv.notify env EcGState.(`Debug) "Translating iteri... Step #%d@." i; let fn = doit st fn in circuit_compose fn [f] ) (doit st base) fs - (* FIXME PR: this is currently being implemented directly on circuits, do we want this case as well? *) - | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iter -> assert false - | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_fold -> assert false + (* This is defined in terms of iteri, so it should get expanded and use the case above *) + (* | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iter -> assert false *) + | ({f_node = Fop (p, _)}, [fn; start_val; reps]) when p = EcCoreLib.CI_Int.p_fold -> + let reps = int_of_form reps |> BI.to_int in + let fn = doit st fn in + let start_val = doit st start_val in + List.fold_left (fun acc f -> + circuit_compose f [acc] + ) start_val (List.make reps fn) | _ -> raise (DestrError "iter") with CircError e -> propagate_circ_error (`ExpandIter (f, fs)) e @@ -880,12 +887,11 @@ let circuit_simplify_equality ?(do_time = true) ~(st: state) ~(hyps: hyps) ~(pre let env = toenv hyps in let time (env: env) (t: float ref) (msg: string) : unit = let new_t = Unix.gettimeofday () in -(* EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. !t); *) - Format.eprintf "[W] %s, took %f s@." msg (new_t -. !t); + EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. !t); t := new_t in - if debug then Format.eprintf "Filletting circuit...@."; + EcEnv.notify env EcGState.(`Debug) "Filletting circuit...@."; let c1 = circuit_of_form ~st hyps f1 |> state_close_circuit st in if do_time then time env tm "Left side circuit generation done"; let c2 = circuit_of_form ~st hyps f2 |> state_close_circuit st in @@ -897,9 +903,9 @@ let circuit_simplify_equality ?(do_time = true) ~(st: state) ~(hyps: hyps) ~(pre let posts = circuit_eqs c1 c2 in if do_time then time env tm "Done with postcondition circuit generation"; - if debug then Format.eprintf "Number of checks before batching: %d@." (List.length posts); + EcEnv.notify env EcGState.(`Debug) "Number of checks before batching: %d@." (List.length posts); let posts = batch_checks ~mode:`BySub posts in - if debug then Format.eprintf "Number of checks after batching: %d@." (List.length posts); + EcEnv.notify env EcGState.(`Debug) "Number of checks after batching: %d@." (List.length posts); if do_time then time env tm "Done with lane compression"; if fillet_tauts pres posts then begin @@ -931,19 +937,19 @@ let vars_of_memtype (mt : memtype) = let process_instr (hyps: hyps) (mem: memory) ~(st: state) (inst: instr) : state = -(* if debug then Format.eprintf "[W] Processing : %a@." (EcPrinting.pp_instr (EcPrinting.PPEnv.ofenv env)) inst; *) +(* EcEnv.notify env EcGState.(`Debug) "[W] Processing : %a@." (EcPrinting.pp_instr (EcPrinting.PPEnv.ofenv env)) inst; *) (* let start = Unix.gettimeofday () in *) try match inst.i_node with | Sasgn (LvVar (PVloc v, _ty), e) -> (* - if debug then Format.eprintf "Assigning form %a to var %s@\n" + EcEnv.notify env EcGState.(`Debug) "Assigning form %a to var %s@\n" (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (LDecl.toenv hyps))) (form_of_expr mem e) v; *) let c = ((ss_inv_of_expr mem e).inv |> circuit_of_form ~st hyps) in let st = update_state_pv st mem v c in st - (* if debug then Format.eprintf "[W] Took %f seconds@." (Unix.gettimeofday() -. start); *) + (* EcEnv.notify env EcGState.(`Debug) "[W] Took %f seconds@." (Unix.gettimeofday() -. start); *) | Sasgn (LvTuple (vs), {e_node = Etuple es; _}) when List.compare_lengths vs es = 0 -> let st = List.fold_left (fun st (v, e) -> let c = ((ss_inv_of_expr mem e).inv |> circuit_of_form ~st hyps) in @@ -1107,7 +1113,7 @@ let circuit_state_of_hyps ?(strict = false) ?(use_mem = false) ?(st = empty_stat let env = toenv hyps in let ppe = EcPrinting.PPEnv.ofenv env in let st = List.fold_left (fun st (id, lk) -> - if debug then Format.eprintf "Processing hyp: %s@." (id.id_symb); + EcEnv.notify env EcGState.(`Debug) "Processing hyp: %s@." (id.id_symb); match lk with (* FIXME: Reasoning here is that we do not directly process program variables in the hyps They are either given a value by assignment in the program or if they are used @@ -1122,7 +1128,7 @@ let circuit_state_of_hyps ?(strict = false) ?(use_mem = false) ?(st = empty_stat Check if body is convertible to circuit, if not just process it as uninitialized. TODO: Maybe do a first pass on this, check convertibility and remove duplicates? *) | EcBaseLogic.LD_var (t, Some f) -> - if debug then Format.eprintf "Assigning %a to %a@." EcPrinting.(pp_form ppe) f EcIdent.pp_ident id; + EcEnv.notify env EcGState.(`Debug) "Assigning %a to %a@." EcPrinting.(pp_form ppe) f EcIdent.pp_ident id; begin try update_state st id (circuit_of_form ~st hyps f) (* FIXME PR: Should only catch circuit translation errors, hack *) diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index e01ece17c8..195d8ac651 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -5,6 +5,9 @@ open EcDecl open EcIdent open EcMemory +(* FIXME: find a solution for the "if debug then" prints here, + since it cannot depend on EcEnv *) + (* -------------------------------------------------------------------- *) module C = struct include Lospecs.Aig diff --git a/src/ecScope.ml b/src/ecScope.ml index 3ee0cd9bba..e8da4916a8 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -3132,6 +3132,19 @@ module Circuit = struct { scope with sc_env = EcSection.add_item item scope.sc_env } in Ax.add_defer scope proofs + + let find_duplicate_specs (scope : scope) : symbol list = + let specs = List.map (fun filename -> + Lospecs.Circuit_spec.load_from_file ~filename |> List.fst + ) scope.sc_specs + in + + let module Set = Batteries.Set in + List.fold_left (fun (acc, dups) next -> + let cur = Set.of_list next in + let new_dup = Set.intersect cur acc in + (Set.union acc cur), (Set.union dups new_dup) + ) (Set.empty, Set.empty) specs |> snd |> Set.to_list (* FIXME CIRCUIT PR: decide how we want to handle multiple spec files in easycrypt.project(s) *) let add_circuit1 (scope : scope) (local : is_local) ((op, circ) : (pqsymbol * string located)) : scope = @@ -3141,7 +3154,7 @@ module Circuit = struct if not (List.is_empty opdecl.op_tparams) then hierror ~loc:(loc op) "operator must be monomorphic"; - let matches = List.filteri_map (fun i filename -> + let matches = List.filteri_map (fun _i filename -> EcEnv.Circuit.get_specification_by_name ~filename env (unloc circ)) scope.sc_specs in @@ -3201,9 +3214,12 @@ module Circuit = struct | circs -> Format.eprintf "Multiple matches found (%d) for circuit %s" (List.length circs) (unloc circ); assert false (* FIXME *) - (* FIXME: Decide if we want set or append here *) let register_spec_files (scope : scope) (files : string list) : scope = - { scope with sc_specs = files } + let sc = { scope with sc_specs = files } in + match find_duplicate_specs sc with + | [] -> sc + | dups -> hierror "duplicate spec definitions: %a" + EcPrinting.(pp_list ", " pp_symbol) dups let add_circuits (scope : scope) (local : is_local) (binds : pbind_circuit) : scope = List.fold_left (fun scope bnd -> diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index 81267697e5..cbe628826e 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -167,7 +167,7 @@ let process_pre ?(st : state option) (tc: tcenv1) (f: form) : state * circuit li let cs = List.fold_left (fun acc f -> List.rev_append (process_form f) acc) [] fs |> List.rev in (* - if debug then Format.eprintf "Translated as much as possible from pre to circuits, got:@.%a@\n" + EcEnv.notify env EcGState.(`Debug) "Translated as much as possible from pre to circuits, got:@.%a@\n" (EcPrinting.pp_list "@\n@\n" pp_circuit) cs; *) @@ -256,7 +256,7 @@ let t_bdep_solve assert (ctxt.h_tvar = []); let st = circuit_state_of_hyps hyps in let cgoal = (circuit_of_form ~st hyps goal |> state_close_circuit st) in - if debug then Format.eprintf "goal: %a@." pp_flatcirc (fst cgoal).reg; + EcEnv.notify env EcGState.(`Debug) "goal: %a@." pp_flatcirc (fst cgoal).reg; if circ_taut cgoal then FApi.close (!@ tc) VBdep else @@ -387,7 +387,8 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = | _ -> tc_error (tc1_penv tc) "Unsupported List pattern" end - | FhoareS ({ hs_m=(m, mt); hs_s; hs_pr; hs_po }), Some v -> + | FhoareS hs, Some v -> + let m, mt = hs.hs_m in let v = match EcMemory.lookup v mt with | Some (v, _, _) -> v | None -> tc_error (tc1_penv tc) "Failed to find var %s in memory %s" v (EcIdent.name m) @@ -410,22 +411,18 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = let ngoals = 1 lsl size in (* let ngoals = min ngoals 5 in *) List.init ngoals (fun i -> (* FIXME FIXME this is bad *) - let subst = EcPV.PVM.(add (tc1_env tc) (PVloc v.v_name) m + let subst = EcPV.PVM.(add (tc1_env tc) (PVloc v.v_name) (fst hs.hs_m) (EcTypesafeFol.f_app_safe (tc1_env tc) of_int [f_int BI.(of_int i)]) empty) in - let s = subst_pv_stmt (tc1_hyps tc) m subst hs_s in + let s = subst_pv_stmt (tc1_hyps tc) m subst hs.hs_s in let subst = EcPV.PVM.subst (tc1_env tc) subst in - let pr = subst hs_pr in - let po = subst hs_po in + let pr = subst (hs_pr hs).inv in + let po = subst (hs_po hs).inv in let goal = f_hoareS mt ({inv=pr;m}) s ({inv=po;m}) in - if debug then - ( - Format.eprintf "[W] Generated goal %d@." i; -(* - Format.eprintf "%a@." - EcPrinting.(pp_form PPEnv.(ofenv (tc1_env tc))) goal -*) - ); + EcEnv.notify (FApi.tc1_env tc) EcGState.(`Debug) + + "[W] Generated goal %d => %a@." i + EcPrinting.(pp_form PPEnv.(ofenv (tc1_env tc))) goal; goal ) From 973b124077aa9ed8a603a3500b994ec587c6db47 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Thu, 5 Feb 2026 18:50:06 +0000 Subject: [PATCH 005/145] Killed warnings --- libs/lospecs/tests/avx2.ml | 259 ------- libs/lospecs/tests/avx2_runtime.cpp | 534 ------------- libs/lospecs/tests/avx2_runtime.h | 210 ----- libs/lospecs/tests/circuit_avx2.ml | 265 ------- libs/lospecs/tests/circuit_test.ml | 1109 --------------------------- libs/lospecs/tests/simde | 1 - src/ecCircuits.ml | 62 +- src/ecCircuits.mli | 5 +- src/ecCoreFol.ml | 3 - src/ecCoreFol.mli | 1 - src/ecLowCircuits.ml | 74 +- src/ecTheoryReplay.ml | 4 +- src/phl/ecPhlBDep.ml | 55 +- src/phl/ecPhlBDep.mli | 2 - src/phl/ecPhlCodeTx.ml | 2 +- src/phl/ecPhlEqobs.ml | 4 +- src/phl/ecPhlRewrite.ml | 17 +- src/phl/ecPhlRwEquiv.ml | 1 - src/phl/ecPhlRwPrgm.ml | 9 +- 19 files changed, 125 insertions(+), 2492 deletions(-) delete mode 100644 libs/lospecs/tests/avx2.ml delete mode 100644 libs/lospecs/tests/avx2_runtime.cpp delete mode 100644 libs/lospecs/tests/avx2_runtime.h delete mode 100644 libs/lospecs/tests/circuit_avx2.ml delete mode 100644 libs/lospecs/tests/circuit_test.ml delete mode 160000 libs/lospecs/tests/simde diff --git a/libs/lospecs/tests/avx2.ml b/libs/lospecs/tests/avx2.ml deleted file mode 100644 index d17d7f26e4..0000000000 --- a/libs/lospecs/tests/avx2.ml +++ /dev/null @@ -1,259 +0,0 @@ -(* -------------------------------------------------------------- *) -type 'a pair = 'a * 'a -type 'a quad = 'a * 'a * 'a * 'a - -(* -------------------------------------------------------------- *) -type m64x2 = int64 pair -type m64x4 = int64 quad -type m32x4 = int32 pair pair -type m32x8 = int32 pair quad -type m16x8 = int pair pair pair -type m16x16 = int pair pair quad -type m8x16 = char pair pair pair pair -type m8x32 = char pair pair pair quad - -(* -------------------------------------------------------------- *) -type m128 = m64x2 -type m256 = m64x4 - -(* -------------------------------------------------------------- *) -type endianess = [`Little | `Big] - -(* -------------------------------------------------------------- *) -type size = [`U8 | `U16 | `U32 | `U64] - -let width_of_size (s : size) : int = - match s with - | `U8 -> 8 - | `U16 -> 16 - | `U32 -> 32 - | `U64 -> 64 - -(* -------------------------------------------------------------- *) -let pp_bytes - ~(size : size) - (fmt : Format.formatter) - (v : bytes) -= - let w = width_of_size size / 8 in - - v |> Bytes.iteri (fun i b -> - if i <> 0 && i mod w = 0 then - Format.fprintf fmt "_"; - Format.fprintf fmt "%02x" (Char.code b) - ) - -(* -------------------------------------------------------------- *) -let map_quad (type a) (type b) - (f : a -> b) - ((x0, x1, x2, x3) : a quad) -= - (f x0, f x1, f x2, f x3) - -(* -------------------------------------------------------------- *) -let map_pair (type a) (type b) (f : a -> b) ((x, y) : a pair) = - (f x, f y) - -(* -------------------------------------------------------------- *) -external m64_to_32x2 : int64 -> int32 pair = "m64_to_32x2" -external m32_to_16x2 : int32 -> int pair = "m32_to_16x2" -external m16_to_8x2 : int -> char pair = "m16_to_8x2" - -(* -------------------------------------------------------------- *) -external m64_of_32x2 : int32 pair -> int64 = "m64_of_32x2" -external m32_of_16x2 : int pair -> int32 = "m32_of_16x2" -external m16_of_8x2 : char pair -> int = "m16_of_8x2" - -(* -------------------------------------------------------------- *) -module M256 = struct - (* ------------------------------------------------------------ *) - external oftuple_64 : m64x4 -> m256 = "%identity" - external totuple_64 : m256 -> m64x4 = "%identity" - - (* ------------------------------------------------------------ *) - let to_bytes ~(endianess : endianess) (v : m256) : bytes = - let w0, w1, w2, w3 = totuple_64 v in - let b = Buffer.create 32 in - - let () = - match endianess with - | `Little -> - Buffer.add_int64_le b w0; - Buffer.add_int64_le b w1; - Buffer.add_int64_le b w2; - Buffer.add_int64_le b w3; - - | `Big -> - Buffer.add_int64_be b w3; - Buffer.add_int64_be b w2; - Buffer.add_int64_be b w1; - Buffer.add_int64_be b w0 - - in Buffer.to_bytes b - - (* ------------------------------------------------------------ *) - let of_bytes ~(endianess : endianess) (v : bytes) : m256 = - assert (Bytes.length v = 32); - - let w0, w1, w2, w3 = - match endianess with - | `Big -> ( - Bytes.get_int64_be v 24, - Bytes.get_int64_be v 16, - Bytes.get_int64_be v 8, - Bytes.get_int64_be v 0 - ) - | `Little -> ( - Bytes.get_int64_le v 0, - Bytes.get_int64_le v 8, - Bytes.get_int64_le v 16, - Bytes.get_int64_le v 24 - ) - - in oftuple_64 (w0, w1, w2, w3) - - (* ------------------------------------------------------------ *) - let pp - ~(size : size) - ~(endianess : endianess) - (fmt : Format.formatter) - (v : m256) - = - Format.fprintf fmt "%a" (pp_bytes ~size) (to_bytes ~endianess v) - - (* ------------------------------------------------------------ *) - let oftuple_32 (v : m32x8) : m256 = - oftuple_64 (map_quad m64_of_32x2 v) - - let totuple_32 (v : m256) : m32x8 = - map_quad m64_to_32x2 (totuple_64 v) - - (* ------------------------------------------------------------ *) - let oftuple_16 (v : m16x16) : m256 = - oftuple_32 (map_quad (map_pair m32_of_16x2) v) - - let totuple_16 (v : m256) : m16x16 = - map_quad (map_pair m32_to_16x2) (totuple_32 v) - - (* ------------------------------------------------------------ *) - let oftuple_8 (v : m8x32) : m256 = - oftuple_16 (map_quad (map_pair (map_pair m16_of_8x2)) v) - - let totuple_8 (v : m256) : m8x32 = - map_quad (map_pair (map_pair m16_to_8x2)) (totuple_16 v) - - (* ------------------------------------------------------------ *) - let random () : m256 = - let w0 = Random.bits64() in - let w1 = Random.bits64() in - let w2 = Random.bits64() in - let w3 = Random.bits64() in - oftuple_64 (w0, w1, w2, w3) -end - -(* -------------------------------------------------------------- *) -module M128 = struct - (* ------------------------------------------------------------ *) - external oftuple_64 : m64x2 -> m128 = "%identity" - external totuple_64 : m128 -> m64x2 = "%identity" - - (* ------------------------------------------------------------ *) - let to_bytes ~(endianess : endianess) (v : m128) : bytes = - let w0, w1 = totuple_64 v in - let b = Buffer.create 32 in - - let () = - match endianess with - | `Little -> - Buffer.add_int64_le b w0; - Buffer.add_int64_le b w1 - - | `Big -> - Buffer.add_int64_be b w1; - Buffer.add_int64_be b w0 - - in Buffer.to_bytes b - - (* ------------------------------------------------------------ *) - let of_bytes ~(endianess : endianess) (v : bytes) : m128 = - assert (Bytes.length v = 16); - - let w0, w1 = - match endianess with - | `Big -> ( - Bytes.get_int64_be v 8, - Bytes.get_int64_be v 0 - ) - | `Little -> ( - Bytes.get_int64_le v 0, - Bytes.get_int64_le v 8 - ) - - in oftuple_64 (w0, w1) - - (* ------------------------------------------------------------ *) - let pp - ~(size : size) - ~(endianess : endianess) - (fmt : Format.formatter) - (v : m128) - = - Format.fprintf fmt "%a" (pp_bytes ~size) (to_bytes ~endianess v) - - (* ------------------------------------------------------------ *) - let oftuple_32 (v : m32x4) : m128 = - oftuple_64 (map_pair m64_of_32x2 v) - - let totuple_32 (v : m128) : m32x4 = - map_pair m64_to_32x2 (totuple_64 v) - - (* ------------------------------------------------------------ *) - let oftuple_16 (v : m16x8) : m128 = - oftuple_32 (map_pair (map_pair m32_of_16x2) v) - - let totuple_16 (v : m128) : m16x8 = - map_pair (map_pair m32_to_16x2) (totuple_32 v) - - (* ------------------------------------------------------------ *) - let oftuple_8 (v : m8x16) : m128 = - oftuple_16 (map_pair (map_pair (map_pair m16_of_8x2)) v) - - let totuple_8 (v : m128) : m8x16 = - map_pair (map_pair (map_pair m16_to_8x2)) (totuple_16 v) - - (* ------------------------------------------------------------ *) - let random () : m128 = - let w0 = Random.bits64() in - let w1 = Random.bits64() in - oftuple_64 (w0, w1) -end - -(* -------------------------------------------------------------- *) -external mm256_and_si256 : m256 -> m256 -> m256 = "caml_simde_mm256_and_si256" -external mm256_andnot_si256 : m256 -> m256 -> m256 = "caml_simde_mm256_andnot_si256" -external mm256_add_epi8 : m256 -> m256 -> m256 = "caml_simde_mm256_add_epi8" -external mm256_add_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_add_epi16" -external mm256_sub_epi8 : m256 -> m256 -> m256 = "caml_simde_mm256_sub_epi8" -external mm256_sub_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_sub_epi16" -external mm256_mulhi_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_mulhi_epi16" -external mm256_mulhi_epu16 : m256 -> m256 -> m256 = "caml_simde_mm256_mulhi_epu16" -external mm256_mulhrs_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_mulhrs_epi16" -external mm256_packus_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_packus_epi16" -external mm256_packs_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_packs_epi16" -external mm256_maddubs_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_maddubs_epi16" -external mm256_permutevar8x32_epi32 : m256 -> m256 -> m256 = "caml_simde_mm256_permutevar8x32_epi32" -external mm256_permute4x64_epi64 : m256 -> int -> m256 = "caml_simde_mm256_permute4x64_epi64_dyn" -external mm256_permute2x128_si256 : m256 -> m256 -> int -> m256 = "caml_simde_mm256_permute2x128_si256_dyn" -external mm256_shuffle_epi8 : m256 -> m256 -> m256 = "caml_simde_mm256_shuffle_epi8" -external mm256_srai_epi16 : m256 -> int -> m256 = "caml_simde_mm256_srai_epi16" -external mm256_srli_epi16 : m256 -> int -> m256 = "caml_simde_mm256_srli_epi16" -external mm256_cmpgt_epi16 : m256 -> m256 -> m256 = "caml_simde_mm256_cmpgt_epi16" -external mm256_movemask_epi8 : m256 -> int32 = "caml_simde_mm256_movemask_epi8" -external mm256_unpacklo_epi8 : m256 -> m256 -> m256 = "caml_simde_mm256_unpacklo_epi8" -external mm256_unpacklo_epi64 : m256 -> m256 -> m256 = "caml_simde_mm256_unpacklo_epi64" -external mm256_unpackhi_epi64 : m256 -> m256 -> m256 = "caml_simde_mm256_unpackhi_epi64" -external mm256_blend_epi16 : m256 -> m256 -> int -> m256 = "caml_simde_mm256_blend_epi16_dyn" -external mm256_blend_epi32 : m256 -> m256 -> int -> m256 = "caml_simde_mm256_blend_epi32_dyn" -external mm256_moveldup_ps : m256 -> m256 = "caml_simde_mm256_moveldup_ps_dyn" -external mm256_inserti128_si256 : m256 -> m128 -> int -> m256 = "caml_simde_mm256_inserti128_si256_dyn" -external mm256_extracti128_si256 : m256 -> int -> m128 = "caml_simde_mm256_extracti128_si256_dyn" diff --git a/libs/lospecs/tests/avx2_runtime.cpp b/libs/lospecs/tests/avx2_runtime.cpp deleted file mode 100644 index 0cbd3c7979..0000000000 --- a/libs/lospecs/tests/avx2_runtime.cpp +++ /dev/null @@ -1,534 +0,0 @@ -/* ==================================================================== */ -#include -#include "avx2_runtime.h" - -/* -------------------------------------------------------------------- */ -#include - -/* -------------------------------------------------------------------- */ -#include -#include -#include -#include -#include - -/* ==================================================================== */ -extern "C" CAMLprim value m64_of_32x2(value lohi) { - CAMLparam1(lohi); - - const uint32_t lo = (uint32_t) Int32_val(Field(lohi, 0)); - const uint32_t hi = (uint32_t) Int32_val(Field(lohi, 1)); - - const uint64_t out = ((uint64_t) lo) | (((uint64_t) hi) << 32); - - CAMLreturn(caml_copy_int64((int64_t) out)); -} - -/* -------------------------------------------------------------------- */ -extern "C" CAMLprim value m64_to_32x2(value lohi) { - CAMLparam1(lohi); - CAMLlocal1(out); - - const uint64_t v = (uint64_t) Int64_val(lohi); - - const uint32_t lo = (v >> 0) & 0xffffffff; - const uint32_t hi = (v >> 32) & 0xffffffff; - - out = caml_alloc_tuple(2); - Field(out, 0) = caml_copy_int32(lo); - Field(out, 1) = caml_copy_int32(hi); - - CAMLreturn(out); -} - -/* -------------------------------------------------------------------- */ -extern "C" CAMLprim value m32_of_16x2(value lohi) { - CAMLparam1(lohi); - - const uint16_t lo = (uint16_t) Int_val(Field(lohi, 0)); - const uint16_t hi = (uint16_t) Int_val(Field(lohi, 1)); - - const uint32_t out = ((uint32_t) lo) | (((uint32_t) hi) << 16); - - CAMLreturn(caml_copy_int32((int32_t) out)); -} - -/* -------------------------------------------------------------------- */ -extern "C" CAMLprim value m32_to_16x2(value lohi) { - CAMLparam1(lohi); - CAMLlocal1(out); - - const uint32_t v = (uint32_t) Int32_val(lohi); - - const uint16_t lo = (v >> 0) & 0xffff; - const uint16_t hi = (v >> 16) & 0xffff; - - out = caml_alloc_tuple(2); - Field(out, 0) = Val_int(lo); - Field(out, 1) = Val_int(hi); - - CAMLreturn(out); -} - -/* -------------------------------------------------------------------- */ -extern "C" CAMLprim value m16_of_8x2(value lohi) { - CAMLparam1(lohi); - - const uint8_t lo = (uint8_t) Int_val(Field(lohi, 0)); - const uint8_t hi = (uint8_t) Int_val(Field(lohi, 1)); - - const uint16_t out = ((uint16_t) lo) | (((uint16_t) hi) << 8); - - CAMLreturn(Val_int(out)); -} - -/* -------------------------------------------------------------------- */ - extern "C" CAMLprim value m16_to_8x2(value lohi) { - CAMLparam1(lohi); - CAMLlocal1(out); - - const uint16_t v = (uint16_t) Int_val(lohi); - - const uint8_t lo = (v >> 0) & 0xff; - const uint8_t hi = (v >> 8) & 0xff; - - out = caml_alloc_tuple(2); - Field(out, 0) = Val_int(lo); - Field(out, 1) = Val_int(hi); - - CAMLreturn(out); -} - -/* ==================================================================== */ -#if defined(HAS_AVX) -/* -------------------------------------------------------------------- */ -value value_of_w256(simde__m256i x) { - CAMLparam0(); - CAMLlocal1(out); - - out = caml_alloc_tuple(4); - Store_field(out, 0, caml_copy_int64(simde_mm256_extract_epi64(x, 0))); - Store_field(out, 1, caml_copy_int64(simde_mm256_extract_epi64(x, 1))); - Store_field(out, 2, caml_copy_int64(simde_mm256_extract_epi64(x, 2))); - Store_field(out, 3, caml_copy_int64(simde_mm256_extract_epi64(x, 3))); - - CAMLreturn(out); -} - -/* -------------------------------------------------------------------- */ -simde__m256i w256_of_value(value x) { - CAMLparam1(x); - - simde__m256i out = simde_mm256_set_epi64x( - Int64_val(Field(x, 3)), - Int64_val(Field(x, 2)), - Int64_val(Field(x, 1)), - Int64_val(Field(x, 0)) - ); - - CAMLreturnT(simde__m256i, out); -} - -/* -------------------------------------------------------------------- */ -value value_of_w128(simde__m128i x) { - CAMLparam0(); - CAMLlocal1(out); - - out = caml_alloc_tuple(2); - Store_field(out, 0, caml_copy_int64(simde_mm_extract_epi64(x, 0))); - Store_field(out, 1, caml_copy_int64(simde_mm_extract_epi64(x, 1))); - - CAMLreturn(out); -} - -/* -------------------------------------------------------------------- */ -simde__m128i w128_of_value(value x) { - CAMLparam1(x); - - simde__m128i out = simde_mm_set_epi64x( - Int64_val(Field(x, 1)), - Int64_val(Field(x, 0)) - ); - - CAMLreturnT(simde__m128i, out); -} - -/* -------------------------------------------------------------------- */ -simde__m256i simde_mm256_inserti128_si256_dyn(simde__m256i a, simde__m128i b, const int imm8) { - switch (imm8 & 0x01) { - case 0: - return simde_mm256_inserti128_si256(a, b, 0); - case 1: - return simde_mm256_inserti128_si256(a, b, 1); - } - abort(); -} - -/* -------------------------------------------------------------------- */ -simde__m128i simde_mm256_extracti128_si256_dyn(simde__m256i a, const int imm8) { - switch (imm8 & 0x01) { - case 0: - return simde_mm256_extracti128_si256(a, 0); - case 1: - return simde_mm256_extracti128_si256(a, 1); - } - abort(); -} - -/* -------------------------------------------------------------------- */ -simde__m256i simde_mm256_blend_epi16_dyn(simde__m256i a, simde__m256i b, const int imm8) { -#define CASE(I) case I: return simde_mm256_blend_epi16(a, b, I) - - /* - * for i in range(0, 256, 4): - * print('; '.join(f'CASE(0x{j:02x})' for j in range(i, i+4)) + ';') - */ - switch (imm8 & 0xff) { - CASE(0x00); CASE(0x01); CASE(0x02); CASE(0x03); - CASE(0x04); CASE(0x05); CASE(0x06); CASE(0x07); - CASE(0x08); CASE(0x09); CASE(0x0a); CASE(0x0b); - CASE(0x0c); CASE(0x0d); CASE(0x0e); CASE(0x0f); - CASE(0x10); CASE(0x11); CASE(0x12); CASE(0x13); - CASE(0x14); CASE(0x15); CASE(0x16); CASE(0x17); - CASE(0x18); CASE(0x19); CASE(0x1a); CASE(0x1b); - CASE(0x1c); CASE(0x1d); CASE(0x1e); CASE(0x1f); - CASE(0x20); CASE(0x21); CASE(0x22); CASE(0x23); - CASE(0x24); CASE(0x25); CASE(0x26); CASE(0x27); - CASE(0x28); CASE(0x29); CASE(0x2a); CASE(0x2b); - CASE(0x2c); CASE(0x2d); CASE(0x2e); CASE(0x2f); - CASE(0x30); CASE(0x31); CASE(0x32); CASE(0x33); - CASE(0x34); CASE(0x35); CASE(0x36); CASE(0x37); - CASE(0x38); CASE(0x39); CASE(0x3a); CASE(0x3b); - CASE(0x3c); CASE(0x3d); CASE(0x3e); CASE(0x3f); - CASE(0x40); CASE(0x41); CASE(0x42); CASE(0x43); - CASE(0x44); CASE(0x45); CASE(0x46); CASE(0x47); - CASE(0x48); CASE(0x49); CASE(0x4a); CASE(0x4b); - CASE(0x4c); CASE(0x4d); CASE(0x4e); CASE(0x4f); - CASE(0x50); CASE(0x51); CASE(0x52); CASE(0x53); - CASE(0x54); CASE(0x55); CASE(0x56); CASE(0x57); - CASE(0x58); CASE(0x59); CASE(0x5a); CASE(0x5b); - CASE(0x5c); CASE(0x5d); CASE(0x5e); CASE(0x5f); - CASE(0x60); CASE(0x61); CASE(0x62); CASE(0x63); - CASE(0x64); CASE(0x65); CASE(0x66); CASE(0x67); - CASE(0x68); CASE(0x69); CASE(0x6a); CASE(0x6b); - CASE(0x6c); CASE(0x6d); CASE(0x6e); CASE(0x6f); - CASE(0x70); CASE(0x71); CASE(0x72); CASE(0x73); - CASE(0x74); CASE(0x75); CASE(0x76); CASE(0x77); - CASE(0x78); CASE(0x79); CASE(0x7a); CASE(0x7b); - CASE(0x7c); CASE(0x7d); CASE(0x7e); CASE(0x7f); - CASE(0x80); CASE(0x81); CASE(0x82); CASE(0x83); - CASE(0x84); CASE(0x85); CASE(0x86); CASE(0x87); - CASE(0x88); CASE(0x89); CASE(0x8a); CASE(0x8b); - CASE(0x8c); CASE(0x8d); CASE(0x8e); CASE(0x8f); - CASE(0x90); CASE(0x91); CASE(0x92); CASE(0x93); - CASE(0x94); CASE(0x95); CASE(0x96); CASE(0x97); - CASE(0x98); CASE(0x99); CASE(0x9a); CASE(0x9b); - CASE(0x9c); CASE(0x9d); CASE(0x9e); CASE(0x9f); - CASE(0xa0); CASE(0xa1); CASE(0xa2); CASE(0xa3); - CASE(0xa4); CASE(0xa5); CASE(0xa6); CASE(0xa7); - CASE(0xa8); CASE(0xa9); CASE(0xaa); CASE(0xab); - CASE(0xac); CASE(0xad); CASE(0xae); CASE(0xaf); - CASE(0xb0); CASE(0xb1); CASE(0xb2); CASE(0xb3); - CASE(0xb4); CASE(0xb5); CASE(0xb6); CASE(0xb7); - CASE(0xb8); CASE(0xb9); CASE(0xba); CASE(0xbb); - CASE(0xbc); CASE(0xbd); CASE(0xbe); CASE(0xbf); - CASE(0xc0); CASE(0xc1); CASE(0xc2); CASE(0xc3); - CASE(0xc4); CASE(0xc5); CASE(0xc6); CASE(0xc7); - CASE(0xc8); CASE(0xc9); CASE(0xca); CASE(0xcb); - CASE(0xcc); CASE(0xcd); CASE(0xce); CASE(0xcf); - CASE(0xd0); CASE(0xd1); CASE(0xd2); CASE(0xd3); - CASE(0xd4); CASE(0xd5); CASE(0xd6); CASE(0xd7); - CASE(0xd8); CASE(0xd9); CASE(0xda); CASE(0xdb); - CASE(0xdc); CASE(0xdd); CASE(0xde); CASE(0xdf); - CASE(0xe0); CASE(0xe1); CASE(0xe2); CASE(0xe3); - CASE(0xe4); CASE(0xe5); CASE(0xe6); CASE(0xe7); - CASE(0xe8); CASE(0xe9); CASE(0xea); CASE(0xeb); - CASE(0xec); CASE(0xed); CASE(0xee); CASE(0xef); - CASE(0xf0); CASE(0xf1); CASE(0xf2); CASE(0xf3); - CASE(0xf4); CASE(0xf5); CASE(0xf6); CASE(0xf7); - CASE(0xf8); CASE(0xf9); CASE(0xfa); CASE(0xfb); - CASE(0xfc); CASE(0xfd); CASE(0xfe); CASE(0xff); - } - abort(); -#undef CASE -} - -/* -------------------------------------------------------------------- */ -simde__m256i simde_mm256_blend_epi32_dyn(simde__m256i a, simde__m256i b, const int imm8) { -#define CASE(I) case I: return simde_mm256_blend_epi32(a, b, I) - - /* - * for i in range(0, 256, 4): - * print('; '.join(f'CASE(0x{j:02x})' for j in range(i, i+4)) + ';') - */ - switch (imm8 & 0xff) { - CASE(0x00); CASE(0x01); CASE(0x02); CASE(0x03); - CASE(0x04); CASE(0x05); CASE(0x06); CASE(0x07); - CASE(0x08); CASE(0x09); CASE(0x0a); CASE(0x0b); - CASE(0x0c); CASE(0x0d); CASE(0x0e); CASE(0x0f); - CASE(0x10); CASE(0x11); CASE(0x12); CASE(0x13); - CASE(0x14); CASE(0x15); CASE(0x16); CASE(0x17); - CASE(0x18); CASE(0x19); CASE(0x1a); CASE(0x1b); - CASE(0x1c); CASE(0x1d); CASE(0x1e); CASE(0x1f); - CASE(0x20); CASE(0x21); CASE(0x22); CASE(0x23); - CASE(0x24); CASE(0x25); CASE(0x26); CASE(0x27); - CASE(0x28); CASE(0x29); CASE(0x2a); CASE(0x2b); - CASE(0x2c); CASE(0x2d); CASE(0x2e); CASE(0x2f); - CASE(0x30); CASE(0x31); CASE(0x32); CASE(0x33); - CASE(0x34); CASE(0x35); CASE(0x36); CASE(0x37); - CASE(0x38); CASE(0x39); CASE(0x3a); CASE(0x3b); - CASE(0x3c); CASE(0x3d); CASE(0x3e); CASE(0x3f); - CASE(0x40); CASE(0x41); CASE(0x42); CASE(0x43); - CASE(0x44); CASE(0x45); CASE(0x46); CASE(0x47); - CASE(0x48); CASE(0x49); CASE(0x4a); CASE(0x4b); - CASE(0x4c); CASE(0x4d); CASE(0x4e); CASE(0x4f); - CASE(0x50); CASE(0x51); CASE(0x52); CASE(0x53); - CASE(0x54); CASE(0x55); CASE(0x56); CASE(0x57); - CASE(0x58); CASE(0x59); CASE(0x5a); CASE(0x5b); - CASE(0x5c); CASE(0x5d); CASE(0x5e); CASE(0x5f); - CASE(0x60); CASE(0x61); CASE(0x62); CASE(0x63); - CASE(0x64); CASE(0x65); CASE(0x66); CASE(0x67); - CASE(0x68); CASE(0x69); CASE(0x6a); CASE(0x6b); - CASE(0x6c); CASE(0x6d); CASE(0x6e); CASE(0x6f); - CASE(0x70); CASE(0x71); CASE(0x72); CASE(0x73); - CASE(0x74); CASE(0x75); CASE(0x76); CASE(0x77); - CASE(0x78); CASE(0x79); CASE(0x7a); CASE(0x7b); - CASE(0x7c); CASE(0x7d); CASE(0x7e); CASE(0x7f); - CASE(0x80); CASE(0x81); CASE(0x82); CASE(0x83); - CASE(0x84); CASE(0x85); CASE(0x86); CASE(0x87); - CASE(0x88); CASE(0x89); CASE(0x8a); CASE(0x8b); - CASE(0x8c); CASE(0x8d); CASE(0x8e); CASE(0x8f); - CASE(0x90); CASE(0x91); CASE(0x92); CASE(0x93); - CASE(0x94); CASE(0x95); CASE(0x96); CASE(0x97); - CASE(0x98); CASE(0x99); CASE(0x9a); CASE(0x9b); - CASE(0x9c); CASE(0x9d); CASE(0x9e); CASE(0x9f); - CASE(0xa0); CASE(0xa1); CASE(0xa2); CASE(0xa3); - CASE(0xa4); CASE(0xa5); CASE(0xa6); CASE(0xa7); - CASE(0xa8); CASE(0xa9); CASE(0xaa); CASE(0xab); - CASE(0xac); CASE(0xad); CASE(0xae); CASE(0xaf); - CASE(0xb0); CASE(0xb1); CASE(0xb2); CASE(0xb3); - CASE(0xb4); CASE(0xb5); CASE(0xb6); CASE(0xb7); - CASE(0xb8); CASE(0xb9); CASE(0xba); CASE(0xbb); - CASE(0xbc); CASE(0xbd); CASE(0xbe); CASE(0xbf); - CASE(0xc0); CASE(0xc1); CASE(0xc2); CASE(0xc3); - CASE(0xc4); CASE(0xc5); CASE(0xc6); CASE(0xc7); - CASE(0xc8); CASE(0xc9); CASE(0xca); CASE(0xcb); - CASE(0xcc); CASE(0xcd); CASE(0xce); CASE(0xcf); - CASE(0xd0); CASE(0xd1); CASE(0xd2); CASE(0xd3); - CASE(0xd4); CASE(0xd5); CASE(0xd6); CASE(0xd7); - CASE(0xd8); CASE(0xd9); CASE(0xda); CASE(0xdb); - CASE(0xdc); CASE(0xdd); CASE(0xde); CASE(0xdf); - CASE(0xe0); CASE(0xe1); CASE(0xe2); CASE(0xe3); - CASE(0xe4); CASE(0xe5); CASE(0xe6); CASE(0xe7); - CASE(0xe8); CASE(0xe9); CASE(0xea); CASE(0xeb); - CASE(0xec); CASE(0xed); CASE(0xee); CASE(0xef); - CASE(0xf0); CASE(0xf1); CASE(0xf2); CASE(0xf3); - CASE(0xf4); CASE(0xf5); CASE(0xf6); CASE(0xf7); - CASE(0xf8); CASE(0xf9); CASE(0xfa); CASE(0xfb); - CASE(0xfc); CASE(0xfd); CASE(0xfe); CASE(0xff); - } - abort(); -#undef CASE -} - -/* -------------------------------------------------------------------- */ -simde__m256i simde_mm256_permute4x64_epi64_dyn(simde__m256i a, const int imm8) { -#define CASE(I) case I: return simde_mm256_permute4x64_epi64(a, I) - - /* - * for i in range(0, 256, 4): - * print('; '.join(f'CASE(0x{j:02x})' for j in range(i, i+4)) + ';') - */ - switch (imm8 & 0xff) { - CASE(0x00); CASE(0x01); CASE(0x02); CASE(0x03); - CASE(0x04); CASE(0x05); CASE(0x06); CASE(0x07); - CASE(0x08); CASE(0x09); CASE(0x0a); CASE(0x0b); - CASE(0x0c); CASE(0x0d); CASE(0x0e); CASE(0x0f); - CASE(0x10); CASE(0x11); CASE(0x12); CASE(0x13); - CASE(0x14); CASE(0x15); CASE(0x16); CASE(0x17); - CASE(0x18); CASE(0x19); CASE(0x1a); CASE(0x1b); - CASE(0x1c); CASE(0x1d); CASE(0x1e); CASE(0x1f); - CASE(0x20); CASE(0x21); CASE(0x22); CASE(0x23); - CASE(0x24); CASE(0x25); CASE(0x26); CASE(0x27); - CASE(0x28); CASE(0x29); CASE(0x2a); CASE(0x2b); - CASE(0x2c); CASE(0x2d); CASE(0x2e); CASE(0x2f); - CASE(0x30); CASE(0x31); CASE(0x32); CASE(0x33); - CASE(0x34); CASE(0x35); CASE(0x36); CASE(0x37); - CASE(0x38); CASE(0x39); CASE(0x3a); CASE(0x3b); - CASE(0x3c); CASE(0x3d); CASE(0x3e); CASE(0x3f); - CASE(0x40); CASE(0x41); CASE(0x42); CASE(0x43); - CASE(0x44); CASE(0x45); CASE(0x46); CASE(0x47); - CASE(0x48); CASE(0x49); CASE(0x4a); CASE(0x4b); - CASE(0x4c); CASE(0x4d); CASE(0x4e); CASE(0x4f); - CASE(0x50); CASE(0x51); CASE(0x52); CASE(0x53); - CASE(0x54); CASE(0x55); CASE(0x56); CASE(0x57); - CASE(0x58); CASE(0x59); CASE(0x5a); CASE(0x5b); - CASE(0x5c); CASE(0x5d); CASE(0x5e); CASE(0x5f); - CASE(0x60); CASE(0x61); CASE(0x62); CASE(0x63); - CASE(0x64); CASE(0x65); CASE(0x66); CASE(0x67); - CASE(0x68); CASE(0x69); CASE(0x6a); CASE(0x6b); - CASE(0x6c); CASE(0x6d); CASE(0x6e); CASE(0x6f); - CASE(0x70); CASE(0x71); CASE(0x72); CASE(0x73); - CASE(0x74); CASE(0x75); CASE(0x76); CASE(0x77); - CASE(0x78); CASE(0x79); CASE(0x7a); CASE(0x7b); - CASE(0x7c); CASE(0x7d); CASE(0x7e); CASE(0x7f); - CASE(0x80); CASE(0x81); CASE(0x82); CASE(0x83); - CASE(0x84); CASE(0x85); CASE(0x86); CASE(0x87); - CASE(0x88); CASE(0x89); CASE(0x8a); CASE(0x8b); - CASE(0x8c); CASE(0x8d); CASE(0x8e); CASE(0x8f); - CASE(0x90); CASE(0x91); CASE(0x92); CASE(0x93); - CASE(0x94); CASE(0x95); CASE(0x96); CASE(0x97); - CASE(0x98); CASE(0x99); CASE(0x9a); CASE(0x9b); - CASE(0x9c); CASE(0x9d); CASE(0x9e); CASE(0x9f); - CASE(0xa0); CASE(0xa1); CASE(0xa2); CASE(0xa3); - CASE(0xa4); CASE(0xa5); CASE(0xa6); CASE(0xa7); - CASE(0xa8); CASE(0xa9); CASE(0xaa); CASE(0xab); - CASE(0xac); CASE(0xad); CASE(0xae); CASE(0xaf); - CASE(0xb0); CASE(0xb1); CASE(0xb2); CASE(0xb3); - CASE(0xb4); CASE(0xb5); CASE(0xb6); CASE(0xb7); - CASE(0xb8); CASE(0xb9); CASE(0xba); CASE(0xbb); - CASE(0xbc); CASE(0xbd); CASE(0xbe); CASE(0xbf); - CASE(0xc0); CASE(0xc1); CASE(0xc2); CASE(0xc3); - CASE(0xc4); CASE(0xc5); CASE(0xc6); CASE(0xc7); - CASE(0xc8); CASE(0xc9); CASE(0xca); CASE(0xcb); - CASE(0xcc); CASE(0xcd); CASE(0xce); CASE(0xcf); - CASE(0xd0); CASE(0xd1); CASE(0xd2); CASE(0xd3); - CASE(0xd4); CASE(0xd5); CASE(0xd6); CASE(0xd7); - CASE(0xd8); CASE(0xd9); CASE(0xda); CASE(0xdb); - CASE(0xdc); CASE(0xdd); CASE(0xde); CASE(0xdf); - CASE(0xe0); CASE(0xe1); CASE(0xe2); CASE(0xe3); - CASE(0xe4); CASE(0xe5); CASE(0xe6); CASE(0xe7); - CASE(0xe8); CASE(0xe9); CASE(0xea); CASE(0xeb); - CASE(0xec); CASE(0xed); CASE(0xee); CASE(0xef); - CASE(0xf0); CASE(0xf1); CASE(0xf2); CASE(0xf3); - CASE(0xf4); CASE(0xf5); CASE(0xf6); CASE(0xf7); - CASE(0xf8); CASE(0xf9); CASE(0xfa); CASE(0xfb); - CASE(0xfc); CASE(0xfd); CASE(0xfe); CASE(0xff); - } - abort(); -#undef CASE -} - -/* -------------------------------------------------------------------- */ -simde__m256i simde_mm256_permute2x128_si256_dyn(simde__m256i a, simde__m256i b, const int imm8) { -#define CASE(I) case I: return simde_mm256_permute2x128_si256(a, b, I) - - /* - * for i in range(0, 256, 4): - * print('; '.join(f'CASE(0x{j:02x})' for j in range(i, i+4)) + ';') - */ - switch (imm8 & 0xff) { - CASE(0x00); CASE(0x01); CASE(0x02); CASE(0x03); - CASE(0x04); CASE(0x05); CASE(0x06); CASE(0x07); - CASE(0x08); CASE(0x09); CASE(0x0a); CASE(0x0b); - CASE(0x0c); CASE(0x0d); CASE(0x0e); CASE(0x0f); - CASE(0x10); CASE(0x11); CASE(0x12); CASE(0x13); - CASE(0x14); CASE(0x15); CASE(0x16); CASE(0x17); - CASE(0x18); CASE(0x19); CASE(0x1a); CASE(0x1b); - CASE(0x1c); CASE(0x1d); CASE(0x1e); CASE(0x1f); - CASE(0x20); CASE(0x21); CASE(0x22); CASE(0x23); - CASE(0x24); CASE(0x25); CASE(0x26); CASE(0x27); - CASE(0x28); CASE(0x29); CASE(0x2a); CASE(0x2b); - CASE(0x2c); CASE(0x2d); CASE(0x2e); CASE(0x2f); - CASE(0x30); CASE(0x31); CASE(0x32); CASE(0x33); - CASE(0x34); CASE(0x35); CASE(0x36); CASE(0x37); - CASE(0x38); CASE(0x39); CASE(0x3a); CASE(0x3b); - CASE(0x3c); CASE(0x3d); CASE(0x3e); CASE(0x3f); - CASE(0x40); CASE(0x41); CASE(0x42); CASE(0x43); - CASE(0x44); CASE(0x45); CASE(0x46); CASE(0x47); - CASE(0x48); CASE(0x49); CASE(0x4a); CASE(0x4b); - CASE(0x4c); CASE(0x4d); CASE(0x4e); CASE(0x4f); - CASE(0x50); CASE(0x51); CASE(0x52); CASE(0x53); - CASE(0x54); CASE(0x55); CASE(0x56); CASE(0x57); - CASE(0x58); CASE(0x59); CASE(0x5a); CASE(0x5b); - CASE(0x5c); CASE(0x5d); CASE(0x5e); CASE(0x5f); - CASE(0x60); CASE(0x61); CASE(0x62); CASE(0x63); - CASE(0x64); CASE(0x65); CASE(0x66); CASE(0x67); - CASE(0x68); CASE(0x69); CASE(0x6a); CASE(0x6b); - CASE(0x6c); CASE(0x6d); CASE(0x6e); CASE(0x6f); - CASE(0x70); CASE(0x71); CASE(0x72); CASE(0x73); - CASE(0x74); CASE(0x75); CASE(0x76); CASE(0x77); - CASE(0x78); CASE(0x79); CASE(0x7a); CASE(0x7b); - CASE(0x7c); CASE(0x7d); CASE(0x7e); CASE(0x7f); - CASE(0x80); CASE(0x81); CASE(0x82); CASE(0x83); - CASE(0x84); CASE(0x85); CASE(0x86); CASE(0x87); - CASE(0x88); CASE(0x89); CASE(0x8a); CASE(0x8b); - CASE(0x8c); CASE(0x8d); CASE(0x8e); CASE(0x8f); - CASE(0x90); CASE(0x91); CASE(0x92); CASE(0x93); - CASE(0x94); CASE(0x95); CASE(0x96); CASE(0x97); - CASE(0x98); CASE(0x99); CASE(0x9a); CASE(0x9b); - CASE(0x9c); CASE(0x9d); CASE(0x9e); CASE(0x9f); - CASE(0xa0); CASE(0xa1); CASE(0xa2); CASE(0xa3); - CASE(0xa4); CASE(0xa5); CASE(0xa6); CASE(0xa7); - CASE(0xa8); CASE(0xa9); CASE(0xaa); CASE(0xab); - CASE(0xac); CASE(0xad); CASE(0xae); CASE(0xaf); - CASE(0xb0); CASE(0xb1); CASE(0xb2); CASE(0xb3); - CASE(0xb4); CASE(0xb5); CASE(0xb6); CASE(0xb7); - CASE(0xb8); CASE(0xb9); CASE(0xba); CASE(0xbb); - CASE(0xbc); CASE(0xbd); CASE(0xbe); CASE(0xbf); - CASE(0xc0); CASE(0xc1); CASE(0xc2); CASE(0xc3); - CASE(0xc4); CASE(0xc5); CASE(0xc6); CASE(0xc7); - CASE(0xc8); CASE(0xc9); CASE(0xca); CASE(0xcb); - CASE(0xcc); CASE(0xcd); CASE(0xce); CASE(0xcf); - CASE(0xd0); CASE(0xd1); CASE(0xd2); CASE(0xd3); - CASE(0xd4); CASE(0xd5); CASE(0xd6); CASE(0xd7); - CASE(0xd8); CASE(0xd9); CASE(0xda); CASE(0xdb); - CASE(0xdc); CASE(0xdd); CASE(0xde); CASE(0xdf); - CASE(0xe0); CASE(0xe1); CASE(0xe2); CASE(0xe3); - CASE(0xe4); CASE(0xe5); CASE(0xe6); CASE(0xe7); - CASE(0xe8); CASE(0xe9); CASE(0xea); CASE(0xeb); - CASE(0xec); CASE(0xed); CASE(0xee); CASE(0xef); - CASE(0xf0); CASE(0xf1); CASE(0xf2); CASE(0xf3); - CASE(0xf4); CASE(0xf5); CASE(0xf6); CASE(0xf7); - CASE(0xf8); CASE(0xf9); CASE(0xfa); CASE(0xfb); - CASE(0xfc); CASE(0xfd); CASE(0xfe); CASE(0xff); - } - abort(); -#undef CASE -} - -/* -------------------------------------------------------------------- */ -simde__m256i simde_mm256_moveldup_ps_dyn(simde__m256i a) { - return (simde__m256i)simde_mm256_moveldup_ps((simde__m256)a); -} - - -#endif - -extern "C" { -BIND_256x2_256(simde_mm256_permutevar8x32_epi32); -BIND2(simde_mm256_permute4x64_epi64_dyn, M256i, M256i, Long); -BIND3(simde_mm256_permute2x128_si256_dyn, M256i, M256i, M256i, Long); - -BIND_256x2_256(simde_mm256_and_si256); -BIND_256x2_256(simde_mm256_andnot_si256); -BIND_256x2_256(simde_mm256_add_epi8); -BIND_256x2_256(simde_mm256_add_epi16); -BIND_256x2_256(simde_mm256_sub_epi8); -BIND_256x2_256(simde_mm256_sub_epi16); -BIND_256x2_256(simde_mm256_maddubs_epi16); -BIND_256x2_256(simde_mm256_packus_epi16); -BIND_256x2_256(simde_mm256_packs_epi16); -BIND_256x2_256(simde_mm256_mulhi_epi16); -BIND_256x2_256(simde_mm256_mulhi_epu16); -BIND_256x2_256(simde_mm256_mulhrs_epi16); - -BIND_256x2_256(simde_mm256_shuffle_epi8); -BIND_256x2_256(simde_mm256_cmpgt_epi16); -BIND_256x2_256(simde_mm256_unpacklo_epi8); -BIND_256x2_256(simde_mm256_unpacklo_epi64); -BIND_256x2_256(simde_mm256_unpackhi_epi64); - -BIND2(simde_mm256_srai_epi16, M256i, M256i, Long); -BIND2(simde_mm256_srli_epi16, M256i, M256i, Long); - -BIND1(simde_mm256_movemask_epi8, Int32, M256i); -BIND1(simde_mm256_moveldup_ps_dyn, M256i, M256i); - -BIND3(simde_mm256_blend_epi16_dyn, M256i, M256i, M256i, Long); -BIND3(simde_mm256_blend_epi32_dyn, M256i, M256i, M256i, Long); - - -BIND3(simde_mm256_inserti128_si256_dyn, M256i, M256i, M128i, Long); -BIND2(simde_mm256_extracti128_si256_dyn, M128i, M256i, Long); -} diff --git a/libs/lospecs/tests/avx2_runtime.h b/libs/lospecs/tests/avx2_runtime.h deleted file mode 100644 index e5dd028584..0000000000 --- a/libs/lospecs/tests/avx2_runtime.h +++ /dev/null @@ -1,210 +0,0 @@ -/* ==================================================================== */ -#if !defined(AVX2_RUNTIME__) -# define AVX2_RUNTIME__ 1 - -#if defined(__x86_64__) || defined(_M_X64) -# define HAS_AVX 1 -# include -#endif - -#define HAS_AVX - -/* -------------------------------------------------------------------- */ -#include -#include -#include -#include -#include - -/* -------------------------------------------------------------------- */ -extern "C" { -CAMLprim value caml_simde_mm256_permutevar8x32_epi32(value, value); -CAMLprim value caml_simde_mm256_permute4x64_epi64_dyn(value, value); -CAMLprim value caml_simde_mm256_permute2x128_si256_dyn(value, value, value); -CAMLprim value m64_of_32x2(value); -CAMLprim value m64_to_32x2(value); -CAMLprim value m32_of_16x2(value lohi); -CAMLprim value m32_to_16x2(value lohi); -CAMLprim value m16_of_8x2(value lohi); -CAMLprim value m16_to_8x2(value lohi); - -CAMLprim value caml_simde_mm256_and_si256(value, value); -CAMLprim value caml_simde_mm256_andnot_si256(value, value); -CAMLprim value caml_simde_mm256_add_epi8(value, value); -CAMLprim value caml_simde_mm256_add_epi16(value, value); -CAMLprim value caml_simde_mm256_sub_epi8(value, value); -CAMLprim value caml_simde_mm256_sub_epi16(value, value); -CAMLprim value caml_simde_mm256_maddubs_epi16(value, value); -CAMLprim value caml_simde_mm256_packus_epi16(value, value); -CAMLprim value caml_simde_mm256_packs_epi16(value, value); -CAMLprim value caml_simde_mm256_mulhi_epu16(value, value); -CAMLprim value caml_simde_mm256_mulhrs_epi16(value, value); -CAMLprim value caml_simde_mm256_shuffle_epi8(value, value); -CAMLprim value caml_simde_mm256_srai_epi16(value, value); -CAMLprim value caml_simde_mm256_srli_epi16(value, value); -CAMLprim value caml_simde_mm256_cmpgt_epi16(value, value); -CAMLprim value caml_simde_mm256_movemask_epi8(value); -CAMLprim value caml_simde_mm256_unpacklo_epi8(value, value); -CAMLprim value caml_simde_mm256_unpacklo_epi64(value, value); -CAMLprim value caml_simde_mm256_unpackhi_epi64(value, value); -CAMLprim value caml_simde_mm256_inserti128_si256_dyn(value, value, value); -CAMLprim value caml_simde_mm256_extracti128_si256_dyn(value, value); -CAMLprim value caml_simde_mm256_blend_epi16_dyn(value, value, value); -CAMLprim value caml_simde_mm256_blend_epi32_dyn(value, value, value); -CAMLprim value caml_simde_mm256_moveldup_ps(value); -} - -/* ==================================================================== */ -#if defined(HAS_AVX) - -/* -------------------------------------------------------------------- */ -extern value value_of_w256(simde__m256i x); -extern simde__m256i w256_of_value(value x); - -/* -------------------------------------------------------------------- */ -extern value value_of_w128(simde__m128i x); -extern simde__m128i w128_of_value(value x); - -/* -------------------------------------------------------------------- */ -struct M256i { - typedef simde__m256i type; - - static inline type ofocaml(value v) { - return w256_of_value(v); - } - - static inline value toocaml(type v) { - return value_of_w256(v); - } -}; - -/* -------------------------------------------------------------------- */ -struct M128i { - typedef simde__m128i type; - - static inline type ofocaml(value v) { - return w128_of_value(v); - } - - static inline value toocaml(type v) { - return value_of_w128(v); - } -}; - -/* -------------------------------------------------------------------- */ -struct Long { - typedef long type; - - static inline type ofocaml(value v) { - return Long_val(v); - } - - static inline value toocaml(type v) { - return Val_long(v); - } -}; - -/* -------------------------------------------------------------------- */ -struct Int32 { - typedef long type; - - static inline type ofocaml(value v) { - return Int32_val(v); - } - - static inline value toocaml(type v) { - return caml_copy_int32(v); - } -}; - -/* -------------------------------------------------------------------- */ -struct Int64 { - typedef long type; - - static inline type ofocaml(value v) { - return Int64_val(v); - } - - static inline value toocaml(type v) { - return caml_copy_int64(v); - } -}; - -/* -------------------------------------------------------------------- */ -template -static value bind(value arg) { - CAMLparam1(arg); - typename T::type varg = T::ofocaml(arg); - CAMLreturn(U::toocaml(F(varg))); -} - -/* -------------------------------------------------------------------- */ -template -static value bind(value arg1, value arg2) { - CAMLparam2(arg1, arg2); - typename T1::type varg1 = T1::ofocaml(arg1); - typename T2::type varg2 = T2::ofocaml(arg2); - CAMLreturn(U::toocaml(F(varg1, varg2))); -} - -/* -------------------------------------------------------------------- */ -template -static value bind(value arg1, value arg2, value arg3) { - CAMLparam3(arg1, arg2, arg3); - typename T1::type varg1 = T1::ofocaml(arg1); - typename T2::type varg2 = T2::ofocaml(arg2); - typename T3::type varg3 = T3::ofocaml(arg3); - CAMLreturn(U::toocaml(F(varg1, varg2, varg3))); -} - -/* -------------------------------------------------------------------- */ -# define BIND1(F, U, T) \ -CAMLprim value caml_##F(value a) { \ - return bind(a); \ -} - -/* -------------------------------------------------------------------- */ -# define BIND2(F, U, T1, T2) \ -CAMLprim value caml_##F(value a, value b) { \ - return bind(a, b); \ -} - -/* -------------------------------------------------------------------- */ -# define BIND3(F, U, T1, T2, T3) \ -CAMLprim value caml_##F(value a, value b, value c) { \ - return bind(a, b, c); \ -} - -/* ==================================================================== */ -#else - -/* -------------------------------------------------------------------- */ -# define BIND1(F, U, T) \ -CAMLprim value caml_##F(value a) { \ - CAMLparam1(a); \ - caml_failwith("not implemented: " #F); \ - CAMLreturn(Val_unit); \ -} - -/* -------------------------------------------------------------------- */ -# define BIND2(F, U, T1, T2) \ -CAMLprim value caml_##F(value a, value b) { \ - CAMLparam2(a, b); \ - caml_failwith("not implemented: " #F); \ - CAMLreturn(Val_unit); \ -} - -/* -------------------------------------------------------------------- */ -# define BIND3(F, U, T1, T2, T3) \ -CAMLprim value caml_##F(value a, value b, value c) { \ - CAMLparam3(a, b, c); \ - caml_failwith("not implemented: " #F); \ - CAMLreturn(Val_unit); \ -} - -#endif /* defined(HAS_AVX) */ - -#define BIND_256x2_256(F) BIND2(F, M256i, M256i, M256i) -#define BIND_256x3_256(F) BIND3(F, M256i, M256i, M256i, M256i) - -#endif /* !AVX2_RUNTIME__ */ diff --git a/libs/lospecs/tests/circuit_avx2.ml b/libs/lospecs/tests/circuit_avx2.ml deleted file mode 100644 index 8792be5e0b..0000000000 --- a/libs/lospecs/tests/circuit_avx2.ml +++ /dev/null @@ -1,265 +0,0 @@ -(* ==================================================================== *) -open Lospecs -open Aig - -type symbol = string - -(* ==================================================================== *) -module type S = sig - val vpermd : reg -> reg -> reg - val vpermq : reg -> int -> reg - val vperm2i128 : reg -> reg -> int -> reg - val vpbroadcast_16u16 : reg -> reg - val vpadd_16u16 : reg -> reg -> reg - val vpadd_32u8 : reg -> reg -> reg - val vpsub_16u16 : reg -> reg -> reg - val vpsub_32u8 : reg -> reg -> reg - val vpand_256 : reg -> reg -> reg - val vpmaddubsw_256 : reg -> reg -> reg - val vpmulh_16u16 : reg -> reg -> reg - val vpmulhu_16u16 : reg -> reg -> reg - val vpmulhrs_16u16 : reg -> reg -> reg - val vpsra_16u16 : reg -> int -> reg - val vpsrl_16u16 : reg -> int -> reg - val vpsrl_4u64 : reg -> int -> reg - val vpsll_4u64 : reg -> int -> reg - val vpackus_16u16 : reg -> reg -> reg - val vpackss_16u16 : reg -> reg -> reg - val vpshufb_256 : reg -> reg -> reg - val vpcmpgt_16u16 : reg -> reg -> reg - val vpmovmskb_u256u64 : reg -> reg - val vpunpckl_32u8 : reg -> reg -> reg - val vpunpckl_4u64 : reg -> reg -> reg - val vpunpckh_4u64 : reg -> reg -> reg - val vpextracti128 : reg -> int -> reg - val vpinserti128 : reg -> reg -> int -> reg - val vpblend_16u16 : reg -> reg -> int -> reg - val vpblend_8u32 : reg -> reg -> int -> reg - val vpslldq_256 : reg -> int -> reg - val vpsrldq_256 : reg -> int -> reg - val vpslldq_128 : reg -> int -> reg - val vpsrldq_128 : reg -> int -> reg - val vmovsldup_256 : reg -> reg -end - -(* ==================================================================== *) -module FromSpec () : S = struct - (* ------------------------------------------------------------------ *) - let specs = - let specs = match Sys.getenv_opt "EC_AVX2_SPEC_FILE_PATH" with - | Some s -> s - | None -> Format.eprintf "Path to avx2 spec file not set, please set env var EC_AVX2_SPEC_FILE_PATH with the correct path to the file@."; - exit 1 - in - let specs = Circuit_spec.load_from_file ~filename:specs in - let specs = BatMap.of_seq (List.to_seq specs) in - specs - - let get_specification (name : symbol) : Ast.adef option = - BatMap.find_opt name specs - - (* ------------------------------------------------------------------ *) - let vpermd = Option.get (get_specification "VPERMD") - - let vpermd (r1 : reg) (r2 : reg) : reg = - Circuit_spec.circuit_of_specification [r1; r2] vpermd - - (* ------------------------------------------------------------------ *) - let vpermq = Option.get (get_specification "VPERMQ") - - let vpermq (r : reg) (i : int) : reg = - Circuit_spec.circuit_of_specification [r; Circuit.w8 i] vpermq - - (* ------------------------------------------------------------------ *) - let vperm2i128 = Option.get (get_specification "VPERM2I128") - - let vperm2i128 (r1 : reg) (r2 : reg) (i : int) : reg = - Circuit_spec.circuit_of_specification [r1; r2; Circuit.w8 i] vperm2i128 - - (* ------------------------------------------------------------------ *) - let vpbroadcast_16u16 = Option.get (get_specification "VPBROADCAST_16u16") - - let vpbroadcast_16u16 (r : reg) : reg = - Circuit_spec.circuit_of_specification [r] vpbroadcast_16u16 - - (* ------------------------------------------------------------------ *) - let vpadd_16u16 = Option.get (get_specification "VPADD_16u16") - - let vpadd_16u16 (r1 : reg) (r2 : reg) : reg = - Circuit_spec.circuit_of_specification [r1; r2] vpadd_16u16 - - (* ------------------------------------------------------------------ *) - let vpadd_32u8 = Option.get (get_specification "VPADD_32u8") - - let vpadd_32u8 (r1 : reg) (r2 : reg) : reg = - Circuit_spec.circuit_of_specification [r1; r2] vpadd_32u8 - - (* ----------------------------------------------------------------- *) - let vpsub_16u16 = Option.get (get_specification "VPSUB_16u16") - - let vpsub_16u16 (r1 : reg) (r2 : reg) : reg = - Circuit_spec.circuit_of_specification [r1; r2] vpsub_16u16 - - (* ------------------------------------------------------------------ *) - let vpsub_32u8 = Option.get (get_specification "VPSUB_32u8") - - let vpsub_32u8 (r1 : reg) (r2 : reg) : reg = - Circuit_spec.circuit_of_specification [r1; r2] vpsub_32u8 - - (* ------------------------------------------------------------------ *) - let vpand_256 = Option.get (get_specification "VPAND_256") - - let vpand_256 (r1 : reg) (r2 : reg) : reg = - Circuit_spec.circuit_of_specification [r1; r2] vpand_256 - - (* ------------------------------------------------------------------ *) - let vpmaddubsw_256 = Option.get (get_specification "VPMADDUBSW_256") - - let vpmaddubsw_256 (r1 : reg) (r2 : reg) : reg = - Circuit_spec.circuit_of_specification [r1; r2] vpmaddubsw_256 - - (* ------------------------------------------------------------------ *) - let vpmulh_16u16 = Option.get (get_specification "VPMULH_16u16") - - let vpmulh_16u16 (r1 : reg) (r2 : reg) : reg = - Circuit_spec.circuit_of_specification [r1; r2] vpmulh_16u16 - - (* ------------------------------------------------------------------ *) - let vpmulhu_16u16 = Option.get (get_specification "VPMULHU_16u16") - - let vpmulhu_16u16 (r1 : reg) (r2 : reg) : reg = - Circuit_spec.circuit_of_specification [r1; r2] vpmulhu_16u16 - - (* ------------------------------------------------------------------ *) - let vpmulhrs_16u16 = Option.get (get_specification "VPMULHRS_16u16") - - let vpmulhrs_16u16 (r1 : reg) (r2 : reg) : reg = - Circuit_spec.circuit_of_specification [r1; r2] vpmulhrs_16u16 - - (* ------------------------------------------------------------------ *) - let vpsra_16u16 = Option.get (get_specification "VPSRA_16u16") - - let vpsra_16u16 (r : reg) (n : int) : reg = - Circuit_spec.circuit_of_specification [r; Circuit.w128 (string_of_int n)] vpsra_16u16 - - (* ------------------------------------------------------------------ *) - let vpsrl_16u16 = Option.get (get_specification "VPSRL_16u16") - - let vpsrl_16u16 (r : reg) (n : int) : reg = - Circuit_spec.circuit_of_specification [r; Circuit.w128 (string_of_int n)] vpsrl_16u16 - - (* ------------------------------------------------------------------ *) - let vpsrl_4u64 = Option.get (get_specification "VPSRL_4u64") - - let vpsrl_4u64 (r : reg) (n : int) : reg = - Circuit_spec.circuit_of_specification [r; Circuit.w128 (string_of_int n)] vpsrl_4u64 - - (* ------------------------------------------------------------------ *) - let vpsll_4u64 = Option.get (get_specification "VPSLL_4u64") - - let vpsll_4u64 (r : reg) (n : int) : reg = - Circuit_spec.circuit_of_specification [r; Circuit.w128 (string_of_int n)] vpsll_4u64 - - (* ------------------------------------------------------------------ *) - let vpslldq_256 = Option.get (get_specification "VPSLLDQ_256") - - let vpslldq_256 (r : reg) (n : int) : reg = - Circuit_spec.circuit_of_specification [r; Circuit.w8 (8 * n)] vpslldq_256 - - (* ------------------------------------------------------------------ *) - let vpsrldq_256 = Option.get (get_specification "VPSRLDQ_256") - - let vpsrldq_256 (r : reg) (n : int) : reg = - Circuit_spec.circuit_of_specification [r; Circuit.w8 (8 * n)] vpsrldq_256 - - (* ------------------------------------------------------------------ *) - let vpslldq_128 = Option.get (get_specification "VPSLLDQ_128") - - let vpslldq_128 (r : reg) (n : int) : reg = - Circuit_spec.circuit_of_specification [r; Circuit.w8 (8 * n)] vpslldq_128 - - (* ------------------------------------------------------------------ *) - let vpsrldq_128 = Option.get (get_specification "VPSRLDQ_128") - - let vpsrldq_128 (r : reg) (n : int) : reg = - Circuit_spec.circuit_of_specification [r; Circuit.w8 (8 * n)] vpsrldq_128 - - (* ------------------------------------------------------------------ *) - let vpackus_16u16 = Option.get (get_specification "VPACKUS_16u16") - - let vpackus_16u16 (r1 : reg) (r2 : reg) : reg = - Circuit_spec.circuit_of_specification [r1; r2] vpackus_16u16 - - (* ------------------------------------------------------------------ *) - let vpackss_16u16 = Option.get (get_specification "VPACKSS_16u16") - - let vpackss_16u16 (r1 : reg) (r2 : reg) : reg = - Circuit_spec.circuit_of_specification [r1; r2] vpackss_16u16 - - (* ------------------------------------------------------------------ *) - let vpshufb_256 = Option.get (get_specification "VPSHUFB_256") - - let vpshufb_256 (r1 : reg) (r2 : reg) : reg = - Circuit_spec.circuit_of_specification [r1; r2] vpshufb_256 - - (* ------------------------------------------------------------------ *) - let vpcmpgt_16u16 = Option.get (get_specification "VPCMPGT_16u16") - - let vpcmpgt_16u16 (r1 : reg) (r2 : reg) : reg = - Circuit_spec.circuit_of_specification [r1; r2] vpcmpgt_16u16 - - (* ------------------------------------------------------------------ *) - let vpmovmskb_u256u64 = Option.get (get_specification "VPMOVMSKB_u256u64") - - let vpmovmskb_u256u64 (r : reg) : reg = - Circuit_spec.circuit_of_specification [r] vpmovmskb_u256u64 - - (* ------------------------------------------------------------------ *) - let vpunpckl_32u8 = Option.get (get_specification "VPUNPCKL_32u8") - - let vpunpckl_32u8 (r1 : reg) (r2 : reg): reg = - Circuit_spec.circuit_of_specification [r1; r2] vpunpckl_32u8 - - (* ------------------------------------------------------------------ *) - let vpunpckl_4u64 = Option.get (get_specification "VPUNPCKL_4u64") - - let vpunpckl_4u64 (r1 : reg) (r2 : reg): reg = - Circuit_spec.circuit_of_specification [r1; r2] vpunpckl_4u64 - - (* ------------------------------------------------------------------ *) - let vpunpckh_4u64 = Option.get (get_specification "VPUNPCKH_4u64") - - let vpunpckh_4u64 (r1 : reg) (r2 : reg): reg = - Circuit_spec.circuit_of_specification [r1; r2] vpunpckh_4u64 - - (* ------------------------------------------------------------------ *) - let vpextracti128 = Option.get (get_specification "VPEXTRACTI128") - - let vpextracti128 (r : reg) (i : int): reg = - Circuit_spec.circuit_of_specification [r; Circuit.w8 i] vpextracti128 - - (* ------------------------------------------------------------------ *) - let vpinserti128 = Option.get (get_specification "VPINSERTI128") - - let vpinserti128 (r1 : reg) (r2 : reg) (i : int): reg = - Circuit_spec.circuit_of_specification [r1; r2; Circuit.w8 i] vpinserti128 - - (* ------------------------------------------------------------------ *) - let vpblend_16u16 = Option.get (get_specification "VPBLEND_16u16") - - let vpblend_16u16 (r1 : reg) (r2 : reg) (i : int): reg = - Circuit_spec.circuit_of_specification [r1; r2; Circuit.w8 i] vpblend_16u16 - - (* ------------------------------------------------------------------ *) - let vpblend_8u32 = Option.get (get_specification "VPBLEND_8u32") - - let vpblend_8u32 (r1 : reg) (r2 : reg) (i : int): reg = - Circuit_spec.circuit_of_specification [r1; r2; Circuit.w8 i] vpblend_8u32 - - (* ------------------------------------------------------------------ *) - let vmovsldup_256 = Option.get (get_specification "VMOVSLDUP_256") - - let vmovsldup_256 (r : reg) : reg = - Circuit_spec.circuit_of_specification [r] vmovsldup_256 - -end diff --git a/libs/lospecs/tests/circuit_test.ml b/libs/lospecs/tests/circuit_test.ml deleted file mode 100644 index a9b205d9e3..0000000000 --- a/libs/lospecs/tests/circuit_test.ml +++ /dev/null @@ -1,1109 +0,0 @@ -(* -------------------------------------------------------------------- *) -open Lospecs - -(* -------------------------------------------------------------------- *) -module C = struct - include Lospecs.Aig - include Lospecs.Circuit - include Circuit_avx2.FromSpec () -end - -(* -------------------------------------------------------------------- *) -let sign (i : int) = - match i with - | _ when i < 0 -> -1 - | _ when i > 0 -> 1 - | _ -> 0 - -(* -------------------------------------------------------------------- *) -let as_seq1 (type t) (xs : t list) = - match xs with [x] -> x | _ -> assert false - -(* -------------------------------------------------------------------- *) -let as_seq2 (type t) (xs : t list) = - match xs with [x; y] -> (x, y) | _ -> assert false - -(* -------------------------------------------------------------------- *) -let pp_bytes (fmt : Format.formatter) (b : bytes) = - Bytes.iter - (fun b -> Format.fprintf fmt "%02x" (Char.code b)) - b - -(* -------------------------------------------------------------------- *) -let srange_ (i : int) = - assert (0 < i && i <= Sys.int_size); - let v = (1 lsl (i - 1)) in - (-v, v-1) - -(* -------------------------------------------------------------------- *) -let srange (i : int) = - let vm, vM = srange_ i in Iter.(--) vm vM - -(* -------------------------------------------------------------------- *) -let urange_ (i : int) = - assert (0 < i && i <= Sys.int_size - 1); - (0, (1 lsl i) - 1) - -(* -------------------------------------------------------------------- *) -let urange (i : int) = - let vm, vM = urange_ i in Iter.(--) vm vM - -(* -------------------------------------------------------------------- *) -let product (type t) (s : t Iter.t list) = - let rec doit (s : t Iter.t list) : t list Iter.t = - match s with - | [] -> - Iter.of_list [[]] - | s1 :: s -> - Iter.map (fun (x, xs) -> x :: xs) (Iter.product s1 (doit s)) - in doit s - -(* -------------------------------------------------------------------- *) -type op = { - name : string; - args : (int * [`U | `S]) list; - out : [`U | `S]; - mk : C.reg list -> C.reg; - reff : int list -> int; -} - -(* -------------------------------------------------------------------- *) -let bar (name : string) (total : int) = - let open Progress.Line in - list [ - spinner ~color:(Progress.Color.ansi `green) () - ; rpad (max 20 (String.length name)) (const name) - ; bar total - ; lpad (2 * 7 + 1) (count_to total) - ] - -(* -------------------------------------------------------------------- *) -let test (op : op) = - let rs, vs = - let reg_of_arg (name : int) ((sz, s) : int * [`U | `S]) = - let r = C.reg ~size:sz ~name in - let v = match s with `U -> urange sz | `S -> srange sz in - (r, v) - in List.split (List.mapi reg_of_arg op.args) - in - - let sz = List.sum (List.map fst op.args) in - - assert (sz <= Sys.int_size - 1); - - let total = 1 lsl sz in - let bar = bar op.name total in - - let circuit = op.mk rs in - - let test (vs : int list) = - let vsa = Array.of_list vs in - let env ((n, k) : C.var) = (vsa.(n) lsr k) land 0b1 <> 0 in - let out = Array.map (C.eval env) circuit in - let out = - match op.out with - | `S -> C.sint_of_bools out - | `U -> C.uint_of_bools out in - let exp = op.reff vs in - - if out <> exp then begin - Progress.interject_with (fun () -> - Format.eprintf "%s(%a) = out: %d / exp: %d@." - op.name - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.pp_print_string fmt ", ") - Format.pp_print_int) - vs - out - exp - ); - assert false - end - in - - Progress.with_reporter bar (fun f -> - Iter.iter - (fun vs -> test vs; f 1) - (product vs) - ) - -(* -------------------------------------------------------------------- *) -let test_uextend () = - let op (isize : int) (osize : int) : op = - { name = (Format.sprintf "uextend<%d,%d>" isize osize) - ; args = [(isize, `U)] - ; out = `U - ; mk = (fun rs -> C.uextend ~size:osize (as_seq1 rs)) - ; reff = (fun vs -> as_seq1 vs) - } - - in test (op 8 16) - -(* -------------------------------------------------------------------- *) -let test_ite () = - let op () : op = - { name = (Format.sprintf "ite") - ; args = [(1, `U)] - ; out = `U - ; mk = (fun rs -> C.ite ((as_seq1 rs).(0)) [|C.true_|] [|C.false_|]) - ; reff = (fun vs -> as_seq1 vs) - } - - in test (op ()) - -(* -------------------------------------------------------------------- *) -let test_sextend () = - let op (isize : int) (osize : int) : op = - { name = (Format.sprintf "sextend<%d,%d>" isize osize) - ; args = [(isize, `S)] - ; out = `S - ; mk = (fun rs -> C.sextend ~size:osize (as_seq1 rs)) - ; reff = (fun vs -> as_seq1 vs) - } - - in test (op 8 16) - -(* -------------------------------------------------------------------- *) -let test_shift ~(side : [`L | `R]) ~(sign : [`U | `S]) = - let str_side = match side with `L -> "left" | `R -> "right" in - let str_sign = match sign with `U -> "u" | `S -> "s" in - - let op (size : int) : op = - let module M = (val Word.word ~sign ~size) in - - let sim (v : int) (i : int) = - M.to_int (match side with - | `L -> M.shiftl (M.of_int v) i - | `R -> M.shiftr (M.of_int v) i - ) - in - - let asign = match sign with `U -> `L | `S -> `A in - - { name = (Format.sprintf "shift<%s,%s,%d>" str_side str_sign size) - ; args = [(size, sign); (4, `U)] - ; out = sign - ; mk = (fun rs -> let x, y = as_seq2 rs in C.shift ~side ~sign:asign x y) - ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) - } - - in - - for i = 1 to 14 do - test (op i) - done - -(* -------------------------------------------------------------------- *) -let test_rot ~(side : [`L | `R]) = - let str_side = match side with `L -> "left" | `R -> "right" in - - let op (size : int) : op = - let module M = (val Word.word ~sign:`U ~size) in - - let sim (v : int) (i : int) = - let i = i mod size in - let m = (1 lsl size) - 1 in - let v = v land m in - match side with - | `L -> ((v lsl i) lor (v lsr (size - i))) land m - | `R -> ((v lsr i) lor (v lsl (size - i))) land m - in - - { name = (Format.sprintf "rot<%s,%d>" str_side size) - ; args = [(size, `U); (4, `U)] - ; out = `U - ; mk = (fun rs -> let x, y = as_seq2 rs in match side with - | `L -> C.rol x y - | `R -> C.ror x y - ) - ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) - } - - in - - for i = 1 to 14 do - test (op i) - done - -(* -------------------------------------------------------------------- *) -let test_opp () = - let op (size : int) : op = - let module M = (val Word.sword ~size) in - - let sim (x : int) : int = - M.to_int (M.neg (M.of_int x)) in - - { name = (Format.sprintf "opp<%d>" size) - ; args = [(size, `S)] - ; out = `S - ; mk = (fun rs -> C.opp (as_seq1 rs)) - ; reff = (fun vs -> sim (as_seq1 vs)) - } - - in test (op 13) - -(* -------------------------------------------------------------------- *) -let test_add () = - let op (size : int) : op = - let module M = (val Word.sword ~size) in - - let sim (x : int) (y : int) : int = - M.to_int (M.add (M.of_int x) (M.of_int y)) in - - { name = (Format.sprintf "add<%d>" size) - ; args = List.make 2 (size, `S) - ; out = `S - ; mk = (fun rs -> let x, y = as_seq2 rs in C.add_dropc x y) - ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) - } - - in test (op 9) - -(* -------------------------------------------------------------------- *) -let test_incr () = - let op (size : int) : op = - let module M = (val Word.uword ~size) in - - let sim (x : int) : int = - M.to_int (M.add (M.of_int x) M.one) in - - { name = (Format.sprintf "incr<%d>" size) - ; args = [(size, `U)] - ; out = `U - ; mk = (fun rs -> C.incr_dropc (as_seq1 rs)) - ; reff = (fun vs -> sim (as_seq1 vs)); - } - - in test (op 11) - -(* -------------------------------------------------------------------- *) -let test_sub () = - let op (size : int) : op = - let module M = (val Word.sword ~size) in - - let sim (x : int) (y : int) : int = - M.to_int (M.sub (M.of_int x) (M.of_int y)) in - - { name = (Format.sprintf "sub<%d>" size) - ; args = List.make 2 (size, `S) - ; out = `S - ; mk = (fun rs -> let x, y = as_seq2 rs in C.sub_dropc x y) - ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) - } - - in test (op 9) - -(* -------------------------------------------------------------------- *) -let test_umul () = - let op (sz1 : int) (sz2 : int) : op = { - name = (Format.sprintf "umul<%d,%d>" sz1 sz2); - args = [(sz1, `U); (sz2, `U)]; - out = `U; - mk = (fun rs -> let x, y = as_seq2 rs in C.umul x y); - reff = (fun vs -> let x, y = as_seq2 vs in (x * y)); - } in - - test (op 10 8) - -(* -------------------------------------------------------------------- *) -let test_smul () = - let op (sz1 : int) (sz2 : int) : op = { - name = (Format.sprintf "smul<%d,%d>" sz1 sz2); - args = [(sz1, `S); (sz2, `S)]; - out = `S; - mk = (fun rs -> let x, y = as_seq2 rs in C.smul x y); - reff = (fun vs -> let x, y = as_seq2 vs in (x * y)); - } in - - test (op 10 8) - -(* -------------------------------------------------------------------- *) -let test_smul_u8_s8 () = - let op () : op = { - name = "smul_u8_s8"; - args = [(8, `U); (8, `S)]; - out = `S; - mk = (fun rs -> - let x, y = as_seq2 rs in - C.smul - (C.uextend ~size:16 x) - (C.sextend ~size:16 y)); - reff = (fun vs -> let x, y = as_seq2 vs in (x * y)); - } in - - test (op ()) - -(* -------------------------------------------------------------------- *) -let test_udiv () = - let op (size : int) : op = - let sim (x : int) (y : int) : int = - if y = 0 then x else x / y - in - - { name = (Format.sprintf "udiv<%d>" size) - ; args = List.make 2 (size, `U) - ; out = `U - ; mk = (fun rs -> let x, y = as_seq2 rs in C.udiv x y) - ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) - } - - in - test (op 4); - test (op 9) - -(* -------------------------------------------------------------------- *) -let test_umod () = - let op (size : int) : op = - let sim (x : int) (y : int) : int = - if y = 0 then 0 else x mod y - in - - { name = (Format.sprintf "umod<%d>" size) - ; args = List.make 2 (size, `U) - ; out = `U - ; mk = (fun rs -> let x, y = as_seq2 rs in C.umod x y) - ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) - } - - in - test (op 4); - test (op 9) - -(* -------------------------------------------------------------------- *) -let test_sdiv () = - let op (size : int) : op = - let module M = (val Word.sword ~size) in - - let sim (x : int) (y : int) : int = - if y = 0 then x else M.to_int (M.div (M.of_int x) (M.of_int y)) - in - - { name = (Format.sprintf "sdiv<%d>" size) - ; args = List.make 2 (size, `S) - ; out = `S - ; mk = (fun rs -> let x, y = as_seq2 rs in C.sdiv x y) - ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) - } - - in - test (op 4); - test (op 9) - -(* -------------------------------------------------------------------- *) -let test_ssat () = - let op (isize : int) (osize: int) : op = - let saturate = - let vm, vM = srange_ osize in - fun (i : int) -> min vM (max vm i) - in - - { name = (Format.sprintf "ssat<%d,%d>" isize osize); - args = [(isize, `S)]; - out = `S; - mk = (fun rs -> C.sat ~signed:true ~size:osize (as_seq1 rs)); - reff = (fun vs -> saturate (as_seq1 vs)); } in - - test (op 10 4); - test (op 15 7); - test (op 17 16) - -(* -------------------------------------------------------------------- *) -let test_usat () = - let op (isize : int) (osize: int) : op = - let saturate = - let vm, vM = urange_ osize in - fun (i : int) -> min vM (max vm i) - in - - { name = (Format.sprintf "usat<%d,%d>" isize osize); - args = [(isize, `S)]; - out = `U; - mk = (fun rs -> C.sat ~signed:false ~size:osize (as_seq1 rs)); - reff = (fun vs -> saturate (as_seq1 vs)); } in - - test (op 10 4); - test (op 15 7) - -(* -------------------------------------------------------------------- *) -let test_sgt () = - let op (size : int) = - { name = Format.sprintf "sgt<%d>" size; - args = [(size, `S); (size, `S)]; - out = `U; - mk = (fun rs -> let x, y = as_seq2 rs in [|C.sgt x y|]); - reff = (fun vs -> let x, y = as_seq2 vs in if x > y then 1 else 0); } - - in - test (op 10) - -(* -------------------------------------------------------------------- *) -let test_sge () = - let op (size : int) = - { name = Format.sprintf "sge<%d>" size; - args = [(size, `S); (size, `S)]; - out = `U; - mk = (fun rs -> let x, y = as_seq2 rs in [|C.sge x y|]); - reff = (fun vs -> let x, y = as_seq2 vs in if x >= y then 1 else 0); } - - in - test (op 10) - -(* -------------------------------------------------------------------- *) -let test_ugt () = - let op (size : int) = - { name = Format.sprintf "ugt<%d>" size; - args = [(size, `U); (size, `U)]; - out = `U; - mk = (fun rs -> let x, y = as_seq2 rs in [|C.ugt x y|]); - reff = (fun vs -> let x, y = as_seq2 vs in if x > y then 1 else 0); } - - in - test (op 10) - -(* -------------------------------------------------------------------- *) -let test_uge () = - let op (size : int) = - { name = Format.sprintf "uge<%d>" size; - args = [(size, `U); (size, `U)]; - out = `U; - mk = (fun rs -> let x, y = as_seq2 rs in [|C.uge x y|]); - reff = (fun vs -> let x, y = as_seq2 vs in if x >= y then 1 else 0); } - - in - test (op 10) - -(* -------------------------------------------------------------------- *) -let test_popcount () = - let op (size : int) = - { name = Format.sprintf "popcount<%d>" size; - args = [(size, `U)]; - out = `U; - mk = (fun rs -> let x = as_seq1 rs in C.popcount ~size x); - reff = (fun vs -> let x = as_seq1 vs in Z.popcount (Z.of_int x)); } - - in - test (op 16) - -(* -------------------------------------------------------------------- *) -type mvalue = M256 of Avx2.m256 | M128 of Avx2.m128 - -module MValue : sig - type kind = [`M256 | `M128] - - val random : kind -> mvalue - - val to_bytes : endianess:Avx2.endianess -> mvalue -> bytes - - val of_bytes : endianess:Avx2.endianess -> bytes -> mvalue - - val pp : - endianess:Avx2.endianess -> - size:Avx2.size -> - Format.formatter -> - mvalue -> - unit -end = struct - type kind = [`M256 | `M128] - - let random (k : kind) = - match k with - | `M256 -> M256 (Avx2.M256.random ()) - | `M128 -> M128 (Avx2.M128.random ()) - - let to_bytes ~(endianess : Avx2.endianess) (m : mvalue) = - match m with - | M256 v -> Avx2.M256.to_bytes ~endianess:`Little v - | M128 v -> Avx2.M128.to_bytes ~endianess:`Little v - - let of_bytes ~(endianess : Avx2.endianess) (m : bytes) = - match Bytes.length m with - | 32 -> M256 (Avx2.M256.of_bytes ~endianess m) - | 16 -> M128 (Avx2.M128.of_bytes ~endianess m) - | _ -> assert false - - let pp - ~(endianess : Avx2.endianess) - ~(size : Avx2.size) - (fmt : Format.formatter) - (m : mvalue) - = - match m with - | M256 v -> Avx2.M256.pp ~endianess ~size fmt v - | M128 v -> Avx2.M128.pp ~endianess ~size fmt v -end - -(* -------------------------------------------------------------------- *) -type vpop = { - name : string; - args : MValue.kind list; - mk : C.reg list -> C.reg; - reff : mvalue list -> mvalue; -} - -(* -------------------------------------------------------------------- *) -let call_m256_m256 - (f : Avx2.m256 -> Avx2.m256) - (vs : mvalue list) - : mvalue -= - match vs with - | [M256 v] -> M256 (f v) - | _ -> assert false - -(* -------------------------------------------------------------------- *) -let call_m256_m128 - (f : Avx2.m256 -> Avx2.m128) - (vs : mvalue list) - : mvalue -= - match vs with - | [M256 v] -> M128 (f v) - | _ -> assert false - -(* -------------------------------------------------------------------- *) -let call_m256_m128_m256 - (f : Avx2.m256 -> Avx2.m128 -> Avx2.m256) - (vs : mvalue list) - : mvalue -= - match vs with - | [M256 v1; M128 v2] -> M256 (f v1 v2) - | _ -> assert false - -(* -------------------------------------------------------------------- *) -let call_m256x2_m256 - (f : Avx2.m256 -> Avx2.m256 -> Avx2.m256) - (vs : mvalue list) - : mvalue -= - match vs with - | [M256 v1; M256 v2] -> M256 (f v1 v2) - | _ -> assert false - -(* -------------------------------------------------------------------- *) -let test_vp (total : int) (op : vpop) = - let rs = op.args |> List.mapi (fun i arg -> - match arg with - | `M256 -> C.reg ~size:256 ~name:i - | `M128 -> C.reg ~size:128 ~name:i - ) in - - let circuit = op.mk rs in - - let test () = - let vs = List.map MValue.random op.args in - let avs = Array.of_list vs in - let avs = Array.map (MValue.to_bytes ~endianess:`Little) avs in - - let env ((n, i) : C.var) = C.get_bit avs.(n) i in - - let o = - match op.reff vs with - | M256 v -> Avx2.M256.to_bytes ~endianess:`Little v - | M128 v -> Avx2.M128.to_bytes ~endianess:`Little v - in - - let o' = Array.map (C.eval env) circuit in - let o' = C.bytes_of_bools o' in - - if o <> o' then begin - Progress.interject_with (fun () -> - vs |> List.iter (fun v -> - Format.eprintf "%a@." - (MValue.pp ~endianess:`Big ~size:`U32) - v - ); - Format.eprintf "%a@." - (MValue.pp ~endianess:`Big ~size:`U32) - (MValue.of_bytes ~endianess:`Little o); - Format.eprintf "%a@." - (MValue.pp ~endianess:`Big ~size:`U32) - (MValue.of_bytes ~endianess:`Little o') - ); - assert false - end - in - - Progress.with_reporter (bar op.name total) (fun f -> - Iter.iter - (fun _ -> test (); f 1) - (Iter.(--) 0 (total-1)) - ) - -(* -------------------------------------------------------------------- *) -let test_vpadd_16u16 () = - let op = { - name = "vpadd_16u16"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpadd_16u16 x y); - reff = call_m256x2_m256 Avx2.mm256_add_epi16; - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vpadd_32u8 () = - let op = { - name = "vpadd_32u8"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpadd_32u8 x y); - reff = call_m256x2_m256 Avx2.mm256_add_epi8; - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vpsub_16u16 () = - let op = { - name = "vpsub_16u16"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpsub_16u16 x y); - reff = call_m256x2_m256 Avx2.mm256_sub_epi16; - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vpsub_32u8 () = - let op = { - name = "vpsub_32u8"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpsub_32u8 x y); - reff = call_m256x2_m256 Avx2.mm256_sub_epi8; - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vpsra_16u16 () = - let op (offset : int) = { - name = Format.sprintf "vpsra_16u16<%d>" offset; - args = [`M256]; - mk = (fun rs -> C.vpsra_16u16 (as_seq1 rs) offset); - reff = call_m256_m256 (fun x -> Avx2.mm256_srai_epi16 x offset); - } in - - Iter.iter (fun i -> test_vp 10000 (op i)) (Iter.(--) 0x00 0x10) - -(* -------------------------------------------------------------------- *) -let test_vpsrl_16u16 () = - let op (offset : int) = { - name = Format.sprintf "vpsrl_16u16<%d>" offset; - args = [`M256]; - mk = (fun rs -> C.vpsrl_16u16 (as_seq1 rs) offset); - reff = call_m256_m256 (fun x -> Avx2.mm256_srli_epi16 x offset); - } in - - Iter.iter (fun i -> test_vp 10000 (op i)) (Iter.(--) 0x00 0x10) - -(* -------------------------------------------------------------------- *) -let test_vpand_256 () = - let op = { - name = "vpand_256"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpand_256 x y); - reff = call_m256x2_m256 Avx2.mm256_and_si256; - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vpmulh_16u16 () = - let op = { - name = "vpmulh_16u16"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpmulh_16u16 x y); - reff = call_m256x2_m256 Avx2.mm256_mulhi_epi16; - } in - - test_vp 200 op - -(* -------------------------------------------------------------------- *) -let test_vpmulhu_16u16 () = - let op = { - name = "vpmulhu_16u16"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpmulhu_16u16 x y); - reff = call_m256x2_m256 Avx2.mm256_mulhi_epu16; - } in - - test_vp 200 op - -(* -------------------------------------------------------------------- *) -let test_vpmulhrs_16u16 () = - let op = { - name = "vpmulhrs_16u16"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpmulhrs_16u16 x y); - reff = call_m256x2_m256 Avx2.mm256_mulhrs_epi16; - } in - - test_vp 200 op - -(* -------------------------------------------------------------------- *) -let test_vpackus_16u16 () = - let op = { - name = "vpackus_16u16"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpackus_16u16 x y); - reff = call_m256x2_m256 Avx2.mm256_packus_epi16; - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vpackss_16u16 () = - let op = { - name = "vpackss_16u16"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpackss_16u16 x y); - reff = call_m256x2_m256 Avx2.mm256_packs_epi16; - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vpmaddubsw_256 () = - let op = { - name = "vpmaddubsw_256"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpmaddubsw_256 x y); - reff = call_m256x2_m256 Avx2.mm256_maddubs_epi16; - } in - - test_vp 200 op - -(* -------------------------------------------------------------------- *) -let test_vpermd () = - let op = { - name = "vpermd"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpermd x y); - reff = call_m256x2_m256 (fun x y -> Avx2.mm256_permutevar8x32_epi32 y x); - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vpermq () = - let op (imm8 : int) = { - name = Format.sprintf "vpermq<%d>" imm8; - args = [`M256]; - mk = (fun rs -> C.vpermq (as_seq1 rs) imm8); - reff = call_m256_m256 (fun x -> Avx2.mm256_permute4x64_epi64 x imm8); - } in - - test_vp 10000 (op 0x23); - test_vp 10000 (op 0xf7) - -(* -------------------------------------------------------------------- *) -let test_vbshufb_256 () = - let op = { - name = "vbshufb_256"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpshufb_256 x y); - reff = call_m256x2_m256 Avx2.mm256_shuffle_epi8; - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vpcmpgt_16u16 () = - let op = { - name = "vpcmpgt_16u16"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpcmpgt_16u16 x y); - reff = call_m256x2_m256 Avx2.mm256_cmpgt_epi16; - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vpmovmskb_u256u64 () = - let op = { - name = "vpmovmskb_u256u64"; - args = [`M256]; - mk = (fun rs -> C.uextend ~size:256 (C.vpmovmskb_u256u64 (as_seq1 rs))); - reff = (fun vs -> - match vs with - | [M256 v] -> - let out = Avx2.mm256_movemask_epi8 v in - let out = Int64.logand (Int64.of_int32 out) 0xffffffffL in - M256 (Avx2.M256.oftuple_64 (out, 0L, 0L, 0L)) - | _ -> - assert false - ) - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vpunpckl_32u8 () = - let op = { - name = "test_vpunpckl_32u8"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpunpckl_32u8 x y); - reff = call_m256x2_m256 Avx2.mm256_unpacklo_epi8; - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vpunpckl_4u64 () = - let op = { - name = "test_vpunpckl_4u64"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpunpckl_4u64 x y); - reff = call_m256x2_m256 Avx2.mm256_unpacklo_epi64; - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vpunpckh_4u64 () = - let op = { - name = "test_vpunpckh_4u64"; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpunpckh_4u64 x y); - reff = call_m256x2_m256 Avx2.mm256_unpackhi_epi64; - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vmovsldup_256 () = - let op = { - name = "test_vmovsldup_256"; - args = List.make 1 `M256; - mk = (fun rs -> let x = as_seq1 rs in C.vmovsldup_256 x); - reff = call_m256_m256 Avx2.mm256_moveldup_ps; - } in - - test_vp 10000 op - -(* -------------------------------------------------------------------- *) -let test_vpblend_16u16 () = - let op (imm8 : int) = { - name = Format.sprintf "test_vpblend_16u16<%d>" imm8; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpblend_16u16 x y imm8); - reff = call_m256x2_m256 (fun x y -> Avx2.mm256_blend_epi16 x y imm8); - } in - - test_vp 10000 (op 0x00); - test_vp 10000 (op 0x3f); - test_vp 10000 (op 0xaa) - -(* -------------------------------------------------------------------- *) -let test_vpblend_8u32 () = - let op (imm8 : int) = { - name = Format.sprintf "test_vpblend_8u32<%d>" imm8; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpblend_8u32 x y imm8); - reff = call_m256x2_m256 (fun x y -> Avx2.mm256_blend_epi32 x y imm8); - } in - - test_vp 10000 (op 0xaa) - - (* -------------------------------------------------------------------- *) -let test_vperm2i128 () = - let op (imm8 : int) = { - name = Format.sprintf "test_vperm2i128<%d>" imm8; - args = List.make 2 `M256; - mk = (fun rs -> let x, y = as_seq2 rs in C.vperm2i128 x y imm8); - reff = call_m256x2_m256 (fun x y -> Avx2.mm256_permute2x128_si256 x y imm8); - } in - - test_vp 10000 (op 32); - test_vp 10000 (op 49) - -(* -------------------------------------------------------------------- *) -let test_extracti128 () = - let op (i : int) = { - name = Format.sprintf "test_extracti128<%d>" i; - args = [`M256]; - mk = (fun rs -> C.vpextracti128 (as_seq1 rs) i); - reff = call_m256_m128 (fun x -> Avx2.mm256_extracti128_si256 x i); - } in - - test_vp 10000 (op 0); - test_vp 10000 (op 1) - -(* -------------------------------------------------------------------- *) -let test_inserti128 () = - let op (i : int) = { - name = Format.sprintf "test_inserti128<%d>" i; - args = [`M256; `M128]; - mk = (fun rs -> let x, y = as_seq2 rs in C.vpinserti128 x y i); - reff = call_m256_m128_m256 (fun x y -> Avx2.mm256_inserti128_si256 x y i); - } in - - test_vp 10000 (op 0); - test_vp 10000 (op 1) - -(* -------------------------------------------------------------------- *) -let test_bvueq () = - let op (size : int) : op = - let module M = (val Word.sword ~size) in - - let sim (x : int) (y : int) : int = - if x = y then 1 else 0 - in - - { name = (Format.sprintf "bvueq<%d>" size) - ; args = List.make 2 (size, `U) - ; out = `U - ; mk = (fun rs -> let x, y = as_seq2 rs in [|C.bvueq x y|]) - ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) - } - - in test (op 9) - -(* -------------------------------------------------------------------- *) -let test_bvseq () = - let op (size : int) : op = - let module M = (val Word.sword ~size) in - - let sim (x : int) (y : int) : int = - if x = y then 1 else 0 - in - - { name = (Format.sprintf "bvseq<%d>" size) - ; args = List.make 2 (size, `S) - ; out = `U - ; mk = (fun rs -> let x, y = as_seq2 rs in [|C.bvseq x y|]) - ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) - } - - in test (op 9) - -(* -------------------------------------------------------------------- *) -let test_mod () = - let op (size : int) : op = - let module M = (val Word.uword ~size) in - - let sim (x : int) (y : int) : int = - M.to_int @@ M.mod_ (M.of_int x) (M.of_int y) - in - - { name = (Format.sprintf "mod<%d>" size) - ; args = List.make 2 (size, `U) - ; out = `U - ; mk = (fun rs -> let x, y = as_seq2 rs in C.umod x y) - ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) - } - - in test (op 9) - -(* -------------------------------------------------------------------- *) -let test_smod () = - let op (size : int) : op = - let module M = (val Word.sword ~size) in - - let sim (x : int) (y : int) : int = - M.to_int @@ M.mod_ (M.of_int x) (M.of_int y) - in - - { name = (Format.sprintf "smod<%d>" size) - ; args = List.make 2 (size, `S) - ; out = `S - ; mk = (fun rs -> let x, y = as_seq2 rs in C.smod x y) - ; reff = (fun vs -> let x, y = as_seq2 vs in sim x y) - } - - in - for i = 1 to 9 do - test (op i) - done - -(* -------------------------------------------------------------------- *) -let tests = [ -(* - ("opp" , test_opp ); - ("incr", test_incr); - ("add" , test_add ); - ("sub" , test_sub ); - ("umul", test_umul); - ("smul", test_smul); - ("ssat", test_ssat); - ("usat", test_usat); - - ("sgt", test_sgt); - ("sge", test_sge); - - ("ugt", test_ugt); - ("uge", test_uge); - - ("lsl", (fun () -> test_shift ~side:`L ~sign:`U)); - ("lsr", (fun () -> test_shift ~side:`R ~sign:`U)); - ("rol", (fun () -> test_rot ~side:`L)); - ("ror", (fun () -> test_rot ~side:`R)); - - ("asl", (fun () -> test_shift ~side:`L ~sign:`S)); - ("asr", (fun () -> test_shift ~side:`R ~sign:`S)); - - ("smul_u8_s8", test_smul_u8_s8); - - ("uextend", test_uextend); - ("sextend", test_sextend); - - ("ite", test_ite); - - ("udiv", test_udiv); - ("sdiv", test_sdiv); - - ("umod", test_umod); - ("smod", test_smod); - - ("bvueq", test_bvueq); - ("bvseq", test_bvseq); - - ("popcount", test_popcount); -*) - ("vpadd_16u16" , test_vpadd_16u16 ); - ("vpadd_32u8" , test_vpadd_32u8 ); - ("vpsub_16u16" , test_vpsub_16u16 ); - ("vpsub_32u8" , test_vpsub_32u8 ); - ("vmovsldup_256" , test_vmovsldup_256 ); - ("vpblend_8u32" , test_vpblend_8u32 ); - ("vpunpckh_4u64" , test_vpunpckh_4u64 ); - ("vpunpckl_4u64" , test_vpunpckl_4u64 ); - ("vperm2i128" , test_vperm2i128 ); - ("vpsra_16u16" , test_vpsra_16u16 ); - ("vpsrl_16u16" , test_vpsrl_16u16 ); - ("vpand_256" , test_vpand_256 ); - ("vpmulh_16u16" , test_vpmulh_16u16 ); - ("vpmulhu_16u16" , test_vpmulhu_16u16 ); - ("vpmulhrs_16u16" , test_vpmulhrs_16u16 ); - ("vpackus_16u16" , test_vpackus_16u16 ); - ("vpackss_16u16" , test_vpackss_16u16 ); - ("vpmaddubsw_256" , test_vpmaddubsw_256 ); - ("vpermd" , test_vpermd ); - ("vpermq" , test_vpermq ); - ("vbshufb_256" , test_vbshufb_256 ); - ("vpcmpgt_16u16" , test_vpcmpgt_16u16 ); - ("vpmovmskb_u256u64", test_vpmovmskb_u256u64); - ("vpunpckl_32u8" , test_vpunpckl_32u8 ); - ("vpblend_16u16" , test_vpblend_16u16 ); - ("vpextracti128" , test_extracti128 ); - ("vpinserti128" , test_inserti128 ); -] - -(* -------------------------------------------------------------------- *) -let main () = - let tests = - let n = Array.length Sys.argv in - if n <= 1 then - List.map snd tests - else - let names = Array.sub Sys.argv 1 (n - 1) in - let names = Set.of_array names in - let tests = List.filter (fun (x, _) -> Set.mem x names) tests in - List.map snd tests in - - Random.self_init (); - - List.iter (fun f -> f ()) tests - -(* -------------------------------------------------------------------- *) -let () = main () diff --git a/libs/lospecs/tests/simde b/libs/lospecs/tests/simde deleted file mode 160000 index 0efee69e5c..0000000000 --- a/libs/lospecs/tests/simde +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 0efee69e5c16185cad512aefe503b812167e15fe diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 2a2ad36563..86b0278372 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -30,8 +30,6 @@ let circ_red (hyps: hyps) = let base_red = EcReduction.full_red in (* FIXME: should change to a decent direct hash of this + store the forms *) (* also move the cache here? *) module AInvFHash = struct - type t = form - let known_hashes : (int, int) Map.t ref = ref Map.empty let clean_known : unit -> unit = @@ -159,8 +157,6 @@ module AInvFHash = struct end (* -------------------------------------------------------------------- *) -type width = int - type circuit_conversion_call = [ | `Convert of form | `ToArg of form @@ -552,7 +548,7 @@ let rec form_list_of_form ?(env: env option) (f: form) : form list = h::(form_list_of_form t) | _ -> Option.may (fun env -> - EcEnv.notify env EcGState.(`Debug) "Failed to destructure claimed list: %a@." (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv env)) f) env; + EcEnv.notify env `Debug "Failed to destructure claimed list: %a@." (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv env)) f) env; raise (DestrError "list") let form_is_iter (f: form) : bool = @@ -576,9 +572,9 @@ let expand_iter_form (hyps: hyps) (f: form) : form = | Fapp ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iteri -> let rep = int_of_form hyps rep in let is = List.init (BI.to_int rep) BI.of_int in - EcEnv.notify env EcGState.(`Debug) "Done generating functions!@."; + EcEnv.notify env `Debug "Done generating functions!@."; let f = List.fold_left (fun f i -> - EcEnv.notify env EcGState.(`Debug) "Expanding iter... Step #%d@.Form: %a@." (BI.to_int i) + EcEnv.notify env `Debug "Expanding iter... Step #%d@.Form: %a@." (BI.to_int i) (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (toenv hyps))) f ; fn @!! [f_int i; f] @@ -596,11 +592,11 @@ let expand_iter_form (hyps: hyps) (f: form) : form = f | _ -> raise (DestrError "iter") in - EcEnv.notify env EcGState.(`Debug) "Expanded iter form: @.%a@." EcPrinting.(pp_form ppenv) res; + EcEnv.notify env `Debug "Expanded iter form: @.%a@." EcPrinting.(pp_form ppenv) res; res let circuit_of_form - ?(st : state = empty_state) (* Program variable values *) + (st : state) (* Program variable values *) (hyps : hyps) (f_ : EcAst.form) : circuit = @@ -676,7 +672,7 @@ let circuit_of_form | Fop (pth, _) -> begin if pth = EcCoreLib.CI_Witness.p_witness then - (EcEnv.notify env EcGState.(`Debug) "Assigning witness to var of type %a@." + (EcEnv.notify env `Debug "Assigning witness to var of type %a@." EcPrinting.(pp_type ppe) f_.f_ty; circuit_uninit env (f_.f_ty)) else @@ -820,7 +816,7 @@ let circuit_of_form let v = match state_get_pv_opt st mem v with | Some v -> v | None -> - EcEnv.notify env EcGState.(`Debug) "Assigning unassigned program variable %a of type %a@." EcPrinting.(pp_pv ppe) pv EcPrinting.(pp_type ppe) f_.f_ty; + EcEnv.notify env `Debug "Assigning unassigned program variable %a of type %a@." EcPrinting.(pp_pv ppe) pv EcPrinting.(pp_type ppe) f_.f_ty; circuit_uninit env f_.f_ty (* Allow uninitialized program variables *) in v @@ -863,7 +859,7 @@ let circuit_of_form fapply_safe fn [f_int (BI.of_int i)] ) in List.fold_lefti (fun f i fn -> - EcEnv.notify env EcGState.(`Debug) "Translating iteri... Step #%d@." i; + EcEnv.notify env `Debug "Translating iteri... Step #%d@." i; let fn = doit st fn in circuit_compose fn [f] ) (doit st base) fs @@ -891,10 +887,10 @@ let circuit_simplify_equality ?(do_time = true) ~(st: state) ~(hyps: hyps) ~(pre t := new_t in - EcEnv.notify env EcGState.(`Debug) "Filletting circuit...@."; - let c1 = circuit_of_form ~st hyps f1 |> state_close_circuit st in + EcEnv.notify env `Debug "Filletting circuit...@."; + let c1 = circuit_of_form st hyps f1 |> state_close_circuit st in if do_time then time env tm "Left side circuit generation done"; - let c2 = circuit_of_form ~st hyps f2 |> state_close_circuit st in + let c2 = circuit_of_form st hyps f2 |> state_close_circuit st in if do_time then time env tm "Right side circuit generation done"; let pres = List.map (state_close_circuit st) pres in (* Assumes pres come open *) @@ -903,9 +899,9 @@ let circuit_simplify_equality ?(do_time = true) ~(st: state) ~(hyps: hyps) ~(pre let posts = circuit_eqs c1 c2 in if do_time then time env tm "Done with postcondition circuit generation"; - EcEnv.notify env EcGState.(`Debug) "Number of checks before batching: %d@." (List.length posts); + EcEnv.notify env `Debug "Number of checks before batching: %d@." (List.length posts); let posts = batch_checks ~mode:`BySub posts in - EcEnv.notify env EcGState.(`Debug) "Number of checks after batching: %d@." (List.length posts); + EcEnv.notify env `Debug "Number of checks after batching: %d@." (List.length posts); if do_time then time env tm "Done with lane compression"; if fillet_tauts pres posts then begin @@ -919,13 +915,13 @@ let circuit_simplify_equality ?(do_time = true) ~(st: state) ~(hyps: hyps) ~(pre end (* FIXME: add support for spec bindings for abstract/opaque operators *) -let circuit_of_path (hyps: hyps) (p: path) : circuit = +let circuit_of_path (st: state) (hyps: hyps) (p: path) : circuit = let f = EcEnv.Op.by_path p (toenv hyps) in let f = match f.op_kind with | OB_oper (Some (OP_Plain f)) -> f | _ -> circ_error (MissingOpBody p) in - circuit_of_form hyps f + circuit_of_form st hyps f let vars_of_memtype (mt : memtype) = let Lmt_concrete lmt = mt in @@ -937,22 +933,22 @@ let vars_of_memtype (mt : memtype) = let process_instr (hyps: hyps) (mem: memory) ~(st: state) (inst: instr) : state = -(* EcEnv.notify env EcGState.(`Debug) "[W] Processing : %a@." (EcPrinting.pp_instr (EcPrinting.PPEnv.ofenv env)) inst; *) +(* EcEnv.notify env `Debug "[W] Processing : %a@." (EcPrinting.pp_instr (EcPrinting.PPEnv.ofenv env)) inst; *) (* let start = Unix.gettimeofday () in *) try match inst.i_node with | Sasgn (LvVar (PVloc v, _ty), e) -> (* - EcEnv.notify env EcGState.(`Debug) "Assigning form %a to var %s@\n" + EcEnv.notify env `Debug "Assigning form %a to var %s@\n" (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (LDecl.toenv hyps))) (form_of_expr mem e) v; *) - let c = ((ss_inv_of_expr mem e).inv |> circuit_of_form ~st hyps) in + let c = ((ss_inv_of_expr mem e).inv |> circuit_of_form st hyps) in let st = update_state_pv st mem v c in st - (* EcEnv.notify env EcGState.(`Debug) "[W] Took %f seconds@." (Unix.gettimeofday() -. start); *) + (* EcEnv.notify env `Debug "[W] Took %f seconds@." (Unix.gettimeofday() -. start); *) | Sasgn (LvTuple (vs), {e_node = Etuple es; _}) when List.compare_lengths vs es = 0 -> let st = List.fold_left (fun st (v, e) -> - let c = ((ss_inv_of_expr mem e).inv |> circuit_of_form ~st hyps) in + let c = ((ss_inv_of_expr mem e).inv |> circuit_of_form st hyps) in let st = update_state_pv st mem v c in st ) st @@ -963,7 +959,7 @@ let process_instr (hyps: hyps) (mem: memory) ~(st: state) (inst: instr) : state es) in st | Sasgn (LvTuple (vs), e) -> - let tp = ((ss_inv_of_expr mem e).inv |> circuit_of_form ~st hyps) in + let tp = ((ss_inv_of_expr mem e).inv |> circuit_of_form st hyps) in let comps = circuits_of_circuit_tuple tp in let st = List.fold_left2 (fun st (pv, _ty) c -> let v = match pv with @@ -985,7 +981,7 @@ let instrs_equiv (hyps : hyps ) ((mem, _mt) : memenv ) ?(keep : EcPV.PV.t option ) - ?(st : state = empty_state ) + (st : state ) (s1 : instr list ) (s2 : instr list ) : bool = @@ -1113,7 +1109,7 @@ let circuit_state_of_hyps ?(strict = false) ?(use_mem = false) ?(st = empty_stat let env = toenv hyps in let ppe = EcPrinting.PPEnv.ofenv env in let st = List.fold_left (fun st (id, lk) -> - EcEnv.notify env EcGState.(`Debug) "Processing hyp: %s@." (id.id_symb); + EcEnv.notify env `Debug "Processing hyp: %s@." (id.id_symb); match lk with (* FIXME: Reasoning here is that we do not directly process program variables in the hyps They are either given a value by assignment in the program or if they are used @@ -1128,12 +1124,12 @@ let circuit_state_of_hyps ?(strict = false) ?(use_mem = false) ?(st = empty_stat Check if body is convertible to circuit, if not just process it as uninitialized. TODO: Maybe do a first pass on this, check convertibility and remove duplicates? *) | EcBaseLogic.LD_var (t, Some f) -> - EcEnv.notify env EcGState.(`Debug) "Assigning %a to %a@." EcPrinting.(pp_form ppe) f EcIdent.pp_ident id; + EcEnv.notify env `Debug "Assigning %a to %a@." EcPrinting.(pp_form ppe) f EcIdent.pp_ident id; begin try - update_state st id (circuit_of_form ~st hyps f) + update_state st id (circuit_of_form st hyps f) (* FIXME PR: Should only catch circuit translation errors, hack *) with CircError e -> - EcEnv.notify env EcGState.(`Debug) "Failed to translate hypothesis for var %s with error %a, skipping@." (tostring_internal id) (pp_circ_error ppe) e; + EcEnv.notify env `Debug "Failed to translate hypothesis for var %s with error %a, skipping@." (tostring_internal id) (pp_circ_error ppe) e; try open_circ_lambda st [(id, ctype_of_ty env t)] (* FIXME PR: Should only catch circuit translation errors, hack *) @@ -1160,15 +1156,15 @@ let circuit_state_of_hyps ?(strict = false) ?(use_mem = false) ?(st = empty_stat | {f_node=Fapp ({f_node = Fop (p, _); _}, [{f_node = Fpvar (PVloc pv, m); _}; fv])} | {f_node=Fapp ({f_node = Fop (p, _); _}, [fv; {f_node = Fpvar (PVloc pv, m); _}])} when EcFol.op_kind p = Some `Eq -> begin try - update_state_pv st m pv (circuit_of_form ~st hyps fv) + update_state_pv st m pv (circuit_of_form st hyps fv) (* FIXME PR: Should only catch circuit translation errors, hack *) with CircError e -> - EcEnv.notify env EcGState.(`Debug) "Failed to translate hypothesis %s => %a@\nWith error: %a@\nSkipping...@\n" + EcEnv.notify env `Debug "Failed to translate hypothesis %s => %a@\nWith error: %a@\nSkipping...@\n" id.id_symb EcPrinting.(pp_form ppe) f (pp_circ_error ppe) e; st end | _ -> - EcEnv.notify env EcGState.(`Debug) "Hypothesis %s: %a does not match any circuit translation patterns, skipping...@\n" + EcEnv.notify env `Debug "Hypothesis %s: %a does not match any circuit translation patterns, skipping...@\n" id.id_symb EcPrinting.(pp_form ppe) f; st end diff --git a/src/ecCircuits.mli b/src/ecCircuits.mli index 7e10a8f45e..8ba1ffa889 100644 --- a/src/ecCircuits.mli +++ b/src/ecCircuits.mli @@ -77,7 +77,7 @@ val circ_taut : circuit -> bool (* Generate circuits *) (* Form processors *) -val circuit_of_form : ?st:state -> hyps -> form -> circuit +val circuit_of_form : state -> hyps -> form -> circuit val circuit_simplify_equality : ?do_time:bool -> st:state -> hyps:hyps -> pres:circuit list -> form -> form -> bool val circ_simplify_form_bitstring_equality : ?st:state -> @@ -85,9 +85,8 @@ val circ_simplify_form_bitstring_equality : (* Proc processors *) val state_of_prog : ?close:bool -> hyps -> memory -> ?st:state -> instr list -> state -val instrs_equiv : hyps -> memenv -> ?keep:EcPV.PV.t -> ?st:state -> instr list -> instr list -> bool +val instrs_equiv : hyps -> memenv -> ?keep:EcPV.PV.t -> state -> instr list -> instr list -> bool val process_instr : hyps -> memory -> st:state -> instr -> state -(* val pstate_of_memtype : ?pstate:pstate -> env -> memtype -> pstate * cinput list *) val circuit_state_of_memenv : st:state -> env -> memenv -> state val circuit_state_of_hyps : ?strict:bool -> ?use_mem:bool -> ?st:state -> hyps -> state diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index aad1c1af43..16e6670aa3 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -206,9 +206,6 @@ let f_append a b ty = f_app (fop_append ty) [a; b] (tlist ty) let f_cons a b ty = f_app (fop_cons ty) [a; b] (tlist ty) let f_flatten a ty = f_app (fop_flatten ty) [a] (tlist ty) let f_lmap f a ty1 ty2 = f_app (fop_lmap ty1 ty2) [f;a] (tlist ty2) -let f_chunk a (n: int) ty2 = - let ty = tfrom_tlist a.f_ty in - f_app (fop_chunk ty) [mk_form (Fint (BI.of_int n)) tint; a] (tlist @@ tlist ty) let f_all f a ty = f_app (fop_all ty) [f; a] tbool (* -------------------------------------------------------------------- *) diff --git a/src/ecCoreFol.mli b/src/ecCoreFol.mli index 1951e169da..78e0816d4b 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -156,7 +156,6 @@ val f_append : form -> form -> ty -> form val f_cons : form -> form -> ty -> form val f_flatten : form -> ty -> form val f_lmap : form -> form -> ty -> ty -> form -val f_chunk : form -> int -> ty -> form val f_all : form -> form -> ty -> form diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index 195d8ac651..1d75637b7a 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -28,7 +28,7 @@ module Hashtbl = Batteries.Hashtbl module Set = Batteries.Set module Option = Batteries.Option -let debug : bool = true +let debug : bool = false (* Backend implementing minimal functions needed for the translation *) (* Minimal expected functionality is QF_ABV *) @@ -518,9 +518,12 @@ module type CircuitInterface = sig val open_circ_lambda_pv : state -> ((memory * symbol) * ctype) list -> state val close_circ_lambda : state -> state val circ_lambda_oneshot : state -> (ident * ctype) list -> (state -> circuit) -> circuit (* FIXME: rename or redo *) + + val set_logger : state -> (string -> unit) -> state end module BVOps : sig + val bvget : circuit -> int -> circuit val circuit_of_bvop : EcDecl.crb_bvoperator -> circuit val circuit_of_parametric_bvop : EcDecl.crb_bvoperator -> arg list -> circuit end @@ -638,9 +641,8 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = | ASliceTy of ctype | SliceSet of { slice_size: int; bitstring_size: int; offset: int } | AGet of { container_size: int; index: int } - | Get of { bitstring_size: int; index: int } | ASet of { container_size: int; index: int } - | Set of { bitstring_size: int; index: int } + | Get of { bitstring_size: int; index: int } | And | Or | Ite @@ -740,12 +742,14 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = circs : circuit Mid.t; lambdas : cinp list list; (* actually a stack *) pv_ids : (ident * symbol, ident) Map.t; (* can be changed to int Msym.t if needed *) + logger : string -> unit; } let empty_state : state = { circs = Mid.empty; lambdas = []; pv_ids = Map.empty; (* can be changed to int Msym.t if needed *) + logger = fun _ -> (); } let update_state_pv (st: state) (m: memory) (s: symbol) (c: circuit) : state = @@ -826,6 +830,9 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let st' = open_circ_lambda st bnds in let (c, inps) = c st' in (c, (List.hd st'.lambdas) @ inps) + + let set_logger (st: state) (logger: string -> unit) : state = + { st with logger; } end (* Inputs helper functions *) @@ -1574,6 +1581,19 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (* { reg = c; CBitstring c, inps) |> convert_type ret_ty *) module BVOps = struct + let bvget (c: circuit) (i: int) : circuit = + match c with + | {reg; type_ = CBitstring n}, inps when 0 <= i && i < n -> + begin try + {reg = Backend.reg_of_node (Backend.get reg i); type_ = CBool}, inps + with Backend.GetOutOfRange -> + lowcircerror (CircConstructorInvalidArguments (Get { + bitstring_size = n; + index = i; + })) + end + | _ -> assert false (* programming error *) + let circuit_of_parametric_bvop (op: EcDecl.crb_bvoperator) (args: arg list) : circuit = match op with | { kind = `ASliceGet (((_, Some _), (_, Some _)), (_, Some m)) } -> @@ -1637,8 +1657,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = end | { kind = `Get (_, Some _) } -> begin match args with - | [ `Circuit ({reg = bs; type_ = CBitstring _}, cinps); `Constant i ] -> - {type_ = CBool; reg = Backend.reg_of_node (Backend.get bs (to_int i))}, cinps + | [ `Circuit c; `Constant i ] -> bvget c (EcBigInt.to_int i) | _ -> assert false (* Should be caught by EC typechecking + binding correctness *) end | { kind = `AInit ((_, Some n), (_, Some w_o)) } -> @@ -1842,25 +1861,32 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = end module ArrayOps = struct - let array_get (({reg = c; type_ = CArray {width=w; count=n}}, inps) : circuit) (i: int) : circuit = - try - { type_ = CBitstring w; reg = (Backend.slice c (i*w) w)}, inps - with Backend.BadSlice `Get -> - lowcircerror @@ CircConstructorInvalidArguments (AGet { - container_size = n; - index = i; - }) - - let array_set (({reg = arr; type_ = CArray {width=w; count=n}}, inps) : circuit) (pos: int) (({reg = bs; type_ = CBitstring w'}, cinps): circuit) : circuit = - try - assert (w = w'); - { type_ = CArray {width=w; count=n}; reg = (Backend.insert arr (pos * w) bs)}, - merge_inputs inps cinps - with Backend.BadSlice `Set -> - lowcircerror @@ CircConstructorInvalidArguments (ASet { - container_size = n; - index = pos; - }) + let array_get (c: circuit) (i: int) : circuit = + match c with + | ({reg = c; type_ = CArray {width=w; count=n}}, inps) -> + begin try + { type_ = CBitstring w; reg = (Backend.slice c (i*w) w)}, inps + with Backend.BadSlice `Get -> + lowcircerror @@ CircConstructorInvalidArguments (AGet { + container_size = n; + index = i; + }) end + | _ -> assert false (* Programming error *) + + let array_set (a: circuit) (pos: int) (bs: circuit) : circuit = + match a, bs with + | (({reg = arr; type_ = CArray {width=w; count=n}}, inps) : circuit), (({reg = bs; type_ = CBitstring w'}, cinps): circuit) -> + begin try + assert (w = w'); + { type_ = CArray {width=w; count=n}; reg = (Backend.insert arr (pos * w) bs)}, + merge_inputs inps cinps + with Backend.BadSlice `Set -> + lowcircerror @@ CircConstructorInvalidArguments (ASet { + container_size = n; + index = pos; + }) + end + | _ -> assert false (* Programming error *) (* FIXME: review this functiono | FIXME: Not axiomatized in QFABV.ec file *) let array_oflist (circs : circuit list) (dfl: circuit) (len: int) : circuit = diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 638f1ec11f..3ddfda4c25 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -1091,8 +1091,8 @@ and replay_crb_array (ove : _ ovrenv) (subst, ops, proofs, scope) (import, ba, l let tolist = forpath ba.tolist in let oflist = forpath ba.oflist in let type_ = match (EcSubst.subst_ty subst (tconstr ba.type_ [tint])).ty_node with (* FIXME: hack *) - | Tconstr (p, x::[]) -> p - | _ -> assert false; forpath ba.type_ + | Tconstr (p, _::[]) -> p + | _ -> assert false (* FIXME: do we always get a good type here? *) in let size = EcSubst.subst_binding_size ~red subst ba.size in let theory = EcSubst.subst_path subst ba.theory in (* FIXME *) diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index cbe628826e..feac1816c2 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -2,8 +2,6 @@ open EcUtils open EcIdent open EcSymbols -open EcLocation -open EcParsetree open EcAst open EcEnv open EcTypes @@ -20,11 +18,9 @@ module Set = Batteries.Set module Option = Batteries.Option (* -------------------------------------------------------------------- *) -exception BDepError of string Lazy.t -exception BDepUninitializedInputs +(* FIXME: maybe remove this ? *) exception BadTypeForConstructor exception TyLookupError -exception BDepVerifyFail (* TODO: Refactor error printing and checking? Lots of duplicated code *) @@ -123,7 +119,7 @@ let process_pre ?(st : state option) (tc: tcenv1) (f: form) : state * circuit li let fs = destr_conj f in - EcEnv.notify env EcGState.(`Debug) "Destructured conj, obtained:@.%a@." + EcEnv.notify env `Debug "Destructured conj, obtained:@.%a@." (EcPrinting.pp_list ";@\n" EcPrinting.(pp_form PPEnv.(ofenv env))) fs; (* If f is of the form (a_ = a) (aka prog_var = log_var) @@ -135,8 +131,8 @@ let process_pre ?(st : state option) (tc: tcenv1) (f: form) : state * circuit li | Fapp ({f_node = Fop (p, _);_}, [a; b]) -> begin match EcFol.op_kind p, (EcCallbyValue.norm_cbv (circ_red hyps) hyps a), (EcCallbyValue.norm_cbv (circ_red hyps) hyps b) with | Some `Eq, {f_node = Fpvar (PVloc pv, m); _}, fv | Some `Eq, fv, {f_node = Fpvar (PVloc pv, m); _} -> - EcEnv.notify env EcGState.(`Debug) "Adding equality to known information for translation: %a@." EcPrinting.(pp_form PPEnv.(ofenv env)) f; - update_state_pv s m pv (circuit_of_form ~st hyps fv) + EcEnv.notify env `Debug "Adding equality to known information for translation: %a@." EcPrinting.(pp_form PPEnv.(ofenv env)) f; + update_state_pv s m pv (circuit_of_form st hyps fv) | _ -> s end | _ -> s @@ -149,29 +145,29 @@ let process_pre ?(st : state option) (tc: tcenv1) (f: form) : state * circuit li let process_form (f: form) : circuit list = match f.f_node with | Fapp ({f_node = Fop (p, _);_}, [f1; f2]) when EcFol.op_kind p = Some `Eq -> - let c1 = circuit_of_form ~st hyps (EcCallbyValue.norm_cbv (circ_red hyps) hyps f1) in - let c2 = circuit_of_form ~st hyps (EcCallbyValue.norm_cbv (circ_red hyps) hyps f2) in + let c1 = circuit_of_form st hyps (EcCallbyValue.norm_cbv (circ_red hyps) hyps f1) in + let c2 = circuit_of_form st hyps (EcCallbyValue.norm_cbv (circ_red hyps) hyps f2) in circuit_eqs c1 c2 | _ -> begin - EcEnv.notify env EcGState.(`Debug) + EcEnv.notify env `Debug "Processing form: %a@.Simplified version: %a@." EcPrinting.(pp_form ppe) f EcPrinting.(pp_form ppe) (EcCallbyValue.norm_cbv (circ_red hyps) hyps f); - try (circuit_of_form ~st hyps (EcCallbyValue.norm_cbv (circ_red hyps) hyps f))::[] with + try (circuit_of_form st hyps (EcCallbyValue.norm_cbv (circ_red hyps) hyps f))::[] with e -> begin - EcEnv.notify env EcGState.(`Debug) "Encountered exception when converting part of the pre to circuit: %s@." (Printexc.to_string e); + EcEnv.notify env `Debug "Encountered exception when converting part of the pre to circuit: %s@." (Printexc.to_string e); [] end end in let cs = List.fold_left (fun acc f -> List.rev_append (process_form f) acc) [] fs |> List.rev in (* - EcEnv.notify env EcGState.(`Debug) "Translated as much as possible from pre to circuits, got:@.%a@\n" + EcEnv.notify env `Debug "Translated as much as possible from pre to circuits, got:@.%a@\n" (EcPrinting.pp_list "@\n@\n" pp_circuit) cs; *) - EcEnv.notify env EcGState.(`Debug) "In the context of the following bindings in the environment:@\n%a@\n" + EcEnv.notify env `Debug "In the context of the following bindings in the environment:@\n%a@\n" (EcPrinting.pp_list "@\n@\n" (fun fmt cinp -> Format.fprintf fmt "%a@." pp_cinp cinp)) (state_lambdas st); st, cs @@ -180,16 +176,16 @@ let solve_post ~(st: state) ~(pres: circuit list) (hyps: hyps) (post: form) : bo let posts = destr_conj post in List.for_all (fun post -> - EcEnv.notify (toenv hyps) EcGState.(`Debug) "Solving post: %a@." + EcEnv.notify (toenv hyps) `Debug "Solving post: %a@." EcPrinting.(pp_form PPEnv.(ofenv (toenv hyps))) post; match post.f_node with | Fapp ({f_node= Fop(p, _); _}, [f1; f2]) -> begin match EcFol.op_kind p with | Some `Eq -> circuit_simplify_equality ~st ~hyps ~pres f1 f2 - | _ -> circuit_of_form ~st hyps post |> state_close_circuit st |> circ_taut + | _ -> circuit_of_form st hyps post |> state_close_circuit st |> circ_taut end - | _ -> circuit_of_form ~st hyps post |> state_close_circuit st |> circ_taut + | _ -> circuit_of_form st hyps post |> state_close_circuit st |> circ_taut ) posts (* TODO: Figure out how to not repeat computations here? *) @@ -229,7 +225,8 @@ let t_bdep_solve let tm = Unix.gettimeofday () in (* FIXME: rework this *) - let st = circuit_state_of_memenv ~st:empty_state (FApi.tc1_env tc) es.es_ml in + let st = set_logger empty_state (EcEnv.notify env `Debug "%s") in + let st = circuit_state_of_memenv ~st (FApi.tc1_env tc) es.es_ml in let st = circuit_state_of_memenv ~st (FApi.tc1_env tc) es.es_mr in (* let st = circuit_state_of_hyps ~st (FApi.tc1_hyps tc) in *) @@ -255,8 +252,8 @@ let t_bdep_solve let ctxt = tohyps hyps in assert (ctxt.h_tvar = []); let st = circuit_state_of_hyps hyps in - let cgoal = (circuit_of_form ~st hyps goal |> state_close_circuit st) in - EcEnv.notify env EcGState.(`Debug) "goal: %a@." pp_flatcirc (fst cgoal).reg; + let cgoal = (circuit_of_form st hyps goal |> state_close_circuit st) in + EcEnv.notify env `Debug "goal: %a@." pp_flatcirc (fst cgoal).reg; if circ_taut cgoal then FApi.close (!@ tc) VBdep else @@ -268,8 +265,8 @@ let t_bdep_solve let t_bdep_simplify (tc: tcenv1) = let time (env: env) (t: float) (msg: string) : float = let new_t = Unix.gettimeofday () in - EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. t); - (* Format.eprintf "[W] %s, took %f s@." msg (new_t -. t); *) + (* FIXME: change log level to debug? maybe not *) + EcEnv.notify ~immediate:true env `Info "%s, took %f s@." msg (new_t -. t); new_t in let hyps = (FApi.tc1_hyps tc) in @@ -289,7 +286,7 @@ let t_bdep_simplify (tc: tcenv1) = let st = EcCircuits.state_of_prog ~st hyps (fst hs.hs_m) hs.hs_s.s_node in let post = EcCallbyValue.norm_cbv (circ_red hyps) hyps (hs_po hs).inv in - EcEnv.notify env EcGState.(`Debug) "[W] Post after simplify (before circuit pass):@. %a@." + EcEnv.notify env `Debug "[W] Post after simplify (before circuit pass):@. %a@." EcPrinting.(pp_form PPEnv.(ofenv env)) post; let tm = time env tm "Done with first simplify" in @@ -299,7 +296,7 @@ let t_bdep_simplify (tc: tcenv1) = let _tm = time env tm "Done with second simplify" in let new_goal = f_hoareS (snd hs.hs_m) {inv=(hs_pr hs).inv; m} hs.hs_s {inv=f; m} in - EcEnv.notify env EcGState.(`Debug) "[W] Goal after simplify:@. %a@." + EcEnv.notify env `Debug "[W] Goal after simplify:@. %a@." EcPrinting.(pp_form PPEnv.(ofenv env)) new_goal; FApi.mutate1 tc (fun _ -> VBdep) new_goal |> FApi.tcenv_of_tcenv1 @@ -352,7 +349,7 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = let fi = EcCallbyValue.norm_cbv redmode hyps fi in let e = try expr_of_ss_inv {f with inv=fi} with CannotTranslate -> - Format.eprintf "Failed on form : %a@." + EcEnv.notify env `Debug "Failed on form : %a@." EcPrinting.(pp_form PPEnv.(ofenv env)) fi; raise CannotTranslate in @@ -364,7 +361,7 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = let goals = match (tc1_goal tc).f_node, v with | Fapp ({f_node = Fop (p, [tp]); _}, [fpred; flist]), None when p = EcCoreLib.CI_List.p_all && tp = tint-> - Format.eprintf "[W] Found list all@."; + EcEnv.notify (tc1_env tc) `Debug "Found list all@."; begin match flist.f_node with | Fapp ({f_node = Fop (p, []); _}, [fstart; flen]) when p = EcCoreLib.CI_List.p_iota -> let start = match fstart.f_node with @@ -381,7 +378,7 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = EcTypesafeFol.fapply_safe (tc1_hyps tc) fpred [f_int EcBigInt.(of_int (i + start))] ) in - Format.eprintf "[w] Got iota => [%d, %d)@.Goals: %a@." start len + EcEnv.notify (tc1_env tc) `Debug "Got iota => [%d, %d)@.Goals: %a@." start len EcPrinting.(pp_list " | " (pp_form PPEnv.(ofenv (tc1_env tc)))) goals; goals @@ -419,7 +416,7 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = let pr = subst (hs_pr hs).inv in let po = subst (hs_po hs).inv in let goal = f_hoareS mt ({inv=pr;m}) s ({inv=po;m}) in - EcEnv.notify (FApi.tc1_env tc) EcGState.(`Debug) + EcEnv.notify (FApi.tc1_env tc) `Debug "[W] Generated goal %d => %a@." i EcPrinting.(pp_form PPEnv.(ofenv (tc1_env tc))) goal; diff --git a/src/phl/ecPhlBDep.mli b/src/phl/ecPhlBDep.mli index c7898b90d6..c50dde367d 100644 --- a/src/phl/ecPhlBDep.mli +++ b/src/phl/ecPhlBDep.mli @@ -1,7 +1,5 @@ (* -------------------------------------------------------------------- *) -open EcParsetree open EcCoreGoal -open EcAst (* -------------------------------------------------------------------- *) val t_bdep_solve : tcenv1 -> tcenv diff --git a/src/phl/ecPhlCodeTx.ml b/src/phl/ecPhlCodeTx.ml index 191344a0a8..d4fd6e9514 100644 --- a/src/phl/ecPhlCodeTx.ml +++ b/src/phl/ecPhlCodeTx.ml @@ -242,7 +242,7 @@ let cfold_stmt ?(simplify = true) (pf, hyps) (me : memenv) (olen : int option) ( let lv = lv_to_ty_list lv in - let tosubst, asgn2 = List.partition (fun ((pv, _), e) -> + let tosubst, asgn2 = List.partition (fun ((pv, _), _) -> Mpv.mem env pv subst0 ) (List.combine lv es) in diff --git a/src/phl/ecPhlEqobs.ml b/src/phl/ecPhlEqobs.ml index b13c46c607..586bf02643 100644 --- a/src/phl/ecPhlEqobs.ml +++ b/src/phl/ecPhlEqobs.ml @@ -468,7 +468,7 @@ let pre_eqobs (cm : crushmode) (tc : tcenv1) = (* -------------------------------------------------------------------- *) let t_eqobs_inS_ (info : sim_info) (tc : tcenv1) = - let env, hyps, _ = FApi.tc1_eflat tc in + let env, _, _ = FApi.tc1_eflat tc in let es = tc1_as_equivS tc in let spec, inv = info.sim_hint in @@ -537,7 +537,7 @@ let process_eqobs_inS (cm : crushmode option) (info : psim_info) (tc : tcenv1) = let t_eqobs_inF_ (info : sim_info) (tc : tcenv1) = assert (Option.is_none info.sim_pos); - let env, hyps, _ = FApi.tc1_eflat tc in + let env, _, _ = FApi.tc1_eflat tc in let ef = tc1_as_equivF tc in let fl = ef.ef_fl and fr = ef.ef_fr in diff --git a/src/phl/ecPhlRewrite.ml b/src/phl/ecPhlRewrite.ml index bc28749e7c..d7c8ac30ce 100644 --- a/src/phl/ecPhlRewrite.ml +++ b/src/phl/ecPhlRewrite.ml @@ -1,6 +1,5 @@ (* -------------------------------------------------------------------- *) open EcParsetree -open EcUtils open EcAst open EcCoreGoal open EcEnv @@ -176,9 +175,9 @@ let rec pvtail (env: env) (pvs : EcPV.PV.t) (zp : Zpr.ipath) = match zp with | Zpr.ZTop -> None | Zpr.ZWhile (_, p) -> Some p - | Zpr.ZIfThen (e, p, _) -> Some p - | Zpr.ZIfElse (e, _, p) -> Some p - | Zpr.ZMatch (e, p, _) -> Some p in + | Zpr.ZIfThen (_, p, _) -> Some p + | Zpr.ZIfElse (_, _, p) -> Some p + | Zpr.ZMatch (_, p, _) -> Some p in match parent with | None -> pvs | Some ((_, tl), p) -> pvtail env (EcPV.PV.union pvs (EcPV.is_read env tl)) p @@ -187,17 +186,17 @@ let rec pvtail (env: env) (pvs : EcPV.PV.t) (zp : Zpr.ipath) = let t_change_stmt (side : side option) (pos : EcMatching.Position.codepos_range) - ((me, bindings) : memenv * ovariable list) + ((me, _bindings) : memenv * ovariable list) (* FIXME: might not be needed, check before merge *) (s : stmt) (tc : tcenv1) = let env = FApi.tc1_env tc in let goal = (FApi.tc1_goal tc) in let post = match goal.f_node with - | FhoareS { hs_po } -> hs_po - | FbdHoareS { bhs_po } -> bhs_po - | FeHoareS { ehs_po } -> ehs_po - | FequivS { es_po } -> es_po + | FhoareS hs -> (hs_po hs).inv + | FbdHoareS bhs -> (bhs_po bhs).inv + | FeHoareS ehs -> (ehs_po ehs).inv + | FequivS es -> (es_po es).inv | _ -> assert false in let _, stmt = EcLowPhlGoal.tc1_get_stmt side tc in diff --git a/src/phl/ecPhlRwEquiv.ml b/src/phl/ecPhlRwEquiv.ml index e3242547a4..3a7d9871d5 100644 --- a/src/phl/ecPhlRwEquiv.ml +++ b/src/phl/ecPhlRwEquiv.ml @@ -2,7 +2,6 @@ open EcUtils open EcLocation open EcParsetree -open EcAst open EcFol open EcModules open EcPath diff --git a/src/phl/ecPhlRwPrgm.ml b/src/phl/ecPhlRwPrgm.ml index f970e42161..7251d333e5 100644 --- a/src/phl/ecPhlRwPrgm.ml +++ b/src/phl/ecPhlRwPrgm.ml @@ -51,9 +51,9 @@ let process_change ((cpos, bindings, i, s) : change_t) (tc : tcenv1) = match zp with | Zpr.ZTop -> None | Zpr.ZWhile (_, p) -> Some p - | Zpr.ZIfThen (e, p, _) -> Some p - | Zpr.ZIfElse (e, _, p) -> Some p - | Zpr.ZMatch (e, p, _) -> Some p in + | Zpr.ZIfThen (_, p, _) -> Some p + | Zpr.ZIfElse (_, _, p) -> Some p + | Zpr.ZMatch (_, p, _) -> Some p in match parent with | None -> pvs | Some ((_, tl), p) -> pvtail (EcPV.PV.union pvs (EcPV.is_read env tl)) p @@ -64,10 +64,11 @@ let process_change ((cpos, bindings, i, s) : change_t) (tc : tcenv1) = let keep = pvtail (EcPV.is_read env tl) zp.z_path in let keep = EcPV.PV.union keep (EcPV.PV.fv env (EcMemory.memory mem) (EcAst.hs_po hs).inv) in + let st = EcLowCircuits.(set_logger empty_state EcEnv.(notify env `Debug "%s")) in begin try - if not (EcCircuits.instrs_equiv (FApi.tc1_hyps tc) ~keep mem target s.s_node) then + if not (EcCircuits.instrs_equiv (FApi.tc1_hyps tc) ~keep mem st target s.s_node) then tc_error !!tc "statements are not circuit-equivalent" with e -> tc_error !!tc "circuit-equivalence checker error: %s" (Printexc.to_string e) From bc0704282aa9ac244be5c003806327bd350fc7f7 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Thu, 5 Feb 2026 19:39:06 +0000 Subject: [PATCH 006/145] Error and printing improvements --- src/ecCircuits.ml | 25 ++++++++++------------ src/ecCircuits.mli | 3 +++ src/ecEnv.ml | 7 +++---- src/ecLowCircuits.ml | 50 ++++++++++++++++++++++++++------------------ src/ecScope.ml | 3 +-- 5 files changed, 48 insertions(+), 40 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 86b0278372..32ad6a6684 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -159,9 +159,11 @@ end (* -------------------------------------------------------------------- *) type circuit_conversion_call = [ | `Convert of form + | `Op of path | `ToArg of form | `ExpandIter of form * form list | `Instr of instr + | `Memenv of memenv ] type circuit_error = @@ -257,8 +259,10 @@ let rec pp_circ_error ppe fmt (err: circuit_error) = begin match call with | `Convert f -> Format.fprintf fmt "conversion of form %a" (pp_form ppe) f | `ToArg f -> Format.fprintf fmt "conversion to arg of form %a" (pp_form ppe) f - | `ExpandIter (f, args) -> Format.eprintf "expansion of iter %a(%a)" (pp_form ppe) f (pp_list ", " (pp_form ppe)) args - | `Instr inst -> Format.eprintf "processing of instruction %a" (pp_instr ppe) inst + | `ExpandIter (f, args) -> Format.fprintf fmt "expansion of iter %a(%a)" (pp_form ppe) f (pp_list ", " (pp_form ppe)) args + | `Instr inst -> Format.fprintf fmt "processing of instruction %a" (pp_instr ppe) inst + | `Op pth -> Format.fprintf fmt "translating operator at path %a" pp_path pth + | `Memenv (m, mt) -> Format.fprintf fmt "entering memory %a : %a" (pp_mem ppe) m (pp_memtype ppe) mt end @@ -649,7 +653,7 @@ let circuit_of_form type_has_bindings env t -> let cs = List.map (fun f -> doit st f) (form_list_of_form ~env f) in arg_of_circuits cs - | _ -> Format.eprintf "Failed to convert form to arg: %a@." EcPrinting.(pp_form ppe) f; + | _ -> EcLowCircuits.log st @@ Format.asprintf "Failed to convert form to arg: %a@." EcPrinting.(pp_form ppe) f; circ_error (BadFormForArg f) with CircError e -> propagate_circ_error (`ToArg f) e @@ -684,7 +688,7 @@ let circuit_of_form let circ = try circuit_of_op env pth with - | CircError le -> Format.eprintf "(%s ->)" (EcPath.tostring pth); raise (CircError le) + | CircError err -> propagate_circ_error (`Op pth) err in op_cache := Mp.add pth circ !op_cache; circ @@ -769,10 +773,7 @@ let circuit_of_form circ end (* FIXME: Redo call chain on error *) - (* with CircError le -> - let err = lazy (Format.asprintf "Call %a\n%s" EcPrinting.(pp_form ppe) f (Lazy.force le)) in - raise (CircError err) *) - with e -> raise e + with CircError err -> propagate_circ_error (`Convert f_) err end | Fquant (qnt, binds, f) -> @@ -1084,7 +1085,7 @@ let state_get = state_get_pv let state_get_opt = state_get_pv_opt let state_get_all = fun st -> state_get_all_pv st |> List.snd -let circuit_state_of_memenv ~(st: state) (env:env) ((m, mt): memenv) : state = +let circuit_state_of_memenv ~(st: state) (env:env) ((m, mt) as me: memenv) : state = match mt with | (Lmt_concrete Some {lmt_decl=decls}) -> let bnds = List.map (fun {ov_name; ov_type} -> @@ -1092,11 +1093,7 @@ let circuit_state_of_memenv ~(st: state) (env:env) ((m, mt): memenv) : state = | Some v -> begin try Some ((m, v), ctype_of_ty env ov_type) - with e -> - raise e (* FIXME *) - (* (CircError (lazy ( - (Format.asprintf "Failed for decl for var %s@." v) ^ Lazy.force err - ))) *) + with CircError err -> propagate_circ_error (`Memenv me) err end | None -> None ) decls in diff --git a/src/ecCircuits.mli b/src/ecCircuits.mli index 8ba1ffa889..edf18c8828 100644 --- a/src/ecCircuits.mli +++ b/src/ecCircuits.mli @@ -13,11 +13,14 @@ module Map = Batteries.Map (* -------------------------------------------------------------------- *) type circuit_conversion_call = [ | `Convert of form + | `Op of path | `ToArg of form | `ExpandIter of form * form list | `Instr of instr + | `Memenv of memenv ] + type circuit_error = | MissingTyBinding of [`Ty of ty | `Path of path] | AbstractTyBinding of [`Ty of ty | `Path of path] diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 1686809943..b71cbbf628 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -3290,7 +3290,7 @@ module Circuit = struct | CRB_Circuit cr -> bind_circuit ?import lc cr env let rec lookup_bitstring_path (env : env) (k : path) : crb_bitstring option = -(* Format.eprintf "Looking up bitstring binding for type with path %s@." (EcPath.tostring k); *) + notify env `Debug "Looking up bitstring binding for type with path %s@." (EcPath.tostring k); let k, _ = Ty.lookup (EcPath.toqsymbol k) (env) in match Mp.find_opt k env.env_crbds.bitstrings with | Some _ as bs -> bs @@ -3328,7 +3328,7 @@ module Circuit = struct let rec lookup_array_and_bitstring (env: env) (ty: ty) : (crb_array * crb_bitstring) option = match ty.ty_node with | Tconstr (p, [w]) -> -(* Format.eprintf "Unfolding parametric type with path %s@." (EcPath.tostring p); *) + notify env `Debug "Unfolding parametric type with path %s@." (EcPath.tostring p); let arr = lookup_array_path env p in let bs = lookup_bitstring env w in begin match arr, bs with @@ -3336,7 +3336,7 @@ module Circuit = struct | _ -> None end | Tconstr (p, []) -> -(* Format.eprintf "Unfolding non parametric type with path %s@." (EcPath.tostring p); *) + notify env `Debug "Unfolding non parametric type with path %s@." (EcPath.tostring p); (try lookup_array_and_bitstring env (Ty.unfold p [] env) with LookupFailure _ -> None) @@ -3383,7 +3383,6 @@ module Circuit = struct reverse_and_filter_operator ~filter:(function `Circuit x -> Some x | _ -> None) - (* FIXME: Remove env argument? *) let get_specification_by_name ~(filename : string) (name : symbol) : Lospecs.Ast.adef option = let specs = Lospecs.Circuit_spec.load_from_file ~filename in List.Exceptionless.assoc name specs diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index 1d75637b7a..32aaae7d5c 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -283,7 +283,6 @@ module LospecsBack : CBackend = struct raise GetOutOfRange let permute (w: int) (perm: int -> int) (r: reg) : reg = - if debug then Format.eprintf "Applying permutation to reg of size %d with block size of %d@." (size_of_reg r) w; Array.init (size_of_reg r) (fun i -> let block_idx, bit_idx = perm (i / w), (i mod w) in if block_idx < 0 then None @@ -520,6 +519,7 @@ module type CircuitInterface = sig val circ_lambda_oneshot : state -> (ident * ctype) list -> (state -> circuit) -> circuit (* FIXME: rename or redo *) val set_logger : state -> (string -> unit) -> state + val log : state -> string -> unit end module BVOps : sig @@ -602,8 +602,8 @@ module type CircuitInterface = sig val circuit_slice : size:int -> circuit -> int -> circuit val circuit_slice_insert : circuit -> int -> circuit -> circuit val fillet_circuit : circuit -> circuit list - val fillet_tauts : circuit list -> circuit list -> bool - val batch_checks : ?sort:bool -> ?mode:[`ByEq | `BySub ] -> circuit list -> circuit list + val fillet_tauts : ?logger:(string -> unit) -> circuit list -> circuit list -> bool + val batch_checks : ?logger:(string -> unit) -> ?sort:bool -> ?mode:[`ByEq | `BySub ] -> circuit list -> circuit list (* Wraps the backend call to deal with args/inputs *) val circuit_to_file : name:string -> circuit -> symbol @@ -802,7 +802,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (* Circuit lambdas, for managing inputs *) let open_circ_lambda (st: state) (bnds: (ident * ctype) list) : state = let inps, cs = List.map (fun (id, t) -> - if debug then Format.eprintf "Opening circuit lambda for ident: (%s, %d)@." (name id) (tag id); + st.logger @@ Format.asprintf "Opening circuit lambda for ident: (%s, %d)@." (name id) (tag id); let inp, c = cinput_of_type (`Idn id) t in inp, (id, c)) bnds |> List.split in {st with @@ -833,6 +833,9 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let set_logger (st: state) (logger: string -> unit) : state = { st with logger; } + + let log (st: state) (s: string) : unit = + st.logger s end (* Inputs helper functions *) @@ -1157,7 +1160,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = else false let circ_sat ((c, inps): circuit) : bool = - if debug then Format.eprintf "Calling circ_sat on circuit: %a@." pp_circuit (c, inps); let c = match c with | {type_ = CBool; reg} -> Backend.node_of_reg reg | _ -> lowcircerror CircSmtNonBoolCirc @@ -1172,7 +1174,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = Backend.sat ~inps c let circ_taut ((c, inps): circuit) : bool = - if debug then Format.eprintf "Calling circ_taut on circuit: %a@." pp_circuit (c, inps); let c = match c with | {type_ = CBool; reg} -> Backend.node_of_reg reg | _ -> lowcircerror CircSmtNonBoolCirc @@ -1292,7 +1293,13 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = Does not affect current examples => MLKEM *) (* Batches circuit checks by dependencies. Assumes equivalent checks are contiguous *) - let batch_checks ?(sort = true) ?(mode : [`ByEq | `BySub] = `ByEq) (checks: circuit list) : circuit list = + let batch_checks + ?(logger : (string -> unit) option) + ?(sort = true) + ?(mode : [`ByEq | `BySub] = `ByEq) + (checks: circuit list) + : circuit list + = (* Order by dependencies *) let checks = if sort then begin @@ -1323,9 +1330,13 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = match cs with | [] -> (cur::acc) | (c, d')::cs -> - if debug && false then Format.eprintf "Comparing deps:@.%a@.To deps:@.%a@." - Backend.Deps.pp_dep d - Backend.Deps.pp_dep d'; +(* + FIXME: do we keep this? also add log levels *) + Option.may (fun f -> f @@ + Format.asprintf "Comparing deps:@.%a@.To deps:@.%a@." + Backend.Deps.pp_dep d + Backend.Deps.pp_dep d') + logger; begin match mode with | `ByEq when Backend.Deps.deps_equal d d' -> doit acc ((circuit_and cur c), d) cs @@ -1334,7 +1345,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = | `BySub when Backend.Deps.(dep_contained d' d) -> doit acc ((circuit_and cur c), d) cs | _ -> - Format.eprintf "Consolidated lane deps: %a@." Backend.Deps.pp_dep d; + Option.may (fun f -> f @@ Format.asprintf "Consolidated lane deps: %a@." Backend.Deps.pp_dep d) logger; doit (cur::acc) (c, d') cs end in @@ -1413,7 +1424,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (* Review later? *) - let collapse_lanes (lanes: circuit list) = + let collapse_lanes ?(logger : (string -> unit) option) (lanes: circuit list) = (* Circuit structural equality after renaming *) let (===) (c1: circ) (c2: circ) : bool = let n', _ = Backend.node_of_reg c1.reg |> Backend.Deps.excise_bit in @@ -1441,7 +1452,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = doit (collapse [] c cs) else if (List.length (cs) + 1) mod idx != 0 then - (Format.eprintf "Cannot correctly infer lanes, defaulting to bruteforce checking@."; + (Option.may (fun f -> f "Cannot correctly infer lanes, defaulting to bruteforce checking@.") logger; (c::cs)) else let cs = List.chunkify idx (c::cs) |> List.map (List.reduce circuit_and) in @@ -1460,7 +1471,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = *) (* FIXME: current lane collapse is always quadratic, add toggle option? or remove arg *) - let fillet_tauts (pres: circuit list) (posts: circuit list) : bool = + let fillet_tauts ?(logger: (string -> unit) option) (pres: circuit list) (posts: circuit list) : bool = (* Assumes everything is single bit outputs. FIXME: does it? *) let posts = List.filter_map (fun ((postc, _) as post) -> if Backend.nodes_eq (Backend.node_of_reg postc.reg) Backend.true_ then None @@ -1476,18 +1487,18 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let pres = List.map (fun ((c, _) as circ) -> circ, Backend.Deps.dep_of_node (Backend.node_of_reg c.reg)) pres in let posts = List.map (attach_compatible_pres ~mode:`Int pres) posts in - let posts = collapse_lanes posts in + let posts = collapse_lanes ?logger posts in - if debug then Format.eprintf "%d conditions to check after structural equality collapse@." (List.length posts); + Option.may (fun f -> f @@ Format.asprintf "%d conditions to check after structural equality collapse@." (List.length posts)) logger; List.mapi (fun i post -> - if debug then Format.eprintf "Checking equivalence for bit %d@." i; (* FIXME *) + Option.may (fun f -> f @@ Format.asprintf "Checking equivalence for bit %d@." i) logger; (* let res = fillet_taut pres post in *) let post = sublimate_inputs post in let res = circ_taut post in - if not res then Format.eprintf "Failed for bit %d@." i; - + if not res then + Option.may (fun f -> f @@ Format.asprintf "Failed for bit %d@." i) logger; res) posts |> List.for_all identity @@ -1892,7 +1903,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let array_oflist (circs : circuit list) (dfl: circuit) (len: int) : circuit = let circs, inps = List.split circs in let dif = len - List.length circs in assert (dif >= 0); - (* if debug then Format.eprintf "Len, Dif in array_oflist: %d, %d@." len dif; *) let circs = circs @ (List.init dif (fun _ -> fst dfl)) in let inps = if dif > 0 then inps @ [snd dfl] else inps in let circs = List.map diff --git a/src/ecScope.ml b/src/ecScope.ml index e32d7abc13..bb7b1736f7 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -3140,8 +3140,7 @@ module Circuit = struct EcTheory.mkitem ~import:true (EcTheory.Th_crbinding (item, local)) in { scope with sc_env = EcSection.add_item item scope.sc_env } - | circs -> Format.eprintf "Multiple matches found (%d) for circuit %s" (List.length circs) (unloc circ); assert false - (* FIXME *) + | circs -> hierror "Multiple matches found (%d) for circuit %s" (List.length circs) (unloc circ) let register_spec_files (scope : scope) (files : string list) : scope = let sc = { scope with sc_specs = files } in From b116717a095f86b06ed836d1b800af0725b8a4e2 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Thu, 5 Feb 2026 19:44:22 +0000 Subject: [PATCH 007/145] Added fail case circuit tests --- tests/circuit_test.ec | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/tests/circuit_test.ec b/tests/circuit_test.ec index 8552d8f83e..b1b73eb111 100644 --- a/tests/circuit_test.ec +++ b/tests/circuit_test.ec @@ -28,7 +28,8 @@ realize tosintP by admit. realize ofintP by admit. realize size_tolist by admit. - +op zero : W = of_int 0. +op one : W = of_int 1. op bool2bits (b : bool) : bool list = [b]. op bits2bool (b: bool list) : bool = List.nth false b 0. @@ -69,6 +70,8 @@ module M = { op "_.[_]" : W8 -> int -> bool. +op non_translate : W8 -> W8. + bind op [W8 & bool] "_.[_]" "get". realize le_size by auto. realize eq1_size by auto. @@ -84,15 +87,29 @@ qed. lemma W8_xor_ext (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. proof. proc. -(* extens [a] : (wp; skip; smt()). *) -(* FIXME : while debugging fhash *) admit. +extens [a] : (wp; skip; smt()). +(* FIXME : while debugging fhash admit. *) qed. lemma W8_xor_simp (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. proof. proc. -(* circuit simplify; trivial. *) admit. +circuit simplify. trivial. (* admit. *) +qed. + + + +lemma W8_xor_fail_equiv (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ zero]. +proof. +proc. +circuit. (* Fails *) +qed. + +lemma W8_xor_fail_translate (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ non_translate zero]. +proof. +proc. +circuit. (* Fails *) qed. From de7b2950b6664456ad24ca8af3596ef7d0e80e85 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Thu, 5 Feb 2026 19:50:42 +0000 Subject: [PATCH 008/145] Minor error propagation fix --- src/ecCircuits.ml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 32ad6a6684..c21bfa76c5 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -709,7 +709,7 @@ let circuit_of_form op_cache := Mp.add pth circ !op_cache; circ end - | Fapp (f, fs) -> begin try + | Fapp (f, fs) -> begin match Map.find_opt (fhash f_) !cache with (* TODO: Maybe add cache statistics? *) | Some circ -> circ | None -> let circ = @@ -772,9 +772,6 @@ let circuit_of_form cache := Map.add (fhash f_) circ !cache; circ end - (* FIXME: Redo call chain on error *) - with CircError err -> propagate_circ_error (`Convert f_) err - end | Fquant (qnt, binds, f) -> let binds = List.map (fun (idn, t) -> (idn, gty_as_ty t |> ctype_of_ty env)) binds in (* FIXME *) From 4b94cb8980c5def3108577d694bc67221386f18b Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Fri, 6 Feb 2026 16:08:54 +0000 Subject: [PATCH 009/145] Allow uninitialized program variable in circuit solve for hoare goals --- src/phl/ecPhlBDep.ml | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index feac1816c2..bc422f1eb7 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -125,6 +125,12 @@ let process_pre ?(st : state option) (tc: tcenv1) (f: form) : state * circuit li (* If f is of the form (a_ = a) (aka prog_var = log_var) then add it to the state, otherwise do nothing *) (* FIXME: are all the simplifications necessary ? *) + (* Processes explicit equations *) + (* FIXME PR: Make sure this works with things of the form + a{hr} = b{hr} /\ b{hr} = a{hr} + or even + a{hr} = b{hr} /\ b{hr} = c{hr} /\ c{hr} = a{hr} + *) let process_equality (s: state) (f: form) : state = let f = (EcCallbyValue.norm_cbv (circ_red hyps) hyps f) in match f.f_node with @@ -203,7 +209,9 @@ let t_bdep_solve match goal.f_node with | FhoareS hs -> begin try let tm = Unix.gettimeofday () in - let st, cpres = process_pre tc (hs_pr hs).inv in + let st = set_logger empty_state (EcEnv.notify env `Debug "%s") in + let st = circuit_state_of_hyps ~use_mem:true ~st hyps in + let st, cpres = process_pre ~st tc (hs_pr hs).inv in let tm = time (toenv hyps) tm "Done with precondition processing" in (* Get open state *) From f21c0cb3b8f4d8c5df26224deab6835e94e74ff0 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Mon, 9 Feb 2026 12:33:42 +0000 Subject: [PATCH 010/145] Changed alpha equiv hash to not compute form normal form and fixed circuit test --- src/ecCircuits.ml | 122 +++++++++++++++++++++--------------------- tests/circuit_test.ec | 49 ++++++----------- 2 files changed, 76 insertions(+), 95 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index c21bfa76c5..d8a246b5a9 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -29,28 +29,16 @@ let circ_red (hyps: hyps) = let base_red = EcReduction.full_red in (* FIXME: should change to a decent direct hash of this + store the forms *) (* also move the cache here? *) -module AInvFHash = struct - let known_hashes : (int, int) Map.t ref = ref Map.empty +module AInvFHashtbl(Ctxt: sig val hyps: hyps end) = Batteries.Hashtbl.Make(struct + type t = form - let clean_known : unit -> unit = - fun () -> known_hashes := Map.empty + let equal f1 f2 = EcReduction.is_alpha_eq Ctxt.hyps f1 f2 let bruijn_idents : (int, ident) Map.t ref = ref Map.empty let clean_bruijn_idents : unit -> unit = fun () -> bruijn_idents := Map.empty - let form_storage : (int, form) Map.t ref = ref Map.empty - - let clean_form_storage : unit -> unit = - fun () -> form_storage := Map.empty - - let nuke_state_from_orbit : unit -> unit = - fun () -> - clean_known (); - clean_bruijn_idents (); - clean_form_storage () - let ident_of_debruijn_level (i: int) : ident = match Map.find_opt i !bruijn_idents with | Some id -> id @@ -63,7 +51,6 @@ module AInvFHash = struct subst: EcSubst.subst; } - let add_to_state (id: ident) (ty: ty) (st: state) = let new_id = ident_of_debruijn_level st.level in let level = st.level + 1 in @@ -71,9 +58,9 @@ module AInvFHash = struct { level; subst }, new_id - let to_debruijn (f: form) : form = - let rec doit (st: state) (f: form) = - match f.f_node with + let hash (f: form) : int = + let rec doit (st: state) (f: form) : int = + let hnode = match f.f_node with | Fquant (qnt, bnds, f) -> let st, bnds = List.fold_left_map (fun st (orig_id, gty) -> @@ -84,77 +71,86 @@ module AInvFHash = struct | _ -> st, (orig_id, gty) ) st bnds - in f_quant qnt bnds (doit st (EcSubst.subst_form st.subst f)) + in Why3.Hashcons.combine2 (qt_hash qnt) (b_hash bnds) (doit st (EcSubst.subst_form st.subst f)) | Fif (cond, tb, fb) -> let doit = doit st in - f_if (doit cond) (doit tb) (doit fb) + Why3.Hashcons.combine2 (doit cond) (doit tb) (doit fb) | Fmatch (_, _, _) -> assert false | Flet (lp, value, body) -> begin match lp with | LSymbol (orig_id, ty) -> - let nval = doit st value in + let hval = doit st value in let st, new_id = add_to_state orig_id ty st in - let nbody = doit st (EcSubst.subst_form st.subst body) in - f_let (LSymbol (new_id, ty)) nval nbody + let hbody = doit st (EcSubst.subst_form st.subst body) in + let hlp = lp_hash (LSymbol (new_id, ty)) in + Why3.Hashcons.combine2 hlp hval hbody | LTuple bnds -> - let nval = doit st value in + let hval = doit st value in let st, new_ids = List.fold_left_map (fun st (id, ty) -> add_to_state id ty st) st bnds in - let nbody = doit st (EcSubst.subst_form st.subst body) in - let nbinds = List.combine new_ids (List.snd bnds) in - f_let (LTuple nbinds) nval nbody + let hbody = doit st (EcSubst.subst_form st.subst body) in + let hbinds = lp_hash @@ LTuple (List.combine new_ids (List.snd bnds)) in + Why3.Hashcons.combine2 hbinds hval hbody | LRecord (_, _) -> assert false end | Fapp (op, args) -> - let nargs = List.map (doit st) args in - let nop = doit st op in - f_app nop nargs f.f_ty + let hop = doit st op in + Why3.Hashcons.combine_list (doit st) hop args | Ftuple comps -> - f_tuple (List.map (doit st) comps) + Why3.Hashcons.combine_list (doit st) 0 comps | Fproj (tp, i) -> - f_proj (doit st tp) i f.f_ty - | FhoareF hf -> - let npre = doit st (hf_pr hf).inv in - let npo = doit st (hf_po hf).inv in - let m = hf.hf_m in - f_hoareF {inv=npre;m} hf.hf_f {inv=npo;m} - | FhoareS hs -> - let m, me = hs.hs_m in - let npre = doit st (hs_pr hs).inv in - let npo = doit st (hs_po hs).inv in + Why3.Hashcons.combine (doit st tp) i + | FhoareF _hF -> + assert false +(* FIXME: do we want this case and the one below? + let hpre = doit st (hf_pr hF).inv in + let hpo = doit st (hf_po hF).inv in + let hf = x_hash hF.hf_f in + let hm = id_hash hF.hf_m in + Why3.Hashcons.combine3 hpre hpo hf hm +*) + | FhoareS _hS -> + assert false +(* + let hme = me_hash hS.hs_m in + let hpre = doit st (hs_pr hS).inv in + let hpo = doit st (hs_po hS).inv in + let hs = s_hash f_hoareS me {inv=npre;m} hs.hs_s {inv=npo;m} +*) | FbdHoareF _ -> assert false | FbdHoareS _ -> assert false | FeHoareF _ -> assert false | FeHoareS _ -> assert false - | FequivF ef -> + | FequivF _ef -> + assert false +(* FIXME: do we want these cases? let npre = doit st (ef_pr ef).inv in let npo = doit st (ef_po ef).inv in f_equivF {inv=npre;ml=ef.ef_ml;mr=ef.ef_mr} ef.ef_fl ef.ef_fr {inv=npo;ml=ef.ef_ml;mr=ef.ef_mr} - | FequivS es -> +*) + | FequivS _es -> + assert false +(* let ml, mel = es.es_ml in let mr, mer = es.es_mr in let npre = doit st (es_pr es).inv in let npo = doit st (es_po es).inv in f_equivS mel mer {inv=npre;ml;mr} es.es_sl es.es_sr {inv=npo;ml;mr} +*) | FeagerF _ -> assert false | Fpr _ -> assert false - | Fint _ + | Fint _ | Flocal _ | Fpvar (_, _) | Fglob (_, _) - | Fop (_, _) -> f + | Fop (_, _) -> f_hash f (* FIXME: maybe do these cases as well? *) + in Why3.Hashcons.combine hnode (ty_hash f.f_ty) in - doit {level = 0; subst = EcSubst.empty} f - - (* FIXME: Check that this does not incur false positives *) - let hash_form (f: form) = - match Map.find_opt f.f_tag !known_hashes with - | Some hash -> hash - | None -> let fnorm = to_debruijn f in - form_storage := Map.add f.f_tag fnorm !form_storage; - known_hashes := Map.add f.f_tag fnorm.f_tag !known_hashes; - fnorm.f_tag -end + let res = doit {level = 0; subst = EcSubst.empty} f in + clean_bruijn_idents (); + res + +end) (* -------------------------------------------------------------------- *) type circuit_conversion_call = [ @@ -605,9 +601,10 @@ let circuit_of_form (f_ : EcAst.form) : circuit = + let module Htbl = AInvFHashtbl(struct let hyps = hyps end) in + (* Form level cache, local to each high-level call *) - let cache : (int, circuit) Map.t ref = ref Map.empty in - let fhash = AInvFHash.hash_form in + let cache : circuit Htbl.t = Htbl.create 700 in let op_cache : circuit Mp.t ref = ref Mp.empty in let redmode = circ_red hyps in let env = toenv hyps in @@ -710,7 +707,9 @@ let circuit_of_form circ end | Fapp (f, fs) -> - begin match Map.find_opt (fhash f_) !cache with (* TODO: Maybe add cache statistics? *) + (* TODO: Maybe add cache statistics? *) + (* TODO: Maybe cache all forms *) + begin match Htbl.find_opt cache f_ with | Some circ -> circ | None -> let circ = begin match f with @@ -769,7 +768,7 @@ let circuit_of_form circuit_compose f_c fcs end in - cache := Map.add (fhash f_) circ !cache; + Htbl.add cache f_ circ; circ end @@ -1170,4 +1169,3 @@ let circuit_state_of_hyps ?(strict = false) ?(use_mem = false) ?(st = empty_stat let clear_translation_caches () = EcLowCircuits.reset_backend_state (); - AInvFHash.nuke_state_from_orbit () diff --git a/tests/circuit_test.ec b/tests/circuit_test.ec index b1b73eb111..24814834bc 100644 --- a/tests/circuit_test.ec +++ b/tests/circuit_test.ec @@ -44,7 +44,7 @@ realize tolistP by auto. realize oflistP by rewrite /bool2bits /bits2bool;smt(size_eq1). realize ofintP by admit. realize touintP by admit. -realize tosintP by move => bv => //. +realize tosintP by done. realize gt0_size by done. op (+^) : W -> W -> W. @@ -87,62 +87,45 @@ qed. lemma W8_xor_ext (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. proof. proc. -extens [a] : (wp; skip; smt()). -(* FIXME : while debugging fhash admit. *) +(* extens [a] : (wp; skip; smt()). *) +(* FIXME : while debugging fhash *) +admit. (* *) +qed. + +lemma W8_xor_circuit (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. by proc; circuit. qed. lemma W8_xor_simp (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. proof. -proc. -circuit simplify. trivial. (* admit. *) +by proc; circuit simplify; trivial. qed. - - lemma W8_xor_fail_equiv (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ zero]. proof. proc. -circuit. (* Fails *) -qed. +fail circuit. (* Fails *) +abort. + lemma W8_xor_fail_translate (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ non_translate zero]. proof. proc. -circuit. (* Fails *) -qed. - +fail circuit. (* Fails *) +abort. lemma W8_xor_ext2 (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. proof. -proc. -admit. -(* extens [a] : circuit. *) +by proc; extens [a] : circuit. qed. lemma W8_xor_ext_simp (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. proof. proc. -(* extens [a] : by circuit simplify; trivial. (* FIXME: without by does not work *) *) admit. +extens [a] : by circuit simplify; trivial. (* FIXME: without by does not work *) qed. - -(* -lemma xor_0 (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b /\ a_ = b_ ==> res = of_int 0]. -proof. - proc. - proc change 1 : { c <- b +^ a; }. - wp. skip. move => &h1 &h2. - have : a{h1} = a_ by admit. - have : b{h1} = b_ by admit. - move => A B [] C D. - have : a{h2} = a_ by smt(). - have : b{h2} = b_ by smt(). - (* move : A B C D. (* Comment or uncomment this line for different modes of working *) *) - bdep solve. -bdep solve. -qed. -*) lemma xor_com (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b /\ a_ = b_ ==> res = b_ +^ a_]. From 9b111722857ab43aaf3bfac306121acc05f15769 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Mon, 9 Feb 2026 12:54:58 +0000 Subject: [PATCH 011/145] Fixed merge problems + nits on error printing --- src/ecCircuits.ml | 11 +++-------- src/ecCircuits.mli | 1 - src/ecEnv.ml | 2 +- src/ecScope.ml | 2 +- 4 files changed, 5 insertions(+), 11 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index d8a246b5a9..2bc4f7713c 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -155,7 +155,6 @@ end) (* -------------------------------------------------------------------- *) type circuit_conversion_call = [ | `Convert of form - | `Op of path | `ToArg of form | `ExpandIter of form * form list | `Instr of instr @@ -257,7 +256,6 @@ let rec pp_circ_error ppe fmt (err: circuit_error) = | `ToArg f -> Format.fprintf fmt "conversion to arg of form %a" (pp_form ppe) f | `ExpandIter (f, args) -> Format.fprintf fmt "expansion of iter %a(%a)" (pp_form ppe) f (pp_list ", " (pp_form ppe)) args | `Instr inst -> Format.fprintf fmt "processing of instruction %a" (pp_instr ppe) inst - | `Op pth -> Format.fprintf fmt "translating operator at path %a" pp_path pth | `Memenv (m, mt) -> Format.fprintf fmt "entering memory %a : %a" (pp_mem ppe) m (pp_memtype ppe) mt end @@ -630,6 +628,7 @@ let circuit_of_form let res = fapply_safe op args in res in + let rec arg_of_form (st: state) (f: form) : arg = try match f.f_ty with @@ -682,11 +681,7 @@ let circuit_of_form op | None -> if op_is_base env pth then - let circ = try - circuit_of_op env pth - with - | CircError err -> propagate_circ_error (`Op pth) err - in + let circ = circuit_of_op env pth in op_cache := Mp.add pth circ !op_cache; circ else @@ -990,7 +985,7 @@ let instrs_equiv if not (List.is_empty rglobs && List.is_empty wglobs) then circ_error CantReadWriteGlobs; - if not (List.for_all (EcTypes.is_loc |- fst) (rd @ wr)) then + if not (List.for_all (EcTypes.is_loc -| fst) (rd @ wr)) then circ_error CantReadWriteGlobs; let inputs = List.map (fun (pv, ty) -> { v_name = EcTypes.get_loc pv; v_type = ty; }) (rd @ wr) in diff --git a/src/ecCircuits.mli b/src/ecCircuits.mli index edf18c8828..2d99af5327 100644 --- a/src/ecCircuits.mli +++ b/src/ecCircuits.mli @@ -13,7 +13,6 @@ module Map = Batteries.Map (* -------------------------------------------------------------------- *) type circuit_conversion_call = [ | `Convert of form - | `Op of path | `ToArg of form | `ExpandIter of form * form list | `Instr of instr diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 11e45c0e0f..fbeefc739c 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -3706,7 +3706,7 @@ module Theory = struct Some (Th_axiom (x, { ax with ax_kind = `Axiom (tags, true) })) | Th_addrw (p, ps, lc) -> - let ps = List.filter ((not) |- inclear |- oget |- EcPath.prefix) ps in + let ps = List.filter ((not) -| inclear -| oget -| EcPath.prefix) ps in if List.is_empty ps then None else Some (Th_addrw (p, ps,lc)) | Th_auto ({ axioms } as auto_rl) -> diff --git a/src/ecScope.ml b/src/ecScope.ml index 3f8bc46f3e..f898d045d2 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -3004,7 +3004,7 @@ module Circuit = struct let operator, _ = EcEnv.Op.lookup op.operator.pl_desc env in let name = - let suffix = List.map (EcPath.tolist |- proj3_1) types in + let suffix = List.map (EcPath.tolist -| proj3_1) types in let suffix = List.flatten suffix in String.concat "_" ("BVA" :: unloc op.name :: suffix) (* FIXME: not stable*) in From 08d87a3e63e6dff120be59a648e760ed72d2c3fa Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Mon, 9 Feb 2026 18:09:14 +0000 Subject: [PATCH 012/145] Fixing FIXMEs --- src/ecCircuits.ml | 102 ++++++++------- src/ecCircuits.mli | 10 +- src/ecLowCircuits.ml | 296 ++++++++++++------------------------------- src/phl/ecPhlBDep.ml | 50 ++------ 4 files changed, 145 insertions(+), 313 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 2bc4f7713c..769cc2506e 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -27,8 +27,6 @@ let circ_red (hyps: hyps) = let base_red = EcReduction.full_red in `No) } -(* FIXME: should change to a decent direct hash of this + store the forms *) -(* also move the cache here? *) module AInvFHashtbl(Ctxt: sig val hyps: hyps end) = Batteries.Hashtbl.Make(struct type t = form @@ -149,7 +147,6 @@ module AInvFHashtbl(Ctxt: sig val hyps: hyps end) = Batteries.Hashtbl.Make(struc let res = doit {level = 0; subst = EcSubst.empty} f in clean_bruijn_idents (); res - end) (* -------------------------------------------------------------------- *) @@ -164,12 +161,10 @@ type circuit_conversion_call = [ type circuit_error = | MissingTyBinding of [`Ty of ty | `Path of path] | AbstractTyBinding of [`Ty of ty | `Path of path] -| InvalidArgument | MissingOpBinding of path | MissingOpSpec of path | IntConversionFailure -| DestrError of string (* FIXME: change this one *) -| MissingOpBody of path (* FIXME: rename? *) +| MissingOpBody of path | CantConvertToConstant | CantReadWriteGlobs | BadFormForArg of form @@ -185,7 +180,7 @@ type circuit_error = | `Hoare | `Instr ] -| PropagateError of circuit_conversion_call * circuit_error (* FIXME: make this lazy *) +| PropagateError of circuit_conversion_call * circuit_error exception CircError of circuit_error @@ -195,6 +190,37 @@ let circ_error (err: circuit_error) = let propagate_circ_error (call: circuit_conversion_call) (err: circuit_error) = raise (CircError (PropagateError (call, err))) +(* FIXME: move this to EcPrinting maybe? *) +let pp_op_kind (fmt: Format.formatter) (opk: EcFol.op_kind) : unit = + Format.fprintf fmt "%s" + (match opk with + | `Map_set -> "Map_set" + | `Real_le -> "Real_le" + | `Int_le -> "Int_le" + | `Iff -> "Iff" + | `Int_opp -> "Int_opp" + | `Int_lt -> "Int_lt" + | `Int_pow -> "Int_pow" + | `And `Asym -> "And (&&)" + | `And `Sym -> "And (/\\)" + | `Map_cst -> "Map_cst" + | `False -> "False" + | `Eq -> "Eq" + | `True -> "True" + | `Int_mul -> "Int_mul" + | `Real_inv -> "Real_inv" + | `Real_add -> "Real_add" + | `Int_edivz -> "Int_edivz" + | `Or `Asym -> "Or (||)" + | `Or `Sym -> "Or (\\/)" + | `Not -> "Not" + | `Int_add -> "Int_add" + | `Map_get -> "Map_get" + | `Real_lt -> "Real_lt" + | `Real_opp -> "Real_opp" + | `Real_mul -> "Real_mul" + | `Imp -> "Imp") + let rec pp_circ_error ppe fmt (err: circuit_error) = let open EcPrinting in match err with @@ -210,7 +236,6 @@ let rec pp_circ_error ppe fmt (err: circuit_error) = | `Path pth -> Format.fprintf fmt "type at path %a" pp_path pth | `Ty ty -> Format.fprintf fmt "type %a" (pp_type ppe) ty end - | InvalidArgument -> assert false | MissingOpBinding pth -> Format.fprintf fmt "Missing op binding for operator at path %a" pp_path pth | MissingOpSpec pth -> @@ -218,7 +243,6 @@ let rec pp_circ_error ppe fmt (err: circuit_error) = | IntConversionFailure -> (* FIXME: check that this actually prints the form, otherwise add it *) Format.fprintf fmt "Failed to convert form to concrete integer" - | DestrError _ -> assert false | MissingOpBody pth -> Format.fprintf fmt "No body for operator at path %a" pp_path pth | CantConvertToConstant -> @@ -231,16 +255,9 @@ let rec pp_circ_error ppe fmt (err: circuit_error) = Format.fprintf fmt "Failed circuit conversion due to: "; begin match reason with | `Int -> Format.fprintf fmt "Encountered unexpected integer (maybe you are missing a binding?)" - | `OpK opk -> Format.fprintf fmt "Don't know how to translate op kind: %a" (fun _ _ -> assert false) opk + | `OpK opk -> Format.fprintf fmt "Don't know how to translate op kind: %a" pp_op_kind opk | `Op pth -> Format.fprintf fmt "Don't know how to convert operator at path %a to circuit (not concrete and does not match any known operator kind)" pp_path pth - | `Quantif qnt -> - Format.fprintf fmt "Encountered unexpected quantifier %s" - (* FIXME: put into pp_quantif function *) - begin match qnt with - | Lforall -> "Forall" - | Lexists -> "Exists" - | Llambda -> "Lambda" - end + | `Quantif qnt -> Format.fprintf fmt "Encountered unexpected quantifier %s" (string_of_quant qnt) | `Match -> Format.fprintf fmt "Conversion of match statements not supported" | `Glob -> Format.fprintf fmt "Global variables not supported in conversion" | `ModGlob -> Format.fprintf fmt "Conversion of module globals not supported" @@ -383,7 +400,7 @@ module BitstringOps = struct | _args -> assert false (* Should be caught by EC typechecking + binding correctness *) end | {size = (_, None); type_=ty}, `OfInt -> - circ_error (AbstractTyBinding (`Path ty)) (* FIXME: check this, might want to add generic path -> ty conversion *) + circ_error (AbstractTyBinding (`Path ty)) | _bs, `To -> assert false (* doesn't translate to circuit *) | _bs, `ToSInt -> assert false (* doesn't translate to circuit *) | _bs, `ToUInt -> assert false (* doesn't translate to circuit *) @@ -517,7 +534,7 @@ let circuit_of_op_with_args (env: env) (p: path) (args: arg list) : circuit = | `Bitstring bsbnd -> circuit_of_bsop env (`BSBinding bsbnd) args | `Array abnd -> circuit_of_arrayop env (`ABinding abnd) args | `BvOperator bvbnd -> circuit_of_parametric_bvop env (`BvBind bvbnd) args - | `Circuit _c -> assert false (* FIXME PR: Do we want to have parametric operators coming from the spec? *) + | `Circuit _c -> assert false (* FIXME PR: Do we want to have parametric operators coming from the spec? *) let type_has_bindings (env: env) (t: ty) : bool = @@ -623,7 +640,7 @@ let circuit_of_form | OB_oper (Some (OP_Plain f)) -> f | _ -> - circ_error (MissingOpBody pth) (* FIXME: how to actually print this? *) + circ_error (MissingOpBody pth) in let res = fapply_safe op args in res @@ -632,8 +649,7 @@ let circuit_of_form let rec arg_of_form (st: state) (f: form) : arg = try match f.f_ty with - (* FIXME: check this (does this corrently detect ints?) *) - | t when t.ty_node = EcTypes.tint.ty_node -> arg_of_zint (int_of_form f) + | t when EcReduction.EqTest.is_int env t -> arg_of_zint (int_of_form f) | t when type_has_bindings env t -> let f = doit st f in arg_of_circuit f @@ -721,7 +737,6 @@ let circuit_of_form | {f_node = Fop _} -> (* Assuming correct types coming from EC *) - (* FIXME: Add some extra info about errors when something here throws *) begin match EcFol.op_kind (destr_op f |> fst), fs with | Some `Eq, [f1; f2] -> let c1 = doit st f1 in @@ -768,12 +783,13 @@ let circuit_of_form end | Fquant (qnt, binds, f) -> - let binds = List.map (fun (idn, t) -> (idn, gty_as_ty t |> ctype_of_ty env)) binds in (* FIXME *) + (* FIXME Does this type conversion make sense? *) + let binds = List.map (fun (idn, t) -> (idn, gty_as_ty t |> ctype_of_ty env)) binds in begin match qnt with | Lforall | Llambda -> circ_lambda_oneshot st binds (fun st -> doit st f) (* FIXME: look at this interaction *) | Lexists -> circ_error (CantConvertToCirc (`Quantif qnt)) - (* TODO: figure out how to handle quantifiers. Maybe just dont? *) + (* FIXME: Do we want to handle existentials? *) end | Fproj (f, i) -> @@ -830,7 +846,10 @@ let circuit_of_form | FequivF _ | FequivS _ | FeagerF _ - | Fpr _ -> circ_error (CantConvertToCirc `Hoare) (* FIXME: do we want to allow conversion of hoare statements? *) + | Fpr _ -> circ_error (CantConvertToCirc `Hoare) + (* FIXME: do we want to allow conversion of hoare statements? + Probably not at this point + *) end with | CircError e -> @@ -906,7 +925,8 @@ let circuit_simplify_equality ?(do_time = true) ~(st: state) ~(hyps: hyps) ~(pre false end -(* FIXME: add support for spec bindings for abstract/opaque operators *) +(* FIXME: add support for spec bindings for abstract/opaque operators + = convert from Fop rather than from op body *) let circuit_of_path (st: state) (hyps: hyps) (p: path) : circuit = let f = EcEnv.Op.by_path p (toenv hyps) in let f = match f.op_kind with @@ -925,15 +945,11 @@ let vars_of_memtype (mt : memtype) = let process_instr (hyps: hyps) (mem: memory) ~(st: state) (inst: instr) : state = -(* EcEnv.notify env `Debug "[W] Processing : %a@." (EcPrinting.pp_instr (EcPrinting.PPEnv.ofenv env)) inst; *) + EcEnv.notify (toenv hyps) `Debug "[W] Processing : %a@." (EcPrinting.pp_instr (EcPrinting.PPEnv.ofenv (toenv hyps))) inst; (* let start = Unix.gettimeofday () in *) try match inst.i_node with | Sasgn (LvVar (PVloc v, _ty), e) -> -(* - EcEnv.notify env `Debug "Assigning form %a to var %s@\n" - (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (LDecl.toenv hyps))) (form_of_expr mem e) v; -*) let c = ((ss_inv_of_expr mem e).inv |> circuit_of_form st hyps) in let st = update_state_pv st mem v c in st @@ -1020,8 +1036,8 @@ let instrs_equiv circ_equiv circ1 circ2 ) -(* FIXME: change memory -> memenv *) -let state_of_prog ?(close = false) (hyps: hyps) (mem: memory) ?(st: state = empty_state) (proc: instr list) : state = +(* FIXME: change memory -> memenv Why? *) +let state_of_prog ?(close = false) (hyps: hyps) (mem: memory) ~(st: state) (proc: instr list) : state = let st = List.fold_left (fun st -> process_instr hyps mem ~st) st proc in @@ -1076,7 +1092,7 @@ let state_get = state_get_pv let state_get_opt = state_get_pv_opt let state_get_all = fun st -> state_get_all_pv st |> List.snd -let circuit_state_of_memenv ~(st: state) (env:env) ((m, mt) as me: memenv) : state = +let circuit_state_of_memenv ?(st: state = empty_state) (env:env) ((m, mt) as me: memenv) : state = match mt with | (Lmt_concrete Some {lmt_decl=decls}) -> let bnds = List.map (fun {ov_name; ov_type} -> @@ -1091,22 +1107,14 @@ let circuit_state_of_memenv ~(st: state) (env:env) ((m, mt) as me: memenv) : sta open_circ_lambda_pv st (List.filter_map identity bnds) | Lmt_concrete None -> st -(* Generally called without the optional argument, here just to see if we need it, - maybe remove later? FIXME *) -let circuit_state_of_hyps ?(strict = false) ?(use_mem = false) ?(st = empty_state) hyps : state = +let circuit_state_of_hyps ?(st: state = empty_state) ?(strict = false) (hyps: hyps) : state = let env = toenv hyps in let ppe = EcPrinting.PPEnv.ofenv env in let st = List.fold_left (fun st (id, lk) -> EcEnv.notify env `Debug "Processing hyp: %s@." (id.id_symb); match lk with -(* FIXME: Reasoning here is that we do not directly process program variables in the hyps - They are either given a value by assignment in the program or if they are used - before that they are implicitly initialized to BAD - - FIXME: Find a good way to handle this -*) - - | EcBaseLogic.LD_mem mt when use_mem -> circuit_state_of_memenv ~st env (id, mt) + (* If there is a memory, add all the variables from that memory into the translation state *) + | EcBaseLogic.LD_mem mt -> circuit_state_of_memenv ~st env (id, mt) (* Initialized variable. Check if body is convertible to circuit, if not just process it as uninitialized. diff --git a/src/ecCircuits.mli b/src/ecCircuits.mli index 2d99af5327..08db055905 100644 --- a/src/ecCircuits.mli +++ b/src/ecCircuits.mli @@ -23,12 +23,10 @@ type circuit_conversion_call = [ type circuit_error = | MissingTyBinding of [`Ty of ty | `Path of path] | AbstractTyBinding of [`Ty of ty | `Path of path] -| InvalidArgument | MissingOpBinding of path | MissingOpSpec of path | IntConversionFailure -| DestrError of string (* FIXME: change this one *) -| MissingOpBody of path (* FIXME: rename? *) +| MissingOpBody of path | CantConvertToConstant | CantReadWriteGlobs | BadFormForArg of form @@ -86,12 +84,12 @@ val circ_simplify_form_bitstring_equality : ?pres:circuit list -> hyps -> form -> form (* Proc processors *) -val state_of_prog : ?close:bool -> hyps -> memory -> ?st:state -> instr list -> state +val state_of_prog : ?close:bool -> hyps -> memory -> st:state -> instr list -> state val instrs_equiv : hyps -> memenv -> ?keep:EcPV.PV.t -> state -> instr list -> instr list -> bool val process_instr : hyps -> memory -> st:state -> instr -> state -val circuit_state_of_memenv : st:state -> env -> memenv -> state -val circuit_state_of_hyps : ?strict:bool -> ?use_mem:bool -> ?st:state -> hyps -> state +val circuit_state_of_memenv : ?st:state -> env -> memenv -> state +val circuit_state_of_hyps : ?st:state -> ?strict:bool -> hyps -> state (* Check for uninitialized inputs *) val circuit_has_uninitialized : circuit -> int option diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index 32aaae7d5c..d965c0c98a 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -5,9 +5,6 @@ open EcDecl open EcIdent open EcMemory -(* FIXME: find a solution for the "if debug then" prints here, - since it cannot depend on EcEnv *) - (* -------------------------------------------------------------------- *) module C = struct include Lospecs.Aig @@ -211,10 +208,8 @@ module LospecsBack : CBackend = struct let reg_of_node_array : node array -> reg = fun x -> x let reg_of_node : node -> reg = fun x -> [| x |] - (* FIXME: throws array error, error handling TODO - Maybe leave as is? This throwing is a programming error - not a user error - *) + + (* If this throws it is a programming error *) let node_of_reg : reg -> node = fun x -> x.(0) let reg_of_zint ~(size: int) (v: zint) : reg = @@ -275,7 +270,6 @@ module LospecsBack : CBackend = struct with Invalid_argument _ -> raise (BadSlice `Set) - (* FIXME: Error handling *) let get (r: reg) (idx: int) = try r.(idx) @@ -304,7 +298,6 @@ module LospecsBack : CBackend = struct let bnand : node -> node -> node = C.nand let bnor : node -> node -> node = fun n1 n2 -> C.neg @@ C.or_ n1 n2 - (* FIXME: maybe convert to BigInt? *) let input_node ~id i = C.input (id, i) let input_of_size ?(offset = 0) ~id (i: int) = Array.init i (fun i -> C.input (id, offset + i)) @@ -516,7 +509,7 @@ module type CircuitInterface = sig val open_circ_lambda : state -> (ident * ctype) list -> state val open_circ_lambda_pv : state -> ((memory * symbol) * ctype) list -> state val close_circ_lambda : state -> state - val circ_lambda_oneshot : state -> (ident * ctype) list -> (state -> circuit) -> circuit (* FIXME: rename or redo *) + val circ_lambda_oneshot : state -> (ident * ctype) list -> (state -> circuit) -> circuit val set_logger : state -> (string -> unit) -> state val log : state -> string -> unit @@ -549,13 +542,9 @@ module type CircuitInterface = sig val circ_of_zint : size:int -> zint -> circ val circuit_of_zint : size:int -> zint -> circuit - (* Type constructors *) - val new_cbool_inp : ?name:[`Str of string | `Idn of ident] -> unit -> circ * cinp - val new_cbitstring_inp : ?name:[`Str of string | `Idn of ident] -> int -> circ * cinp - val new_carray_inp : ?name:[`Str of string | `Idn of ident] -> int -> int -> circ * cinp - val new_ctuple_inp : ?name:[`Str of string | `Idn of ident] -> ctype list -> circ * cinp - + (* Construct an input *) + val new_input_circuit : ?name:[`Str of string | `Idn of ident | `Bad] -> ctype -> circ * cinp val input_of_ctype : ?name:[`Str of string | `Idn of ident | `Bad] -> ctype -> circuit (* Aggregation functions *) @@ -631,10 +620,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = type circuit = circ cfun (* Exceptions *) - (* FIXME : Might signal a programming mistake? *) - (* FIXME : Might be guarded by EC typechecking *) - (* FIXME : Might need a parameter to specify case *) - type circconstructor = | Slice of { slice_size: int; bitstring_size: int; offset: int } | ASlice of { slice_size: int; container_size: int; offset: int } @@ -763,7 +748,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let state_get_pv_opt (st: state) (m:memory) (s: symbol) : circuit option = Option.bind (Map.find_opt (m, s) st.pv_ids) (fun id -> Mid.find_opt id st.circs) - (* FIXME : Error handling *) let state_get_pv (st: state) (m: memory) (pv: symbol) : circuit = match state_get_pv_opt st m pv with | Some circ -> circ @@ -825,7 +809,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = {st with lambdas = lambdas; circs = Mid.map (fun (c, cinps) -> (c, inps @ cinps)) st.circs } - (* FIXME: Rename. *) let circ_lambda_oneshot (st: state) (bnds : (ident * ctype) list) (c: state -> circuit) : circuit = let st' = open_circ_lambda st bnds in let (c, inps) = c st' in @@ -839,7 +822,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = end (* Inputs helper functions *) - (* FIXME: maybe do something a bit more principled here ? *) + (* FIXME: maybe do something a bit more principled here ? After merge *) let merge_inputs (cs: cinp list) (ds: cinp list) : cinp list = (* if List.for_all2 (fun {id=id1; type_=ct1} {id=id2; type_=ct2} -> id1 = id2 && ct1 = ct2) cs ds then cs *) if cs = ds then cs @@ -922,29 +905,15 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = 0 szs (* Convert a circuit's output to a given circuit type *) - (* FIXME: rewrite and simplify this *) let convert_type (t: ctype) (({type_;_} as c, inps) as circ: circuit) : circuit = - match t, type_ with - (* When types are the same, do nothing *) - | (CArray {width=w; count=n}, CArray {width=w'; count=n'}) when w = w' && n = n' -> circ - | (CBitstring n, CBitstring n') when n = n' -> circ - | (CTuple tys, CTuple tys') when List.for_all2 (=) tys tys' -> circ - | (CBool, CBool) -> circ - - (* Bistring => Type conversions *) - | (CArray {width=w; count=n}, CBitstring n') when w * n = n' -> { c with type_ = t }, inps - | (CTuple tys, CBitstring n) when List.sum @@ List.map size_of_ctype tys = n -> { c with type_ = t}, inps - | (CBool, CBitstring 1) -> { c with type_ = t}, inps - - (* Type => Bitstring conversions *) - | (CBitstring n, CArray {width=w'; count=n'}) when n = w' * n' -> { c with type_ = t}, inps - | (CBitstring n, CTuple tys') when n = List.sum @@ List.map size_of_ctype tys' -> { c with type_ = t}, inps - | (CBitstring 1, CBool) -> {c with type_ = t}, inps - - (* Fail on everything else *) - | _ -> - lowcircerror CircTyConversionFailure - + if t = type_ then circ else begin + if (size_of_ctype t = size_of_ctype type_) + then + {c with type_}, inps + else + lowcircerror CircTyConversionFailure + end + let can_convert_input_type (t1: ctype) (t2: ctype) : bool = size_of_ctype t1 = size_of_ctype t2 @@ -955,58 +924,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = else lowcircerror CircTyConversionFailure ) inps tys - (* Input Helper Functions *) - (* FIXME: maybe change name from inp -> input? *) - let new_cbool_inp ?(name = `Str "input") () : circ * cinp = - let id, inp = match name with - | `Str name -> let id = EcIdent.create name |> tag in - id, Backend.input_node ~id 0 - | `Idn idn -> let id = tag idn in - id, Backend.input_node ~id 0 - | `Bad -> - -1, Backend.bad - in - { reg = Backend.reg_of_node inp; type_= CBool }, { type_ = CBool; id; } - - let new_cbitstring_inp ?(name = `Str "input") (sz: int) : circ * cinp = - let id, r = match name with - | `Str name -> let id = EcIdent.create name |> tag in - id, Backend.input_of_size ~id sz - | `Idn idn -> let id = tag idn in - id, Backend.input_of_size ~id sz - | `Bad -> - -1, Backend.bad_reg sz - in - { reg = r; type_ = CBitstring sz}, - { type_ = CBitstring sz; id; } - - let new_cbitstring_inp_reg ?name (sz: int) : flatcirc * cinp = - let c, inp = new_cbitstring_inp ?name sz in - (c.reg, inp) - - let new_carray_inp ?(name = `Str "input") (el_sz: int) (arr_sz: int) : circ * cinp = - let id, arr = match name with - | `Str name -> let id = EcIdent.create name |> tag in - id, Backend.input_of_size ~id (el_sz * arr_sz) - | `Idn idn -> let id = tag idn in - id, Backend.input_of_size ~id (el_sz * arr_sz) - | `Bad -> - -1, Backend.bad_reg (el_sz * arr_sz) - in - { reg = arr; type_ = CArray {width=el_sz; count=arr_sz}}, - { type_ = CArray {width=el_sz; count=arr_sz}; id; } - - let new_ctuple_inp ?(name = `Str "input") (tys: ctype list) : circ * cinp = - let id, tp = match name with - | `Str name -> let id = EcIdent.create name |> tag in - id, Backend.input_of_size ~id (List.sum @@ List.map size_of_ctype tys) - | `Idn idn -> let id = tag idn in - id, Backend.input_of_size ~id (List.sum @@ List.map size_of_ctype tys) - | `Bad -> - -1, Backend.bad_reg (List.sum @@ List.map size_of_ctype tys) - in - { reg = tp; type_ = CTuple tys}, - { type_ = CTuple tys; id; } let input_of_ctype ?(name : [`Str of string | `Idn of ident | `Bad ] = `Str "input") (ct: ctype) : circuit = let id, c = match name with @@ -1019,6 +936,10 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = in { reg = c; type_ = ct; }, [{ id; type_ = ct; }] + let new_input_circuit ?(name = `Str "input") (ty: ctype) : circ * cinp = + let c, inps = input_of_ctype ~name ty in + c, List.hd inps + let circuit_true = {reg = Backend.reg_of_node Backend.true_; type_ = CBool}, [] let circuit_false = {reg = Backend.reg_of_node Backend.false_; type_ = CBool}, [] @@ -1117,29 +1038,16 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let inps = merge_inputs_list (List.snd args) in (circ, inps) - (* Circuit Lambda functions *) - (* Functions for dealing with uninitialized inputs *) let circuit_uninit (t: ctype) : circuit = - match t with - | CTuple szs -> - let ctp, _cinp = new_ctuple_inp ~name:`Bad szs in - ((ctp, []) :> circuit) - | CArray {width=el_sz; count=arr_sz} -> - let carr, _cinp = new_carray_inp ~name:`Bad el_sz arr_sz in - ((carr, []) :> circuit) - | CBitstring sz -> - let c, _cinp = new_cbitstring_inp ~name:`Bad sz in - ((c, []) :> circuit) - | CBool -> - let c, _cinp = new_cbool_inp ~name:`Bad () in - ((c, []) :> circuit) + let c, _ = input_of_ctype ~name:`Bad t in + c, [] let circuit_has_uninitialized (c: circuit) : int option = Backend.have_bad (fst c).reg let circ_equiv ?(pcond:circuit option) ((c1, inps1): circuit) ((c2, inps2): circuit) : bool = - let pcond = Option.map (convert_type CBool) pcond in (* Try to convert to bool *) (* FIXME: duplicated check *) + let pcond = Option.map (convert_type CBool) pcond in (* Try to convert to bool *) let pcc = match pcond with | Some ({reg = b; type_ = CBool}, pcinps) -> Backend.apply (unify_inputs_renamer inps1 pcinps) (Backend.node_of_reg b) @@ -1287,10 +1195,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = - Structural equality check - SMT check - FIXME: might be unsound on very specific cases where a precondition applies - on only part of the input (the part thats left over after structural equality) - check if this is the case. - Does not affect current examples => MLKEM *) (* Batches circuit checks by dependencies. Assumes equivalent checks are contiguous *) let batch_checks @@ -1367,49 +1271,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let pre = List.fold_left circuit_and circuit_true compat_pres in circuit_or (circuit_not pre) post - (* Assumes all the pre and post have been split, takes all the pres and one post *) - (* DEAD CODE? - let fillet_taut (pres: (circuit * Backend.Deps.dep) list) ((post_circ, post_inps): circuit) : bool = - let pres = List.map (fun ((c, inps), d) -> - assert (inputs_contained inps post_inps); - ((c, post_inps), d) - ) pres in - (* FIXME: removable *) - assert (List.for_all (fun ((_c, inps), _) -> inps = post_inps) pres); - assert (List.for_all (fun (({type_;_}, _), _) -> type_ = CBool) pres); - assert (post_circ.type_ = CBool); - let d = Backend.(Deps.dep_of_node (node_of_reg post_circ.reg)) in - let compat_pres = List.filteri (fun i (c, pre_dep) -> - Backend.Deps.dep_contained pre_dep d - ) pres in - let compat_pres = List.fst compat_pres in - let node_post = Backend.node_of_reg post_circ.reg in - let nodes_pre = List.map (fun (c, _) -> Backend.node_of_reg c.reg) compat_pres in - let node_post, shifts = Backend.Deps.excise_bit node_post in - (* FIXME: do this in a more principled way (the types) after merge *) - let inps = List.filter_map (fun {id; _} -> - match Map.find_opt id shifts with - | Some (low, hi) -> Some {id; type_ = CBitstring (hi - low + 1)} - | None -> None - ) post_inps in - let inp_map = fun (id, v) -> - match Map.find_opt id shifts with - | Some (min, max) -> - let new_id = v - min in - assert (new_id <= max); - Some (id, v - min) - | None -> assert false - in - let nodes_pre = Backend.Deps.rename_inputs inp_map (Backend.reg_of_node_list nodes_pre) in - let pre = List.fold_left Backend.band Backend.true_ (Backend.node_list_of_reg nodes_pre) |> Backend.reg_of_node in - let pre = {reg = pre; type_ = CBool}, inps in - let post = Backend.reg_of_node node_post in - let post = {reg = post; type_ = CBool}, inps in - let cond = circuit_or (circuit_not pre) post in - circ_taut cond - *) - - let sublimate_inputs ((c, cinps): circuit) : circuit = + let sublimate_inputs ((c, cinps): circuit) : circuit = assert (c.type_ = CBool); let node_c = Backend.node_of_reg c.reg in let node_c, shifts = Backend.Deps.excise_bit node_c in @@ -1423,7 +1285,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = { reg = c; type_ = CBool}, inps - (* Review later? *) + (* FIXME: Review later? *) let collapse_lanes ?(logger : (string -> unit) option) (lanes: circuit list) = (* Circuit structural equality after renaming *) let (===) (c1: circ) (c2: circ) : bool = @@ -1469,8 +1331,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = - Checks for structural equality of circuits - SMT check for any remainings ones *) - (* FIXME: current lane collapse is always quadratic, add toggle option? - or remove arg *) let fillet_tauts ?(logger: (string -> unit) option) (pres: circuit list) (posts: circuit list) : bool = (* Assumes everything is single bit outputs. FIXME: does it? *) let posts = List.filter_map (fun ((postc, _) as post) -> @@ -1717,154 +1577,154 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let circuit_of_bvop (op: EcDecl.crb_bvoperator) : circuit = match op with | { kind = `Add (_, Some size) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.add c1 c2 )}, [inp1; inp2] | { kind = `Sub (_, Some size) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.sub c1 c2)}, [inp1; inp2] | { kind = `Mul (_, Some size) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.mul c1 c2)}, [inp1; inp2] | { kind = `Div ((_, Some size), false) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.udiv c1 c2)}, [inp1; inp2] | { kind = `Div ((_, Some size), true) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.sdiv c1 c2)}, [inp1; inp2] | { kind = `Rem ((_, Some size), false) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.umod c1 c2)}, [inp1; inp2] | { kind = `Rem ((_, Some size), true) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.smod c1 c2)}, [inp1; inp2] (* Should this be mod or rem? TODO FIXME*) | { kind = `Shl (_, Some size) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.lshl c1 c2)}, [inp1; inp2] | { kind = `Shr ((_, Some size), false) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.lshr c1 c2)}, [inp1; inp2] | { kind = `Shr ((_, Some size), true) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.ashr c1 c2)}, [inp1; inp2] | { kind = `Shls ((_, Some size1), (_, Some size2)) } -> - let c1, inp1 = new_cbitstring_inp_reg size1 in - let c2, inp2 = new_cbitstring_inp_reg size2 in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size1) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size2) in {type_ = CBitstring size1; reg = (Backend.lshl c1 c2)}, [inp1; inp2] | { kind = `Shrs ((_, Some size1), (_, Some size2), false) } -> - let c1, inp1 = new_cbitstring_inp_reg size1 in - let c2, inp2 = new_cbitstring_inp_reg size2 in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size1) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size2) in {type_ = CBitstring size1; reg = (Backend.lshr c1 c2)}, [inp1; inp2] | { kind = `Shrs ((_, Some size1), (_, Some size2), true) } -> - let c1, inp1 = new_cbitstring_inp_reg size1 in - let c2, inp2 = new_cbitstring_inp_reg size2 in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size1) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size2) in {type_ = CBitstring size1; reg = (Backend.ashr c1 c2)}, [inp1; inp2] | { kind = `Rol (_, Some size) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.rol c1 c2)}, [inp1; inp2] | { kind = `Ror (_, Some size) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.ror c1 c2)}, [inp1; inp2] | { kind = `And (_, Some size) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.land_ c1 c2)}, [inp1; inp2] | { kind = `Or (_, Some size) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.lor_ c1 c2)}, [inp1; inp2] | { kind = `Xor (_, Some size) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.lxor_ c1 c2)}, [inp1; inp2] | { kind = `Not (_, Some size) } -> - let c1, inp1 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.lnot_ c1)}, [inp1] | { kind = `Opp (_, Some size) } -> - let c1, inp1 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.opp c1)}, [inp1] | { kind = `Lt ((_, Some size), false) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBool; reg = Backend.reg_of_node (Backend.ult c1 c2)}, [inp1; inp2] | { kind = `Lt ((_, Some size), true) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBool; reg = Backend.reg_of_node (Backend.slt c1 c2)}, [inp1; inp2] | { kind = `Le ((_, Some size), false) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBool; reg = Backend.reg_of_node (Backend.ule c1 c2)}, [inp1; inp2] | { kind = `Le ((_, Some size), true) } -> - let c1, inp1 = new_cbitstring_inp_reg size in - let c2, inp2 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBool; reg = Backend.reg_of_node (Backend.sle c1 c2)}, [inp1; inp2] | { kind = `Extend ((_, Some size), (_, Some out_size), false) } -> (* assert (size <= out_size); *) - let c1, inp1 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in {type_ = CBitstring out_size; reg = (Backend.uext c1 out_size)}, [inp1] | { kind = `Extend ((_, Some size), (_, Some out_size), true) } -> (* assert (size <= out_size); *) - let c1, inp1 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in {type_ = CBitstring out_size; reg = (Backend.sext c1 out_size)}, [inp1] | { kind = `Truncate ((_, Some size), (_, Some out_sz)) } -> (* assert (size >= out_sz); *) - let c1, inp1 = new_cbitstring_inp_reg size in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in {type_ = CBitstring out_sz; reg = (Backend.trunc c1 out_sz)}, [inp1] | { kind = `Concat ((_, Some sz1), (_, Some sz2), (_, Some szo)) } -> (* assert (sz1 + sz2 = szo); *) - let c1, inp1 = new_cbitstring_inp_reg sz1 in - let c2, inp2 = new_cbitstring_inp_reg sz2 in + let {reg = c1;_}, inp1 = new_input_circuit (CBitstring sz1) in + let {reg = c2;_}, inp2 = new_input_circuit (CBitstring sz2) in {type_ = CBitstring szo; reg = (Backend.concat c1 c2)}, [inp1; inp2] | { kind = `A2B (((_, Some w), (_, Some n)), (_, Some m))} -> (* assert (n * w = m); *) - let c1, inp1 = new_carray_inp w n in - {c1 with type_ = CBitstring m}, [inp1] + let c, inp = new_input_circuit (CArray {width=w;count=n}) in + {c with type_ = CBitstring m}, [inp] | { kind = `B2A ((_, Some m), ((_, Some w), (_, Some n)))} -> (* assert (n * w = m); *) - let c1, inp1 = new_cbitstring_inp m in - {c1 with type_ = CArray {width=w; count=n}}, [inp1] + let c, inp = new_input_circuit (CBitstring m) in + {c with type_ = CArray {width=w; count=n}}, [inp] | { kind = `ASliceGet _ | `ASliceSet _ | `Extract _ | `Insert _ | `Map _ | `AInit _ | `Get _ | `Init _ } | _ diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index bc422f1eb7..1813ba823c 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -1,7 +1,5 @@ (* -------------------------------------------------------------------- *) open EcUtils -open EcIdent -open EcSymbols open EcAst open EcEnv open EcTypes @@ -18,12 +16,6 @@ module Set = Batteries.Set module Option = Batteries.Option (* -------------------------------------------------------------------- *) -(* FIXME: maybe remove this ? *) -exception BadTypeForConstructor -exception TyLookupError - -(* TODO: Refactor error printing and checking? Lots of duplicated code *) - let int_of_form = EcCircuits.int_of_form let time (env: env) (t: float) (msg: string) : float = @@ -31,31 +23,6 @@ let time (env: env) (t: float) (msg: string) : float = EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. t); new_t -(* - f => arr_t.init (fun i => f.(i + offset)) - Assumes f has an array type binding - Assumes f has enough positions so that - arr_t.size + offset < size f (as array) -*) -(* FIXME: error handdling for this function *) -let array_init_from_form (env: env) (f: form) ((arr_t, offset): qsymbol * BI.zint) : form = - let tpath = match EcEnv.Ty.lookup_opt arr_t env with - | None -> raise TyLookupError - | Some (path, decl) when List.length decl.tyd_params = 1 -> - path - | Some _ -> - raise BadTypeForConstructor - in - let get = match EcEnv.Circuit.lookup_array env f.f_ty with - | Some { get } -> get - | None -> circ_error (MissingTyBinding (`Ty f.f_ty)) - in - let init = EcEnv.Op.lookup_path (fst (tpath |> EcPath.toqsymbol), "init") env in - let idx = create "i" in - let f = f_lambda [(idx, GTty tint)] - (EcTypesafeFol.f_app_safe env get [f; f_int_add (f_local idx tint) (f_int offset)]) - in EcTypesafeFol.f_app_safe env init [f] - (* FIXME: move? V *) let form_list_from_iota (hyps: hyps) (f: form) : form list = match f.f_node with @@ -105,7 +72,7 @@ let rec destr_conj (hyps: hyps) (f: form) : form list = let process_pre ?(st : state option) (tc: tcenv1) (f: form) : state * circuit list = let env = FApi.tc1_env tc in let ppe = EcPrinting.PPEnv.ofenv env in - let hyps = FApi.tc1_hyps tc in (* FIXME: should target be specified here? *) + let hyps = FApi.tc1_hyps tc in (* Maybe move this to be a parameter and just supply it from outside *) let st = match st with @@ -210,7 +177,7 @@ let t_bdep_solve | FhoareS hs -> begin try let tm = Unix.gettimeofday () in let st = set_logger empty_state (EcEnv.notify env `Debug "%s") in - let st = circuit_state_of_hyps ~use_mem:true ~st hyps in + let st = circuit_state_of_hyps ~st hyps in let st, cpres = process_pre ~st tc (hs_pr hs).inv in let tm = time (toenv hyps) tm "Done with precondition processing" in @@ -225,18 +192,17 @@ let t_bdep_solve else tc_error (FApi.tc1_penv tc) "failed to verify postcondition" with - (* FIXME: not catching anything, redo *) | CircError err -> tc_error (FApi.tc1_penv tc) "circuit solve failed with error: %a" (pp_circ_error EcPrinting.PPEnv.(ofenv env)) err end | FequivS es -> begin try let tm = Unix.gettimeofday () in - (* FIXME: rework this *) let st = set_logger empty_state (EcEnv.notify env `Debug "%s") in + + let st = circuit_state_of_hyps ~st hyps in let st = circuit_state_of_memenv ~st (FApi.tc1_env tc) es.es_ml in let st = circuit_state_of_memenv ~st (FApi.tc1_env tc) es.es_mr in - (* let st = circuit_state_of_hyps ~st (FApi.tc1_hyps tc) in *) let st, cpres = process_pre ~st tc (es_pr es).inv in let tm = time (toenv hyps) tm "Done with precondition processing" in @@ -244,6 +210,7 @@ let t_bdep_solve (* Circuits from pvars are tagged by memory so we can just put everything in one state *) let st = state_of_prog hyps (fst es.es_ml) ~st es.es_sl.s_node in let tm = time (toenv hyps) tm "Done with left program circuit gen" in + let st = state_of_prog hyps (fst es.es_mr) ~st es.es_sr.s_node in let _tm = time (toenv hyps) tm "Done with right program circuit gen" in @@ -285,12 +252,11 @@ let t_bdep_simplify (tc: tcenv1) = begin try let m = fst hs.hs_m in let tm = Unix.gettimeofday () in - let st = circuit_state_of_hyps ~use_mem:true hyps in + let st = circuit_state_of_hyps hyps in let st = circuit_state_of_memenv ~st env hs.hs_m in let st, pres = process_pre ~st tc (hs_pr hs).inv in let tm = time env tm "Done with precondition processing" in - (* FIXME: line below throws, should handle exceptions *) let st = EcCircuits.state_of_prog ~st hyps (fst hs.hs_m) hs.hs_s.s_node in let post = EcCallbyValue.norm_cbv (circ_red hyps) hyps (hs_po hs).inv in @@ -311,7 +277,7 @@ let t_bdep_simplify (tc: tcenv1) = with CircError err -> tc_error (FApi.tc1_penv tc) "Circuit simplify failed with error: %a" (pp_circ_error EcPrinting.PPEnv.(ofenv env)) err end - | _ -> assert false (* FIXME : TODO *) + | _ -> assert false (* FIXME : Do we want to handle other cases before merge? *) (* ================ EXTENS TACTIC ==================== *) (* FIXME: Maybe move later? *) @@ -415,7 +381,7 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = in let ngoals = 1 lsl size in (* let ngoals = min ngoals 5 in *) - List.init ngoals (fun i -> (* FIXME FIXME this is bad *) + List.init ngoals (fun i -> let subst = EcPV.PVM.(add (tc1_env tc) (PVloc v.v_name) (fst hs.hs_m) (EcTypesafeFol.f_app_safe (tc1_env tc) of_int [f_int BI.(of_int i)]) empty) in From fc94b6cf0bd40d52d0d8c0383b97af8e0e50b096 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Tue, 10 Feb 2026 12:27:45 +0000 Subject: [PATCH 013/145] Moved map reference to inside function scope in hash --- src/ecCircuits.ml | 40 +++++++++++++++++++++------------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 769cc2506e..0e44a8eab5 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -32,31 +32,33 @@ module AInvFHashtbl(Ctxt: sig val hyps: hyps end) = Batteries.Hashtbl.Make(struc let equal f1 f2 = EcReduction.is_alpha_eq Ctxt.hyps f1 f2 - let bruijn_idents : (int, ident) Map.t ref = ref Map.empty - - let clean_bruijn_idents : unit -> unit = - fun () -> bruijn_idents := Map.empty - - let ident_of_debruijn_level (i: int) : ident = - match Map.find_opt i !bruijn_idents with - | Some id -> id - | None -> let id = create (string_of_int i) in - bruijn_idents := Map.add i id !bruijn_idents; - id - type state = { level: int; subst: EcSubst.subst; - } + } + + let hash (f: form) : int = + let bruijn_idents : (int, ident) Map.t ref = ref Map.empty in - let add_to_state (id: ident) (ty: ty) (st: state) = - let new_id = ident_of_debruijn_level st.level in - let level = st.level + 1 in - let subst = EcSubst.add_flocal st.subst id (f_local new_id ty) in - { level; subst }, new_id + let clean_bruijn_idents : unit -> unit = + fun () -> bruijn_idents := Map.empty + in + let ident_of_debruijn_level (i: int) : ident = + match Map.find_opt i !bruijn_idents with + | Some id -> id + | None -> let id = create (string_of_int i) in + bruijn_idents := Map.add i id !bruijn_idents; + id + in + + let add_to_state (id: ident) (ty: ty) (st: state) = + let new_id = ident_of_debruijn_level st.level in + let level = st.level + 1 in + let subst = EcSubst.add_flocal st.subst id (f_local new_id ty) in + { level; subst }, new_id + in - let hash (f: form) : int = let rec doit (st: state) (f: form) : int = let hnode = match f.f_node with | Fquant (qnt, bnds, f) -> From 2260a266ae85e5a4f4b4e07d7a398582dbc298ba Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Wed, 11 Feb 2026 17:16:01 +0000 Subject: [PATCH 014/145] Started documenting circuit tactic and small fix to circuit test --- doc/tactics/circuit.rst | 210 ++++++++++++++++++++++++++++++++++++++++ tests/circuit_test.ec | 12 +-- 2 files changed, 216 insertions(+), 6 deletions(-) create mode 100644 doc/tactics/circuit.rst diff --git a/doc/tactics/circuit.rst b/doc/tactics/circuit.rst new file mode 100644 index 0000000000..2381be15de --- /dev/null +++ b/doc/tactics/circuit.rst @@ -0,0 +1,210 @@ + +======================================================================== +Tactic: `circuit` +======================================================================== + +The ``circuit`` tactic can be used to resolve a multitude of goals where +the semantics in question are over finite types. + +There are currently two variants of this tactic: + +- `circuit`, which attempts to automatically solve/prove the goal + +- `circuit simplify`, which performs a simplification over the goal structure + augmented by equivalence checks whenever an equality between two finite types + with bindings is encountered. + +.. contents:: + :local: + +.. + ------------------------------------------------------------------------ + Variant: ``circuit`` (FOL) + ------------------------------------------------------------------------ + .. ecproof:: + :title: First-order logic example + + require import AllCore List QFABV. + + type W8. + + op to_bits : W8 -> bool list. + op from_bits : bool list -> W8. + op of_int : int -> W8. + op to_uint : W8 -> int. + op to_sint : W8 -> int. + + bind bitstring + to_bits + from_bits + to_uint + to_sint + of_int + W8 + 8. + + realize gt0_size by admit. + realize tolistP by admit. + realize oflistP by admit. + realize touintP by admit. + realize tosintP by admit. + realize ofintP by admit. + realize size_tolist by admit. + + op (+^) : W8 -> W8 -> W8. + bind op W8 (+^) "xor". + realize bvxorP by admit. + + lemma L (w1 w2 : W8) : w1 +^ w2 = w2 +^ w1. + proof. + proc. (*$*) circuit solve. + abort. + + As we can see, the tactic can, through the generation of the appropriate + circuit representing validity of the proposition for a given value and + the equation of this function with the constant function equal to true, + establish the truth of the lemma. + This is, in a sense, a reverse use of function extensionality, to convert + statements about functions to statements about universal quantification. + + +------------------------------------------------------------------------ +Variant: ``circuit`` (HL) +------------------------------------------------------------------------ + +.. ecproof:: + :title: Hoare logic example + + require import AllCore List QFABV. + + type W8. + + op to_bits : W8 -> bool list. + op from_bits : bool list -> W8. + op of_int : int -> W8. + op to_uint : W8 -> int. + op to_sint : W8 -> int. + + bind bitstring + to_bits + from_bits + to_uint + to_sint + of_int + W8 + 8. + + realize gt0_size by admit. + realize tolistP by admit. + realize oflistP by admit. + realize touintP by admit. + realize tosintP by admit. + realize ofintP by admit. + realize size_tolist by admit. + + op (+^) : W8 -> W8 -> W8. + bind op W8 (+^) "xor". + realize bvxorP by admit. + + module M = { + proc f(w : W8) = { + return w +^ w; + } + }. + + lemma L (w_ : W8) : hoare[M.f : w_ = w ==> res = of_int 0]. + proof. + proc. (*$*) circuit. + abort. + + +As we can see from the output, the execution of the tactic has several components: + +- The translation of the precondition to a circuit, using any explicit equations + that define values of program variables at the start of execution in the further + construction of circuits henceforth. + +- The translation of the program to a (collection of) circuits. This is done instruction-wise + by keeping and updating a mapping from program variables to circuits determining how their + value is obtained from the value of some initial "input" variables. In the case of a program + these are either logical variables constraining initial values of program variables or the + program variables themselves, interpreted as symbols which are then universally quantified. + +- The translation of the postcondition into a circuit outputting a boolean, representing whether + the postcondition holds for given values of the input variables. The knowledge of how the + inputs relate to the outputs through the program and the knowledge of any initial relations + or known facts about these variables coming from the precondition or proof context is also + incorporated into this circuit. The goal of the tactic is then to prove that this circuit + is identically true for all values of the input, which is equivalent to the given hoare triple + being valid/true under the current proof context. + +In the case where the goal is an equality, some extra optimization are effected. +This corresponds to a heuristic inferrence procedure which tries to find structurally identical +conditions in order to avoid having to check the same condition more than once and also reduce +the number of inputs which are considered for each condition check, in order to reduce checking time. + + +------------------------------------------------------------------------ +Variant: ``circuit`` (rHL) +------------------------------------------------------------------------ + +.. ecproof:: + :title: Program equivalence example + + require import AllCore List QFABV. + + type W8. + + op to_bits : W8 -> bool list. + op from_bits : bool list -> W8. + op of_int : int -> W8. + op to_uint : W8 -> int. + op to_sint : W8 -> int. + + bind bitstring + to_bits + from_bits + to_uint + to_sint + of_int + W8 + 8. + + realize gt0_size by admit. + realize tolistP by admit. + realize oflistP by admit. + realize touintP by admit. + realize tosintP by admit. + realize ofintP by admit. + realize size_tolist by admit. + + op (+^) : W8 -> W8 -> W8. + bind op W8 (+^) "xor". + realize bvxorP by admit. + + module M = { + proc f1(w1 w2 : W8) = { + var a : W8; + a <- w1 +^ w2; + return a; + } + + proc f2(w1 w2 : W8) = { + var a : W8; + a <- w2 +^ w1; + return a; + } + }. + + lemma L : equiv[M.f1 ~ M.f2 : ={arg} ==> ={res}]. + proof. + proc. (*$*) circuit. + abort. + + +As we can see in this example, the tactic is also able to automatically prove +equivalence of these two programs. The way this is done is similar to the way +that single procedures are handled, but now we consider two sets of transformations +from input to outputs variables, one for each program. We then use this knowledge +to convert the postcondition into the appropriate circuit and use the same procedure +to attempt to automatically discharge it. diff --git a/tests/circuit_test.ec b/tests/circuit_test.ec index 24814834bc..40f0d53a01 100644 --- a/tests/circuit_test.ec +++ b/tests/circuit_test.ec @@ -1,6 +1,5 @@ require import AllCore List QFABV IntDiv. - theory FakeWord. type W. op size : int. @@ -30,6 +29,12 @@ realize size_tolist by admit. op zero : W = of_int 0. op one : W = of_int 1. +op (+^) : W -> W -> W. + +bind op W (+^) "xor". +realize bvxorP by admit. + +end FakeWord. op bool2bits (b : bool) : bool list = [b]. op bits2bool (b: bool list) : bool = List.nth false b 0. @@ -47,12 +52,7 @@ realize touintP by admit. realize tosintP by done. realize gt0_size by done. -op (+^) : W -> W -> W. - -bind op W (+^) "xor". -realize bvxorP by admit. -end FakeWord. type W8. From 5573b37edd9c62a42d06e8cec69e7ee98b5bec34 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Mon, 16 Feb 2026 16:40:45 +0000 Subject: [PATCH 015/145] Added documentation and tests for circuit tactics --- doc/tactics/bindings.rst | 216 ++++++++++++++++++++++++++++++++++++ easycrypt.project | 1 + examples/example_specs.spec | 2 + tests/circuit_test.ec | 2 + 4 files changed, 221 insertions(+) create mode 100644 doc/tactics/bindings.rst create mode 100644 examples/example_specs.spec diff --git a/doc/tactics/bindings.rst b/doc/tactics/bindings.rst new file mode 100644 index 0000000000..d3859c62d3 --- /dev/null +++ b/doc/tactics/bindings.rst @@ -0,0 +1,216 @@ +======================================================================== +Command: `bind` +======================================================================== + +The ``bind`` family of commands is used to allow translation of EasyCrypt +objects into boolean circuits for use in the `circuit` family of tactics. + +We have the following possibilities for these commands: + +- `bind bitstring`, which establishes a bijection between the given type + and a type of fixed size bitstrings through given isomorphisms with lists + of booleans (plus necessary side conditions) + +- `bind array`, which establishes the bijection between the given type constructor + (which must be polymorphic over a given type which must be bound to a + bitstring type in instantiations) and the type of arrays of a given fixed size. + +- `bind op`, which establishes the semantic equivalence of the given operator to + a specified operator from a fixed list (detailed below), which roughly corresponds + to the operators supported by the QFABV theory of SMTLib. + +- `bind circuit`, which asserts the semantic equivalence of the given operator to + the one given by a definition in the low level specification (spec) language. + All equivalences establishes through this particular mean are trusted (rather than + verified) and so become part of the TCB for the given proof. + +.. contents:: + :local: + +------------------------------------------------------------------------ +Variant: ``bind bitstring`` +------------------------------------------------------------------------ + +.. ecproof:: + :title: Bitstring Binding Example + + require import AllCore List QFABV. + + type W8. + + op to_bits : W8 -> bool list. + op from_bits : bool list -> W8. + op of_int : int -> W8. + op to_uint : W8 -> int. + op to_sint : W8 -> int. + + (*$*) bind bitstring + to_bits + from_bits + to_uint + to_sint + of_int + W8 + 8. + + realize gt0_size by admit. + realize tolistP by admit. + realize oflistP by admit. + realize touintP by admit. + realize tosintP by admit. + realize ofintP by admit. + realize size_tolist by admit. + + +Here we have an example of defining a type and establishing +its equivalence with the type of bitstring of size 8, along +with the side conditions needed to verify that equivalence. +Since we only give an abstract type, these side conditions +are admitted, but in a real example they would need to be +proven using the semantics of whatever type we were using. + +------------------------------------------------------------------------ +Variant: ``bind array`` +------------------------------------------------------------------------ + +.. ecproof:: + :title: Array Binding Example + + require import AllCore List QFABV. + + theory Array8. + type 'a t. + + op tolist : 'a t -> 'a list. + op oflist : 'a list -> 'a t. + op "_.[_]" : 'a t -> int -> 'a. + op "_.[_<-_]" : 'a t -> int -> 'a -> 'a t. + + end Array8. + + (*$*) bind array Array8."_.[_]" Array8."_.[_<-_]" Array8.tolist Array8.oflist Array8.t 8. + realize gt0_size by auto. + realize tolistP by admit. + realize eqP by admit. + realize get_setP by admit. + realize get_out by admit. + + +In this example, we can see how the correspondence is established +for a given polymorphic array type. As in the example above, we +use an abstract type and admit the side conditions for simplicity +of presentation, but in a real case we would have to use the +semantics of our array type in order to discharge these conditions. + + +------------------------------------------------------------------------ +Variant: ``bind op`` +------------------------------------------------------------------------ + +.. ecproof:: + :title: Operator Binding Example + + require import AllCore List QFABV. + + type W8. + + op to_bits : W8 -> bool list. + op from_bits : bool list -> W8. + op of_int : int -> W8. + op to_uint : W8 -> int. + op to_sint : W8 -> int. + + bind bitstring + to_bits + from_bits + to_uint + to_sint + of_int + W8 + 8. + + realize gt0_size by admit. + realize tolistP by admit. + realize oflistP by admit. + realize touintP by admit. + realize tosintP by admit. + realize ofintP by admit. + realize size_tolist by admit. + + op (+^) : W8 -> W8 -> W8. + + (*$*) bind op W8 (+^) "xor". + realize bvxorP by admit. + + +Here we give an example of giving the semantic equivalence for +an operator. We again instantiate this abstractly and admit the +side conditions for ease of exposition, assuming that in a real +case the semantics of the operator itself would be used in order +to show that the conditions hold. + +Of note that these bindings are only necessary for a base subset +of operators, and further operators defined in terms of these basic +ones are translated through recursive descent through their definition, +usage of these base cases and a notion of composition for boolean circuits. + + +------------------------------------------------------------------------ +Variant: ``bind circuit`` +------------------------------------------------------------------------ +.. ecproof:: + :title: Spec Binding Example + + require import AllCore List QFABV. + + type W8. + + op to_bits : W8 -> bool list. + op from_bits : bool list -> W8. + op of_int : int -> W8. + op to_uint : W8 -> int. + op to_sint : W8 -> int. + + bind bitstring + to_bits + from_bits + to_uint + to_sint + of_int + W8 + 8. + + realize gt0_size by admit. + realize tolistP by admit. + realize oflistP by admit. + realize touintP by admit. + realize tosintP by admit. + realize ofintP by admit. + realize size_tolist by admit. + + op (+^) : W8 -> W8 -> W8. + + (*$*) bind circuit + (+^) <- "BVXOR_8". + +Here we have an example of attributing semantics coming from a +low level specification language (spec) file to an operator. +We remark again that these equivalences are trusted and so a +potential source of error and unsoundness. This will be subject +to change in the future, but until then the recommended way +to use them is to be very careful or otherwise just bind +operators which are abstract and use these bindings as an +axiomatization (proving lemmas about these through the use +of the circuit family of tactics which is able to make use +of these semantics). + +The definition of the ``BVXOR_8`` operator in the spec language +is as follows:: + + BVXOR_8(w1@8, w2@8) -> @8 = + xor<8>(w1, w2) + + +.. + This is similar to what is done to establish a correspondence + between the basic types and their counterparts in the SMTs. diff --git a/easycrypt.project b/easycrypt.project index 727e5f7819..ad758829e1 100644 --- a/easycrypt.project +++ b/easycrypt.project @@ -1,3 +1,4 @@ [general] provers = CVC5@1.0 provers = Z3@4.12 +spec = examples/example_specs.spec diff --git a/examples/example_specs.spec b/examples/example_specs.spec new file mode 100644 index 0000000000..7c041b8ec9 --- /dev/null +++ b/examples/example_specs.spec @@ -0,0 +1,2 @@ +BVXOR_8(w1@8, w2@8) -> @8 = + xor<8>(w1, w2) diff --git a/tests/circuit_test.ec b/tests/circuit_test.ec index 40f0d53a01..a91835a275 100644 --- a/tests/circuit_test.ec +++ b/tests/circuit_test.ec @@ -174,3 +174,5 @@ proof. circuit. qed. +bind circuit + (+^) <- "BVXOR_8". From 2f23d0ab3e9249729e23ab7f473b66c9d8a4065c Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Thu, 19 Feb 2026 21:53:28 +0000 Subject: [PATCH 016/145] Remove bindings for hidden theories --- src/ecTheoryReplay.ml | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 6770d9b82e..2e911f327d 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -1221,9 +1221,12 @@ and replay1 (ove : _ ovrenv) (subst, ops, proofs, scope) (hidden, item) = | Th_alias (name, target) -> replay_alias ove (subst, ops, proofs, scope) (item.ti_import, name, target) - | Th_crbinding (binding, lc) -> + | Th_crbinding (binding, lc) when not hidden -> replay_crbinding ove (subst, ops, proofs, scope) (item.ti_import, binding, lc) + | Th_crbinding _ -> + (subst, ops, proofs, scope) + | Th_theory (ox, cth) -> begin let thmode = cth.cth_mode in let (subst, x) = rename ove subst (`Theory, ox) in From a0a5b1e1eeb5102cdac8ec5ed35db0f29f9a05e3 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Sat, 21 Feb 2026 14:48:25 +0000 Subject: [PATCH 017/145] WIP: Fixing memory leaks --- src/ecCircuits.ml | 9 ++++++++- src/ecHiTacticals.ml | 8 ++++++-- 2 files changed, 14 insertions(+), 3 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 0e44a8eab5..fdda2886dd 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -889,7 +889,14 @@ let circuit_of_form with CircError e -> propagate_circ_error (`ExpandIter (f, fs)) e in - doit st f_ + let res = doit st f_ in + (* State cleanup *) + begin + op_cache := Mp.empty; + Htbl.clear cache + end; + res + let circuit_simplify_equality ?(do_time = true) ~(st: state) ~(hyps: hyps) ~(pres: circuit list) (f1: form) (f2: form) : bool = let tm = ref (Unix.gettimeofday ()) in diff --git a/src/ecHiTacticals.ml b/src/ecHiTacticals.ml index 3e7265cfa2..a39bb9ae9d 100644 --- a/src/ecHiTacticals.ml +++ b/src/ecHiTacticals.ml @@ -237,8 +237,12 @@ and process1_phl (_ : ttenv) (t : phltactic located) (tc : tcenv1) = | Prepl_stmt infos -> EcPhlTrans.process_equiv_trans infos | Pprocrewrite (s, p, f) -> EcPhlRewrite.process_rewrite s p f | Pchangestmt (s, b, p, c) -> EcPhlRewrite.process_change_stmt s b p c - | Pcircuit `Solve -> EcPhlBDep.t_bdep_solve - | Pcircuit `Simplify -> EcPhlBDep.t_bdep_simplify + | Pcircuit `Solve -> + let tc = EcPhlBDep.t_bdep_solve in + Gc.major (); tc + | Pcircuit `Simplify -> + let tc = EcPhlBDep.t_bdep_simplify in + Gc.major (); tc | Prwprgm infos -> EcPhlRwPrgm.process_rw_prgm infos | Phoaresplit -> EcPhlHoare.process_hoaresplit in From e71eed9916390c1beb3ec0eb4f83adb1c71fb21b Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Sat, 21 Feb 2026 20:47:45 +0000 Subject: [PATCH 018/145] Fixed alpha-invariant hashing bug --- src/ecCircuits.ml | 176 ++++++++++++++++++++++--------------------- src/ecHiTacticals.ml | 8 +- 2 files changed, 92 insertions(+), 92 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index fdda2886dd..26b2c028c4 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -27,22 +27,18 @@ let circ_red (hyps: hyps) = let base_red = EcReduction.full_red in `No) } -module AInvFHashtbl(Ctxt: sig val hyps: hyps end) = Batteries.Hashtbl.Make(struct - type t = form +module AInvFHashtbl(Ctxt: sig val hyps: hyps end) = struct + type state = { + level: int; + subst: EcSubst.subst; + } - let equal f1 f2 = EcReduction.is_alpha_eq Ctxt.hyps f1 f2 + let empty_state : state = {level = 0; subst = EcSubst.empty} - type state = { - level: int; - subst: EcSubst.subst; - } - - let hash (f: form) : int = - let bruijn_idents : (int, ident) Map.t ref = ref Map.empty in + let bruijn_idents : (int, ident) Map.t ref = ref Map.empty let clean_bruijn_idents : unit -> unit = fun () -> bruijn_idents := Map.empty - in let ident_of_debruijn_level (i: int) : ident = match Map.find_opt i !bruijn_idents with @@ -50,16 +46,15 @@ module AInvFHashtbl(Ctxt: sig val hyps: hyps end) = Batteries.Hashtbl.Make(struc | None -> let id = create (string_of_int i) in bruijn_idents := Map.add i id !bruijn_idents; id - in let add_to_state (id: ident) (ty: ty) (st: state) = let new_id = ident_of_debruijn_level st.level in let level = st.level + 1 in let subst = EcSubst.add_flocal st.subst id (f_local new_id ty) in { level; subst }, new_id - in - let rec doit (st: state) (f: form) : int = + (* FIXME: maybe don't allow external calls with a state argument *) + let rec hash (st:state) (f: form) : int = let hnode = match f.f_node with | Fquant (qnt, bnds, f) -> let st, bnds = @@ -71,34 +66,34 @@ module AInvFHashtbl(Ctxt: sig val hyps: hyps end) = Batteries.Hashtbl.Make(struc | _ -> st, (orig_id, gty) ) st bnds - in Why3.Hashcons.combine2 (qt_hash qnt) (b_hash bnds) (doit st (EcSubst.subst_form st.subst f)) + in Why3.Hashcons.combine2 (qt_hash qnt) (b_hash bnds) (hash st (EcSubst.subst_form st.subst f)) | Fif (cond, tb, fb) -> - let doit = doit st in - Why3.Hashcons.combine2 (doit cond) (doit tb) (doit fb) + let hash = hash st in + Why3.Hashcons.combine2 (hash cond) (hash tb) (hash fb) | Fmatch (_, _, _) -> assert false | Flet (lp, value, body) -> begin match lp with | LSymbol (orig_id, ty) -> - let hval = doit st value in + let hval = hash st value in let st, new_id = add_to_state orig_id ty st in - let hbody = doit st (EcSubst.subst_form st.subst body) in + let hbody = hash st (EcSubst.subst_form st.subst body) in let hlp = lp_hash (LSymbol (new_id, ty)) in Why3.Hashcons.combine2 hlp hval hbody | LTuple bnds -> - let hval = doit st value in + let hval = hash st value in let st, new_ids = List.fold_left_map (fun st (id, ty) -> add_to_state id ty st) st bnds in - let hbody = doit st (EcSubst.subst_form st.subst body) in + let hbody = hash st (EcSubst.subst_form st.subst body) in let hbinds = lp_hash @@ LTuple (List.combine new_ids (List.snd bnds)) in Why3.Hashcons.combine2 hbinds hval hbody | LRecord (_, _) -> assert false end | Fapp (op, args) -> - let hop = doit st op in - Why3.Hashcons.combine_list (doit st) hop args + let hop = hash st op in + Why3.Hashcons.combine_list (hash st) hop args | Ftuple comps -> - Why3.Hashcons.combine_list (doit st) 0 comps + Why3.Hashcons.combine_list (hash st) 0 comps | Fproj (tp, i) -> - Why3.Hashcons.combine (doit st tp) i + Why3.Hashcons.combine (hash st tp) i | FhoareF _hF -> assert false (* FIXME: do we want this case and the one below? @@ -145,11 +140,21 @@ module AInvFHashtbl(Ctxt: sig val hyps: hyps end) = Batteries.Hashtbl.Make(struc | Fglob (_, _) | Fop (_, _) -> f_hash f (* FIXME: maybe do these cases as well? *) in Why3.Hashcons.combine hnode (ty_hash f.f_ty) - in - let res = doit {level = 0; subst = EcSubst.empty} f in + + module Htbl = Batteries.Hashtbl.Make(struct + type t = form + + let equal f1 f2 = EcReduction.is_alpha_eq Ctxt.hyps f1 f2 + + let hash f = hash empty_state f + + end) + + let clear htbl = clean_bruijn_idents (); - res -end) + Htbl.clear htbl +end + (* -------------------------------------------------------------------- *) type circuit_conversion_call = [ @@ -618,10 +623,10 @@ let circuit_of_form (f_ : EcAst.form) : circuit = - let module Htbl = AInvFHashtbl(struct let hyps = hyps end) in + let module AIFH = AInvFHashtbl(struct let hyps = hyps end) in (* Form level cache, local to each high-level call *) - let cache : circuit Htbl.t = Htbl.create 700 in + let cache : circuit AIFH.Htbl.t = AIFH.Htbl.create 700 in let op_cache : circuit Mp.t ref = ref Mp.empty in let redmode = circ_red hyps in let env = toenv hyps in @@ -722,67 +727,66 @@ let circuit_of_form | Fapp (f, fs) -> (* TODO: Maybe add cache statistics? *) (* TODO: Maybe cache all forms *) - begin match Htbl.find_opt cache f_ with + begin match AIFH.Htbl.find_opt cache f_ with | Some circ -> circ - | None -> let circ = - begin match f with - | {f_node = Fop (pth, _)} when op_is_parametric_base env pth -> - let args = List.map (arg_of_form st) fs in - circuit_of_op_with_args env pth args - - (* For dealing with iter cases: *) - | {f_node = Fop _} when form_is_iter f_ -> - trans_iter st hyps f fs - - | {f_node = Fop (_p, _)} when not (List.for_all (fun f -> f.f_ty.ty_node <> EcTypes.tint.ty_node) fs) -> - doit st (propagate_integer_arguments f fs) - - | {f_node = Fop _} -> - (* Assuming correct types coming from EC *) - begin match EcFol.op_kind (destr_op f |> fst), fs with - | Some `Eq, [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_eq c1 c2 :> circuit) - | Some `Not, [f] -> - let c = doit st f in - circuit_not c - | Some `True, [] -> - (circuit_true :> circuit) - | Some `False, [] -> - (circuit_false :> circuit) - | Some `Imp, [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_or (circuit_not c1) c2 :> circuit) - | Some (`And _), [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_and c1 c2 :> circuit) - | Some (`Or _), [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_or c1 c2 :> circuit) - | Some `Iff, [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_or (circuit_and c1 c2) (circuit_and (circuit_not c1) (circuit_not c2)) :> circuit) + | None -> + let circ = begin match f with + | {f_node = Fop (pth, _)} when op_is_parametric_base env pth -> + let args = List.map (arg_of_form st) fs in + circuit_of_op_with_args env pth args + + (* For dealing with iter cases: *) + | {f_node = Fop _} when form_is_iter f_ -> + trans_iter st hyps f fs + + | {f_node = Fop (_p, _)} when not (List.for_all (fun f -> f.f_ty.ty_node <> EcTypes.tint.ty_node) fs) -> + doit st (propagate_integer_arguments f fs) + + | {f_node = Fop _} -> + (* Assuming correct types coming from EC *) + begin match EcFol.op_kind (destr_op f |> fst), fs with + | Some `Eq, [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_eq c1 c2 :> circuit) + | Some `Not, [f] -> + let c = doit st f in + circuit_not c + | Some `True, [] -> + (circuit_true :> circuit) + | Some `False, [] -> + (circuit_false :> circuit) + | Some `Imp, [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_or (circuit_not c1) c2 :> circuit) + | Some (`And _), [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_and c1 c2 :> circuit) + | Some (`Or _), [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_or c1 c2 :> circuit) + | Some `Iff, [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_or (circuit_and c1 c2) (circuit_and (circuit_not c1) (circuit_not c2)) :> circuit) + (* Recurse down into definition *) + | _ -> + let f_c = doit st f in + let fcs = List.map (doit st) fs in + circuit_compose f_c fcs + end (* Recurse down into definition *) | _ -> let f_c = doit st f in let fcs = List.map (doit st) fs in circuit_compose f_c fcs + end in + AIFH.Htbl.add cache f_ circ; + circ end - (* Recurse down into definition *) - | _ -> - let f_c = doit st f in - let fcs = List.map (doit st) fs in - circuit_compose f_c fcs - end - in - Htbl.add cache f_ circ; - circ - end | Fquant (qnt, binds, f) -> (* FIXME Does this type conversion make sense? *) @@ -893,7 +897,7 @@ let circuit_of_form (* State cleanup *) begin op_cache := Mp.empty; - Htbl.clear cache + AIFH.clear cache end; res diff --git a/src/ecHiTacticals.ml b/src/ecHiTacticals.ml index a39bb9ae9d..538d7c2d8d 100644 --- a/src/ecHiTacticals.ml +++ b/src/ecHiTacticals.ml @@ -237,12 +237,8 @@ and process1_phl (_ : ttenv) (t : phltactic located) (tc : tcenv1) = | Prepl_stmt infos -> EcPhlTrans.process_equiv_trans infos | Pprocrewrite (s, p, f) -> EcPhlRewrite.process_rewrite s p f | Pchangestmt (s, b, p, c) -> EcPhlRewrite.process_change_stmt s b p c - | Pcircuit `Solve -> - let tc = EcPhlBDep.t_bdep_solve in - Gc.major (); tc - | Pcircuit `Simplify -> - let tc = EcPhlBDep.t_bdep_simplify in - Gc.major (); tc + | Pcircuit `Solve -> EcPhlBDep.t_bdep_solve + | Pcircuit `Simplify -> EcPhlBDep.t_bdep_simplify | Prwprgm infos -> EcPhlRwPrgm.process_rw_prgm infos | Phoaresplit -> EcPhlHoare.process_hoaresplit in From 4fe578a8cdeb130d7ea1197c96411165b68f9ac9 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Mon, 23 Feb 2026 13:15:44 +0000 Subject: [PATCH 019/145] Revert spec file in easycrypt.project and extend loader to support spec files --- src/ec.ml | 9 --------- src/ecCommands.ml | 14 +++++++++----- src/ecCommands.mli | 1 - src/ecLoader.ml | 9 +++++---- src/ecLoader.mli | 2 +- src/ecOptions.ml | 27 --------------------------- src/ecOptions.mli | 8 -------- src/ecParser.mly | 4 ++-- src/ecParsetree.ml | 3 ++- src/ecScope.ml | 36 ++++++------------------------------ src/ecScope.mli | 2 -- 11 files changed, 25 insertions(+), 90 deletions(-) diff --git a/src/ec.ml b/src/ec.ml index 763c709aa5..627d25b81b 100644 --- a/src/ec.ml +++ b/src/ec.ml @@ -415,7 +415,6 @@ let main () = (*---*) gccompact : int option; (*---*) docgen : bool; (*---*) outdirp : string option; - (*---*) specs : spec_options; mutable trace : trace1 list option; } @@ -494,7 +493,6 @@ let main () = ; gccompact = None ; docgen = false ; outdirp = None - ; specs = cliopts.clio_specs ; trace = None } end @@ -530,7 +528,6 @@ let main () = ; gccompact = cmpopts.cmpo_compact ; docgen = false ; outdirp = None - ; specs = cmpopts.cmpo_specs ; trace = trace0 } end @@ -567,10 +564,6 @@ let main () = lazy (T.from_channel ~name (open_in name)) in - let nospec = { - files = []; - } in - { prvopts = prvoff ; input = Some name ; terminal = terminal @@ -579,7 +572,6 @@ let main () = ; gccompact = None ; docgen = true ; outdirp = docopts.doco_outdirp - ; specs = nospec ; trace = None } end @@ -701,7 +693,6 @@ let main () = EcCommands.cm_provers = state.prvopts.prvo_provers; EcCommands.cm_profile = state.prvopts.prvo_profile; EcCommands.cm_iterate = state.prvopts.prvo_iterate; - EcCommands.cm_specs = state.specs.files; } in let checkproof = not state.docgen in diff --git a/src/ecCommands.ml b/src/ecCommands.ml index 2daea29618..88d783b95e 100644 --- a/src/ecCommands.ml +++ b/src/ecCommands.ml @@ -743,12 +743,18 @@ and process_dump scope (source, tc) = scope (* -------------------------------------------------------------------- *) -and process_crbind (scope : EcScope.scope) (binding : pcrbinding) = +and process_crbind (scope : EcScope.scope) (ld : Loader.loader) (binding : pcrbinding) = match binding.binding with | CRB_Bitstring bs -> EcScope.Circuit.add_bitstring scope binding.locality bs | CRB_Array ba -> EcScope.Circuit.add_array scope binding.locality ba | CRB_BvOperator op -> EcScope.Circuit.add_bvoperator scope binding.locality op - | CRB_Circuit cr -> EcScope.Circuit.add_circuits scope binding.locality cr + | CRB_Circuit cr -> + let file = match Loader.locate (unloc cr.file) ld with + | None -> assert false (* FIXME *) + | Some (_, file, `Spec) -> { cr.file with pl_desc = file } + | _ -> assert false (* FIXME *) + in + EcScope.Circuit.add_circuits scope binding.locality {cr with file} (* -------------------------------------------------------------------- *) and process ?(src : string option) (ld : Loader.loader) (scope : EcScope.scope) g = @@ -793,7 +799,7 @@ and process ?(src : string option) (ld : Loader.loader) (scope : EcScope.scope) | Greduction red -> `Fct (fun scope -> process_reduction scope red) | Ghint hint -> `Fct (fun scope -> process_hint scope hint) | GdumpWhy3 file -> `Fct (fun scope -> process_dump_why3 scope file) - | Gcrbinding bind -> `Fct (fun scope -> process_crbind scope bind) + | Gcrbinding bind -> `Fct (fun scope -> process_crbind scope ld bind) with | `Fct f -> Some (f scope) | `State f -> f scope; None @@ -828,7 +834,6 @@ type checkmode = { cm_provers : string list option; cm_profile : bool; cm_iterate : bool; - cm_specs : string list; } let initial ~checkmode ~boot ~checkproof = @@ -854,7 +859,6 @@ let initial ~checkmode ~boot ~checkproof = scope [tactics; prelude] in let scope = EcScope.Prover.set_default scope poptions in - let scope = EcScope.Circuit.register_spec_files scope checkmode.cm_specs in let scope = if checkproof then begin if checkall then diff --git a/src/ecCommands.mli b/src/ecCommands.mli index 14e8de181a..a72d31a437 100644 --- a/src/ecCommands.mli +++ b/src/ecCommands.mli @@ -22,7 +22,6 @@ type checkmode = { cm_provers : string list option; cm_profile : bool; cm_iterate : bool; - cm_specs : string list; } val initial : checkmode:checkmode -> boot:bool -> checkproof:bool -> EcScope.scope diff --git a/src/ecLoader.ml b/src/ecLoader.ml index 25378c19e6..792af5f151 100644 --- a/src/ecLoader.ml +++ b/src/ecLoader.ml @@ -10,7 +10,7 @@ type ecloader = { } (* -------------------------------------------------------------------- *) -type kind = [`Ec | `EcA] +type kind = [`Ec | `EcA | `Spec] exception BadExtension of string @@ -121,8 +121,9 @@ let locate ?(namespaces = [None]) (name : string) (ecl : ecloader) = let locate kind ((inamespace, idir), _) = let name = match kind with - | `Ec -> Printf.sprintf "%s.ec" name - | `EcA -> Printf.sprintf "%s.eca" name + | `Ec -> Printf.sprintf "%s.ec" name + | `EcA -> Printf.sprintf "%s.eca" name + | `Spec -> Printf.sprintf "%s.spec" name in let nmok = @@ -156,7 +157,7 @@ let locate ?(namespaces = [None]) (name : string) (ecl : ecloader) = match List.rev_pmap (fun kind -> List.opick (locate kind) ecl.ecl_idirs) - [`Ec; `EcA] + [`Ec; `EcA; `Spec] with | [x] -> Some x | _ -> None diff --git a/src/ecLoader.mli b/src/ecLoader.mli index 3b5fe2d316..802c557b4e 100644 --- a/src/ecLoader.mli +++ b/src/ecLoader.mli @@ -3,7 +3,7 @@ type idx_t type ecloader (* -------------------------------------------------------------------- *) -type kind = [`Ec | `EcA] +type kind = [`Ec | `EcA | `Spec] exception BadExtension of string diff --git a/src/ecOptions.ml b/src/ecOptions.ml index a1d30f4e35..9dea7c2ffd 100644 --- a/src/ecOptions.ml +++ b/src/ecOptions.ml @@ -25,14 +25,12 @@ and cmp_option = { cmpo_tstats : string option; cmpo_noeco : bool; cmpo_script : bool; - cmpo_specs : spec_options; cmpo_trace : bool; } and cli_option = { clio_emacs : bool; clio_provers : prv_options; - clio_specs : spec_options; } and run_option = { @@ -42,7 +40,6 @@ and run_option = { runo_provers : prv_options; runo_jobs : int option; runo_rawargs : string list; - runo_specs : spec_options; } and doc_option = { @@ -63,10 +60,6 @@ and prv_options = { prvo_why3server : string option; } -and spec_options = { - files : string list; -} - and ldr_options = { ldro_idirs : (string option * string * bool) list; ldro_boot : bool; @@ -88,7 +81,6 @@ type ini_options = { ini_timeout : int option; ini_idirs : (string option * string) list; ini_rdirs : (string option * string) list; - ini_specs : string list; } type ini_context = { @@ -107,8 +99,6 @@ module Ini : sig val get_provers : ini_context -> string list - val get_specs : ini_context -> string list - val get_timeout : ini_context -> int option val get_idirs : ini_context -> (string option * string) list @@ -124,8 +114,6 @@ module Ini : sig val get_all_provers : ini_context list -> string list - val get_all_specs : ini_context list -> string list - val get_all_timeout : ini_context list -> int option val get_all_idirs : ini_context list -> (string option * string) list @@ -157,10 +145,6 @@ end = struct let get_provers (ini : ini_context) = ini.inic_ini.ini_provers - let get_specs (ini : ini_context) = - List.map (absolute ?root:ini.inic_root) - ini.inic_ini.ini_specs - let get_timeout (ini : ini_context) = ini.inic_ini.ini_timeout @@ -187,9 +171,6 @@ end = struct let get_all_provers (ini : ini_context list) = List.flatten (List.map get_provers ini) - let get_all_specs (ini : ini_context list) = - List.flatten (List.map get_specs ini) - let get_all_timeout (ini : ini_context list) = List.find_map_opt get_timeout ini @@ -526,13 +507,9 @@ let prv_options_of_values ini values = prvo_why3server = get_string "why3server" values; } -let spec_options_of_values ini values = - { files = (Ini.get_all_specs ini) @ (get_strings "spec" values); } - let cli_options_of_values ini values = { clio_emacs = get_flag "emacs" values; clio_provers = prv_options_of_values ini values; - clio_specs = spec_options_of_values ini values; } let cmp_options_of_values ini values input = @@ -543,7 +520,6 @@ let cmp_options_of_values ini values input = cmpo_tstats = get_string "tstats" values; cmpo_noeco = get_flag "no-eco" values; cmpo_script = get_flag "script" values; - cmpo_specs = spec_options_of_values ini values; cmpo_trace = get_flag "trace" values; } @@ -554,7 +530,6 @@ let runtest_options_of_values ini values (input, scenarios) = runo_provers = prv_options_of_values ini values; runo_jobs = get_int "jobs" values; runo_rawargs = get_strings "raw-args" values; - runo_specs = spec_options_of_values ini values; } let doc_options_of_values values input = @@ -714,7 +689,6 @@ let read_ini_file (filename : string) = ini_timeout = tryint "timeout" ; ini_idirs = List.map parse_idir (trylist "idirs"); ini_rdirs = List.map parse_idir (trylist "rdirs"); - ini_specs = trylist "spec"; } in { ini_ppwidth = ini.ini_ppwidth; @@ -724,5 +698,4 @@ let read_ini_file (filename : string) = ini_timeout = ini.ini_timeout; ini_idirs = ini.ini_idirs; ini_rdirs = ini.ini_rdirs; - ini_specs = ini.ini_specs; } diff --git a/src/ecOptions.mli b/src/ecOptions.mli index 8bf076f06c..59009718ad 100644 --- a/src/ecOptions.mli +++ b/src/ecOptions.mli @@ -21,14 +21,12 @@ and cmp_option = { cmpo_tstats : string option; cmpo_noeco : bool; cmpo_script : bool; - cmpo_specs : spec_options; cmpo_trace : bool; } and cli_option = { clio_emacs : bool; clio_provers : prv_options; - clio_specs : spec_options; } and run_option = { @@ -38,7 +36,6 @@ and run_option = { runo_provers : prv_options; runo_jobs : int option; runo_rawargs : string list; - runo_specs : spec_options; } and doc_option = { @@ -59,10 +56,6 @@ and prv_options = { prvo_why3server : string option; } -and spec_options = { - files : string list; -} - and ldr_options = { ldro_idirs : (string option * string * bool) list; ldro_boot : bool; @@ -84,7 +77,6 @@ type ini_options = { ini_timeout : int option; ini_idirs : (string option * string) list; ini_rdirs : (string option * string) list; - ini_specs : string list; } type ini_context = { diff --git a/src/ecParser.mly b/src/ecParser.mly index aa74c3887b..c275984d01 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -3831,8 +3831,8 @@ cr_binding_r: | BIND OP types=bracket(plist1(qident, AMP)) operator=qoident name=loc(STRING) { CRB_BvOperator { types; operator; name; } } -| BIND CIRCUIT bindings=plist1(spec_binding, COMMA) - { CRB_Circuit { bindings } } +| BIND CIRCUIT bindings=plist1(spec_binding, COMMA) FROM file=loc(STRING) + { CRB_Circuit { bindings; file } } %inline cr_binding: | locality=is_local binding=cr_binding_r diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index f3c03a2c23..20bb8ba8a3 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -1330,7 +1330,8 @@ type pbind_bvoperator = (* -------------------------------------------------------------------- *) type pbind_circuit = - { bindings : (pqsymbol * string located) list } + { bindings : (pqsymbol * string located) list + ; file : string located } (* -------------------------------------------------------------------- *) type pcrbinding_r = diff --git a/src/ecScope.ml b/src/ecScope.ml index 8faa59004d..6685af0b07 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -3065,37 +3065,21 @@ module Circuit = struct Ax.add_defer scope proofs - let find_duplicate_specs (scope : scope) : symbol list = - let specs = List.map (fun filename -> - Lospecs.Circuit_spec.load_from_file ~filename |> List.fst - ) scope.sc_specs - in - - let module Set = Batteries.Set in - List.fold_left (fun (acc, dups) next -> - let cur = Set.of_list next in - let new_dup = Set.intersect cur acc in - (Set.union acc cur), (Set.union dups new_dup) - ) (Set.empty, Set.empty) specs |> snd |> Set.to_list - - (* FIXME CIRCUIT PR: decide how we want to handle multiple spec files in easycrypt.project(s) *) - let add_circuit1 (scope : scope) (local : is_local) ((op, circ) : (pqsymbol * string located)) : scope = + let add_circuit1 ~(filename: string) (scope : scope) (local : is_local) ((op, circ) : (pqsymbol * string located)) : scope = let env = env scope in let operator, opdecl = EcEnv.Op.lookup op.pl_desc env in if not (List.is_empty opdecl.op_tparams) then hierror ~loc:(loc op) "operator must be monomorphic"; - let matches = List.filteri_map (fun _i filename -> - EcEnv.Circuit.get_specification_by_name ~filename (unloc circ)) scope.sc_specs - in + let ospec = EcEnv.Circuit.get_specification_by_name ~filename (unloc circ) in - match matches with - | [] -> + match ospec with + | None -> hierror ~loc:(loc circ) "unknown circuit: %s" (unloc circ) - | circuit::[] -> + | Some circuit -> let sig_ = List.map (fun (_, `W i) -> i) circuit.arguments in let ret = Lospecs.Ast.get_size circuit.rettype in let dom, codom = EcEnv.Ty.decompose_fun opdecl.op_ty env in @@ -3143,18 +3127,10 @@ module Circuit = struct EcTheory.mkitem ~import:true (EcTheory.Th_crbinding (item, local)) in { scope with sc_env = EcSection.add_item item scope.sc_env } - | circs -> hierror "Multiple matches found (%d) for circuit %s" (List.length circs) (unloc circ) - - let register_spec_files (scope : scope) (files : string list) : scope = - let sc = { scope with sc_specs = files } in - match find_duplicate_specs sc with - | [] -> sc - | dups -> hierror "duplicate spec definitions: %a" - EcPrinting.(pp_list ", " pp_symbol) dups let add_circuits (scope : scope) (local : is_local) (binds : pbind_circuit) : scope = List.fold_left (fun scope bnd -> - add_circuit1 scope local bnd) + add_circuit1 ~filename:(unloc binds.file) scope local bnd) scope binds.bindings end diff --git a/src/ecScope.mli b/src/ecScope.mli index 86eeeff053..aea4d92aa7 100644 --- a/src/ecScope.mli +++ b/src/ecScope.mli @@ -287,8 +287,6 @@ module Circuit : sig val add_array : scope -> EcTypes.is_local -> pbind_array -> scope val add_bvoperator : scope -> EcTypes.is_local -> pbind_bvoperator -> scope val add_circuits : scope -> EcTypes.is_local -> pbind_circuit -> scope - - val register_spec_files : scope -> string list -> scope end (* -------------------------------------------------------------------- *) From 9b6dd79d0073a3f1b76b9d5fb9e34658dd444648 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Mon, 23 Feb 2026 13:22:45 +0000 Subject: [PATCH 020/145] Improve locate API --- src/ecCommands.ml | 22 +++++++++++++--------- src/ecDoc.ml | 5 +++-- src/ecEco.ml | 10 ++++++---- src/ecLoader.ml | 4 ++-- src/ecLoader.mli | 2 +- 5 files changed, 25 insertions(+), 18 deletions(-) diff --git a/src/ecCommands.ml b/src/ecCommands.ml index 88d783b95e..cdabf33112 100644 --- a/src/ecCommands.ml +++ b/src/ecCommands.ml @@ -120,8 +120,9 @@ module Loader : sig val addidir : ?namespace:namespace -> ?recursive:bool -> string -> loader -> unit val aslist : loader -> ((namespace option * string) * idx_t) list - val locate : ?namespaces:namespace option list -> string -> - loader -> (namespace option * string * kind) option + val locate : ?namespaces:namespace option list -> + ?kinds:(EcLoader.kind list) -> string -> + loader -> (namespace option * string * kind) option val push : string -> loader -> unit val pop : loader -> string option @@ -170,8 +171,8 @@ end = struct let aslist (ld : loader) = EcLoader.aslist ld.ld_core - let locate ?namespaces (path : string) (ld : loader) = - EcLoader.locate ?namespaces path ld.ld_core + let locate ?namespaces ?kinds (path : string) (ld : loader) = + EcLoader.locate ?namespaces ?kinds path ld.ld_core let push (p : string) (ld : loader) = ld.ld_stack <- norm p :: ld.ld_stack @@ -522,7 +523,7 @@ and process_th_require1 ld scope (nm, (sysname, thname), io) = then [Loader.namespace ld; None] else [nm] in - match Loader.locate ~namespaces:nm sysname ld with + match Loader.locate ~kinds:[`Ec; `EcA] ~namespaces:nm sysname ld with | None -> EcScope.hierror "cannot locate theory `%s'" sysname @@ -557,7 +558,10 @@ and process_th_require1 ld scope (nm, (sysname, thname), io) = (fun () -> Pragma.set i_pragma) in - let kind = match kind with `Ec -> `Concrete | `EcA -> `Abstract in + let kind = match kind with + | `Ec -> `Concrete | `EcA -> `Abstract + | _ -> assert false + in let scope = EcScope.Theory.require scope (name, kind) loader in match io with @@ -749,10 +753,10 @@ and process_crbind (scope : EcScope.scope) (ld : Loader.loader) (binding : pcrbi | CRB_Array ba -> EcScope.Circuit.add_array scope binding.locality ba | CRB_BvOperator op -> EcScope.Circuit.add_bvoperator scope binding.locality op | CRB_Circuit cr -> - let file = match Loader.locate (unloc cr.file) ld with - | None -> assert false (* FIXME *) + let file = match Loader.locate ~kinds:[`Spec] (unloc cr.file) ld with | Some (_, file, `Spec) -> { cr.file with pl_desc = file } - | _ -> assert false (* FIXME *) + | None -> assert false (* FIXME: Proper error message *) + | _ -> assert false in EcScope.Circuit.add_circuits scope binding.locality {cr with file} diff --git a/src/ecDoc.ml b/src/ecDoc.ml index 01b3437709..49fac0593c 100644 --- a/src/ecDoc.ml +++ b/src/ecDoc.ml @@ -26,8 +26,9 @@ let c_filename ?(ext : string option) (nms : string list) = (* -------------------------------------------------------------------- *) let thkind_str (kind : EcLoader.kind) : string = match kind with - | `Ec -> "Theory" - | `EcA -> "Abstract Theory" + | `Ec -> "Theory" + | `EcA -> "Abstract Theory" + | `Spec -> "Spec File" (* FIXME *) (* -------------------------------------------------------------------- *) let itemkind_str_pl (ik : itemkind) : string = diff --git a/src/ecEco.ml b/src/ecEco.ml index fc8f41c986..d434125b90 100644 --- a/src/ecEco.ml +++ b/src/ecEco.ml @@ -64,13 +64,15 @@ let list_of_json (tx : Json.t -> 'a) (data : Json.t) : 'a list = (* -------------------------------------------------------------------- *) let kind_to_json (k : EcLoader.kind) = match k with - | `Ec -> `String "ec" - | `EcA -> `String "eca" + | `Ec -> `String "ec" + | `EcA -> `String "eca" + | `Spec -> `String "spec" let kind_of_json (data : Json.t) = match data with - | `String "ec" -> `Ec - | `String "eca" -> `EcA + | `String "ec" -> `Ec + | `String "eca" -> `EcA + | `String "spec" -> `Spec | _ -> raise InvalidEco (* -------------------------------------------------------------------- *) diff --git a/src/ecLoader.ml b/src/ecLoader.ml index 792af5f151..a08228d376 100644 --- a/src/ecLoader.ml +++ b/src/ecLoader.ml @@ -114,7 +114,7 @@ let check_case idir name (dev, ino) = with Unix.Unix_error _ -> None (* -------------------------------------------------------------------- *) -let locate ?(namespaces = [None]) (name : string) (ecl : ecloader) = +let locate ?(namespaces = [None]) ?(kinds = [`Ec; `EcA]) (name : string) (ecl : ecloader) = if not (EcRegexp.match_ (`S "^[a-zA-Z0-9_]+$") name) then None else @@ -157,7 +157,7 @@ let locate ?(namespaces = [None]) (name : string) (ecl : ecloader) = match List.rev_pmap (fun kind -> List.opick (locate kind) ecl.ecl_idirs) - [`Ec; `EcA; `Spec] + kinds with | [x] -> Some x | _ -> None diff --git a/src/ecLoader.mli b/src/ecLoader.mli index 802c557b4e..00771b9b72 100644 --- a/src/ecLoader.mli +++ b/src/ecLoader.mli @@ -18,4 +18,4 @@ val aslist : ecloader -> ((namespace option * string) * idx_t) list val dup : ecloader -> ecloader val forsys : ecloader -> ecloader val addidir : ?namespace:namespace -> ?recursive:bool -> string -> ecloader -> unit -val locate : ?namespaces:(namespace option) list -> string -> ecloader -> (namespace option * string * kind) option +val locate : ?namespaces:(namespace option) list -> ?kinds:(kind list) -> string -> ecloader -> (namespace option * string * kind) option From 9a09143b395333916098cc1c2c40163d806dab25 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Mon, 23 Feb 2026 13:25:41 +0000 Subject: [PATCH 021/145] Proper error message --- src/ecCommands.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/ecCommands.ml b/src/ecCommands.ml index cdabf33112..b340d8d75d 100644 --- a/src/ecCommands.ml +++ b/src/ecCommands.ml @@ -755,7 +755,7 @@ and process_crbind (scope : EcScope.scope) (ld : Loader.loader) (binding : pcrbi | CRB_Circuit cr -> let file = match Loader.locate ~kinds:[`Spec] (unloc cr.file) ld with | Some (_, file, `Spec) -> { cr.file with pl_desc = file } - | None -> assert false (* FIXME: Proper error message *) + | None -> EcScope.hierror ~loc:(loc cr.file) "Cannot find spec file %s.spec" (unloc cr.file) | _ -> assert false in EcScope.Circuit.add_circuits scope binding.locality {cr with file} From 701fd101aa31224720747ff3733a5364899a3387 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 23 Feb 2026 16:11:03 +0100 Subject: [PATCH 022/145] load spec file relatively to current processed file --- src/ec.ml | 14 ++++++++---- src/ecCommands.ml | 53 +++++++++++++++++++++++++++++++++++----------- src/ecCommands.mli | 5 +++-- src/ecDoc.ml | 1 - src/ecEco.ml | 2 -- src/ecLoader.ml | 3 +-- src/ecLoader.mli | 2 +- 7 files changed, 56 insertions(+), 24 deletions(-) diff --git a/src/ec.ml b/src/ec.ml index 627d25b81b..36592075a6 100644 --- a/src/ec.ml +++ b/src/ec.ml @@ -578,11 +578,17 @@ let main () = in (match state.input with - | Some input -> EcCommands.addidir (Filename.dirname input) + | Some input -> + EcCommands.addidir (Filename.dirname input); + EcCommands.set_current_path (Filename.dirname input) | None -> - match relocdir with - | None -> EcCommands.addidir Filename.current_dir_name - | Some pwd -> EcCommands.addidir pwd); + let current_path = + match relocdir with + | None -> Filename.current_dir_name + | Some pwd -> pwd + in + EcCommands.addidir current_path; + EcCommands.set_current_path current_path); (* Check if the .eco is up-to-date and exit if so *) (if not state.docgen then diff --git a/src/ecCommands.ml b/src/ecCommands.ml index b340d8d75d..9b3d52bf61 100644 --- a/src/ecCommands.ml +++ b/src/ecCommands.ml @@ -111,6 +111,7 @@ module Loader : sig type kind = EcLoader.kind type idx_t = EcLoader.idx_t type namespace = EcLoader.namespace + type context1 = { cpath : string; filename : string; } val create : unit -> loader val forsys : loader -> loader @@ -125,13 +126,20 @@ module Loader : sig loader -> (namespace option * string * kind) option val push : string -> loader -> unit - val pop : loader -> string option - val context : loader -> string list + val pop : loader -> context1 option + val context : loader -> context1 list val incontext : string -> loader -> bool + + val set_current_path : string -> loader -> unit + + val current_path : loader -> string end = struct + type context1 = { cpath : string; filename : string; } + type loader = { (*---*) ld_core : EcLoader.ecloader; - mutable ld_stack : string list; + mutable ld_stack : context1 list; + mutable ld_cpath : string; (*---*) ld_namespace : EcLoader.namespace option; } @@ -148,16 +156,19 @@ end = struct let create () = { ld_core = EcLoader.create (); ld_stack = []; + ld_cpath = Unix.getcwd (); ld_namespace = None; } let forsys (ld : loader) = { ld_core = EcLoader.forsys ld.ld_core; ld_stack = ld.ld_stack; + ld_cpath = ld.ld_cpath; ld_namespace = None; } let dup ?namespace (ld : loader) = { ld_core = EcLoader.dup ld.ld_core; ld_stack = ld.ld_stack; + ld_cpath = ld.ld_cpath; ld_namespace = match namespace with | Some _ -> namespace @@ -175,7 +186,8 @@ end = struct EcLoader.locate ?namespaces ?kinds path ld.ld_core let push (p : string) (ld : loader) = - ld.ld_stack <- norm p :: ld.ld_stack + let ctxt1 = { cpath = ld.ld_cpath; filename = norm p; } in + ld.ld_stack <- ctxt1 :: ld.ld_stack let pop (ld : loader) = match ld.ld_stack with @@ -186,7 +198,14 @@ end = struct ld.ld_stack let incontext (p : string) (ld : loader) = - List.mem (norm p) ld.ld_stack + let p = norm p in + List.exists (fun ctxt1 -> p = ctxt1.filename) ld.ld_stack + + let set_current_path (cpath : string) (ld : loader) = + ld.ld_cpath <- cpath + + let current_path (ld : loader) : string = + ld.ld_cpath end (* -------------------------------------------------------------------- *) @@ -537,6 +556,8 @@ and process_th_require1 ld scope (nm, (sysname, thname), io) = Loader.push filename subld; Loader.addidir ?namespace:fnm dirname subld; + Loader.set_current_path dirname subld; + let name = EcScope.{ rqd_name = thname; rqd_kind = kind; @@ -560,7 +581,6 @@ and process_th_require1 ld scope (nm, (sysname, thname), io) = let kind = match kind with | `Ec -> `Concrete | `EcA -> `Abstract - | _ -> assert false in let scope = EcScope.Theory.require scope (name, kind) loader in @@ -752,12 +772,18 @@ and process_crbind (scope : EcScope.scope) (ld : Loader.loader) (binding : pcrbi | CRB_Bitstring bs -> EcScope.Circuit.add_bitstring scope binding.locality bs | CRB_Array ba -> EcScope.Circuit.add_array scope binding.locality ba | CRB_BvOperator op -> EcScope.Circuit.add_bvoperator scope binding.locality op - | CRB_Circuit cr -> - let file = match Loader.locate ~kinds:[`Spec] (unloc cr.file) ld with - | Some (_, file, `Spec) -> { cr.file with pl_desc = file } - | None -> EcScope.hierror ~loc:(loc cr.file) "Cannot find spec file %s.spec" (unloc cr.file) - | _ -> assert false - in + | CRB_Circuit cr -> + + let file = + if Filename.is_relative (unloc cr.file) then + Filename.concat (Loader.current_path ld) (unloc cr.file) + else unloc cr.file in + let file = mk_loc (loc cr.file) file in + + if not (Sys.file_exists (unloc file)) then + EcScope.hierror ~loc:(loc file) + "cannot find spec file: %s" (unloc file); + EcScope.Circuit.add_circuits scope binding.locality {cr with file} (* -------------------------------------------------------------------- *) @@ -829,6 +855,9 @@ let addidir ?namespace ?recursive (idir : string) = let loadpath () = List.map fst (Loader.aslist loader) +let set_current_path (path : string) = + Loader.set_current_path path loader + (* -------------------------------------------------------------------- *) type checkmode = { cm_checkall : bool; diff --git a/src/ecCommands.mli b/src/ecCommands.mli index a72d31a437..f4fac4d37f 100644 --- a/src/ecCommands.mli +++ b/src/ecCommands.mli @@ -7,9 +7,10 @@ exception Restart (* -------------------------------------------------------------------- *) type loader -val loader : loader -val addidir : ?namespace:EcLoader.namespace -> ?recursive:bool -> string -> unit +val loader : loader +val addidir : ?namespace:EcLoader.namespace -> ?recursive:bool -> string -> unit val loadpath : unit -> (EcLoader.namespace option * string) list +val set_current_path : string -> unit (* -------------------------------------------------------------------- *) type notifier = EcGState.loglevel -> string Lazy.t -> unit diff --git a/src/ecDoc.ml b/src/ecDoc.ml index 49fac0593c..f8796510e9 100644 --- a/src/ecDoc.ml +++ b/src/ecDoc.ml @@ -28,7 +28,6 @@ let thkind_str (kind : EcLoader.kind) : string = match kind with | `Ec -> "Theory" | `EcA -> "Abstract Theory" - | `Spec -> "Spec File" (* FIXME *) (* -------------------------------------------------------------------- *) let itemkind_str_pl (ik : itemkind) : string = diff --git a/src/ecEco.ml b/src/ecEco.ml index d434125b90..c85da07111 100644 --- a/src/ecEco.ml +++ b/src/ecEco.ml @@ -66,13 +66,11 @@ let kind_to_json (k : EcLoader.kind) = match k with | `Ec -> `String "ec" | `EcA -> `String "eca" - | `Spec -> `String "spec" let kind_of_json (data : Json.t) = match data with | `String "ec" -> `Ec | `String "eca" -> `EcA - | `String "spec" -> `Spec | _ -> raise InvalidEco (* -------------------------------------------------------------------- *) diff --git a/src/ecLoader.ml b/src/ecLoader.ml index a08228d376..af8d5bbedd 100644 --- a/src/ecLoader.ml +++ b/src/ecLoader.ml @@ -10,7 +10,7 @@ type ecloader = { } (* -------------------------------------------------------------------- *) -type kind = [`Ec | `EcA | `Spec] +type kind = [`Ec | `EcA] exception BadExtension of string @@ -123,7 +123,6 @@ let locate ?(namespaces = [None]) ?(kinds = [`Ec; `EcA]) (name : string) (ecl : match kind with | `Ec -> Printf.sprintf "%s.ec" name | `EcA -> Printf.sprintf "%s.eca" name - | `Spec -> Printf.sprintf "%s.spec" name in let nmok = diff --git a/src/ecLoader.mli b/src/ecLoader.mli index 00771b9b72..3be649481e 100644 --- a/src/ecLoader.mli +++ b/src/ecLoader.mli @@ -3,7 +3,7 @@ type idx_t type ecloader (* -------------------------------------------------------------------- *) -type kind = [`Ec | `EcA | `Spec] +type kind = [`Ec | `EcA] exception BadExtension of string From efd0d4c736ee888853b1edebc1da0e38a8f05685 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Thu, 26 Feb 2026 12:14:34 +0000 Subject: [PATCH 023/145] Error message for ec scope --- src/ecScope.ml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/src/ecScope.ml b/src/ecScope.ml index 6685af0b07..a845ea7879 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -1825,7 +1825,9 @@ module Theory = struct List.exists (fun x -> if x.rqd_name = name.rqd_name then ( (* FIXME: raise an error message *) - assert (x.rqd_digest = name.rqd_digest); + if (x.rqd_digest <> name.rqd_digest) then + hierror "Digest mismatch for %s: %s =/= %s" + x.rqd_name x.rqd_digest name.rqd_digest; true) else false) scope.sc_required From 5d4da0b5e935a01a598a93c84f31ddc1ec782f66 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Fri, 27 Feb 2026 10:55:41 +0000 Subject: [PATCH 024/145] nits --- src/phl/ecPhlBDep.ml | 3 ++- theories/datatypes/QFABV.ec | 4 ++++ 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index 1813ba823c..472f0a56a9 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -228,7 +228,8 @@ let t_bdep_solve assert (ctxt.h_tvar = []); let st = circuit_state_of_hyps hyps in let cgoal = (circuit_of_form st hyps goal |> state_close_circuit st) in - EcEnv.notify env `Debug "goal: %a@." pp_flatcirc (fst cgoal).reg; + (* FIXME: make this lazy *) +(* EcEnv.notify env `Debug "goal: %a@." pp_flatcirc (fst cgoal).reg; *) if circ_taut cgoal then FApi.close (!@ tc) VBdep else diff --git a/theories/datatypes/QFABV.ec b/theories/datatypes/QFABV.ec index cd904a4185..0f60739481 100644 --- a/theories/datatypes/QFABV.ec +++ b/theories/datatypes/QFABV.ec @@ -134,6 +134,10 @@ theory BVOperators. axiom bvuremP (bv1 bv2 : bv) : touint (bvurem bv1 bv2) = touint bv1 %% touint bv2. end BVURem. + + (* ------------------------------------------------------------------ *) + (* abstract theory BVSRem. FIXME: TODO *) + (* end BVSRem. *) (* ------------------------------------------------------------------ *) abstract theory BVSHL. From 4a85a0102dbc54049899ca86b25561fcd8e3fcbe Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Tue, 3 Mar 2026 15:55:51 +0000 Subject: [PATCH 025/145] WIP: Bitwuzla -> Bitwuzla_cxx --- dune-project | 2 +- easycrypt.opam | 2 +- libs/lospecs/dune | 2 +- libs/lospecs/smt.ml | 52 ++++++++++++++++++++++----------------------- 4 files changed, 28 insertions(+), 30 deletions(-) diff --git a/dune-project b/dune-project index 64b6a5eaf7..014f6f02c9 100644 --- a/dune-project +++ b/dune-project @@ -14,7 +14,7 @@ (depends (ocaml (>= 4.08.0)) (batteries (>= 3.9)) - bitwuzla + bitwuzla-cxx (camlp-streams (>= 5)) camlzip dune diff --git a/easycrypt.opam b/easycrypt.opam index d957b69428..daee24aa32 100644 --- a/easycrypt.opam +++ b/easycrypt.opam @@ -2,7 +2,7 @@ depends: [ "ocaml" {>= "4.08.0"} "batteries" {>= "3.9"} - "bitwuzla" + "bitwuzla-cxx" "camlp-streams" {>= "5"} "camlzip" "dune" {>= "3.13"} diff --git a/libs/lospecs/dune b/libs/lospecs/dune index a723995e61..97f642aa86 100644 --- a/libs/lospecs/dune +++ b/libs/lospecs/dune @@ -5,7 +5,7 @@ (:standard -open Batteries)) (preprocess (pps ppx_deriving_yojson)) - (libraries batteries bitwuzla menhirLib zarith)) + (libraries batteries bitwuzla-cxx menhirLib zarith)) (ocamllex lexer) diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index 4f7b3c38ab..d94eaae6fc 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -1,4 +1,5 @@ open Aig +open Bitwuzla_cxx module type SMTInstance = sig type bvterm @@ -25,10 +26,10 @@ module type SMTInstance = sig val bvterm_concat : bvterm -> bvterm -> bvterm (* bvand *) - val lognot : bvterm -> bvterm + val bvnot : bvterm -> bvterm (* bvnot *) - val logand : bvterm -> bvterm -> bvterm + val bvand : bvterm -> bvterm -> bvterm val get_value : bvterm -> bvterm @@ -65,7 +66,7 @@ module MakeSMTInterface(SMT: SMTInstance) : SMTInterface = struct | Some mn -> mn in - if 0 < n.id then mn else SMT.lognot mn + if 0 < n.id then mn else SMT.bvnot mn and doit_r (n : Aig.node_r) = match n with @@ -78,7 +79,7 @@ module MakeSMTInterface(SMT: SMTInstance) : SMTInterface = struct Map.String.find name !bvvars | Some t -> t end - | And (n1, n2) -> SMT.logand (doit n1) (doit n2) + | And (n1, n2) -> SMT.bvand (doit n1) (doit n2) in fun n -> doit n in @@ -110,7 +111,7 @@ module MakeSMTInterface(SMT: SMTInstance) : SMTInterface = struct in begin - SMT.assert' @@ SMT.logand pcond (SMT.lognot formula); + SMT.assert' @@ SMT.bvand pcond (SMT.bvnot formula); if SMT.check_sat () = false then true else begin Format.eprintf "bvout1: %a@." SMT.pp_term (SMT.get_value bvinpt1); @@ -153,7 +154,7 @@ module MakeSMTInterface(SMT: SMTInstance) : SMTInterface = struct | Some mn -> mn in - if 0 < n.id then mn else SMT.lognot mn + if 0 < n.id then mn else SMT.bvnot mn and doit_r (n : Aig.node_r) = match n with @@ -166,12 +167,13 @@ module MakeSMTInterface(SMT: SMTInstance) : SMTInterface = struct Map.String.find name !bvvars | Some t -> t end - | And (n1, n2) -> SMT.logand (doit n1) (doit n2) + | And (n1, n2) -> SMT.bvand (doit n1) (doit n2) in fun n -> doit n in let form = bvterm_of_node n in + let form = SMT.(bvterm_equal form @@ bvterm_of_int 1 1) in let inps = Option.bind inps (fun l -> if List.is_empty l then None @@ -213,52 +215,48 @@ end let makeBWZinstance () : (module SMTInstance) = - let module B = Bitwuzla.Once () in - let open B in + let options = Options.default () in + Options.set options Produce_models true; + + let bitwuzla = Solver.create options in (module struct - type bvterm = Term.Bv.t + type bvterm = Term.t exception SMTError let bvterm_of_int (sort: int) (v: int) : bvterm = - Term.Bv.of_int (Sort.bv sort) v + mk_bv_value_int (mk_bv_sort sort) v let bvterm_of_name (sort: int) (name: string) : bvterm = - Term.const (Sort.bv sort) name + mk_const (mk_bv_sort sort) ~symbol:name let assert' (f: bvterm) : unit = - assert' f - + Solver.assert_formula bitwuzla f let check_sat () : bool = - match check_sat () with + match Solver.check_sat bitwuzla with | Sat -> true | Unsat -> false | Unknown -> raise SMTError let bvterm_equal (bv1: bvterm) (bv2: bvterm) : bvterm = - Term.equal bv1 bv2 - + mk_term2 Kind.Equal bv1 bv2 let bvterm_concat (bv1: bvterm) (bv2: bvterm) : bvterm = - Term.Bv.concat [|bv1; bv2|] - + mk_term2 Kind.Bv_concat bv1 bv2 - let lognot (bv: bvterm) : bvterm = - Term.Bv.lognot bv - + let bvnot (bv: bvterm) : bvterm = + mk_term1 Kind.Bv_not bv - let logand (bv1: bvterm) (bv2: bvterm) : bvterm = - Term.Bv.logand bv1 bv2 - + let bvand (bv1: bvterm) (bv2: bvterm) : bvterm = + mk_term2 Kind.Bv_and bv1 bv2 let get_value (bv: bvterm) : bvterm = - (get_value bv :> bvterm) - + Solver.get_value bitwuzla bv let pp_term (fmt: Format.formatter) (bv: bvterm) : unit = Term.pp fmt bv From 4a6d7772b9a655b149737cbb2e997d8a026f8e8d Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 4 Mar 2026 12:02:52 +0100 Subject: [PATCH 026/145] progress on clones & bindings --- src/ecDecl.ml | 20 +++- src/ecDecl.mli | 20 +++- src/ecScope.ml | 223 +++++++++++++++++++++++++----------------- src/ecSubst.ml | 25 ++++- src/ecThCloning.ml | 11 ++- src/ecTheoryReplay.ml | 13 ++- 6 files changed, 203 insertions(+), 109 deletions(-) diff --git a/src/ecDecl.ml b/src/ecDecl.ml index d83120d8f5..3330d110b7 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -363,6 +363,19 @@ let field_equal f1 f2 = (* -------------------------------------------------------------------- *) type binding_size = form * (int option) +type crb_theory1_kind = + | CRBT_Type + | CRBT_Op + | CRBT_Lemma + +type crb_theory1 = + { kind: crb_theory1_kind + ; name: EcSymbols.symbol + ; path: EcPath.path } + +type crb_theory = + crb_theory1 list + type crb_bitstring = { type_ : EcPath.path ; from_ : EcPath.path @@ -371,7 +384,7 @@ type crb_bitstring = ; touint : EcPath.path ; tosint : EcPath.path ; size : binding_size - ; theory : EcPath.path } + ; theory : crb_theory } type crb_array = { type_ : EcPath.path @@ -380,7 +393,7 @@ type crb_array = ; tolist : EcPath.path ; oflist : EcPath.path ; size : binding_size - ; theory : EcPath.path } + ; theory : crb_theory } type bv_opkind = [ | `Add of binding_size (* size *) @@ -420,8 +433,7 @@ type bv_opkind = [ type crb_bvoperator = { kind : bv_opkind ; types : EcPath.path list - ; operator : EcPath.path - ; theory : EcPath.path } + ; operator : EcPath.path } type crb_circuit = { name : string diff --git a/src/ecDecl.mli b/src/ecDecl.mli index 98811ea01b..96936246a6 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -202,6 +202,19 @@ val field_equal : field -> field -> bool (* -------------------------------------------------------------------- *) type binding_size = form * (int option) +type crb_theory1_kind = + | CRBT_Type + | CRBT_Op + | CRBT_Lemma + +type crb_theory1 = + { kind: crb_theory1_kind + ; name: symbol + ; path: EcPath.path } + +type crb_theory = + crb_theory1 list + type crb_bitstring = { type_ : EcPath.path ; from_ : EcPath.path @@ -210,7 +223,7 @@ type crb_bitstring = ; touint : EcPath.path ; tosint : EcPath.path ; size : binding_size - ; theory : EcPath.path } + ; theory : crb_theory } type crb_array = { type_ : EcPath.path @@ -219,7 +232,7 @@ type crb_array = ; tolist : EcPath.path ; oflist : EcPath.path ; size : binding_size - ; theory : EcPath.path } + ; theory : crb_theory } type bv_opkind = [ | `Add of binding_size (* size *) @@ -259,8 +272,7 @@ type bv_opkind = [ type crb_bvoperator = { kind : bv_opkind ; types : EcPath.path list - ; operator : EcPath.path - ; theory : EcPath.path } + ; operator : EcPath.path } type crb_circuit = { name : string diff --git a/src/ecScope.ml b/src/ecScope.ml index a845ea7879..d86aac7884 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -2643,22 +2643,42 @@ module Circuit = struct path : EcPath.path; name : symbol; local : is_local; - theories : (symbol * path) list; - types_ : (symbol * path) list; - operators : (symbol * preoperator) list; - proofs : symbol list; + types_ : (qsymbol * path * clmode) list; + operators : (qsymbol * preoperator * clmode) list; + proofs : (qsymbol * path * clmode) list; } - let doclone (scope : scope) (clone : clone) = + let doclone (scope : scope) (preclone : clone) = let loced x = mk_loc _dummy x in let env = env scope in - let evclone = - let do_type ((x, type_) : symbol * path) : symbol * ty_override located = - (x, loced (`ByPath type_, `Inline `Keep)) in + let open EcThCloning in + + let rec in_evclone (f : evclone -> evclone) (nm : symbol list) (evc : evclone) = + match nm with + | [] -> + f evc + | name :: nm -> + let subevc, clear = Msym.find_def (evc_empty, true) name evc.evc_ths in + let subevc = in_evclone f nm subevc in + { evc with evc_ths = Msym.add name (subevc, clear) evc.evc_ths } in - let do_operator ((x, operator) : symbol * preoperator) : symbol * op_override located = - let operator = + let push_type + (evc : evclone) + (((nm, name), type_, mode) : qsymbol * path * clmode) + = + in_evclone (fun evc -> + let ovrd = loced (`ByPath type_, mode) in + let ovrd = (ovrd :> EcThCloning.xty_override located) in + { evc with evc_types = Msym.add name ovrd evc.evc_types } + ) nm evc + + and push_operator + (evc : evclone) + (((nm, name), operator, mode) : qsymbol * preoperator * clmode) + = + in_evclone (fun evc -> + let ovrd = match operator with | `Path name -> `ByPath name | `Form f -> @@ -2666,70 +2686,66 @@ module Circuit = struct { opov_tyvars = None ; opov_args = [] ; opov_retty = loced PTunivar - ; opov_body = f } - in (x, loced (operator, `Inline `Keep)) - in - - let do_theory (x : symbol) (theory : path) : EcThCloning.evclone = - let thenv = EcEnv.Theory.env_of_theory clone.path env in - let atheory = EcEnv.Theory.by_path (pqname clone.path x) thenv in - - List.fold_left (fun (evc : EcThCloning.evclone) (item : EcTheory.theory_item) -> - match item.ti_item with - | Th_operator (x, opdecl) -> begin - match opdecl.op_kind with - | OB_oper None -> - let ovrd = (`ByPath (pqname theory x), `Inline `Clear) in - { evc with evc_ops = Msym.add x (loced ovrd) evc.evc_ops } - | _ -> evc - end - | Th_type (x, _) -> - let ovrd = (`ByPath (pqname theory x), `Inline `Clear) in - { evc with evc_types = Msym.add x (loced ovrd) evc.evc_types } - | Th_axiom (x, _) -> - let evc_lemmas = - let proof = loced (EcPath.toqsymbol (pqname theory x)) in - let proof = Papply (`ExactType proof, None) in - let proof = loced (Plogic proof) in - let proof = (Some proof, `Inline `Clear, false) in - { evc.evc_lemmas with - ev_bynames = Msym.add x proof evc.evc_lemmas.ev_bynames } - in { evc with evc_lemmas } - | _ -> assert false - ) EcThCloning.evc_empty atheory.cth_items in - - { EcThCloning.evc_empty with - (* FIXME: PR: what to do here? *) - evc_types = (Msym.of_list (List.map do_type clone.types_) :> (EcThCloning.xty_override located MSym.t)); - (* FIXME: PR: what to do here? *) - evc_ops = (Msym.of_list (List.map do_operator clone.operators) :> (EcThCloning.xop_override located MSym.t)); - evc_ths = Msym.of_list (List.map (fun (x, th) -> (x, (do_theory x th, false))) clone.theories); (* FIXME PR: is the false here correct? *) - evc_lemmas = { - ev_bynames = - clone.proofs - |> List.map (fun name -> (name, (Some (loced (Ptry (loced (Pby None)))), `Alias, false))) - |> Msym.of_list; - ev_global = - (* FIXME PR: get this to work *) - [ -(* (Some (loced (Pby None)), Some [`Include, "bydone"]) *) - (None, None) - ; (None, None) ]; } } in - - let npath = EcPath.pqname (EcEnv.root env) clone.name in - let theory = EcEnv.Theory.by_path clone.path env in + ; opov_body = f } in + let ovrd = (loced (ovrd, mode) :> EcThCloning.xop_override located) in + { evc with evc_ops = Msym.add name ovrd evc.evc_ops } + ) nm evc + + and push_proof + (evc : evclone) + (((nm, name), proof, mode) : qsymbol * path * clmode) + = + in_evclone (fun evc -> + let tactic = Papply (`ExactType (loced (EcPath.toqsymbol proof)), None) in + let tactic = loced (Plogic tactic) in + let ovrd = (Some tactic, mode, false) in + let evc_lemmas = { evc.evc_lemmas with + ev_bynames = Msym.add name ovrd evc.evc_lemmas.ev_bynames } in + { evc with evc_lemmas } + ) nm evc in + + let evc = { + evc_empty with evc_lemmas = { + evc_empty.evc_lemmas with + ev_global = [ + (* (Some (loced (Pby None)), Some [`Include, "bydone"]); *) (* FIXME *) + (None, None); + (None, None); + ]; + }} in + + let evc = List.fold_left push_type evc preclone.types_ in + let evc = List.fold_left push_operator evc preclone.operators in + let evc = List.fold_left push_proof evc preclone.proofs in + + let npath = EcPath.pqname (EcEnv.root env) preclone.name in + let theory = EcEnv.Theory.by_path preclone.path env in let (proofs, scope) = - EcTheoryReplay.replay (Cloning.hooks ~override_locality:(Some clone.local)) - ~abstract:false ~override_locality:(Some clone.local) ~incl:false - ~clears:Sp.empty ~renames:[] ~opath:clone.path ~npath - evclone scope (EcPath.basename npath, false, theory.cth_items, clone.local) (* FIXME PR: check extra arguments here *) + EcTheoryReplay.replay (Cloning.hooks ~override_locality:(Some preclone.local)) + ~abstract:false ~override_locality:(Some preclone.local) ~incl:false + ~clears:Sp.empty ~renames:[] ~opath:preclone.path ~npath + evc scope (EcPath.basename npath, false, theory.cth_items, preclone.local) in let proofs = Cloning.replay_proofs scope `Check proofs in (proofs, scope) + let crb_theory_of_theory (root : path) (theory : EcTheory.ctheory) = + let crbt_item (item : EcTheory.theory_item) = + match item.ti_item with + | EcTheory.Th_type (x, _) -> (CRBT_Type , x) + | EcTheory.Th_operator (x, _) -> (CRBT_Op , x) + | EcTheory.Th_axiom (x, _) -> (CRBT_Lemma, x) + | _ -> assert false in + + let crbt_items = List.map crbt_item theory.cth_items in + + List.map (fun (kind, name) -> + let path = pqname root name in { kind; name; path; } + ) crbt_items + let add_bitstring (scope : scope) (local : is_local) (bs : pbind_bitstring) : scope = let env = env scope in @@ -2757,15 +2773,14 @@ module Circuit = struct { path = EcPath.fromqsymbol (["Top"; "QFABV"], "BV") ; name = name ; local = local - ; theories = [] - ; types_ = ["bv", bspath] + ; types_ = [([], "bv"), bspath, `Inline `Keep] ; operators = - [ ("size" , `Form bs.size) - ; ("tolist", `Path to_) - ; ("oflist", `Path from_) - ; ("touint", `Path touint) - ; ("tosint", `Path tosint) - ; ("ofint" , `Path ofint) ] + [ (([], "size" ), `Form bs.size, `Inline `Keep) + ; (([], "tolist"), `Path to_ , `Inline `Keep) + ; (([], "oflist"), `Path from_ , `Inline `Keep) + ; (([], "touint"), `Path touint , `Inline `Keep) + ; (([], "tosint"), `Path tosint , `Inline `Keep) + ; (([], "ofint" ), `Path ofint , `Inline `Keep) ] ; proofs = [] } in let proofs, scope = doclone scope preclone in @@ -2778,11 +2793,19 @@ module Circuit = struct | EcEnv.NotReducible -> None in + let crbt_items = + let env = EcSection.env scope.sc_env in + let root = EcEnv.root env in + let bvpath = pqname root name in + let bvtheory = EcEnv.Theory.by_path bvpath env in + crb_theory_of_theory bvpath bvtheory + in + let item = CRB_Bitstring { from_; to_; touint; tosint; ofint; type_ = bspath; size = (size_f, size_i); - theory = pqname (EcEnv.root env) name; } in + theory = crbt_items; } in let item = EcTheory.mkitem ~import:true (EcTheory.Th_crbinding (item, local)) in @@ -2817,18 +2840,25 @@ module Circuit = struct { path = EcPath.fromqsymbol (["Top"; "QFABV"], "A") ; name = name ; local = local - ; theories = [] - ; types_ = ["t", bspath] + ; types_ = [([], "t"), bspath, `Inline `Keep] ; operators = - [ ("size" , `Form ba.size) - ; ("get" , `Path get) - ; ("set" , `Path set) - ; ("to_list", `Path tolist) - ; ("of_list", `Path oflist) ] + [ (([], "size" ), `Form ba.size, `Inline `Keep) + ; (([], "get" ), `Path get , `Inline `Keep) + ; (([], "set" ), `Path set , `Inline `Keep) + ; (([], "to_list"), `Path tolist , `Inline `Keep) + ; (([], "of_list"), `Path oflist , `Inline `Keep) ] ; proofs = [] } in let proofs, scope = doclone scope preclone in + let crbt_items = + let env = EcSection.env scope.sc_env in + let root = EcEnv.root env in + let bvpath = pqname root name in + let bvtheory = EcEnv.Theory.by_path bvpath env in + crb_theory_of_theory bvpath bvtheory + in + let size_f = EcTyping.trans_form env (EcUnify.UniEnv.create None) ba.size tint in let size_i = try Some (EcCallbyValue.norm_cbv EcReduction.full_red (EcEnv.LDecl.init env []) size_f |> destr_int |> BI.to_int) @@ -2841,7 +2871,7 @@ module Circuit = struct { get; set; tolist; oflist; type_ = bspath; size = (size_f, size_i); - theory = pqname (EcEnv.root env) name; } in + theory = crbt_items; } in let item = EcTheory.mkitem ~import:true (Th_crbinding (item, local)) in @@ -3043,22 +3073,37 @@ module Circuit = struct in (counts, (name, theory)) ) counts0 types in + + let cltheories = + cltheories + |> List.map (fun (name, clth) -> + List.map (fun (item : crb_theory1) -> (([name], item.name), item)) clth) + |> List.flatten in + + let filter_cltheories (kind : crb_theory1_kind) = + List.filter_map (fun (qname, (item : crb_theory1)) -> + if item.kind = kind then Some (qname, item.path, `Inline `Clear) else None + ) cltheories in + + let types_ = filter_cltheories CRBT_Type in + let operators = filter_cltheories CRBT_Op in + let operators = List.map (fun (qn, p, mode) -> (qn, `Path p, mode)) operators in + let proofs = filter_cltheories CRBT_Lemma in + let preclone = { path = EcPath.fromqsymbol (["Top"; "QFABV"; "BVOperators"], subname) ; name = name ; local = local - ; theories = cltheories - ; types_ = [] - ; operators = ["bv" ^ unloc op.name, `Path operator] - ; proofs = [] } in + ; types_ = types_ + ; operators = [([], "bv" ^ unloc op.name), `Path operator, `Inline `Keep] @ operators + ; proofs = proofs } in let proofs, scope = doclone scope preclone in let item = CRB_BvOperator { kind = kind (List.map proj3_2 types); types = List.map proj3_1 types; - operator = operator; - theory = EcPath.pqname (EcEnv.root env) subname; } in + operator = operator; } in let item = EcTheory.mkitem ~import:true (Th_crbinding (item, local)) in diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 8a61f7a012..69ca75e702 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -1053,6 +1053,24 @@ let subst_bv_opkind ?(red: (form -> int option) option) (s: subst) (opk: bv_opki | `ASliceGet ((s1, s2), s3) -> `ASliceGet ((ssize s1, ssize s2), ssize s3) | `B2A (s1, (s2, s3)) -> `B2A (ssize s1, (ssize s2, ssize s3)) +(* -------------------------------------------------------------------- *) +let subst_crb_theory1 (s : subst) (crbth1 : crb_theory1) = + let path = + match crbth1.kind with + | CRBT_Type -> + assert (not (Mp.mem crbth1.path s.sb_tydef)); + subst_path s crbth1.path + | CRBT_Op -> + assert (not (Mp.mem crbth1.path s.sb_def)); + subst_path s crbth1.path + | CRBT_Lemma -> + subst_path s crbth1.path + in { kind = crbth1.kind; name = crbth1.name; path; } + +(* -------------------------------------------------------------------- *) +let subst_crb_theory (s : subst) (crbth : crb_theory) = + List.map (subst_crb_theory1 s) crbth + (* -------------------------------------------------------------------- *) let subst_crbinding ?(red: (form -> int option) option) (s : subst) (crb : crbinding) = match crb with @@ -1072,7 +1090,7 @@ let subst_crbinding ?(red: (form -> int option) option) (s : subst) (crb : crbin tosint = subst_path s bs.tosint; ofint = subst_path s bs.ofint; size = subst_binding_size ?red s bs.size; - theory = subst_path s bs.theory; } + theory = subst_crb_theory s bs.theory; } | CRB_Array ba -> assert (not (Mp.mem ba.type_ s.sb_tydef)); @@ -1087,7 +1105,7 @@ let subst_crbinding ?(red: (form -> int option) option) (s : subst) (crb : crbin tolist = subst_path s ba.tolist; oflist = subst_path s ba.oflist; size = subst_binding_size ?red s ba.size; - theory = subst_path s ba.theory } + theory = subst_crb_theory s ba.theory } | CRB_BvOperator op -> assert (List.for_all (fun ty -> not (Mp.mem ty s.sb_tydef)) op.types); @@ -1095,8 +1113,7 @@ let subst_crbinding ?(red: (form -> int option) option) (s : subst) (crb : crbin CRB_BvOperator { kind = subst_bv_opkind ?red s op.kind; types = List.map (subst_path s) op.types; - operator = subst_path s op.operator; - theory = subst_path s op.theory; } + operator = subst_path s op.operator; } | CRB_Circuit cr -> assert (not (Mp.mem cr.operator s.sb_def)); diff --git a/src/ecThCloning.ml b/src/ecThCloning.ml index 995d6aa909..2e06eba546 100644 --- a/src/ecThCloning.ml +++ b/src/ecThCloning.ml @@ -65,6 +65,10 @@ type xop_override = type xpr_override = [pr_override_def genoverride | `Direct of EcAst.form] * clmode +(* ------------------------------------------------------------------ *) +type nt_override = + EcPath.path * clmode + (* ------------------------------------------------------------------ *) type evclone = { evc_types : (xty_override located) Msym.t; @@ -482,7 +486,7 @@ end = struct let ovrd = (`ByPath (tgpath ~kind:`Pred x), mode) in pr_ovrd oc (proofs, evc) (dtpath x) ovrd - | Th_operator (x, {op_kind=OB_nott _; _ }) -> + | Th_operator (x, {op_kind = OB_nott _ }) -> let ovrd = (tgpath x, mode) in nt_ovrd oc (proofs, evc) (dtpath x) ovrd @@ -508,8 +512,7 @@ end = struct | Th_modtype (x, _) -> let ovrd = loced (EcPath.toqsymbol (tgpath ~kind:`ModType x)) in - modtype_ovrd - oc (proofs, evc) (dtpath x) (ovrd, mode) + modtype_ovrd oc (proofs, evc) (dtpath x) (ovrd, mode) | Th_instance _ -> (proofs, evc) @@ -517,8 +520,8 @@ end = struct | Th_addrw _ -> (proofs, evc) | Th_reduction _ -> (proofs, evc) | Th_auto _ -> (proofs, evc) - | Th_crbinding _ -> (proofs, evc) | Th_alias _ -> (proofs, evc) + | Th_crbinding _ -> (proofs, evc) and doit prefix (proofs, evc) dth = doit_r prefix (proofs, evc) dth.ti_item diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 2e911f327d..baeda99904 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -1050,8 +1050,11 @@ and replay_crb_bitstring (ove : _ ovrenv) (subst, ops, proofs, scope) (import, b | Tconstr (p, []) -> p | _ -> forpath bs.type_ (* FIXME: fallback *) in - let theory = EcSubst.subst_path subst bs.theory in (* FIXME *) let size = EcSubst.subst_binding_size ~red subst bs.size in + let theory = + List.map + (fun crbth -> { crbth with path = forpath crbth.path }) + bs.theory in let bs = CRB_Bitstring { to_; from_; touint; tosint; ofint; type_; theory; size; } in let scope = ove.ovre_hooks.hadd_item scope ~import (Th_crbinding (bs, lc)) in @@ -1086,7 +1089,10 @@ and replay_crb_array (ove : _ ovrenv) (subst, ops, proofs, scope) (import, ba, l | _ -> assert false (* FIXME: do we always get a good type here? *) in let size = EcSubst.subst_binding_size ~red subst ba.size in - let theory = EcSubst.subst_path subst ba.theory in (* FIXME *) + let theory = + List.map + (fun crbth -> { crbth with path = forpath crbth.path }) + ba.theory in let ba = CRB_Array { get; set; tolist; oflist; type_; size; theory; } in let scope = ove.ovre_hooks.hadd_item scope ~import (Th_crbinding (ba, lc)) in @@ -1116,9 +1122,8 @@ and replay_crb_bvoperator (ove : _ ovrenv) (subst, ops, proofs, scope) (import, let kind = EcSubst.subst_bv_opkind ~red subst op.kind in let operator = forpath op.operator in let types = List.map forpath op.types in (* FIXME *) - let theory = forpath op.theory in (* FIXME *) - let op = CRB_BvOperator { kind; operator; types; theory; } in + let op = CRB_BvOperator { kind; operator; types; } in let scope = ove.ovre_hooks.hadd_item scope ~import (Th_crbinding (op, lc)) in (subst, ops, proofs, scope) From d98dc0b26ad2b9d83e04630d4b14699a729f84fe Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 4 Mar 2026 18:16:50 +0100 Subject: [PATCH 027/145] generic bindings now work --- src/ecDecl.ml | 11 ++- src/ecDecl.mli | 11 ++- src/ecPrinting.ml | 24 ++++++ src/ecScope.ml | 62 +++++++++----- src/ecSubst.ml | 26 +++--- src/ecSubst.mli | 3 +- src/ecThCloning.ml | 6 +- src/ecThCloning.mli | 6 +- src/ecTheoryReplay.ml | 185 ++++++++++++++++++++++++++++-------------- 9 files changed, 225 insertions(+), 109 deletions(-) diff --git a/src/ecDecl.ml b/src/ecDecl.ml index 3330d110b7..88890d79a8 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -364,14 +364,13 @@ let field_equal f1 f2 = type binding_size = form * (int option) type crb_theory1_kind = - | CRBT_Type - | CRBT_Op - | CRBT_Lemma + | CRBT_Type of EcPath.path + | CRBT_Op of ty_params * expr + | CRBT_Lemma of EcPath.path type crb_theory1 = - { kind: crb_theory1_kind - ; name: EcSymbols.symbol - ; path: EcPath.path } + { name: EcSymbols.symbol + ; kind: crb_theory1_kind } type crb_theory = crb_theory1 list diff --git a/src/ecDecl.mli b/src/ecDecl.mli index 96936246a6..a6f1954606 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -203,14 +203,13 @@ val field_equal : field -> field -> bool type binding_size = form * (int option) type crb_theory1_kind = - | CRBT_Type - | CRBT_Op - | CRBT_Lemma + | CRBT_Type of EcPath.path + | CRBT_Op of ty_params * expr + | CRBT_Lemma of EcPath.path type crb_theory1 = - { kind: crb_theory1_kind - ; name: symbol - ; path: EcPath.path } + { name: EcSymbols.symbol + ; kind: crb_theory1_kind } type crb_theory = crb_theory1 list diff --git a/src/ecPrinting.ml b/src/ecPrinting.ml index a30f9871c1..3cf71d34b0 100644 --- a/src/ecPrinting.ml +++ b/src/ecPrinting.ml @@ -3567,6 +3567,28 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = (pp_list "@,@," (pp_th_item ppe path)) cth.cth_items basename + and pp_crb_theory1 (ppe : PPEnv.t) (fmt : Format.formatter) (item : crb_theory1) = + match item.kind with + | CRBT_Type p -> + Format.fprintf fmt "%s/ty:%a" item.name (pp_tyname ppe) p + | CRBT_Op (tparams, { e_node = Eop (p, tys) }) + when List.for_all2 ty_equal (List.map tvar tparams) tys + -> + let ppe = PPEnv.add_locals ppe tparams in + Format.fprintf fmt "%s/op: %a" + item.name (pp_opname ppe) p + | CRBT_Op (tparams, e) -> + let ppe = PPEnv.add_locals ppe tparams in + Format.fprintf fmt "%s/op:[%a] %a" + item.name + (pp_list ",@ " (pp_tyvar ppe)) tparams + (pp_expr ppe) e + | CRBT_Lemma p -> + Format.fprintf fmt "%s/ax:%a" item.name (pp_axname ppe) p + + and pp_crb_theory (ppe : PPEnv.t) (fmt : Format.formatter) (crbth : crb_theory) = + Format.fprintf fmt "%a" (pp_list ", " (pp_crb_theory1 ppe)) crbth + and pp_th_item_r ppe p fmt item = match item.EcTheory.ti_item with | EcTheory.Th_type (id, ty) -> @@ -3669,6 +3691,7 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = | EcTheory.Th_crbinding (binding, lc) -> begin match binding with | CRB_Bitstring bs -> + Format.fprintf fmt "(* %a *) " (pp_crb_theory ppe) bs.theory; Format.fprintf fmt "%abind bitstring %a %a %a %a%s." pp_locality lc (pp_opname ppe) bs.to_ @@ -3678,6 +3701,7 @@ let rec pp_theory ppe (fmt : Format.formatter) (path, cth) = (if Option.is_some (snd bs.size) then " (concrete)" else " (abstract)") | CRB_Array ba -> + Format.fprintf fmt "(* %a *) " (pp_crb_theory ppe) ba.theory; Format.fprintf fmt "%abind array %a %a %a %a %a %a%s." pp_locality lc (pp_tyname ppe) ba.type_ diff --git a/src/ecScope.ml b/src/ecScope.ml index d86aac7884..638907b516 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -2313,7 +2313,7 @@ module Ty = struct ); ]; evc_ops = Msym.of_list [ - "P", loced (`Direct pred, `Inline `Clear) + "P", loced (`Direct ([], pred), `Inline `Clear) ]; evc_lemmas = { ev_bynames = Msym.empty; @@ -2637,7 +2637,11 @@ end (* -------------------------------------------------------------------- *) module Circuit = struct - type preoperator = [`Path of path | `Form of pformula] + type preoperator = [ + | `Path of path + | `Direct of ty_params * expr + | `Form of pformula + ] type clone = { path : EcPath.path; @@ -2681,7 +2685,8 @@ module Circuit = struct let ovrd = match operator with | `Path name -> `ByPath name - | `Form f -> + | `Direct (tparams, body) -> `Direct (tparams, form_of_expr body) + | `Form f -> `BySyntax { opov_tyvars = None ; opov_args = [] @@ -2735,16 +2740,18 @@ module Circuit = struct let crb_theory_of_theory (root : path) (theory : EcTheory.ctheory) = let crbt_item (item : EcTheory.theory_item) = match item.ti_item with - | EcTheory.Th_type (x, _) -> (CRBT_Type , x) - | EcTheory.Th_operator (x, _) -> (CRBT_Op , x) - | EcTheory.Th_axiom (x, _) -> (CRBT_Lemma, x) + | EcTheory.Th_type (name, _) -> + { name; kind = CRBT_Type (pqname root name) } + | EcTheory.Th_operator (name, op) -> + (* FIXME: refresh type parameters? *) + let tvars = List.map tvar op.op_tparams in + let body = e_op (pqname root name) tvars op.op_ty in + { name; kind = CRBT_Op (op.op_tparams, body) } + | EcTheory.Th_axiom (name, _) -> + { name; kind = CRBT_Lemma (pqname root name) } | _ -> assert false in - let crbt_items = List.map crbt_item theory.cth_items in - - List.map (fun (kind, name) -> - let path = pqname root name in { kind; name; path; } - ) crbt_items + List.map crbt_item theory.cth_items let add_bitstring (scope : scope) (local : is_local) (bs : pbind_bitstring) : scope = let env = env scope in @@ -3073,22 +3080,33 @@ module Circuit = struct in (counts, (name, theory)) ) counts0 types in - let cltheories = cltheories |> List.map (fun (name, clth) -> List.map (fun (item : crb_theory1) -> (([name], item.name), item)) clth) |> List.flatten in - let filter_cltheories (kind : crb_theory1_kind) = + let types_ = List.filter_map (fun (qname, (item : crb_theory1)) -> - if item.kind = kind then Some (qname, item.path, `Inline `Clear) else None + match item.kind with + | CRBT_Type p -> Some (qname, p, `Inline `Clear) + | _ -> None ) cltheories in - let types_ = filter_cltheories CRBT_Type in - let operators = filter_cltheories CRBT_Op in - let operators = List.map (fun (qn, p, mode) -> (qn, `Path p, mode)) operators in - let proofs = filter_cltheories CRBT_Lemma in + let operators = + List.filter_map (fun (qname, (item : crb_theory1)) -> + match item.kind with + | CRBT_Op (tparams, e) -> + Some (qname, `Direct (tparams, e), `Inline `Clear) + | _ -> None + ) cltheories in + + let proofs = + List.filter_map (fun (qname, (item : crb_theory1)) -> + match item.kind with + | CRBT_Lemma p -> Some (qname, p, `Inline `Clear) + | _ -> None + ) cltheories in let preclone = { path = EcPath.fromqsymbol (["Top"; "QFABV"; "BVOperators"], subname) @@ -3112,7 +3130,13 @@ module Circuit = struct Ax.add_defer scope proofs - let add_circuit1 ~(filename: string) (scope : scope) (local : is_local) ((op, circ) : (pqsymbol * string located)) : scope = + let add_circuit1 + ~(filename : string) + (scope : scope) + (local : is_local) + ((op, circ) : (pqsymbol * string located)) + : scope + = let env = env scope in let operator, opdecl = EcEnv.Op.lookup op.pl_desc env in diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 69ca75e702..b82c4f1799 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -1053,19 +1053,23 @@ let subst_bv_opkind ?(red: (form -> int option) option) (s: subst) (opk: bv_opki | `ASliceGet ((s1, s2), s3) -> `ASliceGet ((ssize s1, ssize s2), ssize s3) | `B2A (s1, (s2, s3)) -> `B2A (ssize s1, (ssize s2, ssize s3)) +(* -------------------------------------------------------------------- *) +let subst_crb_theory1_kind (s : subst) (kind : crb_theory1_kind) = + match kind with + | CRBT_Type p -> + assert (not (Mp.mem p s.sb_tydef)); + CRBT_Type (subst_path s p) + | CRBT_Op (tparams, body) -> + let s, tparams = fresh_tparams s tparams in + let body = subst_expr s body in + CRBT_Op (tparams, body) + | CRBT_Lemma p -> + CRBT_Lemma (subst_path s p) + (* -------------------------------------------------------------------- *) let subst_crb_theory1 (s : subst) (crbth1 : crb_theory1) = - let path = - match crbth1.kind with - | CRBT_Type -> - assert (not (Mp.mem crbth1.path s.sb_tydef)); - subst_path s crbth1.path - | CRBT_Op -> - assert (not (Mp.mem crbth1.path s.sb_def)); - subst_path s crbth1.path - | CRBT_Lemma -> - subst_path s crbth1.path - in { kind = crbth1.kind; name = crbth1.name; path; } + { kind = subst_crb_theory1_kind s crbth1.kind + ; name = crbth1.name } (* -------------------------------------------------------------------- *) let subst_crb_theory (s : subst) (crbth : crb_theory) = diff --git a/src/ecSubst.mli b/src/ecSubst.mli index 66b47c3782..d23afea4a8 100644 --- a/src/ecSubst.mli +++ b/src/ecSubst.mli @@ -36,7 +36,8 @@ val add_elocals : subst -> EcIdent.t list -> expr list -> subst val rename_flocal : subst -> EcIdent.t -> EcIdent.t -> ty -> subst (* -------------------------------------------------------------------- *) -val freshen_type : (ty_params * ty) -> (ty_params * ty) +val fresh_tparams : subst -> ty_params -> subst * ty_params +val freshen_type : (ty_params * ty) -> (ty_params * ty) (* -------------------------------------------------------------------- *) val subst_theory : subst -> theory -> theory diff --git a/src/ecThCloning.ml b/src/ecThCloning.ml index 2e06eba546..771e616275 100644 --- a/src/ecThCloning.ml +++ b/src/ecThCloning.ml @@ -58,8 +58,10 @@ type xty_override = [ty_override_def genoverride | `Direct of EcAst.ty] * clmode (* ------------------------------------------------------------------ *) -type xop_override = - [op_override_def genoverride | `Direct of EcAst.form] * clmode +type xop_override = [ + | op_override_def genoverride + | `Direct of EcDecl.ty_params * EcAst.form +] * clmode (* ------------------------------------------------------------------ *) type xpr_override = diff --git a/src/ecThCloning.mli b/src/ecThCloning.mli index 82e160cfa2..780ee397fc 100644 --- a/src/ecThCloning.mli +++ b/src/ecThCloning.mli @@ -44,8 +44,10 @@ type xty_override = [ty_override_def genoverride | `Direct of EcAst.ty] * clmode (* ------------------------------------------------------------------ *) -type xop_override = - [op_override_def genoverride | `Direct of EcAst.form] * clmode +type xop_override = [ + | op_override_def genoverride + | `Direct of EcDecl.ty_params * EcAst.form +] * clmode (* ------------------------------------------------------------------ *) type xpr_override = diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index ea49f400fb..d55a03dc39 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -403,7 +403,7 @@ let rename ove subst (kind, name) = exception InvInstPath (* -------------------------------------------------------------------- *) -let forpath ~(opath : EcPath.path) ~(npath : EcPath.path) ~(ops : _ Mp.t) (p : EcPath.path) = +let for_op_path ~(opath : EcPath.path) ~(npath : EcPath.path) ~(ops : _ Mp.t) (p : EcPath.path) = match EcPath.remprefix ~prefix:opath ~path:p |> omap List.rev with | None | Some [] -> None | Some (x::px) -> @@ -431,9 +431,24 @@ let forpath ~(opath : EcPath.path) ~(npath : EcPath.path) ~(ops : _ Mp.t) (p : E | Fop (r, _) -> Some r | _ -> raise InvInstPath -let forpath ~opath ~npath ~ops p = - odfl p (forpath ~opath ~npath ~ops p) +(* -------------------------------------------------------------------- *) +let for_op_path ~opath ~npath ~ops p = + odfl p (for_op_path ~opath ~npath ~ops p) +(* -------------------------------------------------------------------- *) +let for_ty_path (subst : EcSubst.subst) ?(nargs = 0) (p : EcPath.path) = + let tyargs = List.init nargs (fun _ -> tvar (EcIdent.create "_")) in + + match (EcSubst.subst_ty subst (tconstr p tyargs)).ty_node with + | Tconstr (p, tyargs') when List.equal ty_equal tyargs tyargs' -> p + | _ -> raise InvInstPath + +(* -------------------------------------------------------------------- *) +let for_ty_path (env : EcEnv.env) (subst : EcSubst.subst) (p : EcPath.path) = + let env = EcEnv.Theory.env_of_theory (oget (EcPath.prefix p)) env in + let nargs = List.length ((EcEnv.Ty.by_path p env).tyd_params) in + for_ty_path subst ~nargs p + (* -------------------------------------------------------------------- *) let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd) = let scenv = ove.ovre_hooks.henv scope in @@ -568,6 +583,26 @@ and replay_opd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopd) = (subst, ops, proofs, ove.ovre_hooks.hadd_item scope ~import (Th_operator (x, oopd))) | Some { pl_desc = (opov, opmode); pl_loc = loc; } -> + let bypath (p : EcPath.path) = + match EcEnv.Op.by_path_opt p env with + | Some ({ op_kind = OB_oper _ } as refop) -> + let tyargs = List.map tvar refop.op_tparams in + let body = + if refop.op_clinline then + (match refop.op_kind with + | OB_oper (Some (OP_Plain body)) -> body + | _ -> assert false) + else EcFol.f_op p tyargs refop.op_ty in + let decl = + { refop with + op_kind = OB_oper (Some (OP_Plain body)); + op_clinline = (opmode <> `Alias) } in + (decl, body) + + | _ -> + clone_error env (CE_UnkOverride(OVK_Operator, EcPath.toqsymbol p)) + in + let refop = EcSubst.subst_op subst oopd in let (reftyvars, refty) = (refop.op_tparams, refop.op_ty) in @@ -607,27 +642,15 @@ and replay_opd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, oopd) = tparams ty (Some (OP_Plain body)) refop.op_loca in (newop, body) - | `ByPath p -> begin - match EcEnv.Op.by_path_opt p env with - | Some ({ op_kind = OB_oper _ } as refop) -> - let tyargs = List.map tvar refop.op_tparams in - let body = - if refop.op_clinline then - (match refop.op_kind with - | OB_oper (Some (OP_Plain body)) -> body - | _ -> assert false) - else EcFol.f_op p tyargs refop.op_ty in - let decl = - { refop with - op_kind = OB_oper (Some (OP_Plain body)); - op_clinline = (opmode <> `Alias) } in - (decl, body) + | `ByPath p -> + bypath p - | _ -> clone_error env (CE_UnkOverride(OVK_Operator, EcPath.toqsymbol p)) - end + | `Direct (tps, { f_node = Fop (p, tys) }) + when List.for_all2 ty_equal (List.map tvar tps) tys -> + bypath p - | `Direct body -> - assert (List.is_empty refop.op_tparams); + | `Direct (tparams, body) -> + assert (List.compare_lengths tparams refop.op_tparams = 0); let newop = mk_op ~opaque:optransparent ~clinline:(opmode <> `Alias) @@ -986,7 +1009,7 @@ and replay_instance = let opath = ove.ovre_opath in let npath = ove.ovre_npath in - let forpath = forpath ~npath ~opath ~ops in + let forpath = for_op_path ~npath ~opath ~ops in try let (typ, ty) = EcSubst.subst_genty subst (typ, ty) in @@ -1027,33 +1050,49 @@ and replay_instance (* -------------------------------------------------------------------- *) and replay_crb_bitstring (ove : _ ovrenv) (subst, ops, proofs, scope) (import, bs, lc) = + let env = EcSection.env (ove.ovre_hooks.henv scope) in + let hyps = EcEnv.LDecl.init env [] in + let opath = ove.ovre_opath in let npath = ove.ovre_npath in - let forpath = forpath ~npath ~opath ~ops in - let env = EcSection.env (ove.ovre_hooks.henv scope) in - let hyps = EcEnv.LDecl.init env [] in + let oppath = for_op_path ~npath ~opath ~ops in + let typath = for_ty_path env subst in + + let crbpath (kind : crb_theory1_kind) = + match kind with + | CRBT_Type p -> + CRBT_Type (typath p) + | CRBT_Op (tparams, body) -> + let subst, tparams = EcSubst.fresh_tparams subst tparams in + let body = EcSubst.subst_expr subst body in + CRBT_Op (tparams, body) + | CRBT_Lemma p -> CRBT_Lemma (EcSubst.subst_path subst p) + in + let red f = try - Some (EcCallbyValue.norm_cbv EcReduction.full_red hyps f |> EcCoreFol.destr_int |> BI.to_int) + Some ( + EcCallbyValue.norm_cbv EcReduction.full_red hyps f + |> EcCoreFol.destr_int + |> BI.to_int + ) with | EcCoreFol.DestrError "destr_int" -> None | EcEnv.NotReducible -> None in try - let to_ = forpath bs.to_ in - let from_ = forpath bs.from_ in - let touint = forpath bs.touint in - let tosint = forpath bs.tosint in - let ofint = forpath bs.ofint in - let type_ = match (EcSubst.subst_ty subst (tconstr bs.type_ [])).ty_node with - | Tconstr (p, []) -> p - | _ -> forpath bs.type_ (* FIXME: fallback *) - in + let to_ = oppath bs.to_ in + let from_ = oppath bs.from_ in + let touint = oppath bs.touint in + let tosint = oppath bs.tosint in + let ofint = oppath bs.ofint in + let type_ = typath bs.type_ in let size = EcSubst.subst_binding_size ~red subst bs.size in let theory = List.map - (fun crbth -> { crbth with path = forpath crbth.path }) + (fun (crbth : crb_theory1) -> + { crbth with kind = crbpath crbth.kind }) bs.theory in let bs = CRB_Bitstring { to_; from_; touint; tosint; ofint; type_; theory; size; } in @@ -1062,36 +1101,52 @@ and replay_crb_bitstring (ove : _ ovrenv) (subst, ops, proofs, scope) (import, b (subst, ops, proofs, scope) with InvInstPath -> + Format.eprintf "[W]PAF@."; (subst, ops, proofs, scope) (* -------------------------------------------------------------------- *) and replay_crb_array (ove : _ ovrenv) (subst, ops, proofs, scope) (import, ba, lc) = + let env = EcSection.env (ove.ovre_hooks.henv scope) in + let hyps = EcEnv.LDecl.init env [] in + let opath = ove.ovre_opath in let npath = ove.ovre_npath in - let forpath = forpath ~npath ~opath ~ops in + let oppath = for_op_path ~npath ~opath ~ops in + let typath = for_ty_path env subst in + + let crbpath (kind : crb_theory1_kind) = + match kind with + | CRBT_Type p -> + CRBT_Type (typath p) + | CRBT_Op (tparams, body) -> + let subst, tparams = EcSubst.fresh_tparams subst tparams in + let body = EcSubst.subst_expr subst body in + CRBT_Op (tparams, body) + | CRBT_Lemma p -> CRBT_Lemma (EcSubst.subst_path subst p) + in - let env = EcSection.env (ove.ovre_hooks.henv scope) in - let hyps = EcEnv.LDecl.init env [] in let red f = try - Some (EcCallbyValue.norm_cbv EcReduction.full_red hyps f |> EcCoreFol.destr_int |> BI.to_int) + Some ( + EcCallbyValue.norm_cbv EcReduction.full_red hyps f + |> EcCoreFol.destr_int + |> BI.to_int + ) with | EcCoreFol.DestrError "destr_int" -> None | EcEnv.NotReducible -> None in try - let get = forpath ba.get in - let set = forpath ba.set in - let tolist = forpath ba.tolist in - let oflist = forpath ba.oflist in - let type_ = match (EcSubst.subst_ty subst (tconstr ba.type_ [tint])).ty_node with (* FIXME: hack *) - | Tconstr (p, _::[]) -> p - | _ -> assert false (* FIXME: do we always get a good type here? *) - in + let get = oppath ba.get in + let set = oppath ba.set in + let tolist = oppath ba.tolist in + let oflist = oppath ba.oflist in + let type_ = typath ba.type_ in let size = EcSubst.subst_binding_size ~red subst ba.size in let theory = List.map - (fun crbth -> { crbth with path = forpath crbth.path }) + (fun (crbth : crb_theory1) -> + { crbth with kind = crbpath crbth.kind }) ba.theory in let ba = CRB_Array { get; set; tolist; oflist; type_; size; theory; } in @@ -1105,24 +1160,30 @@ and replay_crb_array (ove : _ ovrenv) (subst, ops, proofs, scope) (import, ba, l (* -------------------------------------------------------------------- *) and replay_crb_bvoperator (ove : _ ovrenv) (subst, ops, proofs, scope) (import, op, lc) = + let env = EcSection.env (ove.ovre_hooks.henv scope) in + let hyps = EcEnv.LDecl.init env [] in + let opath = ove.ovre_opath in let npath = ove.ovre_npath in - let forpath = forpath ~npath ~opath ~ops in + let oppath = for_op_path ~npath ~opath ~ops in + let typath = for_ty_path env subst in - let env = EcSection.env (ove.ovre_hooks.henv scope) in - let hyps = EcEnv.LDecl.init env [] in - let red f = try - Some (EcCallbyValue.norm_cbv EcReduction.full_red hyps f |> EcCoreFol.destr_int |> BI.to_int) - with + let red f = + try + Some ( + EcCallbyValue.norm_cbv EcReduction.full_red hyps f + |> EcCoreFol.destr_int + |> BI.to_int + ) + with | EcCoreFol.DestrError "destr_int" -> None | EcEnv.NotReducible -> None in try - let kind = EcSubst.subst_bv_opkind ~red subst op.kind in - let operator = forpath op.operator in - let types = List.map forpath op.types in (* FIXME *) - + let kind = EcSubst.subst_bv_opkind ~red subst op.kind in + let operator = oppath op.operator in + let types = List.map typath op.types in let op = CRB_BvOperator { kind; operator; types; } in let scope = ove.ovre_hooks.hadd_item scope ~import (Th_crbinding (op, lc)) in @@ -1135,12 +1196,12 @@ and replay_crb_bvoperator (ove : _ ovrenv) (subst, ops, proofs, scope) (import, and replay_crb_circuit (ove : _ ovrenv) (subst, ops, proofs, scope) (import, cr, lc) = let opath = ove.ovre_opath in let npath = ove.ovre_npath in - let forpath = forpath ~npath ~opath ~ops in + let oppath = for_op_path ~npath ~opath ~ops in try let name = cr.name in let circuit = cr.circuit in - let operator = forpath cr.operator in + let operator = oppath cr.operator in let cr = CRB_Circuit { name; circuit; operator; } in let scope = ove.ovre_hooks.hadd_item scope ~import (Th_crbinding (cr, lc)) in From 2b00eb5c21651f00bb161e27a5f116dded5dbb20 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sun, 8 Mar 2026 05:56:02 +0100 Subject: [PATCH 028/145] [refold]: allow rigid unification Syntax: `rewrite -/~(pattern)` --- src/ecHiGoal.ml | 42 +++++++++++++++++++++++------------------- src/ecHiGoal.mli | 2 +- src/ecParser.mly | 4 ++-- src/ecParsetree.ml | 2 +- 4 files changed, 27 insertions(+), 23 deletions(-) diff --git a/src/ecHiGoal.ml b/src/ecHiGoal.ml index d34ba4aa76..f2b67436a9 100644 --- a/src/ecHiGoal.ml +++ b/src/ecHiGoal.ml @@ -598,9 +598,10 @@ let process_rewrite1_core ?mode ?(close = true) ?target (s, p, o) pt tc = tc_error !!tc "r-pattern does not match the rewriting rule" (* -------------------------------------------------------------------- *) -let process_delta ~und_delta ?target (s, o, p) tc = +let process_delta ~und_delta ?(rigid = false) ?target (s, o, p) tc = let env, hyps, concl = FApi.tc1_eflat tc in let o = norm_rwocc o in + let occmode = if rigid then Some om_rigid else None in let idtg, target = match target with @@ -668,7 +669,7 @@ let process_delta ~und_delta ?target (s, o, p) tc = match s with | `LtoR -> begin let matches = - try ignore (PT.pf_find_occurence ptenv ~ptn:p target); true + try ignore (PT.pf_find_occurence ptenv ?occmode ~ptn:p target); true with PT.FindOccFailure _ -> false in @@ -729,23 +730,26 @@ let process_delta ~und_delta ?target (s, o, p) tc = with EcEnv.NotReducible -> fp in - let matches = - try ignore (PT.pf_find_occurence ptenv ~ptn:fp target); true - with PT.FindOccFailure _ -> false - in + begin + match PT.pf_find_occurence ?occmode ptenv ~ptn:fp target with + | (_, occmode) -> + let p = concretize_form ptenv p in + let fp = concretize_form ptenv fp in + let cpos = + try + FPosition.select_form + ?xconv:(if rigid then Some `AlphaEq else None) + ?keyed:(if rigid then Some occmode.k_keyed else None) + hyps o fp target + with InvalidOccurence -> + tc_error !!tc "invalid occurences selector" in - if matches then begin - let p = concretize_form ptenv p in - let fp = concretize_form ptenv fp in - let cpos = - try FPosition.select_form hyps o fp target - with InvalidOccurence -> - tc_error !!tc "invalid occurences selector" - in + let target = FPosition.map cpos (fun _ -> p) target in + t_change ~ri ?target:idtg target tc - let target = FPosition.map cpos (fun _ -> p) target in - t_change ~ri ?target:idtg target tc - end else t_id tc + | exception (PT.FindOccFailure _) -> + t_id tc + end (* -------------------------------------------------------------------- *) let process_rewrite1_r ttenv ?target ri tc = @@ -768,11 +772,11 @@ let process_rewrite1_r ttenv ?target ri tc = let target = target |> omap (fst -| ((LDecl.hyp_by_name^~ hyps) -| unloc)) in t_simplify_lg ?target ~delta:`IfApplied (ttenv, logic) tc - | RWDelta ((s, r, o, px), p) -> begin + | RWDelta (rigid, (s, r, o, px), p) -> begin if Option.is_some px then tc_error !!tc "cannot use pattern selection in delta-rewrite rules"; - let do1 tc = process_delta ~und_delta ?target (s, o, p) tc in + let do1 tc = process_delta ~und_delta ~rigid ?target (s, o, p) tc in match r with | None -> do1 tc diff --git a/src/ecHiGoal.mli b/src/ecHiGoal.mli index 317163fd6e..ff18b1f8c9 100644 --- a/src/ecHiGoal.mli +++ b/src/ecHiGoal.mli @@ -75,7 +75,7 @@ val process_clear : clear_info -> backward val process_smt : ?loc:EcLocation.t -> ttenv -> pprover_infos option -> backward val process_coq : loc:EcLocation.t -> name:string -> ttenv -> EcProvers.coq_mode option -> pprover_infos -> backward val process_apply : implicits:bool -> apply_t * prevert option -> backward -val process_delta : und_delta:bool -> ?target:psymbol -> (rwside * rwocc * pformula) -> backward +val process_delta : und_delta:bool -> ?rigid:bool -> ?target:psymbol -> (rwside * rwocc * pformula) -> backward val process_rewrite : ttenv -> ?target:psymbol -> rwarg list -> backward val process_subst : pformula list -> backward val process_cut : ?mode:cutmode -> engine -> ttenv -> cut_t -> backward diff --git a/src/ecParser.mly b/src/ecParser.mly index e0255c5323..cf5441c25b 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -2398,8 +2398,8 @@ rwarg1: | s=rwside r=rwrepeat? o=rwocc? p=bracket(form_h)? fp=rwpterms { RWRw ((s, r, o, p), fp) } -| s=rwside r=rwrepeat? o=rwocc? SLASH x=sform_h %prec prec_tactic - { RWDelta ((s, r, o, None), x); } +| s=rwside r=rwrepeat? o=rwocc? SLASH rigid=iboption(TILD) x=sform_h %prec prec_tactic + { RWDelta (rigid, (s, r, o, None), x); } | PR s=bracket(rwpr_arg) { RWPr s } diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 20bb8ba8a3..3e21c09784 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -903,7 +903,7 @@ type rwarg = (tfocus located) option * rwarg1 located and rwarg1 = | RWSimpl of [`Default | `Variant] - | RWDelta of (rwoptions * pformula) + | RWDelta of (bool * rwoptions * pformula) | RWRw of (rwoptions * (rwside * ppterm) list) | RWPr of (psymbol * pformula option) | RWDone of [`Default | `Variant] option From 64731a492c5bb43f14cde6adc0c84ee780ef0874 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 9 Mar 2026 04:29:10 +0100 Subject: [PATCH 029/145] QFABV: aligned extraction --- src/ecDecl.ml | 2 +- src/ecDecl.mli | 2 +- src/ecLowCircuits.ml | 4 ++-- src/ecScope.ml | 6 +++++- src/ecSubst.ml | 2 +- theories/datatypes/QFABV.ec | 16 +++++++++++++++- 6 files changed, 25 insertions(+), 7 deletions(-) diff --git a/src/ecDecl.ml b/src/ecDecl.ml index 88890d79a8..13da264aff 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -416,7 +416,7 @@ type bv_opkind = [ | `Le of binding_size * bool (* size + sign *) | `Extend of binding_size * binding_size * bool (* size in + size out + sign *) | `Truncate of binding_size * binding_size (* size in + size out *) - | `Extract of binding_size * binding_size (* size in + size out *) + | `Extract of binding_size * binding_size * bool (* size in + size out * aligned *) | `Insert of binding_size * binding_size (* size in + size out *) | `Concat of binding_size * binding_size * binding_size (* size in1 + size in2 *) | `Init of binding_size (* size_out *) diff --git a/src/ecDecl.mli b/src/ecDecl.mli index a6f1954606..d07848a9cc 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -255,7 +255,7 @@ type bv_opkind = [ | `Le of binding_size * bool (* size + sign *) | `Extend of binding_size * binding_size * bool (* size in + size out + sign *) | `Truncate of binding_size * binding_size (* size in + size out *) - | `Extract of binding_size * binding_size (* size in + size out *) + | `Extract of binding_size * binding_size * bool (* size in + size out * aligned *) | `Insert of binding_size * binding_size (* size in + size out *) | `Concat of binding_size * binding_size * binding_size (* size in1 + size in2 *) | `Init of binding_size (* size_out *) diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index d965c0c98a..921f445c6a 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -1493,10 +1493,10 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = end (* FIXME: what do we want for out of bounds extract? Decide later *) - | { kind = `Extract ((_, Some _), (_, Some w_out)) } -> + | { kind = `Extract ((_, Some _), (_, Some w_out), aligned) } -> begin match args with | [ `Circuit (({type_ = CBitstring _}, _ ) as c) ; `Constant i ] -> - circuit_slice ~size:w_out c (to_int i) + circuit_slice ~size:w_out c ((if aligned then w_out else 1) * to_int i) | _ -> assert false (* Should be caught by EC typechecking + binding correctness *) end | { kind = `Insert ((_, Some _), (_, Some _)) } -> diff --git a/src/ecScope.ml b/src/ecScope.ml index 638907b516..1cd8ef2f7c 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -2948,9 +2948,13 @@ module Circuit = struct mk, [`BV None; `BV None], "Insert" | "extract" -> - let mk sz = let sz1, sz2 = as_seq2 sz in `Extract (sz1, sz2) in + let mk sz = let sz1, sz2 = as_seq2 sz in `Extract (sz1, sz2, false) in mk, [`BV None; `BV None], "Extract" + | "aextract" -> + let mk sz = let sz1, sz2 = as_seq2 sz in `Extract (sz1, sz2, true) in + mk, [`BV None; `BV None], "AExtract" + | "asliceget" -> let mk sz = let sz1, sz2, arr_sz = as_seq3 sz in `ASliceGet ((arr_sz, sz1), sz2) in mk, [`BV None; `BV None; `A], "ASliceGet" diff --git a/src/ecSubst.ml b/src/ecSubst.ml index b82c4f1799..9ce81e997b 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -1030,7 +1030,7 @@ let subst_bv_opkind ?(red: (form -> int option) option) (s: subst) (opk: bv_opki | `Shls (s1, s2) -> `Shls (ssize s1, ssize s2) | `ASliceSet ((s1, s2), s3) -> `ASliceSet ((ssize s1, ssize s2), ssize s3) | `And s -> `And (ssize s) - | `Extract (s1, s2) -> `Extract (ssize s1, ssize s2) + | `Extract (s1, s2, aligned) -> `Extract (ssize s1, ssize s2, aligned) | `Map (s1, s2, s3) -> `Map (ssize s1, ssize s2, ssize s3) | `AInit (s1, s2) -> `AInit (ssize s1, ssize s2) | `Sub s -> `Sub (ssize s) diff --git a/theories/datatypes/QFABV.ec b/theories/datatypes/QFABV.ec index 0f60739481..a6c6de6350 100644 --- a/theories/datatypes/QFABV.ec +++ b/theories/datatypes/QFABV.ec @@ -366,6 +366,21 @@ theory BVOperators. take BV2.size (drop base (BV1.tolist bv)) = BV2.tolist (bvextract bv base). end BVExtract. + (* ------------------------------------------------------------------ *) + abstract theory BVAExtract. + clone BV as BV1. + clone BV as BV2. + + axiom [bydone] dvd_size : BV2.size %| BV1.size. + + op bvaextract : BV1.bv -> int -> BV2.bv. + + axiom bvaextractP (bv : BV1.bv) (base : int) : + 0 <= base + => base <= BV1.size %/ BV2.size + => take BV2.size (drop (base * BV2.size) (BV1.tolist bv)) = BV2.tolist (bvaextract bv base). + end BVAExtract. + print List.mkseq. (* ------------------------------------------------------------------ *) @@ -553,4 +568,3 @@ print List.mkseq. proof. admitted. end A2B2A. end BVOperators. - From d78990265a5276aa86238e6b5bd8ee1984b45a22 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Mon, 9 Mar 2026 15:08:24 +0000 Subject: [PATCH 030/145] WIP: Proc change add code + simple framing --- src/phl/ecPhlRewrite.ml | 37 +++++++++++++++++++++-- tests/procchange.ec | 67 +++++++++++++++++++++++++++++++++++++++++ 2 files changed, 101 insertions(+), 3 deletions(-) diff --git a/src/phl/ecPhlRewrite.ml b/src/phl/ecPhlRewrite.ml index d7c8ac30ce..889b44200c 100644 --- a/src/phl/ecPhlRewrite.ml +++ b/src/phl/ecPhlRewrite.ml @@ -203,11 +203,20 @@ let t_change_stmt let env = EcEnv.Memory.push_active_ts me me env in (* FIXME *) + + let get_pre_equalities (pre: form) : form list = + List.filter (fun f -> + match EcFol.sform_of_form f with + | SFeq _ -> true + | _ -> false + ) @@ EcFol.destr_ands ~deep:true pre + in + let zpr, epos = Zpr.zipper_of_cpos_range env pos stmt in let stmt, epilog = match zpr.z_tail with | [] -> raise Zpr.InvalidCPos - | i::tl -> let s, tl = Zpr.split_at_cpos1 env epos (EcAst.stmt tl) in - (i::s), tl + | tl -> let s, tl = Zpr.split_at_cpos1 env epos (EcAst.stmt tl) in + s, tl in let keep = pvtail env (EcPV.is_read env epilog) zpr.z_path in @@ -257,10 +266,32 @@ let t_change_stmt pre_globs in + (* FIXME: implement remaining cases *) + let pre = match zpr.z_path, FApi.tc1_goal tc with + | ZTop, {f_node=FhoareS _;_} -> + let hs = tc1_as_hoareS tc in + let prelude = zpr.z_head in + let writes = EcPV.is_write env prelude in + let eqs = List.filter (fun (f: form) -> + let e = expr_of_ss_inv {inv=f; m=(fst hs.hs_m)} in + let reads = EcPV.e_read env e in + EcPV.PV.inter reads writes |> EcPV.PV.is_empty + ) (get_pre_equalities (hs_pr hs).inv) + in + let eqs_l = List.map (fun f -> + (EcSubst.ss_inv_rebind {inv=f;m=(fst hs.hs_m)} mleft).inv + ) eqs in + let eqs_r = List.map (fun f -> + (EcSubst.ss_inv_rebind {inv=f;m=(fst hs.hs_m)} mright).inv + ) eqs in + pre_eq @ eqs_l @ eqs_r + | _ -> pre_eq + in + let goal1 = f_equivS (snd me) (snd me) - {ml=mleft; mr=mright; inv=f_ands pre_eq} + {ml=mleft; mr=mright; inv=f_ands pre} (EcAst.stmt stmt) s {ml=mleft; mr=mright; inv=f_ands eq} in diff --git a/tests/procchange.ec b/tests/procchange.ec index cdc2924952..c4ec80a8e6 100644 --- a/tests/procchange.ec +++ b/tests/procchange.ec @@ -1,5 +1,72 @@ require import AllCore Distr. +(* -------------------------------------------------------------------- *) +theory ProcChangeEmptyRangeAddCode. + module M = { + proc f(x : int) = { + x <- x + 1; + x <- x + 2; + x <- x + 3; + } + }. + + lemma L : hoare[M.f: x = 0 ==> true]. + proof. + proc. + proc change [0..0] : [y : int] { x <- 0; y <- x; }. + by auto. + abort. +end ProcChangeEmptyRangeAddCode. + +theory ProcChangeFrameFail. + module M = { + proc f(x : int) = { + x <- x + 1; + x <- x + 2; + x <- x + 3; + } + }. + + lemma L : hoare[M.f: x = 0 ==> true]. + proof. + proc. + proc change [2..2] : [y : int] { x <- 0; y <- x; }. + fail by auto. + abort. +end ProcChangeFrameFail. + +theory ProcChangeAddCodeFail. + module M = { + proc f(x : int) = { + x <- x + 1; + x <- x + 2; + x <- x + 3; + } + }. + + lemma L : hoare[M.f: x = 2 ==> true]. + proof. + proc. + proc change [1..1] : [y : int] { x <- 0; y <- x; }. + fail by auto. + abort. +end ProcChangeAddCodeFail. + +theory ProcChangeAssignHoareEquiv. + module M = { + proc f(x : int) = { + x <- x + 0; + } + }. + + lemma L : hoare[M.f : true ==> true]. + proof. + proc. + proc change [1..1] : { x <- x ; }. wp. skip. smt(). + abort. +end ProcChangeEmptyRangeAddCode. + + (* -------------------------------------------------------------------- *) theory ProcChangeAssignEquiv. module M = { From e8f828ce06abfd61f74d3de8fec44513c8b8f0cd Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 10 Mar 2026 05:09:30 +0100 Subject: [PATCH 031/145] Fix oppath cloning --- src/ecTheoryReplay.ml | 36 +++++++++++++++++------------------- 1 file changed, 17 insertions(+), 19 deletions(-) diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index d55a03dc39..0117766db4 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -403,18 +403,23 @@ let rename ove subst (kind, name) = exception InvInstPath (* -------------------------------------------------------------------- *) -let for_op_path ~(opath : EcPath.path) ~(npath : EcPath.path) ~(ops : _ Mp.t) (p : EcPath.path) = +let for_op_path + (subst : EcSubst.subst) + ~(opath : EcPath.path) + ~(ops : _ Mp.t) + (p : EcPath.path) += match EcPath.remprefix ~prefix:opath ~path:p |> omap List.rev with | None | Some [] -> None - | Some (x::px) -> + | Some (x :: px) -> let q = EcPath.fromqsymbol (List.rev px, x) in match Mp.find_opt q ops with | None -> - Some (EcPath.pappend npath q) + Some (EcSubst.subst_path subst p) | Some (op, alias) -> match alias with - | true -> Some (EcPath.pappend npath q) + | true -> Some (EcSubst.subst_path subst p) | false -> match op.EcDecl.op_kind with | OB_pred _ @@ -425,15 +430,15 @@ let for_op_path ~(opath : EcPath.path) ~(npath : EcPath.path) ~(ops : _ Mp.t) (p | OB_oper (Some (OP_Proj _)) | OB_oper (Some (OP_Fix _)) | OB_oper (Some (OP_TC )) -> - Some (EcPath.pappend npath q) + Some (EcSubst.subst_path subst p) | OB_oper (Some (OP_Plain f)) -> match f.f_node with | Fop (r, _) -> Some r | _ -> raise InvInstPath (* -------------------------------------------------------------------- *) -let for_op_path ~opath ~npath ~ops p = - odfl p (for_op_path ~opath ~npath ~ops p) +let for_op_path subst ~opath ~ops p = + odfl p (for_op_path subst ~opath ~ops p) (* -------------------------------------------------------------------- *) let for_ty_path (subst : EcSubst.subst) ?(nargs = 0) (p : EcPath.path) = @@ -1008,8 +1013,7 @@ and replay_instance (ove : _ ovrenv) (subst, ops, proofs, scope) (import, (typ, ty), tc, lc) = let opath = ove.ovre_opath in - let npath = ove.ovre_npath in - let forpath = for_op_path ~npath ~opath ~ops in + let forpath = for_op_path subst ~opath ~ops in try let (typ, ty) = EcSubst.subst_genty subst (typ, ty) in @@ -1054,9 +1058,7 @@ and replay_crb_bitstring (ove : _ ovrenv) (subst, ops, proofs, scope) (import, b let hyps = EcEnv.LDecl.init env [] in let opath = ove.ovre_opath in - let npath = ove.ovre_npath in - - let oppath = for_op_path ~npath ~opath ~ops in + let oppath = for_op_path subst ~opath ~ops in let typath = for_ty_path env subst in let crbpath (kind : crb_theory1_kind) = @@ -1101,7 +1103,6 @@ and replay_crb_bitstring (ove : _ ovrenv) (subst, ops, proofs, scope) (import, b (subst, ops, proofs, scope) with InvInstPath -> - Format.eprintf "[W]PAF@."; (subst, ops, proofs, scope) (* -------------------------------------------------------------------- *) @@ -1110,8 +1111,7 @@ and replay_crb_array (ove : _ ovrenv) (subst, ops, proofs, scope) (import, ba, l let hyps = EcEnv.LDecl.init env [] in let opath = ove.ovre_opath in - let npath = ove.ovre_npath in - let oppath = for_op_path ~npath ~opath ~ops in + let oppath = for_op_path subst ~opath ~ops in let typath = for_ty_path env subst in let crbpath (kind : crb_theory1_kind) = @@ -1164,8 +1164,7 @@ and replay_crb_bvoperator (ove : _ ovrenv) (subst, ops, proofs, scope) (import, let hyps = EcEnv.LDecl.init env [] in let opath = ove.ovre_opath in - let npath = ove.ovre_npath in - let oppath = for_op_path ~npath ~opath ~ops in + let oppath = for_op_path subst ~opath ~ops in let typath = for_ty_path env subst in let red f = @@ -1195,8 +1194,7 @@ and replay_crb_bvoperator (ove : _ ovrenv) (subst, ops, proofs, scope) (import, (* -------------------------------------------------------------------- *) and replay_crb_circuit (ove : _ ovrenv) (subst, ops, proofs, scope) (import, cr, lc) = let opath = ove.ovre_opath in - let npath = ove.ovre_npath in - let oppath = for_op_path ~npath ~opath ~ops in + let oppath = for_op_path subst ~opath ~ops in try let name = cr.name in From ff94177a9b454a0361d3f8c1e15d0ce66ad7f8cf Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 10 Mar 2026 07:21:29 +0100 Subject: [PATCH 032/145] Fix QFABV --- theories/datatypes/QFABV.ec | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/theories/datatypes/QFABV.ec b/theories/datatypes/QFABV.ec index a6c6de6350..4466d74032 100644 --- a/theories/datatypes/QFABV.ec +++ b/theories/datatypes/QFABV.ec @@ -96,13 +96,14 @@ theory BVOperators. touint (bvsub bv1 bv2) = (touint bv1 - touint bv2) %% 2^BV.size. end BVSub. + (* ------------------------------------------------------------------ *) abstract theory BVOpp. clone import BV. op bvopp : bv -> bv. axiom bvoppP (bv : bv) : - tosint (bvopp bv) = -(tosint bv). + touint (bvopp bv) = (-touint bv) %% 2^BV.size. end BVOpp. (* ------------------------------------------------------------------ *) @@ -362,8 +363,10 @@ theory BVOperators. op bvextract : BV1.bv -> int -> BV2.bv. - axiom bvextractP (bv : BV1.bv) (base : int) : 0 <= base => base + BV2.size <= BV1.size => - take BV2.size (drop base (BV1.tolist bv)) = BV2.tolist (bvextract bv base). + axiom bvextractP (bv : BV1.bv) (base : int) : + 0 <= base + => base + BV2.size <= BV1.size + => take BV2.size (drop base (BV1.tolist bv)) = BV2.tolist (bvextract bv base). end BVExtract. (* ------------------------------------------------------------------ *) @@ -376,8 +379,7 @@ theory BVOperators. op bvaextract : BV1.bv -> int -> BV2.bv. axiom bvaextractP (bv : BV1.bv) (base : int) : - 0 <= base - => base <= BV1.size %/ BV2.size + 0 <= base < BV1.size %/ BV2.size => take BV2.size (drop (base * BV2.size) (BV1.tolist bv)) = BV2.tolist (bvaextract bv base). end BVAExtract. From 1790498ca125ccc699c9ba1d8ada77e751ac00b2 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Tue, 10 Mar 2026 07:17:31 +0000 Subject: [PATCH 033/145] Fixes to proc change indexes --- src/ecLowPhlGoal.ml | 10 +++--- src/ecMatching.ml | 52 +++++++++++++++++++---------- src/ecMatching.mli | 4 +-- src/ecParser.mly | 7 +++- src/ecTyping.ml | 2 +- src/phl/ecPhlEager.ml | 2 +- src/phl/ecPhlInline.ml | 4 +-- src/phl/ecPhlRewrite.ml | 48 +++++++++++++++++++++++---- src/phl/ecPhlSwap.ml | 2 +- tests/procchange.ec | 73 ++++++++++++++++++++++++++++------------- 10 files changed, 143 insertions(+), 61 deletions(-) diff --git a/src/ecLowPhlGoal.ml b/src/ecLowPhlGoal.ml index 75b103beba..23b97ad38f 100644 --- a/src/ecLowPhlGoal.ml +++ b/src/ecLowPhlGoal.ml @@ -309,17 +309,17 @@ exception InvalidSplit of codepos1 let s_split env i s = let module Zpr = EcMatching.Zipper in try Zpr.split_at_cpos1 env i s - with Zpr.InvalidCPos -> raise (InvalidSplit i) + with Zpr.InvalidCPos _ -> raise (InvalidSplit i) let s_split_i env i s = let module Zpr = EcMatching.Zipper in try Zpr.find_by_cpos1 ~rev:false env i s - with Zpr.InvalidCPos -> raise (InvalidSplit i) + with Zpr.InvalidCPos _ -> raise (InvalidSplit i) let o_split ?rev env i s = let module Zpr = EcMatching.Zipper in try Zpr.may_split_at_cpos1 ?rev env i s - with Zpr.InvalidCPos -> raise (InvalidSplit (oget i)) + with Zpr.InvalidCPos _ -> raise (InvalidSplit (oget i)) (* -------------------------------------------------------------------- *) let t_hS_or_bhS_or_eS ?th ?teh ?tbh ?te tc = @@ -665,14 +665,14 @@ let t_fold f (cenv : code_txenv) (cpos : codepos) (_ : form * form) (state, s) = let env = EcEnv.LDecl.toenv (snd cenv) in let (me, f) = Zpr.fold env cenv cpos (fun _ -> f) state s in ((me, f, []) : memenv * _ * form list) - with Zpr.InvalidCPos -> tc_error (fst cenv) "invalid code position" + with Zpr.InvalidCPos _ -> tc_error (fst cenv) "invalid code position" let t_zip f (cenv : code_txenv) (cpos : codepos) (prpo : form * form) (state, s) = try let env = EcEnv.LDecl.toenv (snd cenv) in let (me, zpr, gs) = f cenv prpo state (Zpr.zipper_of_cpos env cpos s) in ((me, Zpr.zip zpr, gs) : memenv * _ * form list) - with Zpr.InvalidCPos -> tc_error (fst cenv) "invalid code position" + with Zpr.InvalidCPos _ -> tc_error (fst cenv) "invalid code position" let t_code_transform (side : oside) ?(bdhoare = false) cpos tr tx tc = let pf = FApi.tc1_penv tc in diff --git a/src/ecMatching.ml b/src/ecMatching.ml index cdac304de9..59a7589955 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -54,8 +54,6 @@ end module Zipper = struct open Position - exception InvalidCPos - module P = EcPath type ('a, 'state) folder = @@ -86,6 +84,8 @@ module Zipper = struct z_env : env option; } + exception InvalidCPos of [`Invalid | `Overrun of (ipath * codepos1) option] + let cpos (i : int) : codepos1 = (0, `ByPos i) let zipper ?env hd tl zpr = { z_head = hd; z_tail = tl; z_path = zpr; z_env = env; } @@ -103,7 +103,7 @@ module Zipper = struct else let ir, s = - match s with [] -> raise InvalidCPos | ir :: s -> (ir, s) + match s with [] -> raise (InvalidCPos `Invalid) | ir :: s -> (ir, s) in let i = @@ -139,7 +139,7 @@ module Zipper = struct in - let i = odfl 1 i in if i = 0 then raise InvalidCPos; + let i = odfl 1 i in if i = 0 then raise (InvalidCPos `Invalid); let rev, i = (i < 0), abs i in let s1, ir, s2 = @@ -162,7 +162,7 @@ module Zipper = struct let i = if i < 0 then List.length s.s_node + i + 1 else i in let i = i - if after then 0 else 1 in try List.takedrop i s.s_node - with (Invalid_argument _ | Not_found) -> raise InvalidCPos + with (Invalid_argument _ | Not_found) -> raise (InvalidCPos `Invalid) end | `ByMatch (i, cm) -> @@ -180,13 +180,13 @@ module Zipper = struct | off when off > 0 -> let (ss1, ss2) = try List.takedrop off s2 - with (Invalid_argument _ | Not_found) -> raise InvalidCPos in + with (Invalid_argument _ | Not_found) -> raise (InvalidCPos `Invalid) in (s1 @ ss1, ss2) | off when off < 0 -> let (ss1, ss2) = try List.takedrop (List.length s1 + off) s1 - with (Invalid_argument _ | Not_found) -> raise InvalidCPos in + with (Invalid_argument _ | Not_found) -> raise (InvalidCPos `Invalid) in (ss1, ss2 @ s2) | _ -> (s1, s2) @@ -196,7 +196,7 @@ module Zipper = struct let find_by_cpos1 ?(rev = true) (env : EcEnv.env) (cpos1 : codepos1) (s : stmt) = match split_at_cpos1 ~after:`No env cpos1 s with | (s1, i :: s2) -> ((if rev then List.rev s1 else s1), i, s2) - | _ -> raise InvalidCPos + | (_, []) -> raise (InvalidCPos (`Overrun None)) let offset_of_position (env : EcEnv.env) (cpos : codepos1) (s : stmt) = let (s, _) = split_at_cpos1 ~after:`No env cpos s in @@ -227,13 +227,13 @@ module Zipper = struct let cnames = List.fst indt.tydt_ctors in let ix, _ = try List.findi (fun _ n -> EcSymbols.sym_equal cn n) cnames - with Not_found -> raise InvalidCPos + with Not_found -> raise (InvalidCPos `Invalid) in let prebr, (locals, body), postbr = List.pivot_at ix bs in let env = EcEnv.Var.bind_locals locals env in (ZMatch (e, ((s1, s2), zpr), { locals; prebr; postbr; }), body), env - | _ -> raise InvalidCPos + | _ -> raise (InvalidCPos `Invalid) in zpr, ((0, `ByPos (1 + List.length s1)), sub), env let zipper_of_cpos_r (env : EcEnv.env) ((nm, cp1) : codepos) (s : stmt) = @@ -242,7 +242,11 @@ module Zipper = struct (fun ((zpr, s), env) nm1 -> let zpr, s, env = zipper_at_nm_cpos1 env nm1 s zpr in (zpr, env), s) ((ZTop, s), env) nm in - let s1, i, s2 = find_by_cpos1 env cp1 s in + let s1, i, s2 = try + find_by_cpos1 env cp1 s + with InvalidCPos (`Overrun None) -> + raise (InvalidCPos (`Overrun (Some (zpr, cp1)))) + in let zpr = zipper ~env s1 (i :: s2) zpr in (zpr, (nm, (0, `ByPos (1 + List.length s1)))) @@ -254,27 +258,39 @@ module Zipper = struct let top, bot = cpr in let zpr, (_, pos) = zipper_of_cpos_r env top s in match bot with - | `Base cp -> begin + | `Base cp -> begin try begin let zpr', (_, pos') = zipper_of_cpos_r env cp s in (* The two positions should identify the same block *) if zpr'.z_path <> zpr.z_path then - raise InvalidCPos; + raise (InvalidCPos `Invalid); (* The end position should be after the start *) match pos, pos' with | (_, `ByPos x), (_, `ByPos y) when x <= y -> zpr, (0, `ByPos (y - x)) - | _ -> raise InvalidCPos + | _ -> raise (InvalidCPos `Invalid) + end + with InvalidCPos `Overrun (Some (zpath, cp1)) when zpr.z_path = zpath -> + zpr, cp1 end | `Offset cp1 -> zpr, cp1 - let zipper_and_split_of_cpos_range env cpr s = + let zipper_and_split_of_cpos_range ?(op:bool = false) env cpr s = let zpr, cp = zipper_of_cpos_range env cpr s in match zpr.z_tail with - | [] -> raise InvalidCPos + | [] -> raise (InvalidCPos `Invalid) | i :: tl -> - let s, tl = split_at_cpos1 ~after:`Auto env cp (stmt tl) in - (zpr, cp), ((i::s), tl) + if not op then + let s, tl = split_at_cpos1 ~after:`Auto env cp (stmt tl) in + (zpr, cp), ((i::s), tl) + else + let tl = i::tl in + let s, tl = try + split_at_cpos1 ~after:`Auto env cp (stmt tl) + with InvalidCPos (`Overrun _) -> + tl, [] + in + (zpr, cp), (s, tl) let split_at_cpos1 env cpos1 s = split_at_cpos1 ~after:`Auto env cpos1 s diff --git a/src/ecMatching.mli b/src/ecMatching.mli index 66c6bc2006..22f2a5cb3f 100644 --- a/src/ecMatching.mli +++ b/src/ecMatching.mli @@ -66,7 +66,7 @@ module Zipper : sig z_env : env option; (* env with local vars from previous instructions *) } - exception InvalidCPos + exception InvalidCPos of [`Invalid | `Overrun of (ipath * codepos1) option] (* Create a codepos1 from a top-level absolute position *) val cpos : int -> codepos1 @@ -99,7 +99,7 @@ module Zipper : sig * Raise [InvalidCPos] if [codepos_range] is not a valid range for [stmt]. *) val zipper_of_cpos_range : env -> codepos_range -> stmt -> zipper * codepos1 - val zipper_and_split_of_cpos_range : env -> codepos_range -> stmt -> (zipper * codepos1) * (instr list * instr list) + val zipper_and_split_of_cpos_range : ?op:bool -> env -> codepos_range -> stmt -> (zipper * codepos1) * (instr list * instr list) (* Zip the zipper, returning the corresponding statement *) val zip : zipper -> stmt diff --git a/src/ecParser.mly b/src/ecParser.mly index cf5441c25b..132bf92cec 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -2551,10 +2551,15 @@ codepos_range: | LBRACKET cps=codepos DOTDOT cpe=codepos RBRACKET { (cps, `Base cpe) } | LBRACKET cps=codepos PLUS cpe=codepos1 RBRACKET { (cps, `Offset cpe) } +(* FIXME: rewrite and unify *) codepos_or_range: | cp=codepos { (cp, `Offset (0, `ByPos 0)) } | cpr=codepos_range { cpr } +codepos_or_open_range: +| cp=codepos { (cp, `Offset (0, `ByPos 1)) } +| cpr=codepos_range { cpr } + codeoffset1: | i=sword { (`ByOffset i :> pcodeoffset1) } | AT p=codepos1 { (`ByPosition p :> pcodeoffset1) } @@ -3166,7 +3171,7 @@ interleave_info: | LOSSLESS { Plossless } -| PROC CHANGE side=side? pos=loc(codepos_or_range) COLON b=option(bracket(ptybindings)) s=brace(stmt) +| PROC CHANGE side=side? pos=loc(codepos_or_open_range) COLON b=option(bracket(ptybindings)) s=brace(stmt) { Pchangestmt (side, b, (unloc pos), s) } | PROC REWRITE side=side? pos=codepos f=pterm diff --git a/src/ecTyping.ml b/src/ecTyping.ml index ed88589e03..d5507cd34c 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -2214,7 +2214,7 @@ and transmod_body ~attop (env : EcEnv.env) x params (me:pmodule_expr) = try EcMatching.Zipper.map_range env cp change bd with - | EcMatching.Zipper.InvalidCPos -> + | EcMatching.Zipper.InvalidCPos _ -> tyerror loc env (InvalidModUpdate MUE_InvalidCodePos); ) pupdates diff --git a/src/phl/ecPhlEager.ml b/src/phl/ecPhlEager.ml index e3e165c834..105f531f8e 100644 --- a/src/phl/ecPhlEager.ml +++ b/src/phl/ecPhlEager.ml @@ -100,7 +100,7 @@ let destruct_on_op id_op tc = (* ensure the right statement also contains an [id_op]: *) and _, _ = split_at_cpos1 env (1, `ByMatch (None, id_op)) es.es_sr in s - with InvalidCPos -> + with InvalidCPos _ -> tc_error_lazy !!tc (fun fmt -> Format.fprintf fmt "eager: invalid pivot statement") in diff --git a/src/phl/ecPhlInline.ml b/src/phl/ecPhlInline.ml index d40f5ab8b8..6bca0492d6 100644 --- a/src/phl/ecPhlInline.ml +++ b/src/phl/ecPhlInline.ml @@ -328,7 +328,7 @@ module HiInternal = struct match zip.Zp.z_tail with | { i_node = Scall _ } :: tl -> pat_of_spath ((zip.Zp.z_head, tl), zip.Zp.z_path) - | _ -> raise Zp.InvalidCPos + | _ -> raise Zp.(InvalidCPos `Invalid) end (* -------------------------------------------------------------------- *) @@ -426,7 +426,7 @@ let process_inline_codepos ~use_tuple side pos tc = | _, _ -> tc_error !!tc "invalid arguments" - with EcMatching.Zipper.InvalidCPos -> + with EcMatching.Zipper.InvalidCPos _ -> tc_error !!tc "invalid position" (* -------------------------------------------------------------------- *) diff --git a/src/phl/ecPhlRewrite.ml b/src/phl/ecPhlRewrite.ml index 889b44200c..38d2f2d53f 100644 --- a/src/phl/ecPhlRewrite.ml +++ b/src/phl/ecPhlRewrite.ml @@ -204,6 +204,8 @@ let t_change_stmt let env = EcEnv.Memory.push_active_ts me me env in (* FIXME *) + (* ---------------------------------------------------------- *) + (* TODO: Factor out of this file *) let get_pre_equalities (pre: form) : form list = List.filter (fun f -> match EcFol.sform_of_form f with @@ -212,13 +214,20 @@ let t_change_stmt ) @@ EcFol.destr_ands ~deep:true pre in - let zpr, epos = Zpr.zipper_of_cpos_range env pos stmt in - let stmt, epilog = match zpr.z_tail with - | [] -> raise Zpr.InvalidCPos - | tl -> let s, tl = Zpr.split_at_cpos1 env epos (EcAst.stmt tl) in - s, tl + let form_restricts_to_mem (f: form) (m: memory) : bool = + let rec doit f = + match f.f_node with + | Fpvar (_, m') when m <> m' -> false + | Fpvar (_, m') when m = m' -> true + | _ -> form_forall doit f + in + doit f in + (* ---------------------------------------------------------- *) + (* FIXME: Error printing *) + let (zpr, _epos), (stmt, epilog) = Zpr.zipper_and_split_of_cpos_range ~op:true env pos stmt in + let keep = pvtail env (EcPV.is_read env epilog) zpr.z_path in let keep = EcPV.PV.union keep (EcPV.PV.fv env (EcMemory.memory me) post) in @@ -267,8 +276,8 @@ let t_change_stmt in (* FIXME: implement remaining cases *) - let pre = match zpr.z_path, FApi.tc1_goal tc with - | ZTop, {f_node=FhoareS _;_} -> + let pre = match zpr.z_path, FApi.tc1_goal tc, side with + | ZTop, {f_node=FhoareS _;_}, _ -> let hs = tc1_as_hoareS tc in let prelude = zpr.z_head in let writes = EcPV.is_write env prelude in @@ -285,6 +294,31 @@ let t_change_stmt (EcSubst.ss_inv_rebind {inv=f;m=(fst hs.hs_m)} mright).inv ) eqs in pre_eq @ eqs_l @ eqs_r + | ZTop, {f_node=FequivS _; _}, Some side -> + let es = tc1_as_equivS tc in + let prelude = zpr.z_head in + let writes = EcPV.is_write env prelude in + let m = if side = `Left + then (fst es.es_ml) + else (fst es.es_mr) + in + let eqs = List.filter (fun f -> + form_restricts_to_mem f m + ) (get_pre_equalities (es_pr es).inv) + in + let eqs = List.filter (fun (f: form) -> + let e = expr_of_ss_inv {inv=f; m} in + let reads = EcPV.e_read env e in + EcPV.PV.inter reads writes |> EcPV.PV.is_empty + ) eqs + in + let eqs_l = List.map (fun f -> + (EcSubst.ss_inv_rebind {inv=f;m} mleft).inv + ) eqs in + let eqs_r = List.map (fun f -> + (EcSubst.ss_inv_rebind {inv=f;m} mright).inv + ) eqs in + pre_eq @ eqs_l @ eqs_r | _ -> pre_eq in diff --git a/src/phl/ecPhlSwap.ml b/src/phl/ecPhlSwap.ml index ff641f6924..4f7c2237cc 100644 --- a/src/phl/ecPhlSwap.ml +++ b/src/phl/ecPhlSwap.ml @@ -67,7 +67,7 @@ module LowInternal = struct let process_cpos (p : codepos1) = try EcMatching.Zipper.offset_of_position env p s - with EcMatching.Zipper.InvalidCPos -> + with EcMatching.Zipper.InvalidCPos _ -> tc_error_lazy pf (fun fmt -> let ppe = EcPrinting.PPEnv.ofenv env in Format.fprintf fmt "invalid position: %a" (EcPrinting.pp_codepos1 ppe) p diff --git a/tests/procchange.ec b/tests/procchange.ec index c4ec80a8e6..4a67735350 100644 --- a/tests/procchange.ec +++ b/tests/procchange.ec @@ -18,6 +18,27 @@ theory ProcChangeEmptyRangeAddCode. abort. end ProcChangeEmptyRangeAddCode. +theory ProcChangeFullProgram. + module M = { + proc f(x : int) = { + x <- x + 1; + x <- x + 2; + x <- x + 3; + } + }. + + lemma L : hoare[M.f: x = 0 ==> true]. + proof. + proc. + proc change [0..100] : [y : int] { + x <- x + 1; + x <- x + 2; + x <- x + 3; + }. + by auto. + abort. +end ProcChangeFullProgram. + theory ProcChangeFrameFail. module M = { proc f(x : int) = { @@ -52,6 +73,26 @@ theory ProcChangeAddCodeFail. abort. end ProcChangeAddCodeFail. + +(* -------------------------------------------------------------------- *) +theory ProcChangeEmptyRangeAddCodeEquiv. + module M = { + proc f(x : int) = { + x <- x + 1; + x <- x + 2; + x <- x + 3; + } + }. + + lemma L : equiv[M.f ~ M.f: x{1} = 0 ==> true]. + proof. + proc. + proc change {1} [0..0] : [y : int] { x <- 0; y <- x; }; 1:by auto. + fail proc change {2} [0..0] : [y : int] { x <- 0; y <- x; }; 1:by auto. + fail proc change {2} [100..102] : [y : int ] { x <- 0; y <- x; }. (* FIXME: move test *) + abort. +end ProcChangeEmptyRangeAddCodeEquiv. + theory ProcChangeAssignHoareEquiv. module M = { proc f(x : int) = { @@ -62,10 +103,9 @@ theory ProcChangeAssignHoareEquiv. lemma L : hoare[M.f : true ==> true]. proof. proc. - proc change [1..1] : { x <- x ; }. wp. skip. smt(). + proc change [0..2] : { x <- x ; }. wp. skip. smt(). abort. -end ProcChangeEmptyRangeAddCode. - +end ProcChangeAssignHoareEquiv. (* -------------------------------------------------------------------- *) theory ProcChangeAssignEquiv. @@ -81,24 +121,11 @@ theory ProcChangeAssignEquiv. lemma L : equiv[M.f ~ M.f: true ==> true]. proof. proc. - proc change {1} [1..3] : [y : int] { y <- 3; x <- y; }. + proc change {1} [1..4] : [y : int] { y <- 3; x <- y; }. wp. skip. smt(). abort. end ProcChangeAssignEquiv. -theory ProcChangeAssignHoareEquiv. - module M = { - proc f(x : int) = { - x <- x + 0; - } - }. - - lemma L : hoare[M.f : true ==> true]. - proof. - proc. - proc change [1..1] : { x <- x ; }. wp. skip. smt(). - abort. -end ProcChangeAssignHoareEquiv. (* -------------------------------------------------------------------- *) theory ProcChangeSampleEquiv. @@ -111,7 +138,7 @@ theory ProcChangeSampleEquiv. lemma L : equiv[M.f ~ M.f : true ==> true]. proof. proc. - proc change {1} [1..1] : { x <$ (dunit x); }. + proc change {1} [1..2] : { x <$ (dunit x); }. rnd. skip. smt(). abort. end ProcChangeSampleEquiv. @@ -131,7 +158,7 @@ theory ProcChangeIfEquiv. lemma L : equiv[M.f ~ M.f : true ==> true]. proof. proc. - proc change {1} [1..1] : { + proc change {1} [1..2] : { if (x = y) { x <- y; } else { @@ -154,7 +181,7 @@ theory ProcChangeWhileEquiv. lemma L : equiv[M.f ~ M.f : true ==> true]. proof. proc. - proc change {1} [1..1] : { + proc change {1} [1..2] : { while (x <> y) { x <- x + 1 + 0; } @@ -189,10 +216,10 @@ theory ProcChangeInWhileEquiv. x <- x + 0 + 1; }. wp; skip. smt(). - proc change {1} [^while.1..^while.2] : { + proc change {1} [^while.1..^while.3] : { x <- 2; }. wp; skip. smt(). - proc change {2} [^while.1-1] : { + proc change {2} [^while.1+2] : { x <- 2; }. wp; skip. smt(). abort. @@ -210,7 +237,7 @@ theory ProcChangeAssignHoare. lemma L : hoare[M.f: true ==> true]. proof. proc. - proc change [1..1] : { x <- x; }. + proc change [1..2] : { x <- x; }. wp; skip; smt(). abort. end ProcChangeAssignHoare. From 4e9587f2b4f59566dee71a62a0f26b6b1d54bc90 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Thu, 12 Mar 2026 11:42:37 +0000 Subject: [PATCH 034/145] Revert "Fixes to proc change indexes" This reverts commit 1790498ca125ccc699c9ba1d8ada77e751ac00b2. --- src/ecLowPhlGoal.ml | 10 +++--- src/ecMatching.ml | 52 ++++++++++------------------- src/ecMatching.mli | 4 +-- src/ecParser.mly | 7 +--- src/ecTyping.ml | 2 +- src/phl/ecPhlEager.ml | 2 +- src/phl/ecPhlInline.ml | 4 +-- src/phl/ecPhlRewrite.ml | 48 ++++----------------------- src/phl/ecPhlSwap.ml | 2 +- tests/procchange.ec | 73 +++++++++++++---------------------------- 10 files changed, 61 insertions(+), 143 deletions(-) diff --git a/src/ecLowPhlGoal.ml b/src/ecLowPhlGoal.ml index 23b97ad38f..75b103beba 100644 --- a/src/ecLowPhlGoal.ml +++ b/src/ecLowPhlGoal.ml @@ -309,17 +309,17 @@ exception InvalidSplit of codepos1 let s_split env i s = let module Zpr = EcMatching.Zipper in try Zpr.split_at_cpos1 env i s - with Zpr.InvalidCPos _ -> raise (InvalidSplit i) + with Zpr.InvalidCPos -> raise (InvalidSplit i) let s_split_i env i s = let module Zpr = EcMatching.Zipper in try Zpr.find_by_cpos1 ~rev:false env i s - with Zpr.InvalidCPos _ -> raise (InvalidSplit i) + with Zpr.InvalidCPos -> raise (InvalidSplit i) let o_split ?rev env i s = let module Zpr = EcMatching.Zipper in try Zpr.may_split_at_cpos1 ?rev env i s - with Zpr.InvalidCPos _ -> raise (InvalidSplit (oget i)) + with Zpr.InvalidCPos -> raise (InvalidSplit (oget i)) (* -------------------------------------------------------------------- *) let t_hS_or_bhS_or_eS ?th ?teh ?tbh ?te tc = @@ -665,14 +665,14 @@ let t_fold f (cenv : code_txenv) (cpos : codepos) (_ : form * form) (state, s) = let env = EcEnv.LDecl.toenv (snd cenv) in let (me, f) = Zpr.fold env cenv cpos (fun _ -> f) state s in ((me, f, []) : memenv * _ * form list) - with Zpr.InvalidCPos _ -> tc_error (fst cenv) "invalid code position" + with Zpr.InvalidCPos -> tc_error (fst cenv) "invalid code position" let t_zip f (cenv : code_txenv) (cpos : codepos) (prpo : form * form) (state, s) = try let env = EcEnv.LDecl.toenv (snd cenv) in let (me, zpr, gs) = f cenv prpo state (Zpr.zipper_of_cpos env cpos s) in ((me, Zpr.zip zpr, gs) : memenv * _ * form list) - with Zpr.InvalidCPos _ -> tc_error (fst cenv) "invalid code position" + with Zpr.InvalidCPos -> tc_error (fst cenv) "invalid code position" let t_code_transform (side : oside) ?(bdhoare = false) cpos tr tx tc = let pf = FApi.tc1_penv tc in diff --git a/src/ecMatching.ml b/src/ecMatching.ml index 59a7589955..cdac304de9 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -54,6 +54,8 @@ end module Zipper = struct open Position + exception InvalidCPos + module P = EcPath type ('a, 'state) folder = @@ -84,8 +86,6 @@ module Zipper = struct z_env : env option; } - exception InvalidCPos of [`Invalid | `Overrun of (ipath * codepos1) option] - let cpos (i : int) : codepos1 = (0, `ByPos i) let zipper ?env hd tl zpr = { z_head = hd; z_tail = tl; z_path = zpr; z_env = env; } @@ -103,7 +103,7 @@ module Zipper = struct else let ir, s = - match s with [] -> raise (InvalidCPos `Invalid) | ir :: s -> (ir, s) + match s with [] -> raise InvalidCPos | ir :: s -> (ir, s) in let i = @@ -139,7 +139,7 @@ module Zipper = struct in - let i = odfl 1 i in if i = 0 then raise (InvalidCPos `Invalid); + let i = odfl 1 i in if i = 0 then raise InvalidCPos; let rev, i = (i < 0), abs i in let s1, ir, s2 = @@ -162,7 +162,7 @@ module Zipper = struct let i = if i < 0 then List.length s.s_node + i + 1 else i in let i = i - if after then 0 else 1 in try List.takedrop i s.s_node - with (Invalid_argument _ | Not_found) -> raise (InvalidCPos `Invalid) + with (Invalid_argument _ | Not_found) -> raise InvalidCPos end | `ByMatch (i, cm) -> @@ -180,13 +180,13 @@ module Zipper = struct | off when off > 0 -> let (ss1, ss2) = try List.takedrop off s2 - with (Invalid_argument _ | Not_found) -> raise (InvalidCPos `Invalid) in + with (Invalid_argument _ | Not_found) -> raise InvalidCPos in (s1 @ ss1, ss2) | off when off < 0 -> let (ss1, ss2) = try List.takedrop (List.length s1 + off) s1 - with (Invalid_argument _ | Not_found) -> raise (InvalidCPos `Invalid) in + with (Invalid_argument _ | Not_found) -> raise InvalidCPos in (ss1, ss2 @ s2) | _ -> (s1, s2) @@ -196,7 +196,7 @@ module Zipper = struct let find_by_cpos1 ?(rev = true) (env : EcEnv.env) (cpos1 : codepos1) (s : stmt) = match split_at_cpos1 ~after:`No env cpos1 s with | (s1, i :: s2) -> ((if rev then List.rev s1 else s1), i, s2) - | (_, []) -> raise (InvalidCPos (`Overrun None)) + | _ -> raise InvalidCPos let offset_of_position (env : EcEnv.env) (cpos : codepos1) (s : stmt) = let (s, _) = split_at_cpos1 ~after:`No env cpos s in @@ -227,13 +227,13 @@ module Zipper = struct let cnames = List.fst indt.tydt_ctors in let ix, _ = try List.findi (fun _ n -> EcSymbols.sym_equal cn n) cnames - with Not_found -> raise (InvalidCPos `Invalid) + with Not_found -> raise InvalidCPos in let prebr, (locals, body), postbr = List.pivot_at ix bs in let env = EcEnv.Var.bind_locals locals env in (ZMatch (e, ((s1, s2), zpr), { locals; prebr; postbr; }), body), env - | _ -> raise (InvalidCPos `Invalid) + | _ -> raise InvalidCPos in zpr, ((0, `ByPos (1 + List.length s1)), sub), env let zipper_of_cpos_r (env : EcEnv.env) ((nm, cp1) : codepos) (s : stmt) = @@ -242,11 +242,7 @@ module Zipper = struct (fun ((zpr, s), env) nm1 -> let zpr, s, env = zipper_at_nm_cpos1 env nm1 s zpr in (zpr, env), s) ((ZTop, s), env) nm in - let s1, i, s2 = try - find_by_cpos1 env cp1 s - with InvalidCPos (`Overrun None) -> - raise (InvalidCPos (`Overrun (Some (zpr, cp1)))) - in + let s1, i, s2 = find_by_cpos1 env cp1 s in let zpr = zipper ~env s1 (i :: s2) zpr in (zpr, (nm, (0, `ByPos (1 + List.length s1)))) @@ -258,39 +254,27 @@ module Zipper = struct let top, bot = cpr in let zpr, (_, pos) = zipper_of_cpos_r env top s in match bot with - | `Base cp -> begin try begin + | `Base cp -> begin let zpr', (_, pos') = zipper_of_cpos_r env cp s in (* The two positions should identify the same block *) if zpr'.z_path <> zpr.z_path then - raise (InvalidCPos `Invalid); + raise InvalidCPos; (* The end position should be after the start *) match pos, pos' with | (_, `ByPos x), (_, `ByPos y) when x <= y -> zpr, (0, `ByPos (y - x)) - | _ -> raise (InvalidCPos `Invalid) - end - with InvalidCPos `Overrun (Some (zpath, cp1)) when zpr.z_path = zpath -> - zpr, cp1 + | _ -> raise InvalidCPos end | `Offset cp1 -> zpr, cp1 - let zipper_and_split_of_cpos_range ?(op:bool = false) env cpr s = + let zipper_and_split_of_cpos_range env cpr s = let zpr, cp = zipper_of_cpos_range env cpr s in match zpr.z_tail with - | [] -> raise (InvalidCPos `Invalid) + | [] -> raise InvalidCPos | i :: tl -> - if not op then - let s, tl = split_at_cpos1 ~after:`Auto env cp (stmt tl) in - (zpr, cp), ((i::s), tl) - else - let tl = i::tl in - let s, tl = try - split_at_cpos1 ~after:`Auto env cp (stmt tl) - with InvalidCPos (`Overrun _) -> - tl, [] - in - (zpr, cp), (s, tl) + let s, tl = split_at_cpos1 ~after:`Auto env cp (stmt tl) in + (zpr, cp), ((i::s), tl) let split_at_cpos1 env cpos1 s = split_at_cpos1 ~after:`Auto env cpos1 s diff --git a/src/ecMatching.mli b/src/ecMatching.mli index 22f2a5cb3f..66c6bc2006 100644 --- a/src/ecMatching.mli +++ b/src/ecMatching.mli @@ -66,7 +66,7 @@ module Zipper : sig z_env : env option; (* env with local vars from previous instructions *) } - exception InvalidCPos of [`Invalid | `Overrun of (ipath * codepos1) option] + exception InvalidCPos (* Create a codepos1 from a top-level absolute position *) val cpos : int -> codepos1 @@ -99,7 +99,7 @@ module Zipper : sig * Raise [InvalidCPos] if [codepos_range] is not a valid range for [stmt]. *) val zipper_of_cpos_range : env -> codepos_range -> stmt -> zipper * codepos1 - val zipper_and_split_of_cpos_range : ?op:bool -> env -> codepos_range -> stmt -> (zipper * codepos1) * (instr list * instr list) + val zipper_and_split_of_cpos_range : env -> codepos_range -> stmt -> (zipper * codepos1) * (instr list * instr list) (* Zip the zipper, returning the corresponding statement *) val zip : zipper -> stmt diff --git a/src/ecParser.mly b/src/ecParser.mly index 132bf92cec..cf5441c25b 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -2551,15 +2551,10 @@ codepos_range: | LBRACKET cps=codepos DOTDOT cpe=codepos RBRACKET { (cps, `Base cpe) } | LBRACKET cps=codepos PLUS cpe=codepos1 RBRACKET { (cps, `Offset cpe) } -(* FIXME: rewrite and unify *) codepos_or_range: | cp=codepos { (cp, `Offset (0, `ByPos 0)) } | cpr=codepos_range { cpr } -codepos_or_open_range: -| cp=codepos { (cp, `Offset (0, `ByPos 1)) } -| cpr=codepos_range { cpr } - codeoffset1: | i=sword { (`ByOffset i :> pcodeoffset1) } | AT p=codepos1 { (`ByPosition p :> pcodeoffset1) } @@ -3171,7 +3166,7 @@ interleave_info: | LOSSLESS { Plossless } -| PROC CHANGE side=side? pos=loc(codepos_or_open_range) COLON b=option(bracket(ptybindings)) s=brace(stmt) +| PROC CHANGE side=side? pos=loc(codepos_or_range) COLON b=option(bracket(ptybindings)) s=brace(stmt) { Pchangestmt (side, b, (unloc pos), s) } | PROC REWRITE side=side? pos=codepos f=pterm diff --git a/src/ecTyping.ml b/src/ecTyping.ml index d5507cd34c..ed88589e03 100644 --- a/src/ecTyping.ml +++ b/src/ecTyping.ml @@ -2214,7 +2214,7 @@ and transmod_body ~attop (env : EcEnv.env) x params (me:pmodule_expr) = try EcMatching.Zipper.map_range env cp change bd with - | EcMatching.Zipper.InvalidCPos _ -> + | EcMatching.Zipper.InvalidCPos -> tyerror loc env (InvalidModUpdate MUE_InvalidCodePos); ) pupdates diff --git a/src/phl/ecPhlEager.ml b/src/phl/ecPhlEager.ml index 105f531f8e..e3e165c834 100644 --- a/src/phl/ecPhlEager.ml +++ b/src/phl/ecPhlEager.ml @@ -100,7 +100,7 @@ let destruct_on_op id_op tc = (* ensure the right statement also contains an [id_op]: *) and _, _ = split_at_cpos1 env (1, `ByMatch (None, id_op)) es.es_sr in s - with InvalidCPos _ -> + with InvalidCPos -> tc_error_lazy !!tc (fun fmt -> Format.fprintf fmt "eager: invalid pivot statement") in diff --git a/src/phl/ecPhlInline.ml b/src/phl/ecPhlInline.ml index 6bca0492d6..d40f5ab8b8 100644 --- a/src/phl/ecPhlInline.ml +++ b/src/phl/ecPhlInline.ml @@ -328,7 +328,7 @@ module HiInternal = struct match zip.Zp.z_tail with | { i_node = Scall _ } :: tl -> pat_of_spath ((zip.Zp.z_head, tl), zip.Zp.z_path) - | _ -> raise Zp.(InvalidCPos `Invalid) + | _ -> raise Zp.InvalidCPos end (* -------------------------------------------------------------------- *) @@ -426,7 +426,7 @@ let process_inline_codepos ~use_tuple side pos tc = | _, _ -> tc_error !!tc "invalid arguments" - with EcMatching.Zipper.InvalidCPos _ -> + with EcMatching.Zipper.InvalidCPos -> tc_error !!tc "invalid position" (* -------------------------------------------------------------------- *) diff --git a/src/phl/ecPhlRewrite.ml b/src/phl/ecPhlRewrite.ml index 38d2f2d53f..889b44200c 100644 --- a/src/phl/ecPhlRewrite.ml +++ b/src/phl/ecPhlRewrite.ml @@ -204,8 +204,6 @@ let t_change_stmt let env = EcEnv.Memory.push_active_ts me me env in (* FIXME *) - (* ---------------------------------------------------------- *) - (* TODO: Factor out of this file *) let get_pre_equalities (pre: form) : form list = List.filter (fun f -> match EcFol.sform_of_form f with @@ -214,20 +212,13 @@ let t_change_stmt ) @@ EcFol.destr_ands ~deep:true pre in - let form_restricts_to_mem (f: form) (m: memory) : bool = - let rec doit f = - match f.f_node with - | Fpvar (_, m') when m <> m' -> false - | Fpvar (_, m') when m = m' -> true - | _ -> form_forall doit f - in - doit f + let zpr, epos = Zpr.zipper_of_cpos_range env pos stmt in + let stmt, epilog = match zpr.z_tail with + | [] -> raise Zpr.InvalidCPos + | tl -> let s, tl = Zpr.split_at_cpos1 env epos (EcAst.stmt tl) in + s, tl in - (* ---------------------------------------------------------- *) - (* FIXME: Error printing *) - let (zpr, _epos), (stmt, epilog) = Zpr.zipper_and_split_of_cpos_range ~op:true env pos stmt in - let keep = pvtail env (EcPV.is_read env epilog) zpr.z_path in let keep = EcPV.PV.union keep (EcPV.PV.fv env (EcMemory.memory me) post) in @@ -276,8 +267,8 @@ let t_change_stmt in (* FIXME: implement remaining cases *) - let pre = match zpr.z_path, FApi.tc1_goal tc, side with - | ZTop, {f_node=FhoareS _;_}, _ -> + let pre = match zpr.z_path, FApi.tc1_goal tc with + | ZTop, {f_node=FhoareS _;_} -> let hs = tc1_as_hoareS tc in let prelude = zpr.z_head in let writes = EcPV.is_write env prelude in @@ -294,31 +285,6 @@ let t_change_stmt (EcSubst.ss_inv_rebind {inv=f;m=(fst hs.hs_m)} mright).inv ) eqs in pre_eq @ eqs_l @ eqs_r - | ZTop, {f_node=FequivS _; _}, Some side -> - let es = tc1_as_equivS tc in - let prelude = zpr.z_head in - let writes = EcPV.is_write env prelude in - let m = if side = `Left - then (fst es.es_ml) - else (fst es.es_mr) - in - let eqs = List.filter (fun f -> - form_restricts_to_mem f m - ) (get_pre_equalities (es_pr es).inv) - in - let eqs = List.filter (fun (f: form) -> - let e = expr_of_ss_inv {inv=f; m} in - let reads = EcPV.e_read env e in - EcPV.PV.inter reads writes |> EcPV.PV.is_empty - ) eqs - in - let eqs_l = List.map (fun f -> - (EcSubst.ss_inv_rebind {inv=f;m} mleft).inv - ) eqs in - let eqs_r = List.map (fun f -> - (EcSubst.ss_inv_rebind {inv=f;m} mright).inv - ) eqs in - pre_eq @ eqs_l @ eqs_r | _ -> pre_eq in diff --git a/src/phl/ecPhlSwap.ml b/src/phl/ecPhlSwap.ml index 4f7c2237cc..ff641f6924 100644 --- a/src/phl/ecPhlSwap.ml +++ b/src/phl/ecPhlSwap.ml @@ -67,7 +67,7 @@ module LowInternal = struct let process_cpos (p : codepos1) = try EcMatching.Zipper.offset_of_position env p s - with EcMatching.Zipper.InvalidCPos _ -> + with EcMatching.Zipper.InvalidCPos -> tc_error_lazy pf (fun fmt -> let ppe = EcPrinting.PPEnv.ofenv env in Format.fprintf fmt "invalid position: %a" (EcPrinting.pp_codepos1 ppe) p diff --git a/tests/procchange.ec b/tests/procchange.ec index 4a67735350..c4ec80a8e6 100644 --- a/tests/procchange.ec +++ b/tests/procchange.ec @@ -18,27 +18,6 @@ theory ProcChangeEmptyRangeAddCode. abort. end ProcChangeEmptyRangeAddCode. -theory ProcChangeFullProgram. - module M = { - proc f(x : int) = { - x <- x + 1; - x <- x + 2; - x <- x + 3; - } - }. - - lemma L : hoare[M.f: x = 0 ==> true]. - proof. - proc. - proc change [0..100] : [y : int] { - x <- x + 1; - x <- x + 2; - x <- x + 3; - }. - by auto. - abort. -end ProcChangeFullProgram. - theory ProcChangeFrameFail. module M = { proc f(x : int) = { @@ -73,26 +52,6 @@ theory ProcChangeAddCodeFail. abort. end ProcChangeAddCodeFail. - -(* -------------------------------------------------------------------- *) -theory ProcChangeEmptyRangeAddCodeEquiv. - module M = { - proc f(x : int) = { - x <- x + 1; - x <- x + 2; - x <- x + 3; - } - }. - - lemma L : equiv[M.f ~ M.f: x{1} = 0 ==> true]. - proof. - proc. - proc change {1} [0..0] : [y : int] { x <- 0; y <- x; }; 1:by auto. - fail proc change {2} [0..0] : [y : int] { x <- 0; y <- x; }; 1:by auto. - fail proc change {2} [100..102] : [y : int ] { x <- 0; y <- x; }. (* FIXME: move test *) - abort. -end ProcChangeEmptyRangeAddCodeEquiv. - theory ProcChangeAssignHoareEquiv. module M = { proc f(x : int) = { @@ -103,9 +62,10 @@ theory ProcChangeAssignHoareEquiv. lemma L : hoare[M.f : true ==> true]. proof. proc. - proc change [0..2] : { x <- x ; }. wp. skip. smt(). + proc change [1..1] : { x <- x ; }. wp. skip. smt(). abort. -end ProcChangeAssignHoareEquiv. +end ProcChangeEmptyRangeAddCode. + (* -------------------------------------------------------------------- *) theory ProcChangeAssignEquiv. @@ -121,11 +81,24 @@ theory ProcChangeAssignEquiv. lemma L : equiv[M.f ~ M.f: true ==> true]. proof. proc. - proc change {1} [1..4] : [y : int] { y <- 3; x <- y; }. + proc change {1} [1..3] : [y : int] { y <- 3; x <- y; }. wp. skip. smt(). abort. end ProcChangeAssignEquiv. +theory ProcChangeAssignHoareEquiv. + module M = { + proc f(x : int) = { + x <- x + 0; + } + }. + + lemma L : hoare[M.f : true ==> true]. + proof. + proc. + proc change [1..1] : { x <- x ; }. wp. skip. smt(). + abort. +end ProcChangeAssignHoareEquiv. (* -------------------------------------------------------------------- *) theory ProcChangeSampleEquiv. @@ -138,7 +111,7 @@ theory ProcChangeSampleEquiv. lemma L : equiv[M.f ~ M.f : true ==> true]. proof. proc. - proc change {1} [1..2] : { x <$ (dunit x); }. + proc change {1} [1..1] : { x <$ (dunit x); }. rnd. skip. smt(). abort. end ProcChangeSampleEquiv. @@ -158,7 +131,7 @@ theory ProcChangeIfEquiv. lemma L : equiv[M.f ~ M.f : true ==> true]. proof. proc. - proc change {1} [1..2] : { + proc change {1} [1..1] : { if (x = y) { x <- y; } else { @@ -181,7 +154,7 @@ theory ProcChangeWhileEquiv. lemma L : equiv[M.f ~ M.f : true ==> true]. proof. proc. - proc change {1} [1..2] : { + proc change {1} [1..1] : { while (x <> y) { x <- x + 1 + 0; } @@ -216,10 +189,10 @@ theory ProcChangeInWhileEquiv. x <- x + 0 + 1; }. wp; skip. smt(). - proc change {1} [^while.1..^while.3] : { + proc change {1} [^while.1..^while.2] : { x <- 2; }. wp; skip. smt(). - proc change {2} [^while.1+2] : { + proc change {2} [^while.1-1] : { x <- 2; }. wp; skip. smt(). abort. @@ -237,7 +210,7 @@ theory ProcChangeAssignHoare. lemma L : hoare[M.f: true ==> true]. proof. proc. - proc change [1..2] : { x <- x; }. + proc change [1..1] : { x <- x; }. wp; skip; smt(). abort. end ProcChangeAssignHoare. From 29e8888c51d1276118927c08d62e40cf345c0a91 Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Thu, 12 Mar 2026 11:42:59 +0000 Subject: [PATCH 035/145] Revert "WIP: Proc change add code + simple framing" This reverts commit d78990265a5276aa86238e6b5bd8ee1984b45a22. --- src/phl/ecPhlRewrite.ml | 37 ++--------------------- tests/procchange.ec | 67 ----------------------------------------- 2 files changed, 3 insertions(+), 101 deletions(-) diff --git a/src/phl/ecPhlRewrite.ml b/src/phl/ecPhlRewrite.ml index 889b44200c..d7c8ac30ce 100644 --- a/src/phl/ecPhlRewrite.ml +++ b/src/phl/ecPhlRewrite.ml @@ -203,20 +203,11 @@ let t_change_stmt let env = EcEnv.Memory.push_active_ts me me env in (* FIXME *) - - let get_pre_equalities (pre: form) : form list = - List.filter (fun f -> - match EcFol.sform_of_form f with - | SFeq _ -> true - | _ -> false - ) @@ EcFol.destr_ands ~deep:true pre - in - let zpr, epos = Zpr.zipper_of_cpos_range env pos stmt in let stmt, epilog = match zpr.z_tail with | [] -> raise Zpr.InvalidCPos - | tl -> let s, tl = Zpr.split_at_cpos1 env epos (EcAst.stmt tl) in - s, tl + | i::tl -> let s, tl = Zpr.split_at_cpos1 env epos (EcAst.stmt tl) in + (i::s), tl in let keep = pvtail env (EcPV.is_read env epilog) zpr.z_path in @@ -266,32 +257,10 @@ let t_change_stmt pre_globs in - (* FIXME: implement remaining cases *) - let pre = match zpr.z_path, FApi.tc1_goal tc with - | ZTop, {f_node=FhoareS _;_} -> - let hs = tc1_as_hoareS tc in - let prelude = zpr.z_head in - let writes = EcPV.is_write env prelude in - let eqs = List.filter (fun (f: form) -> - let e = expr_of_ss_inv {inv=f; m=(fst hs.hs_m)} in - let reads = EcPV.e_read env e in - EcPV.PV.inter reads writes |> EcPV.PV.is_empty - ) (get_pre_equalities (hs_pr hs).inv) - in - let eqs_l = List.map (fun f -> - (EcSubst.ss_inv_rebind {inv=f;m=(fst hs.hs_m)} mleft).inv - ) eqs in - let eqs_r = List.map (fun f -> - (EcSubst.ss_inv_rebind {inv=f;m=(fst hs.hs_m)} mright).inv - ) eqs in - pre_eq @ eqs_l @ eqs_r - | _ -> pre_eq - in - let goal1 = f_equivS (snd me) (snd me) - {ml=mleft; mr=mright; inv=f_ands pre} + {ml=mleft; mr=mright; inv=f_ands pre_eq} (EcAst.stmt stmt) s {ml=mleft; mr=mright; inv=f_ands eq} in diff --git a/tests/procchange.ec b/tests/procchange.ec index c4ec80a8e6..cdc2924952 100644 --- a/tests/procchange.ec +++ b/tests/procchange.ec @@ -1,72 +1,5 @@ require import AllCore Distr. -(* -------------------------------------------------------------------- *) -theory ProcChangeEmptyRangeAddCode. - module M = { - proc f(x : int) = { - x <- x + 1; - x <- x + 2; - x <- x + 3; - } - }. - - lemma L : hoare[M.f: x = 0 ==> true]. - proof. - proc. - proc change [0..0] : [y : int] { x <- 0; y <- x; }. - by auto. - abort. -end ProcChangeEmptyRangeAddCode. - -theory ProcChangeFrameFail. - module M = { - proc f(x : int) = { - x <- x + 1; - x <- x + 2; - x <- x + 3; - } - }. - - lemma L : hoare[M.f: x = 0 ==> true]. - proof. - proc. - proc change [2..2] : [y : int] { x <- 0; y <- x; }. - fail by auto. - abort. -end ProcChangeFrameFail. - -theory ProcChangeAddCodeFail. - module M = { - proc f(x : int) = { - x <- x + 1; - x <- x + 2; - x <- x + 3; - } - }. - - lemma L : hoare[M.f: x = 2 ==> true]. - proof. - proc. - proc change [1..1] : [y : int] { x <- 0; y <- x; }. - fail by auto. - abort. -end ProcChangeAddCodeFail. - -theory ProcChangeAssignHoareEquiv. - module M = { - proc f(x : int) = { - x <- x + 0; - } - }. - - lemma L : hoare[M.f : true ==> true]. - proof. - proc. - proc change [1..1] : { x <- x ; }. wp. skip. smt(). - abort. -end ProcChangeEmptyRangeAddCode. - - (* -------------------------------------------------------------------- *) theory ProcChangeAssignEquiv. module M = { From 1bacdf9008e4fb84d8b8ae4cbbc4436e3a68106e Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 17 Mar 2026 17:45:28 +0100 Subject: [PATCH 036/145] fix merge warnings --- src/ecTheoryReplay.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index fb35022309..06b0d1044d 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -438,7 +438,8 @@ let for_op_path | OB_oper (Some (OP_Record _)) | OB_oper (Some (OP_Proj _)) | OB_oper (Some (OP_Fix _)) - | OB_oper (Some (OP_TC )) -> + | OB_oper (Some (OP_TC )) + | OB_oper (Some (OP_Exn _)) -> Some (EcSubst.subst_path subst p) | OB_oper (Some (OP_Plain f)) -> match f.f_node with From 64b53a07243cbacaf4ffb31e5f0018254607893c Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 17 Mar 2026 17:50:52 +0100 Subject: [PATCH 037/145] int -> int64 for lospec literals --- libs/lospecs/ast.ml | 2 +- libs/lospecs/circuit.ml | 8 ++++---- libs/lospecs/circuit.mli | 4 ++++ libs/lospecs/circuit_spec.ml | 6 +++--- libs/lospecs/lexer.mll | 4 ++-- libs/lospecs/parser.mly | 6 +++--- libs/lospecs/ptree.ml | 2 +- libs/lospecs/typing.ml | 18 ++++++++++++------ 8 files changed, 30 insertions(+), 20 deletions(-) diff --git a/libs/lospecs/ast.ml b/libs/lospecs/ast.ml index 7df7bd130e..0a7062831d 100644 --- a/libs/lospecs/ast.ml +++ b/libs/lospecs/ast.ml @@ -50,7 +50,7 @@ type mulk = [`U of hld | `S of hld | `US] [@@deriving yojson] (* -------------------------------------------------------------------- *) type aexpr_ = | EVar of ident - | EInt of int + | EInt of int64 | ESlice of aexpr * (aexpr * int * int) | EAssign of aexpr * (aexpr * int * int) * aexpr | EApp of ident * aexpr list diff --git a/libs/lospecs/circuit.ml b/libs/lospecs/circuit.ml index 65f699f5b1..ad542a6a6d 100644 --- a/libs/lospecs/circuit.ml +++ b/libs/lospecs/circuit.ml @@ -131,12 +131,12 @@ let of_int ~(size : int) (v : int) : reg = Array.init size (fun i -> constant (bit ~position:i v)) (* -------------------------------------------------------------------- *) -let of_int32 (v : int32) : reg = - Array.init 32 (fun i -> constant (bit32 ~position:i v)) +let of_int32 ?(size = 32) (v : int32) : reg = + Array.init size (fun i -> constant (bit32 ~position:i v)) (* -------------------------------------------------------------------- *) -let of_int64 (v : int64) : reg = - Array.init 64 (fun i -> constant (bit64 ~position:i v)) +let of_int64 ?(size = 64) (v : int64) : reg = + Array.init size (fun i -> constant (bit64 ~position:i v)) (* -------------------------------------------------------------------- *) let of_int32s (vs : int32 array) : reg = diff --git a/libs/lospecs/circuit.mli b/libs/lospecs/circuit.mli index 6f923966a3..44ff800994 100644 --- a/libs/lospecs/circuit.mli +++ b/libs/lospecs/circuit.mli @@ -25,6 +25,10 @@ val bool_list_of_reg : reg -> bool list (* ==================================================================== *) val of_int : size:int -> int -> reg +val of_int32 : ?size:int -> int32 -> reg + +val of_int64 : ?size:int -> int64 -> reg + val of_bigint : size:int -> Z.t -> reg val of_int32s : int32 array -> reg diff --git a/libs/lospecs/circuit_spec.ml b/libs/lospecs/circuit_spec.ml index fca87e49b0..931b9a5986 100644 --- a/libs/lospecs/circuit_spec.ml +++ b/libs/lospecs/circuit_spec.ml @@ -158,7 +158,7 @@ let circuit_of_specification (rs : reg list) (p : adef) : reg = | ESlice (e, ({ node = EInt offset }, size, scale)) -> let e = of_expr env e in - let offset = offset * scale in + let offset = (Int64.to_int offset) * scale in let size = size * scale in Array.sub e offset size @@ -177,7 +177,7 @@ let circuit_of_specification (rs : reg list) (p : adef) : reg = | EAssign (e, ({ node = EInt offset }, size, scale), v) -> let e = of_expr env e in let v = of_expr env v in - let offset = offset * scale in + let offset = (Int64.to_int offset) * scale in let size = size * scale in let pre, e = split_at_arr offset e in let e, post = split_at_arr size e in @@ -251,7 +251,7 @@ let circuit_of_specification (rs : reg list) (p : adef) : reg = | EInt i -> begin match e.type_ with - | `W n -> Circuit.of_int ~size:n i + | `W n -> Circuit.of_int64 ~size:n i | _ -> raise (CircuitSpecError (Format.asprintf "Expected int got %a" pp_atype e.type_)) end diff --git a/libs/lospecs/lexer.mll b/libs/lospecs/lexer.mll index 21346fa2ad..e6ccc35367 100644 --- a/libs/lospecs/lexer.mll +++ b/libs/lospecs/lexer.mll @@ -48,10 +48,10 @@ rule main = parse { Hashtbl.find_default keywords x (IDENT x) } | decnum as d - { NUMBER (int_of_string d) } + { NUMBER (Int64.of_string d) } | hexnum as d - { NUMBER (int_of_string d) } + { NUMBER (Int64.of_string d) } | whitespace+ { main lexbuf } diff --git a/libs/lospecs/parser.mly b/libs/lospecs/parser.mly index dad00ee271..93ec191298 100644 --- a/libs/lospecs/parser.mly +++ b/libs/lospecs/parser.mly @@ -28,7 +28,7 @@ %token RPAREN %token IDENT -%token NUMBER +%token NUMBER %type program @@ -50,7 +50,7 @@ %inline wtype_: | AT x=NUMBER - { `W x } + { `W (Int64.to_int x) } %inline wtype: | w=loc(wtype_) { w } @@ -60,7 +60,7 @@ fname_: { (f, None) } | f=loc(IDENT) p=angled(list0(loc(NUMBER), COMMA)) - { (f, Some (List.map (Lc.map (fun x -> `W x)) p)) } + { (f, Some (List.map (Lc.map (fun x -> `W (Int64.to_int x))) p)) } %inline fname: | f=loc(fname_) { f } diff --git a/libs/lospecs/ptree.ml b/libs/lospecs/ptree.ml index 6c1da94ce7..8131fb3155 100644 --- a/libs/lospecs/ptree.ml +++ b/libs/lospecs/ptree.ml @@ -88,7 +88,7 @@ type pfname = (psymbol * pword list option) loced [@@deriving yojson] type pexpr_ = | PEParens of pexpr | PEFName of pfname - | PEInt of int * pword option + | PEInt of int64 * pword option | PECond of pexpr * (pexpr * pexpr) | PEFun of pargs * pexpr | PELet of (psymbol * pargs option * pexpr) * pexpr diff --git a/libs/lospecs/typing.ml b/libs/lospecs/typing.ml index 9601b67f2a..0f4c1c24b9 100644 --- a/libs/lospecs/typing.ml +++ b/libs/lospecs/typing.ml @@ -109,12 +109,18 @@ let check_plain_arg (_ : env) (arg : pexpr option loced) = arg (* -------------------------------------------------------------------- *) -let as_int_constant (e : pexpr) : int = +let as_int_constant (e : pexpr) : int64 = match e.data with | PEInt (i, None) -> i | _ -> tyerror e.range "integer constant expected" (* -------------------------------------------------------------------- *) +let as_nativeint_constant (e : pexpr) : int = + match e.data with + | PEInt (i, None) -> Int64.to_int i + | _ -> tyerror e.range "integer constant expected" + + (* -------------------------------------------------------------------- *) type sig_ = { s_name : string; s_ntyparams : int; @@ -468,8 +474,8 @@ let rec tt_expr_ (env : env) (e : pexpr) : aargs option * aexpr = | PESlice (ev, (start, len, scale)) -> let ev = tt_expr env ev in let start = tt_expr env start in - let len = Option.default 1 (Option.map as_int_constant len) in - let scale = Option.default 1 (Option.map as_int_constant scale) in + let len = Option.default 1 (Option.map as_nativeint_constant len) in + let scale = Option.default 1 (Option.map as_nativeint_constant scale) in let node = ESlice (ev, (start, len, scale)) and type_ = `W (len * scale) in (None, { node; type_; }) @@ -477,8 +483,8 @@ let rec tt_expr_ (env : env) (e : pexpr) : aargs option * aexpr = | PEAssign (ev, (start, len, scale), v) -> let ev = tt_expr env ev in let start = tt_expr env start in - let len = Option.default 1 (Option.map as_int_constant len) in - let scale = Option.default 1 (Option.map as_int_constant scale) in + let len = Option.default 1 (Option.map as_nativeint_constant len) in + let scale = Option.default 1 (Option.map as_nativeint_constant scale) in let v = tt_expr env ~check:(`W (len * scale)) v in let node = EAssign (ev, (start, len, scale), v) in (None, { node; type_ = ev.type_; }) @@ -526,7 +532,7 @@ let rec tt_expr_ (env : env) (e : pexpr) : aargs option * aexpr = let (`W w) = as_seq1 (tt_type_parameters env fn.range f ~expected:1 w) in let args = List.map (check_plain_arg env) args in let e, n = as_seq2 (check_arguments_count e.range ~expected:2 args) in - let n = as_int_constant n in + let n = as_nativeint_constant n in let ne = tt_expr env ~check:(`W w) e in (None, { node = ERepeat (`W (w * n), (ne, n)); type_ = `W (w * n); }) From ab16441aed1aef5a58c703a7580e3999891cbb87 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 17 Mar 2026 17:58:47 +0100 Subject: [PATCH 038/145] lospec: raw equality --- libs/lospecs/ast.ml | 1 + libs/lospecs/circuit.ml | 5 +++++ libs/lospecs/circuit.mli | 2 ++ libs/lospecs/circuit_spec.ml | 5 +++++ libs/lospecs/typing.ml | 6 ++++++ 5 files changed, 19 insertions(+) diff --git a/libs/lospecs/ast.ml b/libs/lospecs/ast.ml index 0a7062831d..f10383f2df 100644 --- a/libs/lospecs/ast.ml +++ b/libs/lospecs/ast.ml @@ -70,6 +70,7 @@ type aexpr_ = | EOr of aword * (aexpr * aexpr) | EXor of aword * (aexpr * aexpr) | EAnd of aword * (aexpr * aexpr) + | EEq of aword * (aexpr * aexpr) | ECmp of aword * us * [`Gt | `Ge] * (aexpr * aexpr) | EPopCount of aword * aexpr [@@deriving yojson] diff --git a/libs/lospecs/circuit.ml b/libs/lospecs/circuit.ml index ad542a6a6d..7b468a3f5f 100644 --- a/libs/lospecs/circuit.ml +++ b/libs/lospecs/circuit.ml @@ -648,6 +648,11 @@ let sle (r1 : reg) (r2 : reg) : node = let iszero (r : reg) : node = bvueq r (Array.map (fun _ -> false_) r) +(* -------------------------------------------------------------------- *) +let eq (r1 : reg) (r2 : reg) : node = + assert (Array.length r1 = Array.length r2); + bvueq r1 r2 + (* -------------------------------------------------------------------- *) let abs (a : reg) : reg = let msb_a, _ = split_msb a in diff --git a/libs/lospecs/circuit.mli b/libs/lospecs/circuit.mli index 44ff800994..d784860438 100644 --- a/libs/lospecs/circuit.mli +++ b/libs/lospecs/circuit.mli @@ -152,6 +152,8 @@ val bvueq : reg -> reg -> node val bvseq : reg -> reg -> node +val eq : reg -> reg -> node + (* ==================================================================== *) val sat : signed:bool -> size:int -> reg -> reg diff --git a/libs/lospecs/circuit_spec.ml b/libs/lospecs/circuit_spec.ml index 931b9a5986..abc3677be0 100644 --- a/libs/lospecs/circuit_spec.ml +++ b/libs/lospecs/circuit_spec.ml @@ -105,6 +105,11 @@ let circuit_of_specification (rs : reg list) (p : adef) : reg = | `US -> Circuit.usmul e1 e2 end + | EEq(`W _, (e1, e2)) -> + let e1 = of_expr env e1 in + let e2 = of_expr env e2 in + [|Circuit.eq e1 e2|] + | ECmp (`W _, us, k, (e1, e2)) -> let e1 = of_expr env e1 in let e2 = of_expr env e2 in diff --git a/libs/lospecs/typing.ml b/libs/lospecs/typing.ml index 0f4c1c24b9..fa2308fd82 100644 --- a/libs/lospecs/typing.ml +++ b/libs/lospecs/typing.ml @@ -155,6 +155,7 @@ module Sigs : sig val smullo : sig_ val smulhi : sig_ val usmul : sig_ + val eq : sig_ val sgt : sig_ val sge : sig_ val ugt : sig_ @@ -291,6 +292,10 @@ end = struct let usmul : sig_ = mulop ~ret:(fun n -> 2 * n) ~name:"usmul" `US + let eq : sig_ = + let mk = fun ws x y -> EEq (as_seq1 ws, (x, y)) in + binop ~ret:(fun _ -> 1) ~name:"eq" mk + let sgt : sig_ = let mk = fun ws x y -> ECmp (as_seq1 ws, `S, `Gt, (x, y)) in binop ~ret:(fun _ -> 1) ~name:"sgt" mk @@ -346,6 +351,7 @@ let sigs : sig_ list = [ Sigs.smullo; Sigs.smulhi; Sigs.usmul; + Sigs.eq; Sigs.sgt; Sigs.sge; Sigs.ugt; From b6c6e268a54cda21c40e0fbd57755d2bf19106b4 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Fri, 20 Mar 2026 20:03:58 +0100 Subject: [PATCH 039/145] Forward call with framed pre --- src/ecAst.mli | 1 + src/ecCoreFol.ml | 5 + src/ecCoreFol.mli | 1 + src/ecEnv.ml | 25 +- src/ecEnv.mli | 7 +- src/ecFol.ml | 19 ++ src/ecFol.mli | 3 + src/ecHiTacticals.ml | 2 +- src/ecMatching.ml | 4 + src/ecMatching.mli | 1 + src/ecPV.ml | 19 +- src/ecPV.mli | 24 +- src/ecParser.mly | 8 +- src/ecParsetree.ml | 8 +- src/ecProofTerm.ml | 93 ++++++++ src/ecProofTerm.mli | 19 +- src/phl/ecPhlCall.ml | 282 ++++++++++++++-------- src/phl/ecPhlCall.mli | 33 ++- src/phl/ecPhlEager.ml | 26 ++- src/phl/ecPhlExists.ml | 501 +++++++++++++++++++++++++++++++++------- src/phl/ecPhlExists.mli | 2 +- tests/forward-call.ec | 26 +++ 22 files changed, 882 insertions(+), 227 deletions(-) create mode 100644 tests/forward-call.ec diff --git a/src/ecAst.mli b/src/ecAst.mli index 61afbb830a..db7a2a6796 100644 --- a/src/ecAst.mli +++ b/src/ecAst.mli @@ -478,6 +478,7 @@ val pv_hash : prog_var hash val pv_fv : prog_var fv val pv_kind : prog_var -> pvar_kind + (* -------------------------------------------------------------------- *) val idty_equal : (EcIdent.t * ty) equality val idty_hash : (EcIdent.t * ty) hash diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index 19d8e1b5f0..640b9058c3 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -588,6 +588,11 @@ let f_iter g f = | FeagerF eg -> g (eg_pr eg).inv; g (eg_po eg).inv | Fpr pr -> g pr.pr_args; g pr.pr_event.inv +(* -------------------------------------------------------------------- *) +let f_fold (tx : 'a -> form -> 'a) (state : 'a) (f : form) = + let state = ref state in + f_iter (fun f -> state := tx !state f) f; + !state (* -------------------------------------------------------------------- *) let form_exists g f = diff --git a/src/ecCoreFol.mli b/src/ecCoreFol.mli index b6c40ee1a7..0aa61b57ee 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -76,6 +76,7 @@ val f_node : form -> f_node (* not recursive *) val f_map : (EcTypes.ty -> EcTypes.ty) -> (form -> form) -> form -> form val f_iter : (form -> unit) -> form -> unit +val f_fold : ('a -> form -> 'a) -> 'a -> form -> 'a val form_exists: (form -> bool) -> form -> bool val form_forall: (form -> bool) -> form -> bool diff --git a/src/ecEnv.ml b/src/ecEnv.ml index d7fe857455..7fd0354814 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -3208,29 +3208,40 @@ module LDecl = struct let fresh_id hyps s = fresh_id (tohyps hyps) s let fresh_ids hyps s = snd (fresh_ids (tohyps hyps) s) + (* ------------------------------------------------------------------ *) + let mapenv (f : env -> env) (lenv : hyps) = + { lenv with le_env = f lenv.le_env } + (* ------------------------------------------------------------------ *) let push_active_ss m lenv = - { lenv with le_env = Memory.push_active_ss m lenv.le_env } + mapenv (Memory.push_active_ss m) lenv let push_active_ts ml mr lenv = - { lenv with le_env = Memory.push_active_ts ml mr lenv.le_env } + mapenv (Memory.push_active_ts ml mr) lenv let push_all l lenv = - { lenv with le_env = Memory.push_all l lenv.le_env } + mapenv (Memory.push_all l) lenv + + let push_active_all l lenv = + let lenv = mapenv (Memory.push_all l) lenv in + + match l with + | [(m, _)] -> mapenv (Memory.set_active_ss m) lenv + | _ -> lenv let hoareF mem xp lenv = let env1, env2 = Fun.hoareF mem xp lenv.le_env in - { lenv with le_env = env1}, {lenv with le_env = env2 } + { lenv with le_env = env1 }, { lenv with le_env = env2 } let equivF ml mr xp1 xp2 lenv = let env1, env2 = Fun.equivF ml mr xp1 xp2 lenv.le_env in - { lenv with le_env = env1}, {lenv with le_env = env2 } + { lenv with le_env = env1 }, { lenv with le_env = env2 } let inv_memenv ml mr lenv = - { lenv with le_env = Fun.inv_memenv ml mr lenv.le_env } + mapenv (Fun.inv_memenv ml mr) lenv let inv_memenv1 m lenv = - { lenv with le_env = Fun.inv_memenv1 m lenv.le_env } + mapenv (Fun.inv_memenv1 m) lenv end (* -------------------------------------------------------------------- *) diff --git a/src/ecEnv.mli b/src/ecEnv.mli index 509a60bb37..751a19ab37 100644 --- a/src/ecEnv.mli +++ b/src/ecEnv.mli @@ -533,9 +533,10 @@ module LDecl : sig val clear : ?leniant:bool -> EcIdent.Sid.t -> hyps -> hyps - val push_all : memenv list -> hyps -> hyps - val push_active_ss : memenv -> hyps -> hyps - val push_active_ts : memenv -> memenv -> hyps -> hyps + val push_all : memenv list -> hyps -> hyps + val push_active_all : memenv list -> hyps -> hyps + val push_active_ss : memenv -> hyps -> hyps + val push_active_ts : memenv -> memenv -> hyps -> hyps val hoareF : memory -> xpath -> hyps -> hyps * hyps val equivF : memory -> memory -> xpath -> xpath -> hyps -> hyps * hyps diff --git a/src/ecFol.ml b/src/ecFol.ml index 57322210d9..7a9fbf4942 100644 --- a/src/ecFol.ml +++ b/src/ecFol.ml @@ -1104,6 +1104,25 @@ let rec one_sided_vs mem fp = | Fapp (f, args) -> one_sided_vs mem f @ List.concat_map (one_sided_vs mem) args | _ -> [] +(* -------------------------------------------------------------------- *) +let filter_topand_form (test : form -> bool) = + let rec doit (f : form) = + match sform_of_form f with + | SFand (mode, (f1, f2)) -> begin + match doit f1, doit f2 with + | None, None -> None + | Some f, None | None, Some f -> Some f + | Some f1, Some f2 -> begin + match mode with + | `Sym -> Some (f_and f1 f2) + | `Asym -> Some (f_anda f1 f2) + end + end + | _ -> + if test f then Some f else None + in fun f -> doit f + +(* -------------------------------------------------------------------- *) let rec dump_f f = let dump_quant q = match q with diff --git a/src/ecFol.mli b/src/ecFol.mli index 080a4d3dea..6be1d1aafc 100644 --- a/src/ecFol.mli +++ b/src/ecFol.mli @@ -260,5 +260,8 @@ module DestrReal : sig val abs : form -> form end +(* -------------------------------------------------------------------- *) +val filter_topand_form : (form -> bool) -> form -> form option + (* -------------------------------------------------------------------- *) val dump_f : form -> string diff --git a/src/ecHiTacticals.ml b/src/ecHiTacticals.ml index ae81075b4c..ab076f960e 100644 --- a/src/ecHiTacticals.ml +++ b/src/ecHiTacticals.ml @@ -212,7 +212,7 @@ and process1_phl (_ : ttenv) (t : phltactic located) (tc : tcenv1) = | Pconcave info -> EcPhlConseq.process_concave info | Phrex_elim -> EcPhlExists.t_hr_exists_elim | Phrex_intro (fs, b) -> EcPhlExists.process_exists_intro ~elim:b fs - | Phecall (oside, x) -> EcPhlExists.process_ecall oside x + | Phecall (d, s, data) -> EcPhlExists.process_ecall d s data | Pexfalso -> EcPhlAuto.t_exfalso | Pbydeno (mode, info) -> EcPhlDeno.process_deno mode info | Pbyupto -> EcPhlUpto.process_uptobad diff --git a/src/ecMatching.ml b/src/ecMatching.ml index a14e8859b3..efbe257050 100644 --- a/src/ecMatching.ml +++ b/src/ecMatching.ml @@ -372,6 +372,10 @@ module EV = struct | Some (`Set _) -> true | _ -> false + let map (f : 'a -> 'a) (m : 'a evmap) = + { ev_map = Mid.map (omap f) m.ev_map + ; ev_unset = m.ev_unset } + let doget (x : ident) (m : 'a evmap) = match get x m with | Some (`Set a) -> a diff --git a/src/ecMatching.mli b/src/ecMatching.mli index 66c6bc2006..cd1a01301e 100644 --- a/src/ecMatching.mli +++ b/src/ecMatching.mli @@ -150,6 +150,7 @@ module EV : sig val isset : ident -> 'a evmap -> bool val set : ident -> 'a -> 'a evmap -> 'a evmap val get : ident -> 'a evmap -> [`Unset | `Set of 'a] option + val map : ('a -> 'a) -> 'a evmap -> 'a evmap val doget : ident -> 'a evmap -> 'a val fold : (ident -> 'a -> 'b -> 'b) -> 'a evmap -> 'b -> 'b val filled : 'a evmap -> bool diff --git a/src/ecPV.ml b/src/ecPV.ml index c1c297d754..10e233d8b5 100644 --- a/src/ecPV.ml +++ b/src/ecPV.ml @@ -155,6 +155,9 @@ module PVM = struct try Mid.change (fun o -> Some (Mpv.add env pv f (odfl Mpv.empty o))) m s with AliasClash (env,c) -> uerror env c + let of_list env pvs = + List.fold_left (fun s ((pv, m), f) -> add env pv m f s) empty pvs + let find env pv m s = try Mpv.find env pv (Mid.find m s) with AliasClash (env,c) -> uerror env c @@ -580,6 +583,11 @@ let rec e_read_r env r e = | Evar pv -> PV.add env pv e.e_ty r | _ -> e_fold (e_read_r env) r e +let rec form_read_r env r f = + match f.f_node with + | Fpvar (pv, _) -> PV.add env pv f.f_ty r + | _ -> f_fold (form_read_r env) r f + let rec is_read_r env w s = List.fold_left (i_read_r env) w s @@ -624,11 +632,12 @@ let is_write ?(except=Sx.empty) env is = is_write_r ~except env PV.empty is let s_write ?(except=Sx.empty) env s = s_write_r ~except env PV.empty s let f_write ?(except=Sx.empty) env f = f_write_r ~except env PV.empty f -let e_read env e = e_read_r env PV.empty e -let i_read env i = i_read_r env PV.empty i -let is_read env is = is_read_r env PV.empty is -let s_read env s = s_read_r env PV.empty s -let f_read env f = f_read_r env PV.empty f +let e_read env e = e_read_r env PV.empty e +let form_read env e = form_read_r env PV.empty e +let i_read env i = i_read_r env PV.empty i +let is_read env is = is_read_r env PV.empty is +let s_read env s = s_read_r env PV.empty s +let f_read env f = f_read_r env PV.empty f (* -------------------------------------------------------------------- *) exception EqObsInError diff --git a/src/ecPV.mli b/src/ecPV.mli index 0e9df4354b..3abe99be0d 100644 --- a/src/ecPV.mli +++ b/src/ecPV.mli @@ -71,6 +71,8 @@ module PVM : sig val add : env -> prog_var -> EcIdent.t -> form -> subst -> subst + val of_list : env -> ((prog_var * EcIdent.t) * form) list -> subst + val add_glob : env -> mpath -> EcIdent.t -> form -> subst -> subst val of_mpv : (form,form) Mpv.t -> EcIdent.t -> subst @@ -127,11 +129,12 @@ val is_write_r : ?except:Sx.t -> instr list pvaccess val s_write_r : ?except:Sx.t -> stmt pvaccess val f_write_r : ?except:Sx.t -> xpath pvaccess -val e_read_r : expr pvaccess -val i_read_r : instr pvaccess -val is_read_r : instr list pvaccess -val s_read_r : stmt pvaccess -val f_read_r : xpath pvaccess +val e_read_r : expr pvaccess +val form_read_r : form pvaccess +val i_read_r : instr pvaccess +val is_read_r : instr list pvaccess +val s_read_r : stmt pvaccess +val f_read_r : xpath pvaccess (* -------------------------------------------------------------------- *) type 'a pvaccess0 = env -> 'a -> PV.t @@ -142,11 +145,12 @@ val is_write : ?except:Sx.t -> instr list pvaccess0 val s_write : ?except:Sx.t -> stmt pvaccess0 val f_write : ?except:Sx.t -> xpath pvaccess0 -val e_read : expr pvaccess0 -val i_read : instr pvaccess0 -val is_read : instr list pvaccess0 -val s_read : stmt pvaccess0 -val f_read : xpath pvaccess0 +val e_read : expr pvaccess0 +val form_read : form pvaccess0 +val i_read : instr pvaccess0 +val is_read : instr list pvaccess0 +val s_read : stmt pvaccess0 +val f_read : xpath pvaccess0 (* -------------------------------------------------------------------- *) exception EqObsInError diff --git a/src/ecParser.mly b/src/ecParser.mly index c8ac4ea27d..a6ad4e7692 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -2939,6 +2939,10 @@ interleave_info: | TILD f=loc(fident) { OKproc(f, true) } | f=loc(fident) { OKproc(f, false) } +direction: +| RRARROW { (`Forward :> pdirection) } +| LLARROW { (`Backward :> pdirection) } + %public phltactic: | PROC { Pfun `Def } @@ -3124,8 +3128,8 @@ interleave_info: { Phrex_intro (l, b) } -| ECALL s=side? x=paren(p=qident tvi=tvars_app? fs=sform* { (p, tvi, fs) }) - { Phecall (s, x) } +| ECALL d=direction? s=side? x=paren(p=qident tvi=tvars_app? fs=loc(gpterm_arg)* { (p, tvi, fs) }) + { Phecall (odfl `Backward d, s, x) } | EXFALSO { Pexfalso } diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index dc8604d5d4..15e601d6e0 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -768,6 +768,12 @@ type bdepeq_info = (* -------------------------------------------------------------------- *) type prrewrite = [`Rw of ppterm | `Simpl] +(* -------------------------------------------------------------------- *) +type pecall = pqsymbol * ptyannot option * ppt_arg located list + +(* -------------------------------------------------------------------- *) +type pdirection = [`Forward | `Backward] + (* -------------------------------------------------------------------- *) type phltactic = | Pskip @@ -806,7 +812,7 @@ type phltactic = | Pconcave of (pformula option tuple2 gppterm * pformula) | Phrex_elim | Phrex_intro of (pformula list * bool) - | Phecall of (oside * (pqsymbol * ptyannot option * pformula list)) + | Phecall of (pdirection * oside * pecall) | Pexfalso | Pbydeno of ([`PHoare | `Equiv | `EHoare ] * (deno_ppterm * bool * pformula option)) | PPr of (pformula * pformula) option diff --git a/src/ecProofTerm.ml b/src/ecProofTerm.ml index 9055f24629..cd0e218446 100644 --- a/src/ecProofTerm.ml +++ b/src/ecProofTerm.ml @@ -789,6 +789,12 @@ and apply_pterm_to_hole ?loc pt = and apply_pterm_to_holes ?loc n pt = EcUtils.iterop (apply_pterm_to_hole ?loc) n pt +(* -------------------------------------------------------------------- *) +and apply_pterm_to_max_holes (hyps : LDecl.hyps) (pt : pt_ev) = + if is_some (PT.destruct_product ~reduce:true hyps pt.ptev_ax) then + apply_pterm_to_max_holes hyps (apply_pterm_to_hole pt) + else pt + (* -------------------------------------------------------------------- *) and apply_pterm_to_local ?loc pt id = match LDecl.by_id id pt.ptev_env.pte_hy with @@ -964,3 +970,90 @@ module Prept = struct let ahyp h = asub (hyp h) let ahdl h = asub (hdl h) end + +(* -------------------------------------------------------------------- *) +let pvcompare (pv1 : prog_var) (pv2 : prog_var) = + match pv1, pv2 with + | PVglob x1, PVglob x2 -> + EcPath.x_compare x1 x2 + | PVloc s1, PVloc s2 -> + EcSymbols.sym_compare s1 s2 + + | PVglob _, PVloc _ -> 1 + | PVloc _, PVglob _ -> -1 + +module Mpv = Map.Make(struct + type t = prog_var + let compare = pvcompare +end) + +type mpvars = (ty Mpv.t) Mid.t + +(* -------------------------------------------------------------------- *) +let rec collect_pvars_from_pt (pvs : mpvars) (pt : proofterm) = + match pt with + | PTApply { pt_args = args } -> begin + List.fold_left collect_pvars_from_ptarg pvs args + end + | PTQuant (_, pt) -> + collect_pvars_from_pt pvs pt + +and collect_pvars_from_ptarg (pvs : mpvars) (ptarg : pt_arg) = + match ptarg with + | PAFormula f -> collect_pvars_from_form pvs f + | PAMemory _ -> pvs + | PAModule _ -> pvs + | PASub None -> pvs + | PASub (Some pt) -> collect_pvars_from_pt pvs pt + +and collect_pvars_from_form (pvs : mpvars) (f : form) = + let rec doit (pvs : mpvars) (f : form) = + match f.f_node with + | Fpvar (pv, m) -> + Mid.change (fun pvmap -> + Some (Mpv.add pv f.f_ty (odfl Mpv.empty pvmap)) + ) m pvs + | _ -> EcFol.f_fold doit pvs f + in doit pvs f + +(* -------------------------------------------------------------------- *) +let collect_pvars_from_pt (pt : proofterm) = + Mid.map Mpv.bindings (collect_pvars_from_pt Mid.empty pt) + +(* -------------------------------------------------------------------- *) +module PV = struct + open EcPV.PVM + + let rec subst_pt (env : env) (subst : subst) (pt : proofterm) = + match pt with + | PTApply { pt_head; pt_args } -> + PTApply + { pt_head = subst_pt_head env subst pt_head + ; pt_args = List.map (subst_pt_arg env subst) pt_args } + | PTQuant (bds, pt) -> + PTQuant (bds, subst_pt env subst pt) + + and subst_pt_head (env : env) (subst : subst) (pth : pt_head) = + match pth with + | PTHandle _ + | PTLocal _ + | PTGlobal _ -> pth + | PTCut (f, cs) -> PTCut (subst_form env subst f, cs) + | PTTerm pt -> PTTerm (subst_pt env subst pt) + + and subst_pt_arg (env : env) (subst : subst) (pta : pt_arg) = + match pta with + | PAFormula f -> PAFormula (subst_form env subst f) + | PAMemory _ -> pta + | PAModule _ -> pta + | PASub pt -> PASub (omap (subst_pt env subst) pt) + + and subst_form (env : env) (subst : subst) (f : form) = + EcPV.PVM.subst env subst f +end + +let subst_pv_pt (env : env) (subst : EcPV.PVM.subst) (pt : proofterm) = + PV.subst_pt env subst pt + +let subst_pv_pt_arg (env : env) (subst : EcPV.PVM.subst) (pt_arg : pt_arg) = + PV.subst_pt_arg env subst pt_arg diff --git a/src/ecProofTerm.mli b/src/ecProofTerm.mli index 8f54208794..c66db30002 100644 --- a/src/ecProofTerm.mli +++ b/src/ecProofTerm.mli @@ -64,6 +64,8 @@ val process_pterm_cut : prcut:('a -> form) -> pt_env -> 'a ppt_head -> pt_ev val process_pterm : pt_env -> (pformula option) ppt_head -> pt_ev +val process_pterm_arg + : ?implicits:bool -> pt_ev -> ppt_arg located -> pt_ev_arg val process_pterm_args_app : ?implicits:bool -> ?ip:(bool list) -> pt_ev -> ppt_arg located list -> pt_ev * bool list @@ -99,11 +101,12 @@ val check_pterm_arg : -> pt_ev_arg_r -> form * pt_arg -val apply_pterm_to_arg : ?loc:EcLocation.t -> pt_ev -> pt_ev_arg -> pt_ev -val apply_pterm_to_arg_r : ?loc:EcLocation.t -> pt_ev -> pt_ev_arg_r -> pt_ev -val apply_pterm_to_local : ?loc:EcLocation.t -> pt_ev -> EcIdent.t -> pt_ev -val apply_pterm_to_hole : ?loc:EcLocation.t -> pt_ev -> pt_ev -val apply_pterm_to_holes : ?loc:EcLocation.t -> int -> pt_ev -> pt_ev +val apply_pterm_to_arg : ?loc:EcLocation.t -> pt_ev -> pt_ev_arg -> pt_ev +val apply_pterm_to_arg_r : ?loc:EcLocation.t -> pt_ev -> pt_ev_arg_r -> pt_ev +val apply_pterm_to_local : ?loc:EcLocation.t -> pt_ev -> EcIdent.t -> pt_ev +val apply_pterm_to_hole : ?loc:EcLocation.t -> pt_ev -> pt_ev +val apply_pterm_to_holes : ?loc:EcLocation.t -> int -> pt_ev -> pt_ev +val apply_pterm_to_max_holes : LDecl.hyps -> pt_ev -> pt_ev (* pattern matching - raise [MatchFailure] on failure. *) val pf_form_match : pt_env -> ?mode:fmoptions -> ptn:form -> form -> unit @@ -198,3 +201,9 @@ module Prept : sig val ahyp : EcIdent.t -> prept_arg val ahdl : handle -> prept_arg end + +(* -------------------------------------------------------------------- *) +val collect_pvars_from_pt : proofterm -> ((prog_var * ty) list) EcIdent.Mid.t + +val subst_pv_pt : EcEnv.env -> EcPV.PVM.subst -> proofterm -> proofterm +val subst_pv_pt_arg : EcEnv.env -> EcPV.PVM.subst -> pt_arg -> pt_arg \ No newline at end of file diff --git a/src/phl/ecPhlCall.ml b/src/phl/ecPhlCall.ml index 87a3bc727e..1642392a57 100644 --- a/src/phl/ecPhlCall.ml +++ b/src/phl/ecPhlCall.ml @@ -26,79 +26,186 @@ let wp_asgn_call ?mc env lv res post = let lets = lv_subst m lv res.inv in {m;inv=mk_let_of_lv_substs ?mc env ([lets], post.inv)} +(* -------------------------------------------------------------------- *) let subst_args_call env m e s = PVM.add env pv_arg m (ss_inv_of_expr m e).inv s (* -------------------------------------------------------------------- *) -let wp2_call - env fpre fpost (lpl,fl,argsl) modil (lpr,fr,argsr) modir post hyps +let compute_hoare_call_post + (hyps : LDecl.hyps) + (m : memory) + (contract : form * exnpost) + (call : lvalue option * EcPath.xpath * expr list) + (post : exnpost) += + let env = LDecl.toenv hyps in + + let (fpre, fpost) = contract in + let (lvalue, funname, funargs) = call in + let funsig = (Fun.by_xpath funname env).f_sig in + let modi = f_write env funname in + + let { main = fpost; exnmap = (fepost, fd); } = fpost in + let { main = post ; exnmap = ( epost, d); } = post in + + let vres = LDecl.fresh_id hyps "result" in + let fres = f_local vres funsig.fs_ret in + + let fpost = PVM.subst1 env pv_res m fres fpost in + + let post = wp_asgn_call env lvalue { m = m; inv = fres; } { m = m; inv = post; } in + let post = (ss_inv_rebind post m).inv in + let post = f_imp_simpl fpost post in + let post = generalize_mod_ss_inv env modi { m = m; inv = post; } in + let post = (ss_inv_rebind post m).inv in + let post = f_forall_simpl [(vres, GTty funsig.fs_ret)] post in + let post = + let spre = subst_args_call env m (e_tuple funargs) PVM.empty in + f_anda_simpl (PVM.subst env spre fpre) post in + + let poe = TTC.merge2_poe_list (epost, d) (fepost, fd) in + let poe = List.map (fun inv -> { m; inv; }) poe in + let poe = + let penv_e = EcEnv.Fun.inv_memenv1 m env in + List.map (fun f -> + let genf = generalize_mod_ss_inv penv_e modi f in + (ss_inv_rebind genf m).inv + ) poe in + + List.fold f_anda_simpl post poe + +(* -------------------------------------------------------------------- *) +let compute_equiv_call_post + (hyps : LDecl.hyps) + ((ml, mr) : memory * memory) + (contract : form * form) + ?(mods : EcPV.PV.t * EcPV.PV.t = (EcPV.PV.empty, EcPV.PV.empty)) + (call_l : lvalue option * EcPath.xpath * expr list) + (call_r : lvalue option * EcPath.xpath * expr list) + (post : form) = - let ml, mr = post.ml, post.mr in + let env = LDecl.toenv hyps in + + let (fpre, fpost) = contract in + let (lpl, fl, argsl) = call_l in + let (lpr, fr, argsr) = call_r in + + let modil = EcPV.PV.union (fst mods) (f_write env fl) in + let modir = EcPV.PV.union (snd mods) (f_write env fr) in + let fsigl = (Fun.by_xpath fl env).f_sig in let fsigr = (Fun.by_xpath fr env).f_sig in - (* The wp *) - let pvresl = pv_res and pvresr = pv_res in + let vresl = LDecl.fresh_id hyps "result_L" in let vresr = LDecl.fresh_id hyps "result_R" in - let fresl = {ml;mr; inv=f_local vresl fsigl.fs_ret} in - let fresr = {ml;mr; inv=f_local vresr fsigr.fs_ret} in - let post = map_ts_inv_left2 (wp_asgn_call ~mc:(ml,mr) env lpl) fresl post in - let post = map_ts_inv_right2 (wp_asgn_call ~mc:(ml,mr) env lpr) fresr post in - let s = PVM.empty in - let s = PVM.add env pvresr mr fresr.inv s in - let s = PVM.add env pvresl ml fresl.inv s in - let fpost = map_ts_inv1 (PVM.subst env s) fpost in - let post = generalize_mod_ts_inv env modil modir (map_ts_inv2 f_imp_simpl fpost post) in - let post = map_ts_inv1 + let fresl = {ml; mr; inv = f_local vresl fsigl.fs_ret} in + let fresr = {ml; mr; inv = f_local vresr fsigr.fs_ret} in + + let post = + {ml; mr; inv = post} + |> map_ts_inv_left2 (wp_asgn_call ~mc:(ml, mr) env lpl) fresl + |> map_ts_inv_right2 (wp_asgn_call ~mc:(ml, mr) env lpr) fresr in + + let post = (ts_inv_rebind post ml mr).inv in + + let fpost = + let s = + PVM.of_list env + [((pv_res, mr), fresr.inv); ((pv_res, ml), fresl.inv)] in + PVM.subst env s fpost in + + let post = + {ml; mr; inv = (f_imp_simpl fpost post)} + |> generalize_mod_ts_inv env modil modir + in + + let post = (ts_inv_rebind post ml mr).inv in + + let post = (f_forall_simpl [(vresl, GTty fsigl.fs_ret); (vresr, GTty fsigr.fs_ret)]) post in + let spre = subst_args_call env ml (e_tuple argsl) PVM.empty in let spre = subst_args_call env mr (e_tuple argsr) spre in - map_ts_inv2 f_anda_simpl (map_ts_inv1 (PVM.subst env spre) fpre) post + + f_anda_simpl (PVM.subst env spre fpre) post (* -------------------------------------------------------------------- *) +let compute_equiv1_call_post + (hyps : LDecl.hyps) + (side : side) + ((ml, mr) : memory * memory) + (contract : form * form) + (call : lvalue option * EcPath.xpath * expr list) + (post : form) += + let env = LDecl.toenv hyps in + + let (fpre, fpost) = contract in + let (lp, fname, args) = call in + let me = sideif side ml mr in + + let wp_asgn_call_side env lv = sideif side + (map_ts_inv_left2 (wp_asgn_call ~mc:(ml,mr) env lv)) + (map_ts_inv_right2 (wp_asgn_call ~mc:(ml,mr) env lv)) + in + let generalize_mod_side = sideif side + generalize_mod_left generalize_mod_right in + + let ss_inv_generalize_other_side inv = sideif side + (ss_inv_generalize_right inv mr) (ss_inv_generalize_left inv ml) in + + let fsig = (Fun.by_xpath fname env).f_sig in + let vres = LDecl.fresh_id hyps "result" in + let fres = { ml; mr; inv = f_local vres fsig.fs_ret; } in + + let post = wp_asgn_call_side env lp fres { ml; mr; inv = post; } in + let post = (ts_inv_rebind post ml mr).inv in + + let subst = PVM.add env pv_res me fres.inv PVM.empty in + + let fpost = ss_inv_generalize_other_side { m = me; inv = fpost; } in + let fpost = (ts_inv_rebind fpost ml mr).inv in + let fpost = PVM.subst env subst fpost in + let fpre = ss_inv_generalize_other_side { m = me; inv = fpre ; } in + let fpre = (ts_inv_rebind fpre ml mr).inv in + + let modi = f_write env fname in + let post = f_imp_simpl fpost post in + let post = generalize_mod_side env modi { ml; mr; inv = post } in + let post = (ts_inv_rebind post ml mr).inv in + let post = f_forall_simpl [(vres, GTty fsig.fs_ret)] post in + let spre = subst_args_call env me (e_tuple args) PVM.empty in + + f_anda_simpl (PVM.subst env spre fpre) post + +(* -------------------------------------------------------------------- *) let t_hoare_call fpre fpost tc = - let env = FApi.tc1_env tc in - let hs = tc1_as_hoareS tc in - let (lp,f,args),s = tc1_last_call tc hs.hs_s in - let m = EcMemory.memory hs.hs_m in - let fsig = (Fun.by_xpath f env).f_sig in - (* The function satisfies the specification *) - let f_concl = f_hoareF fpre f fpost in - (* substitute memories *) - let fpre = (ss_inv_rebind fpre m) in - let fpost = hs_inv_rebind fpost m in - let { main = inv; exnmap = (fepost, fd); } = fpost.hsi_inv in - let fpost = {m;inv} in - (* The wp *) - let { main = post; exnmap = (epost, d); } = (hs_po hs).hsi_inv in - let pvres = pv_res in - let vres = EcIdent.create "result" in - let fres = {m;inv=f_local vres fsig.fs_ret} in - let post = wp_asgn_call env lp fres {m=(hs_po hs).hsi_m;inv=post} in - let fpost = map_ss_inv2 (PVM.subst1 env pvres m) fres fpost in - let modi = f_write env f in + let hyps = FApi.tc1_hyps tc in + let hs = tc1_as_hoareS tc in + let m = EcMemory.memory hs.hs_m in + let fpre = (ss_inv_rebind fpre m) in + let fpost = (hs_inv_rebind fpost m) in - let post = map_ss_inv2 f_imp_simpl fpost post in - let post = generalize_mod_ss_inv env modi post in - let post = map_ss_inv1 (f_forall_simpl [(vres, GTty fsig.fs_ret)]) post in - let spre = subst_args_call env m (e_tuple args) PVM.empty in - let post = map_ss_inv2 f_anda_simpl (map_ss_inv1 (PVM.subst env spre) fpre) post in + let call, s = tc1_last_call tc hs.hs_s in - let poe = TTC.merge2_poe_list (epost,d) (fepost,fd) in - let poe = List.map (fun inv -> {m;inv}) poe in - let penv_e = EcEnv.Fun.inv_memenv1 m env in - let poe = List.map (generalize_mod_ss_inv penv_e modi) poe in + (* The function satisfies the specification *) + let f_concl = f_hoareF fpre (proj3_2 call) fpost in - let post = List.fold (map_ss_inv2 f_anda_simpl) post poe in + (* WP *) + let post = + compute_hoare_call_post hyps m + (fpre.inv, fpost.hsi_inv) call (hs_po hs).hsi_inv in let post = { - hsi_m = post.m; - hsi_inv = { main = post.inv; exnmap = (epost, d); }; + hsi_m = m; + hsi_inv = { main = post; exnmap = (hs_po hs).hsi_inv.exnmap; }; } in + let concl = f_hoareS (snd hs.hs_m) (hs_pr hs) s post in + FApi.xmutate1 tc `HlCall [f_concl; concl] (* -------------------------------------------------------------------- *) @@ -255,24 +362,25 @@ let t_bdhoare_call fpre fpost opt_bd tc = (* -------------------------------------------------------------------- *) let t_equiv_call fpre fpost tc = - let env, hyps, _ = FApi.tc1_eflat tc in + let hyps = FApi.tc1_hyps tc in let es = tc1_as_equivS tc in let ml, mr = fst es.es_ml, fst es.es_mr in - let fpre = ts_inv_rebind fpre ml mr in + + let fpre = ts_inv_rebind fpre ml mr in let fpost = ts_inv_rebind fpost ml mr in - let (lpl,fl,argsl),sl = tc1_last_call tc es.es_sl in - let (lpr,fr,argsr),sr = tc1_last_call tc es.es_sr in + let ((_, fl, _) as call_l), sl = tc1_last_call tc es.es_sl in + let ((_, fr, _) as call_r), sr = tc1_last_call tc es.es_sr in + (* The functions satisfy their specification *) let f_concl = f_equivF fpre fl fr fpost in - let modil = f_write env fl in - let modir = f_write env fr in + (* The wp *) let post = - wp2_call env fpre fpost - (lpl,fl,argsl) modil (lpr,fr,argsr) modir - (es_po es) hyps - in + compute_equiv_call_post + hyps (ml, mr) (fpre.inv, fpost.inv) call_l call_r (es_po es).inv in + let post = { ml; mr; inv = post; } in + let concl = f_equivS (snd es.es_ml) (snd es.es_mr) (es_pr es) sl sr post in @@ -280,52 +388,34 @@ let t_equiv_call fpre fpost tc = (* -------------------------------------------------------------------- *) let t_equiv_call1 side fpre fpost tc = - let env = FApi.tc1_env tc in - let equiv = tc1_as_equivS tc in - let ml, mr = fst equiv.es_ml, fst equiv.es_mr in - let mtl, mtr = snd equiv.es_ml, snd equiv.es_mr in + let hyps = FApi.tc1_hyps tc in + let es = tc1_as_equivS tc in - let (me, stmt) = - match side with - | `Left -> (EcMemory.memory equiv.es_ml, equiv.es_sl) - | `Right -> (EcMemory.memory equiv.es_mr, equiv.es_sr) - in - let wp_asgn_call_side env lv = sideif side - (map_ts_inv_left2 (wp_asgn_call ~mc:(ml,mr) env lv)) - (map_ts_inv_right2 (wp_asgn_call ~mc:(ml,mr) env lv)) - in - let generalize_mod_side = sideif side - generalize_mod_left generalize_mod_right in - let ss_inv_generalize_other_side inv = sideif side - (ss_inv_generalize_right inv mr) (ss_inv_generalize_left inv ml) in + let ml, mr = fst es.es_ml, fst es.es_mr in + let me = sideif side ml mr in - let (lp, f, args), fstmt = tc1_last_call tc stmt in - let fsig = (Fun.by_xpath f env).f_sig in + let fpre = ss_inv_rebind fpre me in + let fpost = ss_inv_rebind fpost me in + + let stmt = sideif side es.es_sl es.es_sr in + let ((_, fname, _) as call), fstmt = tc1_last_call tc stmt in (* The function satisfies its specification *) - let fconcl = f_bdHoareF fpre f fpost FHeq {m=fpost.m; inv=f_r1} in + let fconcl = + f_bdHoareF fpre fname fpost FHeq { m = fpost.m; inv = f_r1; } in (* WP *) - let pvres = pv_res in - let vres = LDecl.fresh_id (FApi.tc1_hyps tc) "result" in - let fres = {ml;mr;inv=f_local vres fsig.fs_ret} in - let post = wp_asgn_call_side env lp fres (es_po equiv) in - let subst = PVM.add env pvres me fres.inv PVM.empty in - let fpost = ss_inv_generalize_other_side (ss_inv_rebind fpost me) in - let fpre = ss_inv_generalize_other_side (ss_inv_rebind fpre me) in - let fpost = map_ts_inv1 (PVM.subst env subst) fpost in - let modi = f_write env f in - let post = map_ts_inv2 f_imp_simpl fpost post in - let post = generalize_mod_side env modi post in - let post = map_ts_inv1 (f_forall_simpl [(vres, GTty fsig.fs_ret)]) post in - let spre = PVM.empty in - let spre = subst_args_call env me (e_tuple args) spre in - let post = - map_ts_inv2 f_anda_simpl (map_ts_inv1 (PVM.subst env spre) fpre) post in + let post = + compute_equiv1_call_post + hyps side (ml, mr) (fpre.inv, fpost.inv) call (es_po es).inv in + let post = { ml; mr; inv = post; } in + + let mtl, mtr = snd es.es_ml, snd es.es_mr in + let concl = match side with - | `Left -> f_equivS mtl mtr (es_pr equiv) fstmt equiv.es_sr post - | `Right -> f_equivS mtl mtr (es_pr equiv) equiv.es_sl fstmt post in + | `Left -> f_equivS mtl mtr (es_pr es) fstmt es.es_sr post + | `Right -> f_equivS mtl mtr (es_pr es) es.es_sl fstmt post in FApi.xmutate1 tc `HlCall [fconcl; concl] diff --git a/src/phl/ecPhlCall.mli b/src/phl/ecPhlCall.mli index 1c87ae8f21..2cb7d1cd62 100644 --- a/src/phl/ecPhlCall.mli +++ b/src/phl/ecPhlCall.mli @@ -4,15 +4,36 @@ open EcCoreGoal.FApi open EcAst (* -------------------------------------------------------------------- *) -val wp2_call : - EcEnv.env -> ts_inv -> ts_inv +val compute_hoare_call_post : + EcEnv.LDecl.hyps + -> EcMemory.memory + -> form * exnpost + -> lvalue option * EcPath.xpath * expr list + -> exnpost + -> form + +(* -------------------------------------------------------------------- *) +val compute_equiv_call_post : + EcEnv.LDecl.hyps + -> EcMemory.memory * EcMemory.memory + -> form * form + -> ?mods:(EcPV.PV.t * EcPV.PV.t) -> EcModules.lvalue option * EcPath.xpath * EcTypes.expr list - -> EcPV.PV.t -> EcModules.lvalue option * EcPath.xpath * EcTypes.expr list - -> EcPV.PV.t - -> ts_inv - -> EcEnv.LDecl.hyps -> ts_inv + -> form + -> form +(* -------------------------------------------------------------------- *) +val compute_equiv1_call_post : + EcEnv.LDecl.hyps + -> side + -> EcMemory.memory * EcMemory.memory + -> form * form + -> EcModules.lvalue option * EcPath.xpath * EcTypes.expr list + -> form + -> form + +(* -------------------------------------------------------------------- *) val t_hoare_call : ss_inv -> hs_inv -> backward val t_bdhoare_call : ss_inv -> ss_inv -> ss_inv option -> backward val t_equiv_call : ts_inv -> ts_inv -> backward diff --git a/src/phl/ecPhlEager.ml b/src/phl/ecPhlEager.ml index 800de9b7d4..9bb80a3a59 100644 --- a/src/phl/ecPhlEager.ml +++ b/src/phl/ecPhlEager.ml @@ -361,11 +361,14 @@ let t_eager_fun_abs_r i tc = let t_eager_call_r fpre fpost tc = let env, hyps, _ = FApi.tc1_eflat tc in let es = tc1_as_equivS tc in - let fpre = EcSubst.ts_inv_rebind fpre (fst es.es_ml) (fst es.es_mr) in - let fpost = EcSubst.ts_inv_rebind fpost (fst es.es_ml) (fst es.es_mr) in - let (lvl, fl, argsl), sl = pf_last_call !!tc es.es_sl in - let (lvr, fr, argsr), sr = pf_first_call !!tc es.es_sr in + let ml, mr = (fst es.es_ml, fst es.es_mr) in + + let fpre = EcSubst.ts_inv_rebind fpre ml mr in + let fpost = EcSubst.ts_inv_rebind fpost ml mr in + + let ((_, fl, argsl) as call_l), sl = pf_last_call !!tc es.es_sl in + let ((_, fr, _) as call_r), sr = pf_first_call !!tc es.es_sr in let swl = s_write env sl in let swr = s_write env sr in @@ -382,15 +385,18 @@ let t_eager_call_r fpre fpost tc = List.iter check_a argsl; - let modil = PV.union (f_write env fl) swl in - let modir = PV.union (f_write env fr) swr in let post = - EcPhlCall.wp2_call env fpre fpost (lvl, fl, argsl) modil (lvr, fr, argsr) - modir (es_po es) hyps + EcPhlCall.compute_equiv_call_post + hyps ~mods:(swl, swr) (ml, mr) (fpre.inv, fpost.inv) + call_l call_r (es_po es).inv in - let f_concl = f_eagerF fpre sl fl fr sr fpost in + let post = { ml; mr; inv = post } in + + let f_concl = + f_eagerF fpre sl fl fr sr fpost in + let concl = - f_equivS (snd es.es_ml) (snd es.es_mr) (es_pr es) (stmt []) (stmt []) post + f_equivS (snd es.es_ml) (snd es.es_mr) (es_pr es) s_empty s_empty post in FApi.xmutate1 tc `EagerCall [ f_concl; concl ] diff --git a/src/phl/ecPhlExists.ml b/src/phl/ecPhlExists.ml index 90f017cbb1..0c48ce521d 100644 --- a/src/phl/ecPhlExists.ml +++ b/src/phl/ecPhlExists.ml @@ -140,102 +140,443 @@ let process_exists_intro ~(elim : bool) fs tc = else tc (* -------------------------------------------------------------------- *) -let process_ecall oside (l, tvi, fs) tc = - let (hyps, concl) = FApi.tc1_flat tc in +type call = EcModules.lvalue option * EcPath.xpath * EcTypes.expr list - let hyps, kind, f_tr = - match concl.f_node with - | FhoareS hs when is_none oside -> - LDecl.push_active_ss hs.hs_m hyps, `Hoare (List.length hs.hs_s.s_node), - Inv_ss {m = fst hs.hs_m; inv = f_true} - | FequivS es -> - let n1 = List.length es.es_sl.s_node in - let n2 = List.length es.es_sr.s_node in - LDecl.push_all [es.es_ml; es.es_mr] hyps, `Equiv (n1, n2), - Inv_ts {ml = fst es.es_ml; mr = fst es.es_mr; inv = f_true} - | _ -> tc_error_noXhl ~kinds:[`Hoare `Stmt; `Equiv `Stmt] !!tc - in +type calls = [ + | `Single of call + | `Double of call * call +] - let t_local_seq p1 tc = - match kind, oside, p1 with - | `Hoare n, _, Inv_ss p1 -> - EcPhlSeq.t_hoare_seq - (Zpr.cpos (n-1)) p1 tc - | `Hoare n, _, Inv_hs p1 -> - EcPhlSeq.t_hoare_seq - (Zpr.cpos (n-1)) (POE.lower p1) tc - | `Equiv (n1, n2), None, Inv_ts p1 -> - EcPhlSeq.t_equiv_seq - (Zpr.cpos (n1-1), Zpr.cpos (n2-1)) p1 tc - | `Equiv (n1, n2), Some `Left, Inv_ts p1 -> - EcPhlSeq.t_equiv_seq - (Zpr.cpos (n1-1), Zpr.cpos n2) p1 tc - | `Equiv(n1, n2), Some `Right, Inv_ts p1 -> - EcPhlSeq.t_equiv_seq - (Zpr.cpos n1, Zpr.cpos (n2-1)) p1 tc - | _ -> tc_error !!tc "mismatched sidedness or kind of conclusion" - in +(* -------------------------------------------------------------------- *) +let check_contract_type + ?(loc : L.t option) + ?(phoare : bool = false) + ?(noexn : bool = true) + ~(name : EcSymbols.qsymbol) + (pe : proofenv) + (hyps : LDecl.hyps) + (calls : calls) + (contract : form) += + let env = LDecl.toenv hyps in + + let contract = + EcReduction.h_red_opt EcReduction.full_red hyps contract + |> odfl contract in + + match calls with + | `Single (_, funname, _) -> begin + let cttfname = + match contract.f_node with + | FhoareF hf -> + if noexn then begin + if not (POE.is_empty (hf_po hf).hsi_inv) then + tc_error ?loc pe + "contract must have an empty exception post-condition"; + end; + hf.hf_f + | FbdHoareF hf when phoare -> hf.bhf_f + | _ -> + tc_error_lazy ?loc pe (fun fmt -> + Format.fprintf fmt + "contract %a should be a Hoare statement" + EcSymbols.pp_qsymbol name + ) + in + if not (EcReduction.EqTest.for_xp env funname cttfname) then begin + tc_error_lazy ?loc pe (fun fmt -> + let ppe = EcPrinting.PPEnv.ofenv env in + Format.fprintf fmt + "contract %a should be for the procedure %a, not %a" + EcSymbols.pp_qsymbol name + (EcPrinting.pp_funname ppe) funname + (EcPrinting.pp_funname ppe) cttfname + ) + end; + end + + | `Double ((_, fl, _), (_, fr, _)) -> + let contract = + try + destr_equivF contract + with DestrError _ -> + tc_error_lazy ?loc pe (fun fmt -> + Format.fprintf fmt + "contract %a should be an Equiv statement" + EcSymbols.pp_qsymbol name + ) + in + List.iter (fun (f, ef_f, side) -> + if not (EcReduction.EqTest.for_xp env f ef_f) then begin + tc_error_lazy ?loc pe (fun fmt -> + let ppe = EcPrinting.PPEnv.ofenv env in + Format.fprintf fmt + "%s-side of contract %a should be for the procedure %a, not %a" + side + EcSymbols.pp_qsymbol name + (EcPrinting.pp_funname ppe) f + (EcPrinting.pp_funname ppe) ef_f + ) + end + ) [(fl, contract.ef_fl, "left"); (fr, contract.ef_fr, "right")] - let fs = - List.map - (fun f -> map_inv1 (fun _ -> TTC.pf_process_form_opt !!tc hyps None f) f_tr) - fs +(* -------------------------------------------------------------------- *) +let abstract_pvs + (hyps : LDecl.hyps) + (ms : memory list) + (pvs : ((prog_var * ty) list) EcIdent.Mid.t) += + let env = LDecl.toenv hyps in + + let mkinv = + match ms with + | [m] -> fun inv -> Inv_ss { m; inv; } + | [ml; mr] -> fun inv -> Inv_ts { ml; mr; inv; } + | _ -> assert false in + + let for_memory (subst : EcPV.PVM.subst) (m : memory) = + let pvs = EcIdent.Mid.find_def [] m pvs in + + let ids = List.map (fun (pv, ty) -> + (Format.sprintf "%s_" (EcTypes.symbol_of_pv pv)), ty) pvs in + let ids = + List.combine + (LDecl.fresh_ids hyps (List.fst ids)) + (List.snd ids) in + + let pvs_as_inv = List.map (fun (pv, ty) -> + mkinv (f_pvar pv ty m).inv + ) pvs in + let subst = List.fold_left (fun subst ((pv, ty), x) -> + EcPV.PVM.add env pv m (f_local x ty) subst + ) subst (List.combine pvs (List.fst ids)) in + + (subst, (ids, pvs, pvs_as_inv)) in - let ids, p1 = - let sub = t_local_seq f_tr tc in + let subst, ids = + List.fold_left_map for_memory EcPV.PVM.empty ms in - let sub = FApi.t_rotate `Left 1 sub in - let sub = FApi.t_focus (t_hr_exists_intro_r fs) sub in - let sub = FApi.t_focus (t_hr_exists_elim_r ~bound:(List.length fs)) sub in + let ids = List.map proj3_1 ids + and pvs = List.map proj3_2 ids + and pvs_as_inv = List.map proj3_3 ids in + let ids = List.flatten ids in + let pvs = List.flatten pvs in + let pvs_as_inv = List.flatten pvs_as_inv in - let ids = - try fst (EcFol.destr_forall (FApi.tc_goal sub)) - with DestrError _ -> [] in - let ids = List.map (snd_map gty_as_ty) ids in + ids, pvs, pvs_as_inv, subst + +(* -------------------------------------------------------------------- *) +let t_ecall_hoare_fwd ((cttpt, ctt) : (proofterm * form)) (tc : tcenv1) = + let hyps = FApi.tc1_hyps tc in + let env = EcEnv.LDecl.toenv hyps in + let concl = destr_hoareS (FApi.tc1_goal tc) in + let m = (fst concl.hs_m) in + let (lvalue, funname, _), _ = pf_first_call !!tc concl.hs_s in + + let pvs = PT.collect_pvars_from_pt cttpt in + let ids, _, pvs_as_inv, subst = abstract_pvs hyps [m] pvs in + + let tc = t_hr_exists_intro_r pvs_as_inv tc in + let tc = FApi.t_focus (t_hr_exists_elim_r ~bound:(List.length ids)) tc in + let tc = FApi.t_focus (t_intros_i (List.fst ids)) tc in + + let cttpt = PT.subst_pv_pt env subst cttpt in + let ctt = EcPV.PVM.subst env subst ctt in + + let ctt = + EcReduction.h_red_opt EcReduction.full_red hyps ctt + |> odfl ctt in + + let seqf = + let inv = destr_hoareF ctt in + let _ = assert (POE.is_empty (hf_po inv).hsi_inv) in + let inv = POE.lower (hf_po inv) in + let inv = ss_inv_rebind inv (fst concl.hs_m) in + + match lvalue with + | None -> + let not_contains_res (f : form) = + not (EcPV.PV.mem_pv env EcTypes.pv_res (EcPV.form_read env f)) in + map_ss_inv1 + (fun f -> filter_topand_form not_contains_res f |> odfl f_true) + inv + + | Some lvalue -> + let lv = + List.map + (fun (pv, ty) -> (f_pvar pv ty inv.m).inv) + (EcModules.lv_to_ty_list lvalue) in + let sres = + EcPV.PVM.add + env EcTypes.pv_res inv.m + (f_tuple lv) EcPV.PVM.empty in + + { inv = EcPV.PVM.subst env sres inv.inv; m = inv.m; } in + + let seqf_frame = + let wr = lvalue |> omap (EcPV.lp_write env) |> odfl EcPV.PV.empty in + let wr = EcPV.f_write_r env wr funname in + let inv = + filter_topand_form + (fun f -> EcPV.PV.indep env wr (EcPV.form_read env f)) + (hs_pr concl).inv in + { inv = odfl f_true inv; m = (hs_pr concl).m; } in + + let tc = + FApi.t_first + (EcPhlSeq.t_hoare_seq (Zpr.cpos 1) (map_ss_inv2 f_and seqf seqf_frame)) + tc in + + let tc = FApi.t_first EcPhlHoare.t_hoaresplit tc in + let tc = FApi.t_first (EcPhlConseq.t_conseqauto ~delta:false ?tsolve:None) tc in + let tc = FApi.t_first EcPhlTAuto.t_hoare_true tc in + + let tc = FApi.t_first (EcPhlCall.t_call None ctt) tc in + let tc = FApi.t_sub [ + EcLowGoal.Apply.t_apply_bwd_hi ~dpe:true cttpt; + EcPhlSkip.t_skip; + t_id + ] tc in + + let tc = + FApi.t_firsts + (t_generalize_hyps ~clear:`Yes (List.fst ids)) 2 tc in + + tc + +(* -------------------------------------------------------------------- *) +let t_ecall_hoare_bwd ((cttpt, _) : proofterm * form) (tc : tcenv1) = + let hyps = FApi.tc1_hyps tc in + let env = EcEnv.LDecl.toenv hyps in + let concl = destr_hoareS (FApi.tc1_goal tc) in + let m = fst (concl.hs_m) in + let call, _ = pf_last_call !!tc concl.hs_s in + + let pvs = PT.collect_pvars_from_pt cttpt in + let ids, _, pvs_as_inv, subst = abstract_pvs hyps [m] pvs in + + let cttpt = + let pt_head, pt_args = + match cttpt with + | PTApply { pt_head; pt_args } -> (pt_head, pt_args) + | _ -> assert false in + let pt_args = List.map (PT.subst_pv_pt_arg env subst) pt_args in + PTApply { pt_head; pt_args } in + + let cttpt, ctt = EcLowGoal.LowApply.check `Elim cttpt (`Hyps (hyps, !!tc)) in + + let ctt = + EcReduction.h_red_opt EcReduction.full_red hyps ctt + |> odfl ctt in + + let ids_subst = + List.fold_left2 + (fun s (id, _) pv -> EcSubst.add_flocal s id (inv_of_inv pv)) + EcSubst.empty ids pvs_as_inv in + + let fpre, fpost = + let hf = destr_hoareF ctt in + (ss_inv_rebind (hf_pr hf) m).inv, (hs_inv_rebind (hf_po hf) m).hsi_inv + in - let nms = List.map (fun (_, x) -> (EcIdent.create "_", x)) ids in - let sub = FApi.t_focus (EcLowGoal.t_intros_i (List.fst nms)) sub in - let pte = PT.ptenv_of_penv (FApi.tc_hyps sub) !!tc in - let pt = PT.process_pterm pte (APT.FPNamed (l, tvi)) in + let post = + EcPhlCall.compute_hoare_call_post + hyps m (fpre, fpost) call (hs_po concl).hsi_inv in + let post = EcSubst.subst_form ids_subst post in - let pt = - List.fold_left (fun pt (id, ty) -> - PT.apply_pterm_to_arg_r pt (PT.PVAFormula (f_local id ty))) - pt ids in + let tc = EcPhlSeq.t_hoare_seq (Zpr.cpos (-1)) { m = m; inv = post; } tc in + let tc = FApi.t_last (t_hr_exists_intro_r pvs_as_inv) tc in + let tc = FApi.t_last (t_hr_exists_elim_r ~bound:(List.length ids)) tc in + let tc = FApi.t_last (t_intros_i (List.fst ids)) tc in + let tc = FApi.t_last (EcPhlCall.t_call None ctt) tc in - assert (PT.can_concretize pt.PT.ptev_env); - let _pt, ax = PT.concretize pt in + FApi.t_sub [ + EcLowGoal.t_id; (* initial hoare statement without the call *) + EcLowGoal.Apply.t_apply_bwd_hi ~dpe:true cttpt; (* Prove the Hoare contract *) + EcPhlAuto.t_auto ?conv:None; (* Kill the conseq from the call rule *) + ] tc - let sub = FApi.t_focus (EcPhlCall.t_call oside ax) sub in - let sub = FApi.t_rotate `Left 1 sub in - let sub = oget (get_post (FApi.tc_goal sub)) in +(* -------------------------------------------------------------------- *) +let process_ecall_hoare + (dir : APT.pdirection) + (pterm : APT.pecall) + (tc : tcenv1) += + let (ctt_path, ctt_tvi, ctt_args) = pterm in + let hyps = FApi.tc1_hyps tc in + let concl = destr_hoareS (FApi.tc1_goal tc) in + + (* Type-check contract (lemma) - apply it fully to find the Hoare contract *) + let ptenv = PT.ptenv_of_penv (LDecl.push_active_ss concl.hs_m hyps) !!tc in + let contract = PT.process_pterm ptenv (APT.FPNamed (ctt_path, ctt_tvi)) in + let contract, _ = PT.process_pterm_args_app contract ctt_args in + let contract = PT.apply_pterm_to_max_holes hyps contract in + + assert (PT.can_concretize contract.PT.ptev_env); + let contract = PT.concretize contract in + + let call, _ = + match dir with + | `Forward -> pf_first_call !!tc concl.hs_s + | `Backward -> pf_last_call !!tc concl.hs_s in + + check_contract_type + ~noexn:(dir <> `Backward) ~loc:(L.loc ctt_path) ~name:(L.unloc ctt_path) + !!tc hyps (`Single call) (snd contract); + + match dir with + | `Forward -> t_ecall_hoare_fwd contract tc + | `Backward -> t_ecall_hoare_bwd contract tc - let subst = - List.fold_left2 - (fun s id f -> add_flocal s id (inv_of_inv f)) - empty (List.fst ids) fs in - (nms, subst_inv subst sub) in +(* -------------------------------------------------------------------- *) +let process_ecall_equiv + (dir : APT.pdirection) + (oside : side option) + (pterm : APT.pecall) + (tc : tcenv1) += + if dir <> `Backward then + tc_error !!tc "unsupported direction for ecall on an equiv. goal"; + + let (ctt_path, ctt_tvi, ctt_args) = pterm in + let hyps = FApi.tc1_hyps tc in + let env = EcEnv.LDecl.toenv hyps in + let concl = destr_equivS (FApi.tc1_goal tc) in + let (ml, _), (mr, _) = concl.es_ml, concl.es_mr in + + (* Type-check contract (lemma) - apply it fully to find the Hoare/Equiv contract *) + let cttpt, _ = + let ptenv = PT.ptenv_of_penv (LDecl.push_active_ts concl.es_ml concl.es_mr hyps) !!tc in + let contract = PT.process_pterm ptenv (APT.FPNamed (ctt_path, ctt_tvi)) in + let contract, _ = PT.process_pterm_args_app contract ctt_args in + let contract = PT.apply_pterm_to_max_holes hyps contract in + assert (PT.can_concretize contract.PT.ptev_env); + PT.concretize contract in + + let pvs = PT.collect_pvars_from_pt cttpt in + let ids, _, pvs_as_inv, subst = abstract_pvs hyps [ml; mr] pvs in + + let cttpt = + let pt_head, pt_args = + match cttpt with + | PTApply { pt_head; pt_args } -> (pt_head, pt_args) + | _ -> assert false in + let pt_args = List.map (PT.subst_pv_pt_arg env subst) pt_args in + PTApply { pt_head; pt_args } in + + let cttpt, ctt = EcLowGoal.LowApply.check `Elim cttpt (`Hyps (hyps, !!tc)) in + + let ctt = + EcReduction.h_red_opt EcReduction.full_red hyps ctt + |> odfl ctt in + + let ids_subst = + List.fold_left2 + (fun s (id, _) pv -> EcSubst.add_flocal s id (inv_of_inv pv)) + EcSubst.empty ids pvs_as_inv in + + let calls = + match oside with + | None -> + let call_l, _ = pf_last_call !!tc concl.es_sl in + let call_r, _ = pf_last_call !!tc concl.es_sr in + `Double (call_l, call_r) + | Some side -> + let call, _ = + pf_last_call !!tc (APT.sideif side concl.es_sl concl.es_sr) + in `Single call + in - let tc = t_local_seq p1 tc in - let tc = FApi.t_rotate `Left 1 tc in - let tc = FApi.t_focus (t_hr_exists_intro_r fs) tc in - let tc = FApi.t_focus (t_hr_exists_elim_r ~bound:(List.length fs)) tc in - let tc = FApi.t_focus (EcLowGoal.t_intros_i (List.fst ids)) tc in + check_contract_type + ~phoare:true ~loc:(L.loc ctt_path) ~name:(L.unloc ctt_path) + !!tc hyps calls ctt; + + match calls with + | `Single call -> begin + let side = oget oside in + let m = APT.sideif side ml mr in + + let fpre, fpost = + match ctt.f_node with + | FhoareF hf -> + assert (POE.is_empty (hf_po hf).hsi_inv); + (ss_inv_rebind (hf_pr hf) m).inv, + (hs_inv_rebind (hf_po hf) m).hsi_inv.main + | FbdHoareF hf -> + (ss_inv_rebind (bhf_pr hf) m).inv, + (ss_inv_rebind (bhf_po hf) m).inv + | _ -> assert false + in - let pte = PT.ptenv_of_penv (FApi.tc_hyps tc) (FApi.tc_penv tc) in - let pt = PT.process_pterm pte (APT.FPNamed (l, tvi)) in + let post = + EcPhlCall.compute_equiv1_call_post + hyps side (ml, mr) (fpre, fpost) call (es_po concl).inv in + let post = EcSubst.subst_form ids_subst post in + + let pos = + let nl = List.length concl.es_sl.s_node in + let nr = List.length concl.es_sr.s_node in + APT.sideif side + (Zpr.cpos (-1), Zpr.cpos (nr)) + (Zpr.cpos (nl), Zpr.cpos (-1)) in + + let tc = EcPhlSeq.t_equiv_seq pos { ml; mr; inv = post; } tc in + let tc = FApi.t_last (t_hr_exists_intro_r pvs_as_inv) tc in + let tc = FApi.t_last (t_hr_exists_elim_r ~bound:(List.length ids)) tc in + let tc = FApi.t_last (t_intros_i (List.fst ids)) tc in + let tc = FApi.t_last (EcPhlCall.t_call (Some side) ctt) tc in + + FApi.t_sub [ + EcLowGoal.t_id; (* initial equiv statement without the call *) + EcLowGoal.Apply.t_apply_bwd_hi ~dpe:true cttpt; (* Prove the Hoare contract *) + EcPhlAuto.t_auto ?conv:None; (* Kill the conseq from the call rule *) + ] tc + end + + | `Double (call_l, call_r) -> begin + let fpre, fpost = + let hf = destr_equivF ctt in + (ts_inv_rebind (ef_pr hf) ml mr).inv, + (ts_inv_rebind (ef_po hf) ml mr).inv + in - let pt = - List.fold_left (fun pt (id, ty) -> - PT.apply_pterm_to_arg_r pt (PT.PVAFormula (f_local id ty))) - pt ids in + let post = + EcPhlCall.compute_equiv_call_post + hyps (ml, mr) (fpre, fpost) call_l call_r (es_po concl).inv in + let post = EcSubst.subst_form ids_subst post in - assert (PT.can_concretize pt.PT.ptev_env); + let tc = + EcPhlSeq.t_equiv_seq + (Zpr.cpos (-1), Zpr.cpos (-1)) + { ml; mr; inv = post; } tc in - let pt, ax = PT.concretize pt in + let tc = FApi.t_last (t_hr_exists_intro_r pvs_as_inv) tc in + let tc = FApi.t_last (t_hr_exists_elim_r ~bound:(List.length ids)) tc in + let tc = FApi.t_last (t_intros_i (List.fst ids)) tc in + let tc = FApi.t_last (EcPhlCall.t_call None ctt) tc in - let tc = FApi.t_focus (EcPhlCall.t_call oside ax) tc in - let tc = FApi.t_focus (EcLowGoal.Apply.t_apply_bwd_hi ~dpe:true pt) tc in + FApi.t_sub [ + EcLowGoal.t_id; (* initial equiv statement without the call *) + EcLowGoal.Apply.t_apply_bwd_hi ~dpe:true cttpt; (* Prove the Hoare contract *) + EcPhlAuto.t_auto ?conv:None; (* Kill the conseq from the call rule *) + ] tc + end - FApi.t_last EcPhlAuto.t_auto (FApi.t_rotate `Right 1 tc) +(* -------------------------------------------------------------------- *) +let process_ecall + (dir : APT.pdirection) + (oside : side option) + (pterm : APT.pecall) + (tc : tcenv1) += + match (FApi.tc1_goal tc).f_node with + | FhoareS _ -> + if Option.is_some oside then + tc_error !!tc "cannot provide a side for Hoare goals"; + process_ecall_hoare dir pterm tc + + | FequivS _ -> + process_ecall_equiv dir oside pterm tc + + | _ -> tc_error_noXhl ~kinds:[`Hoare `Stmt; `Equiv `Stmt] !!tc diff --git a/src/phl/ecPhlExists.mli b/src/phl/ecPhlExists.mli index 685af80a7d..4e7eea59c8 100644 --- a/src/phl/ecPhlExists.mli +++ b/src/phl/ecPhlExists.mli @@ -10,4 +10,4 @@ val t_hr_exists_intro : inv list -> backward (* -------------------------------------------------------------------- *) val process_exists_intro : elim:bool -> pformula list -> backward -val process_ecall : oside -> pqsymbol * ptyannot option * pformula list -> backward +val process_ecall : pdirection -> oside -> pecall -> backward diff --git a/tests/forward-call.ec b/tests/forward-call.ec new file mode 100644 index 0000000000..4c32690ae1 --- /dev/null +++ b/tests/forward-call.ec @@ -0,0 +1,26 @@ +require import AllCore. + +module M = { + proc f(x : int) : int = { + return x + 1; + } + + proc g(x : int, y : int) : int = { + x <@ f(x); + x <- x + 1; + return 2*x; + } +}. + +lemma fP : hoare[M.f : 0 <= x ==> 1 <= res]. +proof. by proc; auto=> /#. qed. + +pred p : int. + +lemma gP (y_ : int) : + hoare[M.g : 0 < x /\ y = y_ /\ p y ==> 0 < res /\ p y_]. +proof. +proc=> /=. +ecall ->> (fP); first by move=> &hr |> /#. +by auto=> &hr |> /#. +qed. From 098a1cc43577ae3afcf412c547b0b8b5d6ab73f4 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 21 Jan 2026 13:58:01 +0100 Subject: [PATCH 040/145] LSP --- dune-project | 4 + easycrypt.opam | 4 + src/dune | 5 +- src/ec.ml | 6 + src/ecIo.ml | 47 +- src/ecIo.mli | 1 + src/ecLsp.ml | 694 +++++++++++++++++++++ src/ecLsp.mli | 1 + src/ecOptions.ml | 14 + src/ecOptions.mli | 1 + src/ecTerminal.ml | 2 +- vscode/.gitignore | 2 + vscode/README.md | 46 ++ vscode/assets/back.svg | 3 + vscode/assets/easycrypt.svg | 5 + vscode/assets/goals.svg | 4 + vscode/assets/jump.svg | 3 + vscode/assets/refresh.svg | 3 + vscode/assets/step.svg | 3 + vscode/language-configuration.json | 23 + vscode/package-lock.json | 139 +++++ vscode/package.json | 178 ++++++ vscode/package.nls.json | 3 + vscode/src/extension.ts | 696 ++++++++++++++++++++++ vscode/syntaxes/easycrypt.tmLanguage.json | 101 ++++ vscode/tsconfig.json | 13 + 26 files changed, 1993 insertions(+), 8 deletions(-) create mode 100644 src/ecLsp.ml create mode 100644 src/ecLsp.mli create mode 100644 vscode/.gitignore create mode 100644 vscode/README.md create mode 100644 vscode/assets/back.svg create mode 100644 vscode/assets/easycrypt.svg create mode 100644 vscode/assets/goals.svg create mode 100644 vscode/assets/jump.svg create mode 100644 vscode/assets/refresh.svg create mode 100644 vscode/assets/step.svg create mode 100644 vscode/language-configuration.json create mode 100644 vscode/package-lock.json create mode 100644 vscode/package.json create mode 100644 vscode/package.nls.json create mode 100644 vscode/src/extension.ts create mode 100644 vscode/syntaxes/easycrypt.tmLanguage.json create mode 100644 vscode/tsconfig.json diff --git a/dune-project b/dune-project index 85f142616e..435605d30e 100644 --- a/dune-project +++ b/dune-project @@ -19,6 +19,10 @@ dune dune-build-info dune-site + fmt + logs + lsp + lwt markdown (pcre2 (>= 8)) (why3 (and (>= 1.8.0) (< 1.9))) diff --git a/easycrypt.opam b/easycrypt.opam index 08bdb40eac..92b556b975 100644 --- a/easycrypt.opam +++ b/easycrypt.opam @@ -7,6 +7,10 @@ depends: [ "dune" {>= "3.13"} "dune-build-info" "dune-site" + "fmt" + "logs" + "lsp" + "lwt" "markdown" "pcre2" {>= "8"} "why3" {>= "1.8.0" & < "1.9"} diff --git a/src/dune b/src/dune index 487e9cfcf5..53c3a9b40d 100644 --- a/src/dune +++ b/src/dune @@ -16,7 +16,7 @@ (public_name easycrypt.ecLib) (foreign_stubs (language c) (names eunix)) (modules :standard \ ec) - (libraries batteries camlp-streams dune-build-info dune-site inifiles markdown markdown.html pcre2 tyxml why3 yojson zarith) + (libraries batteries camlp-streams dune-build-info dune-site inifiles logs logs.fmt lsp lwt lwt.unix markdown markdown.html pcre2 tyxml why3 yojson zarith) ) (executable @@ -24,7 +24,8 @@ (name ec) (modules ec) (promote (until-clean)) - (libraries batteries camlp-streams dune-build-info dune-site inifiles pcre2 why3 yojson zarith ecLib)) + (libraries batteries ecLib) +) (ocamllex ecLexer) diff --git a/src/ec.ml b/src/ec.ml index 627d25b81b..6820fcf17f 100644 --- a/src/ec.ml +++ b/src/ec.ml @@ -214,6 +214,9 @@ let main () = (* Execution of eager commands *) begin match options.o_command with + | `Lsp -> + EcLsp.run (); + exit 0 | `Runtest input -> begin let root = match EcRelocate.sourceroot with @@ -535,6 +538,9 @@ let main () = | `Runtest _ -> (* Eagerly executed *) assert false + | `Lsp -> + (* Eagerly executed *) + assert false | `DocGen docopts -> begin let name = docopts.doco_input in diff --git a/src/ecIo.ml b/src/ecIo.ml index 016545d85c..d6fd6f498f 100644 --- a/src/ecIo.ml +++ b/src/ecIo.ml @@ -96,14 +96,15 @@ let from_string data = let finalize (ecreader : ecreader) = Disposable.dispose ecreader +(* -------------------------------------------------------------------- *) +let isfinal_token = function + | EcParser.FINAL _ -> true + | _ -> false + (* -------------------------------------------------------------------- *) let lexer ?(checkpoint : _ I.checkpoint option) (ecreader : ecreader_r) = let lexbuf = ecreader.ecr_lexbuf in - let isfinal = function - | EcParser.FINAL _ -> true - | _ -> false in - if ecreader.ecr_atstart then ecreader.ecr_trim <- ecreader.ecr_lexbuf.Lexing.lex_curr_p.pos_cnum; @@ -134,7 +135,7 @@ let lexer ?(checkpoint : _ I.checkpoint option) (ecreader : ecreader_r) = ecreader.ecr_tokens <- prequeue @ queue; - if isfinal token then + if isfinal_token token then ecreader.ecr_atstart <- true else ecreader.ecr_atstart <- ecreader.ecr_atstart && ( @@ -177,6 +178,42 @@ let parse (ecreader : ecreader) : EcParsetree.prog = in parse (EcParser.Incremental.prog ecreader.ecr_lexbuf.lex_curr_p) +(* -------------------------------------------------------------------- *) +let next_sentence_from (text : string) (start : int) : (string * int * int) option = + let len = String.length text in + if start < 0 || start >= len then + None + else + let sub = String.sub text start (len - start) in + let reader = from_string sub in + let ecr = Disposable.get reader in + + let exception EOF in + + Fun.protect + ~finally:(fun () -> finalize reader) + (fun () -> + try + begin + let exception Done in + + try + while true do + match proj3_1 (lexer ecr) with + | EcParser.FINAL _ -> raise Done + | EcParser.EOF -> raise EOF + | _ -> () + done + with Done -> () + end; + + let p = ecr.ecr_lexbuf.Lexing.lex_curr_p.pos_cnum - 1 in + let s = String.sub sub 0 p in + + Some (s, start, start + p) + with + | EcLexer.LexicalError _ | EOF -> None) + (* -------------------------------------------------------------------- *) let xparse (ecreader : ecreader) : string * EcParsetree.prog = let ecr = Disposable.get ecreader in diff --git a/src/ecIo.mli b/src/ecIo.mli index 42d28ba740..f69a371b66 100644 --- a/src/ecIo.mli +++ b/src/ecIo.mli @@ -13,6 +13,7 @@ val parse : ecreader -> EcParsetree.prog val parseall : ecreader -> EcParsetree.global list val drain : ecreader -> unit val lexbuf : ecreader -> Lexing.lexbuf +val next_sentence_from : string -> int -> (string * int * int) option (* -------------------------------------------------------------------- *) val lex_single_token : string -> EcParser.token option diff --git a/src/ecLsp.ml b/src/ecLsp.ml new file mode 100644 index 0000000000..b34c3b02a6 --- /dev/null +++ b/src/ecLsp.ml @@ -0,0 +1,694 @@ +open Lwt.Syntax + +module Json = Yojson.Safe +module J = Yojson.Safe.Util + +module Lsp_io = + Lsp.Io.Make + (struct + type 'a t = 'a Lwt.t + + let return = Lwt.return + let raise = Lwt.fail + + module O = struct + let ( let+ ) x f = Lwt.map f x + let ( let* ) x f = Lwt.bind x f + end + end) + (struct + type input = Lwt_io.input_channel + type output = Lwt_io.output_channel + + let read_line ic = Lwt_io.read_line_opt ic + + let read_exactly ic len = + let rec loop acc remaining = + if remaining <= 0 then + Lwt.return (Some (Buffer.contents acc)) + else + Lwt.bind (Lwt_io.read ~count:remaining ic) (fun s -> + if s = "" then + Lwt.return None + else ( + Buffer.add_string acc s; + loop acc (remaining - String.length s) + )) + in + loop (Buffer.create len) len + + let write oc chunks = + Lwt.bind (Lwt_list.iter_s (Lwt_io.write oc) chunks) (fun () -> + Lwt_io.flush oc) + end) + +let setup_logging () : unit = + let reporter = + match Sys.getenv_opt "EASYCRYPT_LSP_LOG" with + | None -> Logs_fmt.reporter () + | Some path -> ( + try + let oc = + open_out_gen [ Open_creat; Open_text; Open_append ] 0o644 path + in + Logs_fmt.reporter ~dst:(Format.formatter_of_out_channel oc) () + with e -> + prerr_endline ("[easycrypt-lsp] failed to open log file: " ^ Printexc.to_string e); + Logs_fmt.reporter ()) + in + Logs.set_reporter reporter; + Logs.set_level (Some Logs.Info) + +let log (fmt : ('a, Format.formatter, unit, unit) format4) = + Format.kasprintf (fun msg -> Logs.info (fun m -> m "%s" msg)) fmt + +module Easycrypt_cli = struct + type session = { + proc : Lwt_process.process; + mutable uuid : int; + mutable mode : string; + mutable last_output : string; + root_uuid : int; + } + + type config = { + mutable cli_path : string; + mutable cli_args : string list; + } + + let prompt_re : Pcre2.regexp = + Pcre2.regexp "\\[([0-9]+)\\|([^\\]]+)\\]>" + + let parse_prompt (line : string) : (int * string) option = + try + let subs = Pcre2.exec ~rex:prompt_re line in + let uuid_str = Pcre2.get_substring subs 1 in + let mode = Pcre2.get_substring subs 2 in + Some (int_of_string uuid_str, mode) + with + | Not_found -> None + | Pcre2.Error _ -> None + + let default_cli_path () : string = + if Sys.file_exists "ec.native" then + "./ec.native" + else + "easycrypt" + + let read_until_prompt (sess : session) : string Lwt.t = + let buf = Buffer.create 256 in + let rec loop () = + let* line_opt = Lwt_io.read_line_opt sess.proc#stdout in + match line_opt with + | None -> Lwt.return (Buffer.contents buf) + | Some line -> + log "cli + sess.uuid <- uuid; + sess.mode <- mode; + Lwt.return (Buffer.contents buf) + | None -> + Buffer.add_string buf line; + Buffer.add_char buf '\n'; + loop ()) + in + loop () + + let start_session (cfg : config) : session Lwt.t = + let argv = + let args = "cli" :: "-emacs" :: cfg.cli_args in + Array.of_list (cfg.cli_path :: args) + in + let proc = Lwt_process.open_process (cfg.cli_path, argv) in + let sess = + { proc + ; uuid = 0 + ; mode = "" + ; last_output = "" + ; root_uuid = 0 + } + in + let* _initial_output = read_until_prompt sess in + Lwt.return { sess with root_uuid = sess.uuid } + + let send_command (sess : session) (text : string) : string Lwt.t = + log "cli> %s" (String.trim text); + let write = + if String.ends_with ~suffix:"\n" text then + Lwt_io.write sess.proc#stdin text + else + Lwt_io.write_line sess.proc#stdin text + in + let* () = write in + let* () = Lwt_io.flush sess.proc#stdin in + let* output = read_until_prompt sess in + sess.last_output <- output; + let preview = + if String.length output = 0 then "" + else if String.length output <= 200 then String.escaped output + else String.escaped (String.sub output 0 200) ^ "..." + in + log "cli< (%d bytes) %s" (String.length output) preview; + Lwt.return output + + let send_undo (sess : session) (target_uuid : int) : string Lwt.t = + let cmd = Printf.sprintf "undo %d." target_uuid in + send_command sess cmd + + let stop_session (sess : session) : unit Lwt.t = + let close_chan ch = Lwt.catch (fun () -> Lwt_io.close ch) (fun _ -> Lwt.return_unit) in + let* () = close_chan sess.proc#stdin in + let* () = close_chan sess.proc#stdout in + sess.proc#terminate; + let* _status = sess.proc#status in + Lwt.return_unit + +end + +type doc_state = { + mutable text : BatText.t; + mutable last_offset : int; + mutable history : (int * int) list; + mutable session : Easycrypt_cli.session option; +} + +let doc_states : (string, doc_state) Hashtbl.t = Hashtbl.create 16 + +let get_doc_state (uri : string) : doc_state = + match Hashtbl.find_opt doc_states uri with + | Some state -> state + | None -> + let created = { text = BatText.empty; last_offset = 0; history = []; session = None } in + Hashtbl.add doc_states uri created; + created + +let error_tag_re : Pcre2.regexp = + Pcre2.regexp "\\[error-\\d+-\\d+\\]" + +let output_has_error (output : string) : bool = + Pcre2.pmatch ~rex:error_tag_re output + +let find_next_sentence + (text : BatText.t) + (start : int) : (string * int * int) option = + EcIo.next_sentence_from (BatText.to_string text) start + +let position_to_offset (text : BatText.t) (pos : Lsp.Types.Position.t) : int = + let len = BatText.length text in + let target_line = pos.Lsp.Types.Position.line in + let target_col = pos.Lsp.Types.Position.character in + let newline = BatUChar.of_char '\n' in + let rec find_line_start line current = + if line <= 0 then + current + else + try + let idx = BatText.index_from text current newline in + find_line_start (line - 1) (min (idx + 1) len) + with + | Not_found -> len + | BatText.Out_of_bounds -> len + in + let line_start = find_line_start target_line 0 in + if line_start >= len then + len + else + let offset = line_start + target_col in + if offset > len then len else offset + +let apply_change + (text : BatText.t) + (change : Lsp.Types.TextDocumentContentChangeEvent.t) : BatText.t * int = + match change.Lsp.Types.TextDocumentContentChangeEvent.range with + | None -> + BatText.of_string change.Lsp.Types.TextDocumentContentChangeEvent.text, 0 + | Some range -> + let start_offset = position_to_offset text range.Lsp.Types.Range.start in + let end_offset = position_to_offset text range.Lsp.Types.Range.end_ in + let len = BatText.length text in + let start_offset = max 0 (min start_offset len) in + let end_offset = max start_offset (min end_offset len) in + let removed = BatText.remove start_offset (end_offset - start_offset) text in + let inserted = BatText.of_string change.Lsp.Types.TextDocumentContentChangeEvent.text in + (BatText.insert start_offset inserted removed, start_offset) + +let json_of_proof_response + ~(sess : Easycrypt_cli.session) + ~(doc : doc_state) + ?sentence + (output : string) : Json.t = + let sentence_start, sentence_end = + match sentence with + | None -> (`Null, `Null) + | Some (start, end_) -> (`Int start, `Int end_) + in + `Assoc + [ ("output", `String output) + ; ("uuid", `Int sess.uuid) + ; ("mode", `String sess.mode) + ; ("processedEnd", `Int doc.last_offset) + ; ("sentenceStart", sentence_start) + ; ("sentenceEnd", sentence_end) + ] + +type proof_command_kind = + | Proof_next + | Proof_step + | Proof_jump_to of int + | Proof_back + | Proof_restart + | Proof_goals + +type proof_command = + { uri : string + ; cmd : proof_command_kind + } + +let proof_command_of_request (meth : string) (params : Json.t option) : + (proof_command, string) result = + let get_uri json = + match J.member "uri" json with + | `String uri -> uri + | _ -> "" + in + match meth, params with + | "easycrypt/proof/next", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_next } + | "easycrypt/proof/step", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_step } + | "easycrypt/proof/jumpTo", Some (`Assoc _ as json) -> + let uri = get_uri json in + let target = + try J.member "target" json |> J.to_int with _ -> -1 + in + if uri = "" || target < 0 then + Error "missing uri or target" + else + Ok { uri; cmd = Proof_jump_to target } + | "easycrypt/proof/back", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_back } + | "easycrypt/proof/restart", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_restart } + | "easycrypt/proof/goals", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_goals } + | _ -> Error "Method not found" + +let rewind_to_offset + (doc : doc_state) + (sess : Easycrypt_cli.session) + (target : int) : string option Lwt.t = + if target >= doc.last_offset then + Lwt.return_none + else + let rec last_before acc = function + | [] -> acc + | (offset, uuid) :: rest -> + let acc = if offset <= target then Some (offset, uuid) else acc in + last_before acc rest + in + let target_entry = last_before None doc.history in + let target_uuid, new_offset = + match target_entry with + | None -> sess.root_uuid, 0 + | Some (offset, uuid) -> uuid, offset + in + doc.history <- List.filter (fun (offset, _) -> offset <= new_offset) doc.history; + doc.last_offset <- new_offset; + let* output = Easycrypt_cli.send_undo sess target_uuid in + Lwt.return (Some output) + +let send_packet (oc : Lwt_io.output_channel) (packet : Jsonrpc.Packet.t) : unit Lwt.t = + Lsp_io.write oc packet + +let send_response (oc : Lwt_io.output_channel) (id : Jsonrpc.Id.t) (result : Jsonrpc.Json.t) : + unit Lwt.t = + let response = Jsonrpc.Response.ok id result in + send_packet oc (Jsonrpc.Packet.Response response) + +let send_typed_response + (oc : Lwt_io.output_channel) + (id : Jsonrpc.Id.t) + (req : 'a Lsp.Client_request.t) + (result : 'a) : unit Lwt.t = + let payload = Lsp.Client_request.yojson_of_result req result in + send_response oc id payload + +let send_error + (oc : Lwt_io.output_channel) + (id : Jsonrpc.Id.t) + (code : Jsonrpc.Response.Error.Code.t) + (message : string) : unit Lwt.t = + let error = + Jsonrpc.Response.Error.make + ~code + ~message + () + in + let response = Jsonrpc.Response.error id error in + send_packet oc (Jsonrpc.Packet.Response response) + +let send_notification (oc : Lwt_io.output_channel) (method_ : string) (params : Jsonrpc.Json.t) : + unit Lwt.t = + let params_struct = Jsonrpc.Structured.t_of_yojson params in + let notif = Jsonrpc.Notification.create ~params:params_struct ~method_ () in + send_packet oc (Jsonrpc.Packet.Notification notif) + +let run () : unit = + Sys.set_signal Sys.sigpipe Sys.Signal_ignore; + setup_logging (); + log "argv=%s" (String.concat " " (Array.to_list Sys.argv)); + log "server start"; + let run_lwt () : unit Lwt.t = + let argv = Array.to_list Sys.argv in + let cli_path = + match argv with + | prog :: _ -> prog + | [] -> Easycrypt_cli.default_cli_path () + in + let cfg : Easycrypt_cli.config = { cli_path; cli_args = [] } in + let ic = Lwt_io.of_fd ~mode:Lwt_io.input Lwt_unix.stdin in + let oc = Lwt_io.of_fd ~mode:Lwt_io.output Lwt_unix.stdout in + let shutdown = ref false in + let pending : (Jsonrpc.Id.t * proof_command) Queue.t = Queue.create () in + let current : unit Lwt.t option ref = ref None in + + let get_session_for_doc (doc : doc_state) : Easycrypt_cli.session Lwt.t = + match doc.session with + | Some sess -> Lwt.return sess + | None -> + let* sess = Easycrypt_cli.start_session cfg in + doc.session <- Some sess; + Lwt.return sess + in + + let handle_initialize id (params : Lsp.Types.InitializeParams.t) : unit Lwt.t = + log "initialize"; + let capabilities = + Lsp.Types.ServerCapabilities.create + ~textDocumentSync:(`TextDocumentSyncKind Lsp.Types.TextDocumentSyncKind.Incremental) + () + in + let result = Lsp.Types.InitializeResult.create ~capabilities () in + send_typed_response oc id (Lsp.Client_request.Initialize params) result + in + + let handle_proof_next id uri : unit Lwt.t = + log "proof next"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + match find_next_sentence doc.text doc.last_offset with + | None -> + send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) + | Some (_text, start, end_) -> + send_response oc id (json_of_proof_response ~sess ~doc ~sentence:(start, end_) sess.last_output) + in + + let handle_proof_exec id uri : unit Lwt.t = + log "proof exec"; + let doc = get_doc_state uri in + match find_next_sentence doc.text doc.last_offset with + | None -> + let* sess = get_session_for_doc doc in + send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) + | Some (text, start, end_) -> + let previous_offset = doc.last_offset in + let rec run ~retry = + let* sess = get_session_for_doc doc in + Lwt.catch + (fun () -> + let* output = Easycrypt_cli.send_command sess text in + Lwt.return (sess, output)) + (function + | Sys_error msg + when retry && String.lowercase_ascii msg = "broken pipe" -> + log "cli broken pipe; restarting session"; + doc.session <- None; + run ~retry:false + | e -> Lwt.fail e) + in + Lwt.catch + (fun () -> + let* sess, output = run ~retry:true in + if output_has_error output then ( + doc.last_offset <- previous_offset; + send_response oc id + (json_of_proof_response ~sess ~doc ~sentence:(start, end_) output)) + else ( + doc.last_offset <- end_; + doc.history <- doc.history @ [ (doc.last_offset, sess.uuid) ]; + send_response oc id + (json_of_proof_response ~sess ~doc ~sentence:(start, end_) output))) + (fun e -> + log "proof exec error: %s" (Printexc.to_string e); + send_error oc id Jsonrpc.Response.Error.Code.InternalError "proof exec failed") + in + + let handle_proof_jump id uri target : unit Lwt.t = + log "proof jump"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + let text_len = BatText.length doc.text in + let target = max 0 (min target text_len) in + let respond ?sentence output = + send_response oc id (json_of_proof_response ~sess ~doc ?sentence output) + in + if target < doc.last_offset then ( + let rec last_before acc = function + | [] -> acc + | (offset, uuid) :: rest -> + let acc = if offset <= target then Some (offset, uuid) else acc in + last_before acc rest + in + let target_entry = last_before None doc.history in + let target_uuid, new_offset = + match target_entry with + | None -> sess.root_uuid, 0 + | Some (offset, uuid) -> uuid, offset + in + doc.history <- List.filter (fun (offset, _) -> offset <= new_offset) doc.history; + doc.last_offset <- new_offset; + let* output = Easycrypt_cli.send_undo sess target_uuid in + respond output) + else if target = doc.last_offset then + respond sess.last_output + else ( + let rec loop last_output = + if doc.last_offset >= target then + respond last_output + else + match find_next_sentence doc.text doc.last_offset with + | None -> respond last_output + | Some (text, start, end_) -> + if end_ > target then + respond last_output + else + let previous_offset = doc.last_offset in + let* output = Easycrypt_cli.send_command sess text in + if output_has_error output then ( + doc.last_offset <- previous_offset; + respond ~sentence:(start, end_) output) + else ( + doc.last_offset <- end_; + doc.history <- doc.history @ [ (doc.last_offset, sess.uuid) ]; + loop output) + in + loop sess.last_output) + in + + let handle_proof_back id uri : unit Lwt.t = + log "proof back"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + match List.rev doc.history with + | [] -> + send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) + | _last :: rest_rev -> + let target_uuid, new_offset = + match rest_rev with + | [] -> sess.root_uuid, 0 + | (offset, uuid) :: _ -> uuid, offset + in + let* output = Easycrypt_cli.send_undo sess target_uuid in + doc.history <- List.rev rest_rev; + doc.last_offset <- new_offset; + send_response oc id (json_of_proof_response ~sess ~doc output) + in + + let handle_proof_restart id uri : unit Lwt.t = + log "proof restart"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + let* output = Easycrypt_cli.send_undo sess sess.root_uuid in + doc.history <- []; + doc.last_offset <- 0; + send_response oc id (json_of_proof_response ~sess ~doc output) + in + + let handle_proof_goals id uri : unit Lwt.t = + log "proof goals"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) + in + + let execute_proof_command (id : Jsonrpc.Id.t) (cmd : proof_command) : unit Lwt.t = + match cmd.cmd with + | Proof_next -> handle_proof_next id cmd.uri + | Proof_step -> handle_proof_exec id cmd.uri + | Proof_jump_to target -> handle_proof_jump id cmd.uri target + | Proof_back -> handle_proof_back id cmd.uri + | Proof_restart -> handle_proof_restart id cmd.uri + | Proof_goals -> handle_proof_goals id cmd.uri + in + + let start_proof (id : Jsonrpc.Id.t) (cmd : proof_command) : unit Lwt.t = + Lwt.catch + (fun () -> execute_proof_command id cmd) + (fun e -> + log "proof command error: %s" (Printexc.to_string e); + send_error oc id Jsonrpc.Response.Error.Code.InternalError "proof command failed") + in + + let pop_pending () = + if Queue.is_empty pending then None else Some (Queue.take pending) + in + + let handle_request req : unit Lwt.t = + match Lsp.Client_request.of_jsonrpc req with + | Error message -> + send_error oc req.id Jsonrpc.Response.Error.Code.InvalidParams message + | Ok (Lsp.Client_request.E r) -> ( + match r with + | Lsp.Client_request.Initialize params -> + handle_initialize req.id params + | Lsp.Client_request.Shutdown -> + shutdown := true; + send_typed_response oc req.id r () + | Lsp.Client_request.UnknownRequest { meth; params } -> ( + let params = Option.map Jsonrpc.Structured.yojson_of_t params in + match proof_command_of_request meth params with + | Ok cmd -> + (match !current with + | None -> + let task = start_proof req.id cmd in + current := Some task; + Lwt.return_unit + | Some _ -> + Queue.push (req.id, cmd) pending; + Lwt.return_unit) + | Error "Method not found" -> + send_error oc req.id Jsonrpc.Response.Error.Code.MethodNotFound "Method not found" + | Error message -> + send_error oc req.id Jsonrpc.Response.Error.Code.InvalidParams message) + | _ -> + send_error oc req.id Jsonrpc.Response.Error.Code.MethodNotFound "Method not found") + in + + let handle_notification_packet notif : unit Lwt.t = + match Lsp.Client_notification.of_jsonrpc notif with + | Error _ -> Lwt.return_unit + | Ok notification -> ( + match notification with + | Lsp.Client_notification.Initialized -> Lwt.return_unit + | Lsp.Client_notification.Exit -> shutdown := true; Lwt.return_unit + | Lsp.Client_notification.TextDocumentDidOpen params -> + let uri = + Lsp.Types.DocumentUri.to_string + params.Lsp.Types.DidOpenTextDocumentParams.textDocument.uri + in + let doc = get_doc_state uri in + doc.text <- BatText.of_string params.Lsp.Types.DidOpenTextDocumentParams.textDocument.text; + doc.last_offset <- 0; + doc.history <- []; + doc.session <- None; + Lwt.return_unit + | Lsp.Client_notification.TextDocumentDidChange params -> + let uri = + Lsp.Types.DocumentUri.to_string + params.Lsp.Types.DidChangeTextDocumentParams.textDocument.uri + in + let doc = get_doc_state uri in + let earliest = ref max_int in + let updated = ref doc.text in + List.iter + (fun change -> + let text, start_offset = apply_change !updated change in + updated := text; + if start_offset < !earliest then earliest := start_offset) + params.Lsp.Types.DidChangeTextDocumentParams.contentChanges; + doc.text <- !updated; + if !earliest < doc.last_offset then + let* sess = get_session_for_doc doc in + let* _ = rewind_to_offset doc sess !earliest in + Lwt.return_unit + else + Lwt.return_unit + | Lsp.Client_notification.TextDocumentDidClose params -> + let uri = + Lsp.Types.DocumentUri.to_string + params.Lsp.Types.DidCloseTextDocumentParams.textDocument.uri + in + let* () = + match Hashtbl.find_opt doc_states uri with + | Some doc -> ( + match doc.session with + | Some sess -> Easycrypt_cli.stop_session sess + | None -> Lwt.return_unit) + | None -> Lwt.return_unit + in + Hashtbl.remove doc_states uri; + Lwt.return_unit + | _ -> Lwt.return_unit) + in + + let rec loop () : unit Lwt.t = + if !shutdown then + Lwt.return_unit + else + let read_p = Lsp_io.read ic |> Lwt.map (fun p -> `Packet p) in + let waiters = + match !current with + | None -> [ read_p ] + | Some cmd_p -> [ read_p; (cmd_p |> Lwt.map (fun () -> `Cmd_done)) ] + in + let* ev = Lwt.pick waiters in + match ev with + | `Cmd_done -> + current := None; + (match pop_pending () with + | None -> () + | Some (id, cmd) -> current := Some (start_proof id cmd)); + loop () + | `Packet None -> + log "stdin closed"; + shutdown := true; + Lwt.return_unit + | `Packet (Some packet) -> + let* () = + match packet with + | Jsonrpc.Packet.Request req -> + log "recv request %s" req.Jsonrpc.Request.method_; + handle_request req + | Jsonrpc.Packet.Notification notif -> + log "recv notification %s" notif.Jsonrpc.Notification.method_; + handle_notification_packet notif + | Jsonrpc.Packet.Batch_call calls -> + Lwt_list.iter_s + (function + | `Request req -> handle_request req + | `Notification notif -> handle_notification_packet notif) + calls + | Jsonrpc.Packet.Response _ -> Lwt.return_unit + | Jsonrpc.Packet.Batch_response _ -> Lwt.return_unit + in + loop () + in + loop () + in + Lwt_main.run (run_lwt ()) diff --git a/src/ecLsp.mli b/src/ecLsp.mli new file mode 100644 index 0000000000..733b2a3231 --- /dev/null +++ b/src/ecLsp.mli @@ -0,0 +1 @@ +val run : unit -> unit diff --git a/src/ecOptions.ml b/src/ecOptions.ml index f012e8e8d6..c9b54139f9 100644 --- a/src/ecOptions.ml +++ b/src/ecOptions.ml @@ -6,10 +6,12 @@ open EcMaps type command = [ | `Compile of cmp_option | `Cli of cli_option + | `Lsp | `Config | `Runtest of run_option | `Why3Config | `DocGen of doc_option + | `Lsp ] and options = { @@ -356,6 +358,9 @@ let specs = { `Group "provers"; `Spec ("emacs", `Flag, "Output format set to ")]); + ("lsp", "Run EasyCrypt LSP server", [ + `Spec ("-stdio" , `Flag , "")]); + ("config", "Print EasyCrypt configuration", []); ("runtest", "Run a test-suite", [ @@ -604,6 +609,15 @@ let parse getini argv = raise (Arg.Bad "this command takes a single input file as argument") end + | "lsp" -> + if not (List.is_empty anons) then + raise (Arg.Bad "this command does not take arguments"); + + let ini = getini None in + let cmd = `Lsp in + + (cmd, ini, true) + | _ -> assert false in { diff --git a/src/ecOptions.mli b/src/ecOptions.mli index 59009718ad..c6aaa4d145 100644 --- a/src/ecOptions.mli +++ b/src/ecOptions.mli @@ -2,6 +2,7 @@ type command = [ | `Compile of cmp_option | `Cli of cli_option + | `Lsp | `Config | `Runtest of run_option | `Why3Config diff --git a/src/ecTerminal.ml b/src/ecTerminal.ml index 94f7c048e5..f680719f1e 100644 --- a/src/ecTerminal.ml +++ b/src/ecTerminal.ml @@ -90,7 +90,7 @@ object(self) | EcScope.TopError (loc, e) -> (loc, e) | _ -> (LC._dummy, e) in - Format.fprintf Format.err_formatter + Format.fprintf Format.std_formatter "[error-%d-%d]%s\n%!" (max 0 (loc.LC.loc_bchar - startpos)) (max 0 (loc.LC.loc_echar - startpos)) diff --git a/vscode/.gitignore b/vscode/.gitignore new file mode 100644 index 0000000000..82abfab5cc --- /dev/null +++ b/vscode/.gitignore @@ -0,0 +1,2 @@ +/node_modules/ +/out/ diff --git a/vscode/README.md b/vscode/README.md new file mode 100644 index 0000000000..0c3ac44c83 --- /dev/null +++ b/vscode/README.md @@ -0,0 +1,46 @@ +# EasyCrypt VSCode Extension (local) + +This folder contains a local VSCode extension for EasyCrypt. + +## Build the EasyCrypt binary (with LSP) + +From the repository root: + +``` +$ dune build src/ec.exe +``` + +The binary will be at `_build/default/src/ec.exe` and provides `easycrypt lsp`. + +## Build the extension + +From this `vscode/` folder: + +``` +$ npm install +$ npm run compile +``` + +Then use "Developer: Install Extension from Location..." and select this folder. + +## Configuration + +- `easycrypt.cli.path`: path to the EasyCrypt CLI (e.g. `ec.native` or `easycrypt`). + +## TextMate colors + +This extension uses TextMate scopes for syntax highlighting. To customize colors without changing a theme, add rules to your VSCode settings: + +```jsonc +"editor.tokenColorCustomizations": { + "textMateRules": [ + { "scope": "keyword.other.easycrypt.bytac", "settings": { "foreground": "#6C71C4" } }, + { "scope": "keyword.other.easycrypt.dangerous", "settings": { "foreground": "#DC322F", "fontStyle": "bold" } }, + { "scope": "keyword.control.easycrypt.global", "settings": { "foreground": "#268BD2" } }, + { "scope": "keyword.other.easycrypt.internal", "settings": { "foreground": "#B58900" } }, + { "scope": "keyword.operator.easycrypt.prog", "settings": { "foreground": "#2AA198" } }, + { "scope": "keyword.control.easycrypt.tactic", "settings": { "foreground": "#859900" } }, + { "scope": "keyword.control.easycrypt.tactical", "settings": { "foreground": "#CB4B16" } } + ] +} +``` diff --git a/vscode/assets/back.svg b/vscode/assets/back.svg new file mode 100644 index 0000000000..63fa276430 --- /dev/null +++ b/vscode/assets/back.svg @@ -0,0 +1,3 @@ + + + diff --git a/vscode/assets/easycrypt.svg b/vscode/assets/easycrypt.svg new file mode 100644 index 0000000000..f18030d31a --- /dev/null +++ b/vscode/assets/easycrypt.svg @@ -0,0 +1,5 @@ + + + + + diff --git a/vscode/assets/goals.svg b/vscode/assets/goals.svg new file mode 100644 index 0000000000..fe6bd5048c --- /dev/null +++ b/vscode/assets/goals.svg @@ -0,0 +1,4 @@ + + + + diff --git a/vscode/assets/jump.svg b/vscode/assets/jump.svg new file mode 100644 index 0000000000..daeb25d592 --- /dev/null +++ b/vscode/assets/jump.svg @@ -0,0 +1,3 @@ + + + diff --git a/vscode/assets/refresh.svg b/vscode/assets/refresh.svg new file mode 100644 index 0000000000..d124bdd5c7 --- /dev/null +++ b/vscode/assets/refresh.svg @@ -0,0 +1,3 @@ + + + diff --git a/vscode/assets/step.svg b/vscode/assets/step.svg new file mode 100644 index 0000000000..dd77f646a7 --- /dev/null +++ b/vscode/assets/step.svg @@ -0,0 +1,3 @@ + + + diff --git a/vscode/language-configuration.json b/vscode/language-configuration.json new file mode 100644 index 0000000000..163424eeb9 --- /dev/null +++ b/vscode/language-configuration.json @@ -0,0 +1,23 @@ +{ + "comments": { + "lineComment": "//", + "blockComment": ["(*", "*)"] + }, + "brackets": [ + ["{", "}"], + ["[", "]"], + ["(", ")"] + ], + "autoClosingPairs": [ + {"open": "{", "close": "}"}, + {"open": "[", "close": "]"}, + {"open": "(", "close": ")"}, + {"open": "\"", "close": "\""} + ], + "surroundingPairs": [ + ["{", "}"], + ["[", "]"], + ["(", ")"], + ["\"", "\""] + ] +} diff --git a/vscode/package-lock.json b/vscode/package-lock.json new file mode 100644 index 0000000000..7070c58627 --- /dev/null +++ b/vscode/package-lock.json @@ -0,0 +1,139 @@ +{ + "name": "easycrypt-vscode", + "version": "0.0.1", + "lockfileVersion": 3, + "requires": true, + "packages": { + "": { + "name": "easycrypt-vscode", + "version": "0.0.1", + "dependencies": { + "vscode-languageclient": "^9.0.1" + }, + "devDependencies": { + "@types/node": "^20.11.0", + "@types/vscode": "^1.85.0", + "typescript": "^5.3.3" + }, + "engines": { + "vscode": "^1.85.0" + } + }, + "node_modules/@types/node": { + "version": "20.19.30", + "resolved": "https://registry.npmjs.org/@types/node/-/node-20.19.30.tgz", + "integrity": "sha512-WJtwWJu7UdlvzEAUm484QNg5eAoq5QR08KDNx7g45Usrs2NtOPiX8ugDqmKdXkyL03rBqU5dYNYVQetEpBHq2g==", + "dev": true, + "license": "MIT", + "dependencies": { + "undici-types": "~6.21.0" + } + }, + "node_modules/@types/vscode": { + "version": "1.108.1", + "resolved": "https://registry.npmjs.org/@types/vscode/-/vscode-1.108.1.tgz", + "integrity": "sha512-DerV0BbSzt87TbrqmZ7lRDIYaMiqvP8tmJTzW2p49ZBVtGUnGAu2RGQd1Wv4XMzEVUpaHbsemVM5nfuQJj7H6w==", + "dev": true, + "license": "MIT" + }, + "node_modules/balanced-match": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/balanced-match/-/balanced-match-1.0.2.tgz", + "integrity": "sha512-3oSeUO0TMV67hN1AmbXsK4yaqU7tjiHlbxRDZOpH0KW9+CeX4bRAaX0Anxt0tx2MrpRpWwQaPwIlISEJhYU5Pw==", + "license": "MIT" + }, + "node_modules/brace-expansion": { + "version": "2.0.2", + "resolved": "https://registry.npmjs.org/brace-expansion/-/brace-expansion-2.0.2.tgz", + "integrity": "sha512-Jt0vHyM+jmUBqojB7E1NIYadt0vI0Qxjxd2TErW94wDz+E2LAm5vKMXXwg6ZZBTHPuUlDgQHKXvjGBdfcF1ZDQ==", + "license": "MIT", + "dependencies": { + "balanced-match": "^1.0.0" + } + }, + "node_modules/minimatch": { + "version": "5.1.6", + "resolved": "https://registry.npmjs.org/minimatch/-/minimatch-5.1.6.tgz", + "integrity": "sha512-lKwV/1brpG6mBUFHtb7NUmtABCb2WZZmm2wNiOA5hAb8VdCS4B3dtMWyvcoViccwAW/COERjXLt0zP1zXUN26g==", + "license": "ISC", + "dependencies": { + "brace-expansion": "^2.0.1" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/semver": { + "version": "7.7.3", + "resolved": "https://registry.npmjs.org/semver/-/semver-7.7.3.tgz", + "integrity": "sha512-SdsKMrI9TdgjdweUSR9MweHA4EJ8YxHn8DFaDisvhVlUOe4BF1tLD7GAj0lIqWVl+dPb/rExr0Btby5loQm20Q==", + "license": "ISC", + "bin": { + "semver": "bin/semver.js" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/typescript": { + "version": "5.9.3", + "resolved": "https://registry.npmjs.org/typescript/-/typescript-5.9.3.tgz", + "integrity": "sha512-jl1vZzPDinLr9eUt3J/t7V6FgNEw9QjvBPdysz9KfQDD41fQrC2Y4vKQdiaUpFT4bXlb1RHhLpp8wtm6M5TgSw==", + "dev": true, + "license": "Apache-2.0", + "bin": { + "tsc": "bin/tsc", + "tsserver": "bin/tsserver" + }, + "engines": { + "node": ">=14.17" + } + }, + "node_modules/undici-types": { + "version": "6.21.0", + "resolved": "https://registry.npmjs.org/undici-types/-/undici-types-6.21.0.tgz", + "integrity": "sha512-iwDZqg0QAGrg9Rav5H4n0M64c3mkR59cJ6wQp+7C4nI0gsmExaedaYLNO44eT4AtBBwjbTiGPMlt2Md0T9H9JQ==", + "dev": true, + "license": "MIT" + }, + "node_modules/vscode-jsonrpc": { + "version": "8.2.0", + "resolved": "https://registry.npmjs.org/vscode-jsonrpc/-/vscode-jsonrpc-8.2.0.tgz", + "integrity": "sha512-C+r0eKJUIfiDIfwJhria30+TYWPtuHJXHtI7J0YlOmKAo7ogxP20T0zxB7HZQIFhIyvoBPwWskjxrvAtfjyZfA==", + "license": "MIT", + "engines": { + "node": ">=14.0.0" + } + }, + "node_modules/vscode-languageclient": { + "version": "9.0.1", + "resolved": "https://registry.npmjs.org/vscode-languageclient/-/vscode-languageclient-9.0.1.tgz", + "integrity": "sha512-JZiimVdvimEuHh5olxhxkht09m3JzUGwggb5eRUkzzJhZ2KjCN0nh55VfiED9oez9DyF8/fz1g1iBV3h+0Z2EA==", + "license": "MIT", + "dependencies": { + "minimatch": "^5.1.0", + "semver": "^7.3.7", + "vscode-languageserver-protocol": "3.17.5" + }, + "engines": { + "vscode": "^1.82.0" + } + }, + "node_modules/vscode-languageserver-protocol": { + "version": "3.17.5", + "resolved": "https://registry.npmjs.org/vscode-languageserver-protocol/-/vscode-languageserver-protocol-3.17.5.tgz", + "integrity": "sha512-mb1bvRJN8SVznADSGWM9u/b07H7Ecg0I3OgXDuLdn307rl/J3A9YD6/eYOssqhecL27hK1IPZAsaqh00i/Jljg==", + "license": "MIT", + "dependencies": { + "vscode-jsonrpc": "8.2.0", + "vscode-languageserver-types": "3.17.5" + } + }, + "node_modules/vscode-languageserver-types": { + "version": "3.17.5", + "resolved": "https://registry.npmjs.org/vscode-languageserver-types/-/vscode-languageserver-types-3.17.5.tgz", + "integrity": "sha512-Ld1VelNuX9pdF39h2Hgaeb5hEZM2Z3jUrrMgWQAu82jMtZp7p3vJT3BzToKtZI7NgQssZje5o0zryOrhQvzQAg==", + "license": "MIT" + } + } +} diff --git a/vscode/package.json b/vscode/package.json new file mode 100644 index 0000000000..4c1031c20a --- /dev/null +++ b/vscode/package.json @@ -0,0 +1,178 @@ +{ + "name": "easycrypt-vscode", + "displayName": "EasyCrypt", + "publisher": "easycrypt", + "version": "0.0.1", + "engines": { + "vscode": "^1.85.0" + }, + "categories": ["Programming Languages"], + "activationEvents": [ + "onLanguage:easycrypt", + "onCommand:easycrypt.proof.step", + "onCommand:easycrypt.proof.back", + "onCommand:easycrypt.proof.restart", + "onCommand:easycrypt.proof.jumpToCursor", + "onCommand:easycrypt.proof.goals", + "onCommand:easycrypt.lsp.restart" + ], + "main": "./out/extension.js", + "contributes": { + "languages": [ + { + "id": "easycrypt", + "aliases": ["EasyCrypt", "easycrypt"], + "extensions": [".ec"], + "configuration": "./language-configuration.json" + } + ], + "grammars": [ + { + "language": "easycrypt", + "scopeName": "source.easycrypt", + "path": "./syntaxes/easycrypt.tmLanguage.json" + } + ], + "commands": [ + { + "command": "easycrypt.proof.step", + "title": "Step", + "icon": { "light": "assets/step.svg", "dark": "assets/step.svg" } + }, + { + "command": "easycrypt.proof.back", + "title": "Back", + "icon": { "light": "assets/back.svg", "dark": "assets/back.svg" } + }, + { + "command": "easycrypt.proof.restart", + "title": "Restart", + "icon": { "light": "assets/refresh.svg", "dark": "assets/refresh.svg" } + }, + { + "command": "easycrypt.proof.jumpToCursor", + "title": "Jump To Cursor", + "icon": { "light": "assets/jump.svg", "dark": "assets/jump.svg" } + }, + { + "command": "easycrypt.proof.goals", + "title": "Show Goals", + "icon": { "light": "assets/goals.svg", "dark": "assets/goals.svg" } + }, + { + "command": "easycrypt.lsp.restart", + "title": "Restart LSP" + } + ], + "menus": { + "editor/title": [ + { + "command": "easycrypt.proof.step", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", + "group": "navigation.easycrypt@3" + }, + { + "command": "easycrypt.proof.step", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", + "group": "inline.easycrypt@3" + }, + { + "command": "easycrypt.proof.back", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", + "group": "navigation.easycrypt@1" + }, + { + "command": "easycrypt.proof.back", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", + "group": "inline.easycrypt@1" + }, + { + "command": "easycrypt.proof.jumpToCursor", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", + "group": "navigation.easycrypt@2" + }, + { + "command": "easycrypt.proof.jumpToCursor", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", + "group": "inline.easycrypt@2" + }, + { + "command": "easycrypt.proof.goals", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", + "group": "navigation.easycrypt@4" + }, + { + "command": "easycrypt.proof.goals", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", + "group": "inline.easycrypt@4" + } + ] + }, + "keybindings": [ + { + "command": "easycrypt.proof.step", + "key": "ctrl+alt+down", + "mac": "cmd+alt+down", + "when": "editorLangId == easycrypt" + }, + { + "command": "easycrypt.proof.back", + "key": "ctrl+alt+up", + "mac": "cmd+alt+up", + "when": "editorLangId == easycrypt" + }, + { + "command": "easycrypt.proof.jumpToCursor", + "key": "ctrl+alt+enter", + "mac": "cmd+alt+enter", + "when": "editorLangId == easycrypt" + }, + { + "command": "easycrypt.proof.goals", + "key": "ctrl+alt+g", + "mac": "cmd+alt+g", + "when": "editorLangId == easycrypt" + } + ], + "configuration": { + "title": "EasyCrypt", + "properties": { + "easycrypt.cli.path": { + "type": "string", + "default": "", + "description": "Path to the EasyCrypt CLI (easycrypt or ec.native)." + }, + "easycrypt.cli.args": { + "type": "array", + "items": { "type": "string" }, + "default": [], + "description": "Extra arguments passed to the EasyCrypt CLI when running in proof mode." + }, + "easycrypt.trace.server": { + "type": "string", + "enum": ["off", "messages", "verbose"], + "default": "off", + "description": "Trace LSP communication to the Output panel." + }, + "easycrypt.ui.editorToolbarGroup": { + "type": "string", + "enum": ["navigation", "inline"], + "default": "navigation", + "description": "Editor title toolbar group for EasyCrypt buttons." + } + } + } + }, + "scripts": { + "compile": "tsc -p ./", + "watch": "tsc -w -p ./" + }, + "dependencies": { + "vscode-languageclient": "^9.0.1" + }, + "devDependencies": { + "@types/node": "^20.11.0", + "@types/vscode": "^1.85.0", + "typescript": "^5.3.3" + } +} diff --git a/vscode/package.nls.json b/vscode/package.nls.json new file mode 100644 index 0000000000..2da004d97c --- /dev/null +++ b/vscode/package.nls.json @@ -0,0 +1,3 @@ +{ + "easycrypt.ui.editorToolbarGroup": "Editor title toolbar group for EasyCrypt buttons." +} diff --git a/vscode/src/extension.ts b/vscode/src/extension.ts new file mode 100644 index 0000000000..6c976a03f3 --- /dev/null +++ b/vscode/src/extension.ts @@ -0,0 +1,696 @@ +import * as fs from 'fs'; +import * as path from 'path'; +import * as vscode from 'vscode'; +import { + LanguageClient, + LanguageClientOptions, + ServerOptions, + TransportKind, + Trace +} from 'vscode-languageclient/node'; + +type ProofResponse = { + output: string; + uuid: number; + mode: string; + processedEnd: number; + sentenceStart?: number | null; + sentenceEnd?: number | null; +}; + +type DocState = { + lastOffset: number; +}; + +let client: LanguageClient | undefined; +let clientReady: Promise | undefined; +let clientOptions: LanguageClientOptions | undefined; +let serverOptions: ServerOptions | undefined; +let goalsPanel: vscode.WebviewPanel | undefined; +let outputChannel: vscode.OutputChannel | undefined; +let traceLevel: Trace = Trace.Off; +let lspCommand: string | undefined; +let lspArgs: string[] = []; +let processedDecoration: vscode.TextEditorDecorationType | undefined; +let processingDecoration: vscode.TextEditorDecorationType | undefined; +let errorDecoration: vscode.TextEditorDecorationType | undefined; +let lastEasyCryptEditor: vscode.TextEditor | undefined; +const docStates = new Map(); +let suppressProcessedEdits = false; +let suppressProcessingEdits = false; +let processingDocUri: string | undefined; +let processingSnapshot: string | undefined; +let diagnostics: vscode.DiagnosticCollection | undefined; + +function getDocState(doc: vscode.TextDocument): DocState { + const key = doc.uri.toString(); + const state = docStates.get(key); + if (state) { + return state; + } + const created = { lastOffset: 0 }; + docStates.set(key, created); + return created; +} + +function escapeHtml(value: string): string { + return value + .replace(/&/g, '&') + .replace(//g, '>'); +} + +function showGoals(output: string): void { + if (!goalsPanel) { + goalsPanel = vscode.window.createWebviewPanel( + 'easycryptGoals', + 'EasyCrypt Goals', + { viewColumn: vscode.ViewColumn.Beside, preserveFocus: true }, + { enableFindWidget: true } + ); + goalsPanel.onDidDispose(() => { + goalsPanel = undefined; + }); + } else { + goalsPanel.reveal(goalsPanel.viewColumn, true); + } + + goalsPanel.webview.html = ` + + + + + + + +
${escapeHtml(output)}
+ +`; +} + +function updateProcessedDecoration(editor: vscode.TextEditor | undefined): void { + if (!editor || !processedDecoration) { + return; + } + const state = getDocState(editor.document); + const endOffset = state.lastOffset; + const endPos = editor.document.positionAt(endOffset); + const startPos = new vscode.Position(0, 0); + const anchor = new vscode.Range(startPos, startPos); + const fixed = new vscode.Range(startPos, endPos); + editor.setDecorations(processedDecoration, [anchor, fixed]); +} + +function setProcessingDecoration(editor: vscode.TextEditor | undefined, range: vscode.Range): void { + if (!editor || !processingDecoration) { + return; + } + editor.setDecorations(processingDecoration, [range]); +} + +function clearProcessingDecoration(editor: vscode.TextEditor | undefined): void { + if (!editor || !processingDecoration) { + return; + } + editor.setDecorations(processingDecoration, []); +} + +function setProcessingLock(doc: vscode.TextDocument): void { + processingDocUri = doc.uri.toString(); + processingSnapshot = doc.getText(); +} + +function clearProcessingLock(): void { + processingDocUri = undefined; + processingSnapshot = undefined; +} + +async function restoreProcessingSnapshot(doc: vscode.TextDocument): Promise { + if (!processingSnapshot) { + return; + } + const lastLine = doc.lineAt(doc.lineCount - 1); + const fullRange = new vscode.Range(new vscode.Position(0, 0), lastLine.range.end); + const edit = new vscode.WorkspaceEdit(); + edit.replace(doc.uri, fullRange, processingSnapshot); + await vscode.workspace.applyEdit(edit); +} + +function outputHasError(output: string): boolean { + return /\[error-\d+-\d+\]/.test(output); +} + +function summarizeErrorOutput(output: string): string { + const line = output.split(/\r?\n/).find((entry) => entry.trim().length > 0); + if (!line) { + return 'EasyCrypt reported an error.'; + } + const cleaned = line.replace(/\[error-\d+-\d+\]/g, '').trim(); + return cleaned.length > 0 ? cleaned : 'EasyCrypt reported an error.'; +} + +function showGoalsOrError(output: string): void { + if (output.trim().length > 0) { + showGoals(output); + } else { + showGoals('EasyCrypt reported an error.'); + } +} + +function parseErrorTag(output: string): { start: number; end: number; message: string } | undefined { + const match = output.match(/\[error-(\d+)-(\d+)\]/); + if (!match) { + return undefined; + } + const start = Number(match[1]); + const end = Number(match[2]); + if (!Number.isFinite(start) || !Number.isFinite(end)) { + return undefined; + } + const message = output.replace(match[0], '').trim(); + return { start, end, message: message.length > 0 ? message : 'EasyCrypt reported an error.' }; +} + +function clearErrorDecoration(editor: vscode.TextEditor | undefined): void { + if (!editor || !errorDecoration) { + return; + } + editor.setDecorations(errorDecoration, []); +} + +function clearDiagnostics(doc: vscode.TextDocument): void { + diagnostics?.delete(doc.uri); +} + +function showErrorDecoration( + editor: vscode.TextEditor | undefined, + sentenceOffset: number, + errorStart: number, + errorEnd: number +): void { + if (!editor || !errorDecoration) { + return; + } + const start = editor.document.positionAt(sentenceOffset + errorStart); + const end = editor.document.positionAt(sentenceOffset + Math.max(errorStart + 1, errorEnd)); + editor.setDecorations(errorDecoration, [new vscode.Range(start, end)]); +} + +function handleProofError( + output: string, + editor: vscode.TextEditor | undefined, + sentenceOffset?: number +): void { + const parsed = parseErrorTag(output); + if (parsed && sentenceOffset !== undefined) { + showErrorDecoration(editor, sentenceOffset, parsed.start, parsed.end); + showGoals(parsed.message); + if (editor && diagnostics) { + const doc = editor.document; + const start = doc.positionAt(sentenceOffset + parsed.start); + const end = doc.positionAt(sentenceOffset + Math.max(parsed.start + 1, parsed.end)); + const range = new vscode.Range(start, end); + const diag = new vscode.Diagnostic(range, parsed.message, vscode.DiagnosticSeverity.Error); + diagnostics.set(doc.uri, [diag]); + } + } else { + showGoalsOrError(output.replace(/\[error-\d+-\d+\]/g, '').trim()); + } +} + +function getEditorForCommand(): vscode.TextEditor | undefined { + const active = vscode.window.activeTextEditor; + if (active && active.document.languageId === 'easycrypt') { + return active; + } + return lastEasyCryptEditor; +} + +async function requestProof(method: string, params: Record): Promise { + if (!client) { + throw new Error('EasyCrypt language client is not running.'); + } + if (clientReady) { + await clientReady; + } + const start = Date.now(); + outputChannel?.appendLine(`[proof] request ${method}`); + const timeout = setTimeout(() => { + outputChannel?.appendLine(`[proof] waiting ${method} >3s`); + }, 3000); + try { + const result = await client.sendRequest(method, params); + const elapsed = Date.now() - start; + outputChannel?.appendLine(`[proof] response ${method} ${elapsed}ms`); + return result; + } catch (err) { + const elapsed = Date.now() - start; + outputChannel?.appendLine(`[proof] error ${method} ${elapsed}ms ${String(err)}`); + throw err; + } finally { + clearTimeout(timeout); + } +} + +async function handleStep(): Promise { + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + + const doc = editor.document; + const state = getDocState(doc); + const previousOffset = state.lastOffset; + let sentenceStart: number | null | undefined; + let sentenceEnd: number | null | undefined; + let previewProcessedEnd = state.lastOffset; + try { + const preview = await requestProof('easycrypt/proof/next', { uri: doc.uri.toString() }); + sentenceStart = preview.sentenceStart ?? null; + sentenceEnd = preview.sentenceEnd ?? null; + previewProcessedEnd = preview.processedEnd; + } catch (err) { + outputChannel?.appendLine(`[proof] step preview failed ${String(err)}`); + } + + if (sentenceStart == null || sentenceEnd == null) { + state.lastOffset = previewProcessedEnd; + updateProcessedDecoration(editor); + return; + } + + if (sentenceStart != null && sentenceEnd != null) { + const processingRange = new vscode.Range( + doc.positionAt(sentenceStart), + doc.positionAt(sentenceEnd) + ); + setProcessingDecoration(editor, processingRange); + setProcessingLock(doc); + } + + try { + const result = await requestProof('easycrypt/proof/step', { uri: doc.uri.toString() }); + outputChannel?.appendLine(`[proof] step ok uuid=${result.uuid} mode=${result.mode}`); + state.lastOffset = result.processedEnd; + if (outputHasError(result.output)) { + outputChannel?.appendLine(`[proof] step reported error ${result.output}`); + if (result.sentenceStart != null) { + handleProofError(result.output, editor, result.sentenceStart); + } else { + handleProofError(result.output, editor, previousOffset); + } + } else { + showGoals(result.output); + updateProcessedDecoration(editor); + clearErrorDecoration(editor); + clearDiagnostics(editor.document); + } + } catch (err) { + outputChannel?.appendLine(`[proof] step failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt step failed: ${String(err)}`); + } finally { + clearProcessingDecoration(editor); + clearProcessingLock(); + } +} + +async function handleSendRegion(): Promise { + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + + const doc = editor.document; + const state = getDocState(doc); + const cursorOffset = doc.offsetAt(editor.selection.active); + try { + outputChannel?.appendLine('[proof] jumpToCursor'); + const result = await requestProof('easycrypt/proof/jumpTo', { + uri: doc.uri.toString(), + target: cursorOffset + }); + outputChannel?.appendLine(`[proof] jumpToCursor ok uuid=${result.uuid} mode=${result.mode}`); + state.lastOffset = result.processedEnd; + if (outputHasError(result.output)) { + outputChannel?.appendLine(`[proof] jumpToCursor reported error ${result.output}`); + if (result.sentenceStart != null) { + handleProofError(result.output, editor, result.sentenceStart); + } else { + handleProofError(result.output, editor, state.lastOffset); + } + return; + } + showGoals(result.output); + updateProcessedDecoration(editor); + clearErrorDecoration(editor); + clearDiagnostics(doc); + } catch (err) { + outputChannel?.appendLine(`[proof] jumpToCursor failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt jump-to-cursor failed: ${String(err)}`); + } finally { + clearProcessingDecoration(editor); + clearProcessingLock(); + } +} + +async function handleBack(): Promise { + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + + const state = getDocState(editor.document); + try { + outputChannel?.appendLine('[proof] back'); + const result = await requestProof('easycrypt/proof/back', { + uri: editor.document.uri.toString() + }); + if (outputHasError(result.output)) { + outputChannel?.appendLine(`[proof] back reported error ${result.output}`); + if (result.sentenceStart != null) { + handleProofError(result.output, editor, result.sentenceStart); + } else { + handleProofError(result.output, editor); + } + } else { + state.lastOffset = result.processedEnd; + outputChannel?.appendLine(`[proof] back ok uuid=${result.uuid} mode=${result.mode}`); + showGoals(result.output); + updateProcessedDecoration(editor); + clearErrorDecoration(editor); + clearDiagnostics(editor.document); + } + } catch (err) { + outputChannel?.appendLine(`[proof] back failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt back failed: ${String(err)}`); + } +} + +async function handleRestart(): Promise { + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + const state = editor ? getDocState(editor.document) : undefined; + const previousOffset = state?.lastOffset ?? 0; + + try { + outputChannel?.appendLine('[proof] restart'); + const result = await requestProof('easycrypt/proof/restart', { + uri: editor.document.uri.toString() + }); + outputChannel?.appendLine(`[proof] restart ok uuid=${result.uuid} mode=${result.mode}`); + if (outputHasError(result.output)) { + outputChannel?.appendLine(`[proof] restart reported error ${result.output}`); + handleProofError(result.output, editor); + if (state) { + state.lastOffset = previousOffset; + } + } else { + if (state) { + state.lastOffset = result.processedEnd; + } + showGoals(result.output); + updateProcessedDecoration(editor ?? vscode.window.activeTextEditor); + clearErrorDecoration(editor ?? vscode.window.activeTextEditor); + if (editor) { + clearDiagnostics(editor.document); + } + } + } catch (err) { + outputChannel?.appendLine(`[proof] restart failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt restart failed: ${String(err)}`); + } +} + +async function handleGoals(): Promise { + try { + outputChannel?.appendLine('[proof] goals'); + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + const result = await requestProof('easycrypt/proof/goals', { + uri: editor.document.uri.toString() + }); + outputChannel?.appendLine(`[proof] goals ok uuid=${result.uuid} mode=${result.mode}`); + showGoals(result.output); + } catch (err) { + outputChannel?.appendLine(`[proof] goals failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt goals failed: ${String(err)}`); + } +} + +function resolveServerCommand( + workspaceFolder: string | undefined, + cliPath: string +): string | undefined { + if (cliPath && cliPath.trim().length > 0) { + return cliPath; + } + + if (!workspaceFolder) { + return undefined; + } + + const exeCandidate = path.join(workspaceFolder, '_build', 'default', 'src', 'ec.exe'); + const unixCandidate = path.join(workspaceFolder, '_build', 'default', 'src', 'ec'); + if (fs.existsSync(exeCandidate)) { + return exeCandidate; + } + if (fs.existsSync(unixCandidate)) { + return unixCandidate; + } + + return undefined; +} + +function ensureLspArgs(args: string[]): string[] { + if (args.length > 0 && args[0] === 'lsp') { + return args; + } + return ['lsp', ...args]; +} + +function startClient(): void { + if (!clientOptions || !serverOptions) { + throw new Error('EasyCrypt LSP options are not configured.'); + } + outputChannel?.appendLine(`[lsp] spawn command=${lspCommand ?? ''} args=${lspArgs.join(' ')}`); + client = new LanguageClient('easycryptLsp', 'EasyCrypt LSP', serverOptions, clientOptions); + outputChannel?.appendLine('[lsp] starting client'); + clientReady = client.start(); + void clientReady.then( + () => outputChannel?.appendLine('[lsp] client ready'), + (err) => outputChannel?.appendLine(`[lsp] client start failed ${String(err)}`) + ); + void clientReady.then(() => client?.setTrace(traceLevel)); +} + +async function restartClient(): Promise { + if (!serverOptions || !clientOptions) { + vscode.window.showErrorMessage('EasyCrypt: LSP options are not configured.'); + return; + } + const current = client; + if (current) { + try { + await current.stop(); + } catch (err) { + vscode.window.showWarningMessage(`EasyCrypt: failed to stop LSP (${String(err)}).`); + } + } + startClient(); + outputChannel?.appendLine('[lsp] restarted client'); + vscode.window.showInformationMessage('EasyCrypt: LSP restarted.'); +} + +export function activate(context: vscode.ExtensionContext): void { + outputChannel = vscode.window.createOutputChannel('EasyCrypt'); + context.subscriptions.push(outputChannel); + processedDecoration = vscode.window.createTextEditorDecorationType({ + backgroundColor: 'rgba(120, 140, 180, 0.18)', + isWholeLine: false, + rangeBehavior: vscode.DecorationRangeBehavior.ClosedClosed + }); + context.subscriptions.push(processedDecoration); + processingDecoration = vscode.window.createTextEditorDecorationType({ + backgroundColor: 'rgba(210, 170, 90, 0.28)', + isWholeLine: false + }); + context.subscriptions.push(processingDecoration); + + diagnostics = vscode.languages.createDiagnosticCollection('easycrypt'); + context.subscriptions.push(diagnostics); + + errorDecoration = undefined; + + const workspaceFolder = vscode.workspace.workspaceFolders?.[0]?.uri.fsPath; + const config = vscode.workspace.getConfiguration('easycrypt'); + const cliPath = config.get('cli.path') ?? ''; + const serverCommand = resolveServerCommand(workspaceFolder, cliPath) ?? 'easycrypt'; + const cliArgs = config.get('cli.args') ?? []; + const serverArgs = ensureLspArgs(cliArgs); + lspCommand = serverCommand; + lspArgs = serverArgs; + const traceSetting = config.get('trace.server') ?? 'off'; + traceLevel = + traceSetting === 'verbose' + ? Trace.Verbose + : traceSetting === 'messages' + ? Trace.Messages + : Trace.Off; + + outputChannel.appendLine(`[lsp] serverCommand=${serverCommand}`); + outputChannel.appendLine(`[lsp] cliPath=${cliPath || '(default)'}`); + outputChannel.appendLine(`[lsp] cliArgs=${cliArgs.join(' ')}`); + outputChannel.appendLine(`[lsp] serverArgs=${serverArgs.join(' ')}`); + outputChannel.appendLine(`[lsp] trace=${traceSetting}`); + outputChannel.appendLine( + `[lsp] logFile=${workspaceFolder ? path.join(workspaceFolder, '.easycrypt-lsp.log') : '(inherit)'}` + ); + outputChannel.show(true); + + if (!resolveServerCommand(workspaceFolder, cliPath)) { + vscode.window.showWarningMessage( + "EasyCrypt binary not found in the workspace. Using 'easycrypt' from PATH." + ); + } + + const lspEnv = { + ...process.env, + EASYCRYPT_LSP_LOG: workspaceFolder + ? path.join(workspaceFolder, '.easycrypt-lsp.log') + : process.env.EASYCRYPT_LSP_LOG + }; + const localServerOptions: ServerOptions = { + command: serverCommand, + args: serverArgs, + transport: TransportKind.stdio, + options: { env: lspEnv } + }; + + const localClientOptions: LanguageClientOptions = { + documentSelector: [{ language: 'easycrypt' }], + outputChannel, + traceOutputChannel: outputChannel + }; + + serverOptions = localServerOptions; + clientOptions = localClientOptions; + startClient(); + context.subscriptions.push( + new vscode.Disposable(() => { + outputChannel?.appendLine('[lsp] stopping client'); + void client?.stop(); + }) + ); + if (client) { + client.onDidChangeState((event) => { + outputChannel?.appendLine(`[lsp] state ${event.oldState} -> ${event.newState}`); + }); + } + + context.subscriptions.push( + vscode.commands.registerCommand('easycrypt.proof.step', handleStep), + vscode.commands.registerCommand('easycrypt.proof.back', handleBack), + vscode.commands.registerCommand('easycrypt.proof.restart', handleRestart), + vscode.commands.registerCommand('easycrypt.proof.jumpToCursor', handleSendRegion), + vscode.commands.registerCommand('easycrypt.proof.goals', handleGoals), + vscode.commands.registerCommand('easycrypt.lsp.restart', restartClient) + ); + + context.subscriptions.push( + vscode.workspace.onDidCloseTextDocument((doc) => { + docStates.delete(doc.uri.toString()); + }) + ); + + context.subscriptions.push( + vscode.workspace.onDidChangeTextDocument(async (event) => { + if (suppressProcessedEdits || suppressProcessingEdits) { + return; + } + if (event.contentChanges.length === 0) { + return; + } + const doc = event.document; + if (doc.languageId !== 'easycrypt') { + return; + } + if (processingDocUri && processingDocUri === doc.uri.toString()) { + suppressProcessingEdits = true; + try { + await restoreProcessingSnapshot(doc); + } catch (err) { + outputChannel?.appendLine(`[proof] processing lock restore failed ${String(err)}`); + } finally { + suppressProcessingEdits = false; + } + return; + } + clearErrorDecoration(vscode.window.activeTextEditor); + clearDiagnostics(doc); + const state = getDocState(doc); + const limit = state.lastOffset; + const earliestStart = event.contentChanges.reduce((min, change) => { + const start = change.range ? doc.offsetAt(change.range.start) : 0; + return Math.min(min, start); + }, Number.POSITIVE_INFINITY); + if (!(earliestStart < limit)) { + return; + } + suppressProcessedEdits = true; + try { + try { + const result = await requestProof('easycrypt/proof/jumpTo', { + uri: doc.uri.toString(), + target: earliestStart + }); + state.lastOffset = result.processedEnd; + } catch (err) { + outputChannel?.appendLine(`[proof] auto-rewind failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt auto-rewind failed: ${String(err)}`); + } + updateProcessedDecoration(vscode.window.activeTextEditor); + } finally { + suppressProcessedEdits = false; + } + return; + }) + ); + + const updateEditorState = (editor: vscode.TextEditor | undefined) => { + if (editor && editor.document.languageId === 'easycrypt') { + lastEasyCryptEditor = editor; + } + updateProcessedDecoration(editor); + clearErrorDecoration(editor); + if (editor) { + clearDiagnostics(editor.document); + } + }; + + updateEditorState(vscode.window.activeTextEditor); + + context.subscriptions.push( + vscode.window.onDidChangeActiveTextEditor((editor) => { + updateEditorState(editor); + }) + ); + +} + +export async function deactivate(): Promise { + if (client) { + await client.stop(); + } +} diff --git a/vscode/syntaxes/easycrypt.tmLanguage.json b/vscode/syntaxes/easycrypt.tmLanguage.json new file mode 100644 index 0000000000..af025d0dce --- /dev/null +++ b/vscode/syntaxes/easycrypt.tmLanguage.json @@ -0,0 +1,101 @@ +{ + "$schema": "https://raw.githubusercontent.com/martinring/tmlanguage/master/tmlanguage.json", + "name": "EasyCrypt", + "scopeName": "source.easycrypt", + "patterns": [ + { "include": "#comments" }, + { "include": "#strings" }, + { "include": "#keywords" }, + { "include": "#types" }, + { "include": "#numbers" } + ], + "repository": { + "comments": { + "patterns": [ + { + "name": "comment.block.easycrypt", + "begin": "\\(\\*", + "beginCaptures": { + "0": { "name": "punctuation.definition.comment.easycrypt" } + }, + "end": "\\*\\)", + "endCaptures": { + "0": { "name": "punctuation.definition.comment.easycrypt" } + }, + "patterns": [ + { "include": "#comments" } + ] + } + ] + }, + "strings": { + "patterns": [ + { + "name": "string.quoted.double.easycrypt", + "begin": "\"", + "beginCaptures": { + "0": { "name": "punctuation.definition.string.begin.easycrypt" } + }, + "end": "\"", + "endCaptures": { + "0": { "name": "punctuation.definition.string.end.easycrypt" } + }, + "patterns": [ + { + "name": "constant.character.escape.easycrypt", + "match": "\\\\." + } + ] + } + ] + }, + "keywords": { + "patterns": [ + { + "name": "keyword.other.easycrypt.bytac", + "match": "\\b(assumption|by|check|coq|done|edit|exact|fix|reflexivity|smt|solve)\\b" + }, + { + "name": "keyword.other.easycrypt.dangerous", + "match": "\\b(admit|admitted)\\b" + }, + { + "name": "keyword.control.easycrypt.global", + "match": "\\b(Pr|Self|Top|abbrev|abort|abstract|as|axiom|axiomatized|class|clone|const|declare|dump|end|exit|export|from|global|goal|hint|import|include|inductive|instance|lemma|local|locate|module|notation|of|op|pred|print|proof|prover|qed|realize|remove|rename|require|search|section|subtype|theory|timeout|type|why3|with)\\b" + }, + { + "name": "keyword.other.easycrypt.internal", + "match": "\\b(debug|fail|pragma|time|undo)\\b" + }, + { + "name": "keyword.operator.easycrypt.prog", + "match": "\\b(assert|async|ehoare|elif|else|equiv|exists|for|for|forall|fun|glob|hoare|if|in|is|islossless|let|match|match|phoare|proc|res|return|then|var|while)\\b" + }, + { + "name": "keyword.control.easycrypt.tactic", + "match": "\\b(algebra|alias|apply|auto|beta|byehoare|byequiv|byphoare|bypr|byupto|call|case|cbv|cfold|change|clear|congr|conseq|delta|eager|ecall|elim|eta|exfalso|exlim|fel|field|fieldeq|fission|fusion|gen|have|idassign|idtac|inline|interleave|iota|kill|left|logic|modpath|move|outline|pose|pr_bounded|progress|rcondf|rcondt|replace|rewrite|right|ring|ringeq|rnd|rndsem|rwnormal|seq|sim|simplify|skip|sp|split|splitwhile|subst|suff|swap|symmetry|transitivity|trivial|unroll|weakmem|wlog|wp|zeta)\\b" + }, + { + "name": "keyword.control.easycrypt.tactical", + "match": "\\b(do|expect|first|last|try)\\b" + } + ] + }, + "types": { + "patterns": [ + { + "name": "storage.type.easycrypt", + "match": "\\b(bool|int|real|unit)\\b" + } + ] + }, + "numbers": { + "patterns": [ + { + "name": "constant.numeric.easycrypt", + "match": "\\b\\d+(?:\\.\\d+)?\\b" + } + ] + } + } +} diff --git a/vscode/tsconfig.json b/vscode/tsconfig.json new file mode 100644 index 0000000000..6da6eaa6cf --- /dev/null +++ b/vscode/tsconfig.json @@ -0,0 +1,13 @@ +{ + "compilerOptions": { + "target": "ES2020", + "module": "commonjs", + "lib": ["ES2020"], + "outDir": "out", + "rootDir": "src", + "sourceMap": true, + "strict": true, + "esModuleInterop": true + }, + "include": ["src"] +} From d83b2c7b8dfb19955ffba369593ab001c61f623b Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 25 Mar 2026 18:09:07 +0100 Subject: [PATCH 041/145] Tighten proc-change observability Restrict proc-change local postconditions to variables observable from the continuation or the goal post, instead of equating all writes from the replaced fragment. --- src/ecLowPhlGoal.ml | 13 ++ src/ecPV.ml | 43 +++++++ src/ecPV.mli | 9 ++ src/phl/ecPhlRewrite.ml | 72 +++++------ tests/procchange.ec | 261 +++++++++++++++++++++++++++++++++++----- 5 files changed, 323 insertions(+), 75 deletions(-) diff --git a/src/ecLowPhlGoal.ml b/src/ecLowPhlGoal.ml index 6daabbfd6d..07bc36471c 100644 --- a/src/ecLowPhlGoal.ml +++ b/src/ecLowPhlGoal.ml @@ -365,6 +365,19 @@ let logicS_read (env : env) (f : logicS) = | `Equiv hs -> equivS_read env hs | `EHoare hs -> eHoareS_read env hs +let logicS_post_read (env : env) (f : logicS) = + let add pvs inv = EcPV.form_read env pvs inv in + + match f with + | `Hoare hs -> + POE.fold add EcPV.PMVS.empty (hs_po hs).hsi_inv + | `EHoare hs -> + add EcPV.PMVS.empty (ehs_po hs).inv + | `BdHoare hs -> + add (add EcPV.PMVS.empty (bhs_po hs).inv) (bhs_bd hs).inv + | `Equiv es -> + add EcPV.PMVS.empty (es_po es).inv + (* -------------------------------------------------------------------- *) exception InvalidSplit of codepos1 diff --git a/src/ecPV.ml b/src/ecPV.ml index 590ab1a2e7..a9ffeb67e9 100644 --- a/src/ecPV.ml +++ b/src/ecPV.ml @@ -7,6 +7,7 @@ open EcTypes open EcModules open EcFol open EcEnv +open EcMatching (* -------------------------------------------------------------------- *) type alias_clash = @@ -630,6 +631,48 @@ let is_read env is = is_read_r env PV.empty is let s_read env s = s_read_r env PV.empty s let f_read env f = f_read_r env PV.empty f +(* -------------------------------------------------------------------- *) +let zpr_pv (kind : [ `Read | `Write ]) (span : [ `Before | `After ]) (env : env) = + let pv_of_stmt = + match kind with + | `Read -> is_read_r + | `Write -> is_write_r ?except:None + in + + let rec doit (ctxt : instr option) (pvs : PV.t) (zpr : Zipper.spath) = + let (head, tail), ipath = zpr in + let stail = List.ocons ctxt tail in + let s = stmt (List.rev_append head stail) in + + let pvs = + let s = match span with `Before -> head | `After -> tail in + pv_of_stmt env pvs s in + + let parent, pvs = + match ipath with + | Zipper.ZTop -> + None, pvs + + | Zipper.ZIfThen (e, ps, se) -> + Some (ps, i_if (e, s, se)), pvs + + | Zipper.ZIfElse (e, st, ps) -> + Some (ps, i_if (e, st, s)), pvs + + | Zipper.ZMatch (e, ps, mpi) -> + let bs = + List.rev_append mpi.prebr ((mpi.locals, s) :: mpi.postbr) + in Some (ps, i_match (e, bs)), pvs + + | Zipper.ZWhile (e, ps) -> + let wi = i_while (e, s) in + Some (ps, wi), pv_of_stmt env pvs [wi] + in + + ofold (fun (zpr, ctxt) pvs -> doit (Some ctxt) pvs zpr) pvs parent + + in fun pvs zpr -> doit None pvs zpr + (* -------------------------------------------------------------------- *) type pmvs = PV.t Mid.t diff --git a/src/ecPV.mli b/src/ecPV.mli index ac1e64cbb5..fe5d269fe0 100644 --- a/src/ecPV.mli +++ b/src/ecPV.mli @@ -148,6 +148,15 @@ val is_read : instr list pvaccess0 val s_read : stmt pvaccess0 val f_read : xpath pvaccess0 +(* -------------------------------------------------------------------- *) +val zpr_pv : + [ `Read | `Write ] + -> [ `Before | `After ] + -> env + -> PV.t + -> EcMatching.Zipper.spath + -> PV.t + (* -------------------------------------------------------------------- *) type pmvs = PV.t EcIdent.Mid.t diff --git a/src/phl/ecPhlRewrite.ml b/src/phl/ecPhlRewrite.ml index 331d1c9477..b12461179e 100644 --- a/src/phl/ecPhlRewrite.ml +++ b/src/phl/ecPhlRewrite.ml @@ -6,7 +6,6 @@ open EcCoreGoal open EcEnv open EcModules open EcFol -open EcMatching module L = EcLocation module PT = EcProofTerm @@ -230,44 +229,11 @@ let process_rewrite_at EcPhlConseq.t_conseq pre post tc |> FApi.t_sub [t_pre; t_post; EcLowGoal.t_id] -(* -------------------------------------------------------------------- *) -let zpr_write (env : env) = - let rec doit (ctxt : instr option) (pvs : EcPV.PV.t) (zpr : Zipper.spath) = - let (head, tail), ipath = zpr in - let tail = List.ocons ctxt tail in - let s = stmt (List.rev_append head tail) in - - let pvs = EcPV.is_write_r env pvs head in - - let parent, pvs = - match ipath with - | Zipper.ZTop -> - None, pvs - - | Zipper.ZIfThen (e, ps, se) -> - Some (ps, i_if (e, s, se)), pvs - - | Zipper.ZIfElse (e, st, ps) -> - Some (ps, i_if (e, st, s)), pvs - - | Zipper.ZMatch (e, ps, mpi) -> - let bs = - List.rev_append mpi.prebr ((mpi.locals, s) :: mpi.postbr) - in Some (ps, i_match (e, bs)), pvs - - | Zipper.ZWhile (e, ps) -> - Some (ps, i_while (e, s)), EcPV.is_write_r env pvs tail - in - - ofold (fun (zpr, ctxt) pvs -> doit (Some ctxt) pvs zpr) pvs parent - - in fun pvs zpr -> doit None pvs zpr - (* -------------------------------------------------------------------- *) (* [change] replaces a code range with [s] by generating: - a local equivalence goal showing that the original fragment and [s] agree under the framed precondition on the variables they both read, - and produce the same values for everything they may write; + and produce the same values for everything observable afterwards; - the original program-logic goal with the selected range rewritten. *) let t_change_stmt (side : side option) @@ -284,9 +250,9 @@ let t_change_stmt (* Collect the variables that may be modified by the surrounding context, excluding the fragment being replaced. *) let modi = - let zpr = - (zpr.z_head, List.drop (List.length stmt) zpr.z_tail), zpr.z_path - in zpr_write env EcPV.PV.empty zpr in + let zpr = { zpr with z_tail = epilog } in + let zpr = (zpr.z_head, zpr.z_tail), zpr.z_path in + EcPV.zpr_pv `Write `Before env EcPV.PV.empty zpr in (* Keep only the top-level conjuncts of the current precondition that talk about the active memory and are independent from the surrounding writes. *) @@ -307,8 +273,26 @@ let t_change_stmt let written = EcPV.is_write_r env written stmt in let written = EcPV.is_write_r env written s.s_node in + let obs = + let zpr = { zpr with z_tail = epilog } in + let zpr = (zpr.z_head, zpr.z_tail), zpr.z_path in + let obs = EcPV.zpr_pv `Read `After env EcPV.PV.empty zpr in + + let goal = + let pvs = + EcLowPhlGoal.logicS_post_read env + (EcLowPhlGoal.get_logicS (FApi.tc1_goal tc)) + in + EcIdent.Mid.find_def EcPV.PV.empty (fst me) pvs + in + + EcPV.PV.union obs goal + in + + let written = EcPV.PV.inter written obs in + (* The local equivalence goal relates shared reads in the precondition and - all possible writes in the postcondition. *) + the writes that remain observable in the continuation/postcondition. *) let wr_pvs, wr_globs = EcPV.PV.elements written in let pr_pvs, pr_globs = EcPV.PV.elements @@ EcPV.PV.inter @@ -337,11 +321,11 @@ let t_change_stmt (* First subgoal: prove that the replacement fragment preserves the observable behavior required by the outer proof. *) let goal1 = - f_equivS - (snd me) (snd me) - { ml; mr; inv = ofold f_and (f_ands pr_eq) frame; } - (EcAst.stmt stmt) s - { ml; mr; inv = f_ands po_eq; } + f_equivS + (snd me) (snd me) + { ml; mr; inv = ofold f_and (f_ands pr_eq) frame; } + (EcAst.stmt stmt) s + { ml; mr; inv = f_ands po_eq; } in let stmt = EcMatching.Zipper.zip { zpr with z_tail = s.s_node @ epilog } in diff --git a/tests/procchange.ec b/tests/procchange.ec index 25eb8f40aa..f656c52daf 100644 --- a/tests/procchange.ec +++ b/tests/procchange.ec @@ -264,12 +264,12 @@ theory ProcChangeFrameTest. lemma L : hoare[M.f : x = 3 ==> true]. proof. - proc. - simplify. + proc=> /=. proc change 2 : { x <- 4; }; by auto. -qed. + qed. +end ProcChangeFrameTest. (* -------------------------------------------------------------------- *) (* Negative flat case: change statement 3 (x <- x + 1 → x <- 4) fails. @@ -281,18 +281,18 @@ theory ProcChangeFrameFailTest. y <- 0; x <- 4; x <- x + 1; + return x; } }. - lemma L : hoare[M.f : x = 3 ==> true]. + lemma L : hoare[M.f : x = 3 ==> res = 0]. proof. - proc. - simplify. + proc=> /=. fail proc change 3 : { x <- 4; }; by auto. -abort. - + abort. +end ProcChangeFrameFailTest. (* -------------------------------------------------------------------- *) (* Positive if-block case: change ^if.1 (x <- x + 1 → x <- 4) inside @@ -313,12 +313,12 @@ theory ProcChangeBlockFrameTest. lemma L : hoare[M.f : x = 3 ==> true]. proof. - proc. - simplify. + proc=> /=. proc change ^if.1 : { x <- 4; }; by auto. -qed. + qed. +end ProcChangeBlockFrameTest. (* -------------------------------------------------------------------- *) (* Negative if-block case: change ^if.2 (x <- x + 1 → x <- 4) fails. @@ -334,17 +334,18 @@ theory ProcChangeBlockFailFrameTest. } else { x <- 4; } + return x; } }. - lemma L : hoare[M.f : x = 3 ==> true]. + lemma L : hoare[M.f : x = 3 ==> res = 0]. proof. - proc. - simplify. + proc=> /=. fail proc change ^if.2 : { x <- 4; }; by auto. -abort. + abort. +end ProcChangeBlockFailFrameTest. (* -------------------------------------------------------------------- *) (* Positive while case: change ^while.1 (x <- x + 1 → x <- 4). @@ -363,12 +364,12 @@ theory ProcChangeWhileFrameTest. lemma L : hoare[M.f : x = 3 ==> true]. proof. - proc. - simplify. + proc=> /=. proc change ^while.1 : { x <- 4; }; by auto. -qed. + qed. +end ProcChangeWhileFrameTest. (* -------------------------------------------------------------------- *) (* Negative while case — write after the change site: @@ -390,13 +391,14 @@ theory ProcChangeWhileFrameFailWriteAfterTest. lemma L : hoare[M.f : x = 3 ==> true]. proof. - proc. - simplify. - fail proc change ^while.1 : { + proc=> /=. + proc change ^while.1 : { x <- 4; - }; by auto. -abort. + }. + by auto. + abort. +end ProcChangeWhileFrameFailWriteAfterTest. (* -------------------------------------------------------------------- *) (* Negative while case — write before the change site: @@ -412,17 +414,18 @@ theory ProcChangeWhileFrameFailWriteBeforeTest. x <- x + 1; y <- 1; } + return x; } }. - lemma L : hoare[M.f : x = 3 ==> true]. + lemma L : hoare[M.f : x = 3 ==> res = 0]. proof. - proc. - simplify. + proc=> /=. fail proc change ^while.2 : { x <- 4; }; by auto. -abort. + abort. +end ProcChangeWhileFrameFailWriteBeforeTest. (* -------------------------------------------------------------------- *) (* Negative while case — write outside (before) the loop: @@ -438,15 +441,211 @@ theory ProcChangeWhileFrameFailWriteOutsideTest. x <- x + 1; y <- 1; } + return x; } }. - lemma L : hoare[M.f : x = 3 ==> true]. + lemma L : hoare[M.f : x = 3 ==> res = 0]. proof. - proc. - simplify. + proc=> /=. fail proc change ^while.1 : { x <- 4; }; by auto. -abort. + abort. +end ProcChangeWhileFrameFailWriteOutsideTest. + +(* -------------------------------------------------------------------- *) +(* observability through the context/post. + These tests exercise the variable selection performed by [zpr_pv] + and the post-side read analysis used by proc change. *) + +(* The continuation reads only x, so y can be changed freely in the + replacement block. *) +theory ProcChangeContextReadXOnlyTest. + module M = { + proc f(x : int, y : int) = { + x <- 1; + y <- 2; + x <- x + 1; + return x; + } + }. + + lemma L : hoare[M.f : true ==> res = 2]. + proof. + proc=> /=. + proc change [1..2] : { + x <- 1; + y <- 99; + }; by auto. + qed. +end ProcChangeContextReadXOnlyTest. + +(* -------------------------------------------------------------------- *) +(* The continuation reads only y, so x can be changed freely in the + replacement block. *) +theory ProcChangeContextReadYOnlyTest. + module M = { + proc f(x : int, y : int) = { + x <- 1; + y <- 2; + y <- y + 1; + return y; + } + }. + + lemma L : hoare[M.f : true ==> res = 3]. + proof. + proc=> /=. + proc change [1..2] : { + x <- 99; + y <- 2; + }; by auto. + qed. +end ProcChangeContextReadYOnlyTest. + +(* -------------------------------------------------------------------- *) +(* The continuation reads x, so changing x in the replacement block is + observable and proc change must fail. *) +theory ProcChangeContextReadXFailTest. + module M = { + proc f(x : int, y : int) = { + x <- 1; + y <- 2; + x <- x + 1; + return x; + } + }. + + lemma L : hoare[M.f : true ==> res = 2]. + proof. + proc=> /=. + proc change [1..2] : { + x <- 99; + y <- 2; + }. + fail by auto. + abort. +end ProcChangeContextReadXFailTest. + +(* -------------------------------------------------------------------- *) +(* The continuation reads y, so changing y in the replacement block is + observable and proc change must fail. *) +theory ProcChangeContextReadYFailTest. + module M = { + proc f(x : int, y : int) = { + x <- 1; + y <- 2; + y <- y + 1; + return y; + } + }. + + lemma L : hoare[M.f : true ==> res = 3]. + proof. + proc=> /=. + proc change [1..2] : { + x <- 1; + y <- 99; + }. + fail by auto. + abort. +end ProcChangeContextReadYFailTest. + +(* -------------------------------------------------------------------- *) +(* With no continuation, the post mentions only x, so y can vary in the + replacement block. *) +theory ProcChangePostReadXOnlyTest. + module M = { + var x : int + var y : int + + proc f() = { + x <- 1; + y <- 2; + } + }. + + lemma L : hoare[M.f : true ==> M.x = 1]. + proof. + proc=> /=. + proc change [1..2] : { + M.x <- 1; + M.y <- 99; + }; by auto. + qed. +end ProcChangePostReadXOnlyTest. + +(* -------------------------------------------------------------------- *) +(* With no continuation, the post mentions x, so changing x in the + replacement block is observable and proc change must fail. *) +theory ProcChangePostReadXFailTest. + module M = { + var x : int + var y : int + + proc f() = { + x <- 1; + y <- 2; + } + }. + + lemma L : hoare[M.f : true ==> M.x = 1]. + proof. + proc=> /=. + proc change [1..2] : { + M.x <- 99; + M.y <- 2; + }. + fail by auto. + abort. +end ProcChangePostReadXFailTest. + +(* -------------------------------------------------------------------- *) +(* With no continuation, the post mentions only y, so x can vary in the + replacement block. *) +theory ProcChangePostReadYOnlyTest. + module M = { + var x : int + var y : int + + proc f() = { + x <- 1; + y <- 2; + } + }. + + lemma L : hoare[M.f : true ==> M.y = 2]. + proof. + proc=> /=. + proc change [1..2] : { + M.x <- 99; + M.y <- 2; + }; by auto. + qed. +end ProcChangePostReadYOnlyTest. + +(* -------------------------------------------------------------------- *) +(* With no continuation, the post mentions y, so changing y in the + replacement block is observable and proc change must fail. *) +theory ProcChangePostReadYFailTest. + module M = { + var x : int + var y : int + proc f() = { + x <- 1; + y <- 2; + } + }. + + lemma L : hoare[M.f : true ==> M.y = 2]. + proof. + proc=> /=. + proc change [1..2] : { + M.x <- 1; + M.y <- 99; + }. + fail by auto. + abort. +end ProcChangePostReadYFailTest. From 07d9e6dea11d0cc89bca272b6840d027c77c4d1a Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 21 Jan 2026 13:58:01 +0100 Subject: [PATCH 042/145] LSP --- dune-project | 4 + easycrypt.opam | 4 + src/dune | 5 +- src/ec.ml | 6 + src/ecIo.ml | 47 +- src/ecIo.mli | 1 + src/ecLsp.ml | 694 +++++++++++++++++++++ src/ecLsp.mli | 1 + src/ecOptions.ml | 14 + src/ecOptions.mli | 1 + src/ecTerminal.ml | 2 +- vscode/.gitignore | 2 + vscode/README.md | 46 ++ vscode/assets/back.svg | 3 + vscode/assets/easycrypt.svg | 5 + vscode/assets/goals.svg | 4 + vscode/assets/jump.svg | 3 + vscode/assets/refresh.svg | 3 + vscode/assets/step.svg | 3 + vscode/language-configuration.json | 23 + vscode/package-lock.json | 139 +++++ vscode/package.json | 178 ++++++ vscode/package.nls.json | 3 + vscode/src/extension.ts | 696 ++++++++++++++++++++++ vscode/syntaxes/easycrypt.tmLanguage.json | 101 ++++ vscode/tsconfig.json | 13 + 26 files changed, 1993 insertions(+), 8 deletions(-) create mode 100644 src/ecLsp.ml create mode 100644 src/ecLsp.mli create mode 100644 vscode/.gitignore create mode 100644 vscode/README.md create mode 100644 vscode/assets/back.svg create mode 100644 vscode/assets/easycrypt.svg create mode 100644 vscode/assets/goals.svg create mode 100644 vscode/assets/jump.svg create mode 100644 vscode/assets/refresh.svg create mode 100644 vscode/assets/step.svg create mode 100644 vscode/language-configuration.json create mode 100644 vscode/package-lock.json create mode 100644 vscode/package.json create mode 100644 vscode/package.nls.json create mode 100644 vscode/src/extension.ts create mode 100644 vscode/syntaxes/easycrypt.tmLanguage.json create mode 100644 vscode/tsconfig.json diff --git a/dune-project b/dune-project index 85f142616e..435605d30e 100644 --- a/dune-project +++ b/dune-project @@ -19,6 +19,10 @@ dune dune-build-info dune-site + fmt + logs + lsp + lwt markdown (pcre2 (>= 8)) (why3 (and (>= 1.8.0) (< 1.9))) diff --git a/easycrypt.opam b/easycrypt.opam index 08bdb40eac..92b556b975 100644 --- a/easycrypt.opam +++ b/easycrypt.opam @@ -7,6 +7,10 @@ depends: [ "dune" {>= "3.13"} "dune-build-info" "dune-site" + "fmt" + "logs" + "lsp" + "lwt" "markdown" "pcre2" {>= "8"} "why3" {>= "1.8.0" & < "1.9"} diff --git a/src/dune b/src/dune index 487e9cfcf5..53c3a9b40d 100644 --- a/src/dune +++ b/src/dune @@ -16,7 +16,7 @@ (public_name easycrypt.ecLib) (foreign_stubs (language c) (names eunix)) (modules :standard \ ec) - (libraries batteries camlp-streams dune-build-info dune-site inifiles markdown markdown.html pcre2 tyxml why3 yojson zarith) + (libraries batteries camlp-streams dune-build-info dune-site inifiles logs logs.fmt lsp lwt lwt.unix markdown markdown.html pcre2 tyxml why3 yojson zarith) ) (executable @@ -24,7 +24,8 @@ (name ec) (modules ec) (promote (until-clean)) - (libraries batteries camlp-streams dune-build-info dune-site inifiles pcre2 why3 yojson zarith ecLib)) + (libraries batteries ecLib) +) (ocamllex ecLexer) diff --git a/src/ec.ml b/src/ec.ml index 627d25b81b..6820fcf17f 100644 --- a/src/ec.ml +++ b/src/ec.ml @@ -214,6 +214,9 @@ let main () = (* Execution of eager commands *) begin match options.o_command with + | `Lsp -> + EcLsp.run (); + exit 0 | `Runtest input -> begin let root = match EcRelocate.sourceroot with @@ -535,6 +538,9 @@ let main () = | `Runtest _ -> (* Eagerly executed *) assert false + | `Lsp -> + (* Eagerly executed *) + assert false | `DocGen docopts -> begin let name = docopts.doco_input in diff --git a/src/ecIo.ml b/src/ecIo.ml index 016545d85c..d6fd6f498f 100644 --- a/src/ecIo.ml +++ b/src/ecIo.ml @@ -96,14 +96,15 @@ let from_string data = let finalize (ecreader : ecreader) = Disposable.dispose ecreader +(* -------------------------------------------------------------------- *) +let isfinal_token = function + | EcParser.FINAL _ -> true + | _ -> false + (* -------------------------------------------------------------------- *) let lexer ?(checkpoint : _ I.checkpoint option) (ecreader : ecreader_r) = let lexbuf = ecreader.ecr_lexbuf in - let isfinal = function - | EcParser.FINAL _ -> true - | _ -> false in - if ecreader.ecr_atstart then ecreader.ecr_trim <- ecreader.ecr_lexbuf.Lexing.lex_curr_p.pos_cnum; @@ -134,7 +135,7 @@ let lexer ?(checkpoint : _ I.checkpoint option) (ecreader : ecreader_r) = ecreader.ecr_tokens <- prequeue @ queue; - if isfinal token then + if isfinal_token token then ecreader.ecr_atstart <- true else ecreader.ecr_atstart <- ecreader.ecr_atstart && ( @@ -177,6 +178,42 @@ let parse (ecreader : ecreader) : EcParsetree.prog = in parse (EcParser.Incremental.prog ecreader.ecr_lexbuf.lex_curr_p) +(* -------------------------------------------------------------------- *) +let next_sentence_from (text : string) (start : int) : (string * int * int) option = + let len = String.length text in + if start < 0 || start >= len then + None + else + let sub = String.sub text start (len - start) in + let reader = from_string sub in + let ecr = Disposable.get reader in + + let exception EOF in + + Fun.protect + ~finally:(fun () -> finalize reader) + (fun () -> + try + begin + let exception Done in + + try + while true do + match proj3_1 (lexer ecr) with + | EcParser.FINAL _ -> raise Done + | EcParser.EOF -> raise EOF + | _ -> () + done + with Done -> () + end; + + let p = ecr.ecr_lexbuf.Lexing.lex_curr_p.pos_cnum - 1 in + let s = String.sub sub 0 p in + + Some (s, start, start + p) + with + | EcLexer.LexicalError _ | EOF -> None) + (* -------------------------------------------------------------------- *) let xparse (ecreader : ecreader) : string * EcParsetree.prog = let ecr = Disposable.get ecreader in diff --git a/src/ecIo.mli b/src/ecIo.mli index 42d28ba740..f69a371b66 100644 --- a/src/ecIo.mli +++ b/src/ecIo.mli @@ -13,6 +13,7 @@ val parse : ecreader -> EcParsetree.prog val parseall : ecreader -> EcParsetree.global list val drain : ecreader -> unit val lexbuf : ecreader -> Lexing.lexbuf +val next_sentence_from : string -> int -> (string * int * int) option (* -------------------------------------------------------------------- *) val lex_single_token : string -> EcParser.token option diff --git a/src/ecLsp.ml b/src/ecLsp.ml new file mode 100644 index 0000000000..b34c3b02a6 --- /dev/null +++ b/src/ecLsp.ml @@ -0,0 +1,694 @@ +open Lwt.Syntax + +module Json = Yojson.Safe +module J = Yojson.Safe.Util + +module Lsp_io = + Lsp.Io.Make + (struct + type 'a t = 'a Lwt.t + + let return = Lwt.return + let raise = Lwt.fail + + module O = struct + let ( let+ ) x f = Lwt.map f x + let ( let* ) x f = Lwt.bind x f + end + end) + (struct + type input = Lwt_io.input_channel + type output = Lwt_io.output_channel + + let read_line ic = Lwt_io.read_line_opt ic + + let read_exactly ic len = + let rec loop acc remaining = + if remaining <= 0 then + Lwt.return (Some (Buffer.contents acc)) + else + Lwt.bind (Lwt_io.read ~count:remaining ic) (fun s -> + if s = "" then + Lwt.return None + else ( + Buffer.add_string acc s; + loop acc (remaining - String.length s) + )) + in + loop (Buffer.create len) len + + let write oc chunks = + Lwt.bind (Lwt_list.iter_s (Lwt_io.write oc) chunks) (fun () -> + Lwt_io.flush oc) + end) + +let setup_logging () : unit = + let reporter = + match Sys.getenv_opt "EASYCRYPT_LSP_LOG" with + | None -> Logs_fmt.reporter () + | Some path -> ( + try + let oc = + open_out_gen [ Open_creat; Open_text; Open_append ] 0o644 path + in + Logs_fmt.reporter ~dst:(Format.formatter_of_out_channel oc) () + with e -> + prerr_endline ("[easycrypt-lsp] failed to open log file: " ^ Printexc.to_string e); + Logs_fmt.reporter ()) + in + Logs.set_reporter reporter; + Logs.set_level (Some Logs.Info) + +let log (fmt : ('a, Format.formatter, unit, unit) format4) = + Format.kasprintf (fun msg -> Logs.info (fun m -> m "%s" msg)) fmt + +module Easycrypt_cli = struct + type session = { + proc : Lwt_process.process; + mutable uuid : int; + mutable mode : string; + mutable last_output : string; + root_uuid : int; + } + + type config = { + mutable cli_path : string; + mutable cli_args : string list; + } + + let prompt_re : Pcre2.regexp = + Pcre2.regexp "\\[([0-9]+)\\|([^\\]]+)\\]>" + + let parse_prompt (line : string) : (int * string) option = + try + let subs = Pcre2.exec ~rex:prompt_re line in + let uuid_str = Pcre2.get_substring subs 1 in + let mode = Pcre2.get_substring subs 2 in + Some (int_of_string uuid_str, mode) + with + | Not_found -> None + | Pcre2.Error _ -> None + + let default_cli_path () : string = + if Sys.file_exists "ec.native" then + "./ec.native" + else + "easycrypt" + + let read_until_prompt (sess : session) : string Lwt.t = + let buf = Buffer.create 256 in + let rec loop () = + let* line_opt = Lwt_io.read_line_opt sess.proc#stdout in + match line_opt with + | None -> Lwt.return (Buffer.contents buf) + | Some line -> + log "cli + sess.uuid <- uuid; + sess.mode <- mode; + Lwt.return (Buffer.contents buf) + | None -> + Buffer.add_string buf line; + Buffer.add_char buf '\n'; + loop ()) + in + loop () + + let start_session (cfg : config) : session Lwt.t = + let argv = + let args = "cli" :: "-emacs" :: cfg.cli_args in + Array.of_list (cfg.cli_path :: args) + in + let proc = Lwt_process.open_process (cfg.cli_path, argv) in + let sess = + { proc + ; uuid = 0 + ; mode = "" + ; last_output = "" + ; root_uuid = 0 + } + in + let* _initial_output = read_until_prompt sess in + Lwt.return { sess with root_uuid = sess.uuid } + + let send_command (sess : session) (text : string) : string Lwt.t = + log "cli> %s" (String.trim text); + let write = + if String.ends_with ~suffix:"\n" text then + Lwt_io.write sess.proc#stdin text + else + Lwt_io.write_line sess.proc#stdin text + in + let* () = write in + let* () = Lwt_io.flush sess.proc#stdin in + let* output = read_until_prompt sess in + sess.last_output <- output; + let preview = + if String.length output = 0 then "" + else if String.length output <= 200 then String.escaped output + else String.escaped (String.sub output 0 200) ^ "..." + in + log "cli< (%d bytes) %s" (String.length output) preview; + Lwt.return output + + let send_undo (sess : session) (target_uuid : int) : string Lwt.t = + let cmd = Printf.sprintf "undo %d." target_uuid in + send_command sess cmd + + let stop_session (sess : session) : unit Lwt.t = + let close_chan ch = Lwt.catch (fun () -> Lwt_io.close ch) (fun _ -> Lwt.return_unit) in + let* () = close_chan sess.proc#stdin in + let* () = close_chan sess.proc#stdout in + sess.proc#terminate; + let* _status = sess.proc#status in + Lwt.return_unit + +end + +type doc_state = { + mutable text : BatText.t; + mutable last_offset : int; + mutable history : (int * int) list; + mutable session : Easycrypt_cli.session option; +} + +let doc_states : (string, doc_state) Hashtbl.t = Hashtbl.create 16 + +let get_doc_state (uri : string) : doc_state = + match Hashtbl.find_opt doc_states uri with + | Some state -> state + | None -> + let created = { text = BatText.empty; last_offset = 0; history = []; session = None } in + Hashtbl.add doc_states uri created; + created + +let error_tag_re : Pcre2.regexp = + Pcre2.regexp "\\[error-\\d+-\\d+\\]" + +let output_has_error (output : string) : bool = + Pcre2.pmatch ~rex:error_tag_re output + +let find_next_sentence + (text : BatText.t) + (start : int) : (string * int * int) option = + EcIo.next_sentence_from (BatText.to_string text) start + +let position_to_offset (text : BatText.t) (pos : Lsp.Types.Position.t) : int = + let len = BatText.length text in + let target_line = pos.Lsp.Types.Position.line in + let target_col = pos.Lsp.Types.Position.character in + let newline = BatUChar.of_char '\n' in + let rec find_line_start line current = + if line <= 0 then + current + else + try + let idx = BatText.index_from text current newline in + find_line_start (line - 1) (min (idx + 1) len) + with + | Not_found -> len + | BatText.Out_of_bounds -> len + in + let line_start = find_line_start target_line 0 in + if line_start >= len then + len + else + let offset = line_start + target_col in + if offset > len then len else offset + +let apply_change + (text : BatText.t) + (change : Lsp.Types.TextDocumentContentChangeEvent.t) : BatText.t * int = + match change.Lsp.Types.TextDocumentContentChangeEvent.range with + | None -> + BatText.of_string change.Lsp.Types.TextDocumentContentChangeEvent.text, 0 + | Some range -> + let start_offset = position_to_offset text range.Lsp.Types.Range.start in + let end_offset = position_to_offset text range.Lsp.Types.Range.end_ in + let len = BatText.length text in + let start_offset = max 0 (min start_offset len) in + let end_offset = max start_offset (min end_offset len) in + let removed = BatText.remove start_offset (end_offset - start_offset) text in + let inserted = BatText.of_string change.Lsp.Types.TextDocumentContentChangeEvent.text in + (BatText.insert start_offset inserted removed, start_offset) + +let json_of_proof_response + ~(sess : Easycrypt_cli.session) + ~(doc : doc_state) + ?sentence + (output : string) : Json.t = + let sentence_start, sentence_end = + match sentence with + | None -> (`Null, `Null) + | Some (start, end_) -> (`Int start, `Int end_) + in + `Assoc + [ ("output", `String output) + ; ("uuid", `Int sess.uuid) + ; ("mode", `String sess.mode) + ; ("processedEnd", `Int doc.last_offset) + ; ("sentenceStart", sentence_start) + ; ("sentenceEnd", sentence_end) + ] + +type proof_command_kind = + | Proof_next + | Proof_step + | Proof_jump_to of int + | Proof_back + | Proof_restart + | Proof_goals + +type proof_command = + { uri : string + ; cmd : proof_command_kind + } + +let proof_command_of_request (meth : string) (params : Json.t option) : + (proof_command, string) result = + let get_uri json = + match J.member "uri" json with + | `String uri -> uri + | _ -> "" + in + match meth, params with + | "easycrypt/proof/next", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_next } + | "easycrypt/proof/step", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_step } + | "easycrypt/proof/jumpTo", Some (`Assoc _ as json) -> + let uri = get_uri json in + let target = + try J.member "target" json |> J.to_int with _ -> -1 + in + if uri = "" || target < 0 then + Error "missing uri or target" + else + Ok { uri; cmd = Proof_jump_to target } + | "easycrypt/proof/back", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_back } + | "easycrypt/proof/restart", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_restart } + | "easycrypt/proof/goals", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_goals } + | _ -> Error "Method not found" + +let rewind_to_offset + (doc : doc_state) + (sess : Easycrypt_cli.session) + (target : int) : string option Lwt.t = + if target >= doc.last_offset then + Lwt.return_none + else + let rec last_before acc = function + | [] -> acc + | (offset, uuid) :: rest -> + let acc = if offset <= target then Some (offset, uuid) else acc in + last_before acc rest + in + let target_entry = last_before None doc.history in + let target_uuid, new_offset = + match target_entry with + | None -> sess.root_uuid, 0 + | Some (offset, uuid) -> uuid, offset + in + doc.history <- List.filter (fun (offset, _) -> offset <= new_offset) doc.history; + doc.last_offset <- new_offset; + let* output = Easycrypt_cli.send_undo sess target_uuid in + Lwt.return (Some output) + +let send_packet (oc : Lwt_io.output_channel) (packet : Jsonrpc.Packet.t) : unit Lwt.t = + Lsp_io.write oc packet + +let send_response (oc : Lwt_io.output_channel) (id : Jsonrpc.Id.t) (result : Jsonrpc.Json.t) : + unit Lwt.t = + let response = Jsonrpc.Response.ok id result in + send_packet oc (Jsonrpc.Packet.Response response) + +let send_typed_response + (oc : Lwt_io.output_channel) + (id : Jsonrpc.Id.t) + (req : 'a Lsp.Client_request.t) + (result : 'a) : unit Lwt.t = + let payload = Lsp.Client_request.yojson_of_result req result in + send_response oc id payload + +let send_error + (oc : Lwt_io.output_channel) + (id : Jsonrpc.Id.t) + (code : Jsonrpc.Response.Error.Code.t) + (message : string) : unit Lwt.t = + let error = + Jsonrpc.Response.Error.make + ~code + ~message + () + in + let response = Jsonrpc.Response.error id error in + send_packet oc (Jsonrpc.Packet.Response response) + +let send_notification (oc : Lwt_io.output_channel) (method_ : string) (params : Jsonrpc.Json.t) : + unit Lwt.t = + let params_struct = Jsonrpc.Structured.t_of_yojson params in + let notif = Jsonrpc.Notification.create ~params:params_struct ~method_ () in + send_packet oc (Jsonrpc.Packet.Notification notif) + +let run () : unit = + Sys.set_signal Sys.sigpipe Sys.Signal_ignore; + setup_logging (); + log "argv=%s" (String.concat " " (Array.to_list Sys.argv)); + log "server start"; + let run_lwt () : unit Lwt.t = + let argv = Array.to_list Sys.argv in + let cli_path = + match argv with + | prog :: _ -> prog + | [] -> Easycrypt_cli.default_cli_path () + in + let cfg : Easycrypt_cli.config = { cli_path; cli_args = [] } in + let ic = Lwt_io.of_fd ~mode:Lwt_io.input Lwt_unix.stdin in + let oc = Lwt_io.of_fd ~mode:Lwt_io.output Lwt_unix.stdout in + let shutdown = ref false in + let pending : (Jsonrpc.Id.t * proof_command) Queue.t = Queue.create () in + let current : unit Lwt.t option ref = ref None in + + let get_session_for_doc (doc : doc_state) : Easycrypt_cli.session Lwt.t = + match doc.session with + | Some sess -> Lwt.return sess + | None -> + let* sess = Easycrypt_cli.start_session cfg in + doc.session <- Some sess; + Lwt.return sess + in + + let handle_initialize id (params : Lsp.Types.InitializeParams.t) : unit Lwt.t = + log "initialize"; + let capabilities = + Lsp.Types.ServerCapabilities.create + ~textDocumentSync:(`TextDocumentSyncKind Lsp.Types.TextDocumentSyncKind.Incremental) + () + in + let result = Lsp.Types.InitializeResult.create ~capabilities () in + send_typed_response oc id (Lsp.Client_request.Initialize params) result + in + + let handle_proof_next id uri : unit Lwt.t = + log "proof next"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + match find_next_sentence doc.text doc.last_offset with + | None -> + send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) + | Some (_text, start, end_) -> + send_response oc id (json_of_proof_response ~sess ~doc ~sentence:(start, end_) sess.last_output) + in + + let handle_proof_exec id uri : unit Lwt.t = + log "proof exec"; + let doc = get_doc_state uri in + match find_next_sentence doc.text doc.last_offset with + | None -> + let* sess = get_session_for_doc doc in + send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) + | Some (text, start, end_) -> + let previous_offset = doc.last_offset in + let rec run ~retry = + let* sess = get_session_for_doc doc in + Lwt.catch + (fun () -> + let* output = Easycrypt_cli.send_command sess text in + Lwt.return (sess, output)) + (function + | Sys_error msg + when retry && String.lowercase_ascii msg = "broken pipe" -> + log "cli broken pipe; restarting session"; + doc.session <- None; + run ~retry:false + | e -> Lwt.fail e) + in + Lwt.catch + (fun () -> + let* sess, output = run ~retry:true in + if output_has_error output then ( + doc.last_offset <- previous_offset; + send_response oc id + (json_of_proof_response ~sess ~doc ~sentence:(start, end_) output)) + else ( + doc.last_offset <- end_; + doc.history <- doc.history @ [ (doc.last_offset, sess.uuid) ]; + send_response oc id + (json_of_proof_response ~sess ~doc ~sentence:(start, end_) output))) + (fun e -> + log "proof exec error: %s" (Printexc.to_string e); + send_error oc id Jsonrpc.Response.Error.Code.InternalError "proof exec failed") + in + + let handle_proof_jump id uri target : unit Lwt.t = + log "proof jump"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + let text_len = BatText.length doc.text in + let target = max 0 (min target text_len) in + let respond ?sentence output = + send_response oc id (json_of_proof_response ~sess ~doc ?sentence output) + in + if target < doc.last_offset then ( + let rec last_before acc = function + | [] -> acc + | (offset, uuid) :: rest -> + let acc = if offset <= target then Some (offset, uuid) else acc in + last_before acc rest + in + let target_entry = last_before None doc.history in + let target_uuid, new_offset = + match target_entry with + | None -> sess.root_uuid, 0 + | Some (offset, uuid) -> uuid, offset + in + doc.history <- List.filter (fun (offset, _) -> offset <= new_offset) doc.history; + doc.last_offset <- new_offset; + let* output = Easycrypt_cli.send_undo sess target_uuid in + respond output) + else if target = doc.last_offset then + respond sess.last_output + else ( + let rec loop last_output = + if doc.last_offset >= target then + respond last_output + else + match find_next_sentence doc.text doc.last_offset with + | None -> respond last_output + | Some (text, start, end_) -> + if end_ > target then + respond last_output + else + let previous_offset = doc.last_offset in + let* output = Easycrypt_cli.send_command sess text in + if output_has_error output then ( + doc.last_offset <- previous_offset; + respond ~sentence:(start, end_) output) + else ( + doc.last_offset <- end_; + doc.history <- doc.history @ [ (doc.last_offset, sess.uuid) ]; + loop output) + in + loop sess.last_output) + in + + let handle_proof_back id uri : unit Lwt.t = + log "proof back"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + match List.rev doc.history with + | [] -> + send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) + | _last :: rest_rev -> + let target_uuid, new_offset = + match rest_rev with + | [] -> sess.root_uuid, 0 + | (offset, uuid) :: _ -> uuid, offset + in + let* output = Easycrypt_cli.send_undo sess target_uuid in + doc.history <- List.rev rest_rev; + doc.last_offset <- new_offset; + send_response oc id (json_of_proof_response ~sess ~doc output) + in + + let handle_proof_restart id uri : unit Lwt.t = + log "proof restart"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + let* output = Easycrypt_cli.send_undo sess sess.root_uuid in + doc.history <- []; + doc.last_offset <- 0; + send_response oc id (json_of_proof_response ~sess ~doc output) + in + + let handle_proof_goals id uri : unit Lwt.t = + log "proof goals"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) + in + + let execute_proof_command (id : Jsonrpc.Id.t) (cmd : proof_command) : unit Lwt.t = + match cmd.cmd with + | Proof_next -> handle_proof_next id cmd.uri + | Proof_step -> handle_proof_exec id cmd.uri + | Proof_jump_to target -> handle_proof_jump id cmd.uri target + | Proof_back -> handle_proof_back id cmd.uri + | Proof_restart -> handle_proof_restart id cmd.uri + | Proof_goals -> handle_proof_goals id cmd.uri + in + + let start_proof (id : Jsonrpc.Id.t) (cmd : proof_command) : unit Lwt.t = + Lwt.catch + (fun () -> execute_proof_command id cmd) + (fun e -> + log "proof command error: %s" (Printexc.to_string e); + send_error oc id Jsonrpc.Response.Error.Code.InternalError "proof command failed") + in + + let pop_pending () = + if Queue.is_empty pending then None else Some (Queue.take pending) + in + + let handle_request req : unit Lwt.t = + match Lsp.Client_request.of_jsonrpc req with + | Error message -> + send_error oc req.id Jsonrpc.Response.Error.Code.InvalidParams message + | Ok (Lsp.Client_request.E r) -> ( + match r with + | Lsp.Client_request.Initialize params -> + handle_initialize req.id params + | Lsp.Client_request.Shutdown -> + shutdown := true; + send_typed_response oc req.id r () + | Lsp.Client_request.UnknownRequest { meth; params } -> ( + let params = Option.map Jsonrpc.Structured.yojson_of_t params in + match proof_command_of_request meth params with + | Ok cmd -> + (match !current with + | None -> + let task = start_proof req.id cmd in + current := Some task; + Lwt.return_unit + | Some _ -> + Queue.push (req.id, cmd) pending; + Lwt.return_unit) + | Error "Method not found" -> + send_error oc req.id Jsonrpc.Response.Error.Code.MethodNotFound "Method not found" + | Error message -> + send_error oc req.id Jsonrpc.Response.Error.Code.InvalidParams message) + | _ -> + send_error oc req.id Jsonrpc.Response.Error.Code.MethodNotFound "Method not found") + in + + let handle_notification_packet notif : unit Lwt.t = + match Lsp.Client_notification.of_jsonrpc notif with + | Error _ -> Lwt.return_unit + | Ok notification -> ( + match notification with + | Lsp.Client_notification.Initialized -> Lwt.return_unit + | Lsp.Client_notification.Exit -> shutdown := true; Lwt.return_unit + | Lsp.Client_notification.TextDocumentDidOpen params -> + let uri = + Lsp.Types.DocumentUri.to_string + params.Lsp.Types.DidOpenTextDocumentParams.textDocument.uri + in + let doc = get_doc_state uri in + doc.text <- BatText.of_string params.Lsp.Types.DidOpenTextDocumentParams.textDocument.text; + doc.last_offset <- 0; + doc.history <- []; + doc.session <- None; + Lwt.return_unit + | Lsp.Client_notification.TextDocumentDidChange params -> + let uri = + Lsp.Types.DocumentUri.to_string + params.Lsp.Types.DidChangeTextDocumentParams.textDocument.uri + in + let doc = get_doc_state uri in + let earliest = ref max_int in + let updated = ref doc.text in + List.iter + (fun change -> + let text, start_offset = apply_change !updated change in + updated := text; + if start_offset < !earliest then earliest := start_offset) + params.Lsp.Types.DidChangeTextDocumentParams.contentChanges; + doc.text <- !updated; + if !earliest < doc.last_offset then + let* sess = get_session_for_doc doc in + let* _ = rewind_to_offset doc sess !earliest in + Lwt.return_unit + else + Lwt.return_unit + | Lsp.Client_notification.TextDocumentDidClose params -> + let uri = + Lsp.Types.DocumentUri.to_string + params.Lsp.Types.DidCloseTextDocumentParams.textDocument.uri + in + let* () = + match Hashtbl.find_opt doc_states uri with + | Some doc -> ( + match doc.session with + | Some sess -> Easycrypt_cli.stop_session sess + | None -> Lwt.return_unit) + | None -> Lwt.return_unit + in + Hashtbl.remove doc_states uri; + Lwt.return_unit + | _ -> Lwt.return_unit) + in + + let rec loop () : unit Lwt.t = + if !shutdown then + Lwt.return_unit + else + let read_p = Lsp_io.read ic |> Lwt.map (fun p -> `Packet p) in + let waiters = + match !current with + | None -> [ read_p ] + | Some cmd_p -> [ read_p; (cmd_p |> Lwt.map (fun () -> `Cmd_done)) ] + in + let* ev = Lwt.pick waiters in + match ev with + | `Cmd_done -> + current := None; + (match pop_pending () with + | None -> () + | Some (id, cmd) -> current := Some (start_proof id cmd)); + loop () + | `Packet None -> + log "stdin closed"; + shutdown := true; + Lwt.return_unit + | `Packet (Some packet) -> + let* () = + match packet with + | Jsonrpc.Packet.Request req -> + log "recv request %s" req.Jsonrpc.Request.method_; + handle_request req + | Jsonrpc.Packet.Notification notif -> + log "recv notification %s" notif.Jsonrpc.Notification.method_; + handle_notification_packet notif + | Jsonrpc.Packet.Batch_call calls -> + Lwt_list.iter_s + (function + | `Request req -> handle_request req + | `Notification notif -> handle_notification_packet notif) + calls + | Jsonrpc.Packet.Response _ -> Lwt.return_unit + | Jsonrpc.Packet.Batch_response _ -> Lwt.return_unit + in + loop () + in + loop () + in + Lwt_main.run (run_lwt ()) diff --git a/src/ecLsp.mli b/src/ecLsp.mli new file mode 100644 index 0000000000..733b2a3231 --- /dev/null +++ b/src/ecLsp.mli @@ -0,0 +1 @@ +val run : unit -> unit diff --git a/src/ecOptions.ml b/src/ecOptions.ml index f012e8e8d6..c9b54139f9 100644 --- a/src/ecOptions.ml +++ b/src/ecOptions.ml @@ -6,10 +6,12 @@ open EcMaps type command = [ | `Compile of cmp_option | `Cli of cli_option + | `Lsp | `Config | `Runtest of run_option | `Why3Config | `DocGen of doc_option + | `Lsp ] and options = { @@ -356,6 +358,9 @@ let specs = { `Group "provers"; `Spec ("emacs", `Flag, "Output format set to ")]); + ("lsp", "Run EasyCrypt LSP server", [ + `Spec ("-stdio" , `Flag , "")]); + ("config", "Print EasyCrypt configuration", []); ("runtest", "Run a test-suite", [ @@ -604,6 +609,15 @@ let parse getini argv = raise (Arg.Bad "this command takes a single input file as argument") end + | "lsp" -> + if not (List.is_empty anons) then + raise (Arg.Bad "this command does not take arguments"); + + let ini = getini None in + let cmd = `Lsp in + + (cmd, ini, true) + | _ -> assert false in { diff --git a/src/ecOptions.mli b/src/ecOptions.mli index 59009718ad..c6aaa4d145 100644 --- a/src/ecOptions.mli +++ b/src/ecOptions.mli @@ -2,6 +2,7 @@ type command = [ | `Compile of cmp_option | `Cli of cli_option + | `Lsp | `Config | `Runtest of run_option | `Why3Config diff --git a/src/ecTerminal.ml b/src/ecTerminal.ml index 94f7c048e5..f680719f1e 100644 --- a/src/ecTerminal.ml +++ b/src/ecTerminal.ml @@ -90,7 +90,7 @@ object(self) | EcScope.TopError (loc, e) -> (loc, e) | _ -> (LC._dummy, e) in - Format.fprintf Format.err_formatter + Format.fprintf Format.std_formatter "[error-%d-%d]%s\n%!" (max 0 (loc.LC.loc_bchar - startpos)) (max 0 (loc.LC.loc_echar - startpos)) diff --git a/vscode/.gitignore b/vscode/.gitignore new file mode 100644 index 0000000000..82abfab5cc --- /dev/null +++ b/vscode/.gitignore @@ -0,0 +1,2 @@ +/node_modules/ +/out/ diff --git a/vscode/README.md b/vscode/README.md new file mode 100644 index 0000000000..0c3ac44c83 --- /dev/null +++ b/vscode/README.md @@ -0,0 +1,46 @@ +# EasyCrypt VSCode Extension (local) + +This folder contains a local VSCode extension for EasyCrypt. + +## Build the EasyCrypt binary (with LSP) + +From the repository root: + +``` +$ dune build src/ec.exe +``` + +The binary will be at `_build/default/src/ec.exe` and provides `easycrypt lsp`. + +## Build the extension + +From this `vscode/` folder: + +``` +$ npm install +$ npm run compile +``` + +Then use "Developer: Install Extension from Location..." and select this folder. + +## Configuration + +- `easycrypt.cli.path`: path to the EasyCrypt CLI (e.g. `ec.native` or `easycrypt`). + +## TextMate colors + +This extension uses TextMate scopes for syntax highlighting. To customize colors without changing a theme, add rules to your VSCode settings: + +```jsonc +"editor.tokenColorCustomizations": { + "textMateRules": [ + { "scope": "keyword.other.easycrypt.bytac", "settings": { "foreground": "#6C71C4" } }, + { "scope": "keyword.other.easycrypt.dangerous", "settings": { "foreground": "#DC322F", "fontStyle": "bold" } }, + { "scope": "keyword.control.easycrypt.global", "settings": { "foreground": "#268BD2" } }, + { "scope": "keyword.other.easycrypt.internal", "settings": { "foreground": "#B58900" } }, + { "scope": "keyword.operator.easycrypt.prog", "settings": { "foreground": "#2AA198" } }, + { "scope": "keyword.control.easycrypt.tactic", "settings": { "foreground": "#859900" } }, + { "scope": "keyword.control.easycrypt.tactical", "settings": { "foreground": "#CB4B16" } } + ] +} +``` diff --git a/vscode/assets/back.svg b/vscode/assets/back.svg new file mode 100644 index 0000000000..63fa276430 --- /dev/null +++ b/vscode/assets/back.svg @@ -0,0 +1,3 @@ + + + diff --git a/vscode/assets/easycrypt.svg b/vscode/assets/easycrypt.svg new file mode 100644 index 0000000000..f18030d31a --- /dev/null +++ b/vscode/assets/easycrypt.svg @@ -0,0 +1,5 @@ + + + + + diff --git a/vscode/assets/goals.svg b/vscode/assets/goals.svg new file mode 100644 index 0000000000..fe6bd5048c --- /dev/null +++ b/vscode/assets/goals.svg @@ -0,0 +1,4 @@ + + + + diff --git a/vscode/assets/jump.svg b/vscode/assets/jump.svg new file mode 100644 index 0000000000..daeb25d592 --- /dev/null +++ b/vscode/assets/jump.svg @@ -0,0 +1,3 @@ + + + diff --git a/vscode/assets/refresh.svg b/vscode/assets/refresh.svg new file mode 100644 index 0000000000..d124bdd5c7 --- /dev/null +++ b/vscode/assets/refresh.svg @@ -0,0 +1,3 @@ + + + diff --git a/vscode/assets/step.svg b/vscode/assets/step.svg new file mode 100644 index 0000000000..dd77f646a7 --- /dev/null +++ b/vscode/assets/step.svg @@ -0,0 +1,3 @@ + + + diff --git a/vscode/language-configuration.json b/vscode/language-configuration.json new file mode 100644 index 0000000000..163424eeb9 --- /dev/null +++ b/vscode/language-configuration.json @@ -0,0 +1,23 @@ +{ + "comments": { + "lineComment": "//", + "blockComment": ["(*", "*)"] + }, + "brackets": [ + ["{", "}"], + ["[", "]"], + ["(", ")"] + ], + "autoClosingPairs": [ + {"open": "{", "close": "}"}, + {"open": "[", "close": "]"}, + {"open": "(", "close": ")"}, + {"open": "\"", "close": "\""} + ], + "surroundingPairs": [ + ["{", "}"], + ["[", "]"], + ["(", ")"], + ["\"", "\""] + ] +} diff --git a/vscode/package-lock.json b/vscode/package-lock.json new file mode 100644 index 0000000000..7070c58627 --- /dev/null +++ b/vscode/package-lock.json @@ -0,0 +1,139 @@ +{ + "name": "easycrypt-vscode", + "version": "0.0.1", + "lockfileVersion": 3, + "requires": true, + "packages": { + "": { + "name": "easycrypt-vscode", + "version": "0.0.1", + "dependencies": { + "vscode-languageclient": "^9.0.1" + }, + "devDependencies": { + "@types/node": "^20.11.0", + "@types/vscode": "^1.85.0", + "typescript": "^5.3.3" + }, + "engines": { + "vscode": "^1.85.0" + } + }, + "node_modules/@types/node": { + "version": "20.19.30", + "resolved": "https://registry.npmjs.org/@types/node/-/node-20.19.30.tgz", + "integrity": "sha512-WJtwWJu7UdlvzEAUm484QNg5eAoq5QR08KDNx7g45Usrs2NtOPiX8ugDqmKdXkyL03rBqU5dYNYVQetEpBHq2g==", + "dev": true, + "license": "MIT", + "dependencies": { + "undici-types": "~6.21.0" + } + }, + "node_modules/@types/vscode": { + "version": "1.108.1", + "resolved": "https://registry.npmjs.org/@types/vscode/-/vscode-1.108.1.tgz", + "integrity": "sha512-DerV0BbSzt87TbrqmZ7lRDIYaMiqvP8tmJTzW2p49ZBVtGUnGAu2RGQd1Wv4XMzEVUpaHbsemVM5nfuQJj7H6w==", + "dev": true, + "license": "MIT" + }, + "node_modules/balanced-match": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/balanced-match/-/balanced-match-1.0.2.tgz", + "integrity": "sha512-3oSeUO0TMV67hN1AmbXsK4yaqU7tjiHlbxRDZOpH0KW9+CeX4bRAaX0Anxt0tx2MrpRpWwQaPwIlISEJhYU5Pw==", + "license": "MIT" + }, + "node_modules/brace-expansion": { + "version": "2.0.2", + "resolved": "https://registry.npmjs.org/brace-expansion/-/brace-expansion-2.0.2.tgz", + "integrity": "sha512-Jt0vHyM+jmUBqojB7E1NIYadt0vI0Qxjxd2TErW94wDz+E2LAm5vKMXXwg6ZZBTHPuUlDgQHKXvjGBdfcF1ZDQ==", + "license": "MIT", + "dependencies": { + "balanced-match": "^1.0.0" + } + }, + "node_modules/minimatch": { + "version": "5.1.6", + "resolved": "https://registry.npmjs.org/minimatch/-/minimatch-5.1.6.tgz", + "integrity": "sha512-lKwV/1brpG6mBUFHtb7NUmtABCb2WZZmm2wNiOA5hAb8VdCS4B3dtMWyvcoViccwAW/COERjXLt0zP1zXUN26g==", + "license": "ISC", + "dependencies": { + "brace-expansion": "^2.0.1" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/semver": { + "version": "7.7.3", + "resolved": "https://registry.npmjs.org/semver/-/semver-7.7.3.tgz", + "integrity": "sha512-SdsKMrI9TdgjdweUSR9MweHA4EJ8YxHn8DFaDisvhVlUOe4BF1tLD7GAj0lIqWVl+dPb/rExr0Btby5loQm20Q==", + "license": "ISC", + "bin": { + "semver": "bin/semver.js" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/typescript": { + "version": "5.9.3", + "resolved": "https://registry.npmjs.org/typescript/-/typescript-5.9.3.tgz", + "integrity": "sha512-jl1vZzPDinLr9eUt3J/t7V6FgNEw9QjvBPdysz9KfQDD41fQrC2Y4vKQdiaUpFT4bXlb1RHhLpp8wtm6M5TgSw==", + "dev": true, + "license": "Apache-2.0", + "bin": { + "tsc": "bin/tsc", + "tsserver": "bin/tsserver" + }, + "engines": { + "node": ">=14.17" + } + }, + "node_modules/undici-types": { + "version": "6.21.0", + "resolved": "https://registry.npmjs.org/undici-types/-/undici-types-6.21.0.tgz", + "integrity": "sha512-iwDZqg0QAGrg9Rav5H4n0M64c3mkR59cJ6wQp+7C4nI0gsmExaedaYLNO44eT4AtBBwjbTiGPMlt2Md0T9H9JQ==", + "dev": true, + "license": "MIT" + }, + "node_modules/vscode-jsonrpc": { + "version": "8.2.0", + "resolved": "https://registry.npmjs.org/vscode-jsonrpc/-/vscode-jsonrpc-8.2.0.tgz", + "integrity": "sha512-C+r0eKJUIfiDIfwJhria30+TYWPtuHJXHtI7J0YlOmKAo7ogxP20T0zxB7HZQIFhIyvoBPwWskjxrvAtfjyZfA==", + "license": "MIT", + "engines": { + "node": ">=14.0.0" + } + }, + "node_modules/vscode-languageclient": { + "version": "9.0.1", + "resolved": "https://registry.npmjs.org/vscode-languageclient/-/vscode-languageclient-9.0.1.tgz", + "integrity": "sha512-JZiimVdvimEuHh5olxhxkht09m3JzUGwggb5eRUkzzJhZ2KjCN0nh55VfiED9oez9DyF8/fz1g1iBV3h+0Z2EA==", + "license": "MIT", + "dependencies": { + "minimatch": "^5.1.0", + "semver": "^7.3.7", + "vscode-languageserver-protocol": "3.17.5" + }, + "engines": { + "vscode": "^1.82.0" + } + }, + "node_modules/vscode-languageserver-protocol": { + "version": "3.17.5", + "resolved": "https://registry.npmjs.org/vscode-languageserver-protocol/-/vscode-languageserver-protocol-3.17.5.tgz", + "integrity": "sha512-mb1bvRJN8SVznADSGWM9u/b07H7Ecg0I3OgXDuLdn307rl/J3A9YD6/eYOssqhecL27hK1IPZAsaqh00i/Jljg==", + "license": "MIT", + "dependencies": { + "vscode-jsonrpc": "8.2.0", + "vscode-languageserver-types": "3.17.5" + } + }, + "node_modules/vscode-languageserver-types": { + "version": "3.17.5", + "resolved": "https://registry.npmjs.org/vscode-languageserver-types/-/vscode-languageserver-types-3.17.5.tgz", + "integrity": "sha512-Ld1VelNuX9pdF39h2Hgaeb5hEZM2Z3jUrrMgWQAu82jMtZp7p3vJT3BzToKtZI7NgQssZje5o0zryOrhQvzQAg==", + "license": "MIT" + } + } +} diff --git a/vscode/package.json b/vscode/package.json new file mode 100644 index 0000000000..4c1031c20a --- /dev/null +++ b/vscode/package.json @@ -0,0 +1,178 @@ +{ + "name": "easycrypt-vscode", + "displayName": "EasyCrypt", + "publisher": "easycrypt", + "version": "0.0.1", + "engines": { + "vscode": "^1.85.0" + }, + "categories": ["Programming Languages"], + "activationEvents": [ + "onLanguage:easycrypt", + "onCommand:easycrypt.proof.step", + "onCommand:easycrypt.proof.back", + "onCommand:easycrypt.proof.restart", + "onCommand:easycrypt.proof.jumpToCursor", + "onCommand:easycrypt.proof.goals", + "onCommand:easycrypt.lsp.restart" + ], + "main": "./out/extension.js", + "contributes": { + "languages": [ + { + "id": "easycrypt", + "aliases": ["EasyCrypt", "easycrypt"], + "extensions": [".ec"], + "configuration": "./language-configuration.json" + } + ], + "grammars": [ + { + "language": "easycrypt", + "scopeName": "source.easycrypt", + "path": "./syntaxes/easycrypt.tmLanguage.json" + } + ], + "commands": [ + { + "command": "easycrypt.proof.step", + "title": "Step", + "icon": { "light": "assets/step.svg", "dark": "assets/step.svg" } + }, + { + "command": "easycrypt.proof.back", + "title": "Back", + "icon": { "light": "assets/back.svg", "dark": "assets/back.svg" } + }, + { + "command": "easycrypt.proof.restart", + "title": "Restart", + "icon": { "light": "assets/refresh.svg", "dark": "assets/refresh.svg" } + }, + { + "command": "easycrypt.proof.jumpToCursor", + "title": "Jump To Cursor", + "icon": { "light": "assets/jump.svg", "dark": "assets/jump.svg" } + }, + { + "command": "easycrypt.proof.goals", + "title": "Show Goals", + "icon": { "light": "assets/goals.svg", "dark": "assets/goals.svg" } + }, + { + "command": "easycrypt.lsp.restart", + "title": "Restart LSP" + } + ], + "menus": { + "editor/title": [ + { + "command": "easycrypt.proof.step", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", + "group": "navigation.easycrypt@3" + }, + { + "command": "easycrypt.proof.step", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", + "group": "inline.easycrypt@3" + }, + { + "command": "easycrypt.proof.back", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", + "group": "navigation.easycrypt@1" + }, + { + "command": "easycrypt.proof.back", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", + "group": "inline.easycrypt@1" + }, + { + "command": "easycrypt.proof.jumpToCursor", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", + "group": "navigation.easycrypt@2" + }, + { + "command": "easycrypt.proof.jumpToCursor", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", + "group": "inline.easycrypt@2" + }, + { + "command": "easycrypt.proof.goals", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", + "group": "navigation.easycrypt@4" + }, + { + "command": "easycrypt.proof.goals", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", + "group": "inline.easycrypt@4" + } + ] + }, + "keybindings": [ + { + "command": "easycrypt.proof.step", + "key": "ctrl+alt+down", + "mac": "cmd+alt+down", + "when": "editorLangId == easycrypt" + }, + { + "command": "easycrypt.proof.back", + "key": "ctrl+alt+up", + "mac": "cmd+alt+up", + "when": "editorLangId == easycrypt" + }, + { + "command": "easycrypt.proof.jumpToCursor", + "key": "ctrl+alt+enter", + "mac": "cmd+alt+enter", + "when": "editorLangId == easycrypt" + }, + { + "command": "easycrypt.proof.goals", + "key": "ctrl+alt+g", + "mac": "cmd+alt+g", + "when": "editorLangId == easycrypt" + } + ], + "configuration": { + "title": "EasyCrypt", + "properties": { + "easycrypt.cli.path": { + "type": "string", + "default": "", + "description": "Path to the EasyCrypt CLI (easycrypt or ec.native)." + }, + "easycrypt.cli.args": { + "type": "array", + "items": { "type": "string" }, + "default": [], + "description": "Extra arguments passed to the EasyCrypt CLI when running in proof mode." + }, + "easycrypt.trace.server": { + "type": "string", + "enum": ["off", "messages", "verbose"], + "default": "off", + "description": "Trace LSP communication to the Output panel." + }, + "easycrypt.ui.editorToolbarGroup": { + "type": "string", + "enum": ["navigation", "inline"], + "default": "navigation", + "description": "Editor title toolbar group for EasyCrypt buttons." + } + } + } + }, + "scripts": { + "compile": "tsc -p ./", + "watch": "tsc -w -p ./" + }, + "dependencies": { + "vscode-languageclient": "^9.0.1" + }, + "devDependencies": { + "@types/node": "^20.11.0", + "@types/vscode": "^1.85.0", + "typescript": "^5.3.3" + } +} diff --git a/vscode/package.nls.json b/vscode/package.nls.json new file mode 100644 index 0000000000..2da004d97c --- /dev/null +++ b/vscode/package.nls.json @@ -0,0 +1,3 @@ +{ + "easycrypt.ui.editorToolbarGroup": "Editor title toolbar group for EasyCrypt buttons." +} diff --git a/vscode/src/extension.ts b/vscode/src/extension.ts new file mode 100644 index 0000000000..6c976a03f3 --- /dev/null +++ b/vscode/src/extension.ts @@ -0,0 +1,696 @@ +import * as fs from 'fs'; +import * as path from 'path'; +import * as vscode from 'vscode'; +import { + LanguageClient, + LanguageClientOptions, + ServerOptions, + TransportKind, + Trace +} from 'vscode-languageclient/node'; + +type ProofResponse = { + output: string; + uuid: number; + mode: string; + processedEnd: number; + sentenceStart?: number | null; + sentenceEnd?: number | null; +}; + +type DocState = { + lastOffset: number; +}; + +let client: LanguageClient | undefined; +let clientReady: Promise | undefined; +let clientOptions: LanguageClientOptions | undefined; +let serverOptions: ServerOptions | undefined; +let goalsPanel: vscode.WebviewPanel | undefined; +let outputChannel: vscode.OutputChannel | undefined; +let traceLevel: Trace = Trace.Off; +let lspCommand: string | undefined; +let lspArgs: string[] = []; +let processedDecoration: vscode.TextEditorDecorationType | undefined; +let processingDecoration: vscode.TextEditorDecorationType | undefined; +let errorDecoration: vscode.TextEditorDecorationType | undefined; +let lastEasyCryptEditor: vscode.TextEditor | undefined; +const docStates = new Map(); +let suppressProcessedEdits = false; +let suppressProcessingEdits = false; +let processingDocUri: string | undefined; +let processingSnapshot: string | undefined; +let diagnostics: vscode.DiagnosticCollection | undefined; + +function getDocState(doc: vscode.TextDocument): DocState { + const key = doc.uri.toString(); + const state = docStates.get(key); + if (state) { + return state; + } + const created = { lastOffset: 0 }; + docStates.set(key, created); + return created; +} + +function escapeHtml(value: string): string { + return value + .replace(/&/g, '&') + .replace(//g, '>'); +} + +function showGoals(output: string): void { + if (!goalsPanel) { + goalsPanel = vscode.window.createWebviewPanel( + 'easycryptGoals', + 'EasyCrypt Goals', + { viewColumn: vscode.ViewColumn.Beside, preserveFocus: true }, + { enableFindWidget: true } + ); + goalsPanel.onDidDispose(() => { + goalsPanel = undefined; + }); + } else { + goalsPanel.reveal(goalsPanel.viewColumn, true); + } + + goalsPanel.webview.html = ` + + + + + + + +
${escapeHtml(output)}
+ +`; +} + +function updateProcessedDecoration(editor: vscode.TextEditor | undefined): void { + if (!editor || !processedDecoration) { + return; + } + const state = getDocState(editor.document); + const endOffset = state.lastOffset; + const endPos = editor.document.positionAt(endOffset); + const startPos = new vscode.Position(0, 0); + const anchor = new vscode.Range(startPos, startPos); + const fixed = new vscode.Range(startPos, endPos); + editor.setDecorations(processedDecoration, [anchor, fixed]); +} + +function setProcessingDecoration(editor: vscode.TextEditor | undefined, range: vscode.Range): void { + if (!editor || !processingDecoration) { + return; + } + editor.setDecorations(processingDecoration, [range]); +} + +function clearProcessingDecoration(editor: vscode.TextEditor | undefined): void { + if (!editor || !processingDecoration) { + return; + } + editor.setDecorations(processingDecoration, []); +} + +function setProcessingLock(doc: vscode.TextDocument): void { + processingDocUri = doc.uri.toString(); + processingSnapshot = doc.getText(); +} + +function clearProcessingLock(): void { + processingDocUri = undefined; + processingSnapshot = undefined; +} + +async function restoreProcessingSnapshot(doc: vscode.TextDocument): Promise { + if (!processingSnapshot) { + return; + } + const lastLine = doc.lineAt(doc.lineCount - 1); + const fullRange = new vscode.Range(new vscode.Position(0, 0), lastLine.range.end); + const edit = new vscode.WorkspaceEdit(); + edit.replace(doc.uri, fullRange, processingSnapshot); + await vscode.workspace.applyEdit(edit); +} + +function outputHasError(output: string): boolean { + return /\[error-\d+-\d+\]/.test(output); +} + +function summarizeErrorOutput(output: string): string { + const line = output.split(/\r?\n/).find((entry) => entry.trim().length > 0); + if (!line) { + return 'EasyCrypt reported an error.'; + } + const cleaned = line.replace(/\[error-\d+-\d+\]/g, '').trim(); + return cleaned.length > 0 ? cleaned : 'EasyCrypt reported an error.'; +} + +function showGoalsOrError(output: string): void { + if (output.trim().length > 0) { + showGoals(output); + } else { + showGoals('EasyCrypt reported an error.'); + } +} + +function parseErrorTag(output: string): { start: number; end: number; message: string } | undefined { + const match = output.match(/\[error-(\d+)-(\d+)\]/); + if (!match) { + return undefined; + } + const start = Number(match[1]); + const end = Number(match[2]); + if (!Number.isFinite(start) || !Number.isFinite(end)) { + return undefined; + } + const message = output.replace(match[0], '').trim(); + return { start, end, message: message.length > 0 ? message : 'EasyCrypt reported an error.' }; +} + +function clearErrorDecoration(editor: vscode.TextEditor | undefined): void { + if (!editor || !errorDecoration) { + return; + } + editor.setDecorations(errorDecoration, []); +} + +function clearDiagnostics(doc: vscode.TextDocument): void { + diagnostics?.delete(doc.uri); +} + +function showErrorDecoration( + editor: vscode.TextEditor | undefined, + sentenceOffset: number, + errorStart: number, + errorEnd: number +): void { + if (!editor || !errorDecoration) { + return; + } + const start = editor.document.positionAt(sentenceOffset + errorStart); + const end = editor.document.positionAt(sentenceOffset + Math.max(errorStart + 1, errorEnd)); + editor.setDecorations(errorDecoration, [new vscode.Range(start, end)]); +} + +function handleProofError( + output: string, + editor: vscode.TextEditor | undefined, + sentenceOffset?: number +): void { + const parsed = parseErrorTag(output); + if (parsed && sentenceOffset !== undefined) { + showErrorDecoration(editor, sentenceOffset, parsed.start, parsed.end); + showGoals(parsed.message); + if (editor && diagnostics) { + const doc = editor.document; + const start = doc.positionAt(sentenceOffset + parsed.start); + const end = doc.positionAt(sentenceOffset + Math.max(parsed.start + 1, parsed.end)); + const range = new vscode.Range(start, end); + const diag = new vscode.Diagnostic(range, parsed.message, vscode.DiagnosticSeverity.Error); + diagnostics.set(doc.uri, [diag]); + } + } else { + showGoalsOrError(output.replace(/\[error-\d+-\d+\]/g, '').trim()); + } +} + +function getEditorForCommand(): vscode.TextEditor | undefined { + const active = vscode.window.activeTextEditor; + if (active && active.document.languageId === 'easycrypt') { + return active; + } + return lastEasyCryptEditor; +} + +async function requestProof(method: string, params: Record): Promise { + if (!client) { + throw new Error('EasyCrypt language client is not running.'); + } + if (clientReady) { + await clientReady; + } + const start = Date.now(); + outputChannel?.appendLine(`[proof] request ${method}`); + const timeout = setTimeout(() => { + outputChannel?.appendLine(`[proof] waiting ${method} >3s`); + }, 3000); + try { + const result = await client.sendRequest(method, params); + const elapsed = Date.now() - start; + outputChannel?.appendLine(`[proof] response ${method} ${elapsed}ms`); + return result; + } catch (err) { + const elapsed = Date.now() - start; + outputChannel?.appendLine(`[proof] error ${method} ${elapsed}ms ${String(err)}`); + throw err; + } finally { + clearTimeout(timeout); + } +} + +async function handleStep(): Promise { + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + + const doc = editor.document; + const state = getDocState(doc); + const previousOffset = state.lastOffset; + let sentenceStart: number | null | undefined; + let sentenceEnd: number | null | undefined; + let previewProcessedEnd = state.lastOffset; + try { + const preview = await requestProof('easycrypt/proof/next', { uri: doc.uri.toString() }); + sentenceStart = preview.sentenceStart ?? null; + sentenceEnd = preview.sentenceEnd ?? null; + previewProcessedEnd = preview.processedEnd; + } catch (err) { + outputChannel?.appendLine(`[proof] step preview failed ${String(err)}`); + } + + if (sentenceStart == null || sentenceEnd == null) { + state.lastOffset = previewProcessedEnd; + updateProcessedDecoration(editor); + return; + } + + if (sentenceStart != null && sentenceEnd != null) { + const processingRange = new vscode.Range( + doc.positionAt(sentenceStart), + doc.positionAt(sentenceEnd) + ); + setProcessingDecoration(editor, processingRange); + setProcessingLock(doc); + } + + try { + const result = await requestProof('easycrypt/proof/step', { uri: doc.uri.toString() }); + outputChannel?.appendLine(`[proof] step ok uuid=${result.uuid} mode=${result.mode}`); + state.lastOffset = result.processedEnd; + if (outputHasError(result.output)) { + outputChannel?.appendLine(`[proof] step reported error ${result.output}`); + if (result.sentenceStart != null) { + handleProofError(result.output, editor, result.sentenceStart); + } else { + handleProofError(result.output, editor, previousOffset); + } + } else { + showGoals(result.output); + updateProcessedDecoration(editor); + clearErrorDecoration(editor); + clearDiagnostics(editor.document); + } + } catch (err) { + outputChannel?.appendLine(`[proof] step failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt step failed: ${String(err)}`); + } finally { + clearProcessingDecoration(editor); + clearProcessingLock(); + } +} + +async function handleSendRegion(): Promise { + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + + const doc = editor.document; + const state = getDocState(doc); + const cursorOffset = doc.offsetAt(editor.selection.active); + try { + outputChannel?.appendLine('[proof] jumpToCursor'); + const result = await requestProof('easycrypt/proof/jumpTo', { + uri: doc.uri.toString(), + target: cursorOffset + }); + outputChannel?.appendLine(`[proof] jumpToCursor ok uuid=${result.uuid} mode=${result.mode}`); + state.lastOffset = result.processedEnd; + if (outputHasError(result.output)) { + outputChannel?.appendLine(`[proof] jumpToCursor reported error ${result.output}`); + if (result.sentenceStart != null) { + handleProofError(result.output, editor, result.sentenceStart); + } else { + handleProofError(result.output, editor, state.lastOffset); + } + return; + } + showGoals(result.output); + updateProcessedDecoration(editor); + clearErrorDecoration(editor); + clearDiagnostics(doc); + } catch (err) { + outputChannel?.appendLine(`[proof] jumpToCursor failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt jump-to-cursor failed: ${String(err)}`); + } finally { + clearProcessingDecoration(editor); + clearProcessingLock(); + } +} + +async function handleBack(): Promise { + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + + const state = getDocState(editor.document); + try { + outputChannel?.appendLine('[proof] back'); + const result = await requestProof('easycrypt/proof/back', { + uri: editor.document.uri.toString() + }); + if (outputHasError(result.output)) { + outputChannel?.appendLine(`[proof] back reported error ${result.output}`); + if (result.sentenceStart != null) { + handleProofError(result.output, editor, result.sentenceStart); + } else { + handleProofError(result.output, editor); + } + } else { + state.lastOffset = result.processedEnd; + outputChannel?.appendLine(`[proof] back ok uuid=${result.uuid} mode=${result.mode}`); + showGoals(result.output); + updateProcessedDecoration(editor); + clearErrorDecoration(editor); + clearDiagnostics(editor.document); + } + } catch (err) { + outputChannel?.appendLine(`[proof] back failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt back failed: ${String(err)}`); + } +} + +async function handleRestart(): Promise { + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + const state = editor ? getDocState(editor.document) : undefined; + const previousOffset = state?.lastOffset ?? 0; + + try { + outputChannel?.appendLine('[proof] restart'); + const result = await requestProof('easycrypt/proof/restart', { + uri: editor.document.uri.toString() + }); + outputChannel?.appendLine(`[proof] restart ok uuid=${result.uuid} mode=${result.mode}`); + if (outputHasError(result.output)) { + outputChannel?.appendLine(`[proof] restart reported error ${result.output}`); + handleProofError(result.output, editor); + if (state) { + state.lastOffset = previousOffset; + } + } else { + if (state) { + state.lastOffset = result.processedEnd; + } + showGoals(result.output); + updateProcessedDecoration(editor ?? vscode.window.activeTextEditor); + clearErrorDecoration(editor ?? vscode.window.activeTextEditor); + if (editor) { + clearDiagnostics(editor.document); + } + } + } catch (err) { + outputChannel?.appendLine(`[proof] restart failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt restart failed: ${String(err)}`); + } +} + +async function handleGoals(): Promise { + try { + outputChannel?.appendLine('[proof] goals'); + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + const result = await requestProof('easycrypt/proof/goals', { + uri: editor.document.uri.toString() + }); + outputChannel?.appendLine(`[proof] goals ok uuid=${result.uuid} mode=${result.mode}`); + showGoals(result.output); + } catch (err) { + outputChannel?.appendLine(`[proof] goals failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt goals failed: ${String(err)}`); + } +} + +function resolveServerCommand( + workspaceFolder: string | undefined, + cliPath: string +): string | undefined { + if (cliPath && cliPath.trim().length > 0) { + return cliPath; + } + + if (!workspaceFolder) { + return undefined; + } + + const exeCandidate = path.join(workspaceFolder, '_build', 'default', 'src', 'ec.exe'); + const unixCandidate = path.join(workspaceFolder, '_build', 'default', 'src', 'ec'); + if (fs.existsSync(exeCandidate)) { + return exeCandidate; + } + if (fs.existsSync(unixCandidate)) { + return unixCandidate; + } + + return undefined; +} + +function ensureLspArgs(args: string[]): string[] { + if (args.length > 0 && args[0] === 'lsp') { + return args; + } + return ['lsp', ...args]; +} + +function startClient(): void { + if (!clientOptions || !serverOptions) { + throw new Error('EasyCrypt LSP options are not configured.'); + } + outputChannel?.appendLine(`[lsp] spawn command=${lspCommand ?? ''} args=${lspArgs.join(' ')}`); + client = new LanguageClient('easycryptLsp', 'EasyCrypt LSP', serverOptions, clientOptions); + outputChannel?.appendLine('[lsp] starting client'); + clientReady = client.start(); + void clientReady.then( + () => outputChannel?.appendLine('[lsp] client ready'), + (err) => outputChannel?.appendLine(`[lsp] client start failed ${String(err)}`) + ); + void clientReady.then(() => client?.setTrace(traceLevel)); +} + +async function restartClient(): Promise { + if (!serverOptions || !clientOptions) { + vscode.window.showErrorMessage('EasyCrypt: LSP options are not configured.'); + return; + } + const current = client; + if (current) { + try { + await current.stop(); + } catch (err) { + vscode.window.showWarningMessage(`EasyCrypt: failed to stop LSP (${String(err)}).`); + } + } + startClient(); + outputChannel?.appendLine('[lsp] restarted client'); + vscode.window.showInformationMessage('EasyCrypt: LSP restarted.'); +} + +export function activate(context: vscode.ExtensionContext): void { + outputChannel = vscode.window.createOutputChannel('EasyCrypt'); + context.subscriptions.push(outputChannel); + processedDecoration = vscode.window.createTextEditorDecorationType({ + backgroundColor: 'rgba(120, 140, 180, 0.18)', + isWholeLine: false, + rangeBehavior: vscode.DecorationRangeBehavior.ClosedClosed + }); + context.subscriptions.push(processedDecoration); + processingDecoration = vscode.window.createTextEditorDecorationType({ + backgroundColor: 'rgba(210, 170, 90, 0.28)', + isWholeLine: false + }); + context.subscriptions.push(processingDecoration); + + diagnostics = vscode.languages.createDiagnosticCollection('easycrypt'); + context.subscriptions.push(diagnostics); + + errorDecoration = undefined; + + const workspaceFolder = vscode.workspace.workspaceFolders?.[0]?.uri.fsPath; + const config = vscode.workspace.getConfiguration('easycrypt'); + const cliPath = config.get('cli.path') ?? ''; + const serverCommand = resolveServerCommand(workspaceFolder, cliPath) ?? 'easycrypt'; + const cliArgs = config.get('cli.args') ?? []; + const serverArgs = ensureLspArgs(cliArgs); + lspCommand = serverCommand; + lspArgs = serverArgs; + const traceSetting = config.get('trace.server') ?? 'off'; + traceLevel = + traceSetting === 'verbose' + ? Trace.Verbose + : traceSetting === 'messages' + ? Trace.Messages + : Trace.Off; + + outputChannel.appendLine(`[lsp] serverCommand=${serverCommand}`); + outputChannel.appendLine(`[lsp] cliPath=${cliPath || '(default)'}`); + outputChannel.appendLine(`[lsp] cliArgs=${cliArgs.join(' ')}`); + outputChannel.appendLine(`[lsp] serverArgs=${serverArgs.join(' ')}`); + outputChannel.appendLine(`[lsp] trace=${traceSetting}`); + outputChannel.appendLine( + `[lsp] logFile=${workspaceFolder ? path.join(workspaceFolder, '.easycrypt-lsp.log') : '(inherit)'}` + ); + outputChannel.show(true); + + if (!resolveServerCommand(workspaceFolder, cliPath)) { + vscode.window.showWarningMessage( + "EasyCrypt binary not found in the workspace. Using 'easycrypt' from PATH." + ); + } + + const lspEnv = { + ...process.env, + EASYCRYPT_LSP_LOG: workspaceFolder + ? path.join(workspaceFolder, '.easycrypt-lsp.log') + : process.env.EASYCRYPT_LSP_LOG + }; + const localServerOptions: ServerOptions = { + command: serverCommand, + args: serverArgs, + transport: TransportKind.stdio, + options: { env: lspEnv } + }; + + const localClientOptions: LanguageClientOptions = { + documentSelector: [{ language: 'easycrypt' }], + outputChannel, + traceOutputChannel: outputChannel + }; + + serverOptions = localServerOptions; + clientOptions = localClientOptions; + startClient(); + context.subscriptions.push( + new vscode.Disposable(() => { + outputChannel?.appendLine('[lsp] stopping client'); + void client?.stop(); + }) + ); + if (client) { + client.onDidChangeState((event) => { + outputChannel?.appendLine(`[lsp] state ${event.oldState} -> ${event.newState}`); + }); + } + + context.subscriptions.push( + vscode.commands.registerCommand('easycrypt.proof.step', handleStep), + vscode.commands.registerCommand('easycrypt.proof.back', handleBack), + vscode.commands.registerCommand('easycrypt.proof.restart', handleRestart), + vscode.commands.registerCommand('easycrypt.proof.jumpToCursor', handleSendRegion), + vscode.commands.registerCommand('easycrypt.proof.goals', handleGoals), + vscode.commands.registerCommand('easycrypt.lsp.restart', restartClient) + ); + + context.subscriptions.push( + vscode.workspace.onDidCloseTextDocument((doc) => { + docStates.delete(doc.uri.toString()); + }) + ); + + context.subscriptions.push( + vscode.workspace.onDidChangeTextDocument(async (event) => { + if (suppressProcessedEdits || suppressProcessingEdits) { + return; + } + if (event.contentChanges.length === 0) { + return; + } + const doc = event.document; + if (doc.languageId !== 'easycrypt') { + return; + } + if (processingDocUri && processingDocUri === doc.uri.toString()) { + suppressProcessingEdits = true; + try { + await restoreProcessingSnapshot(doc); + } catch (err) { + outputChannel?.appendLine(`[proof] processing lock restore failed ${String(err)}`); + } finally { + suppressProcessingEdits = false; + } + return; + } + clearErrorDecoration(vscode.window.activeTextEditor); + clearDiagnostics(doc); + const state = getDocState(doc); + const limit = state.lastOffset; + const earliestStart = event.contentChanges.reduce((min, change) => { + const start = change.range ? doc.offsetAt(change.range.start) : 0; + return Math.min(min, start); + }, Number.POSITIVE_INFINITY); + if (!(earliestStart < limit)) { + return; + } + suppressProcessedEdits = true; + try { + try { + const result = await requestProof('easycrypt/proof/jumpTo', { + uri: doc.uri.toString(), + target: earliestStart + }); + state.lastOffset = result.processedEnd; + } catch (err) { + outputChannel?.appendLine(`[proof] auto-rewind failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt auto-rewind failed: ${String(err)}`); + } + updateProcessedDecoration(vscode.window.activeTextEditor); + } finally { + suppressProcessedEdits = false; + } + return; + }) + ); + + const updateEditorState = (editor: vscode.TextEditor | undefined) => { + if (editor && editor.document.languageId === 'easycrypt') { + lastEasyCryptEditor = editor; + } + updateProcessedDecoration(editor); + clearErrorDecoration(editor); + if (editor) { + clearDiagnostics(editor.document); + } + }; + + updateEditorState(vscode.window.activeTextEditor); + + context.subscriptions.push( + vscode.window.onDidChangeActiveTextEditor((editor) => { + updateEditorState(editor); + }) + ); + +} + +export async function deactivate(): Promise { + if (client) { + await client.stop(); + } +} diff --git a/vscode/syntaxes/easycrypt.tmLanguage.json b/vscode/syntaxes/easycrypt.tmLanguage.json new file mode 100644 index 0000000000..af025d0dce --- /dev/null +++ b/vscode/syntaxes/easycrypt.tmLanguage.json @@ -0,0 +1,101 @@ +{ + "$schema": "https://raw.githubusercontent.com/martinring/tmlanguage/master/tmlanguage.json", + "name": "EasyCrypt", + "scopeName": "source.easycrypt", + "patterns": [ + { "include": "#comments" }, + { "include": "#strings" }, + { "include": "#keywords" }, + { "include": "#types" }, + { "include": "#numbers" } + ], + "repository": { + "comments": { + "patterns": [ + { + "name": "comment.block.easycrypt", + "begin": "\\(\\*", + "beginCaptures": { + "0": { "name": "punctuation.definition.comment.easycrypt" } + }, + "end": "\\*\\)", + "endCaptures": { + "0": { "name": "punctuation.definition.comment.easycrypt" } + }, + "patterns": [ + { "include": "#comments" } + ] + } + ] + }, + "strings": { + "patterns": [ + { + "name": "string.quoted.double.easycrypt", + "begin": "\"", + "beginCaptures": { + "0": { "name": "punctuation.definition.string.begin.easycrypt" } + }, + "end": "\"", + "endCaptures": { + "0": { "name": "punctuation.definition.string.end.easycrypt" } + }, + "patterns": [ + { + "name": "constant.character.escape.easycrypt", + "match": "\\\\." + } + ] + } + ] + }, + "keywords": { + "patterns": [ + { + "name": "keyword.other.easycrypt.bytac", + "match": "\\b(assumption|by|check|coq|done|edit|exact|fix|reflexivity|smt|solve)\\b" + }, + { + "name": "keyword.other.easycrypt.dangerous", + "match": "\\b(admit|admitted)\\b" + }, + { + "name": "keyword.control.easycrypt.global", + "match": "\\b(Pr|Self|Top|abbrev|abort|abstract|as|axiom|axiomatized|class|clone|const|declare|dump|end|exit|export|from|global|goal|hint|import|include|inductive|instance|lemma|local|locate|module|notation|of|op|pred|print|proof|prover|qed|realize|remove|rename|require|search|section|subtype|theory|timeout|type|why3|with)\\b" + }, + { + "name": "keyword.other.easycrypt.internal", + "match": "\\b(debug|fail|pragma|time|undo)\\b" + }, + { + "name": "keyword.operator.easycrypt.prog", + "match": "\\b(assert|async|ehoare|elif|else|equiv|exists|for|for|forall|fun|glob|hoare|if|in|is|islossless|let|match|match|phoare|proc|res|return|then|var|while)\\b" + }, + { + "name": "keyword.control.easycrypt.tactic", + "match": "\\b(algebra|alias|apply|auto|beta|byehoare|byequiv|byphoare|bypr|byupto|call|case|cbv|cfold|change|clear|congr|conseq|delta|eager|ecall|elim|eta|exfalso|exlim|fel|field|fieldeq|fission|fusion|gen|have|idassign|idtac|inline|interleave|iota|kill|left|logic|modpath|move|outline|pose|pr_bounded|progress|rcondf|rcondt|replace|rewrite|right|ring|ringeq|rnd|rndsem|rwnormal|seq|sim|simplify|skip|sp|split|splitwhile|subst|suff|swap|symmetry|transitivity|trivial|unroll|weakmem|wlog|wp|zeta)\\b" + }, + { + "name": "keyword.control.easycrypt.tactical", + "match": "\\b(do|expect|first|last|try)\\b" + } + ] + }, + "types": { + "patterns": [ + { + "name": "storage.type.easycrypt", + "match": "\\b(bool|int|real|unit)\\b" + } + ] + }, + "numbers": { + "patterns": [ + { + "name": "constant.numeric.easycrypt", + "match": "\\b\\d+(?:\\.\\d+)?\\b" + } + ] + } + } +} diff --git a/vscode/tsconfig.json b/vscode/tsconfig.json new file mode 100644 index 0000000000..6da6eaa6cf --- /dev/null +++ b/vscode/tsconfig.json @@ -0,0 +1,13 @@ +{ + "compilerOptions": { + "target": "ES2020", + "module": "commonjs", + "lib": ["ES2020"], + "outDir": "out", + "rootDir": "src", + "sourceMap": true, + "strict": true, + "esModuleInterop": true + }, + "include": ["src"] +} From 62cbd2d6581f93773fa827251aa6d192c6c382bc Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Wed, 21 Jan 2026 13:58:01 +0100 Subject: [PATCH 043/145] LSP --- dune-project | 4 + easycrypt.opam | 4 + src/dune | 5 +- src/ec.ml | 6 + src/ecIo.ml | 47 +- src/ecIo.mli | 1 + src/ecLsp.ml | 777 ++++++++++++++++ src/ecLsp.mli | 1 + src/ecOptions.ml | 14 + src/ecOptions.mli | 1 + src/ecTerminal.ml | 2 +- vscode/.gitignore | 2 + vscode/README.md | 46 + vscode/assets/back.svg | 3 + vscode/assets/easycrypt.svg | 5 + vscode/assets/goals.svg | 4 + vscode/assets/jump.svg | 3 + vscode/assets/refresh.svg | 3 + vscode/assets/step.svg | 3 + vscode/language-configuration.json | 23 + vscode/package-lock.json | 139 +++ vscode/package.json | 226 +++++ vscode/package.nls.json | 3 + vscode/src/extension.ts | 1020 +++++++++++++++++++++ vscode/syntaxes/easycrypt.tmLanguage.json | 101 ++ vscode/tsconfig.json | 13 + 26 files changed, 2448 insertions(+), 8 deletions(-) create mode 100644 src/ecLsp.ml create mode 100644 src/ecLsp.mli create mode 100644 vscode/.gitignore create mode 100644 vscode/README.md create mode 100644 vscode/assets/back.svg create mode 100644 vscode/assets/easycrypt.svg create mode 100644 vscode/assets/goals.svg create mode 100644 vscode/assets/jump.svg create mode 100644 vscode/assets/refresh.svg create mode 100644 vscode/assets/step.svg create mode 100644 vscode/language-configuration.json create mode 100644 vscode/package-lock.json create mode 100644 vscode/package.json create mode 100644 vscode/package.nls.json create mode 100644 vscode/src/extension.ts create mode 100644 vscode/syntaxes/easycrypt.tmLanguage.json create mode 100644 vscode/tsconfig.json diff --git a/dune-project b/dune-project index 85f142616e..435605d30e 100644 --- a/dune-project +++ b/dune-project @@ -19,6 +19,10 @@ dune dune-build-info dune-site + fmt + logs + lsp + lwt markdown (pcre2 (>= 8)) (why3 (and (>= 1.8.0) (< 1.9))) diff --git a/easycrypt.opam b/easycrypt.opam index 08bdb40eac..92b556b975 100644 --- a/easycrypt.opam +++ b/easycrypt.opam @@ -7,6 +7,10 @@ depends: [ "dune" {>= "3.13"} "dune-build-info" "dune-site" + "fmt" + "logs" + "lsp" + "lwt" "markdown" "pcre2" {>= "8"} "why3" {>= "1.8.0" & < "1.9"} diff --git a/src/dune b/src/dune index 487e9cfcf5..53c3a9b40d 100644 --- a/src/dune +++ b/src/dune @@ -16,7 +16,7 @@ (public_name easycrypt.ecLib) (foreign_stubs (language c) (names eunix)) (modules :standard \ ec) - (libraries batteries camlp-streams dune-build-info dune-site inifiles markdown markdown.html pcre2 tyxml why3 yojson zarith) + (libraries batteries camlp-streams dune-build-info dune-site inifiles logs logs.fmt lsp lwt lwt.unix markdown markdown.html pcre2 tyxml why3 yojson zarith) ) (executable @@ -24,7 +24,8 @@ (name ec) (modules ec) (promote (until-clean)) - (libraries batteries camlp-streams dune-build-info dune-site inifiles pcre2 why3 yojson zarith ecLib)) + (libraries batteries ecLib) +) (ocamllex ecLexer) diff --git a/src/ec.ml b/src/ec.ml index 627d25b81b..6820fcf17f 100644 --- a/src/ec.ml +++ b/src/ec.ml @@ -214,6 +214,9 @@ let main () = (* Execution of eager commands *) begin match options.o_command with + | `Lsp -> + EcLsp.run (); + exit 0 | `Runtest input -> begin let root = match EcRelocate.sourceroot with @@ -535,6 +538,9 @@ let main () = | `Runtest _ -> (* Eagerly executed *) assert false + | `Lsp -> + (* Eagerly executed *) + assert false | `DocGen docopts -> begin let name = docopts.doco_input in diff --git a/src/ecIo.ml b/src/ecIo.ml index 016545d85c..d6fd6f498f 100644 --- a/src/ecIo.ml +++ b/src/ecIo.ml @@ -96,14 +96,15 @@ let from_string data = let finalize (ecreader : ecreader) = Disposable.dispose ecreader +(* -------------------------------------------------------------------- *) +let isfinal_token = function + | EcParser.FINAL _ -> true + | _ -> false + (* -------------------------------------------------------------------- *) let lexer ?(checkpoint : _ I.checkpoint option) (ecreader : ecreader_r) = let lexbuf = ecreader.ecr_lexbuf in - let isfinal = function - | EcParser.FINAL _ -> true - | _ -> false in - if ecreader.ecr_atstart then ecreader.ecr_trim <- ecreader.ecr_lexbuf.Lexing.lex_curr_p.pos_cnum; @@ -134,7 +135,7 @@ let lexer ?(checkpoint : _ I.checkpoint option) (ecreader : ecreader_r) = ecreader.ecr_tokens <- prequeue @ queue; - if isfinal token then + if isfinal_token token then ecreader.ecr_atstart <- true else ecreader.ecr_atstart <- ecreader.ecr_atstart && ( @@ -177,6 +178,42 @@ let parse (ecreader : ecreader) : EcParsetree.prog = in parse (EcParser.Incremental.prog ecreader.ecr_lexbuf.lex_curr_p) +(* -------------------------------------------------------------------- *) +let next_sentence_from (text : string) (start : int) : (string * int * int) option = + let len = String.length text in + if start < 0 || start >= len then + None + else + let sub = String.sub text start (len - start) in + let reader = from_string sub in + let ecr = Disposable.get reader in + + let exception EOF in + + Fun.protect + ~finally:(fun () -> finalize reader) + (fun () -> + try + begin + let exception Done in + + try + while true do + match proj3_1 (lexer ecr) with + | EcParser.FINAL _ -> raise Done + | EcParser.EOF -> raise EOF + | _ -> () + done + with Done -> () + end; + + let p = ecr.ecr_lexbuf.Lexing.lex_curr_p.pos_cnum - 1 in + let s = String.sub sub 0 p in + + Some (s, start, start + p) + with + | EcLexer.LexicalError _ | EOF -> None) + (* -------------------------------------------------------------------- *) let xparse (ecreader : ecreader) : string * EcParsetree.prog = let ecr = Disposable.get ecreader in diff --git a/src/ecIo.mli b/src/ecIo.mli index 42d28ba740..f69a371b66 100644 --- a/src/ecIo.mli +++ b/src/ecIo.mli @@ -13,6 +13,7 @@ val parse : ecreader -> EcParsetree.prog val parseall : ecreader -> EcParsetree.global list val drain : ecreader -> unit val lexbuf : ecreader -> Lexing.lexbuf +val next_sentence_from : string -> int -> (string * int * int) option (* -------------------------------------------------------------------- *) val lex_single_token : string -> EcParser.token option diff --git a/src/ecLsp.ml b/src/ecLsp.ml new file mode 100644 index 0000000000..6dde77b4df --- /dev/null +++ b/src/ecLsp.ml @@ -0,0 +1,777 @@ +open Lwt.Syntax + +module Json = Yojson.Safe +module J = Yojson.Safe.Util + +module Lsp_io = + Lsp.Io.Make + (struct + type 'a t = 'a Lwt.t + + let return = Lwt.return + let raise = Lwt.fail + + module O = struct + let ( let+ ) x f = Lwt.map f x + let ( let* ) x f = Lwt.bind x f + end + end) + (struct + type input = Lwt_io.input_channel + type output = Lwt_io.output_channel + + let read_line ic = Lwt_io.read_line_opt ic + + let read_exactly ic len = + let rec loop acc remaining = + if remaining <= 0 then + Lwt.return (Some (Buffer.contents acc)) + else + Lwt.bind (Lwt_io.read ~count:remaining ic) (fun s -> + if s = "" then + Lwt.return None + else ( + Buffer.add_string acc s; + loop acc (remaining - String.length s) + )) + in + loop (Buffer.create len) len + + let write oc chunks = + Lwt.bind (Lwt_list.iter_s (Lwt_io.write oc) chunks) (fun () -> + Lwt_io.flush oc) + end) + +let setup_logging () : unit = + let reporter = + match Sys.getenv_opt "EASYCRYPT_LSP_LOG" with + | None -> Logs_fmt.reporter () + | Some path -> ( + try + let oc = + open_out_gen [ Open_creat; Open_text; Open_append ] 0o644 path + in + Logs_fmt.reporter ~dst:(Format.formatter_of_out_channel oc) () + with e -> + prerr_endline ("[easycrypt-lsp] failed to open log file: " ^ Printexc.to_string e); + Logs_fmt.reporter ()) + in + Logs.set_reporter reporter; + Logs.set_level (Some Logs.Info) + +let log (fmt : ('a, Format.formatter, unit, unit) format4) = + Format.kasprintf (fun msg -> Logs.info (fun m -> m "%s" msg)) fmt + +module Easycrypt_cli = struct + type session = { + proc : Lwt_process.process; + mutable uuid : int; + mutable mode : string; + mutable last_output : string; + root_uuid : int; + } + + type config = { + mutable cli_path : string; + mutable cli_args : string list; + } + + let prompt_re : Pcre2.regexp = + Pcre2.regexp "\\[([0-9]+)\\|([^\\]]+)\\]>" + + let parse_prompt (line : string) : (int * string) option = + try + let subs = Pcre2.exec ~rex:prompt_re line in + let uuid_str = Pcre2.get_substring subs 1 in + let mode = Pcre2.get_substring subs 2 in + Some (int_of_string uuid_str, mode) + with + | Not_found -> None + | Pcre2.Error _ -> None + + let default_cli_path () : string = + if Sys.file_exists "ec.native" then + "./ec.native" + else + "easycrypt" + + let read_until_prompt (sess : session) : string Lwt.t = + let buf = Buffer.create 256 in + let rec loop () = + let* line_opt = Lwt_io.read_line_opt sess.proc#stdout in + match line_opt with + | None -> Lwt.return (Buffer.contents buf) + | Some line -> + log "cli + sess.uuid <- uuid; + sess.mode <- mode; + Lwt.return (Buffer.contents buf) + | None -> + Buffer.add_string buf line; + Buffer.add_char buf '\n'; + loop ()) + in + loop () + + let start_session (cfg : config) : session Lwt.t = + let argv = + let args = "cli" :: "-emacs" :: cfg.cli_args in + Array.of_list (cfg.cli_path :: args) + in + let proc = Lwt_process.open_process (cfg.cli_path, argv) in + let sess = + { proc + ; uuid = 0 + ; mode = "" + ; last_output = "" + ; root_uuid = 0 + } + in + let* _initial_output = read_until_prompt sess in + Lwt.return { sess with root_uuid = sess.uuid } + + let send_command ?(record_last_output = true) (sess : session) (text : string) : string Lwt.t = + log "cli> %s" (String.trim text); + let write = + if String.ends_with ~suffix:"\n" text then + Lwt_io.write sess.proc#stdin text + else + Lwt_io.write_line sess.proc#stdin text + in + let* () = write in + let* () = Lwt_io.flush sess.proc#stdin in + let* output = read_until_prompt sess in + if record_last_output then + sess.last_output <- output; + let preview = + if String.length output = 0 then "" + else if String.length output <= 200 then String.escaped output + else String.escaped (String.sub output 0 200) ^ "..." + in + log "cli< (%d bytes) %s" (String.length output) preview; + Lwt.return output + + let send_undo (sess : session) (target_uuid : int) : string Lwt.t = + let cmd = Printf.sprintf "undo %d." target_uuid in + send_command sess cmd + + let stop_session (sess : session) : unit Lwt.t = + let close_chan ch = Lwt.catch (fun () -> Lwt_io.close ch) (fun _ -> Lwt.return_unit) in + let* () = close_chan sess.proc#stdin in + let* () = close_chan sess.proc#stdout in + sess.proc#terminate; + let* _status = sess.proc#status in + Lwt.return_unit + +end + +type doc_state = { + mutable text : BatText.t; + mutable last_offset : int; + mutable history : (int * int) list; + mutable session : Easycrypt_cli.session option; +} + +let doc_states : (string, doc_state) Hashtbl.t = Hashtbl.create 16 + +let get_doc_state (uri : string) : doc_state = + match Hashtbl.find_opt doc_states uri with + | Some state -> state + | None -> + let created = { text = BatText.empty; last_offset = 0; history = []; session = None } in + Hashtbl.add doc_states uri created; + created + +let error_tag_re : Pcre2.regexp = + Pcre2.regexp "\\[error-\\d+-\\d+\\]" + +let output_has_error (output : string) : bool = + Pcre2.pmatch ~rex:error_tag_re output + +let find_next_sentence + (text : BatText.t) + (start : int) : (string * int * int) option = + EcIo.next_sentence_from (BatText.to_string text) start + +let position_to_offset (text : BatText.t) (pos : Lsp.Types.Position.t) : int = + let len = BatText.length text in + let target_line = pos.Lsp.Types.Position.line in + let target_col = pos.Lsp.Types.Position.character in + let newline = BatUChar.of_char '\n' in + let rec find_line_start line current = + if line <= 0 then + current + else + try + let idx = BatText.index_from text current newline in + find_line_start (line - 1) (min (idx + 1) len) + with + | Not_found -> len + | BatText.Out_of_bounds -> len + in + let line_start = find_line_start target_line 0 in + if line_start >= len then + len + else + let offset = line_start + target_col in + if offset > len then len else offset + +let apply_change + (text : BatText.t) + (change : Lsp.Types.TextDocumentContentChangeEvent.t) : BatText.t * int = + match change.Lsp.Types.TextDocumentContentChangeEvent.range with + | None -> + BatText.of_string change.Lsp.Types.TextDocumentContentChangeEvent.text, 0 + | Some range -> + let start_offset = position_to_offset text range.Lsp.Types.Range.start in + let end_offset = position_to_offset text range.Lsp.Types.Range.end_ in + let len = BatText.length text in + let start_offset = max 0 (min start_offset len) in + let end_offset = max start_offset (min end_offset len) in + let removed = BatText.remove start_offset (end_offset - start_offset) text in + let inserted = BatText.of_string change.Lsp.Types.TextDocumentContentChangeEvent.text in + (BatText.insert start_offset inserted removed, start_offset) + +let json_of_proof_response + ~(sess : Easycrypt_cli.session) + ~(doc : doc_state) + ?sentence + (output : string) : Json.t = + let sentence_start, sentence_end = + match sentence with + | None -> (`Null, `Null) + | Some (start, end_) -> (`Int start, `Int end_) + in + `Assoc + [ ("output", `String output) + ; ("uuid", `Int sess.uuid) + ; ("mode", `String sess.mode) + ; ("processedEnd", `Int doc.last_offset) + ; ("sentenceStart", sentence_start) + ; ("sentenceEnd", sentence_end) + ] + +let json_of_query_response (output : string) : Json.t = + `Assoc [ ("output", `String output) ] + +let rstrip (s : string) : string = + let rec find i = + if i < 0 then + -1 + else + match s.[i] with + | ' ' | '\t' | '\r' | '\n' -> find (i - 1) + | _ -> i + in + let last = find (String.length s - 1) in + if last < 0 then "" else String.sub s 0 (last + 1) + +let strip_trailing_goal (output : string) (goal : string) : string = + let output_trimmed = rstrip output in + let goal_trimmed = rstrip goal in + if goal_trimmed = "" || output_trimmed = goal_trimmed then + output_trimmed + else if String.ends_with ~suffix:goal_trimmed output_trimmed then + let prefix_len = String.length output_trimmed - String.length goal_trimmed in + rstrip (String.sub output_trimmed 0 prefix_len) + else + output_trimmed + +type proof_command_kind = + | Proof_next + | Proof_step + | Proof_jump_to of int + | Proof_back + | Proof_restart + | Proof_goals + | Query_print of string + | Query_locate of string + | Query_search of string + +type proof_command = + { uri : string + ; cmd : proof_command_kind + } + +let proof_command_of_request (meth : string) (params : Json.t option) : + (proof_command, string) result = + let get_uri json = + match J.member "uri" json with + | `String uri -> uri + | _ -> "" + in + let get_query json = + match J.member "query" json with + | `String query -> String.trim query + | _ -> "" + in + match meth, params with + | "easycrypt/proof/next", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_next } + | "easycrypt/proof/step", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_step } + | "easycrypt/proof/jumpTo", Some (`Assoc _ as json) -> + let uri = get_uri json in + let target = + try J.member "target" json |> J.to_int with _ -> -1 + in + if uri = "" || target < 0 then + Error "missing uri or target" + else + Ok { uri; cmd = Proof_jump_to target } + | "easycrypt/proof/back", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_back } + | "easycrypt/proof/restart", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_restart } + | "easycrypt/proof/goals", Some (`Assoc _ as json) -> + let uri = get_uri json in + if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_goals } + | "easycrypt/query/print", Some (`Assoc _ as json) -> + let uri = get_uri json in + let query = get_query json in + if uri = "" || query = "" then + Error "missing uri or query" + else + Ok { uri; cmd = Query_print query } + | "easycrypt/query/locate", Some (`Assoc _ as json) -> + let uri = get_uri json in + let query = get_query json in + if uri = "" || query = "" then + Error "missing uri or query" + else + Ok { uri; cmd = Query_locate query } + | "easycrypt/query/search", Some (`Assoc _ as json) -> + let uri = get_uri json in + let query = get_query json in + if uri = "" || query = "" then + Error "missing uri or query" + else + Ok { uri; cmd = Query_search query } + | _ -> Error "Method not found" + +let rewind_to_offset + (doc : doc_state) + (sess : Easycrypt_cli.session) + (target : int) : string option Lwt.t = + if target >= doc.last_offset then + Lwt.return_none + else + let rec last_before acc = function + | [] -> acc + | (offset, uuid) :: rest -> + let acc = if offset <= target then Some (offset, uuid) else acc in + last_before acc rest + in + let target_entry = last_before None doc.history in + let target_uuid, new_offset = + match target_entry with + | None -> sess.root_uuid, 0 + | Some (offset, uuid) -> uuid, offset + in + doc.history <- List.filter (fun (offset, _) -> offset <= new_offset) doc.history; + doc.last_offset <- new_offset; + let* output = Easycrypt_cli.send_undo sess target_uuid in + Lwt.return (Some output) + +let send_packet (oc : Lwt_io.output_channel) (packet : Jsonrpc.Packet.t) : unit Lwt.t = + Lsp_io.write oc packet + +let send_response (oc : Lwt_io.output_channel) (id : Jsonrpc.Id.t) (result : Jsonrpc.Json.t) : + unit Lwt.t = + let response = Jsonrpc.Response.ok id result in + send_packet oc (Jsonrpc.Packet.Response response) + +let send_typed_response + (oc : Lwt_io.output_channel) + (id : Jsonrpc.Id.t) + (req : 'a Lsp.Client_request.t) + (result : 'a) : unit Lwt.t = + let payload = Lsp.Client_request.yojson_of_result req result in + send_response oc id payload + +let send_error + (oc : Lwt_io.output_channel) + (id : Jsonrpc.Id.t) + (code : Jsonrpc.Response.Error.Code.t) + (message : string) : unit Lwt.t = + let error = + Jsonrpc.Response.Error.make + ~code + ~message + () + in + let response = Jsonrpc.Response.error id error in + send_packet oc (Jsonrpc.Packet.Response response) + +let send_notification (oc : Lwt_io.output_channel) (method_ : string) (params : Jsonrpc.Json.t) : + unit Lwt.t = + let params_struct = Jsonrpc.Structured.t_of_yojson params in + let notif = Jsonrpc.Notification.create ~params:params_struct ~method_ () in + send_packet oc (Jsonrpc.Packet.Notification notif) + +let run () : unit = + Sys.set_signal Sys.sigpipe Sys.Signal_ignore; + setup_logging (); + log "argv=%s" (String.concat " " (Array.to_list Sys.argv)); + log "server start"; + let run_lwt () : unit Lwt.t = + let argv = Array.to_list Sys.argv in + let cli_path = + match argv with + | prog :: _ -> prog + | [] -> Easycrypt_cli.default_cli_path () + in + let cfg : Easycrypt_cli.config = { cli_path; cli_args = [] } in + let ic = Lwt_io.of_fd ~mode:Lwt_io.input Lwt_unix.stdin in + let oc = Lwt_io.of_fd ~mode:Lwt_io.output Lwt_unix.stdout in + let shutdown = ref false in + let pending : (Jsonrpc.Id.t * proof_command) Queue.t = Queue.create () in + let current : unit Lwt.t option ref = ref None in + + let get_session_for_doc (doc : doc_state) : Easycrypt_cli.session Lwt.t = + match doc.session with + | Some sess -> Lwt.return sess + | None -> + let* sess = Easycrypt_cli.start_session cfg in + doc.session <- Some sess; + Lwt.return sess + in + + let handle_initialize id (params : Lsp.Types.InitializeParams.t) : unit Lwt.t = + log "initialize"; + let capabilities = + Lsp.Types.ServerCapabilities.create + ~textDocumentSync:(`TextDocumentSyncKind Lsp.Types.TextDocumentSyncKind.Incremental) + () + in + let result = Lsp.Types.InitializeResult.create ~capabilities () in + send_typed_response oc id (Lsp.Client_request.Initialize params) result + in + + let handle_proof_next id uri : unit Lwt.t = + log "proof next"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + match find_next_sentence doc.text doc.last_offset with + | None -> + send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) + | Some (_text, start, end_) -> + send_response oc id (json_of_proof_response ~sess ~doc ~sentence:(start, end_) sess.last_output) + in + + let handle_proof_exec id uri : unit Lwt.t = + log "proof exec"; + let doc = get_doc_state uri in + match find_next_sentence doc.text doc.last_offset with + | None -> + let* sess = get_session_for_doc doc in + send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) + | Some (text, start, end_) -> + let previous_offset = doc.last_offset in + let rec run ~retry = + let* sess = get_session_for_doc doc in + Lwt.catch + (fun () -> + let* output = Easycrypt_cli.send_command sess text in + Lwt.return (sess, output)) + (function + | Sys_error msg + when retry && String.lowercase_ascii msg = "broken pipe" -> + log "cli broken pipe; restarting session"; + doc.session <- None; + run ~retry:false + | e -> Lwt.fail e) + in + Lwt.catch + (fun () -> + let* sess, output = run ~retry:true in + if output_has_error output then ( + doc.last_offset <- previous_offset; + send_response oc id + (json_of_proof_response ~sess ~doc ~sentence:(start, end_) output)) + else ( + doc.last_offset <- end_; + doc.history <- doc.history @ [ (doc.last_offset, sess.uuid) ]; + send_response oc id + (json_of_proof_response ~sess ~doc ~sentence:(start, end_) output))) + (fun e -> + log "proof exec error: %s" (Printexc.to_string e); + send_error oc id Jsonrpc.Response.Error.Code.InternalError "proof exec failed") + in + + let handle_proof_jump id uri target : unit Lwt.t = + log "proof jump"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + let text_len = BatText.length doc.text in + let target = max 0 (min target text_len) in + let respond ?sentence output = + send_response oc id (json_of_proof_response ~sess ~doc ?sentence output) + in + if target < doc.last_offset then ( + let rec last_before acc = function + | [] -> acc + | (offset, uuid) :: rest -> + let acc = if offset <= target then Some (offset, uuid) else acc in + last_before acc rest + in + let target_entry = last_before None doc.history in + let target_uuid, new_offset = + match target_entry with + | None -> sess.root_uuid, 0 + | Some (offset, uuid) -> uuid, offset + in + doc.history <- List.filter (fun (offset, _) -> offset <= new_offset) doc.history; + doc.last_offset <- new_offset; + let* output = Easycrypt_cli.send_undo sess target_uuid in + respond output) + else if target = doc.last_offset then + respond sess.last_output + else ( + let rec loop last_output = + if doc.last_offset >= target then + respond last_output + else + match find_next_sentence doc.text doc.last_offset with + | None -> respond last_output + | Some (text, start, end_) -> + if end_ > target then + respond last_output + else + let previous_offset = doc.last_offset in + let* output = Easycrypt_cli.send_command sess text in + if output_has_error output then ( + doc.last_offset <- previous_offset; + respond ~sentence:(start, end_) output) + else ( + doc.last_offset <- end_; + doc.history <- doc.history @ [ (doc.last_offset, sess.uuid) ]; + loop output) + in + loop sess.last_output) + in + + let handle_proof_back id uri : unit Lwt.t = + log "proof back"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + match List.rev doc.history with + | [] -> + send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) + | _last :: rest_rev -> + let target_uuid, new_offset = + match rest_rev with + | [] -> sess.root_uuid, 0 + | (offset, uuid) :: _ -> uuid, offset + in + let* output = Easycrypt_cli.send_undo sess target_uuid in + doc.history <- List.rev rest_rev; + doc.last_offset <- new_offset; + send_response oc id (json_of_proof_response ~sess ~doc output) + in + + let handle_proof_restart id uri : unit Lwt.t = + log "proof restart"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + let* output = Easycrypt_cli.send_undo sess sess.root_uuid in + doc.history <- []; + doc.last_offset <- 0; + send_response oc id (json_of_proof_response ~sess ~doc output) + in + + let handle_proof_goals id uri : unit Lwt.t = + log "proof goals"; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) + in + + let normalize_query_command keyword query = + let query = String.trim query in + if query = "" then + invalid_arg "empty query" + else + let query = + if String.ends_with ~suffix:"." query then + String.sub query 0 (String.length query - 1) + else + query + in + Printf.sprintf "%s %s." keyword query + in + + let handle_query id uri keyword query : unit Lwt.t = + log "query %s" keyword; + let doc = get_doc_state uri in + let* sess = get_session_for_doc doc in + let command = normalize_query_command keyword query in + let* output = Easycrypt_cli.send_command ~record_last_output:false sess command in + let output = strip_trailing_goal output sess.last_output in + send_response oc id (json_of_query_response output) + in + + let execute_proof_command (id : Jsonrpc.Id.t) (cmd : proof_command) : unit Lwt.t = + match cmd.cmd with + | Proof_next -> handle_proof_next id cmd.uri + | Proof_step -> handle_proof_exec id cmd.uri + | Proof_jump_to target -> handle_proof_jump id cmd.uri target + | Proof_back -> handle_proof_back id cmd.uri + | Proof_restart -> handle_proof_restart id cmd.uri + | Proof_goals -> handle_proof_goals id cmd.uri + | Query_print query -> handle_query id cmd.uri "print" query + | Query_locate query -> handle_query id cmd.uri "locate" query + | Query_search query -> handle_query id cmd.uri "search" query + in + + let start_proof (id : Jsonrpc.Id.t) (cmd : proof_command) : unit Lwt.t = + Lwt.catch + (fun () -> execute_proof_command id cmd) + (fun e -> + log "proof command error: %s" (Printexc.to_string e); + send_error oc id Jsonrpc.Response.Error.Code.InternalError "proof command failed") + in + + let pop_pending () = + if Queue.is_empty pending then None else Some (Queue.take pending) + in + + let handle_request req : unit Lwt.t = + match Lsp.Client_request.of_jsonrpc req with + | Error message -> + send_error oc req.id Jsonrpc.Response.Error.Code.InvalidParams message + | Ok (Lsp.Client_request.E r) -> ( + match r with + | Lsp.Client_request.Initialize params -> + handle_initialize req.id params + | Lsp.Client_request.Shutdown -> + shutdown := true; + send_typed_response oc req.id r () + | Lsp.Client_request.UnknownRequest { meth; params } -> ( + let params = Option.map Jsonrpc.Structured.yojson_of_t params in + match proof_command_of_request meth params with + | Ok cmd -> + (match !current with + | None -> + let task = start_proof req.id cmd in + current := Some task; + Lwt.return_unit + | Some _ -> + Queue.push (req.id, cmd) pending; + Lwt.return_unit) + | Error "Method not found" -> + send_error oc req.id Jsonrpc.Response.Error.Code.MethodNotFound "Method not found" + | Error message -> + send_error oc req.id Jsonrpc.Response.Error.Code.InvalidParams message) + | _ -> + send_error oc req.id Jsonrpc.Response.Error.Code.MethodNotFound "Method not found") + in + + let handle_notification_packet notif : unit Lwt.t = + match Lsp.Client_notification.of_jsonrpc notif with + | Error _ -> Lwt.return_unit + | Ok notification -> ( + match notification with + | Lsp.Client_notification.Initialized -> Lwt.return_unit + | Lsp.Client_notification.Exit -> shutdown := true; Lwt.return_unit + | Lsp.Client_notification.TextDocumentDidOpen params -> + let uri = + Lsp.Types.DocumentUri.to_string + params.Lsp.Types.DidOpenTextDocumentParams.textDocument.uri + in + let doc = get_doc_state uri in + doc.text <- BatText.of_string params.Lsp.Types.DidOpenTextDocumentParams.textDocument.text; + doc.last_offset <- 0; + doc.history <- []; + doc.session <- None; + Lwt.return_unit + | Lsp.Client_notification.TextDocumentDidChange params -> + let uri = + Lsp.Types.DocumentUri.to_string + params.Lsp.Types.DidChangeTextDocumentParams.textDocument.uri + in + let doc = get_doc_state uri in + let earliest = ref max_int in + let updated = ref doc.text in + List.iter + (fun change -> + let text, start_offset = apply_change !updated change in + updated := text; + if start_offset < !earliest then earliest := start_offset) + params.Lsp.Types.DidChangeTextDocumentParams.contentChanges; + doc.text <- !updated; + if !earliest < doc.last_offset then + let* sess = get_session_for_doc doc in + let* _ = rewind_to_offset doc sess !earliest in + Lwt.return_unit + else + Lwt.return_unit + | Lsp.Client_notification.TextDocumentDidClose params -> + let uri = + Lsp.Types.DocumentUri.to_string + params.Lsp.Types.DidCloseTextDocumentParams.textDocument.uri + in + let* () = + match Hashtbl.find_opt doc_states uri with + | Some doc -> ( + match doc.session with + | Some sess -> Easycrypt_cli.stop_session sess + | None -> Lwt.return_unit) + | None -> Lwt.return_unit + in + Hashtbl.remove doc_states uri; + Lwt.return_unit + | _ -> Lwt.return_unit) + in + + let rec loop () : unit Lwt.t = + if !shutdown then + Lwt.return_unit + else + let read_p = Lsp_io.read ic |> Lwt.map (fun p -> `Packet p) in + let waiters = + match !current with + | None -> [ read_p ] + | Some cmd_p -> [ read_p; (cmd_p |> Lwt.map (fun () -> `Cmd_done)) ] + in + let* ev = Lwt.pick waiters in + match ev with + | `Cmd_done -> + current := None; + (match pop_pending () with + | None -> () + | Some (id, cmd) -> current := Some (start_proof id cmd)); + loop () + | `Packet None -> + log "stdin closed"; + shutdown := true; + Lwt.return_unit + | `Packet (Some packet) -> + let* () = + match packet with + | Jsonrpc.Packet.Request req -> + log "recv request %s" req.Jsonrpc.Request.method_; + handle_request req + | Jsonrpc.Packet.Notification notif -> + log "recv notification %s" notif.Jsonrpc.Notification.method_; + handle_notification_packet notif + | Jsonrpc.Packet.Batch_call calls -> + Lwt_list.iter_s + (function + | `Request req -> handle_request req + | `Notification notif -> handle_notification_packet notif) + calls + | Jsonrpc.Packet.Response _ -> Lwt.return_unit + | Jsonrpc.Packet.Batch_response _ -> Lwt.return_unit + in + loop () + in + loop () + in + Lwt_main.run (run_lwt ()) diff --git a/src/ecLsp.mli b/src/ecLsp.mli new file mode 100644 index 0000000000..733b2a3231 --- /dev/null +++ b/src/ecLsp.mli @@ -0,0 +1 @@ +val run : unit -> unit diff --git a/src/ecOptions.ml b/src/ecOptions.ml index f012e8e8d6..c9b54139f9 100644 --- a/src/ecOptions.ml +++ b/src/ecOptions.ml @@ -6,10 +6,12 @@ open EcMaps type command = [ | `Compile of cmp_option | `Cli of cli_option + | `Lsp | `Config | `Runtest of run_option | `Why3Config | `DocGen of doc_option + | `Lsp ] and options = { @@ -356,6 +358,9 @@ let specs = { `Group "provers"; `Spec ("emacs", `Flag, "Output format set to ")]); + ("lsp", "Run EasyCrypt LSP server", [ + `Spec ("-stdio" , `Flag , "")]); + ("config", "Print EasyCrypt configuration", []); ("runtest", "Run a test-suite", [ @@ -604,6 +609,15 @@ let parse getini argv = raise (Arg.Bad "this command takes a single input file as argument") end + | "lsp" -> + if not (List.is_empty anons) then + raise (Arg.Bad "this command does not take arguments"); + + let ini = getini None in + let cmd = `Lsp in + + (cmd, ini, true) + | _ -> assert false in { diff --git a/src/ecOptions.mli b/src/ecOptions.mli index 59009718ad..c6aaa4d145 100644 --- a/src/ecOptions.mli +++ b/src/ecOptions.mli @@ -2,6 +2,7 @@ type command = [ | `Compile of cmp_option | `Cli of cli_option + | `Lsp | `Config | `Runtest of run_option | `Why3Config diff --git a/src/ecTerminal.ml b/src/ecTerminal.ml index 94f7c048e5..f680719f1e 100644 --- a/src/ecTerminal.ml +++ b/src/ecTerminal.ml @@ -90,7 +90,7 @@ object(self) | EcScope.TopError (loc, e) -> (loc, e) | _ -> (LC._dummy, e) in - Format.fprintf Format.err_formatter + Format.fprintf Format.std_formatter "[error-%d-%d]%s\n%!" (max 0 (loc.LC.loc_bchar - startpos)) (max 0 (loc.LC.loc_echar - startpos)) diff --git a/vscode/.gitignore b/vscode/.gitignore new file mode 100644 index 0000000000..82abfab5cc --- /dev/null +++ b/vscode/.gitignore @@ -0,0 +1,2 @@ +/node_modules/ +/out/ diff --git a/vscode/README.md b/vscode/README.md new file mode 100644 index 0000000000..0c3ac44c83 --- /dev/null +++ b/vscode/README.md @@ -0,0 +1,46 @@ +# EasyCrypt VSCode Extension (local) + +This folder contains a local VSCode extension for EasyCrypt. + +## Build the EasyCrypt binary (with LSP) + +From the repository root: + +``` +$ dune build src/ec.exe +``` + +The binary will be at `_build/default/src/ec.exe` and provides `easycrypt lsp`. + +## Build the extension + +From this `vscode/` folder: + +``` +$ npm install +$ npm run compile +``` + +Then use "Developer: Install Extension from Location..." and select this folder. + +## Configuration + +- `easycrypt.cli.path`: path to the EasyCrypt CLI (e.g. `ec.native` or `easycrypt`). + +## TextMate colors + +This extension uses TextMate scopes for syntax highlighting. To customize colors without changing a theme, add rules to your VSCode settings: + +```jsonc +"editor.tokenColorCustomizations": { + "textMateRules": [ + { "scope": "keyword.other.easycrypt.bytac", "settings": { "foreground": "#6C71C4" } }, + { "scope": "keyword.other.easycrypt.dangerous", "settings": { "foreground": "#DC322F", "fontStyle": "bold" } }, + { "scope": "keyword.control.easycrypt.global", "settings": { "foreground": "#268BD2" } }, + { "scope": "keyword.other.easycrypt.internal", "settings": { "foreground": "#B58900" } }, + { "scope": "keyword.operator.easycrypt.prog", "settings": { "foreground": "#2AA198" } }, + { "scope": "keyword.control.easycrypt.tactic", "settings": { "foreground": "#859900" } }, + { "scope": "keyword.control.easycrypt.tactical", "settings": { "foreground": "#CB4B16" } } + ] +} +``` diff --git a/vscode/assets/back.svg b/vscode/assets/back.svg new file mode 100644 index 0000000000..63fa276430 --- /dev/null +++ b/vscode/assets/back.svg @@ -0,0 +1,3 @@ + + + diff --git a/vscode/assets/easycrypt.svg b/vscode/assets/easycrypt.svg new file mode 100644 index 0000000000..f18030d31a --- /dev/null +++ b/vscode/assets/easycrypt.svg @@ -0,0 +1,5 @@ + + + + + diff --git a/vscode/assets/goals.svg b/vscode/assets/goals.svg new file mode 100644 index 0000000000..fe6bd5048c --- /dev/null +++ b/vscode/assets/goals.svg @@ -0,0 +1,4 @@ + + + + diff --git a/vscode/assets/jump.svg b/vscode/assets/jump.svg new file mode 100644 index 0000000000..daeb25d592 --- /dev/null +++ b/vscode/assets/jump.svg @@ -0,0 +1,3 @@ + + + diff --git a/vscode/assets/refresh.svg b/vscode/assets/refresh.svg new file mode 100644 index 0000000000..d124bdd5c7 --- /dev/null +++ b/vscode/assets/refresh.svg @@ -0,0 +1,3 @@ + + + diff --git a/vscode/assets/step.svg b/vscode/assets/step.svg new file mode 100644 index 0000000000..dd77f646a7 --- /dev/null +++ b/vscode/assets/step.svg @@ -0,0 +1,3 @@ + + + diff --git a/vscode/language-configuration.json b/vscode/language-configuration.json new file mode 100644 index 0000000000..163424eeb9 --- /dev/null +++ b/vscode/language-configuration.json @@ -0,0 +1,23 @@ +{ + "comments": { + "lineComment": "//", + "blockComment": ["(*", "*)"] + }, + "brackets": [ + ["{", "}"], + ["[", "]"], + ["(", ")"] + ], + "autoClosingPairs": [ + {"open": "{", "close": "}"}, + {"open": "[", "close": "]"}, + {"open": "(", "close": ")"}, + {"open": "\"", "close": "\""} + ], + "surroundingPairs": [ + ["{", "}"], + ["[", "]"], + ["(", ")"], + ["\"", "\""] + ] +} diff --git a/vscode/package-lock.json b/vscode/package-lock.json new file mode 100644 index 0000000000..7070c58627 --- /dev/null +++ b/vscode/package-lock.json @@ -0,0 +1,139 @@ +{ + "name": "easycrypt-vscode", + "version": "0.0.1", + "lockfileVersion": 3, + "requires": true, + "packages": { + "": { + "name": "easycrypt-vscode", + "version": "0.0.1", + "dependencies": { + "vscode-languageclient": "^9.0.1" + }, + "devDependencies": { + "@types/node": "^20.11.0", + "@types/vscode": "^1.85.0", + "typescript": "^5.3.3" + }, + "engines": { + "vscode": "^1.85.0" + } + }, + "node_modules/@types/node": { + "version": "20.19.30", + "resolved": "https://registry.npmjs.org/@types/node/-/node-20.19.30.tgz", + "integrity": "sha512-WJtwWJu7UdlvzEAUm484QNg5eAoq5QR08KDNx7g45Usrs2NtOPiX8ugDqmKdXkyL03rBqU5dYNYVQetEpBHq2g==", + "dev": true, + "license": "MIT", + "dependencies": { + "undici-types": "~6.21.0" + } + }, + "node_modules/@types/vscode": { + "version": "1.108.1", + "resolved": "https://registry.npmjs.org/@types/vscode/-/vscode-1.108.1.tgz", + "integrity": "sha512-DerV0BbSzt87TbrqmZ7lRDIYaMiqvP8tmJTzW2p49ZBVtGUnGAu2RGQd1Wv4XMzEVUpaHbsemVM5nfuQJj7H6w==", + "dev": true, + "license": "MIT" + }, + "node_modules/balanced-match": { + "version": "1.0.2", + "resolved": "https://registry.npmjs.org/balanced-match/-/balanced-match-1.0.2.tgz", + "integrity": "sha512-3oSeUO0TMV67hN1AmbXsK4yaqU7tjiHlbxRDZOpH0KW9+CeX4bRAaX0Anxt0tx2MrpRpWwQaPwIlISEJhYU5Pw==", + "license": "MIT" + }, + "node_modules/brace-expansion": { + "version": "2.0.2", + "resolved": "https://registry.npmjs.org/brace-expansion/-/brace-expansion-2.0.2.tgz", + "integrity": "sha512-Jt0vHyM+jmUBqojB7E1NIYadt0vI0Qxjxd2TErW94wDz+E2LAm5vKMXXwg6ZZBTHPuUlDgQHKXvjGBdfcF1ZDQ==", + "license": "MIT", + "dependencies": { + "balanced-match": "^1.0.0" + } + }, + "node_modules/minimatch": { + "version": "5.1.6", + "resolved": "https://registry.npmjs.org/minimatch/-/minimatch-5.1.6.tgz", + "integrity": "sha512-lKwV/1brpG6mBUFHtb7NUmtABCb2WZZmm2wNiOA5hAb8VdCS4B3dtMWyvcoViccwAW/COERjXLt0zP1zXUN26g==", + "license": "ISC", + "dependencies": { + "brace-expansion": "^2.0.1" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/semver": { + "version": "7.7.3", + "resolved": "https://registry.npmjs.org/semver/-/semver-7.7.3.tgz", + "integrity": "sha512-SdsKMrI9TdgjdweUSR9MweHA4EJ8YxHn8DFaDisvhVlUOe4BF1tLD7GAj0lIqWVl+dPb/rExr0Btby5loQm20Q==", + "license": "ISC", + "bin": { + "semver": "bin/semver.js" + }, + "engines": { + "node": ">=10" + } + }, + "node_modules/typescript": { + "version": "5.9.3", + "resolved": "https://registry.npmjs.org/typescript/-/typescript-5.9.3.tgz", + "integrity": "sha512-jl1vZzPDinLr9eUt3J/t7V6FgNEw9QjvBPdysz9KfQDD41fQrC2Y4vKQdiaUpFT4bXlb1RHhLpp8wtm6M5TgSw==", + "dev": true, + "license": "Apache-2.0", + "bin": { + "tsc": "bin/tsc", + "tsserver": "bin/tsserver" + }, + "engines": { + "node": ">=14.17" + } + }, + "node_modules/undici-types": { + "version": "6.21.0", + "resolved": "https://registry.npmjs.org/undici-types/-/undici-types-6.21.0.tgz", + "integrity": "sha512-iwDZqg0QAGrg9Rav5H4n0M64c3mkR59cJ6wQp+7C4nI0gsmExaedaYLNO44eT4AtBBwjbTiGPMlt2Md0T9H9JQ==", + "dev": true, + "license": "MIT" + }, + "node_modules/vscode-jsonrpc": { + "version": "8.2.0", + "resolved": "https://registry.npmjs.org/vscode-jsonrpc/-/vscode-jsonrpc-8.2.0.tgz", + "integrity": "sha512-C+r0eKJUIfiDIfwJhria30+TYWPtuHJXHtI7J0YlOmKAo7ogxP20T0zxB7HZQIFhIyvoBPwWskjxrvAtfjyZfA==", + "license": "MIT", + "engines": { + "node": ">=14.0.0" + } + }, + "node_modules/vscode-languageclient": { + "version": "9.0.1", + "resolved": "https://registry.npmjs.org/vscode-languageclient/-/vscode-languageclient-9.0.1.tgz", + "integrity": "sha512-JZiimVdvimEuHh5olxhxkht09m3JzUGwggb5eRUkzzJhZ2KjCN0nh55VfiED9oez9DyF8/fz1g1iBV3h+0Z2EA==", + "license": "MIT", + "dependencies": { + "minimatch": "^5.1.0", + "semver": "^7.3.7", + "vscode-languageserver-protocol": "3.17.5" + }, + "engines": { + "vscode": "^1.82.0" + } + }, + "node_modules/vscode-languageserver-protocol": { + "version": "3.17.5", + "resolved": "https://registry.npmjs.org/vscode-languageserver-protocol/-/vscode-languageserver-protocol-3.17.5.tgz", + "integrity": "sha512-mb1bvRJN8SVznADSGWM9u/b07H7Ecg0I3OgXDuLdn307rl/J3A9YD6/eYOssqhecL27hK1IPZAsaqh00i/Jljg==", + "license": "MIT", + "dependencies": { + "vscode-jsonrpc": "8.2.0", + "vscode-languageserver-types": "3.17.5" + } + }, + "node_modules/vscode-languageserver-types": { + "version": "3.17.5", + "resolved": "https://registry.npmjs.org/vscode-languageserver-types/-/vscode-languageserver-types-3.17.5.tgz", + "integrity": "sha512-Ld1VelNuX9pdF39h2Hgaeb5hEZM2Z3jUrrMgWQAu82jMtZp7p3vJT3BzToKtZI7NgQssZje5o0zryOrhQvzQAg==", + "license": "MIT" + } + } +} diff --git a/vscode/package.json b/vscode/package.json new file mode 100644 index 0000000000..81b732dc1a --- /dev/null +++ b/vscode/package.json @@ -0,0 +1,226 @@ +{ + "name": "easycrypt-vscode", + "displayName": "EasyCrypt", + "publisher": "easycrypt", + "version": "0.0.1", + "engines": { + "vscode": "^1.85.0" + }, + "categories": ["Programming Languages"], + "activationEvents": [ + "onLanguage:easycrypt", + "onCommand:easycrypt.proof.step", + "onCommand:easycrypt.proof.back", + "onCommand:easycrypt.proof.restart", + "onCommand:easycrypt.proof.jumpToCursor", + "onCommand:easycrypt.proof.goals", + "onCommand:easycrypt.query.print", + "onCommand:easycrypt.query.locate", + "onCommand:easycrypt.query.search", + "onCommand:easycrypt.lsp.restart" + ], + "main": "./out/extension.js", + "contributes": { + "languages": [ + { + "id": "easycrypt", + "aliases": ["EasyCrypt", "easycrypt"], + "extensions": [".ec"], + "configuration": "./language-configuration.json" + } + ], + "grammars": [ + { + "language": "easycrypt", + "scopeName": "source.easycrypt", + "path": "./syntaxes/easycrypt.tmLanguage.json" + } + ], + "submenus": [ + { + "id": "easycrypt.query", + "label": "EasyCrypt" + } + ], + "commands": [ + { + "command": "easycrypt.proof.step", + "title": "Step", + "icon": { "light": "assets/step.svg", "dark": "assets/step.svg" } + }, + { + "command": "easycrypt.proof.back", + "title": "Back", + "icon": { "light": "assets/back.svg", "dark": "assets/back.svg" } + }, + { + "command": "easycrypt.proof.restart", + "title": "Restart", + "icon": { "light": "assets/refresh.svg", "dark": "assets/refresh.svg" } + }, + { + "command": "easycrypt.proof.jumpToCursor", + "title": "Jump To Cursor", + "icon": { "light": "assets/jump.svg", "dark": "assets/jump.svg" } + }, + { + "command": "easycrypt.proof.goals", + "title": "Show Goals", + "icon": { "light": "assets/goals.svg", "dark": "assets/goals.svg" } + }, + { + "command": "easycrypt.query.print", + "title": "Print Object", + "category": "EasyCrypt" + }, + { + "command": "easycrypt.query.locate", + "title": "Locate Object", + "category": "EasyCrypt" + }, + { + "command": "easycrypt.query.search", + "title": "Search Objects", + "category": "EasyCrypt" + }, + { + "command": "easycrypt.lsp.restart", + "title": "Restart LSP" + } + ], + "menus": { + "editor/title": [ + { + "command": "easycrypt.proof.step", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", + "group": "navigation.easycrypt@3" + }, + { + "command": "easycrypt.proof.step", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", + "group": "inline.easycrypt@3" + }, + { + "command": "easycrypt.proof.back", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", + "group": "navigation.easycrypt@1" + }, + { + "command": "easycrypt.proof.back", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", + "group": "inline.easycrypt@1" + }, + { + "command": "easycrypt.proof.jumpToCursor", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", + "group": "navigation.easycrypt@2" + }, + { + "command": "easycrypt.proof.jumpToCursor", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", + "group": "inline.easycrypt@2" + }, + { + "command": "easycrypt.proof.goals", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", + "group": "navigation.easycrypt@4" + }, + { + "command": "easycrypt.proof.goals", + "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", + "group": "inline.easycrypt@4" + } + ], + "editor/context": [ + { + "submenu": "easycrypt.query", + "when": "resourceLangId == easycrypt", + "group": "navigation" + } + ], + "easycrypt.query": [ + { + "command": "easycrypt.query.print", + "when": "resourceLangId == easycrypt", + "group": "query" + }, + { + "command": "easycrypt.query.locate", + "when": "resourceLangId == easycrypt", + "group": "query" + }, + { + "command": "easycrypt.query.search", + "when": "resourceLangId == easycrypt", + "group": "query" + } + ] + }, + "keybindings": [ + { + "command": "easycrypt.proof.step", + "key": "ctrl+alt+down", + "mac": "cmd+alt+down", + "when": "editorLangId == easycrypt" + }, + { + "command": "easycrypt.proof.back", + "key": "ctrl+alt+up", + "mac": "cmd+alt+up", + "when": "editorLangId == easycrypt" + }, + { + "command": "easycrypt.proof.jumpToCursor", + "key": "ctrl+alt+enter", + "mac": "cmd+alt+enter", + "when": "editorLangId == easycrypt" + }, + { + "command": "easycrypt.proof.goals", + "key": "ctrl+alt+g", + "mac": "cmd+alt+g", + "when": "editorLangId == easycrypt" + } + ], + "configuration": { + "title": "EasyCrypt", + "properties": { + "easycrypt.cli.path": { + "type": "string", + "default": "", + "description": "Path to the EasyCrypt CLI (easycrypt or ec.native)." + }, + "easycrypt.cli.args": { + "type": "array", + "items": { "type": "string" }, + "default": [], + "description": "Extra arguments passed to the EasyCrypt CLI when running in proof mode." + }, + "easycrypt.trace.server": { + "type": "string", + "enum": ["off", "messages", "verbose"], + "default": "off", + "description": "Trace LSP communication to the Output panel." + }, + "easycrypt.ui.editorToolbarGroup": { + "type": "string", + "enum": ["navigation", "inline"], + "default": "navigation", + "description": "Editor title toolbar group for EasyCrypt buttons." + } + } + } + }, + "scripts": { + "compile": "tsc -p ./", + "watch": "tsc -w -p ./" + }, + "dependencies": { + "vscode-languageclient": "^9.0.1" + }, + "devDependencies": { + "@types/node": "^20.11.0", + "@types/vscode": "^1.85.0", + "typescript": "^5.3.3" + } +} diff --git a/vscode/package.nls.json b/vscode/package.nls.json new file mode 100644 index 0000000000..2da004d97c --- /dev/null +++ b/vscode/package.nls.json @@ -0,0 +1,3 @@ +{ + "easycrypt.ui.editorToolbarGroup": "Editor title toolbar group for EasyCrypt buttons." +} diff --git a/vscode/src/extension.ts b/vscode/src/extension.ts new file mode 100644 index 0000000000..900ad46491 --- /dev/null +++ b/vscode/src/extension.ts @@ -0,0 +1,1020 @@ +import * as fs from 'fs'; +import * as path from 'path'; +import * as vscode from 'vscode'; +import { + LanguageClient, + LanguageClientOptions, + ServerOptions, + TransportKind, + Trace +} from 'vscode-languageclient/node'; + +type ProofResponse = { + output: string; + uuid: number; + mode: string; + processedEnd: number; + sentenceStart?: number | null; + sentenceEnd?: number | null; +}; + +type QueryResponse = { + output: string; +}; + +type DocState = { + lastOffset: number; +}; + +let client: LanguageClient | undefined; +let clientReady: Promise | undefined; +let clientOptions: LanguageClientOptions | undefined; +let serverOptions: ServerOptions | undefined; +let goalsPanel: vscode.WebviewPanel | undefined; +let queryPanel: vscode.WebviewPanel | undefined; +let queryStatusBarItem: vscode.StatusBarItem | undefined; +let printStatusBarItem: vscode.StatusBarItem | undefined; +let locateStatusBarItem: vscode.StatusBarItem | undefined; +let outputChannel: vscode.OutputChannel | undefined; +let traceLevel: Trace = Trace.Off; +let lspCommand: string | undefined; +let lspArgs: string[] = []; +let processedDecoration: vscode.TextEditorDecorationType | undefined; +let processingDecoration: vscode.TextEditorDecorationType | undefined; +let errorDecoration: vscode.TextEditorDecorationType | undefined; +let lastEasyCryptEditor: vscode.TextEditor | undefined; +const docStates = new Map(); +let suppressProcessedEdits = false; +let suppressProcessingEdits = false; +let processingDocUri: string | undefined; +let processingSnapshot: string | undefined; +let diagnostics: vscode.DiagnosticCollection | undefined; + +function getDocState(doc: vscode.TextDocument): DocState { + const key = doc.uri.toString(); + const state = docStates.get(key); + if (state) { + return state; + } + const created = { lastOffset: 0 }; + docStates.set(key, created); + return created; +} + +function escapeHtml(value: string): string { + return value + .replace(/&/g, '&') + .replace(//g, '>'); +} + +function showGoals(output: string): void { + showTextPanel('easycryptGoals', 'EasyCrypt Goals', output, { + panel: goalsPanel, + setPanel: (panel) => { + goalsPanel = panel; + } + }); +} + +function showQueryResult(title: string, output: string): void { + showTextPanel('easycryptQuery', title, output, { + panel: queryPanel, + setPanel: (panel) => { + queryPanel = panel; + } + }); +} + +function showTextPanel( + viewType: string, + title: string, + output: string, + holder: { + panel: vscode.WebviewPanel | undefined; + setPanel: (panel: vscode.WebviewPanel | undefined) => void; + } +): void { + let panel = holder.panel; + if (!panel) { + panel = vscode.window.createWebviewPanel( + viewType, + title, + { viewColumn: vscode.ViewColumn.Beside, preserveFocus: true }, + { enableFindWidget: true } + ); + panel.onDidDispose(() => { + holder.setPanel(undefined); + }); + holder.setPanel(panel); + } else { + panel.title = title; + panel.reveal(panel.viewColumn, true); + } + + panel.webview.html = ` + + + + + + + +
${escapeHtml(output)}
+ +`; +} + +async function restoreEditorFocus(editor: vscode.TextEditor | undefined): Promise { + if (!editor) { + return; + } + await vscode.window.showTextDocument(editor.document, { + viewColumn: editor.viewColumn, + preserveFocus: false, + selection: editor.selection + }); +} + +function getQuerySeed(editor: vscode.TextEditor): string { + const selection = editor.document.getText(editor.selection).trim(); + if (selection.length > 0) { + return selection; + } + const wordRange = editor.document.getWordRangeAtPosition(editor.selection.active); + if (!wordRange) { + return ''; + } + return editor.document.getText(wordRange).trim(); +} + +async function promptQuery( + editor: vscode.TextEditor, + kind: 'print' | 'locate' | 'search' +): Promise { + return vscode.window.showInputBox({ + title: `EasyCrypt ${kind}`, + prompt: `Enter an EasyCrypt ${kind} query`, + value: getQuerySeed(editor), + ignoreFocusOut: true + }); +} + +async function executeQuery( + editor: vscode.TextEditor, + method: 'easycrypt/query/print' | 'easycrypt/query/locate' | 'easycrypt/query/search', + kind: 'print' | 'locate' | 'search', + title: string, + query: string +): Promise { + try { + outputChannel?.appendLine(`[query] ${kind} ${query}`); + const result = await requestProof(method, { + uri: editor.document.uri.toString(), + query + }); + if (outputHasError(result.output)) { + handleQueryError(title, result.output, editor); + await restoreEditorFocus(editor); + return; + } + showQueryResult(title, result.output.trim().length > 0 ? result.output : 'No output.'); + await restoreEditorFocus(editor); + } catch (err) { + outputChannel?.appendLine(`[query] ${kind} failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt ${kind} failed: ${String(err)}`); + } finally { + refreshQueryStatusBar(editor); + } +} + +async function runQuery( + method: 'easycrypt/query/print' | 'easycrypt/query/locate' | 'easycrypt/query/search', + kind: 'print' | 'locate' | 'search', + title: string +): Promise { + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + + const query = (await promptQuery(editor, kind))?.trim(); + if (!query) { + return; + } + + await executeQuery(editor, method, kind, title, query); +} + +async function handlePrintQuery(): Promise { + await runQuery('easycrypt/query/print', 'print', 'EasyCrypt Print'); +} + +async function handleLocateQuery(): Promise { + await runQuery('easycrypt/query/locate', 'locate', 'EasyCrypt Locate'); +} + +async function handleSearchQuery(): Promise { + await runQuery('easycrypt/query/search', 'search', 'EasyCrypt Search'); +} + +async function handleLocateCurrentQuery(): Promise { + const editor = getEditorForCommand(); + if (!editor || editor.document.languageId !== 'easycrypt') { + return; + } + const query = getQuerySeed(editor); + if (!query) { + return; + } + await executeQuery( + editor, + 'easycrypt/query/locate', + 'locate', + `EasyCrypt Locate: ${query}`, + query + ); +} + +async function handlePrintCurrentQuery(): Promise { + const editor = getEditorForCommand(); + if (!editor || editor.document.languageId !== 'easycrypt') { + return; + } + const query = getQuerySeed(editor); + if (!query) { + return; + } + await executeQuery( + editor, + 'easycrypt/query/print', + 'print', + `EasyCrypt Print: ${query}`, + query + ); +} + +async function handleQueryStatusBar(): Promise { + const editor = getEditorForCommand(); + if (!editor || editor.document.languageId !== 'easycrypt') { + return; + } + + const selection = await vscode.window.showQuickPick( + [ + { + label: '$(symbol-key) Print Object', + command: 'easycrypt.query.print' + }, + { + label: '$(symbol-file) Locate Object', + command: 'easycrypt.query.locate' + }, + { + label: '$(search) Search Objects', + command: 'easycrypt.query.search' + } + ], + { + title: 'EasyCrypt Query', + placeHolder: 'Choose a query command' + } + ); + + if (!selection) { + return; + } + + await vscode.commands.executeCommand(selection.command); +} + +function updateQueryStatusBar(editor: vscode.TextEditor | undefined): void { + if (!queryStatusBarItem) { + return; + } + if (getStatusBarEditor(editor)) { + queryStatusBarItem.show(); + } else { + queryStatusBarItem.hide(); + } +} + +function updateLocateStatusBar(editor: vscode.TextEditor | undefined): void { + if (!locateStatusBarItem) { + return; + } + const targetEditor = getStatusBarEditor(editor); + if (!targetEditor) { + locateStatusBarItem.hide(); + return; + } + + const query = getQuerySeed(targetEditor); + if (!query) { + locateStatusBarItem.hide(); + return; + } + + locateStatusBarItem.text = '$(symbol-file) Locate'; + locateStatusBarItem.tooltip = `EasyCrypt: locate ${query}`; + locateStatusBarItem.show(); +} + +function updatePrintStatusBar(editor: vscode.TextEditor | undefined): void { + if (!printStatusBarItem) { + return; + } + const targetEditor = getStatusBarEditor(editor); + if (!targetEditor) { + printStatusBarItem.hide(); + return; + } + + const query = getQuerySeed(targetEditor); + if (!query) { + printStatusBarItem.hide(); + return; + } + + printStatusBarItem.text = '$(symbol-key) Print'; + printStatusBarItem.tooltip = `EasyCrypt: print ${query}`; + printStatusBarItem.show(); +} + +function refreshQueryStatusBar(editor: vscode.TextEditor | undefined): void { + updateQueryStatusBar(editor); + updatePrintStatusBar(editor); + updateLocateStatusBar(editor); +} + +function updateProcessedDecoration(editor: vscode.TextEditor | undefined): void { + if (!editor || !processedDecoration) { + return; + } + const state = getDocState(editor.document); + const endOffset = state.lastOffset; + const endPos = editor.document.positionAt(endOffset); + const startPos = new vscode.Position(0, 0); + const anchor = new vscode.Range(startPos, startPos); + const fixed = new vscode.Range(startPos, endPos); + editor.setDecorations(processedDecoration, [anchor, fixed]); +} + +function setProcessingDecoration(editor: vscode.TextEditor | undefined, range: vscode.Range): void { + if (!editor || !processingDecoration) { + return; + } + editor.setDecorations(processingDecoration, [range]); +} + +function clearProcessingDecoration(editor: vscode.TextEditor | undefined): void { + if (!editor || !processingDecoration) { + return; + } + editor.setDecorations(processingDecoration, []); +} + +function setProcessingLock(doc: vscode.TextDocument): void { + processingDocUri = doc.uri.toString(); + processingSnapshot = doc.getText(); +} + +function clearProcessingLock(): void { + processingDocUri = undefined; + processingSnapshot = undefined; +} + +async function restoreProcessingSnapshot(doc: vscode.TextDocument): Promise { + if (!processingSnapshot) { + return; + } + const lastLine = doc.lineAt(doc.lineCount - 1); + const fullRange = new vscode.Range(new vscode.Position(0, 0), lastLine.range.end); + const edit = new vscode.WorkspaceEdit(); + edit.replace(doc.uri, fullRange, processingSnapshot); + await vscode.workspace.applyEdit(edit); +} + +function outputHasError(output: string): boolean { + return /\[error-\d+-\d+\]/.test(output); +} + +function summarizeErrorOutput(output: string): string { + const line = output.split(/\r?\n/).find((entry) => entry.trim().length > 0); + if (!line) { + return 'EasyCrypt reported an error.'; + } + const cleaned = line.replace(/\[error-\d+-\d+\]/g, '').trim(); + return cleaned.length > 0 ? cleaned : 'EasyCrypt reported an error.'; +} + +function showGoalsOrError(output: string): void { + if (output.trim().length > 0) { + showGoals(output); + } else { + showGoals('EasyCrypt reported an error.'); + } +} + +function showQueryResultOrError(title: string, output: string): void { + if (output.trim().length > 0) { + showQueryResult(title, output); + } else { + showQueryResult(title, 'EasyCrypt reported an error.'); + } +} + +function parseErrorTag(output: string): { start: number; end: number; message: string } | undefined { + const match = output.match(/\[error-(\d+)-(\d+)\]/); + if (!match) { + return undefined; + } + const start = Number(match[1]); + const end = Number(match[2]); + if (!Number.isFinite(start) || !Number.isFinite(end)) { + return undefined; + } + const message = output.replace(match[0], '').trim(); + return { start, end, message: message.length > 0 ? message : 'EasyCrypt reported an error.' }; +} + +function clearErrorDecoration(editor: vscode.TextEditor | undefined): void { + if (!editor || !errorDecoration) { + return; + } + editor.setDecorations(errorDecoration, []); +} + +function clearDiagnostics(doc: vscode.TextDocument): void { + diagnostics?.delete(doc.uri); +} + +function showErrorDecoration( + editor: vscode.TextEditor | undefined, + sentenceOffset: number, + errorStart: number, + errorEnd: number +): void { + if (!editor || !errorDecoration) { + return; + } + const start = editor.document.positionAt(sentenceOffset + errorStart); + const end = editor.document.positionAt(sentenceOffset + Math.max(errorStart + 1, errorEnd)); + editor.setDecorations(errorDecoration, [new vscode.Range(start, end)]); +} + +function handleProofError( + output: string, + editor: vscode.TextEditor | undefined, + sentenceOffset?: number +): void { + const parsed = parseErrorTag(output); + if (parsed && sentenceOffset !== undefined) { + showErrorDecoration(editor, sentenceOffset, parsed.start, parsed.end); + showGoals(parsed.message); + if (editor && diagnostics) { + const doc = editor.document; + const start = doc.positionAt(sentenceOffset + parsed.start); + const end = doc.positionAt(sentenceOffset + Math.max(parsed.start + 1, parsed.end)); + const range = new vscode.Range(start, end); + const diag = new vscode.Diagnostic(range, parsed.message, vscode.DiagnosticSeverity.Error); + diagnostics.set(doc.uri, [diag]); + } + } else { + showGoalsOrError(output.replace(/\[error-\d+-\d+\]/g, '').trim()); + } +} + +function handleQueryError( + title: string, + output: string, + editor: vscode.TextEditor | undefined +): void { + const parsed = parseErrorTag(output); + clearErrorDecoration(editor); + if (editor) { + clearDiagnostics(editor.document); + } + if (parsed) { + showQueryResult(title, parsed.message); + } else { + showQueryResultOrError(title, output.replace(/\[error-\d+-\d+\]/g, '').trim()); + } +} + +function getEditorForCommand(): vscode.TextEditor | undefined { + const active = vscode.window.activeTextEditor; + if (active && active.document.languageId === 'easycrypt') { + return active; + } + return lastEasyCryptEditor; +} + +function getStatusBarEditor(editor: vscode.TextEditor | undefined): vscode.TextEditor | undefined { + if (editor && editor.document.languageId === 'easycrypt') { + return editor; + } + if (lastEasyCryptEditor?.document.languageId === 'easycrypt') { + return lastEasyCryptEditor; + } + return undefined; +} + +async function requestProof( + method: string, + params: Record +): Promise { + if (!client) { + throw new Error('EasyCrypt language client is not running.'); + } + if (clientReady) { + await clientReady; + } + const start = Date.now(); + outputChannel?.appendLine(`[proof] request ${method}`); + const timeout = setTimeout(() => { + outputChannel?.appendLine(`[proof] waiting ${method} >3s`); + }, 3000); + try { + const result = await client.sendRequest(method, params); + const elapsed = Date.now() - start; + outputChannel?.appendLine(`[proof] response ${method} ${elapsed}ms`); + return result; + } catch (err) { + const elapsed = Date.now() - start; + outputChannel?.appendLine(`[proof] error ${method} ${elapsed}ms ${String(err)}`); + throw err; + } finally { + clearTimeout(timeout); + } +} + +async function handleStep(): Promise { + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + + const doc = editor.document; + const state = getDocState(doc); + const previousOffset = state.lastOffset; + let sentenceStart: number | null | undefined; + let sentenceEnd: number | null | undefined; + let previewProcessedEnd = state.lastOffset; + try { + const preview = await requestProof('easycrypt/proof/next', { uri: doc.uri.toString() }); + sentenceStart = preview.sentenceStart ?? null; + sentenceEnd = preview.sentenceEnd ?? null; + previewProcessedEnd = preview.processedEnd; + } catch (err) { + outputChannel?.appendLine(`[proof] step preview failed ${String(err)}`); + } + + if (sentenceStart == null || sentenceEnd == null) { + state.lastOffset = previewProcessedEnd; + updateProcessedDecoration(editor); + return; + } + + if (sentenceStart != null && sentenceEnd != null) { + const processingRange = new vscode.Range( + doc.positionAt(sentenceStart), + doc.positionAt(sentenceEnd) + ); + setProcessingDecoration(editor, processingRange); + setProcessingLock(doc); + } + + try { + const result = await requestProof('easycrypt/proof/step', { uri: doc.uri.toString() }); + outputChannel?.appendLine(`[proof] step ok uuid=${result.uuid} mode=${result.mode}`); + state.lastOffset = result.processedEnd; + if (outputHasError(result.output)) { + outputChannel?.appendLine(`[proof] step reported error ${result.output}`); + updateProcessedDecoration(editor); + if (result.sentenceStart != null) { + handleProofError(result.output, editor, result.sentenceStart); + } else { + handleProofError(result.output, editor, previousOffset); + } + } else { + showGoals(result.output); + updateProcessedDecoration(editor); + clearErrorDecoration(editor); + clearDiagnostics(editor.document); + } + } catch (err) { + outputChannel?.appendLine(`[proof] step failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt step failed: ${String(err)}`); + } finally { + clearProcessingDecoration(editor); + clearProcessingLock(); + } +} + +async function handleSendRegion(): Promise { + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + + const doc = editor.document; + const state = getDocState(doc); + const cursorOffset = doc.offsetAt(editor.selection.active); + try { + outputChannel?.appendLine('[proof] jumpToCursor'); + const result = await requestProof('easycrypt/proof/jumpTo', { + uri: doc.uri.toString(), + target: cursorOffset + }); + outputChannel?.appendLine(`[proof] jumpToCursor ok uuid=${result.uuid} mode=${result.mode}`); + state.lastOffset = result.processedEnd; + if (outputHasError(result.output)) { + outputChannel?.appendLine(`[proof] jumpToCursor reported error ${result.output}`); + updateProcessedDecoration(editor); + if (result.sentenceStart != null) { + handleProofError(result.output, editor, result.sentenceStart); + } else { + handleProofError(result.output, editor, state.lastOffset); + } + return; + } + showGoals(result.output); + updateProcessedDecoration(editor); + clearErrorDecoration(editor); + clearDiagnostics(doc); + } catch (err) { + outputChannel?.appendLine(`[proof] jumpToCursor failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt jump-to-cursor failed: ${String(err)}`); + } finally { + clearProcessingDecoration(editor); + clearProcessingLock(); + } +} + +async function handleBack(): Promise { + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + + const state = getDocState(editor.document); + try { + outputChannel?.appendLine('[proof] back'); + const result = await requestProof('easycrypt/proof/back', { + uri: editor.document.uri.toString() + }); + if (outputHasError(result.output)) { + outputChannel?.appendLine(`[proof] back reported error ${result.output}`); + if (result.sentenceStart != null) { + handleProofError(result.output, editor, result.sentenceStart); + } else { + handleProofError(result.output, editor); + } + } else { + state.lastOffset = result.processedEnd; + outputChannel?.appendLine(`[proof] back ok uuid=${result.uuid} mode=${result.mode}`); + showGoals(result.output); + updateProcessedDecoration(editor); + clearErrorDecoration(editor); + clearDiagnostics(editor.document); + } + } catch (err) { + outputChannel?.appendLine(`[proof] back failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt back failed: ${String(err)}`); + } +} + +async function handleRestart(): Promise { + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + const state = editor ? getDocState(editor.document) : undefined; + const previousOffset = state?.lastOffset ?? 0; + + try { + outputChannel?.appendLine('[proof] restart'); + const result = await requestProof('easycrypt/proof/restart', { + uri: editor.document.uri.toString() + }); + outputChannel?.appendLine(`[proof] restart ok uuid=${result.uuid} mode=${result.mode}`); + if (outputHasError(result.output)) { + outputChannel?.appendLine(`[proof] restart reported error ${result.output}`); + handleProofError(result.output, editor); + if (state) { + state.lastOffset = previousOffset; + } + } else { + if (state) { + state.lastOffset = result.processedEnd; + } + showGoals(result.output); + updateProcessedDecoration(editor ?? vscode.window.activeTextEditor); + clearErrorDecoration(editor ?? vscode.window.activeTextEditor); + if (editor) { + clearDiagnostics(editor.document); + } + } + } catch (err) { + outputChannel?.appendLine(`[proof] restart failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt restart failed: ${String(err)}`); + } +} + +async function handleGoals(): Promise { + try { + outputChannel?.appendLine('[proof] goals'); + const editor = getEditorForCommand(); + if (!editor) { + vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); + return; + } + const result = await requestProof('easycrypt/proof/goals', { + uri: editor.document.uri.toString() + }); + outputChannel?.appendLine(`[proof] goals ok uuid=${result.uuid} mode=${result.mode}`); + showGoals(result.output); + } catch (err) { + outputChannel?.appendLine(`[proof] goals failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt goals failed: ${String(err)}`); + } +} + +function resolveServerCommand( + workspaceFolder: string | undefined, + cliPath: string +): string | undefined { + if (cliPath && cliPath.trim().length > 0) { + return cliPath; + } + + if (!workspaceFolder) { + return undefined; + } + + const exeCandidate = path.join(workspaceFolder, '_build', 'default', 'src', 'ec.exe'); + const unixCandidate = path.join(workspaceFolder, '_build', 'default', 'src', 'ec'); + if (fs.existsSync(exeCandidate)) { + return exeCandidate; + } + if (fs.existsSync(unixCandidate)) { + return unixCandidate; + } + + return undefined; +} + +function ensureLspArgs(args: string[]): string[] { + if (args.length > 0 && args[0] === 'lsp') { + return args; + } + return ['lsp', ...args]; +} + +function startClient(): void { + if (!clientOptions || !serverOptions) { + throw new Error('EasyCrypt LSP options are not configured.'); + } + outputChannel?.appendLine(`[lsp] spawn command=${lspCommand ?? ''} args=${lspArgs.join(' ')}`); + client = new LanguageClient('easycryptLsp', 'EasyCrypt LSP', serverOptions, clientOptions); + outputChannel?.appendLine('[lsp] starting client'); + clientReady = client.start(); + void clientReady.then( + () => outputChannel?.appendLine('[lsp] client ready'), + (err) => outputChannel?.appendLine(`[lsp] client start failed ${String(err)}`) + ); + void clientReady.then(() => client?.setTrace(traceLevel)); +} + +async function restartClient(): Promise { + if (!serverOptions || !clientOptions) { + vscode.window.showErrorMessage('EasyCrypt: LSP options are not configured.'); + return; + } + const current = client; + if (current) { + try { + await current.stop(); + } catch (err) { + vscode.window.showWarningMessage(`EasyCrypt: failed to stop LSP (${String(err)}).`); + } + } + startClient(); + outputChannel?.appendLine('[lsp] restarted client'); + vscode.window.showInformationMessage('EasyCrypt: LSP restarted.'); +} + +export function activate(context: vscode.ExtensionContext): void { + outputChannel = vscode.window.createOutputChannel('EasyCrypt'); + context.subscriptions.push(outputChannel); + queryStatusBarItem = vscode.window.createStatusBarItem(vscode.StatusBarAlignment.Left, 100); + queryStatusBarItem.text = '$(symbol-namespace) EasyCrypt'; + queryStatusBarItem.tooltip = 'EasyCrypt query commands'; + queryStatusBarItem.command = 'easycrypt.query.statusBar'; + context.subscriptions.push(queryStatusBarItem); + printStatusBarItem = vscode.window.createStatusBarItem(vscode.StatusBarAlignment.Left, 99); + printStatusBarItem.command = 'easycrypt.query.printCurrent'; + context.subscriptions.push(printStatusBarItem); + locateStatusBarItem = vscode.window.createStatusBarItem(vscode.StatusBarAlignment.Left, 99); + locateStatusBarItem.command = 'easycrypt.query.locateCurrent'; + context.subscriptions.push(locateStatusBarItem); + processedDecoration = vscode.window.createTextEditorDecorationType({ + backgroundColor: 'rgba(120, 140, 180, 0.18)', + isWholeLine: false, + rangeBehavior: vscode.DecorationRangeBehavior.ClosedClosed + }); + context.subscriptions.push(processedDecoration); + processingDecoration = vscode.window.createTextEditorDecorationType({ + backgroundColor: 'rgba(210, 170, 90, 0.28)', + isWholeLine: false + }); + context.subscriptions.push(processingDecoration); + + diagnostics = vscode.languages.createDiagnosticCollection('easycrypt'); + context.subscriptions.push(diagnostics); + + errorDecoration = undefined; + + const workspaceFolder = vscode.workspace.workspaceFolders?.[0]?.uri.fsPath; + const config = vscode.workspace.getConfiguration('easycrypt'); + const cliPath = config.get('cli.path') ?? ''; + const serverCommand = resolveServerCommand(workspaceFolder, cliPath) ?? 'easycrypt'; + const cliArgs = config.get('cli.args') ?? []; + const serverArgs = ensureLspArgs(cliArgs); + lspCommand = serverCommand; + lspArgs = serverArgs; + const traceSetting = config.get('trace.server') ?? 'off'; + traceLevel = + traceSetting === 'verbose' + ? Trace.Verbose + : traceSetting === 'messages' + ? Trace.Messages + : Trace.Off; + + outputChannel.appendLine(`[lsp] serverCommand=${serverCommand}`); + outputChannel.appendLine(`[lsp] cliPath=${cliPath || '(default)'}`); + outputChannel.appendLine(`[lsp] cliArgs=${cliArgs.join(' ')}`); + outputChannel.appendLine(`[lsp] serverArgs=${serverArgs.join(' ')}`); + outputChannel.appendLine(`[lsp] trace=${traceSetting}`); + outputChannel.appendLine( + `[lsp] logFile=${workspaceFolder ? path.join(workspaceFolder, '.easycrypt-lsp.log') : '(inherit)'}` + ); + outputChannel.show(true); + + if (!resolveServerCommand(workspaceFolder, cliPath)) { + vscode.window.showWarningMessage( + "EasyCrypt binary not found in the workspace. Using 'easycrypt' from PATH." + ); + } + + const lspEnv = { + ...process.env, + EASYCRYPT_LSP_LOG: workspaceFolder + ? path.join(workspaceFolder, '.easycrypt-lsp.log') + : process.env.EASYCRYPT_LSP_LOG + }; + const localServerOptions: ServerOptions = { + command: serverCommand, + args: serverArgs, + transport: TransportKind.stdio, + options: { env: lspEnv } + }; + + const localClientOptions: LanguageClientOptions = { + documentSelector: [{ language: 'easycrypt' }], + outputChannel, + traceOutputChannel: outputChannel + }; + + serverOptions = localServerOptions; + clientOptions = localClientOptions; + startClient(); + context.subscriptions.push( + new vscode.Disposable(() => { + outputChannel?.appendLine('[lsp] stopping client'); + void client?.stop(); + }) + ); + if (client) { + client.onDidChangeState((event) => { + outputChannel?.appendLine(`[lsp] state ${event.oldState} -> ${event.newState}`); + }); + } + + context.subscriptions.push( + vscode.commands.registerCommand('easycrypt.proof.step', handleStep), + vscode.commands.registerCommand('easycrypt.proof.back', handleBack), + vscode.commands.registerCommand('easycrypt.proof.restart', handleRestart), + vscode.commands.registerCommand('easycrypt.proof.jumpToCursor', handleSendRegion), + vscode.commands.registerCommand('easycrypt.proof.goals', handleGoals), + vscode.commands.registerCommand('easycrypt.query.print', handlePrintQuery), + vscode.commands.registerCommand('easycrypt.query.locate', handleLocateQuery), + vscode.commands.registerCommand('easycrypt.query.search', handleSearchQuery), + vscode.commands.registerCommand('easycrypt.query.statusBar', handleQueryStatusBar), + vscode.commands.registerCommand('easycrypt.query.printCurrent', handlePrintCurrentQuery), + vscode.commands.registerCommand('easycrypt.query.locateCurrent', handleLocateCurrentQuery), + vscode.commands.registerCommand('easycrypt.lsp.restart', restartClient) + ); + + context.subscriptions.push( + vscode.workspace.onDidCloseTextDocument((doc) => { + docStates.delete(doc.uri.toString()); + }) + ); + + context.subscriptions.push( + vscode.workspace.onDidChangeTextDocument(async (event) => { + if (suppressProcessedEdits || suppressProcessingEdits) { + return; + } + if (event.contentChanges.length === 0) { + return; + } + const doc = event.document; + if (doc.languageId !== 'easycrypt') { + return; + } + if (processingDocUri && processingDocUri === doc.uri.toString()) { + suppressProcessingEdits = true; + try { + await restoreProcessingSnapshot(doc); + } catch (err) { + outputChannel?.appendLine(`[proof] processing lock restore failed ${String(err)}`); + } finally { + suppressProcessingEdits = false; + } + return; + } + clearErrorDecoration(vscode.window.activeTextEditor); + clearDiagnostics(doc); + const state = getDocState(doc); + const limit = state.lastOffset; + const earliestStart = event.contentChanges.reduce((min, change) => { + const start = change.range ? doc.offsetAt(change.range.start) : 0; + return Math.min(min, start); + }, Number.POSITIVE_INFINITY); + if (!(earliestStart < limit)) { + return; + } + suppressProcessedEdits = true; + try { + try { + const result = await requestProof('easycrypt/proof/jumpTo', { + uri: doc.uri.toString(), + target: earliestStart + }); + state.lastOffset = result.processedEnd; + } catch (err) { + outputChannel?.appendLine(`[proof] auto-rewind failed ${String(err)}`); + vscode.window.showErrorMessage(`EasyCrypt auto-rewind failed: ${String(err)}`); + } + updateProcessedDecoration(vscode.window.activeTextEditor); + } finally { + suppressProcessedEdits = false; + } + return; + }) + ); + + const updateEditorState = (editor: vscode.TextEditor | undefined) => { + if (editor && editor.document.languageId === 'easycrypt') { + lastEasyCryptEditor = editor; + } + updateProcessedDecoration(editor); + refreshQueryStatusBar(editor); + clearErrorDecoration(editor); + if (editor) { + clearDiagnostics(editor.document); + } + }; + + updateEditorState(vscode.window.activeTextEditor); + + context.subscriptions.push( + vscode.window.onDidChangeTextEditorSelection((event) => { + refreshQueryStatusBar(event.textEditor); + }) + ); + + context.subscriptions.push( + vscode.window.onDidChangeActiveTextEditor((editor) => { + updateEditorState(editor); + }) + ); + +} + +export async function deactivate(): Promise { + if (client) { + await client.stop(); + } +} diff --git a/vscode/syntaxes/easycrypt.tmLanguage.json b/vscode/syntaxes/easycrypt.tmLanguage.json new file mode 100644 index 0000000000..af025d0dce --- /dev/null +++ b/vscode/syntaxes/easycrypt.tmLanguage.json @@ -0,0 +1,101 @@ +{ + "$schema": "https://raw.githubusercontent.com/martinring/tmlanguage/master/tmlanguage.json", + "name": "EasyCrypt", + "scopeName": "source.easycrypt", + "patterns": [ + { "include": "#comments" }, + { "include": "#strings" }, + { "include": "#keywords" }, + { "include": "#types" }, + { "include": "#numbers" } + ], + "repository": { + "comments": { + "patterns": [ + { + "name": "comment.block.easycrypt", + "begin": "\\(\\*", + "beginCaptures": { + "0": { "name": "punctuation.definition.comment.easycrypt" } + }, + "end": "\\*\\)", + "endCaptures": { + "0": { "name": "punctuation.definition.comment.easycrypt" } + }, + "patterns": [ + { "include": "#comments" } + ] + } + ] + }, + "strings": { + "patterns": [ + { + "name": "string.quoted.double.easycrypt", + "begin": "\"", + "beginCaptures": { + "0": { "name": "punctuation.definition.string.begin.easycrypt" } + }, + "end": "\"", + "endCaptures": { + "0": { "name": "punctuation.definition.string.end.easycrypt" } + }, + "patterns": [ + { + "name": "constant.character.escape.easycrypt", + "match": "\\\\." + } + ] + } + ] + }, + "keywords": { + "patterns": [ + { + "name": "keyword.other.easycrypt.bytac", + "match": "\\b(assumption|by|check|coq|done|edit|exact|fix|reflexivity|smt|solve)\\b" + }, + { + "name": "keyword.other.easycrypt.dangerous", + "match": "\\b(admit|admitted)\\b" + }, + { + "name": "keyword.control.easycrypt.global", + "match": "\\b(Pr|Self|Top|abbrev|abort|abstract|as|axiom|axiomatized|class|clone|const|declare|dump|end|exit|export|from|global|goal|hint|import|include|inductive|instance|lemma|local|locate|module|notation|of|op|pred|print|proof|prover|qed|realize|remove|rename|require|search|section|subtype|theory|timeout|type|why3|with)\\b" + }, + { + "name": "keyword.other.easycrypt.internal", + "match": "\\b(debug|fail|pragma|time|undo)\\b" + }, + { + "name": "keyword.operator.easycrypt.prog", + "match": "\\b(assert|async|ehoare|elif|else|equiv|exists|for|for|forall|fun|glob|hoare|if|in|is|islossless|let|match|match|phoare|proc|res|return|then|var|while)\\b" + }, + { + "name": "keyword.control.easycrypt.tactic", + "match": "\\b(algebra|alias|apply|auto|beta|byehoare|byequiv|byphoare|bypr|byupto|call|case|cbv|cfold|change|clear|congr|conseq|delta|eager|ecall|elim|eta|exfalso|exlim|fel|field|fieldeq|fission|fusion|gen|have|idassign|idtac|inline|interleave|iota|kill|left|logic|modpath|move|outline|pose|pr_bounded|progress|rcondf|rcondt|replace|rewrite|right|ring|ringeq|rnd|rndsem|rwnormal|seq|sim|simplify|skip|sp|split|splitwhile|subst|suff|swap|symmetry|transitivity|trivial|unroll|weakmem|wlog|wp|zeta)\\b" + }, + { + "name": "keyword.control.easycrypt.tactical", + "match": "\\b(do|expect|first|last|try)\\b" + } + ] + }, + "types": { + "patterns": [ + { + "name": "storage.type.easycrypt", + "match": "\\b(bool|int|real|unit)\\b" + } + ] + }, + "numbers": { + "patterns": [ + { + "name": "constant.numeric.easycrypt", + "match": "\\b\\d+(?:\\.\\d+)?\\b" + } + ] + } + } +} diff --git a/vscode/tsconfig.json b/vscode/tsconfig.json new file mode 100644 index 0000000000..6da6eaa6cf --- /dev/null +++ b/vscode/tsconfig.json @@ -0,0 +1,13 @@ +{ + "compilerOptions": { + "target": "ES2020", + "module": "commonjs", + "lib": ["ES2020"], + "outDir": "out", + "rootDir": "src", + "sourceMap": true, + "strict": true, + "esModuleInterop": true + }, + "include": ["src"] +} From cd6faa0ef208935347915e16bb29e9edb1e64ac1 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Thu, 26 Mar 2026 14:17:52 +0100 Subject: [PATCH 044/145] fix dune --- src/dune | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/dune b/src/dune index 53c3a9b40d..a699ccd3c3 100644 --- a/src/dune +++ b/src/dune @@ -16,7 +16,7 @@ (public_name easycrypt.ecLib) (foreign_stubs (language c) (names eunix)) (modules :standard \ ec) - (libraries batteries camlp-streams dune-build-info dune-site inifiles logs logs.fmt lsp lwt lwt.unix markdown markdown.html pcre2 tyxml why3 yojson zarith) + (libraries batteries camlp-streams dune-build-info dune-site inifiles logs logs.fmt lospecs lsp lwt lwt.unix markdown markdown.html pcre2 tyxml why3 yojson zarith) ) (executable From 11857f35fc78fa69ebaca696c0e02ff0d5d360bb Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Mon, 30 Mar 2026 10:51:09 +0100 Subject: [PATCH 045/145] Fixed circuit test binding syntax --- tests/circuit_test.ec | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/circuit_test.ec b/tests/circuit_test.ec index a91835a275..0ce429f464 100644 --- a/tests/circuit_test.ec +++ b/tests/circuit_test.ec @@ -175,4 +175,4 @@ circuit. qed. bind circuit - (+^) <- "BVXOR_8". + (+^) <- "BVXOR_8" from "../examples/example_specs.spec". From 668095975a713a4a1f7e826a873e922c236da8c2 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 30 Mar 2026 13:21:04 +0200 Subject: [PATCH 046/145] Fix simplify flag handling in `cfold` --- src/phl/ecPhlCodeTx.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/phl/ecPhlCodeTx.ml b/src/phl/ecPhlCodeTx.ml index 1a938a6fd8..5d49a34fc2 100644 --- a/src/phl/ecPhlCodeTx.ml +++ b/src/phl/ecPhlCodeTx.ml @@ -239,8 +239,8 @@ let cfold_stmt let e_simplify, i_simplify = if simplify - then (identity, identity) - else (e_simplify, i_simplify) in + then (e_simplify, i_simplify) + else (identity, identity) in (* Process one instruction under the current propagated substitution and From f3c8905a7318a0b3029116dde3a3b626a42dc73b Mon Sep 17 00:00:00 2001 From: Gustavo Delerue Date: Mon, 30 Mar 2026 16:04:05 +0100 Subject: [PATCH 047/145] Added precondition attachment to non-equality goals for bdep --- src/ecCircuits.ml | 43 ++++++++++++++++++++++++------------- src/ecCircuits.mli | 2 ++ src/phl/ecPhlBDep.ml | 28 +++++++++++++----------- theories/datatypes/QFABV.ec | 2 -- 4 files changed, 45 insertions(+), 30 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 26b2c028c4..c2b2b0762b 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -901,28 +901,14 @@ let circuit_of_form end; res - -let circuit_simplify_equality ?(do_time = true) ~(st: state) ~(hyps: hyps) ~(pres: circuit list) (f1: form) (f2: form) : bool = +let circuit_check_posts ?(do_time = true) ~(env: env) ~(pres: circuit list) (posts: circuit list) = let tm = ref (Unix.gettimeofday ()) in - let env = toenv hyps in let time (env: env) (t: float ref) (msg: string) : unit = let new_t = Unix.gettimeofday () in EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. !t); t := new_t in - EcEnv.notify env `Debug "Filletting circuit...@."; - let c1 = circuit_of_form st hyps f1 |> state_close_circuit st in - if do_time then time env tm "Left side circuit generation done"; - let c2 = circuit_of_form st hyps f2 |> state_close_circuit st in - if do_time then time env tm "Right side circuit generation done"; - - let pres = List.map (state_close_circuit st) pres in (* Assumes pres come open *) - assert (Option.is_none @@ circuit_has_uninitialized c1); - assert (Option.is_none @@ circuit_has_uninitialized c2); - let posts = circuit_eqs c1 c2 in - if do_time then time env tm "Done with postcondition circuit generation"; - EcEnv.notify env `Debug "Number of checks before batching: %d@." (List.length posts); let posts = batch_checks ~mode:`BySub posts in EcEnv.notify env `Debug "Number of checks after batching: %d@." (List.length posts); @@ -938,6 +924,33 @@ let circuit_simplify_equality ?(do_time = true) ~(st: state) ~(hyps: hyps) ~(pre false end +let circuits_of_equality ?(do_time = true) ~(st: state) ~(hyps: hyps) (f1: form) (f2: form) : circuit list = + let tm = ref (Unix.gettimeofday ()) in + let env = toenv hyps in + let time (env: env) (t: float ref) (msg: string) : unit = + let new_t = Unix.gettimeofday () in + EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. !t); + t := new_t + in + + EcEnv.notify env `Debug "Filletting circuit...@."; + let c1 = circuit_of_form st hyps f1 |> state_close_circuit st in + if do_time then time env tm "Left side circuit generation done"; + let c2 = circuit_of_form st hyps f2 |> state_close_circuit st in + if do_time then time env tm "Right side circuit generation done"; + + assert (Option.is_none @@ circuit_has_uninitialized c1); + assert (Option.is_none @@ circuit_has_uninitialized c2); + let posts = circuit_eqs c1 c2 in + if do_time then time env tm "Done with postcondition circuit generation"; + posts + + +let circuit_simplify_equality ?(do_time = true) ~(st: state) ~(hyps: hyps) ~(pres: circuit list) (f1: form) (f2: form) : bool = + let posts = circuits_of_equality ~do_time ~st ~hyps f1 f2 in + circuit_check_posts ~do_time ~env:(toenv hyps) ~pres posts + + (* FIXME: add support for spec bindings for abstract/opaque operators = convert from Fop rather than from op body *) let circuit_of_path (st: state) (hyps: hyps) (p: path) : circuit = diff --git a/src/ecCircuits.mli b/src/ecCircuits.mli index 08db055905..cf1984eac1 100644 --- a/src/ecCircuits.mli +++ b/src/ecCircuits.mli @@ -78,6 +78,8 @@ val circ_taut : circuit -> bool (* Generate circuits *) (* Form processors *) val circuit_of_form : state -> hyps -> form -> circuit +val circuit_check_posts : ?do_time:bool -> env:env -> pres:circuit list -> circuit list -> bool +val circuits_of_equality : ?do_time:bool -> st:state -> hyps:hyps -> form -> form -> circuit list val circuit_simplify_equality : ?do_time:bool -> st:state -> hyps:hyps -> pres:circuit list -> form -> form -> bool val circ_simplify_form_bitstring_equality : ?st:state -> diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index 5ba0c1bd64..2aa2e2127d 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -145,21 +145,23 @@ let process_pre ?(st : state option) (tc: tcenv1) (f: form) : state * circuit li st, cs let solve_post ~(st: state) ~(pres: circuit list) (hyps: hyps) (post: form) : bool = + let env = toenv hyps in let destr_conj = destr_conj hyps in let posts = destr_conj post in - - List.for_all (fun post -> - EcEnv.notify (toenv hyps) `Debug "Solving post: %a@." - EcPrinting.(pp_form PPEnv.(ofenv (toenv hyps))) post; - match post.f_node with - | Fapp ({f_node= Fop(p, _); _}, [f1; f2]) -> - begin match EcFol.op_kind p with - | Some `Eq -> - circuit_simplify_equality ~st ~hyps ~pres f1 f2 - | _ -> circuit_of_form st hyps post |> state_close_circuit st |> circ_taut - end - | _ -> circuit_of_form st hyps post |> state_close_circuit st |> circ_taut - ) posts + let pres = List.map (state_close_circuit st) pres in + + posts |> List.to_seq |> Seq.concat_map (fun post -> + EcEnv.notify (toenv hyps) `Debug "Translating post: %a@." + EcPrinting.(pp_form PPEnv.(ofenv (toenv hyps))) post; + match post.f_node with + | Fapp ({f_node= Fop(p, _); _}, [f1; f2]) -> + begin match EcFol.op_kind p with + | Some `Eq -> + circuits_of_equality ~st ~hyps f1 f2 |> List.to_seq + | _ -> Seq.return (circuit_of_form st hyps post |> state_close_circuit st) + end + | _ -> Seq.return (circuit_of_form st hyps post |> state_close_circuit st) + ) |> List.of_seq |> circuit_check_posts ~env ~pres (* TODO: Figure out how to not repeat computations here? *) let t_bdep_solve diff --git a/theories/datatypes/QFABV.ec b/theories/datatypes/QFABV.ec index 4466d74032..a09af42771 100644 --- a/theories/datatypes/QFABV.ec +++ b/theories/datatypes/QFABV.ec @@ -383,8 +383,6 @@ theory BVOperators. => take BV2.size (drop (base * BV2.size) (BV1.tolist bv)) = BV2.tolist (bvaextract bv base). end BVAExtract. -print List.mkseq. - (* ------------------------------------------------------------------ *) abstract theory BVInsert. clone BV as BV1. From fe9fba3e9e725ee6ab579847e8988f2c35e2b100 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sat, 11 Apr 2026 09:12:50 +0200 Subject: [PATCH 048/145] Add goal printing flags (-upto, -lastgoals) and LLM agent guide Add two new flags for the `easycrypt` CLI to support LLM coding agents: - `-upto `: compile up to a given position and print goals there - `-lastgoals`: print the last unproven goals Also add a dedicated `llm` command mode and an LLM agent guide (doc/llm/CLAUDE.md) documenting EasyCrypt tactics and workflow for use with AI coding assistants. --- README.md | 8 -- assets/latex/eclistings.sty | 155 ------------------------------------ doc/llm/CLAUDE.md | 149 ++++++++++++++++++++++++++++++++++ src/ec.ml | 53 +++++++++++- src/ecCommands.ml | 7 ++ src/ecCommands.mli | 1 + src/ecOptions.ml | 46 +++++++++++ src/ecOptions.mli | 8 ++ src/ecTerminal.ml | 15 ++-- src/ecTerminal.mli | 1 + src/phl/ecPhlLoopTx.ml | 4 +- theories/algebra/Perms.ec | 16 ++-- 12 files changed, 286 insertions(+), 177 deletions(-) delete mode 100644 assets/latex/eclistings.sty create mode 100644 doc/llm/CLAUDE.md diff --git a/README.md b/README.md index 9ef3d2917e..902d7bc3cb 100644 --- a/README.md +++ b/README.md @@ -26,7 +26,6 @@ EasyCrypt is part of the [Formosa Crypto project](https://formosa-crypto.org/). - [Visual Studio Code](#visual-studio-code) - [Useful Resources](#useful-resources) - [Examples](#examples) - - [LaTeX Formatting](#latex-formatting) # Installation @@ -186,10 +185,3 @@ Examples of how to use EasyCrypt are in the `examples` directory. You will find basic examples at the root of this directory, as well as a more advanced example in the `MEE-CBC` sub-directory and a tutorial on how to use the complexity system in `cost` sub-directory. - -## LaTeX Formatting - -LaTeX style file is in `assets/latex` directory. The basic usages are -`\begin{eclst} ... \end{eclst}` (display mode) and -`\ecinl{proc main() = { ... }}` (inline mode). - diff --git a/assets/latex/eclistings.sty b/assets/latex/eclistings.sty deleted file mode 100644 index 7b5c15d681..0000000000 --- a/assets/latex/eclistings.sty +++ /dev/null @@ -1,155 +0,0 @@ -\NeedsTeXFormat{LaTeX2e} -\ProvidesPackage{eclistings}[2026/04/07 EasyCrypt listings] - -\RequirePackage{listings} -\RequirePackage{xcolor} -\RequirePackage{xparse} - -% EasyCrypt % Language -\lstdefinelanguage{easycrypt}{% - sensitive=true, % Case sensitive keywords - % Keywords: Global and programming language - morekeywords=[1]% - { - Pr, Self, Top, abbrev, abort, abstract, as, axiom, axiomatized, clone, const, - declare, dump, end, exception, exit, export, from, global, goal, hint, import, - include, inductive, instance, lemma, local, locate, module, notation, of, op, - pred, print, proof, prover, qed, realize, remove, rename, require, search, - section, subtype, theory, timeout, type, why3, with, - async, ehoare, elif, else, equiv, exists, for, forall, fun, glob, hoare, if, - in, is, islossless, let, match, phoare, proc, raise, res, return, then, var, - while - }, - % Keywords: Regular (i.e., non-closing) tactics - morekeywords=[2]% - { - algebra, alias, apply, auto, beta, byehoare, byequiv, byphoare, bypr, byupto, - call, case, cbv, cfold, change, clear, congr, conseq, delta, eager, ecall, - elim, eta, exfalso, exlim, fel, field, fieldeq, fission, fusion, gen, have, - idassign, idtac, inline, interleave, iota, kill, left, logic, modpath, move, - outline, pose, pr_bounded, progress, rcondf, rcondt, replace, rewrite, right, - ring, ringeq, rnd, rndsem, rwnormal, seq, sim, simplify, skip, sp, split, - splitwhile, subst, suff, swap, symmetry, transitivity, trivial, unroll, - weakmem, wlog, wp, zeta - }, - % Keywords: Closing/byclose tactics and dangerous commands - morekeywords=[3]% - { - admit, admitted, - assumption, by, check, coq, done, edit, exact, fix, reflexivity, smt, solve - }, - % Keywords: Tacticals and internal - morekeywords=[4]% - { - do, expect, first, last, try, - debug, fail, pragma, time, undo - }, - comment=[n]{(*}{*)}, % Multi-line, nested comments delimited by (* and *) - string=[d]{"}, % Strings delimited by " and ", non-escapable -} - -% Style (base/default) -\lstdefinestyle{easycrypt-base}{% - % Frame - captionpos=t, % Position caption at top (mirroring what's typical for algorithms) - frame=tb, % Top and bottom rules - framesep=\smallskipamount, % Small skip between frame and listing content - % Float placement - floatplacement=tbhp, - % Character printing and placement - upquote=true, % Print backtick and single quote as is - columns=[c]fixed, % Monospace characters, centered in their box - keepspaces=true, % Don't drop spaces for column alignment - tabsize=2, % Tabstops every 2 spaces - mathescape=false, % Don't allow escaping to LaTeX with $ - showstringspaces=false, % Don't print characters for spaces - % Line numbers - numbers=none, % No line numbers - % Basic style - basicstyle={\normalsize\ttfamily}, - % Style for (non-keyword) identifiers - identifierstyle={}, -} - -% Define default colors based on availability of colorblind colors -\@ifpackageloaded{colorblind}{ - \lstdefinestyle{easycrypt-default}{% - style=easycrypt-base, - % Styles for different keyword classes - keywordstyle=[1]{\color{T-Q-B6}},% - keywordstyle=[2]{\color{T-Q-B1}},% - keywordstyle=[3]{\color{T-Q-B5}},% - keywordstyle=[4]{\color{T-Q-B4}},% - % Styles for comments and strings - commentstyle={\itshape\color{T-Q-B0}},% - stringstyle={\color{T-Q-B3}}, - % Style of line numbers (in case numbers is overwritten to true) - numberstyle={\small\color{T-Q-B0}}, - } -}{% - \lstdefinestyle{easycrypt-default}{% - style=easycrypt-base, - % Styles for different keyword classes - keywordstyle=[1]{\color{violet}},% - keywordstyle=[2]{\color{blue}},% - keywordstyle=[3]{\color{red}},% - keywordstyle=[4]{\color{olive}},% - % Styles for comments and strings - commentstyle={\itshape\color{gray}},% - stringstyle={\color{green}}, - % Style of line numbers (in case numbers is overwritten to true) - numberstyle={\small\color{gray}}, - } -} - -% Style for drafting/debugging (explicit spaces/tabs) -\lstdefinestyle{easycrypt-draft}{% - style=easycrypt-default, - showspaces=true, - showtabs=true, - showstringspaces=true, -} - -% Style without top/bottom frame rules -\lstdefinestyle{easycrypt-plain}{% - style=easycrypt-default, - frame=none, - framesep=0pt, - basicstyle={\small\ttfamily}, - aboveskip=0.3\baselineskip, - belowskip=0.3\baselineskip, - columns=fullflexible -} - -% Environments % Default, non-floating environment % Meant to be used inside -%other (potentially floating) environment % that takes care of the caption and -%surrounding spacing -\lstnewenvironment{eclst}[1][]{% - \lstset{% - language=easycrypt,% - style=easycrypt-default,% - aboveskip=\smallskipamount,% Equal to framesep of style if top rule, else 0pt - belowskip=\smallskipamount,% Equal to framesep of style if bottom rule, else 0pt - abovecaptionskip=0pt,% - belowcaptionskip=0pt,% - #1% - }% -}{} - -% Inline -\NewDocumentCommand{\ecinl}{O{easycrypt-default} m O{}}{% - \lstinline[% - language=easycrypt,% - style=#1,% - breaklines,% - breakindent=0pt,% - columns=fullflexible,% - #3% - ]{#2}% -} - -\NewDocumentCommand{\ecinlfoot}{O{easycrypt-default} m O{}}{% - \ecinl[#1]{#2}[basicstyle={\footnotesize\ttfamily},#3]% -} - -\endinput \ No newline at end of file diff --git a/doc/llm/CLAUDE.md b/doc/llm/CLAUDE.md new file mode 100644 index 0000000000..0cc20c5a38 --- /dev/null +++ b/doc/llm/CLAUDE.md @@ -0,0 +1,149 @@ +# EasyCrypt — LLM Agent Guide + +EasyCrypt is a proof assistant for reasoning about the security of +cryptographic constructions. It provides support for probabilistic +computations, program logics (Hoare logic, probabilistic Hoare logic, +probabilistic relational Hoare logic), and ambient mathematical +reasoning. + +## Using the `llm` command + +The `llm` subcommand is designed for non-interactive, LLM-friendly +batch compilation. It produces no progress bar and no `.eco` cache +files. + +``` +easycrypt llm [OPTIONS] FILE.ec +``` + +### Options + +- `-upto LINE` or `-upto LINE:COL` — Compile up to (but not + including) the given location, then print the current goal state to + stdout and exit with code 0. Use this to inspect the proof state at + a specific point in a file. + +- `-lastgoals` — On failure, print the goal state (as it was just + before the failing command) to stdout, then print the error to + stderr, and exit with code 1. Use this to understand what the + failing tactic was supposed to prove. + +Standard loader and prover options (`-I`, `-timeout`, `-p`, etc.) are +also available. + +### Output conventions + +- **Goals** are printed to **stdout**. +- **Errors** are printed to **stderr**. +- **Exit code 0** means success (or `-upto` reached its target). +- **Exit code 1** means a command failed. +- If there is no active proof at the point where goals are requested, + stdout will contain: `No active proof.` + +### Workflow for writing and debugging proofs + +1. Try to write a pen-and-paper proof first. + +2. Write the `.ec` file with your proof attempt. For a large proof, + write down skeleton and `admit` subgoals first, and then detail + the proof. + +3. Run `easycrypt llm -lastgoals FILE.ec` to check the full file. + - If it succeeds (exit 0), you are done. + - If it fails (exit 1), read the error from stderr and the goal + state from stdout to understand what went wrong. + +4. Use `-upto LINE` to inspect the proof state at a specific point + without running the rest of the file. This is useful for + incremental proof development. + +5. Fix the proof and repeat from step 2. The ultimate proof should + not contain `admit` or `admitted`. + +## EasyCrypt language overview + +### File structure + +An EasyCrypt file typically begins with `require` and `import` +statements, followed by type, operator, and module declarations, and +then lemma statements with their proofs. + +``` +require import AllCore List. + +type key. +op n : int. +axiom gt0_n : 0 < n. + +lemma foo : 0 < n + 1. +proof. smt(gt0_n). qed. +``` + +### Proofs + +A proof is delimited by `proof.` and `qed.`. Inside, tactics are +applied sequentially to transform the goal until it is discharged. + +``` +lemma bar (x : int) : x + 0 = x. +proof. by ring. qed. +``` + +### Common tactics + + + +- `trivial` — solve trivial goals +- `smt` / `smt(lemmas...)` — call SMT solvers, optionally with hints +- `auto` — automatic reasoning +- `split` — split conjunctions +- `left` / `right` — choose a disjunct +- `assumption` — close goal from a hypothesis +- `apply H` — apply a hypothesis or lemma +- `rewrite H` — rewrite using an equality +- `have : P` — introduce an intermediate goal +- `elim` — elimination / induction +- `case` — case analysis +- `congr` — congruence +- `ring` / `field` — algebraic reasoning +- `proc` — unfold a procedure (program logics) +- `inline` — inline a procedure call +- `sp` / `wp` — symbolic execution (forward / backward) +- `if` — handle conditionals in programs +- `while I` — handle while loops with invariant `I` +- `rnd` — handle random sampling +- `seq N : P` — split a program at statement `N` with mid-condition `P` +- `conseq` — weaken/strengthen pre/postconditions +- `byequiv` / `byphoare` — switch between program logics +- `skip` — skip trivial program steps +- `sim` — similarity (automatic relational reasoning) +- `ecall` — external call + +### Tactic combinators + +- `by tac.` — apply `tac` and require all goals to be closed +- `tac1; tac2` — sequence +- `try tac` — try, ignore failure +- `do tac` / `do N tac` — repeat +- `[tac1 | tac2 | ...]` — apply different tactics to each subgoal +- `tac => //.` — apply `tac`, then try `trivial` on generated subgoals +- `move=> H` / `move=> /H` — introduction and views + +### Key libraries + +- `AllCore` — re-exports the core libraries (logic, integers, reals, + lists, etc.) +- `Distr` — probability distributions +- `DBool`, `DInterval`, `DList` — specific distributions +- `FSet`, `FMap` — finite sets and maps +- `SmtMap` — maps with SMT support +- `PROM` — programmable/lazy random oracles + +### Guidelines + +* Use SMT solver only in direct mode (smt() or /#) on simple goals (arithmetic goals, pure logical goals). + +* Refrain from unfolding operator definitions unless necessary. + If you need more properties on an operator, state this property in a dedicated lemma, + but avoid unfolding definitions in higher level proofs. + diff --git a/src/ec.ml b/src/ec.ml index 627d25b81b..ada7602b58 100644 --- a/src/ec.ml +++ b/src/ec.ml @@ -415,6 +415,7 @@ let main () = (*---*) gccompact : int option; (*---*) docgen : bool; (*---*) outdirp : string option; + (*---*) upto : (int * int option) option; mutable trace : trace1 list option; } @@ -493,6 +494,7 @@ let main () = ; gccompact = None ; docgen = false ; outdirp = None + ; upto = None ; trace = None } end @@ -528,10 +530,40 @@ let main () = ; gccompact = cmpopts.cmpo_compact ; docgen = false ; outdirp = None + ; upto = None ; trace = trace0 } end + | `Llm llmopts -> begin + let name = llmopts.llmo_input in + + begin try + let ext = Filename.extension name in + ignore (EcLoader.getkind ext : EcLoader.kind) + with EcLoader.BadExtension ext -> + Format.eprintf "do not know what to do with %s@." ext; + exit 1 + end; + + let lastgoals = llmopts.llmo_lastgoals in + let terminal = + lazy (T.from_channel ~name ~progress:`Silent ~lastgoals (open_in name)) + in + + { prvopts = {llmopts.llmo_provers with prvo_iterate = true} + ; input = Some name + ; terminal = terminal + ; interactive = false + ; eco = true + ; gccompact = None + ; docgen = false + ; outdirp = None + ; upto = llmopts.llmo_upto + ; trace = None } + + end + | `Runtest _ -> (* Eagerly executed *) assert false @@ -572,6 +604,7 @@ let main () = ; gccompact = None ; docgen = true ; outdirp = docopts.doco_outdirp + ; upto = None ; trace = None } end @@ -585,7 +618,7 @@ let main () = | Some pwd -> EcCommands.addidir pwd); (* Check if the .eco is up-to-date and exit if so *) - (if not state.docgen then + (if not state.docgen && state.upto = None then oiter (fun input -> if EcCommands.check_eco input then exit 0) state.input); @@ -669,6 +702,16 @@ let main () = if T.interactive terminal then T.notice ~immediate:true `Warning copyright terminal; + (* Check if a location is past the -upto point *) + let past_upto (loc : EcLocation.t) = + match state.upto with + | None -> false + | Some (line, col) -> + let (sl, sc) = loc.loc_start in + sl > line || (sl = line && match col with + | None -> true + | Some c -> sc >= c) in + try if T.interactive terminal then Sys.catch_break true; @@ -737,6 +780,14 @@ let main () = List.iter (fun p -> let loc = p.EP.gl_action.EcLocation.pl_loc in + + (* -upto: if this command starts past the target, print goals and exit *) + if past_upto loc then begin + T.finalize terminal; + EcCommands.pp_current_goal_or_noproof ~all:true Format.std_formatter; + exit 0 + end; + let timed = p.EP.gl_debug = Some `Timed in let break = p.EP.gl_debug = Some `Break in let ignore_fail = ref false in diff --git a/src/ecCommands.ml b/src/ecCommands.ml index 438295196e..474eab8888 100644 --- a/src/ecCommands.ml +++ b/src/ecCommands.ml @@ -1024,6 +1024,13 @@ let pp_current_goal ?(all = false) stream = end end +(* -------------------------------------------------------------------- *) +let pp_current_goal_or_noproof ?(all = false) stream = + if Option.is_some (S.xgoal (current ())) then + pp_current_goal ~all stream + else + Format.fprintf stream "No active proof.@\n%!" + (* -------------------------------------------------------------------- *) let pp_maybe_current_goal stream = match (Pragma.get ()).pm_verbose with diff --git a/src/ecCommands.mli b/src/ecCommands.mli index a72d31a437..e411b99d6c 100644 --- a/src/ecCommands.mli +++ b/src/ecCommands.mli @@ -60,6 +60,7 @@ val doc_comment : [`Global | `Item] * string -> unit (* -------------------------------------------------------------------- *) val pp_current_goal : ?all:bool -> Format.formatter -> unit +val pp_current_goal_or_noproof : ?all:bool -> Format.formatter -> unit val pp_maybe_current_goal : Format.formatter -> unit val pp_all_goals : unit -> string list diff --git a/src/ecOptions.ml b/src/ecOptions.ml index f012e8e8d6..52a4d6e66b 100644 --- a/src/ecOptions.ml +++ b/src/ecOptions.ml @@ -10,6 +10,7 @@ type command = [ | `Runtest of run_option | `Why3Config | `DocGen of doc_option + | `Llm of llm_option ] and options = { @@ -47,6 +48,13 @@ and doc_option = { doco_outdirp : string option; } +and llm_option = { + llmo_input : string; + llmo_provers : prv_options; + llmo_lastgoals : bool; + llmo_upto : (int * int option) option; +} + and prv_options = { prvo_maxjobs : int option; prvo_timeout : int option; @@ -351,6 +359,12 @@ let specs = { `Spec ("trace" , `Flag , "Save all goals & messages in .eco"); `Spec ("compact", `Int , "")]); + ("llm", "LLM-friendly batch compilation", [ + `Group "loader"; + `Group "provers"; + `Spec ("lastgoals" , `Flag , "Print last unproved goals on failure"); + `Spec ("upto" , `String, "Compile up to LINE or LINE:COL and print goals")]); + ("cli", "Run EasyCrypt top-level", [ `Group "loader"; `Group "provers"; @@ -533,6 +547,27 @@ let doc_options_of_values values input = { doco_input = input; doco_outdirp = get_string "outdir" values; } +let parse_upto values = + get_string "upto" values |> Option.map (fun s -> + let invalid () = + raise (Arg.Bad (Printf.sprintf + "invalid -upto format: expected LINE or LINE:COL, got %S" s)) in + match String.split_on_char ':' s with + | [line] -> + let line = try int_of_string line with Failure _ -> invalid () in + (line, None) + | [line; col] -> + let line = try int_of_string line with Failure _ -> invalid () in + let col = try int_of_string col with Failure _ -> invalid () in + (line, Some col) + | _ -> invalid ()) + +let llm_options_of_values ini values input = + { llmo_input = input; + llmo_provers = prv_options_of_values ini values; + llmo_lastgoals = get_flag "lastgoals" values; + llmo_upto = parse_upto values; } + (* -------------------------------------------------------------------- *) let parse getini argv = let (command, values, anons) = parse specs argv in @@ -604,6 +639,17 @@ let parse getini argv = raise (Arg.Bad "this command takes a single input file as argument") end + | "llm" -> begin + match anons with + | [input] -> + let ini = getini (Some input) in + let cmd = `Llm (llm_options_of_values ini values input) in + (cmd, ini, true) + + | _ -> + raise (Arg.Bad "this command takes a single argument") + end + | _ -> assert false in { diff --git a/src/ecOptions.mli b/src/ecOptions.mli index 59009718ad..7ac81ec0a4 100644 --- a/src/ecOptions.mli +++ b/src/ecOptions.mli @@ -6,6 +6,7 @@ type command = [ | `Runtest of run_option | `Why3Config | `DocGen of doc_option + | `Llm of llm_option ] and options = { @@ -43,6 +44,13 @@ and doc_option = { doco_outdirp : string option; } +and llm_option = { + llmo_input : string; + llmo_provers : prv_options; + llmo_lastgoals : bool; + llmo_upto : (int * int option) option; +} + and prv_options = { prvo_maxjobs : int option; prvo_timeout : int option; diff --git a/src/ecTerminal.ml b/src/ecTerminal.ml index 94f7c048e5..c5f85bc814 100644 --- a/src/ecTerminal.ml +++ b/src/ecTerminal.ml @@ -148,8 +148,9 @@ type progress = [ `Human | `Script | `Silent ] class from_channel ?(gcstats : bool = true) ?(progress : progress option) - ~(name : string) - (stream : in_channel) + ?(lastgoals : bool = false) + ~(name : string) + (stream : in_channel) : terminal = object(self) @@ -260,11 +261,11 @@ class from_channel self#_clean_progress_line (); begin match progress with | `Human -> - Format.eprintf "[%s] [%s] %s\n%!" prefix strloc msg; + Format.eprintf "[%s] [%s] %s\n%!" prefix strloc msg | `Script -> Format.eprintf "E %s %s %s\n%!" prefix strloc (String.escaped msg) | `Silent -> - () + Format.eprintf "[%s] [%s] %s\n%!" prefix strloc msg end; self#_update_progress @@ -290,6 +291,8 @@ class from_channel let msg = String.strip (EcPException.tostring e) in self#_clean_progress_line (); + if lastgoals then + EcCommands.pp_current_goal_or_noproof ~all:true Format.std_formatter; self#_notice ?subloc ~immediate:true `Critical msg; self#_update_progress; self#_clean_progress_line ~erase:false (); @@ -314,5 +317,5 @@ class from_channel Format.pp_set_margin Format.err_formatter i end -let from_channel ?gcstats ?progress ~name stream = - new from_channel ?gcstats ?progress ~name stream +let from_channel ?gcstats ?progress ?lastgoals ~name stream = + new from_channel ?gcstats ?progress ?lastgoals ~name stream diff --git a/src/ecTerminal.mli b/src/ecTerminal.mli index 0a96a56d24..faacff0e7f 100644 --- a/src/ecTerminal.mli +++ b/src/ecTerminal.mli @@ -22,6 +22,7 @@ type progress = [ `Human | `Script | `Silent ] val from_channel : ?gcstats:bool -> ?progress:progress + -> ?lastgoals:bool -> name:string -> in_channel -> terminal diff --git a/src/phl/ecPhlLoopTx.ml b/src/phl/ecPhlLoopTx.ml index 71f33072dc..b8bf396d5e 100644 --- a/src/phl/ecPhlLoopTx.ml +++ b/src/phl/ecPhlLoopTx.ml @@ -254,8 +254,8 @@ let process_unroll_for ~cfold side cpos tc = e | _ -> tc_error !!tc - "last instruction of the while loop must be \ - an \"increment\" of the loop counter" in + "last instruction of the while loop must be" + "an \"increment\" of the loop counter" in (* Apply loop increment *) let incrz = diff --git a/theories/algebra/Perms.ec b/theories/algebra/Perms.ec index 1ebc0e1d70..5423d79128 100644 --- a/theories/algebra/Perms.ec +++ b/theories/algebra/Perms.ec @@ -3,13 +3,19 @@ require import AllCore List IntDiv Binomial Ring StdOrder. (*---*) import IntID IntOrder. (* -------------------------------------------------------------------- *) -op allperms_r (n : unit list) (s : 'a list) : 'a list list = -with n = [] => [[]] -with n = x::n => flatten ( +op allperms_r (n : unit list) (s : 'a list) : 'a list list. + +axiom allperms_r0 (s : 'a list) : + allperms_r [] s = [[]]. + +axiom allperms_rS (x : unit) (n : unit list) (s : 'a list) : + allperms_r (x :: n) s = flatten ( map (fun x => map ((::) x) (allperms_r n (rem x s))) (undup s)). op allperms (s : 'a list) = allperms_r (nseq (size s) tt) s. +hint rewrite ap_r : allperms_r0 allperms_rS. + (* -------------------------------------------------------------------- *) lemma allperms_rP n (s t : 'a list) : size s = size n => (mem (allperms_r n s) t) <=> (perm_eq s t). @@ -45,7 +51,7 @@ qed. (* -------------------------------------------------------------------- *) lemma uniq_allperms_r n (s : 'a list) : uniq (allperms_r n s). proof. -elim: n s => [|? n ih] s; rewrite ?ap_r //=. +elim: n s => [|? n ih] s; rewrite ?ap_r //. apply/uniq_flatten_map/undup_uniq. by move=> x /=; apply/map_inj_in_uniq/ih => a b _ _ []. move=> x y; rewrite !mem_undup => sx sy /= /hasP[t]. @@ -73,7 +79,7 @@ require import StdBigop. lemma size_allperms_uniq_r n (s : 'a list) : size s = size n => uniq s => size (allperms_r n s) = fact (size s). proof. -elim: n s => /= [s|n ih s]. +elim: n s => /= [|? n ih] s; rewrite ?ap_r /=. by move/size_eq0=> -> /=; rewrite fact0. case: s=> [|x s]; first by rewrite addz_neq0 ?size_ge0. (pose s' := undup _)=> /=; move/addrI=> eq_sz [Nsz uqs]. From dd93ca9c7d0825fd3fb2cd1999c0f8741902f352 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 13 Apr 2026 00:39:24 +0200 Subject: [PATCH 049/145] Replace LLM batch mode with interactive REPL protocol MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Replace the batch `easycrypt llm file.ec` command with an interactive REPL (`easycrypt llm`) using a line-oriented protocol over stdin/stdout. The REPL supports: - LOAD "file.ec" [LINE[:COL]] — compile a file, optionally up to a line - UNDO / REVERT — navigate proof state - GOALS / GOALS ALL — inspect current or all subgoals - CHECKPOINT — named bookmarks for branching exploration - SEARCH — lemma search - QUIET ON/OFF — suppress goal display for bulk tactic application - Direct EasyCrypt input (tactics, declarations, search, print, etc.) Responses use a typed envelope (OK/ERROR with uuid) and sentinel for reliable parsing by LLM agent frameworks. Additional improvements: - LOAD reports the last processed line in the response tag - Error messages include the source tactic text - Only the current subgoal is shown by default (with remaining count) - LOAD uses loc_end for upto check (more intuitive line semantics) Update doc/llm/CLAUDE.md with the new protocol reference, interactive workflow guide, and proof strategy tips from practical usage. --- doc/llm/CLAUDE.md | 211 +++++++++++++++++++----- src/ec.ml | 404 ++++++++++++++++++++++++++++++++++++++++++---- src/ecOptions.ml | 47 ++---- src/ecOptions.mli | 3 - 4 files changed, 555 insertions(+), 110 deletions(-) diff --git a/doc/llm/CLAUDE.md b/doc/llm/CLAUDE.md index 0cc20c5a38..1ef19b164e 100644 --- a/doc/llm/CLAUDE.md +++ b/doc/llm/CLAUDE.md @@ -6,59 +6,185 @@ computations, program logics (Hoare logic, probabilistic Hoare logic, probabilistic relational Hoare logic), and ambient mathematical reasoning. -## Using the `llm` command +## Using the `llm` interactive mode -The `llm` subcommand is designed for non-interactive, LLM-friendly -batch compilation. It produces no progress bar and no `.eco` cache -files. +The `llm` subcommand provides an interactive REPL with a +machine-friendly protocol designed for LLM agents. The LLM sends +commands over stdin and receives structured responses on stdout. ``` -easycrypt llm [OPTIONS] FILE.ec +easycrypt llm [OPTIONS] ``` -### Options +Standard loader and prover options (`-I`, `-timeout`, `-p`, etc.) are +available. -- `-upto LINE` or `-upto LINE:COL` — Compile up to (but not - including) the given location, then print the current goal state to - stdout and exit with code 0. Use this to inspect the proof state at - a specific point in a file. +### Protocol -- `-lastgoals` — On failure, print the goal state (as it was just - before the failing command) to stdout, then print the error to - stderr, and exit with code 1. Use this to understand what the - failing tactic was supposed to prove. +**Startup.** EasyCrypt prints a `READY` message and waits for input: -Standard loader and prover options (`-I`, `-timeout`, `-p`, etc.) are -also available. +``` +READY [uuid:0] + +``` + +**Responses.** Every response has a typed envelope and an `` +sentinel: + +``` +OK [uuid:N] + + +``` + +``` +ERROR [uuid:N] + + +``` + +The `uuid` is a monotonically increasing integer identifying the proof +engine state. It increments with each successful command. + +### Meta-commands + +These are protocol-level commands, not EasyCrypt syntax: + +| Command | Description | +|---------|-------------| +| `LOAD "file.ec" [LINE[:COL]]` | Reset state, compile file up to the given line | +| `UNDO` | Undo the last proof step | +| `REVERT ` | Revert to a specific state (by uuid or checkpoint name) | +| `GOALS` | Print the current goal (first subgoal only, with remaining count) | +| `GOALS ALL` | Print all subgoals | +| `CHECKPOINT ` | Save current uuid under a name for later `REVERT` | +| `SEARCH ` | Search for lemmas matching a pattern | +| `QUIET ON` / `QUIET OFF` | Suppress/enable automatic goal display after tactics | +| `QUIT` | Exit | + +### EasyCrypt commands + +Any line that is not a meta-command is parsed as EasyCrypt input. +This covers tactics, declarations, `search`, `print`, `require`, +etc. The line must be a complete EasyCrypt statement ending with `.` + +``` +smt(). +rewrite H1 H2. +search (%/). +print mulzK. +``` + +### Workflow + +**1. Load a file up to the proof point:** -### Output conventions +``` +LOAD "myfile.ec" 42 +``` + +This compiles the file through line 42 (processing any command whose +end is on or before that line). The response includes where it +stopped: + +``` +OK [uuid:15] [loaded:myfile.ec:42] +Current goal +... + +``` + +**2. Try tactics interactively:** + +``` +smt(). +``` + +If it fails, the state is unchanged — try another tactic immediately: -- **Goals** are printed to **stdout**. -- **Errors** are printed to **stderr**. -- **Exit code 0** means success (or `-upto` reached its target). -- **Exit code 1** means a command failed. -- If there is no active proof at the point where goals are requested, - stdout will contain: `No active proof.` +``` +rewrite H1. +smt(lemma1 lemma2). +``` -### Workflow for writing and debugging proofs +**3. Use checkpoints for branching exploration:** -1. Try to write a pen-and-paper proof first. +``` +CHECKPOINT before_split +split. +smt(). ← fails +REVERT before_split +apply H. ← try a different approach +``` -2. Write the `.ec` file with your proof attempt. For a large proof, - write down skeleton and `admit` subgoals first, and then detail - the proof. +**4. Use QUIET mode to save tokens during bulk tactic application:** -3. Run `easycrypt llm -lastgoals FILE.ec` to check the full file. - - If it succeeds (exit 0), you are done. - - If it fails (exit 1), read the error from stderr and the goal - state from stdout to understand what went wrong. +``` +QUIET ON +rewrite H1. +rewrite H2. +rewrite H3. +QUIET OFF +GOALS +``` -4. Use `-upto LINE` to inspect the proof state at a specific point - without running the rest of the file. This is useful for - incremental proof development. +**5. Search for lemmas:** -5. Fix the proof and repeat from step 2. The ultimate proof should - not contain `admit` or `admitted`. +``` +SEARCH mulzK +SEARCH dvdz +``` + +## EasyCrypt proof strategy + +### General approach + +- Start with a pen-and-paper proof plan before writing tactics. +- Use `smt()` aggressively. Try it first — if it fails, add hints: + `smt(lemma1 lemma2)`. +- Build proofs with `have` assertions. Establish intermediate facts + as named hypotheses, then combine with `smt()`. Avoid long rewrite + chains. +- Case split early: `case (n = 0) => [->|hn0].` Base cases often + close by computation. +- Provide specific instances of lemmas to smt: + `have h := lemma arg1 arg2.` SMT works much better with ground + instances than with universally quantified axioms. + +### Integer division (`%/`) + +- `divzK`: `d %| m => m %/ d * d = m` — recovering from exact + division +- `mulzK`: `d <> 0 => m * d %/ d = m` — canceling a known factor +- `divzMpl`: `0 < p => p * m %/ (p * d) = m %/ d` — simplifying + common factors +- To prove `a %/ d = x`, establish `a = x * d` (with `d %| a`), + then use `mulzK`. +- Don't try to rewrite inside `%/` expressions directly. Instead, + prove the equality as a `have` and use it. + +### What works, what doesn't + +- `ring` solves polynomial equalities over integers but treats + abstract ops (like `fact`) as opaque. It **cannot** simplify + `fact(n-1+1)` to `fact(n)`. +- `smt()` can do linear arithmetic and combine hypotheses, but + struggles with nonlinear integer division. Pre-compute key facts + with `have` and `divzK`/`mulzK`, then let smt combine them. +- `rewrite {k}h` rewrites the k-th occurrence only. Essential when a + term appears on both sides of an equation. +- For induction on naturals: `elim/natind: n` gives base (`n ≤ 0`) + and step (`0 ≤ n → P n → P (n+1)`). + +### Common pitfalls + +- `rewrite (factS n) //` generates a side goal `0 <= n`. Use + `first smt()` or provide the precondition explicitly. +- `by` closes **all** remaining subgoals. If it fails, the error + refers to the first unclosed goal, which may not be the intended + one. +- When a tactic generates multiple subgoals, each subgoal must be + closed in order. Use `GOALS ALL` to see them all. ## EasyCrypt language overview @@ -91,8 +217,6 @@ proof. by ring. qed. ### Common tactics - - - `trivial` — solve trivial goals - `smt` / `smt(lemmas...)` — call SMT solvers, optionally with hints - `auto` — automatic reasoning @@ -141,9 +265,10 @@ proof. by ring. qed. ### Guidelines -* Use SMT solver only in direct mode (smt() or /#) on simple goals (arithmetic goals, pure logical goals). +* Use SMT solver only in direct mode (smt() or /#) on simple goals + (arithmetic goals, pure logical goals). * Refrain from unfolding operator definitions unless necessary. - If you need more properties on an operator, state this property in a dedicated lemma, - but avoid unfolding definitions in higher level proofs. - + If you need more properties on an operator, state this property + in a dedicated lemma, but avoid unfolding definitions in higher + level proofs. diff --git a/src/ec.ml b/src/ec.ml index ada7602b58..f49a7c9f6b 100644 --- a/src/ec.ml +++ b/src/ec.ml @@ -404,6 +404,379 @@ let main () = (* Register user messages printers *) begin let open EcUserMessages in register () end; + (* -------------------------------------------------------------------- *) + (* LLM interactive mode *) + (* -------------------------------------------------------------------- *) + + let run_llm_repl (prvopts : prv_options) = + (* Initialize PRNG *) + Random.self_init (); + + (* Connect to external Why3 server if requested *) + prvopts.prvo_why3server |> oiter (fun server -> + try + Why3.Prove_client.connect_external server + with Why3.Prove_client.ConnectionError e -> + Format.eprintf + "cannot connect to Why3 server `%s': %s" server e; + exit 1); + + (* Add current directory to load path *) + (match relocdir with + | None -> EcCommands.addidir Filename.current_dir_name + | Some pwd -> EcCommands.addidir pwd); + + (* Proof engine configuration *) + let checkmode = { + EcCommands.cm_checkall = prvopts.prvo_checkall; + EcCommands.cm_timeout = odfl 3 prvopts.prvo_timeout; + EcCommands.cm_cpufactor = odfl 1 prvopts.prvo_cpufactor; + EcCommands.cm_nprovers = odfl 4 prvopts.prvo_maxjobs; + EcCommands.cm_provers = prvopts.prvo_provers; + EcCommands.cm_profile = prvopts.prvo_profile; + EcCommands.cm_iterate = prvopts.prvo_iterate; + } in + + (* Notice buffer: collects messages during command processing *) + let notices = Buffer.create 256 in + + let notifier (_ : EcGState.loglevel) (lazy msg) = + Buffer.add_string notices msg; + Buffer.add_char notices '\n' + in + + let initialized = ref false in + + let do_initialize () = + EcCommands.initialize + ~restart:!initialized ~undo:true + ~boot:ldropts.ldro_boot ~checkmode ~checkproof:true; + initialized := true; + (try + List.iter EcCommands.apply_pragma prvopts.prvo_pragmas + with EcCommands.InvalidPragma x -> + EcScope.hierror "invalid pragma: `%s'\n%!" x); + EcCommands.addnotifier notifier; + oiter (fun ppwidth -> + let gs = EcEnv.gstate (EcScope.env (EcCommands.current ())) in + EcGState.setvalue "PP:width" (`Int ppwidth) gs) + prvopts.prvo_ppwidth + in + + (* Error formatting *) + let format_error ?(src="") e = + let base = match e with + | EcScope.TopError (loc, e) -> + let msg = String.strip (EcPException.tostring e) in + if loc = EcLocation._dummy then msg + else Format.asprintf "%s: %s" (EcLocation.tostring loc) msg + | e -> + String.strip (EcPException.tostring e) + in + if src = "" then base + else Printf.sprintf "%s\nsource: %s" base src + in + + (* Output helpers *) + let goals_to_string ?(all=false) () = + let buf = Buffer.create 256 in + let fmt = Format.formatter_of_buffer buf in + EcCommands.pp_current_goal_or_noproof ~all fmt; + Format.pp_print_flush fmt (); + Buffer.contents buf + in + + let quiet = ref false in + + let checkpoints : (string, int) Hashtbl.t = Hashtbl.create 16 in + + let reply_ok ?(tag="") body = + let n = Buffer.contents notices in + Printf.printf "OK [uuid:%d]%s\n" (EcCommands.uuid ()) tag; + if n <> "" then print_string n; + if body <> "" then begin + print_string body; + let len = String.length body in + if len > 0 && body.[len - 1] <> '\n' then + print_char '\n' + end; + Printf.printf "\n%!"; + Buffer.clear notices + in + + let reply_ok_goals ?(all=false) () = + if !quiet then reply_ok "" + else reply_ok (goals_to_string ~all ()) + in + + let reply_error msg = + Printf.printf "ERROR [uuid:%d]\n%s\n\n%!" + (EcCommands.uuid ()) msg; + Buffer.clear notices + in + + (* Process a single EasyCrypt command, respecting gl_fail *) + let process_action ~src (p : EP.global) = + let loc = p.EP.gl_action.EcLocation.pl_loc in + let succeeded = ref false in + begin try + ignore (EcCommands.process ~src p.EP.gl_action : float option); + succeeded := true + with + | EcCommands.Restart -> raise EcCommands.Restart + | _ when p.EP.gl_fail -> () + | e -> raise (EcScope.toperror_of_exn ~gloc:loc e) + end; + if !succeeded && p.EP.gl_fail then + raise (EcScope.toperror_of_exn ~gloc:loc + (EcScope.HiScopeError (None, + "this command is expected to fail"))) + in + + (* Process EasyCrypt input from a string (one parsed program) *) + let process_ec_input input = + Buffer.clear notices; + let reader = EcIo.from_string input in + let last_src = ref "" in + begin try + let (src, prog) = EcIo.xparse reader in + let src = String.strip src in + last_src := src; + begin match EcLocation.unloc prog with + | EP.P_Prog (commands, _) -> + List.iter (process_action ~src) commands; + reply_ok_goals () + | EP.P_Undo i -> + EcCommands.undo i; + reply_ok_goals () + | EP.P_Exit -> + EcIo.finalize reader; exit 0 + | EP.P_DocComment doc -> + EcCommands.doc_comment doc; + reply_ok "" + end + with + | EcCommands.Restart -> + do_initialize (); + reply_ok "Session restarted" + | e -> + reply_error (format_error ~src:!last_src e) + end; + EcIo.finalize reader + in + + (* Handle LOAD "file.ec" [LINE[:COL]] *) + let handle_load args = + Buffer.clear notices; + let args = String.strip args in + let last_src = ref "" in + + try + (* Parse quoted or unquoted filename *) + let filename, rest = + if String.length args > 0 && args.[0] = '"' then + let close = + try String.index_from args 1 '"' + with Not_found -> + failwith "LOAD: unterminated filename" + in + let fn = String.sub args 1 (close - 1) in + let rest = String.strip ( + String.sub args (close + 1) + (String.length args - close - 1)) in + (fn, rest) + else + match String.split_on_char ' ' args with + | [] -> failwith "LOAD: missing filename" + | [f] -> (f, "") + | f :: rest -> (f, String.concat " " rest) + in + + (* Parse optional LINE[:COL] *) + let upto = + if rest = "" then None + else + match String.split_on_char ':' rest with + | [line] -> + Some (int_of_string line, None) + | [line; col] -> + Some (int_of_string line, Some (int_of_string col)) + | _ -> failwith "LOAD: invalid LINE[:COL] format" + in + + (* Validate file extension *) + begin try + ignore (EcLoader.getkind + (Filename.extension filename) : EcLoader.kind) + with EcLoader.BadExtension ext -> + failwith (Format.sprintf + "unknown file extension: %s" ext) + end; + + (* Reset proof engine and process file *) + do_initialize (); + Hashtbl.clear checkpoints; + EcCommands.addidir (Filename.dirname filename); + + let reader = EcIo.from_file filename in + + let past_upto (loc : EcLocation.t) = + match upto with + | None -> false + | Some (line, col) -> + let (el, ec) = loc.loc_end in + el > line || (el = line && match col with + | None -> false + | Some c -> ec > c) + in + + let last_loc = ref None in + + begin try while true do + let (src, prog) = EcIo.xparse reader in + let src = String.strip src in + last_src := src; + match EcLocation.unloc prog with + | EP.P_Prog (commands, locterm) -> + List.iter (fun p -> + let loc = p.EP.gl_action.EcLocation.pl_loc in + if past_upto loc then raise Exit; + process_action ~src p; + last_loc := Some loc + ) commands; + if locterm then raise Exit + | EP.P_Undo i -> + EcCommands.undo i + | EP.P_Exit -> + raise Exit + | EP.P_DocComment doc -> + EcCommands.doc_comment doc + done with + | Exit | End_of_file -> () + | e -> EcIo.finalize reader; raise e + end; + + EcIo.finalize reader; + let tag = + match !last_loc with + | None -> "" + | Some loc -> + let (el, _) = loc.EcLocation.loc_end in + Printf.sprintf " [loaded:%s:%d]" filename el + in + reply_ok ~tag (goals_to_string ()) + + with + | EcCommands.Restart -> + do_initialize (); + Hashtbl.clear checkpoints; + reply_ok "Session restarted" + | Failure s -> + reply_error s + | e -> + reply_error (format_error ~src:!last_src e) + in + + (* Initialize proof engine *) + do_initialize (); + + (* Signal ready *) + Printf.printf "READY [uuid:%d]\n\n%!" + (EcCommands.uuid ()); + + (* Main REPL loop *) + begin try while true do + let line = input_line stdin in + let line = String.strip line in + + if line = "" then + () + else if line = "QUIT" then + exit 0 + else if line = "UNDO" then begin + Buffer.clear notices; + let uuid = EcCommands.uuid () in + if uuid > 0 then begin + EcCommands.undo (uuid - 1); + reply_ok_goals () + end else + reply_error "nothing to undo" + end + else if line = "GOALS ALL" then begin + Buffer.clear notices; + reply_ok (goals_to_string ~all:true ()) + end + else if line = "GOALS" then begin + Buffer.clear notices; + reply_ok (goals_to_string ()) + end + else if String.starts_with line "CHECKPOINT " then begin + Buffer.clear notices; + let name = String.strip ( + String.sub line 11 (String.length line - 11)) in + if name = "" then + reply_error "CHECKPOINT: missing name" + else begin + Hashtbl.replace checkpoints name (EcCommands.uuid ()); + reply_ok (Printf.sprintf + "checkpoint '%s' set at uuid %d" name (EcCommands.uuid ())) + end + end + else if String.starts_with line "REVERT " then begin + Buffer.clear notices; + let n = String.strip ( + String.sub line 7 (String.length line - 7)) in + let target = + try Some (int_of_string n) + with Failure _ -> Hashtbl.find_opt checkpoints n + in + begin match target with + | None -> + reply_error (Printf.sprintf + "REVERT: '%s' is not a valid uuid or checkpoint name" n) + | Some target -> + let uuid = EcCommands.uuid () in + if target < 0 || target > uuid then + reply_error (Printf.sprintf + "REVERT: uuid %d out of range [0, %d]" target uuid) + else begin + EcCommands.undo target; + reply_ok_goals () + end + end + end + else if line = "QUIET ON" then begin + Buffer.clear notices; + quiet := true; + reply_ok "" + end + else if line = "QUIET OFF" then begin + Buffer.clear notices; + quiet := false; + reply_ok "" + end + else if String.starts_with line "SEARCH " then begin + let query = String.strip ( + String.sub line 7 (String.length line - 7)) in + let query = + if String.ends_with query "." + then String.sub query 0 (String.length query - 1) + else query + in + process_ec_input (Printf.sprintf "search %s." query) + end + else if String.starts_with line "LOAD " then + handle_load (String.sub line 5 (String.length line - 5)) + else + (* Treat as EasyCrypt input *) + process_ec_input line + done with + | End_of_file -> () + end; + + exit 0 + in + (* Initialize I/O + interaction module *) let module State = struct type t = { @@ -535,34 +908,9 @@ let main () = end - | `Llm llmopts -> begin - let name = llmopts.llmo_input in - - begin try - let ext = Filename.extension name in - ignore (EcLoader.getkind ext : EcLoader.kind) - with EcLoader.BadExtension ext -> - Format.eprintf "do not know what to do with %s@." ext; - exit 1 - end; - - let lastgoals = llmopts.llmo_lastgoals in - let terminal = - lazy (T.from_channel ~name ~progress:`Silent ~lastgoals (open_in name)) - in - - { prvopts = {llmopts.llmo_provers with prvo_iterate = true} - ; input = Some name - ; terminal = terminal - ; interactive = false - ; eco = true - ; gccompact = None - ; docgen = false - ; outdirp = None - ; upto = llmopts.llmo_upto - ; trace = None } - - end + | `Llm llmopts -> + run_llm_repl + {llmopts.llmo_provers with prvo_iterate = true} | `Runtest _ -> (* Eagerly executed *) diff --git a/src/ecOptions.ml b/src/ecOptions.ml index 52a4d6e66b..5eed323397 100644 --- a/src/ecOptions.ml +++ b/src/ecOptions.ml @@ -49,10 +49,7 @@ and doc_option = { } and llm_option = { - llmo_input : string; llmo_provers : prv_options; - llmo_lastgoals : bool; - llmo_upto : (int * int option) option; } and prv_options = { @@ -359,11 +356,9 @@ let specs = { `Spec ("trace" , `Flag , "Save all goals & messages in .eco"); `Spec ("compact", `Int , "")]); - ("llm", "LLM-friendly batch compilation", [ + ("llm", "LLM-friendly interactive mode", [ `Group "loader"; - `Group "provers"; - `Spec ("lastgoals" , `Flag , "Print last unproved goals on failure"); - `Spec ("upto" , `String, "Compile up to LINE or LINE:COL and print goals")]); + `Group "provers"]); ("cli", "Run EasyCrypt top-level", [ `Group "loader"; @@ -547,26 +542,8 @@ let doc_options_of_values values input = { doco_input = input; doco_outdirp = get_string "outdir" values; } -let parse_upto values = - get_string "upto" values |> Option.map (fun s -> - let invalid () = - raise (Arg.Bad (Printf.sprintf - "invalid -upto format: expected LINE or LINE:COL, got %S" s)) in - match String.split_on_char ':' s with - | [line] -> - let line = try int_of_string line with Failure _ -> invalid () in - (line, None) - | [line; col] -> - let line = try int_of_string line with Failure _ -> invalid () in - let col = try int_of_string col with Failure _ -> invalid () in - (line, Some col) - | _ -> invalid ()) - -let llm_options_of_values ini values input = - { llmo_input = input; - llmo_provers = prv_options_of_values ini values; - llmo_lastgoals = get_flag "lastgoals" values; - llmo_upto = parse_upto values; } +let llm_options_of_values ini values = + { llmo_provers = prv_options_of_values ini values; } (* -------------------------------------------------------------------- *) let parse getini argv = @@ -639,16 +616,14 @@ let parse getini argv = raise (Arg.Bad "this command takes a single input file as argument") end - | "llm" -> begin - match anons with - | [input] -> - let ini = getini (Some input) in - let cmd = `Llm (llm_options_of_values ini values input) in - (cmd, ini, true) + | "llm" -> + if not (List.is_empty anons) then + raise (Arg.Bad "this command does not take arguments"); - | _ -> - raise (Arg.Bad "this command takes a single argument") - end + let ini = getini None in + let cmd = `Llm (llm_options_of_values ini values) in + + (cmd, ini, true) | _ -> assert false diff --git a/src/ecOptions.mli b/src/ecOptions.mli index 7ac81ec0a4..d02fbd1392 100644 --- a/src/ecOptions.mli +++ b/src/ecOptions.mli @@ -45,10 +45,7 @@ and doc_option = { } and llm_option = { - llmo_input : string; llmo_provers : prv_options; - llmo_lastgoals : bool; - llmo_upto : (int * int option) option; } and prv_options = { From cf30a76c226684c7b6ec72aa6a6f2ed999b6b090 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 13 Apr 2026 12:07:27 +0200 Subject: [PATCH 050/145] Add LLM REPL improvements and built-in guide New REPL features: - LOAD -nosmt: skip SMT calls during prefix compilation (uses Proofs:weak pragma), restores strict mode for interactive tactics - Error responses now include the current goal state, eliminating the need for a separate GOALS roundtrip after failures - Multi-line input support via / delimiters - HELP meta-command and -help flag: print the LLM agent guide (doc/llm/CLAUDE.md) from within the REPL or at startup The guide is installed as part of the distribution (doc site) so it stays version-matched with the binary. Agent frameworks can use `easycrypt llm -help` to populate their system prompt automatically. Documentation updates: - REVERT-to-LOAD-uuid workflow (instant restart vs recompile) - Pattern-based search syntax with examples - SMT usage guidance (pure arithmetic/logic only) - rewrite-in-H clarification --- doc/llm/CLAUDE.md | 81 +++++++++++++++++++++++++++---- dune | 6 ++- src/ec.ml | 121 ++++++++++++++++++++++++++++++++++++++++------ src/ecOptions.ml | 7 ++- src/ecOptions.mli | 1 + 5 files changed, 187 insertions(+), 29 deletions(-) diff --git a/doc/llm/CLAUDE.md b/doc/llm/CLAUDE.md index 1ef19b164e..c33dc18253 100644 --- a/doc/llm/CLAUDE.md +++ b/doc/llm/CLAUDE.md @@ -17,7 +17,11 @@ easycrypt llm [OPTIONS] ``` Standard loader and prover options (`-I`, `-timeout`, `-p`, etc.) are -available. +available. Use `-help` to print this guide and exit: + +``` +easycrypt llm -help +``` ### Protocol @@ -52,7 +56,7 @@ These are protocol-level commands, not EasyCrypt syntax: | Command | Description | |---------|-------------| -| `LOAD "file.ec" [LINE[:COL]]` | Reset state, compile file up to the given line | +| `LOAD "file.ec" [LINE[:COL]] [-nosmt]` | Reset state, compile file (optionally skip SMT) | | `UNDO` | Undo the last proof step | | `REVERT ` | Revert to a specific state (by uuid or checkpoint name) | | `GOALS` | Print the current goal (first subgoal only, with remaining count) | @@ -60,6 +64,8 @@ These are protocol-level commands, not EasyCrypt syntax: | `CHECKPOINT ` | Save current uuid under a name for later `REVERT` | | `SEARCH ` | Search for lemmas matching a pattern | | `QUIET ON` / `QUIET OFF` | Suppress/enable automatic goal display after tactics | +| `` / `` | Delimit multi-line EasyCrypt input | +| `HELP` | Print this guide | | `QUIT` | Exit | ### EasyCrypt commands @@ -75,6 +81,16 @@ search (%/). print mulzK. ``` +For multi-line statements, wrap with `` and ``: + +``` + +lemma test : + 0 <= n => + 0 < n + 1. + +``` + ### Workflow **1. Load a file up to the proof point:** @@ -94,19 +110,37 @@ Current goal ``` -**2. Try tactics interactively:** +For large files, use `-nosmt` to skip SMT calls during prefix +compilation (safe when the prefix was already verified): ``` -smt(). +LOAD "myfile.ec" 436 -nosmt ``` -If it fails, the state is unchanged — try another tactic immediately: +**2. Try tactics, using REVERT to restart:** + +The uuid returned by LOAD is a revertible state. Use `REVERT` to +return to it after failed experiments — this is instant, unlike +re-doing LOAD which recompiles the prefix. ``` -rewrite H1. -smt(lemma1 lemma2). +LOAD "myfile.ec" 42 +→ OK [uuid:15] [loaded:myfile.ec:42] + +smt(). ← fails, state unchanged +rewrite H1. smt(). ← succeeds (uuid:17) +rewrite H2. ← wrong direction +REVERT 17 ← back to after the successful smt() ``` +To restart the proof from scratch, revert to the LOAD uuid: + +``` +REVERT 15 ← back to the state right after LOAD +``` + +Always note the LOAD uuid so you can return to it. + **3. Use checkpoints for branching exploration:** ``` @@ -128,11 +162,23 @@ QUIET OFF GOALS ``` -**5. Search for lemmas:** +**5. Search for lemmas using patterns:** + +EasyCrypt `search` uses pattern syntax, not keywords. Use `_` as +wildcard: + +``` +search (fdom _). ← lemmas involving fdom +search (_ %/ _). ← integer division lemmas +search (card (_ `|` _)). ← card of union +search (mu _ _) (_ <= _). ← mu lemmas with inequalities +``` + +The SEARCH meta-command is a shorthand that adds `search`/`.`: ``` -SEARCH mulzK -SEARCH dvdz +SEARCH (fdom _) +SEARCH (_ %/ _) ``` ## EasyCrypt proof strategy @@ -176,6 +222,18 @@ SEARCH dvdz - For induction on naturals: `elim/natind: n` gives base (`n ≤ 0`) and step (`0 ≤ n → P n → P (n+1)`). +### SMT usage + +`smt()` and `/#` are equivalent — both call external SMT solvers. + +- Use `smt()` **only** on goals that are pure arithmetic or pure + propositional logic. If the goal contains abstract operators, + FMap terms, or `if-then-else`, reduce it first with `rewrite`, + `case`, or `have` before calling `smt()`. +- If `smt()` takes more than 1 second, the goal is too complex. + Simplify with interactive tactics instead of increasing the + timeout. + ### Common pitfalls - `rewrite (factS n) //` generates a side goal `0 <= n`. Use @@ -185,6 +243,9 @@ SEARCH dvdz one. - When a tactic generates multiple subgoals, each subgoal must be closed in order. Use `GOALS ALL` to see them all. +- `rewrite lemma in H` modifies hypothesis `H` in place (it does + not consume it). If you need to preserve the original, copy it + first: `have H' := H; rewrite lemma in H'`. ## EasyCrypt language overview diff --git a/dune b/dune index 7c8edf7096..b232abeca3 100644 --- a/dune +++ b/dune @@ -1,4 +1,4 @@ -(dirs 3rdparty src etc theories examples assets scripts) +(dirs 3rdparty src etc theories examples assets scripts doc) (install (section (site (easycrypt commands))) @@ -6,7 +6,9 @@ (install (section (site (easycrypt doc))) - (files (assets/styles/styles.css as styles.css))) + (files + (assets/styles/styles.css as styles.css) + (doc/llm/CLAUDE.md as llm-guide.md))) (install (section (bin)) diff --git a/src/ec.ml b/src/ec.ml index f49a7c9f6b..92ea759483 100644 --- a/src/ec.ml +++ b/src/ec.ml @@ -408,7 +408,34 @@ let main () = (* LLM interactive mode *) (* -------------------------------------------------------------------- *) - let run_llm_repl (prvopts : prv_options) = + let llm_guide_path () = + let (module Sites) = EcRelocate.sites in + match EcRelocate.sourceroot with + | Some root -> + Filename.concat (Filename.concat root "doc/llm") "CLAUDE.md" + | None -> + Filename.concat Sites.doc "llm-guide.md" + in + + let print_llm_guide () = + let path = llm_guide_path () in + try + let ic = open_in path in + begin try while true do + print_char (input_char ic) + done with End_of_file -> () end; + close_in ic + with Sys_error e -> + Printf.eprintf "cannot read LLM guide: %s\n%!" e + in + + let run_llm_repl (llmopts : llm_option) = + if llmopts.llmo_help then begin + print_llm_guide (); + exit 0 + end; + + let prvopts = llmopts.llmo_provers in (* Initialize PRNG *) Random.self_init (); @@ -510,8 +537,15 @@ let main () = in let reply_error msg = - Printf.printf "ERROR [uuid:%d]\n%s\n\n%!" - (EcCommands.uuid ()) msg; + let goals = goals_to_string () in + Printf.printf "ERROR [uuid:%d]\n%s\n" (EcCommands.uuid ()) msg; + if goals <> "" then begin + print_string goals; + let len = String.length goals in + if len > 0 && goals.[len - 1] <> '\n' then + print_char '\n' + end; + Printf.printf "\n%!"; Buffer.clear notices in @@ -592,16 +626,27 @@ let main () = | f :: rest -> (f, String.concat " " rest) in - (* Parse optional LINE[:COL] *) - let upto = - if rest = "" then None + (* Parse optional LINE[:COL] and flags (-nosmt) *) + let upto, nosmt = + if rest = "" then (None, false) else - match String.split_on_char ':' rest with - | [line] -> - Some (int_of_string line, None) - | [line; col] -> - Some (int_of_string line, Some (int_of_string col)) - | _ -> failwith "LOAD: invalid LINE[:COL] format" + let words = String.split_on_char ' ' rest in + let words = List.filter (fun s -> s <> "") words in + let nosmt = List.mem "-nosmt" words in + let words = List.filter (fun s -> s <> "-nosmt") words in + let upto = match words with + | [] -> None + | [w] -> + begin match String.split_on_char ':' w with + | [line] -> + Some (int_of_string line, None) + | [line; col] -> + Some (int_of_string line, Some (int_of_string col)) + | _ -> failwith "LOAD: invalid LINE[:COL] format" + end + | _ -> failwith "LOAD: unexpected arguments" + in + (upto, nosmt) in (* Validate file extension *) @@ -632,6 +677,9 @@ let main () = let last_loc = ref None in + (* In -nosmt mode, admit all SMT calls during prefix loading *) + if nosmt then EcCommands.pragma_check `WeakCheck; + begin try while true do let (src, prog) = EcIo.xparse reader in let src = String.strip src in @@ -653,10 +701,17 @@ let main () = EcCommands.doc_comment doc done with | Exit | End_of_file -> () - | e -> EcIo.finalize reader; raise e + | e -> + EcIo.finalize reader; + if nosmt then EcCommands.pragma_check `Check; + raise e end; EcIo.finalize reader; + + (* Restore full SMT checking for interactive tactics *) + if nosmt then EcCommands.pragma_check `Check; + let tag = match !last_loc with | None -> "" @@ -685,14 +740,49 @@ let main () = (EcCommands.uuid ()); (* Main REPL loop *) + let multi_buf = Buffer.create 256 in + let in_multi = ref false in + begin try while true do let line = input_line stdin in let line = String.strip line in - if line = "" then + (* Multi-line input: starts, flushes *) + if line = "" then begin + Buffer.clear multi_buf; + in_multi := true + end + else if line = "" && !in_multi then begin + let input = Buffer.contents multi_buf in + Buffer.clear multi_buf; + in_multi := false; + if input <> "" then process_ec_input input + end + else if !in_multi then begin + if Buffer.length multi_buf > 0 then + Buffer.add_char multi_buf ' '; + Buffer.add_string multi_buf line + end + + else if line = "" then () else if line = "QUIT" then exit 0 + else if line = "HELP" then begin + Buffer.clear notices; + let buf = Buffer.create 4096 in + let path = llm_guide_path () in + begin try + let ic = open_in path in + begin try while true do + Buffer.add_char buf (input_char ic) + done with End_of_file -> () end; + close_in ic; + reply_ok (Buffer.contents buf) + with Sys_error e -> + reply_error (Printf.sprintf "cannot read guide: %s" e) + end + end else if line = "UNDO" then begin Buffer.clear notices; let uuid = EcCommands.uuid () in @@ -910,7 +1000,8 @@ let main () = | `Llm llmopts -> run_llm_repl - {llmopts.llmo_provers with prvo_iterate = true} + {llmopts with llmo_provers = + {llmopts.llmo_provers with prvo_iterate = true}} | `Runtest _ -> (* Eagerly executed *) diff --git a/src/ecOptions.ml b/src/ecOptions.ml index 5eed323397..76db91bfe8 100644 --- a/src/ecOptions.ml +++ b/src/ecOptions.ml @@ -50,6 +50,7 @@ and doc_option = { and llm_option = { llmo_provers : prv_options; + llmo_help : bool; } and prv_options = { @@ -358,7 +359,8 @@ let specs = { ("llm", "LLM-friendly interactive mode", [ `Group "loader"; - `Group "provers"]); + `Group "provers"; + `Spec ("help", `Flag, "Print the LLM agent guide and exit")]); ("cli", "Run EasyCrypt top-level", [ `Group "loader"; @@ -543,7 +545,8 @@ let doc_options_of_values values input = doco_outdirp = get_string "outdir" values; } let llm_options_of_values ini values = - { llmo_provers = prv_options_of_values ini values; } + { llmo_provers = prv_options_of_values ini values; + llmo_help = get_flag "help" values; } (* -------------------------------------------------------------------- *) let parse getini argv = diff --git a/src/ecOptions.mli b/src/ecOptions.mli index d02fbd1392..91e93fbe28 100644 --- a/src/ecOptions.mli +++ b/src/ecOptions.mli @@ -46,6 +46,7 @@ and doc_option = { and llm_option = { llmo_provers : prv_options; + llmo_help : bool; } and prv_options = { From 0b07a19be15a23cb1c679e70f60d5b6e280caf7a Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Sat, 18 Apr 2026 11:54:45 +0100 Subject: [PATCH 051/145] Fixed proc change not registering new vars in program memory --- src/phl/ecPhlRewrite.ml | 16 +++++++++++++++- tests/procchange.ec | 23 +++++++++++++++++++++++ 2 files changed, 38 insertions(+), 1 deletion(-) diff --git a/src/phl/ecPhlRewrite.ml b/src/phl/ecPhlRewrite.ml index 9eddcb5c11..f44ee298fe 100644 --- a/src/phl/ecPhlRewrite.ml +++ b/src/phl/ecPhlRewrite.ml @@ -345,7 +345,21 @@ let t_change_stmt let goal2 = EcLowPhlGoal.hl_set_stmt side (FApi.tc1_goal tc) - stmt in + stmt + in + + let goal2 = + let rebind inv = EcSubst.ss_inv_rebind inv (fst me) in + let rebind_left inv = EcSubst.ts_inv_rebind_left inv (fst me) in + let rebind_right inv = EcSubst.ts_inv_rebind_right inv (fst me) in + match side, goal2.f_node with + | None , FhoareS hs -> f_hoareS (snd me) (rebind (hs_pr hs)) hs.hs_s {(hs_po hs) with hsi_m=(fst me)} + | None , FeHoareS hs -> f_eHoareS (snd me) {(ehs_pr hs) with m=(fst me)} hs.ehs_s {(ehs_po hs) with m=(fst me)} + | None , FbdHoareS hs -> f_bdHoareS (snd hs.bhs_m) (rebind (bhs_pr hs)) hs.bhs_s (rebind (bhs_po hs)) hs.bhs_cmp (bhs_bd hs) + | Some `Left , FequivS es -> f_equivS (snd me) (snd es.es_mr) (rebind_left (es_pr es)) es.es_sl es.es_sr (rebind_left (es_po es)) + | Some `Right, FequivS es -> f_equivS (snd es.es_ml) (snd me) (rebind_right (es_pr es)) es.es_sl es.es_sr (rebind_right (es_po es)) + | _ -> assert false + in FApi.xmutate1 tc `ProcChangeStmt [goal1; goal2] diff --git a/tests/procchange.ec b/tests/procchange.ec index 65c265234e..e65e4b9132 100644 --- a/tests/procchange.ec +++ b/tests/procchange.ec @@ -673,3 +673,26 @@ theory ProcChangePostReadYFailTest. fail by auto. abort. end ProcChangePostReadYFailTest. + +theory ProcChangeUseNewVars. + module M = { + proc f(x : int) = { + x <- 1; + x <- x - x; + return x; + } + }. + + lemma L : hoare[M.f : 4 < arg ==> res = 0]. + proof. + proc. + proc change [1..1] : [y : int] { + y <- x; + x <- 1; + }; 1: by auto. + seq 2 : (x = 1 /\ 4 < y); 1: by auto. + conseq (: ==> x = 0 /\ 4 < y); 1: by auto. + wp. skip => &hr H. simplify. + by move : H => [] <*>> -> //. + qed. +end ProcChangeUseNewVars. From 5802c59cd9ef7534a1749e99e87358bbac800620 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sun, 31 May 2026 08:42:44 +0200 Subject: [PATCH 052/145] Remove editor & agent tooling (LSP server, VSCode extension, LLM REPL) Brings the editor/agent-tooling surface back in sync with origin/main: - delete LSP server (src/ecLsp.ml/.mli) and the whole vscode/ extension - revert the interactive llm REPL back to origin/main's batch llm mode (ec.ml, ecOptions.ml/.mli, doc/llm/CLAUDE.md) - drop the LSP-only deps (fmt, logs, lsp, lwt) from dune-project/src/dune Circuit/bdep features (incl. spec-relative loading via set_current_path) are untouched. --- doc/llm/CLAUDE.md | 272 +----- dune-project | 4 - easycrypt.opam | 4 - src/dune | 2 +- src/ec.ml | 499 +--------- src/ecLsp.ml | 777 ---------------- src/ecLsp.mli | 1 - src/ecOptions.ml | 78 +- src/ecOptions.mli | 5 +- vscode/.gitignore | 2 - vscode/README.md | 46 - vscode/assets/back.svg | 3 - vscode/assets/easycrypt.svg | 5 - vscode/assets/goals.svg | 4 - vscode/assets/jump.svg | 3 - vscode/assets/refresh.svg | 3 - vscode/assets/step.svg | 3 - vscode/language-configuration.json | 23 - vscode/package-lock.json | 139 --- vscode/package.json | 226 ----- vscode/package.nls.json | 3 - vscode/src/extension.ts | 1020 --------------------- vscode/syntaxes/easycrypt.tmLanguage.json | 101 -- vscode/tsconfig.json | 13 - 24 files changed, 116 insertions(+), 3120 deletions(-) delete mode 100644 src/ecLsp.ml delete mode 100644 src/ecLsp.mli delete mode 100644 vscode/.gitignore delete mode 100644 vscode/README.md delete mode 100644 vscode/assets/back.svg delete mode 100644 vscode/assets/easycrypt.svg delete mode 100644 vscode/assets/goals.svg delete mode 100644 vscode/assets/jump.svg delete mode 100644 vscode/assets/refresh.svg delete mode 100644 vscode/assets/step.svg delete mode 100644 vscode/language-configuration.json delete mode 100644 vscode/package-lock.json delete mode 100644 vscode/package.json delete mode 100644 vscode/package.nls.json delete mode 100644 vscode/src/extension.ts delete mode 100644 vscode/syntaxes/easycrypt.tmLanguage.json delete mode 100644 vscode/tsconfig.json diff --git a/doc/llm/CLAUDE.md b/doc/llm/CLAUDE.md index c33dc18253..0cc20c5a38 100644 --- a/doc/llm/CLAUDE.md +++ b/doc/llm/CLAUDE.md @@ -6,246 +6,59 @@ computations, program logics (Hoare logic, probabilistic Hoare logic, probabilistic relational Hoare logic), and ambient mathematical reasoning. -## Using the `llm` interactive mode +## Using the `llm` command -The `llm` subcommand provides an interactive REPL with a -machine-friendly protocol designed for LLM agents. The LLM sends -commands over stdin and receives structured responses on stdout. +The `llm` subcommand is designed for non-interactive, LLM-friendly +batch compilation. It produces no progress bar and no `.eco` cache +files. ``` -easycrypt llm [OPTIONS] +easycrypt llm [OPTIONS] FILE.ec ``` -Standard loader and prover options (`-I`, `-timeout`, `-p`, etc.) are -available. Use `-help` to print this guide and exit: - -``` -easycrypt llm -help -``` - -### Protocol - -**Startup.** EasyCrypt prints a `READY` message and waits for input: - -``` -READY [uuid:0] - -``` - -**Responses.** Every response has a typed envelope and an `` -sentinel: - -``` -OK [uuid:N] - - -``` - -``` -ERROR [uuid:N] - - -``` +### Options -The `uuid` is a monotonically increasing integer identifying the proof -engine state. It increments with each successful command. +- `-upto LINE` or `-upto LINE:COL` — Compile up to (but not + including) the given location, then print the current goal state to + stdout and exit with code 0. Use this to inspect the proof state at + a specific point in a file. -### Meta-commands - -These are protocol-level commands, not EasyCrypt syntax: - -| Command | Description | -|---------|-------------| -| `LOAD "file.ec" [LINE[:COL]] [-nosmt]` | Reset state, compile file (optionally skip SMT) | -| `UNDO` | Undo the last proof step | -| `REVERT ` | Revert to a specific state (by uuid or checkpoint name) | -| `GOALS` | Print the current goal (first subgoal only, with remaining count) | -| `GOALS ALL` | Print all subgoals | -| `CHECKPOINT ` | Save current uuid under a name for later `REVERT` | -| `SEARCH ` | Search for lemmas matching a pattern | -| `QUIET ON` / `QUIET OFF` | Suppress/enable automatic goal display after tactics | -| `` / `` | Delimit multi-line EasyCrypt input | -| `HELP` | Print this guide | -| `QUIT` | Exit | - -### EasyCrypt commands - -Any line that is not a meta-command is parsed as EasyCrypt input. -This covers tactics, declarations, `search`, `print`, `require`, -etc. The line must be a complete EasyCrypt statement ending with `.` - -``` -smt(). -rewrite H1 H2. -search (%/). -print mulzK. -``` - -For multi-line statements, wrap with `` and ``: - -``` - -lemma test : - 0 <= n => - 0 < n + 1. - -``` - -### Workflow - -**1. Load a file up to the proof point:** - -``` -LOAD "myfile.ec" 42 -``` +- `-lastgoals` — On failure, print the goal state (as it was just + before the failing command) to stdout, then print the error to + stderr, and exit with code 1. Use this to understand what the + failing tactic was supposed to prove. -This compiles the file through line 42 (processing any command whose -end is on or before that line). The response includes where it -stopped: - -``` -OK [uuid:15] [loaded:myfile.ec:42] -Current goal -... - -``` - -For large files, use `-nosmt` to skip SMT calls during prefix -compilation (safe when the prefix was already verified): - -``` -LOAD "myfile.ec" 436 -nosmt -``` - -**2. Try tactics, using REVERT to restart:** - -The uuid returned by LOAD is a revertible state. Use `REVERT` to -return to it after failed experiments — this is instant, unlike -re-doing LOAD which recompiles the prefix. - -``` -LOAD "myfile.ec" 42 -→ OK [uuid:15] [loaded:myfile.ec:42] - -smt(). ← fails, state unchanged -rewrite H1. smt(). ← succeeds (uuid:17) -rewrite H2. ← wrong direction -REVERT 17 ← back to after the successful smt() -``` - -To restart the proof from scratch, revert to the LOAD uuid: - -``` -REVERT 15 ← back to the state right after LOAD -``` +Standard loader and prover options (`-I`, `-timeout`, `-p`, etc.) are +also available. -Always note the LOAD uuid so you can return to it. +### Output conventions -**3. Use checkpoints for branching exploration:** +- **Goals** are printed to **stdout**. +- **Errors** are printed to **stderr**. +- **Exit code 0** means success (or `-upto` reached its target). +- **Exit code 1** means a command failed. +- If there is no active proof at the point where goals are requested, + stdout will contain: `No active proof.` -``` -CHECKPOINT before_split -split. -smt(). ← fails -REVERT before_split -apply H. ← try a different approach -``` +### Workflow for writing and debugging proofs -**4. Use QUIET mode to save tokens during bulk tactic application:** +1. Try to write a pen-and-paper proof first. -``` -QUIET ON -rewrite H1. -rewrite H2. -rewrite H3. -QUIET OFF -GOALS -``` +2. Write the `.ec` file with your proof attempt. For a large proof, + write down skeleton and `admit` subgoals first, and then detail + the proof. -**5. Search for lemmas using patterns:** +3. Run `easycrypt llm -lastgoals FILE.ec` to check the full file. + - If it succeeds (exit 0), you are done. + - If it fails (exit 1), read the error from stderr and the goal + state from stdout to understand what went wrong. -EasyCrypt `search` uses pattern syntax, not keywords. Use `_` as -wildcard: +4. Use `-upto LINE` to inspect the proof state at a specific point + without running the rest of the file. This is useful for + incremental proof development. -``` -search (fdom _). ← lemmas involving fdom -search (_ %/ _). ← integer division lemmas -search (card (_ `|` _)). ← card of union -search (mu _ _) (_ <= _). ← mu lemmas with inequalities -``` - -The SEARCH meta-command is a shorthand that adds `search`/`.`: - -``` -SEARCH (fdom _) -SEARCH (_ %/ _) -``` - -## EasyCrypt proof strategy - -### General approach - -- Start with a pen-and-paper proof plan before writing tactics. -- Use `smt()` aggressively. Try it first — if it fails, add hints: - `smt(lemma1 lemma2)`. -- Build proofs with `have` assertions. Establish intermediate facts - as named hypotheses, then combine with `smt()`. Avoid long rewrite - chains. -- Case split early: `case (n = 0) => [->|hn0].` Base cases often - close by computation. -- Provide specific instances of lemmas to smt: - `have h := lemma arg1 arg2.` SMT works much better with ground - instances than with universally quantified axioms. - -### Integer division (`%/`) - -- `divzK`: `d %| m => m %/ d * d = m` — recovering from exact - division -- `mulzK`: `d <> 0 => m * d %/ d = m` — canceling a known factor -- `divzMpl`: `0 < p => p * m %/ (p * d) = m %/ d` — simplifying - common factors -- To prove `a %/ d = x`, establish `a = x * d` (with `d %| a`), - then use `mulzK`. -- Don't try to rewrite inside `%/` expressions directly. Instead, - prove the equality as a `have` and use it. - -### What works, what doesn't - -- `ring` solves polynomial equalities over integers but treats - abstract ops (like `fact`) as opaque. It **cannot** simplify - `fact(n-1+1)` to `fact(n)`. -- `smt()` can do linear arithmetic and combine hypotheses, but - struggles with nonlinear integer division. Pre-compute key facts - with `have` and `divzK`/`mulzK`, then let smt combine them. -- `rewrite {k}h` rewrites the k-th occurrence only. Essential when a - term appears on both sides of an equation. -- For induction on naturals: `elim/natind: n` gives base (`n ≤ 0`) - and step (`0 ≤ n → P n → P (n+1)`). - -### SMT usage - -`smt()` and `/#` are equivalent — both call external SMT solvers. - -- Use `smt()` **only** on goals that are pure arithmetic or pure - propositional logic. If the goal contains abstract operators, - FMap terms, or `if-then-else`, reduce it first with `rewrite`, - `case`, or `have` before calling `smt()`. -- If `smt()` takes more than 1 second, the goal is too complex. - Simplify with interactive tactics instead of increasing the - timeout. - -### Common pitfalls - -- `rewrite (factS n) //` generates a side goal `0 <= n`. Use - `first smt()` or provide the precondition explicitly. -- `by` closes **all** remaining subgoals. If it fails, the error - refers to the first unclosed goal, which may not be the intended - one. -- When a tactic generates multiple subgoals, each subgoal must be - closed in order. Use `GOALS ALL` to see them all. -- `rewrite lemma in H` modifies hypothesis `H` in place (it does - not consume it). If you need to preserve the original, copy it - first: `have H' := H; rewrite lemma in H'`. +5. Fix the proof and repeat from step 2. The ultimate proof should + not contain `admit` or `admitted`. ## EasyCrypt language overview @@ -278,6 +91,8 @@ proof. by ring. qed. ### Common tactics + + - `trivial` — solve trivial goals - `smt` / `smt(lemmas...)` — call SMT solvers, optionally with hints - `auto` — automatic reasoning @@ -326,10 +141,9 @@ proof. by ring. qed. ### Guidelines -* Use SMT solver only in direct mode (smt() or /#) on simple goals - (arithmetic goals, pure logical goals). +* Use SMT solver only in direct mode (smt() or /#) on simple goals (arithmetic goals, pure logical goals). * Refrain from unfolding operator definitions unless necessary. - If you need more properties on an operator, state this property - in a dedicated lemma, but avoid unfolding definitions in higher - level proofs. + If you need more properties on an operator, state this property in a dedicated lemma, + but avoid unfolding definitions in higher level proofs. + diff --git a/dune-project b/dune-project index 96c17b67d1..014f6f02c9 100644 --- a/dune-project +++ b/dune-project @@ -20,10 +20,6 @@ dune dune-build-info dune-site - fmt - logs - lsp - lwt markdown (pcre2 (>= 8)) (why3 (and (>= 1.8.0) (< 1.9))) diff --git a/easycrypt.opam b/easycrypt.opam index 976e20bd3d..daee24aa32 100644 --- a/easycrypt.opam +++ b/easycrypt.opam @@ -8,10 +8,6 @@ depends: [ "dune" {>= "3.13"} "dune-build-info" "dune-site" - "fmt" - "logs" - "lsp" - "lwt" "markdown" "pcre2" {>= "8"} "why3" {>= "1.8.0" & < "1.9"} diff --git a/src/dune b/src/dune index a699ccd3c3..a75a406694 100644 --- a/src/dune +++ b/src/dune @@ -16,7 +16,7 @@ (public_name easycrypt.ecLib) (foreign_stubs (language c) (names eunix)) (modules :standard \ ec) - (libraries batteries camlp-streams dune-build-info dune-site inifiles logs logs.fmt lospecs lsp lwt lwt.unix markdown markdown.html pcre2 tyxml why3 yojson zarith) + (libraries batteries camlp-streams dune-build-info dune-site inifiles lospecs markdown markdown.html pcre2 tyxml why3 yojson zarith) ) (executable diff --git a/src/ec.ml b/src/ec.ml index 1db0f6bca4..a40f7bef26 100644 --- a/src/ec.ml +++ b/src/ec.ml @@ -214,9 +214,6 @@ let main () = (* Execution of eager commands *) begin match options.o_command with - | `Lsp -> - EcLsp.run (); - exit 0 | `Runtest input -> begin let root = match EcRelocate.sourceroot with @@ -407,469 +404,6 @@ let main () = (* Register user messages printers *) begin let open EcUserMessages in register () end; - (* -------------------------------------------------------------------- *) - (* LLM interactive mode *) - (* -------------------------------------------------------------------- *) - - let llm_guide_path () = - let (module Sites) = EcRelocate.sites in - match EcRelocate.sourceroot with - | Some root -> - Filename.concat (Filename.concat root "doc/llm") "CLAUDE.md" - | None -> - Filename.concat Sites.doc "llm-guide.md" - in - - let print_llm_guide () = - let path = llm_guide_path () in - try - let ic = open_in path in - begin try while true do - print_char (input_char ic) - done with End_of_file -> () end; - close_in ic - with Sys_error e -> - Printf.eprintf "cannot read LLM guide: %s\n%!" e - in - - let run_llm_repl (llmopts : llm_option) = - if llmopts.llmo_help then begin - print_llm_guide (); - exit 0 - end; - - let prvopts = llmopts.llmo_provers in - (* Initialize PRNG *) - Random.self_init (); - - (* Connect to external Why3 server if requested *) - prvopts.prvo_why3server |> oiter (fun server -> - try - Why3.Prove_client.connect_external server - with Why3.Prove_client.ConnectionError e -> - Format.eprintf - "cannot connect to Why3 server `%s': %s" server e; - exit 1); - - (* Add current directory to load path *) - (match relocdir with - | None -> EcCommands.addidir Filename.current_dir_name - | Some pwd -> EcCommands.addidir pwd); - - (* Proof engine configuration *) - let checkmode = { - EcCommands.cm_checkall = prvopts.prvo_checkall; - EcCommands.cm_timeout = odfl 3 prvopts.prvo_timeout; - EcCommands.cm_cpufactor = odfl 1 prvopts.prvo_cpufactor; - EcCommands.cm_nprovers = odfl 4 prvopts.prvo_maxjobs; - EcCommands.cm_provers = prvopts.prvo_provers; - EcCommands.cm_quorum = prvopts.prvo_quorum; - EcCommands.cm_profile = prvopts.prvo_profile; - } in - - (* Notice buffer: collects messages during command processing *) - let notices = Buffer.create 256 in - - let notifier (_ : EcGState.loglevel) (lazy msg) = - Buffer.add_string notices msg; - Buffer.add_char notices '\n' - in - - let initialized = ref false in - - let do_initialize () = - EcCommands.initialize - ~restart:!initialized ~undo:true - ~boot:ldropts.ldro_boot ~checkmode ~checkproof:true; - initialized := true; - (try - List.iter EcCommands.apply_pragma prvopts.prvo_pragmas - with EcCommands.InvalidPragma x -> - EcScope.hierror "invalid pragma: `%s'\n%!" x); - EcCommands.addnotifier notifier; - oiter (fun ppwidth -> - let gs = EcEnv.gstate (EcScope.env (EcCommands.current ())) in - EcGState.setvalue "PP:width" (`Int ppwidth) gs) - prvopts.prvo_ppwidth - in - - (* Error formatting *) - let format_error ?(src="") e = - let base = match e with - | EcScope.TopError (loc, e) -> - let msg = String.strip (EcPException.tostring e) in - if loc = EcLocation._dummy then msg - else Format.asprintf "%s: %s" (EcLocation.tostring loc) msg - | e -> - String.strip (EcPException.tostring e) - in - if src = "" then base - else Printf.sprintf "%s\nsource: %s" base src - in - - (* Output helpers *) - let goals_to_string ?(all=false) () = - let buf = Buffer.create 256 in - let fmt = Format.formatter_of_buffer buf in - EcCommands.pp_current_goal_or_noproof ~all fmt; - Format.pp_print_flush fmt (); - Buffer.contents buf - in - - let quiet = ref false in - - let checkpoints : (string, int) Hashtbl.t = Hashtbl.create 16 in - - let reply_ok ?(tag="") body = - let n = Buffer.contents notices in - Printf.printf "OK [uuid:%d]%s\n" (EcCommands.uuid ()) tag; - if n <> "" then print_string n; - if body <> "" then begin - print_string body; - let len = String.length body in - if len > 0 && body.[len - 1] <> '\n' then - print_char '\n' - end; - Printf.printf "\n%!"; - Buffer.clear notices - in - - let reply_ok_goals ?(all=false) () = - if !quiet then reply_ok "" - else reply_ok (goals_to_string ~all ()) - in - - let reply_error msg = - let goals = goals_to_string () in - Printf.printf "ERROR [uuid:%d]\n%s\n" (EcCommands.uuid ()) msg; - if goals <> "" then begin - print_string goals; - let len = String.length goals in - if len > 0 && goals.[len - 1] <> '\n' then - print_char '\n' - end; - Printf.printf "\n%!"; - Buffer.clear notices - in - - (* Process a single EasyCrypt command, respecting gl_fail *) - let process_action ~src (p : EP.global) = - let loc = p.EP.gl_action.EcLocation.pl_loc in - let succeeded = ref false in - begin try - ignore (EcCommands.process ~src p.EP.gl_action : float option); - succeeded := true - with - | EcCommands.Restart -> raise EcCommands.Restart - | _ when p.EP.gl_fail -> () - | e -> raise (EcScope.toperror_of_exn ~gloc:loc e) - end; - if !succeeded && p.EP.gl_fail then - raise (EcScope.toperror_of_exn ~gloc:loc - (EcScope.HiScopeError (None, - "this command is expected to fail"))) - in - - (* Process EasyCrypt input from a string (one parsed program) *) - let process_ec_input input = - Buffer.clear notices; - let reader = EcIo.from_string input in - let last_src = ref "" in - begin try - let (src, prog) = EcIo.xparse reader in - let src = String.strip src in - last_src := src; - begin match EcLocation.unloc prog with - | EP.P_Prog (commands, _) -> - List.iter (process_action ~src) commands; - reply_ok_goals () - | EP.P_Undo i -> - EcCommands.undo i; - reply_ok_goals () - | EP.P_Exit -> - EcIo.finalize reader; exit 0 - | EP.P_DocComment doc -> - EcCommands.doc_comment doc; - reply_ok "" - end - with - | EcCommands.Restart -> - do_initialize (); - reply_ok "Session restarted" - | e -> - reply_error (format_error ~src:!last_src e) - end; - EcIo.finalize reader - in - - (* Handle LOAD "file.ec" [LINE[:COL]] *) - let handle_load args = - Buffer.clear notices; - let args = String.strip args in - let last_src = ref "" in - - try - (* Parse quoted or unquoted filename *) - let filename, rest = - if String.length args > 0 && args.[0] = '"' then - let close = - try String.index_from args 1 '"' - with Not_found -> - failwith "LOAD: unterminated filename" - in - let fn = String.sub args 1 (close - 1) in - let rest = String.strip ( - String.sub args (close + 1) - (String.length args - close - 1)) in - (fn, rest) - else - match String.split_on_char ' ' args with - | [] -> failwith "LOAD: missing filename" - | [f] -> (f, "") - | f :: rest -> (f, String.concat " " rest) - in - - (* Parse optional LINE[:COL] and flags (-nosmt) *) - let upto, nosmt = - if rest = "" then (None, false) - else - let words = String.split_on_char ' ' rest in - let words = List.filter (fun s -> s <> "") words in - let nosmt = List.mem "-nosmt" words in - let words = List.filter (fun s -> s <> "-nosmt") words in - let upto = match words with - | [] -> None - | [w] -> - begin match String.split_on_char ':' w with - | [line] -> - Some (int_of_string line, None) - | [line; col] -> - Some (int_of_string line, Some (int_of_string col)) - | _ -> failwith "LOAD: invalid LINE[:COL] format" - end - | _ -> failwith "LOAD: unexpected arguments" - in - (upto, nosmt) - in - - (* Validate file extension *) - begin try - ignore (EcLoader.getkind - (Filename.extension filename) : EcLoader.kind) - with EcLoader.BadExtension ext -> - failwith (Format.sprintf - "unknown file extension: %s" ext) - end; - - (* Reset proof engine and process file *) - do_initialize (); - Hashtbl.clear checkpoints; - EcCommands.addidir (Filename.dirname filename); - - let reader = EcIo.from_file filename in - - let past_upto (loc : EcLocation.t) = - match upto with - | None -> false - | Some (line, col) -> - let (el, ec) = loc.loc_end in - el > line || (el = line && match col with - | None -> false - | Some c -> ec > c) - in - - let last_loc = ref None in - - (* In -nosmt mode, admit all SMT calls during prefix loading *) - if nosmt then EcCommands.pragma_check `WeakCheck; - - begin try while true do - let (src, prog) = EcIo.xparse reader in - let src = String.strip src in - last_src := src; - match EcLocation.unloc prog with - | EP.P_Prog (commands, locterm) -> - List.iter (fun p -> - let loc = p.EP.gl_action.EcLocation.pl_loc in - if past_upto loc then raise Exit; - process_action ~src p; - last_loc := Some loc - ) commands; - if locterm then raise Exit - | EP.P_Undo i -> - EcCommands.undo i - | EP.P_Exit -> - raise Exit - | EP.P_DocComment doc -> - EcCommands.doc_comment doc - done with - | Exit | End_of_file -> () - | e -> - EcIo.finalize reader; - if nosmt then EcCommands.pragma_check `Check; - raise e - end; - - EcIo.finalize reader; - - (* Restore full SMT checking for interactive tactics *) - if nosmt then EcCommands.pragma_check `Check; - - let tag = - match !last_loc with - | None -> "" - | Some loc -> - let (el, _) = loc.EcLocation.loc_end in - Printf.sprintf " [loaded:%s:%d]" filename el - in - reply_ok ~tag (goals_to_string ()) - - with - | EcCommands.Restart -> - do_initialize (); - Hashtbl.clear checkpoints; - reply_ok "Session restarted" - | Failure s -> - reply_error s - | e -> - reply_error (format_error ~src:!last_src e) - in - - (* Initialize proof engine *) - do_initialize (); - - (* Signal ready *) - Printf.printf "READY [uuid:%d]\n\n%!" - (EcCommands.uuid ()); - - (* Main REPL loop *) - let multi_buf = Buffer.create 256 in - let in_multi = ref false in - - begin try while true do - let line = input_line stdin in - let line = String.strip line in - - (* Multi-line input: starts, flushes *) - if line = "" then begin - Buffer.clear multi_buf; - in_multi := true - end - else if line = "" && !in_multi then begin - let input = Buffer.contents multi_buf in - Buffer.clear multi_buf; - in_multi := false; - if input <> "" then process_ec_input input - end - else if !in_multi then begin - if Buffer.length multi_buf > 0 then - Buffer.add_char multi_buf ' '; - Buffer.add_string multi_buf line - end - - else if line = "" then - () - else if line = "QUIT" then - exit 0 - else if line = "HELP" then begin - Buffer.clear notices; - let buf = Buffer.create 4096 in - let path = llm_guide_path () in - begin try - let ic = open_in path in - begin try while true do - Buffer.add_char buf (input_char ic) - done with End_of_file -> () end; - close_in ic; - reply_ok (Buffer.contents buf) - with Sys_error e -> - reply_error (Printf.sprintf "cannot read guide: %s" e) - end - end - else if line = "UNDO" then begin - Buffer.clear notices; - let uuid = EcCommands.uuid () in - if uuid > 0 then begin - EcCommands.undo (uuid - 1); - reply_ok_goals () - end else - reply_error "nothing to undo" - end - else if line = "GOALS ALL" then begin - Buffer.clear notices; - reply_ok (goals_to_string ~all:true ()) - end - else if line = "GOALS" then begin - Buffer.clear notices; - reply_ok (goals_to_string ()) - end - else if String.starts_with line "CHECKPOINT " then begin - Buffer.clear notices; - let name = String.strip ( - String.sub line 11 (String.length line - 11)) in - if name = "" then - reply_error "CHECKPOINT: missing name" - else begin - Hashtbl.replace checkpoints name (EcCommands.uuid ()); - reply_ok (Printf.sprintf - "checkpoint '%s' set at uuid %d" name (EcCommands.uuid ())) - end - end - else if String.starts_with line "REVERT " then begin - Buffer.clear notices; - let n = String.strip ( - String.sub line 7 (String.length line - 7)) in - let target = - try Some (int_of_string n) - with Failure _ -> Hashtbl.find_opt checkpoints n - in - begin match target with - | None -> - reply_error (Printf.sprintf - "REVERT: '%s' is not a valid uuid or checkpoint name" n) - | Some target -> - let uuid = EcCommands.uuid () in - if target < 0 || target > uuid then - reply_error (Printf.sprintf - "REVERT: uuid %d out of range [0, %d]" target uuid) - else begin - EcCommands.undo target; - reply_ok_goals () - end - end - end - else if line = "QUIET ON" then begin - Buffer.clear notices; - quiet := true; - reply_ok "" - end - else if line = "QUIET OFF" then begin - Buffer.clear notices; - quiet := false; - reply_ok "" - end - else if String.starts_with line "SEARCH " then begin - let query = String.strip ( - String.sub line 7 (String.length line - 7)) in - let query = - if String.ends_with query "." - then String.sub query 0 (String.length query - 1) - else query - in - process_ec_input (Printf.sprintf "search %s." query) - end - else if String.starts_with line "LOAD " then - handle_load (String.sub line 5 (String.length line - 5)) - else - (* Treat as EasyCrypt input *) - process_ec_input line - done with - | End_of_file -> () - end; - - exit 0 - in - (* Initialize I/O + interaction module *) let module State = struct type t = { @@ -1001,15 +535,38 @@ let main () = end - | `Llm llmopts -> - run_llm_repl llmopts + | `Llm llmopts -> begin + let name = llmopts.llmo_input in + + begin try + let ext = Filename.extension name in + ignore (EcLoader.getkind ext : EcLoader.kind) + with EcLoader.BadExtension ext -> + Format.eprintf "do not know what to do with %s@." ext; + exit 1 + end; + + let lastgoals = llmopts.llmo_lastgoals in + let terminal = + lazy (T.from_channel ~name ~progress:`Silent ~lastgoals (open_in name)) + in + + { prvopts = llmopts.llmo_provers + ; input = Some name + ; terminal = terminal + ; interactive = false + ; eco = true + ; gccompact = None + ; docgen = false + ; outdirp = None + ; upto = llmopts.llmo_upto + ; trace = None } + + end | `Runtest _ -> (* Eagerly executed *) assert false - | `Lsp -> - (* Eagerly executed *) - assert false | `DocGen docopts -> begin let name = docopts.doco_input in diff --git a/src/ecLsp.ml b/src/ecLsp.ml deleted file mode 100644 index 6dde77b4df..0000000000 --- a/src/ecLsp.ml +++ /dev/null @@ -1,777 +0,0 @@ -open Lwt.Syntax - -module Json = Yojson.Safe -module J = Yojson.Safe.Util - -module Lsp_io = - Lsp.Io.Make - (struct - type 'a t = 'a Lwt.t - - let return = Lwt.return - let raise = Lwt.fail - - module O = struct - let ( let+ ) x f = Lwt.map f x - let ( let* ) x f = Lwt.bind x f - end - end) - (struct - type input = Lwt_io.input_channel - type output = Lwt_io.output_channel - - let read_line ic = Lwt_io.read_line_opt ic - - let read_exactly ic len = - let rec loop acc remaining = - if remaining <= 0 then - Lwt.return (Some (Buffer.contents acc)) - else - Lwt.bind (Lwt_io.read ~count:remaining ic) (fun s -> - if s = "" then - Lwt.return None - else ( - Buffer.add_string acc s; - loop acc (remaining - String.length s) - )) - in - loop (Buffer.create len) len - - let write oc chunks = - Lwt.bind (Lwt_list.iter_s (Lwt_io.write oc) chunks) (fun () -> - Lwt_io.flush oc) - end) - -let setup_logging () : unit = - let reporter = - match Sys.getenv_opt "EASYCRYPT_LSP_LOG" with - | None -> Logs_fmt.reporter () - | Some path -> ( - try - let oc = - open_out_gen [ Open_creat; Open_text; Open_append ] 0o644 path - in - Logs_fmt.reporter ~dst:(Format.formatter_of_out_channel oc) () - with e -> - prerr_endline ("[easycrypt-lsp] failed to open log file: " ^ Printexc.to_string e); - Logs_fmt.reporter ()) - in - Logs.set_reporter reporter; - Logs.set_level (Some Logs.Info) - -let log (fmt : ('a, Format.formatter, unit, unit) format4) = - Format.kasprintf (fun msg -> Logs.info (fun m -> m "%s" msg)) fmt - -module Easycrypt_cli = struct - type session = { - proc : Lwt_process.process; - mutable uuid : int; - mutable mode : string; - mutable last_output : string; - root_uuid : int; - } - - type config = { - mutable cli_path : string; - mutable cli_args : string list; - } - - let prompt_re : Pcre2.regexp = - Pcre2.regexp "\\[([0-9]+)\\|([^\\]]+)\\]>" - - let parse_prompt (line : string) : (int * string) option = - try - let subs = Pcre2.exec ~rex:prompt_re line in - let uuid_str = Pcre2.get_substring subs 1 in - let mode = Pcre2.get_substring subs 2 in - Some (int_of_string uuid_str, mode) - with - | Not_found -> None - | Pcre2.Error _ -> None - - let default_cli_path () : string = - if Sys.file_exists "ec.native" then - "./ec.native" - else - "easycrypt" - - let read_until_prompt (sess : session) : string Lwt.t = - let buf = Buffer.create 256 in - let rec loop () = - let* line_opt = Lwt_io.read_line_opt sess.proc#stdout in - match line_opt with - | None -> Lwt.return (Buffer.contents buf) - | Some line -> - log "cli - sess.uuid <- uuid; - sess.mode <- mode; - Lwt.return (Buffer.contents buf) - | None -> - Buffer.add_string buf line; - Buffer.add_char buf '\n'; - loop ()) - in - loop () - - let start_session (cfg : config) : session Lwt.t = - let argv = - let args = "cli" :: "-emacs" :: cfg.cli_args in - Array.of_list (cfg.cli_path :: args) - in - let proc = Lwt_process.open_process (cfg.cli_path, argv) in - let sess = - { proc - ; uuid = 0 - ; mode = "" - ; last_output = "" - ; root_uuid = 0 - } - in - let* _initial_output = read_until_prompt sess in - Lwt.return { sess with root_uuid = sess.uuid } - - let send_command ?(record_last_output = true) (sess : session) (text : string) : string Lwt.t = - log "cli> %s" (String.trim text); - let write = - if String.ends_with ~suffix:"\n" text then - Lwt_io.write sess.proc#stdin text - else - Lwt_io.write_line sess.proc#stdin text - in - let* () = write in - let* () = Lwt_io.flush sess.proc#stdin in - let* output = read_until_prompt sess in - if record_last_output then - sess.last_output <- output; - let preview = - if String.length output = 0 then "" - else if String.length output <= 200 then String.escaped output - else String.escaped (String.sub output 0 200) ^ "..." - in - log "cli< (%d bytes) %s" (String.length output) preview; - Lwt.return output - - let send_undo (sess : session) (target_uuid : int) : string Lwt.t = - let cmd = Printf.sprintf "undo %d." target_uuid in - send_command sess cmd - - let stop_session (sess : session) : unit Lwt.t = - let close_chan ch = Lwt.catch (fun () -> Lwt_io.close ch) (fun _ -> Lwt.return_unit) in - let* () = close_chan sess.proc#stdin in - let* () = close_chan sess.proc#stdout in - sess.proc#terminate; - let* _status = sess.proc#status in - Lwt.return_unit - -end - -type doc_state = { - mutable text : BatText.t; - mutable last_offset : int; - mutable history : (int * int) list; - mutable session : Easycrypt_cli.session option; -} - -let doc_states : (string, doc_state) Hashtbl.t = Hashtbl.create 16 - -let get_doc_state (uri : string) : doc_state = - match Hashtbl.find_opt doc_states uri with - | Some state -> state - | None -> - let created = { text = BatText.empty; last_offset = 0; history = []; session = None } in - Hashtbl.add doc_states uri created; - created - -let error_tag_re : Pcre2.regexp = - Pcre2.regexp "\\[error-\\d+-\\d+\\]" - -let output_has_error (output : string) : bool = - Pcre2.pmatch ~rex:error_tag_re output - -let find_next_sentence - (text : BatText.t) - (start : int) : (string * int * int) option = - EcIo.next_sentence_from (BatText.to_string text) start - -let position_to_offset (text : BatText.t) (pos : Lsp.Types.Position.t) : int = - let len = BatText.length text in - let target_line = pos.Lsp.Types.Position.line in - let target_col = pos.Lsp.Types.Position.character in - let newline = BatUChar.of_char '\n' in - let rec find_line_start line current = - if line <= 0 then - current - else - try - let idx = BatText.index_from text current newline in - find_line_start (line - 1) (min (idx + 1) len) - with - | Not_found -> len - | BatText.Out_of_bounds -> len - in - let line_start = find_line_start target_line 0 in - if line_start >= len then - len - else - let offset = line_start + target_col in - if offset > len then len else offset - -let apply_change - (text : BatText.t) - (change : Lsp.Types.TextDocumentContentChangeEvent.t) : BatText.t * int = - match change.Lsp.Types.TextDocumentContentChangeEvent.range with - | None -> - BatText.of_string change.Lsp.Types.TextDocumentContentChangeEvent.text, 0 - | Some range -> - let start_offset = position_to_offset text range.Lsp.Types.Range.start in - let end_offset = position_to_offset text range.Lsp.Types.Range.end_ in - let len = BatText.length text in - let start_offset = max 0 (min start_offset len) in - let end_offset = max start_offset (min end_offset len) in - let removed = BatText.remove start_offset (end_offset - start_offset) text in - let inserted = BatText.of_string change.Lsp.Types.TextDocumentContentChangeEvent.text in - (BatText.insert start_offset inserted removed, start_offset) - -let json_of_proof_response - ~(sess : Easycrypt_cli.session) - ~(doc : doc_state) - ?sentence - (output : string) : Json.t = - let sentence_start, sentence_end = - match sentence with - | None -> (`Null, `Null) - | Some (start, end_) -> (`Int start, `Int end_) - in - `Assoc - [ ("output", `String output) - ; ("uuid", `Int sess.uuid) - ; ("mode", `String sess.mode) - ; ("processedEnd", `Int doc.last_offset) - ; ("sentenceStart", sentence_start) - ; ("sentenceEnd", sentence_end) - ] - -let json_of_query_response (output : string) : Json.t = - `Assoc [ ("output", `String output) ] - -let rstrip (s : string) : string = - let rec find i = - if i < 0 then - -1 - else - match s.[i] with - | ' ' | '\t' | '\r' | '\n' -> find (i - 1) - | _ -> i - in - let last = find (String.length s - 1) in - if last < 0 then "" else String.sub s 0 (last + 1) - -let strip_trailing_goal (output : string) (goal : string) : string = - let output_trimmed = rstrip output in - let goal_trimmed = rstrip goal in - if goal_trimmed = "" || output_trimmed = goal_trimmed then - output_trimmed - else if String.ends_with ~suffix:goal_trimmed output_trimmed then - let prefix_len = String.length output_trimmed - String.length goal_trimmed in - rstrip (String.sub output_trimmed 0 prefix_len) - else - output_trimmed - -type proof_command_kind = - | Proof_next - | Proof_step - | Proof_jump_to of int - | Proof_back - | Proof_restart - | Proof_goals - | Query_print of string - | Query_locate of string - | Query_search of string - -type proof_command = - { uri : string - ; cmd : proof_command_kind - } - -let proof_command_of_request (meth : string) (params : Json.t option) : - (proof_command, string) result = - let get_uri json = - match J.member "uri" json with - | `String uri -> uri - | _ -> "" - in - let get_query json = - match J.member "query" json with - | `String query -> String.trim query - | _ -> "" - in - match meth, params with - | "easycrypt/proof/next", Some (`Assoc _ as json) -> - let uri = get_uri json in - if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_next } - | "easycrypt/proof/step", Some (`Assoc _ as json) -> - let uri = get_uri json in - if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_step } - | "easycrypt/proof/jumpTo", Some (`Assoc _ as json) -> - let uri = get_uri json in - let target = - try J.member "target" json |> J.to_int with _ -> -1 - in - if uri = "" || target < 0 then - Error "missing uri or target" - else - Ok { uri; cmd = Proof_jump_to target } - | "easycrypt/proof/back", Some (`Assoc _ as json) -> - let uri = get_uri json in - if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_back } - | "easycrypt/proof/restart", Some (`Assoc _ as json) -> - let uri = get_uri json in - if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_restart } - | "easycrypt/proof/goals", Some (`Assoc _ as json) -> - let uri = get_uri json in - if uri = "" then Error "missing uri" else Ok { uri; cmd = Proof_goals } - | "easycrypt/query/print", Some (`Assoc _ as json) -> - let uri = get_uri json in - let query = get_query json in - if uri = "" || query = "" then - Error "missing uri or query" - else - Ok { uri; cmd = Query_print query } - | "easycrypt/query/locate", Some (`Assoc _ as json) -> - let uri = get_uri json in - let query = get_query json in - if uri = "" || query = "" then - Error "missing uri or query" - else - Ok { uri; cmd = Query_locate query } - | "easycrypt/query/search", Some (`Assoc _ as json) -> - let uri = get_uri json in - let query = get_query json in - if uri = "" || query = "" then - Error "missing uri or query" - else - Ok { uri; cmd = Query_search query } - | _ -> Error "Method not found" - -let rewind_to_offset - (doc : doc_state) - (sess : Easycrypt_cli.session) - (target : int) : string option Lwt.t = - if target >= doc.last_offset then - Lwt.return_none - else - let rec last_before acc = function - | [] -> acc - | (offset, uuid) :: rest -> - let acc = if offset <= target then Some (offset, uuid) else acc in - last_before acc rest - in - let target_entry = last_before None doc.history in - let target_uuid, new_offset = - match target_entry with - | None -> sess.root_uuid, 0 - | Some (offset, uuid) -> uuid, offset - in - doc.history <- List.filter (fun (offset, _) -> offset <= new_offset) doc.history; - doc.last_offset <- new_offset; - let* output = Easycrypt_cli.send_undo sess target_uuid in - Lwt.return (Some output) - -let send_packet (oc : Lwt_io.output_channel) (packet : Jsonrpc.Packet.t) : unit Lwt.t = - Lsp_io.write oc packet - -let send_response (oc : Lwt_io.output_channel) (id : Jsonrpc.Id.t) (result : Jsonrpc.Json.t) : - unit Lwt.t = - let response = Jsonrpc.Response.ok id result in - send_packet oc (Jsonrpc.Packet.Response response) - -let send_typed_response - (oc : Lwt_io.output_channel) - (id : Jsonrpc.Id.t) - (req : 'a Lsp.Client_request.t) - (result : 'a) : unit Lwt.t = - let payload = Lsp.Client_request.yojson_of_result req result in - send_response oc id payload - -let send_error - (oc : Lwt_io.output_channel) - (id : Jsonrpc.Id.t) - (code : Jsonrpc.Response.Error.Code.t) - (message : string) : unit Lwt.t = - let error = - Jsonrpc.Response.Error.make - ~code - ~message - () - in - let response = Jsonrpc.Response.error id error in - send_packet oc (Jsonrpc.Packet.Response response) - -let send_notification (oc : Lwt_io.output_channel) (method_ : string) (params : Jsonrpc.Json.t) : - unit Lwt.t = - let params_struct = Jsonrpc.Structured.t_of_yojson params in - let notif = Jsonrpc.Notification.create ~params:params_struct ~method_ () in - send_packet oc (Jsonrpc.Packet.Notification notif) - -let run () : unit = - Sys.set_signal Sys.sigpipe Sys.Signal_ignore; - setup_logging (); - log "argv=%s" (String.concat " " (Array.to_list Sys.argv)); - log "server start"; - let run_lwt () : unit Lwt.t = - let argv = Array.to_list Sys.argv in - let cli_path = - match argv with - | prog :: _ -> prog - | [] -> Easycrypt_cli.default_cli_path () - in - let cfg : Easycrypt_cli.config = { cli_path; cli_args = [] } in - let ic = Lwt_io.of_fd ~mode:Lwt_io.input Lwt_unix.stdin in - let oc = Lwt_io.of_fd ~mode:Lwt_io.output Lwt_unix.stdout in - let shutdown = ref false in - let pending : (Jsonrpc.Id.t * proof_command) Queue.t = Queue.create () in - let current : unit Lwt.t option ref = ref None in - - let get_session_for_doc (doc : doc_state) : Easycrypt_cli.session Lwt.t = - match doc.session with - | Some sess -> Lwt.return sess - | None -> - let* sess = Easycrypt_cli.start_session cfg in - doc.session <- Some sess; - Lwt.return sess - in - - let handle_initialize id (params : Lsp.Types.InitializeParams.t) : unit Lwt.t = - log "initialize"; - let capabilities = - Lsp.Types.ServerCapabilities.create - ~textDocumentSync:(`TextDocumentSyncKind Lsp.Types.TextDocumentSyncKind.Incremental) - () - in - let result = Lsp.Types.InitializeResult.create ~capabilities () in - send_typed_response oc id (Lsp.Client_request.Initialize params) result - in - - let handle_proof_next id uri : unit Lwt.t = - log "proof next"; - let doc = get_doc_state uri in - let* sess = get_session_for_doc doc in - match find_next_sentence doc.text doc.last_offset with - | None -> - send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) - | Some (_text, start, end_) -> - send_response oc id (json_of_proof_response ~sess ~doc ~sentence:(start, end_) sess.last_output) - in - - let handle_proof_exec id uri : unit Lwt.t = - log "proof exec"; - let doc = get_doc_state uri in - match find_next_sentence doc.text doc.last_offset with - | None -> - let* sess = get_session_for_doc doc in - send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) - | Some (text, start, end_) -> - let previous_offset = doc.last_offset in - let rec run ~retry = - let* sess = get_session_for_doc doc in - Lwt.catch - (fun () -> - let* output = Easycrypt_cli.send_command sess text in - Lwt.return (sess, output)) - (function - | Sys_error msg - when retry && String.lowercase_ascii msg = "broken pipe" -> - log "cli broken pipe; restarting session"; - doc.session <- None; - run ~retry:false - | e -> Lwt.fail e) - in - Lwt.catch - (fun () -> - let* sess, output = run ~retry:true in - if output_has_error output then ( - doc.last_offset <- previous_offset; - send_response oc id - (json_of_proof_response ~sess ~doc ~sentence:(start, end_) output)) - else ( - doc.last_offset <- end_; - doc.history <- doc.history @ [ (doc.last_offset, sess.uuid) ]; - send_response oc id - (json_of_proof_response ~sess ~doc ~sentence:(start, end_) output))) - (fun e -> - log "proof exec error: %s" (Printexc.to_string e); - send_error oc id Jsonrpc.Response.Error.Code.InternalError "proof exec failed") - in - - let handle_proof_jump id uri target : unit Lwt.t = - log "proof jump"; - let doc = get_doc_state uri in - let* sess = get_session_for_doc doc in - let text_len = BatText.length doc.text in - let target = max 0 (min target text_len) in - let respond ?sentence output = - send_response oc id (json_of_proof_response ~sess ~doc ?sentence output) - in - if target < doc.last_offset then ( - let rec last_before acc = function - | [] -> acc - | (offset, uuid) :: rest -> - let acc = if offset <= target then Some (offset, uuid) else acc in - last_before acc rest - in - let target_entry = last_before None doc.history in - let target_uuid, new_offset = - match target_entry with - | None -> sess.root_uuid, 0 - | Some (offset, uuid) -> uuid, offset - in - doc.history <- List.filter (fun (offset, _) -> offset <= new_offset) doc.history; - doc.last_offset <- new_offset; - let* output = Easycrypt_cli.send_undo sess target_uuid in - respond output) - else if target = doc.last_offset then - respond sess.last_output - else ( - let rec loop last_output = - if doc.last_offset >= target then - respond last_output - else - match find_next_sentence doc.text doc.last_offset with - | None -> respond last_output - | Some (text, start, end_) -> - if end_ > target then - respond last_output - else - let previous_offset = doc.last_offset in - let* output = Easycrypt_cli.send_command sess text in - if output_has_error output then ( - doc.last_offset <- previous_offset; - respond ~sentence:(start, end_) output) - else ( - doc.last_offset <- end_; - doc.history <- doc.history @ [ (doc.last_offset, sess.uuid) ]; - loop output) - in - loop sess.last_output) - in - - let handle_proof_back id uri : unit Lwt.t = - log "proof back"; - let doc = get_doc_state uri in - let* sess = get_session_for_doc doc in - match List.rev doc.history with - | [] -> - send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) - | _last :: rest_rev -> - let target_uuid, new_offset = - match rest_rev with - | [] -> sess.root_uuid, 0 - | (offset, uuid) :: _ -> uuid, offset - in - let* output = Easycrypt_cli.send_undo sess target_uuid in - doc.history <- List.rev rest_rev; - doc.last_offset <- new_offset; - send_response oc id (json_of_proof_response ~sess ~doc output) - in - - let handle_proof_restart id uri : unit Lwt.t = - log "proof restart"; - let doc = get_doc_state uri in - let* sess = get_session_for_doc doc in - let* output = Easycrypt_cli.send_undo sess sess.root_uuid in - doc.history <- []; - doc.last_offset <- 0; - send_response oc id (json_of_proof_response ~sess ~doc output) - in - - let handle_proof_goals id uri : unit Lwt.t = - log "proof goals"; - let doc = get_doc_state uri in - let* sess = get_session_for_doc doc in - send_response oc id (json_of_proof_response ~sess ~doc sess.last_output) - in - - let normalize_query_command keyword query = - let query = String.trim query in - if query = "" then - invalid_arg "empty query" - else - let query = - if String.ends_with ~suffix:"." query then - String.sub query 0 (String.length query - 1) - else - query - in - Printf.sprintf "%s %s." keyword query - in - - let handle_query id uri keyword query : unit Lwt.t = - log "query %s" keyword; - let doc = get_doc_state uri in - let* sess = get_session_for_doc doc in - let command = normalize_query_command keyword query in - let* output = Easycrypt_cli.send_command ~record_last_output:false sess command in - let output = strip_trailing_goal output sess.last_output in - send_response oc id (json_of_query_response output) - in - - let execute_proof_command (id : Jsonrpc.Id.t) (cmd : proof_command) : unit Lwt.t = - match cmd.cmd with - | Proof_next -> handle_proof_next id cmd.uri - | Proof_step -> handle_proof_exec id cmd.uri - | Proof_jump_to target -> handle_proof_jump id cmd.uri target - | Proof_back -> handle_proof_back id cmd.uri - | Proof_restart -> handle_proof_restart id cmd.uri - | Proof_goals -> handle_proof_goals id cmd.uri - | Query_print query -> handle_query id cmd.uri "print" query - | Query_locate query -> handle_query id cmd.uri "locate" query - | Query_search query -> handle_query id cmd.uri "search" query - in - - let start_proof (id : Jsonrpc.Id.t) (cmd : proof_command) : unit Lwt.t = - Lwt.catch - (fun () -> execute_proof_command id cmd) - (fun e -> - log "proof command error: %s" (Printexc.to_string e); - send_error oc id Jsonrpc.Response.Error.Code.InternalError "proof command failed") - in - - let pop_pending () = - if Queue.is_empty pending then None else Some (Queue.take pending) - in - - let handle_request req : unit Lwt.t = - match Lsp.Client_request.of_jsonrpc req with - | Error message -> - send_error oc req.id Jsonrpc.Response.Error.Code.InvalidParams message - | Ok (Lsp.Client_request.E r) -> ( - match r with - | Lsp.Client_request.Initialize params -> - handle_initialize req.id params - | Lsp.Client_request.Shutdown -> - shutdown := true; - send_typed_response oc req.id r () - | Lsp.Client_request.UnknownRequest { meth; params } -> ( - let params = Option.map Jsonrpc.Structured.yojson_of_t params in - match proof_command_of_request meth params with - | Ok cmd -> - (match !current with - | None -> - let task = start_proof req.id cmd in - current := Some task; - Lwt.return_unit - | Some _ -> - Queue.push (req.id, cmd) pending; - Lwt.return_unit) - | Error "Method not found" -> - send_error oc req.id Jsonrpc.Response.Error.Code.MethodNotFound "Method not found" - | Error message -> - send_error oc req.id Jsonrpc.Response.Error.Code.InvalidParams message) - | _ -> - send_error oc req.id Jsonrpc.Response.Error.Code.MethodNotFound "Method not found") - in - - let handle_notification_packet notif : unit Lwt.t = - match Lsp.Client_notification.of_jsonrpc notif with - | Error _ -> Lwt.return_unit - | Ok notification -> ( - match notification with - | Lsp.Client_notification.Initialized -> Lwt.return_unit - | Lsp.Client_notification.Exit -> shutdown := true; Lwt.return_unit - | Lsp.Client_notification.TextDocumentDidOpen params -> - let uri = - Lsp.Types.DocumentUri.to_string - params.Lsp.Types.DidOpenTextDocumentParams.textDocument.uri - in - let doc = get_doc_state uri in - doc.text <- BatText.of_string params.Lsp.Types.DidOpenTextDocumentParams.textDocument.text; - doc.last_offset <- 0; - doc.history <- []; - doc.session <- None; - Lwt.return_unit - | Lsp.Client_notification.TextDocumentDidChange params -> - let uri = - Lsp.Types.DocumentUri.to_string - params.Lsp.Types.DidChangeTextDocumentParams.textDocument.uri - in - let doc = get_doc_state uri in - let earliest = ref max_int in - let updated = ref doc.text in - List.iter - (fun change -> - let text, start_offset = apply_change !updated change in - updated := text; - if start_offset < !earliest then earliest := start_offset) - params.Lsp.Types.DidChangeTextDocumentParams.contentChanges; - doc.text <- !updated; - if !earliest < doc.last_offset then - let* sess = get_session_for_doc doc in - let* _ = rewind_to_offset doc sess !earliest in - Lwt.return_unit - else - Lwt.return_unit - | Lsp.Client_notification.TextDocumentDidClose params -> - let uri = - Lsp.Types.DocumentUri.to_string - params.Lsp.Types.DidCloseTextDocumentParams.textDocument.uri - in - let* () = - match Hashtbl.find_opt doc_states uri with - | Some doc -> ( - match doc.session with - | Some sess -> Easycrypt_cli.stop_session sess - | None -> Lwt.return_unit) - | None -> Lwt.return_unit - in - Hashtbl.remove doc_states uri; - Lwt.return_unit - | _ -> Lwt.return_unit) - in - - let rec loop () : unit Lwt.t = - if !shutdown then - Lwt.return_unit - else - let read_p = Lsp_io.read ic |> Lwt.map (fun p -> `Packet p) in - let waiters = - match !current with - | None -> [ read_p ] - | Some cmd_p -> [ read_p; (cmd_p |> Lwt.map (fun () -> `Cmd_done)) ] - in - let* ev = Lwt.pick waiters in - match ev with - | `Cmd_done -> - current := None; - (match pop_pending () with - | None -> () - | Some (id, cmd) -> current := Some (start_proof id cmd)); - loop () - | `Packet None -> - log "stdin closed"; - shutdown := true; - Lwt.return_unit - | `Packet (Some packet) -> - let* () = - match packet with - | Jsonrpc.Packet.Request req -> - log "recv request %s" req.Jsonrpc.Request.method_; - handle_request req - | Jsonrpc.Packet.Notification notif -> - log "recv notification %s" notif.Jsonrpc.Notification.method_; - handle_notification_packet notif - | Jsonrpc.Packet.Batch_call calls -> - Lwt_list.iter_s - (function - | `Request req -> handle_request req - | `Notification notif -> handle_notification_packet notif) - calls - | Jsonrpc.Packet.Response _ -> Lwt.return_unit - | Jsonrpc.Packet.Batch_response _ -> Lwt.return_unit - in - loop () - in - loop () - in - Lwt_main.run (run_lwt ()) diff --git a/src/ecLsp.mli b/src/ecLsp.mli deleted file mode 100644 index 733b2a3231..0000000000 --- a/src/ecLsp.mli +++ /dev/null @@ -1 +0,0 @@ -val run : unit -> unit diff --git a/src/ecOptions.ml b/src/ecOptions.ml index fab1a54e77..bd21a69aa0 100644 --- a/src/ecOptions.ml +++ b/src/ecOptions.ml @@ -6,7 +6,6 @@ open EcMaps type command = [ | `Compile of cmp_option | `Cli of cli_option - | `Lsp | `Config | `Runtest of run_option | `Why3Config @@ -50,8 +49,10 @@ and doc_option = { } and llm_option = { + llmo_input : string; llmo_provers : prv_options; - llmo_help : bool; + llmo_lastgoals : bool; + llmo_upto : (int * int option) option; } and prv_options = { @@ -369,19 +370,17 @@ let specs = { `Spec ("trace" , `Flag , "Save all goals & messages in .eco"); `Spec ("compact", `Int , "")]); - ("llm", "LLM-friendly interactive mode", [ + ("llm", "LLM-friendly batch compilation", [ `Group "loader"; `Group "provers"; - `Spec ("help", `Flag, "Print the LLM agent guide and exit")]); + `Spec ("lastgoals" , `Flag , "Print last unproved goals on failure"); + `Spec ("upto" , `String, "Compile up to LINE or LINE:COL and print goals")]); ("cli", "Run EasyCrypt top-level", [ `Group "loader"; `Group "provers"; `Spec ("emacs", `Flag, "Output format set to ")]); - ("lsp", "Run EasyCrypt LSP server", [ - `Spec ("-stdio" , `Flag , "")]); - ("config", "Print EasyCrypt configuration", []); ("runtest", "Run a test-suite", [ @@ -539,8 +538,7 @@ let prv_options_of_values ini values = let cli_options_of_values ini values = { clio_emacs = get_flag "emacs" values; - clio_provers = prv_options_of_values ini values; - } + clio_provers = prv_options_of_values ini values; } let cmp_options_of_values ini values input = { cmpo_input = input; @@ -549,9 +547,8 @@ let cmp_options_of_values ini values input = cmpo_compact = get_int "compact" values; cmpo_tstats = get_string "tstats" values; cmpo_noeco = get_flag "no-eco" values; - cmpo_script = get_flag "script" values; - cmpo_trace = get_flag "trace" values; - } + cmpo_script = get_flag "script" values; + cmpo_trace = get_flag "trace" values; } let runtest_options_of_values ini values (input, scenarios) = { runo_input = input; @@ -559,16 +556,32 @@ let runtest_options_of_values ini values (input, scenarios) = runo_report = get_string "report" values; runo_provers = prv_options_of_values ini values; runo_jobs = get_int "jobs" values; - runo_rawargs = get_strings "raw-args" values; - } + runo_rawargs = get_strings "raw-args" values; } let doc_options_of_values values input = { doco_input = input; doco_outdirp = get_string "outdir" values; } -let llm_options_of_values ini values = - { llmo_provers = prv_options_of_values ini values; - llmo_help = get_flag "help" values; } +let parse_upto values = + get_string "upto" values |> Option.map (fun s -> + let invalid () = + raise (Arg.Bad (Printf.sprintf + "invalid -upto format: expected LINE or LINE:COL, got %S" s)) in + match String.split_on_char ':' s with + | [line] -> + let line = try int_of_string line with Failure _ -> invalid () in + (line, None) + | [line; col] -> + let line = try int_of_string line with Failure _ -> invalid () in + let col = try int_of_string col with Failure _ -> invalid () in + (line, Some col) + | _ -> invalid ()) + +let llm_options_of_values ini values input = + { llmo_input = input; + llmo_provers = prv_options_of_values ini values; + llmo_lastgoals = get_flag "lastgoals" values; + llmo_upto = parse_upto values; } (* -------------------------------------------------------------------- *) let parse getini argv = @@ -641,23 +654,16 @@ let parse getini argv = raise (Arg.Bad "this command takes a single input file as argument") end - | "lsp" -> - if not (List.is_empty anons) then - raise (Arg.Bad "this command does not take arguments"); - - let ini = getini None in - let cmd = `Lsp in - - (cmd, ini, true) - - | "llm" -> - if not (List.is_empty anons) then - raise (Arg.Bad "this command does not take arguments"); - - let ini = getini None in - let cmd = `Llm (llm_options_of_values ini values) in + | "llm" -> begin + match anons with + | [input] -> + let ini = getini (Some input) in + let cmd = `Llm (llm_options_of_values ini values input) in + (cmd, ini, true) - (cmd, ini, true) + | _ -> + raise (Arg.Bad "this command takes a single argument") + end | _ -> assert false @@ -741,8 +747,7 @@ let read_ini_file (filename : string) = ini_quorum = tryint "quorum" ; ini_timeout = tryint "timeout" ; ini_idirs = List.map parse_idir (trylist "idirs"); - ini_rdirs = List.map parse_idir (trylist "rdirs"); - } in + ini_rdirs = List.map parse_idir (trylist "rdirs"); } in { ini_ppwidth = ini.ini_ppwidth; ini_why3 = omap expand ini.ini_why3; @@ -751,5 +756,4 @@ let read_ini_file (filename : string) = ini_quorum = ini.ini_quorum; ini_timeout = ini.ini_timeout; ini_idirs = ini.ini_idirs; - ini_rdirs = ini.ini_rdirs; - } + ini_rdirs = ini.ini_rdirs; } diff --git a/src/ecOptions.mli b/src/ecOptions.mli index 59d8b0d644..a5c09b11d9 100644 --- a/src/ecOptions.mli +++ b/src/ecOptions.mli @@ -2,7 +2,6 @@ type command = [ | `Compile of cmp_option | `Cli of cli_option - | `Lsp | `Config | `Runtest of run_option | `Why3Config @@ -46,8 +45,10 @@ and doc_option = { } and llm_option = { + llmo_input : string; llmo_provers : prv_options; - llmo_help : bool; + llmo_lastgoals : bool; + llmo_upto : (int * int option) option; } and prv_options = { diff --git a/vscode/.gitignore b/vscode/.gitignore deleted file mode 100644 index 82abfab5cc..0000000000 --- a/vscode/.gitignore +++ /dev/null @@ -1,2 +0,0 @@ -/node_modules/ -/out/ diff --git a/vscode/README.md b/vscode/README.md deleted file mode 100644 index 0c3ac44c83..0000000000 --- a/vscode/README.md +++ /dev/null @@ -1,46 +0,0 @@ -# EasyCrypt VSCode Extension (local) - -This folder contains a local VSCode extension for EasyCrypt. - -## Build the EasyCrypt binary (with LSP) - -From the repository root: - -``` -$ dune build src/ec.exe -``` - -The binary will be at `_build/default/src/ec.exe` and provides `easycrypt lsp`. - -## Build the extension - -From this `vscode/` folder: - -``` -$ npm install -$ npm run compile -``` - -Then use "Developer: Install Extension from Location..." and select this folder. - -## Configuration - -- `easycrypt.cli.path`: path to the EasyCrypt CLI (e.g. `ec.native` or `easycrypt`). - -## TextMate colors - -This extension uses TextMate scopes for syntax highlighting. To customize colors without changing a theme, add rules to your VSCode settings: - -```jsonc -"editor.tokenColorCustomizations": { - "textMateRules": [ - { "scope": "keyword.other.easycrypt.bytac", "settings": { "foreground": "#6C71C4" } }, - { "scope": "keyword.other.easycrypt.dangerous", "settings": { "foreground": "#DC322F", "fontStyle": "bold" } }, - { "scope": "keyword.control.easycrypt.global", "settings": { "foreground": "#268BD2" } }, - { "scope": "keyword.other.easycrypt.internal", "settings": { "foreground": "#B58900" } }, - { "scope": "keyword.operator.easycrypt.prog", "settings": { "foreground": "#2AA198" } }, - { "scope": "keyword.control.easycrypt.tactic", "settings": { "foreground": "#859900" } }, - { "scope": "keyword.control.easycrypt.tactical", "settings": { "foreground": "#CB4B16" } } - ] -} -``` diff --git a/vscode/assets/back.svg b/vscode/assets/back.svg deleted file mode 100644 index 63fa276430..0000000000 --- a/vscode/assets/back.svg +++ /dev/null @@ -1,3 +0,0 @@ - - - diff --git a/vscode/assets/easycrypt.svg b/vscode/assets/easycrypt.svg deleted file mode 100644 index f18030d31a..0000000000 --- a/vscode/assets/easycrypt.svg +++ /dev/null @@ -1,5 +0,0 @@ - - - - - diff --git a/vscode/assets/goals.svg b/vscode/assets/goals.svg deleted file mode 100644 index fe6bd5048c..0000000000 --- a/vscode/assets/goals.svg +++ /dev/null @@ -1,4 +0,0 @@ - - - - diff --git a/vscode/assets/jump.svg b/vscode/assets/jump.svg deleted file mode 100644 index daeb25d592..0000000000 --- a/vscode/assets/jump.svg +++ /dev/null @@ -1,3 +0,0 @@ - - - diff --git a/vscode/assets/refresh.svg b/vscode/assets/refresh.svg deleted file mode 100644 index d124bdd5c7..0000000000 --- a/vscode/assets/refresh.svg +++ /dev/null @@ -1,3 +0,0 @@ - - - diff --git a/vscode/assets/step.svg b/vscode/assets/step.svg deleted file mode 100644 index dd77f646a7..0000000000 --- a/vscode/assets/step.svg +++ /dev/null @@ -1,3 +0,0 @@ - - - diff --git a/vscode/language-configuration.json b/vscode/language-configuration.json deleted file mode 100644 index 163424eeb9..0000000000 --- a/vscode/language-configuration.json +++ /dev/null @@ -1,23 +0,0 @@ -{ - "comments": { - "lineComment": "//", - "blockComment": ["(*", "*)"] - }, - "brackets": [ - ["{", "}"], - ["[", "]"], - ["(", ")"] - ], - "autoClosingPairs": [ - {"open": "{", "close": "}"}, - {"open": "[", "close": "]"}, - {"open": "(", "close": ")"}, - {"open": "\"", "close": "\""} - ], - "surroundingPairs": [ - ["{", "}"], - ["[", "]"], - ["(", ")"], - ["\"", "\""] - ] -} diff --git a/vscode/package-lock.json b/vscode/package-lock.json deleted file mode 100644 index 7070c58627..0000000000 --- a/vscode/package-lock.json +++ /dev/null @@ -1,139 +0,0 @@ -{ - "name": "easycrypt-vscode", - "version": "0.0.1", - "lockfileVersion": 3, - "requires": true, - "packages": { - "": { - "name": "easycrypt-vscode", - "version": "0.0.1", - "dependencies": { - "vscode-languageclient": "^9.0.1" - }, - "devDependencies": { - "@types/node": "^20.11.0", - "@types/vscode": "^1.85.0", - "typescript": "^5.3.3" - }, - "engines": { - "vscode": "^1.85.0" - } - }, - "node_modules/@types/node": { - "version": "20.19.30", - "resolved": "https://registry.npmjs.org/@types/node/-/node-20.19.30.tgz", - "integrity": "sha512-WJtwWJu7UdlvzEAUm484QNg5eAoq5QR08KDNx7g45Usrs2NtOPiX8ugDqmKdXkyL03rBqU5dYNYVQetEpBHq2g==", - "dev": true, - "license": "MIT", - "dependencies": { - "undici-types": "~6.21.0" - } - }, - "node_modules/@types/vscode": { - "version": "1.108.1", - "resolved": "https://registry.npmjs.org/@types/vscode/-/vscode-1.108.1.tgz", - "integrity": "sha512-DerV0BbSzt87TbrqmZ7lRDIYaMiqvP8tmJTzW2p49ZBVtGUnGAu2RGQd1Wv4XMzEVUpaHbsemVM5nfuQJj7H6w==", - "dev": true, - "license": "MIT" - }, - "node_modules/balanced-match": { - "version": "1.0.2", - "resolved": "https://registry.npmjs.org/balanced-match/-/balanced-match-1.0.2.tgz", - "integrity": "sha512-3oSeUO0TMV67hN1AmbXsK4yaqU7tjiHlbxRDZOpH0KW9+CeX4bRAaX0Anxt0tx2MrpRpWwQaPwIlISEJhYU5Pw==", - "license": "MIT" - }, - "node_modules/brace-expansion": { - "version": "2.0.2", - "resolved": "https://registry.npmjs.org/brace-expansion/-/brace-expansion-2.0.2.tgz", - "integrity": "sha512-Jt0vHyM+jmUBqojB7E1NIYadt0vI0Qxjxd2TErW94wDz+E2LAm5vKMXXwg6ZZBTHPuUlDgQHKXvjGBdfcF1ZDQ==", - "license": "MIT", - "dependencies": { - "balanced-match": "^1.0.0" - } - }, - "node_modules/minimatch": { - "version": "5.1.6", - "resolved": "https://registry.npmjs.org/minimatch/-/minimatch-5.1.6.tgz", - "integrity": "sha512-lKwV/1brpG6mBUFHtb7NUmtABCb2WZZmm2wNiOA5hAb8VdCS4B3dtMWyvcoViccwAW/COERjXLt0zP1zXUN26g==", - "license": "ISC", - "dependencies": { - "brace-expansion": "^2.0.1" - }, - "engines": { - "node": ">=10" - } - }, - "node_modules/semver": { - "version": "7.7.3", - "resolved": "https://registry.npmjs.org/semver/-/semver-7.7.3.tgz", - "integrity": "sha512-SdsKMrI9TdgjdweUSR9MweHA4EJ8YxHn8DFaDisvhVlUOe4BF1tLD7GAj0lIqWVl+dPb/rExr0Btby5loQm20Q==", - "license": "ISC", - "bin": { - "semver": "bin/semver.js" - }, - "engines": { - "node": ">=10" - } - }, - "node_modules/typescript": { - "version": "5.9.3", - "resolved": "https://registry.npmjs.org/typescript/-/typescript-5.9.3.tgz", - "integrity": "sha512-jl1vZzPDinLr9eUt3J/t7V6FgNEw9QjvBPdysz9KfQDD41fQrC2Y4vKQdiaUpFT4bXlb1RHhLpp8wtm6M5TgSw==", - "dev": true, - "license": "Apache-2.0", - "bin": { - "tsc": "bin/tsc", - "tsserver": "bin/tsserver" - }, - "engines": { - "node": ">=14.17" - } - }, - "node_modules/undici-types": { - "version": "6.21.0", - "resolved": "https://registry.npmjs.org/undici-types/-/undici-types-6.21.0.tgz", - "integrity": "sha512-iwDZqg0QAGrg9Rav5H4n0M64c3mkR59cJ6wQp+7C4nI0gsmExaedaYLNO44eT4AtBBwjbTiGPMlt2Md0T9H9JQ==", - "dev": true, - "license": "MIT" - }, - "node_modules/vscode-jsonrpc": { - "version": "8.2.0", - "resolved": "https://registry.npmjs.org/vscode-jsonrpc/-/vscode-jsonrpc-8.2.0.tgz", - "integrity": "sha512-C+r0eKJUIfiDIfwJhria30+TYWPtuHJXHtI7J0YlOmKAo7ogxP20T0zxB7HZQIFhIyvoBPwWskjxrvAtfjyZfA==", - "license": "MIT", - "engines": { - "node": ">=14.0.0" - } - }, - "node_modules/vscode-languageclient": { - "version": "9.0.1", - "resolved": "https://registry.npmjs.org/vscode-languageclient/-/vscode-languageclient-9.0.1.tgz", - "integrity": "sha512-JZiimVdvimEuHh5olxhxkht09m3JzUGwggb5eRUkzzJhZ2KjCN0nh55VfiED9oez9DyF8/fz1g1iBV3h+0Z2EA==", - "license": "MIT", - "dependencies": { - "minimatch": "^5.1.0", - "semver": "^7.3.7", - "vscode-languageserver-protocol": "3.17.5" - }, - "engines": { - "vscode": "^1.82.0" - } - }, - "node_modules/vscode-languageserver-protocol": { - "version": "3.17.5", - "resolved": "https://registry.npmjs.org/vscode-languageserver-protocol/-/vscode-languageserver-protocol-3.17.5.tgz", - "integrity": "sha512-mb1bvRJN8SVznADSGWM9u/b07H7Ecg0I3OgXDuLdn307rl/J3A9YD6/eYOssqhecL27hK1IPZAsaqh00i/Jljg==", - "license": "MIT", - "dependencies": { - "vscode-jsonrpc": "8.2.0", - "vscode-languageserver-types": "3.17.5" - } - }, - "node_modules/vscode-languageserver-types": { - "version": "3.17.5", - "resolved": "https://registry.npmjs.org/vscode-languageserver-types/-/vscode-languageserver-types-3.17.5.tgz", - "integrity": "sha512-Ld1VelNuX9pdF39h2Hgaeb5hEZM2Z3jUrrMgWQAu82jMtZp7p3vJT3BzToKtZI7NgQssZje5o0zryOrhQvzQAg==", - "license": "MIT" - } - } -} diff --git a/vscode/package.json b/vscode/package.json deleted file mode 100644 index 81b732dc1a..0000000000 --- a/vscode/package.json +++ /dev/null @@ -1,226 +0,0 @@ -{ - "name": "easycrypt-vscode", - "displayName": "EasyCrypt", - "publisher": "easycrypt", - "version": "0.0.1", - "engines": { - "vscode": "^1.85.0" - }, - "categories": ["Programming Languages"], - "activationEvents": [ - "onLanguage:easycrypt", - "onCommand:easycrypt.proof.step", - "onCommand:easycrypt.proof.back", - "onCommand:easycrypt.proof.restart", - "onCommand:easycrypt.proof.jumpToCursor", - "onCommand:easycrypt.proof.goals", - "onCommand:easycrypt.query.print", - "onCommand:easycrypt.query.locate", - "onCommand:easycrypt.query.search", - "onCommand:easycrypt.lsp.restart" - ], - "main": "./out/extension.js", - "contributes": { - "languages": [ - { - "id": "easycrypt", - "aliases": ["EasyCrypt", "easycrypt"], - "extensions": [".ec"], - "configuration": "./language-configuration.json" - } - ], - "grammars": [ - { - "language": "easycrypt", - "scopeName": "source.easycrypt", - "path": "./syntaxes/easycrypt.tmLanguage.json" - } - ], - "submenus": [ - { - "id": "easycrypt.query", - "label": "EasyCrypt" - } - ], - "commands": [ - { - "command": "easycrypt.proof.step", - "title": "Step", - "icon": { "light": "assets/step.svg", "dark": "assets/step.svg" } - }, - { - "command": "easycrypt.proof.back", - "title": "Back", - "icon": { "light": "assets/back.svg", "dark": "assets/back.svg" } - }, - { - "command": "easycrypt.proof.restart", - "title": "Restart", - "icon": { "light": "assets/refresh.svg", "dark": "assets/refresh.svg" } - }, - { - "command": "easycrypt.proof.jumpToCursor", - "title": "Jump To Cursor", - "icon": { "light": "assets/jump.svg", "dark": "assets/jump.svg" } - }, - { - "command": "easycrypt.proof.goals", - "title": "Show Goals", - "icon": { "light": "assets/goals.svg", "dark": "assets/goals.svg" } - }, - { - "command": "easycrypt.query.print", - "title": "Print Object", - "category": "EasyCrypt" - }, - { - "command": "easycrypt.query.locate", - "title": "Locate Object", - "category": "EasyCrypt" - }, - { - "command": "easycrypt.query.search", - "title": "Search Objects", - "category": "EasyCrypt" - }, - { - "command": "easycrypt.lsp.restart", - "title": "Restart LSP" - } - ], - "menus": { - "editor/title": [ - { - "command": "easycrypt.proof.step", - "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", - "group": "navigation.easycrypt@3" - }, - { - "command": "easycrypt.proof.step", - "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", - "group": "inline.easycrypt@3" - }, - { - "command": "easycrypt.proof.back", - "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", - "group": "navigation.easycrypt@1" - }, - { - "command": "easycrypt.proof.back", - "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", - "group": "inline.easycrypt@1" - }, - { - "command": "easycrypt.proof.jumpToCursor", - "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", - "group": "navigation.easycrypt@2" - }, - { - "command": "easycrypt.proof.jumpToCursor", - "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", - "group": "inline.easycrypt@2" - }, - { - "command": "easycrypt.proof.goals", - "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'navigation'", - "group": "navigation.easycrypt@4" - }, - { - "command": "easycrypt.proof.goals", - "when": "resourceLangId == easycrypt && config.easycrypt.ui.editorToolbarGroup == 'inline'", - "group": "inline.easycrypt@4" - } - ], - "editor/context": [ - { - "submenu": "easycrypt.query", - "when": "resourceLangId == easycrypt", - "group": "navigation" - } - ], - "easycrypt.query": [ - { - "command": "easycrypt.query.print", - "when": "resourceLangId == easycrypt", - "group": "query" - }, - { - "command": "easycrypt.query.locate", - "when": "resourceLangId == easycrypt", - "group": "query" - }, - { - "command": "easycrypt.query.search", - "when": "resourceLangId == easycrypt", - "group": "query" - } - ] - }, - "keybindings": [ - { - "command": "easycrypt.proof.step", - "key": "ctrl+alt+down", - "mac": "cmd+alt+down", - "when": "editorLangId == easycrypt" - }, - { - "command": "easycrypt.proof.back", - "key": "ctrl+alt+up", - "mac": "cmd+alt+up", - "when": "editorLangId == easycrypt" - }, - { - "command": "easycrypt.proof.jumpToCursor", - "key": "ctrl+alt+enter", - "mac": "cmd+alt+enter", - "when": "editorLangId == easycrypt" - }, - { - "command": "easycrypt.proof.goals", - "key": "ctrl+alt+g", - "mac": "cmd+alt+g", - "when": "editorLangId == easycrypt" - } - ], - "configuration": { - "title": "EasyCrypt", - "properties": { - "easycrypt.cli.path": { - "type": "string", - "default": "", - "description": "Path to the EasyCrypt CLI (easycrypt or ec.native)." - }, - "easycrypt.cli.args": { - "type": "array", - "items": { "type": "string" }, - "default": [], - "description": "Extra arguments passed to the EasyCrypt CLI when running in proof mode." - }, - "easycrypt.trace.server": { - "type": "string", - "enum": ["off", "messages", "verbose"], - "default": "off", - "description": "Trace LSP communication to the Output panel." - }, - "easycrypt.ui.editorToolbarGroup": { - "type": "string", - "enum": ["navigation", "inline"], - "default": "navigation", - "description": "Editor title toolbar group for EasyCrypt buttons." - } - } - } - }, - "scripts": { - "compile": "tsc -p ./", - "watch": "tsc -w -p ./" - }, - "dependencies": { - "vscode-languageclient": "^9.0.1" - }, - "devDependencies": { - "@types/node": "^20.11.0", - "@types/vscode": "^1.85.0", - "typescript": "^5.3.3" - } -} diff --git a/vscode/package.nls.json b/vscode/package.nls.json deleted file mode 100644 index 2da004d97c..0000000000 --- a/vscode/package.nls.json +++ /dev/null @@ -1,3 +0,0 @@ -{ - "easycrypt.ui.editorToolbarGroup": "Editor title toolbar group for EasyCrypt buttons." -} diff --git a/vscode/src/extension.ts b/vscode/src/extension.ts deleted file mode 100644 index 900ad46491..0000000000 --- a/vscode/src/extension.ts +++ /dev/null @@ -1,1020 +0,0 @@ -import * as fs from 'fs'; -import * as path from 'path'; -import * as vscode from 'vscode'; -import { - LanguageClient, - LanguageClientOptions, - ServerOptions, - TransportKind, - Trace -} from 'vscode-languageclient/node'; - -type ProofResponse = { - output: string; - uuid: number; - mode: string; - processedEnd: number; - sentenceStart?: number | null; - sentenceEnd?: number | null; -}; - -type QueryResponse = { - output: string; -}; - -type DocState = { - lastOffset: number; -}; - -let client: LanguageClient | undefined; -let clientReady: Promise | undefined; -let clientOptions: LanguageClientOptions | undefined; -let serverOptions: ServerOptions | undefined; -let goalsPanel: vscode.WebviewPanel | undefined; -let queryPanel: vscode.WebviewPanel | undefined; -let queryStatusBarItem: vscode.StatusBarItem | undefined; -let printStatusBarItem: vscode.StatusBarItem | undefined; -let locateStatusBarItem: vscode.StatusBarItem | undefined; -let outputChannel: vscode.OutputChannel | undefined; -let traceLevel: Trace = Trace.Off; -let lspCommand: string | undefined; -let lspArgs: string[] = []; -let processedDecoration: vscode.TextEditorDecorationType | undefined; -let processingDecoration: vscode.TextEditorDecorationType | undefined; -let errorDecoration: vscode.TextEditorDecorationType | undefined; -let lastEasyCryptEditor: vscode.TextEditor | undefined; -const docStates = new Map(); -let suppressProcessedEdits = false; -let suppressProcessingEdits = false; -let processingDocUri: string | undefined; -let processingSnapshot: string | undefined; -let diagnostics: vscode.DiagnosticCollection | undefined; - -function getDocState(doc: vscode.TextDocument): DocState { - const key = doc.uri.toString(); - const state = docStates.get(key); - if (state) { - return state; - } - const created = { lastOffset: 0 }; - docStates.set(key, created); - return created; -} - -function escapeHtml(value: string): string { - return value - .replace(/&/g, '&') - .replace(//g, '>'); -} - -function showGoals(output: string): void { - showTextPanel('easycryptGoals', 'EasyCrypt Goals', output, { - panel: goalsPanel, - setPanel: (panel) => { - goalsPanel = panel; - } - }); -} - -function showQueryResult(title: string, output: string): void { - showTextPanel('easycryptQuery', title, output, { - panel: queryPanel, - setPanel: (panel) => { - queryPanel = panel; - } - }); -} - -function showTextPanel( - viewType: string, - title: string, - output: string, - holder: { - panel: vscode.WebviewPanel | undefined; - setPanel: (panel: vscode.WebviewPanel | undefined) => void; - } -): void { - let panel = holder.panel; - if (!panel) { - panel = vscode.window.createWebviewPanel( - viewType, - title, - { viewColumn: vscode.ViewColumn.Beside, preserveFocus: true }, - { enableFindWidget: true } - ); - panel.onDidDispose(() => { - holder.setPanel(undefined); - }); - holder.setPanel(panel); - } else { - panel.title = title; - panel.reveal(panel.viewColumn, true); - } - - panel.webview.html = ` - - - - - - - -
${escapeHtml(output)}
- -`; -} - -async function restoreEditorFocus(editor: vscode.TextEditor | undefined): Promise { - if (!editor) { - return; - } - await vscode.window.showTextDocument(editor.document, { - viewColumn: editor.viewColumn, - preserveFocus: false, - selection: editor.selection - }); -} - -function getQuerySeed(editor: vscode.TextEditor): string { - const selection = editor.document.getText(editor.selection).trim(); - if (selection.length > 0) { - return selection; - } - const wordRange = editor.document.getWordRangeAtPosition(editor.selection.active); - if (!wordRange) { - return ''; - } - return editor.document.getText(wordRange).trim(); -} - -async function promptQuery( - editor: vscode.TextEditor, - kind: 'print' | 'locate' | 'search' -): Promise { - return vscode.window.showInputBox({ - title: `EasyCrypt ${kind}`, - prompt: `Enter an EasyCrypt ${kind} query`, - value: getQuerySeed(editor), - ignoreFocusOut: true - }); -} - -async function executeQuery( - editor: vscode.TextEditor, - method: 'easycrypt/query/print' | 'easycrypt/query/locate' | 'easycrypt/query/search', - kind: 'print' | 'locate' | 'search', - title: string, - query: string -): Promise { - try { - outputChannel?.appendLine(`[query] ${kind} ${query}`); - const result = await requestProof(method, { - uri: editor.document.uri.toString(), - query - }); - if (outputHasError(result.output)) { - handleQueryError(title, result.output, editor); - await restoreEditorFocus(editor); - return; - } - showQueryResult(title, result.output.trim().length > 0 ? result.output : 'No output.'); - await restoreEditorFocus(editor); - } catch (err) { - outputChannel?.appendLine(`[query] ${kind} failed ${String(err)}`); - vscode.window.showErrorMessage(`EasyCrypt ${kind} failed: ${String(err)}`); - } finally { - refreshQueryStatusBar(editor); - } -} - -async function runQuery( - method: 'easycrypt/query/print' | 'easycrypt/query/locate' | 'easycrypt/query/search', - kind: 'print' | 'locate' | 'search', - title: string -): Promise { - const editor = getEditorForCommand(); - if (!editor) { - vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); - return; - } - - const query = (await promptQuery(editor, kind))?.trim(); - if (!query) { - return; - } - - await executeQuery(editor, method, kind, title, query); -} - -async function handlePrintQuery(): Promise { - await runQuery('easycrypt/query/print', 'print', 'EasyCrypt Print'); -} - -async function handleLocateQuery(): Promise { - await runQuery('easycrypt/query/locate', 'locate', 'EasyCrypt Locate'); -} - -async function handleSearchQuery(): Promise { - await runQuery('easycrypt/query/search', 'search', 'EasyCrypt Search'); -} - -async function handleLocateCurrentQuery(): Promise { - const editor = getEditorForCommand(); - if (!editor || editor.document.languageId !== 'easycrypt') { - return; - } - const query = getQuerySeed(editor); - if (!query) { - return; - } - await executeQuery( - editor, - 'easycrypt/query/locate', - 'locate', - `EasyCrypt Locate: ${query}`, - query - ); -} - -async function handlePrintCurrentQuery(): Promise { - const editor = getEditorForCommand(); - if (!editor || editor.document.languageId !== 'easycrypt') { - return; - } - const query = getQuerySeed(editor); - if (!query) { - return; - } - await executeQuery( - editor, - 'easycrypt/query/print', - 'print', - `EasyCrypt Print: ${query}`, - query - ); -} - -async function handleQueryStatusBar(): Promise { - const editor = getEditorForCommand(); - if (!editor || editor.document.languageId !== 'easycrypt') { - return; - } - - const selection = await vscode.window.showQuickPick( - [ - { - label: '$(symbol-key) Print Object', - command: 'easycrypt.query.print' - }, - { - label: '$(symbol-file) Locate Object', - command: 'easycrypt.query.locate' - }, - { - label: '$(search) Search Objects', - command: 'easycrypt.query.search' - } - ], - { - title: 'EasyCrypt Query', - placeHolder: 'Choose a query command' - } - ); - - if (!selection) { - return; - } - - await vscode.commands.executeCommand(selection.command); -} - -function updateQueryStatusBar(editor: vscode.TextEditor | undefined): void { - if (!queryStatusBarItem) { - return; - } - if (getStatusBarEditor(editor)) { - queryStatusBarItem.show(); - } else { - queryStatusBarItem.hide(); - } -} - -function updateLocateStatusBar(editor: vscode.TextEditor | undefined): void { - if (!locateStatusBarItem) { - return; - } - const targetEditor = getStatusBarEditor(editor); - if (!targetEditor) { - locateStatusBarItem.hide(); - return; - } - - const query = getQuerySeed(targetEditor); - if (!query) { - locateStatusBarItem.hide(); - return; - } - - locateStatusBarItem.text = '$(symbol-file) Locate'; - locateStatusBarItem.tooltip = `EasyCrypt: locate ${query}`; - locateStatusBarItem.show(); -} - -function updatePrintStatusBar(editor: vscode.TextEditor | undefined): void { - if (!printStatusBarItem) { - return; - } - const targetEditor = getStatusBarEditor(editor); - if (!targetEditor) { - printStatusBarItem.hide(); - return; - } - - const query = getQuerySeed(targetEditor); - if (!query) { - printStatusBarItem.hide(); - return; - } - - printStatusBarItem.text = '$(symbol-key) Print'; - printStatusBarItem.tooltip = `EasyCrypt: print ${query}`; - printStatusBarItem.show(); -} - -function refreshQueryStatusBar(editor: vscode.TextEditor | undefined): void { - updateQueryStatusBar(editor); - updatePrintStatusBar(editor); - updateLocateStatusBar(editor); -} - -function updateProcessedDecoration(editor: vscode.TextEditor | undefined): void { - if (!editor || !processedDecoration) { - return; - } - const state = getDocState(editor.document); - const endOffset = state.lastOffset; - const endPos = editor.document.positionAt(endOffset); - const startPos = new vscode.Position(0, 0); - const anchor = new vscode.Range(startPos, startPos); - const fixed = new vscode.Range(startPos, endPos); - editor.setDecorations(processedDecoration, [anchor, fixed]); -} - -function setProcessingDecoration(editor: vscode.TextEditor | undefined, range: vscode.Range): void { - if (!editor || !processingDecoration) { - return; - } - editor.setDecorations(processingDecoration, [range]); -} - -function clearProcessingDecoration(editor: vscode.TextEditor | undefined): void { - if (!editor || !processingDecoration) { - return; - } - editor.setDecorations(processingDecoration, []); -} - -function setProcessingLock(doc: vscode.TextDocument): void { - processingDocUri = doc.uri.toString(); - processingSnapshot = doc.getText(); -} - -function clearProcessingLock(): void { - processingDocUri = undefined; - processingSnapshot = undefined; -} - -async function restoreProcessingSnapshot(doc: vscode.TextDocument): Promise { - if (!processingSnapshot) { - return; - } - const lastLine = doc.lineAt(doc.lineCount - 1); - const fullRange = new vscode.Range(new vscode.Position(0, 0), lastLine.range.end); - const edit = new vscode.WorkspaceEdit(); - edit.replace(doc.uri, fullRange, processingSnapshot); - await vscode.workspace.applyEdit(edit); -} - -function outputHasError(output: string): boolean { - return /\[error-\d+-\d+\]/.test(output); -} - -function summarizeErrorOutput(output: string): string { - const line = output.split(/\r?\n/).find((entry) => entry.trim().length > 0); - if (!line) { - return 'EasyCrypt reported an error.'; - } - const cleaned = line.replace(/\[error-\d+-\d+\]/g, '').trim(); - return cleaned.length > 0 ? cleaned : 'EasyCrypt reported an error.'; -} - -function showGoalsOrError(output: string): void { - if (output.trim().length > 0) { - showGoals(output); - } else { - showGoals('EasyCrypt reported an error.'); - } -} - -function showQueryResultOrError(title: string, output: string): void { - if (output.trim().length > 0) { - showQueryResult(title, output); - } else { - showQueryResult(title, 'EasyCrypt reported an error.'); - } -} - -function parseErrorTag(output: string): { start: number; end: number; message: string } | undefined { - const match = output.match(/\[error-(\d+)-(\d+)\]/); - if (!match) { - return undefined; - } - const start = Number(match[1]); - const end = Number(match[2]); - if (!Number.isFinite(start) || !Number.isFinite(end)) { - return undefined; - } - const message = output.replace(match[0], '').trim(); - return { start, end, message: message.length > 0 ? message : 'EasyCrypt reported an error.' }; -} - -function clearErrorDecoration(editor: vscode.TextEditor | undefined): void { - if (!editor || !errorDecoration) { - return; - } - editor.setDecorations(errorDecoration, []); -} - -function clearDiagnostics(doc: vscode.TextDocument): void { - diagnostics?.delete(doc.uri); -} - -function showErrorDecoration( - editor: vscode.TextEditor | undefined, - sentenceOffset: number, - errorStart: number, - errorEnd: number -): void { - if (!editor || !errorDecoration) { - return; - } - const start = editor.document.positionAt(sentenceOffset + errorStart); - const end = editor.document.positionAt(sentenceOffset + Math.max(errorStart + 1, errorEnd)); - editor.setDecorations(errorDecoration, [new vscode.Range(start, end)]); -} - -function handleProofError( - output: string, - editor: vscode.TextEditor | undefined, - sentenceOffset?: number -): void { - const parsed = parseErrorTag(output); - if (parsed && sentenceOffset !== undefined) { - showErrorDecoration(editor, sentenceOffset, parsed.start, parsed.end); - showGoals(parsed.message); - if (editor && diagnostics) { - const doc = editor.document; - const start = doc.positionAt(sentenceOffset + parsed.start); - const end = doc.positionAt(sentenceOffset + Math.max(parsed.start + 1, parsed.end)); - const range = new vscode.Range(start, end); - const diag = new vscode.Diagnostic(range, parsed.message, vscode.DiagnosticSeverity.Error); - diagnostics.set(doc.uri, [diag]); - } - } else { - showGoalsOrError(output.replace(/\[error-\d+-\d+\]/g, '').trim()); - } -} - -function handleQueryError( - title: string, - output: string, - editor: vscode.TextEditor | undefined -): void { - const parsed = parseErrorTag(output); - clearErrorDecoration(editor); - if (editor) { - clearDiagnostics(editor.document); - } - if (parsed) { - showQueryResult(title, parsed.message); - } else { - showQueryResultOrError(title, output.replace(/\[error-\d+-\d+\]/g, '').trim()); - } -} - -function getEditorForCommand(): vscode.TextEditor | undefined { - const active = vscode.window.activeTextEditor; - if (active && active.document.languageId === 'easycrypt') { - return active; - } - return lastEasyCryptEditor; -} - -function getStatusBarEditor(editor: vscode.TextEditor | undefined): vscode.TextEditor | undefined { - if (editor && editor.document.languageId === 'easycrypt') { - return editor; - } - if (lastEasyCryptEditor?.document.languageId === 'easycrypt') { - return lastEasyCryptEditor; - } - return undefined; -} - -async function requestProof( - method: string, - params: Record -): Promise { - if (!client) { - throw new Error('EasyCrypt language client is not running.'); - } - if (clientReady) { - await clientReady; - } - const start = Date.now(); - outputChannel?.appendLine(`[proof] request ${method}`); - const timeout = setTimeout(() => { - outputChannel?.appendLine(`[proof] waiting ${method} >3s`); - }, 3000); - try { - const result = await client.sendRequest(method, params); - const elapsed = Date.now() - start; - outputChannel?.appendLine(`[proof] response ${method} ${elapsed}ms`); - return result; - } catch (err) { - const elapsed = Date.now() - start; - outputChannel?.appendLine(`[proof] error ${method} ${elapsed}ms ${String(err)}`); - throw err; - } finally { - clearTimeout(timeout); - } -} - -async function handleStep(): Promise { - const editor = getEditorForCommand(); - if (!editor) { - vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); - return; - } - - const doc = editor.document; - const state = getDocState(doc); - const previousOffset = state.lastOffset; - let sentenceStart: number | null | undefined; - let sentenceEnd: number | null | undefined; - let previewProcessedEnd = state.lastOffset; - try { - const preview = await requestProof('easycrypt/proof/next', { uri: doc.uri.toString() }); - sentenceStart = preview.sentenceStart ?? null; - sentenceEnd = preview.sentenceEnd ?? null; - previewProcessedEnd = preview.processedEnd; - } catch (err) { - outputChannel?.appendLine(`[proof] step preview failed ${String(err)}`); - } - - if (sentenceStart == null || sentenceEnd == null) { - state.lastOffset = previewProcessedEnd; - updateProcessedDecoration(editor); - return; - } - - if (sentenceStart != null && sentenceEnd != null) { - const processingRange = new vscode.Range( - doc.positionAt(sentenceStart), - doc.positionAt(sentenceEnd) - ); - setProcessingDecoration(editor, processingRange); - setProcessingLock(doc); - } - - try { - const result = await requestProof('easycrypt/proof/step', { uri: doc.uri.toString() }); - outputChannel?.appendLine(`[proof] step ok uuid=${result.uuid} mode=${result.mode}`); - state.lastOffset = result.processedEnd; - if (outputHasError(result.output)) { - outputChannel?.appendLine(`[proof] step reported error ${result.output}`); - updateProcessedDecoration(editor); - if (result.sentenceStart != null) { - handleProofError(result.output, editor, result.sentenceStart); - } else { - handleProofError(result.output, editor, previousOffset); - } - } else { - showGoals(result.output); - updateProcessedDecoration(editor); - clearErrorDecoration(editor); - clearDiagnostics(editor.document); - } - } catch (err) { - outputChannel?.appendLine(`[proof] step failed ${String(err)}`); - vscode.window.showErrorMessage(`EasyCrypt step failed: ${String(err)}`); - } finally { - clearProcessingDecoration(editor); - clearProcessingLock(); - } -} - -async function handleSendRegion(): Promise { - const editor = getEditorForCommand(); - if (!editor) { - vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); - return; - } - - const doc = editor.document; - const state = getDocState(doc); - const cursorOffset = doc.offsetAt(editor.selection.active); - try { - outputChannel?.appendLine('[proof] jumpToCursor'); - const result = await requestProof('easycrypt/proof/jumpTo', { - uri: doc.uri.toString(), - target: cursorOffset - }); - outputChannel?.appendLine(`[proof] jumpToCursor ok uuid=${result.uuid} mode=${result.mode}`); - state.lastOffset = result.processedEnd; - if (outputHasError(result.output)) { - outputChannel?.appendLine(`[proof] jumpToCursor reported error ${result.output}`); - updateProcessedDecoration(editor); - if (result.sentenceStart != null) { - handleProofError(result.output, editor, result.sentenceStart); - } else { - handleProofError(result.output, editor, state.lastOffset); - } - return; - } - showGoals(result.output); - updateProcessedDecoration(editor); - clearErrorDecoration(editor); - clearDiagnostics(doc); - } catch (err) { - outputChannel?.appendLine(`[proof] jumpToCursor failed ${String(err)}`); - vscode.window.showErrorMessage(`EasyCrypt jump-to-cursor failed: ${String(err)}`); - } finally { - clearProcessingDecoration(editor); - clearProcessingLock(); - } -} - -async function handleBack(): Promise { - const editor = getEditorForCommand(); - if (!editor) { - vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); - return; - } - - const state = getDocState(editor.document); - try { - outputChannel?.appendLine('[proof] back'); - const result = await requestProof('easycrypt/proof/back', { - uri: editor.document.uri.toString() - }); - if (outputHasError(result.output)) { - outputChannel?.appendLine(`[proof] back reported error ${result.output}`); - if (result.sentenceStart != null) { - handleProofError(result.output, editor, result.sentenceStart); - } else { - handleProofError(result.output, editor); - } - } else { - state.lastOffset = result.processedEnd; - outputChannel?.appendLine(`[proof] back ok uuid=${result.uuid} mode=${result.mode}`); - showGoals(result.output); - updateProcessedDecoration(editor); - clearErrorDecoration(editor); - clearDiagnostics(editor.document); - } - } catch (err) { - outputChannel?.appendLine(`[proof] back failed ${String(err)}`); - vscode.window.showErrorMessage(`EasyCrypt back failed: ${String(err)}`); - } -} - -async function handleRestart(): Promise { - const editor = getEditorForCommand(); - if (!editor) { - vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); - return; - } - const state = editor ? getDocState(editor.document) : undefined; - const previousOffset = state?.lastOffset ?? 0; - - try { - outputChannel?.appendLine('[proof] restart'); - const result = await requestProof('easycrypt/proof/restart', { - uri: editor.document.uri.toString() - }); - outputChannel?.appendLine(`[proof] restart ok uuid=${result.uuid} mode=${result.mode}`); - if (outputHasError(result.output)) { - outputChannel?.appendLine(`[proof] restart reported error ${result.output}`); - handleProofError(result.output, editor); - if (state) { - state.lastOffset = previousOffset; - } - } else { - if (state) { - state.lastOffset = result.processedEnd; - } - showGoals(result.output); - updateProcessedDecoration(editor ?? vscode.window.activeTextEditor); - clearErrorDecoration(editor ?? vscode.window.activeTextEditor); - if (editor) { - clearDiagnostics(editor.document); - } - } - } catch (err) { - outputChannel?.appendLine(`[proof] restart failed ${String(err)}`); - vscode.window.showErrorMessage(`EasyCrypt restart failed: ${String(err)}`); - } -} - -async function handleGoals(): Promise { - try { - outputChannel?.appendLine('[proof] goals'); - const editor = getEditorForCommand(); - if (!editor) { - vscode.window.showInformationMessage('EasyCrypt: no active EasyCrypt editor.'); - return; - } - const result = await requestProof('easycrypt/proof/goals', { - uri: editor.document.uri.toString() - }); - outputChannel?.appendLine(`[proof] goals ok uuid=${result.uuid} mode=${result.mode}`); - showGoals(result.output); - } catch (err) { - outputChannel?.appendLine(`[proof] goals failed ${String(err)}`); - vscode.window.showErrorMessage(`EasyCrypt goals failed: ${String(err)}`); - } -} - -function resolveServerCommand( - workspaceFolder: string | undefined, - cliPath: string -): string | undefined { - if (cliPath && cliPath.trim().length > 0) { - return cliPath; - } - - if (!workspaceFolder) { - return undefined; - } - - const exeCandidate = path.join(workspaceFolder, '_build', 'default', 'src', 'ec.exe'); - const unixCandidate = path.join(workspaceFolder, '_build', 'default', 'src', 'ec'); - if (fs.existsSync(exeCandidate)) { - return exeCandidate; - } - if (fs.existsSync(unixCandidate)) { - return unixCandidate; - } - - return undefined; -} - -function ensureLspArgs(args: string[]): string[] { - if (args.length > 0 && args[0] === 'lsp') { - return args; - } - return ['lsp', ...args]; -} - -function startClient(): void { - if (!clientOptions || !serverOptions) { - throw new Error('EasyCrypt LSP options are not configured.'); - } - outputChannel?.appendLine(`[lsp] spawn command=${lspCommand ?? ''} args=${lspArgs.join(' ')}`); - client = new LanguageClient('easycryptLsp', 'EasyCrypt LSP', serverOptions, clientOptions); - outputChannel?.appendLine('[lsp] starting client'); - clientReady = client.start(); - void clientReady.then( - () => outputChannel?.appendLine('[lsp] client ready'), - (err) => outputChannel?.appendLine(`[lsp] client start failed ${String(err)}`) - ); - void clientReady.then(() => client?.setTrace(traceLevel)); -} - -async function restartClient(): Promise { - if (!serverOptions || !clientOptions) { - vscode.window.showErrorMessage('EasyCrypt: LSP options are not configured.'); - return; - } - const current = client; - if (current) { - try { - await current.stop(); - } catch (err) { - vscode.window.showWarningMessage(`EasyCrypt: failed to stop LSP (${String(err)}).`); - } - } - startClient(); - outputChannel?.appendLine('[lsp] restarted client'); - vscode.window.showInformationMessage('EasyCrypt: LSP restarted.'); -} - -export function activate(context: vscode.ExtensionContext): void { - outputChannel = vscode.window.createOutputChannel('EasyCrypt'); - context.subscriptions.push(outputChannel); - queryStatusBarItem = vscode.window.createStatusBarItem(vscode.StatusBarAlignment.Left, 100); - queryStatusBarItem.text = '$(symbol-namespace) EasyCrypt'; - queryStatusBarItem.tooltip = 'EasyCrypt query commands'; - queryStatusBarItem.command = 'easycrypt.query.statusBar'; - context.subscriptions.push(queryStatusBarItem); - printStatusBarItem = vscode.window.createStatusBarItem(vscode.StatusBarAlignment.Left, 99); - printStatusBarItem.command = 'easycrypt.query.printCurrent'; - context.subscriptions.push(printStatusBarItem); - locateStatusBarItem = vscode.window.createStatusBarItem(vscode.StatusBarAlignment.Left, 99); - locateStatusBarItem.command = 'easycrypt.query.locateCurrent'; - context.subscriptions.push(locateStatusBarItem); - processedDecoration = vscode.window.createTextEditorDecorationType({ - backgroundColor: 'rgba(120, 140, 180, 0.18)', - isWholeLine: false, - rangeBehavior: vscode.DecorationRangeBehavior.ClosedClosed - }); - context.subscriptions.push(processedDecoration); - processingDecoration = vscode.window.createTextEditorDecorationType({ - backgroundColor: 'rgba(210, 170, 90, 0.28)', - isWholeLine: false - }); - context.subscriptions.push(processingDecoration); - - diagnostics = vscode.languages.createDiagnosticCollection('easycrypt'); - context.subscriptions.push(diagnostics); - - errorDecoration = undefined; - - const workspaceFolder = vscode.workspace.workspaceFolders?.[0]?.uri.fsPath; - const config = vscode.workspace.getConfiguration('easycrypt'); - const cliPath = config.get('cli.path') ?? ''; - const serverCommand = resolveServerCommand(workspaceFolder, cliPath) ?? 'easycrypt'; - const cliArgs = config.get('cli.args') ?? []; - const serverArgs = ensureLspArgs(cliArgs); - lspCommand = serverCommand; - lspArgs = serverArgs; - const traceSetting = config.get('trace.server') ?? 'off'; - traceLevel = - traceSetting === 'verbose' - ? Trace.Verbose - : traceSetting === 'messages' - ? Trace.Messages - : Trace.Off; - - outputChannel.appendLine(`[lsp] serverCommand=${serverCommand}`); - outputChannel.appendLine(`[lsp] cliPath=${cliPath || '(default)'}`); - outputChannel.appendLine(`[lsp] cliArgs=${cliArgs.join(' ')}`); - outputChannel.appendLine(`[lsp] serverArgs=${serverArgs.join(' ')}`); - outputChannel.appendLine(`[lsp] trace=${traceSetting}`); - outputChannel.appendLine( - `[lsp] logFile=${workspaceFolder ? path.join(workspaceFolder, '.easycrypt-lsp.log') : '(inherit)'}` - ); - outputChannel.show(true); - - if (!resolveServerCommand(workspaceFolder, cliPath)) { - vscode.window.showWarningMessage( - "EasyCrypt binary not found in the workspace. Using 'easycrypt' from PATH." - ); - } - - const lspEnv = { - ...process.env, - EASYCRYPT_LSP_LOG: workspaceFolder - ? path.join(workspaceFolder, '.easycrypt-lsp.log') - : process.env.EASYCRYPT_LSP_LOG - }; - const localServerOptions: ServerOptions = { - command: serverCommand, - args: serverArgs, - transport: TransportKind.stdio, - options: { env: lspEnv } - }; - - const localClientOptions: LanguageClientOptions = { - documentSelector: [{ language: 'easycrypt' }], - outputChannel, - traceOutputChannel: outputChannel - }; - - serverOptions = localServerOptions; - clientOptions = localClientOptions; - startClient(); - context.subscriptions.push( - new vscode.Disposable(() => { - outputChannel?.appendLine('[lsp] stopping client'); - void client?.stop(); - }) - ); - if (client) { - client.onDidChangeState((event) => { - outputChannel?.appendLine(`[lsp] state ${event.oldState} -> ${event.newState}`); - }); - } - - context.subscriptions.push( - vscode.commands.registerCommand('easycrypt.proof.step', handleStep), - vscode.commands.registerCommand('easycrypt.proof.back', handleBack), - vscode.commands.registerCommand('easycrypt.proof.restart', handleRestart), - vscode.commands.registerCommand('easycrypt.proof.jumpToCursor', handleSendRegion), - vscode.commands.registerCommand('easycrypt.proof.goals', handleGoals), - vscode.commands.registerCommand('easycrypt.query.print', handlePrintQuery), - vscode.commands.registerCommand('easycrypt.query.locate', handleLocateQuery), - vscode.commands.registerCommand('easycrypt.query.search', handleSearchQuery), - vscode.commands.registerCommand('easycrypt.query.statusBar', handleQueryStatusBar), - vscode.commands.registerCommand('easycrypt.query.printCurrent', handlePrintCurrentQuery), - vscode.commands.registerCommand('easycrypt.query.locateCurrent', handleLocateCurrentQuery), - vscode.commands.registerCommand('easycrypt.lsp.restart', restartClient) - ); - - context.subscriptions.push( - vscode.workspace.onDidCloseTextDocument((doc) => { - docStates.delete(doc.uri.toString()); - }) - ); - - context.subscriptions.push( - vscode.workspace.onDidChangeTextDocument(async (event) => { - if (suppressProcessedEdits || suppressProcessingEdits) { - return; - } - if (event.contentChanges.length === 0) { - return; - } - const doc = event.document; - if (doc.languageId !== 'easycrypt') { - return; - } - if (processingDocUri && processingDocUri === doc.uri.toString()) { - suppressProcessingEdits = true; - try { - await restoreProcessingSnapshot(doc); - } catch (err) { - outputChannel?.appendLine(`[proof] processing lock restore failed ${String(err)}`); - } finally { - suppressProcessingEdits = false; - } - return; - } - clearErrorDecoration(vscode.window.activeTextEditor); - clearDiagnostics(doc); - const state = getDocState(doc); - const limit = state.lastOffset; - const earliestStart = event.contentChanges.reduce((min, change) => { - const start = change.range ? doc.offsetAt(change.range.start) : 0; - return Math.min(min, start); - }, Number.POSITIVE_INFINITY); - if (!(earliestStart < limit)) { - return; - } - suppressProcessedEdits = true; - try { - try { - const result = await requestProof('easycrypt/proof/jumpTo', { - uri: doc.uri.toString(), - target: earliestStart - }); - state.lastOffset = result.processedEnd; - } catch (err) { - outputChannel?.appendLine(`[proof] auto-rewind failed ${String(err)}`); - vscode.window.showErrorMessage(`EasyCrypt auto-rewind failed: ${String(err)}`); - } - updateProcessedDecoration(vscode.window.activeTextEditor); - } finally { - suppressProcessedEdits = false; - } - return; - }) - ); - - const updateEditorState = (editor: vscode.TextEditor | undefined) => { - if (editor && editor.document.languageId === 'easycrypt') { - lastEasyCryptEditor = editor; - } - updateProcessedDecoration(editor); - refreshQueryStatusBar(editor); - clearErrorDecoration(editor); - if (editor) { - clearDiagnostics(editor.document); - } - }; - - updateEditorState(vscode.window.activeTextEditor); - - context.subscriptions.push( - vscode.window.onDidChangeTextEditorSelection((event) => { - refreshQueryStatusBar(event.textEditor); - }) - ); - - context.subscriptions.push( - vscode.window.onDidChangeActiveTextEditor((editor) => { - updateEditorState(editor); - }) - ); - -} - -export async function deactivate(): Promise { - if (client) { - await client.stop(); - } -} diff --git a/vscode/syntaxes/easycrypt.tmLanguage.json b/vscode/syntaxes/easycrypt.tmLanguage.json deleted file mode 100644 index af025d0dce..0000000000 --- a/vscode/syntaxes/easycrypt.tmLanguage.json +++ /dev/null @@ -1,101 +0,0 @@ -{ - "$schema": "https://raw.githubusercontent.com/martinring/tmlanguage/master/tmlanguage.json", - "name": "EasyCrypt", - "scopeName": "source.easycrypt", - "patterns": [ - { "include": "#comments" }, - { "include": "#strings" }, - { "include": "#keywords" }, - { "include": "#types" }, - { "include": "#numbers" } - ], - "repository": { - "comments": { - "patterns": [ - { - "name": "comment.block.easycrypt", - "begin": "\\(\\*", - "beginCaptures": { - "0": { "name": "punctuation.definition.comment.easycrypt" } - }, - "end": "\\*\\)", - "endCaptures": { - "0": { "name": "punctuation.definition.comment.easycrypt" } - }, - "patterns": [ - { "include": "#comments" } - ] - } - ] - }, - "strings": { - "patterns": [ - { - "name": "string.quoted.double.easycrypt", - "begin": "\"", - "beginCaptures": { - "0": { "name": "punctuation.definition.string.begin.easycrypt" } - }, - "end": "\"", - "endCaptures": { - "0": { "name": "punctuation.definition.string.end.easycrypt" } - }, - "patterns": [ - { - "name": "constant.character.escape.easycrypt", - "match": "\\\\." - } - ] - } - ] - }, - "keywords": { - "patterns": [ - { - "name": "keyword.other.easycrypt.bytac", - "match": "\\b(assumption|by|check|coq|done|edit|exact|fix|reflexivity|smt|solve)\\b" - }, - { - "name": "keyword.other.easycrypt.dangerous", - "match": "\\b(admit|admitted)\\b" - }, - { - "name": "keyword.control.easycrypt.global", - "match": "\\b(Pr|Self|Top|abbrev|abort|abstract|as|axiom|axiomatized|class|clone|const|declare|dump|end|exit|export|from|global|goal|hint|import|include|inductive|instance|lemma|local|locate|module|notation|of|op|pred|print|proof|prover|qed|realize|remove|rename|require|search|section|subtype|theory|timeout|type|why3|with)\\b" - }, - { - "name": "keyword.other.easycrypt.internal", - "match": "\\b(debug|fail|pragma|time|undo)\\b" - }, - { - "name": "keyword.operator.easycrypt.prog", - "match": "\\b(assert|async|ehoare|elif|else|equiv|exists|for|for|forall|fun|glob|hoare|if|in|is|islossless|let|match|match|phoare|proc|res|return|then|var|while)\\b" - }, - { - "name": "keyword.control.easycrypt.tactic", - "match": "\\b(algebra|alias|apply|auto|beta|byehoare|byequiv|byphoare|bypr|byupto|call|case|cbv|cfold|change|clear|congr|conseq|delta|eager|ecall|elim|eta|exfalso|exlim|fel|field|fieldeq|fission|fusion|gen|have|idassign|idtac|inline|interleave|iota|kill|left|logic|modpath|move|outline|pose|pr_bounded|progress|rcondf|rcondt|replace|rewrite|right|ring|ringeq|rnd|rndsem|rwnormal|seq|sim|simplify|skip|sp|split|splitwhile|subst|suff|swap|symmetry|transitivity|trivial|unroll|weakmem|wlog|wp|zeta)\\b" - }, - { - "name": "keyword.control.easycrypt.tactical", - "match": "\\b(do|expect|first|last|try)\\b" - } - ] - }, - "types": { - "patterns": [ - { - "name": "storage.type.easycrypt", - "match": "\\b(bool|int|real|unit)\\b" - } - ] - }, - "numbers": { - "patterns": [ - { - "name": "constant.numeric.easycrypt", - "match": "\\b\\d+(?:\\.\\d+)?\\b" - } - ] - } - } -} diff --git a/vscode/tsconfig.json b/vscode/tsconfig.json deleted file mode 100644 index 6da6eaa6cf..0000000000 --- a/vscode/tsconfig.json +++ /dev/null @@ -1,13 +0,0 @@ -{ - "compilerOptions": { - "target": "ES2020", - "module": "commonjs", - "lib": ["ES2020"], - "outDir": "out", - "rootDir": "src", - "sourceMap": true, - "strict": true, - "esModuleInterop": true - }, - "include": ["src"] -} From d0c06e1cb1cafb505d7e53e617df342daef4ac6c Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sun, 31 May 2026 08:55:47 +0200 Subject: [PATCH 053/145] Remove orphaned LSP helpers from ecIo (next_sentence_from, isfinal_token) These were sentence-parsing support for the now-removed LSP server and had no remaining users. Reverts src/ecIo.ml and src/ecIo.mli to origin/main. --- src/ecIo.ml | 47 +++++------------------------------------------ src/ecIo.mli | 1 - 2 files changed, 5 insertions(+), 43 deletions(-) diff --git a/src/ecIo.ml b/src/ecIo.ml index d6fd6f498f..016545d85c 100644 --- a/src/ecIo.ml +++ b/src/ecIo.ml @@ -96,15 +96,14 @@ let from_string data = let finalize (ecreader : ecreader) = Disposable.dispose ecreader -(* -------------------------------------------------------------------- *) -let isfinal_token = function - | EcParser.FINAL _ -> true - | _ -> false - (* -------------------------------------------------------------------- *) let lexer ?(checkpoint : _ I.checkpoint option) (ecreader : ecreader_r) = let lexbuf = ecreader.ecr_lexbuf in + let isfinal = function + | EcParser.FINAL _ -> true + | _ -> false in + if ecreader.ecr_atstart then ecreader.ecr_trim <- ecreader.ecr_lexbuf.Lexing.lex_curr_p.pos_cnum; @@ -135,7 +134,7 @@ let lexer ?(checkpoint : _ I.checkpoint option) (ecreader : ecreader_r) = ecreader.ecr_tokens <- prequeue @ queue; - if isfinal_token token then + if isfinal token then ecreader.ecr_atstart <- true else ecreader.ecr_atstart <- ecreader.ecr_atstart && ( @@ -178,42 +177,6 @@ let parse (ecreader : ecreader) : EcParsetree.prog = in parse (EcParser.Incremental.prog ecreader.ecr_lexbuf.lex_curr_p) -(* -------------------------------------------------------------------- *) -let next_sentence_from (text : string) (start : int) : (string * int * int) option = - let len = String.length text in - if start < 0 || start >= len then - None - else - let sub = String.sub text start (len - start) in - let reader = from_string sub in - let ecr = Disposable.get reader in - - let exception EOF in - - Fun.protect - ~finally:(fun () -> finalize reader) - (fun () -> - try - begin - let exception Done in - - try - while true do - match proj3_1 (lexer ecr) with - | EcParser.FINAL _ -> raise Done - | EcParser.EOF -> raise EOF - | _ -> () - done - with Done -> () - end; - - let p = ecr.ecr_lexbuf.Lexing.lex_curr_p.pos_cnum - 1 in - let s = String.sub sub 0 p in - - Some (s, start, start + p) - with - | EcLexer.LexicalError _ | EOF -> None) - (* -------------------------------------------------------------------- *) let xparse (ecreader : ecreader) : string * EcParsetree.prog = let ecr = Disposable.get ecreader in diff --git a/src/ecIo.mli b/src/ecIo.mli index f69a371b66..42d28ba740 100644 --- a/src/ecIo.mli +++ b/src/ecIo.mli @@ -13,7 +13,6 @@ val parse : ecreader -> EcParsetree.prog val parseall : ecreader -> EcParsetree.global list val drain : ecreader -> unit val lexbuf : ecreader -> Lexing.lexbuf -val next_sentence_from : string -> int -> (string * int * int) option (* -------------------------------------------------------------------- *) val lex_single_token : string -> EcParser.token option From eaad87e5391f8dd92d3b17fe421d37cfff39894d Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sun, 31 May 2026 09:00:21 +0200 Subject: [PATCH 054/145] Remove refold rigid-unification feature (tracked separately in PR #923) The 'rewrite /~' rigid-delta feature is in flight as open PR #923 ([refold]: allow rigid unification) and will be rebased onto main on its own. Drop it from this branch: - ecHiGoal.ml/.mli: reverted to origin/main (process_delta rigid logic) - ecParser.mly / ecParsetree.ml: RWDelta back to (rwoptions * pformula), dropping the rigid bool; circuit/bdep content in these files retained. --- src/ecHiGoal.ml | 42 +++++++++++++++++++----------------------- src/ecHiGoal.mli | 2 +- src/ecParser.mly | 4 ++-- src/ecParsetree.ml | 2 +- 4 files changed, 23 insertions(+), 27 deletions(-) diff --git a/src/ecHiGoal.ml b/src/ecHiGoal.ml index adea2cd933..c58de527f6 100644 --- a/src/ecHiGoal.ml +++ b/src/ecHiGoal.ml @@ -690,10 +690,9 @@ let process_rewrite1_core tc_error !!tc "context variable does not appear in the r-pattern" (* -------------------------------------------------------------------- *) -let process_delta ~und_delta ?(rigid = false) ?target ((s : rwside), o, p) tc = +let process_delta ~und_delta ?target ((s :rwside), o, p) tc = let env, hyps, concl = FApi.tc1_eflat tc in let o = norm_rwocc o in - let occmode = if rigid then Some om_rigid else None in let idtg, target = match target with @@ -761,7 +760,7 @@ let process_delta ~und_delta ?(rigid = false) ?target ((s : rwside), o, p) tc = match s with | `LtoR -> begin let matches = - try ignore (PT.pf_find_occurence ptenv ?occmode ~ptn:p target); true + try ignore (PT.pf_find_occurence ptenv ~ptn:p target); true with PT.FindOccFailure _ -> false in @@ -822,26 +821,23 @@ let process_delta ~und_delta ?(rigid = false) ?target ((s : rwside), o, p) tc = with EcEnv.NotReducible -> fp in - begin - match PT.pf_find_occurence ?occmode ptenv ~ptn:fp target with - | (_, occmode) -> - let p = concretize_form ptenv p in - let fp = concretize_form ptenv fp in - let cpos = - try - FPosition.select_form - ?xconv:(if rigid then Some `AlphaEq else None) - ?keyed:(if rigid then Some occmode.k_keyed else None) - hyps o fp target - with InvalidOccurence -> - tc_error !!tc "invalid occurences selector" in + let matches = + try ignore (PT.pf_find_occurence ptenv ~ptn:fp target); true + with PT.FindOccFailure _ -> false + in - let target = FPosition.map cpos (fun _ -> p) target in - t_change ~ri ?target:idtg target tc + if matches then begin + let p = concretize_form ptenv p in + let fp = concretize_form ptenv fp in + let cpos = + try FPosition.select_form hyps o fp target + with InvalidOccurence -> + tc_error !!tc "invalid occurences selector" + in - | exception (PT.FindOccFailure _) -> - t_id tc - end + let target = FPosition.map cpos (fun _ -> p) target in + t_change ~ri ?target:idtg target tc + end else t_id tc (* -------------------------------------------------------------------- *) let process_rewrite1_r ttenv ?target ri tc = @@ -864,12 +860,12 @@ let process_rewrite1_r ttenv ?target ri tc = let target = target |> omap (fst -| ((LDecl.hyp_by_name^~ hyps) -| unloc)) in t_simplify_lg ?target ~delta:`IfApplied (ttenv, logic) tc - | RWDelta (rigid, rwopt, p) -> begin + | RWDelta (rwopt, p) -> begin if Option.is_some rwopt.match_ then tc_error !!tc "cannot use pattern selection in delta-rewrite rules"; let do1 tc = - process_delta ~und_delta ~rigid ?target (rwopt.side, rwopt.occurrence, p) tc in + process_delta ~und_delta ?target (rwopt.side, rwopt.occurrence, p) tc in match rwopt.repeat with | None -> do1 tc diff --git a/src/ecHiGoal.mli b/src/ecHiGoal.mli index 85d34e8cb8..78f61f3b00 100644 --- a/src/ecHiGoal.mli +++ b/src/ecHiGoal.mli @@ -80,7 +80,7 @@ val process_clear : clear_info -> backward val process_smt : ?loc:EcLocation.t -> ttenv -> pprover_infos option -> backward val process_coq : loc:EcLocation.t -> name:string -> ttenv -> EcProvers.coq_mode option -> pprover_infos -> backward val process_apply : implicits:bool -> apply_t * prevert option -> backward -val process_delta : und_delta:bool -> ?rigid:bool -> ?target:psymbol -> (rwside * rwocc * pformula) -> backward +val process_delta : und_delta:bool -> ?target:psymbol -> (rwside * rwocc * pformula) -> backward val process_rewrite : ttenv -> ?target:psymbol -> rwarg list -> backward val process_subst : pformula list -> backward val process_cut : ?mode:cutmode -> engine -> ttenv -> cut_t -> backward diff --git a/src/ecParser.mly b/src/ecParser.mly index 0a9c8c4505..906eafeda1 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -2422,8 +2422,8 @@ rwarg1: | side=rwside repeat=rwrepeat? occurrence=rwocc? match_=bracket(rwmatch)? fp=rwpterms { RWRw ({ side; repeat; occurrence; match_ }, fp) } -| side=rwside repeat=rwrepeat? occurrence=rwocc? SLASH rigid=iboption(TILD) fp=sform_h %prec prec_tactic - { RWDelta (rigid, { side; repeat; occurrence; match_ = None }, fp); } +| side=rwside repeat=rwrepeat? occurrence=rwocc? SLASH fp=sform_h %prec prec_tactic + { RWDelta ({ side; repeat; occurrence; match_ = None }, fp); } | PR s=bracket(rwpr_arg) { RWPr s } diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 68f71480e3..67cb42e933 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -966,7 +966,7 @@ type rwarg = (tfocus located) option * rwarg1 located and rwarg1 = | RWSimpl of [`Default | `Variant] - | RWDelta of (bool * rwoptions * pformula) + | RWDelta of (rwoptions * pformula) | RWRw of (rwoptions * (rwside * ppterm) list) | RWPr of (psymbol * pformula option) | RWDone of [`Default | `Variant] option From 6cb868de47b4b6ca634db35b6ba4e9eed445e759 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sun, 31 May 2026 09:01:24 +0200 Subject: [PATCH 055/145] Restore assets/latex/eclistings.sty (sync with origin/main) This LaTeX listings style file was dropped on the branch (incidentally, via a merge); origin/main keeps it. Restore it verbatim. --- assets/latex/eclistings.sty | 155 ++++++++++++++++++++++++++++++++++++ 1 file changed, 155 insertions(+) create mode 100644 assets/latex/eclistings.sty diff --git a/assets/latex/eclistings.sty b/assets/latex/eclistings.sty new file mode 100644 index 0000000000..7b5c15d681 --- /dev/null +++ b/assets/latex/eclistings.sty @@ -0,0 +1,155 @@ +\NeedsTeXFormat{LaTeX2e} +\ProvidesPackage{eclistings}[2026/04/07 EasyCrypt listings] + +\RequirePackage{listings} +\RequirePackage{xcolor} +\RequirePackage{xparse} + +% EasyCrypt % Language +\lstdefinelanguage{easycrypt}{% + sensitive=true, % Case sensitive keywords + % Keywords: Global and programming language + morekeywords=[1]% + { + Pr, Self, Top, abbrev, abort, abstract, as, axiom, axiomatized, clone, const, + declare, dump, end, exception, exit, export, from, global, goal, hint, import, + include, inductive, instance, lemma, local, locate, module, notation, of, op, + pred, print, proof, prover, qed, realize, remove, rename, require, search, + section, subtype, theory, timeout, type, why3, with, + async, ehoare, elif, else, equiv, exists, for, forall, fun, glob, hoare, if, + in, is, islossless, let, match, phoare, proc, raise, res, return, then, var, + while + }, + % Keywords: Regular (i.e., non-closing) tactics + morekeywords=[2]% + { + algebra, alias, apply, auto, beta, byehoare, byequiv, byphoare, bypr, byupto, + call, case, cbv, cfold, change, clear, congr, conseq, delta, eager, ecall, + elim, eta, exfalso, exlim, fel, field, fieldeq, fission, fusion, gen, have, + idassign, idtac, inline, interleave, iota, kill, left, logic, modpath, move, + outline, pose, pr_bounded, progress, rcondf, rcondt, replace, rewrite, right, + ring, ringeq, rnd, rndsem, rwnormal, seq, sim, simplify, skip, sp, split, + splitwhile, subst, suff, swap, symmetry, transitivity, trivial, unroll, + weakmem, wlog, wp, zeta + }, + % Keywords: Closing/byclose tactics and dangerous commands + morekeywords=[3]% + { + admit, admitted, + assumption, by, check, coq, done, edit, exact, fix, reflexivity, smt, solve + }, + % Keywords: Tacticals and internal + morekeywords=[4]% + { + do, expect, first, last, try, + debug, fail, pragma, time, undo + }, + comment=[n]{(*}{*)}, % Multi-line, nested comments delimited by (* and *) + string=[d]{"}, % Strings delimited by " and ", non-escapable +} + +% Style (base/default) +\lstdefinestyle{easycrypt-base}{% + % Frame + captionpos=t, % Position caption at top (mirroring what's typical for algorithms) + frame=tb, % Top and bottom rules + framesep=\smallskipamount, % Small skip between frame and listing content + % Float placement + floatplacement=tbhp, + % Character printing and placement + upquote=true, % Print backtick and single quote as is + columns=[c]fixed, % Monospace characters, centered in their box + keepspaces=true, % Don't drop spaces for column alignment + tabsize=2, % Tabstops every 2 spaces + mathescape=false, % Don't allow escaping to LaTeX with $ + showstringspaces=false, % Don't print characters for spaces + % Line numbers + numbers=none, % No line numbers + % Basic style + basicstyle={\normalsize\ttfamily}, + % Style for (non-keyword) identifiers + identifierstyle={}, +} + +% Define default colors based on availability of colorblind colors +\@ifpackageloaded{colorblind}{ + \lstdefinestyle{easycrypt-default}{% + style=easycrypt-base, + % Styles for different keyword classes + keywordstyle=[1]{\color{T-Q-B6}},% + keywordstyle=[2]{\color{T-Q-B1}},% + keywordstyle=[3]{\color{T-Q-B5}},% + keywordstyle=[4]{\color{T-Q-B4}},% + % Styles for comments and strings + commentstyle={\itshape\color{T-Q-B0}},% + stringstyle={\color{T-Q-B3}}, + % Style of line numbers (in case numbers is overwritten to true) + numberstyle={\small\color{T-Q-B0}}, + } +}{% + \lstdefinestyle{easycrypt-default}{% + style=easycrypt-base, + % Styles for different keyword classes + keywordstyle=[1]{\color{violet}},% + keywordstyle=[2]{\color{blue}},% + keywordstyle=[3]{\color{red}},% + keywordstyle=[4]{\color{olive}},% + % Styles for comments and strings + commentstyle={\itshape\color{gray}},% + stringstyle={\color{green}}, + % Style of line numbers (in case numbers is overwritten to true) + numberstyle={\small\color{gray}}, + } +} + +% Style for drafting/debugging (explicit spaces/tabs) +\lstdefinestyle{easycrypt-draft}{% + style=easycrypt-default, + showspaces=true, + showtabs=true, + showstringspaces=true, +} + +% Style without top/bottom frame rules +\lstdefinestyle{easycrypt-plain}{% + style=easycrypt-default, + frame=none, + framesep=0pt, + basicstyle={\small\ttfamily}, + aboveskip=0.3\baselineskip, + belowskip=0.3\baselineskip, + columns=fullflexible +} + +% Environments % Default, non-floating environment % Meant to be used inside +%other (potentially floating) environment % that takes care of the caption and +%surrounding spacing +\lstnewenvironment{eclst}[1][]{% + \lstset{% + language=easycrypt,% + style=easycrypt-default,% + aboveskip=\smallskipamount,% Equal to framesep of style if top rule, else 0pt + belowskip=\smallskipamount,% Equal to framesep of style if bottom rule, else 0pt + abovecaptionskip=0pt,% + belowcaptionskip=0pt,% + #1% + }% +}{} + +% Inline +\NewDocumentCommand{\ecinl}{O{easycrypt-default} m O{}}{% + \lstinline[% + language=easycrypt,% + style=#1,% + breaklines,% + breakindent=0pt,% + columns=fullflexible,% + #3% + ]{#2}% +} + +\NewDocumentCommand{\ecinlfoot}{O{easycrypt-default} m O{}}{% + \ecinl[#1]{#2}[basicstyle={\footnotesize\ttfamily},#3]% +} + +\endinput \ No newline at end of file From 47c9fba85b91e6e238bc0154a96361eff4656f42 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sun, 31 May 2026 09:25:07 +0200 Subject: [PATCH 056/145] Cloning: support inlining a type via clone-inline (clinline) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Adds a 'tyd_clinline' flag to 'tydecl', the type-level analogue of the existing 'op_clinline'. A type cloned with an inline override ('<-' or '<=') is tagged clinline and retains its body; when it is later used as the target of a 'theory ... <=' override, the consumer receives that body rather than a reference to the type (the two remain convertible — the difference shows only when printing). The replay 'ByPath' branch now consults 'reftyd.tyd_clinline' to choose body-vs-reference, mirroring the operator side. All three type override paths (BySyntax / ByPath / Direct) set tyd_clinline = (mode <> `Alias), matching the operator side exactly. Threads the field through ecDecl, ecHiInductive, ecScope, ecSection, ecSubst. Adds tests/clone-type-inline.ec (expect-based). --- src/ecDecl.ml | 18 ++++++++++-------- src/ecDecl.mli | 9 +++++---- src/ecHiInductive.ml | 9 +++++---- src/ecScope.ml | 11 ++++++----- src/ecSection.ml | 5 +++-- src/ecSubst.ml | 9 +++++---- src/ecTheoryReplay.ml | 33 ++++++++++++++++++++++----------- tests/clone-type-inline.ec | 38 ++++++++++++++++++++++++++++++++++++++ 8 files changed, 94 insertions(+), 38 deletions(-) create mode 100644 tests/clone-type-inline.ec diff --git a/src/ecDecl.ml b/src/ecDecl.ml index 42af1b670c..70f3ec7e0b 100644 --- a/src/ecDecl.ml +++ b/src/ecDecl.ml @@ -35,10 +35,11 @@ type ty_body = type tydecl = { - tyd_params : ty_params; - tyd_type : ty_body; - tyd_loca : locality; - tyd_subtype : (EcTypes.ty * EcCoreFol.form) option; + tyd_params : ty_params; + tyd_type : ty_body; + tyd_loca : locality; + tyd_clinline : bool; + tyd_subtype : (EcTypes.ty * EcCoreFol.form) option; } let tydecl_as_concrete (td : tydecl) = @@ -66,10 +67,11 @@ let abs_tydecl ?(params = `Int 0) lc = (EcUid.NameGen.bulk ~fmt n) in - { tyd_params = params; - tyd_type = Abstract; - tyd_loca = lc; - tyd_subtype = None; } + { tyd_params = params; + tyd_type = Abstract; + tyd_loca = lc; + tyd_clinline = false; + tyd_subtype = None; } (* -------------------------------------------------------------------- *) let ty_instantiate (params : ty_params) (args : ty list) (ty : ty) = diff --git a/src/ecDecl.mli b/src/ecDecl.mli index b121a50a67..f67d497e7d 100644 --- a/src/ecDecl.mli +++ b/src/ecDecl.mli @@ -30,9 +30,10 @@ type ty_body = type tydecl = { - tyd_params : ty_params; - tyd_type : ty_body; - tyd_loca : locality; + tyd_params : ty_params; + tyd_type : ty_body; + tyd_loca : locality; + tyd_clinline : bool; (* For [subtype]-declared types: the carrier and the predicate. The declared type itself stays [tyd_type = Abstract], because a subtype is semantically a fresh abstract type — but its dependency @@ -41,7 +42,7 @@ type tydecl = { carrier+predicate fv into the type's fv when this field is set, so a subtype declared inside [section. declare type c.] gets the section's tparams added at close, just like type aliases do. *) - tyd_subtype : (EcTypes.ty * EcCoreFol.form) option; + tyd_subtype : (EcTypes.ty * EcCoreFol.form) option; } val tydecl_as_concrete : tydecl -> EcTypes.ty option diff --git a/src/ecHiInductive.ml b/src/ecHiInductive.ml index aa05ac3f38..4d59c0f291 100644 --- a/src/ecHiInductive.ml +++ b/src/ecHiInductive.ml @@ -83,10 +83,11 @@ let trans_datatype (env : EcEnv.env) (name : ptydname) (dt : pdatatype) = let tpath = EcPath.pqname (EcEnv.root env) (unloc name) in let env0 = let myself = { - tyd_params = EcUnify.UniEnv.tparams ue; - tyd_type = Abstract; - tyd_loca = lc; - tyd_subtype = None; + tyd_params = EcUnify.UniEnv.tparams ue; + tyd_type = Abstract; + tyd_loca = lc; + tyd_clinline = false; + tyd_subtype = None; } in EcEnv.Ty.bind (unloc name) myself env in diff --git a/src/ecScope.ml b/src/ecScope.ml index c7cc2fbe6b..412363899e 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -2297,7 +2297,7 @@ module Ty = struct in bind scope (unloc name, - { tyd_params; tyd_type; tyd_loca; tyd_subtype = None; }) + { tyd_params; tyd_type; tyd_loca; tyd_clinline = false; tyd_subtype = None; }) (* ------------------------------------------------------------------ *) let add_subtype (scope : scope) ({ pl_desc = subtype } : psubtype located) = @@ -2326,10 +2326,11 @@ module Ty = struct let scope = let decl = EcDecl.{ - tyd_params = []; - tyd_type = Abstract; - tyd_loca = `Global; - tyd_subtype = Some (carrier, pred); + tyd_params = []; + tyd_type = Abstract; + tyd_loca = `Global; + tyd_clinline = false; + tyd_subtype = Some (carrier, pred); } in bind scope (unloc subtype.pst_name, decl) in let evclone = diff --git a/src/ecSection.ml b/src/ecSection.ml index 901597418c..bf98fdd8cb 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -870,8 +870,9 @@ let generalize_tydecl to_gen prefix (name, tydecl) = let to_gen = { to_gen with tg_subst} in let tydecl = { tyd_params; tyd_type; - tyd_loca = `Global; - tyd_subtype = tydecl.tyd_subtype; } in + tyd_loca = `Global; + tyd_clinline = tydecl.tyd_clinline; + tyd_subtype = tydecl.tyd_subtype; } in to_gen, Some (Th_type (name, tydecl)) | `Declare -> diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 8bae12c68e..2faa406794 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -873,10 +873,11 @@ let subst_tydecl (s : subst) (tyd : tydecl) = (fun (carrier, pred) -> (subst_ty s carrier, subst_form s pred)) tyd.tyd_subtype in - { tyd_params = tparams; - tyd_type = body; - tyd_loca = tyd.tyd_loca; - tyd_subtype = subtype; } + { tyd_params = tparams; + tyd_type = body; + tyd_loca = tyd.tyd_loca; + tyd_clinline = tyd.tyd_clinline; + tyd_subtype = subtype; } (* -------------------------------------------------------------------- *) let rec subst_op_kind (s : subst) (kind : operator_kind) = diff --git a/src/ecTheoryReplay.ml b/src/ecTheoryReplay.ml index 8982a34932..234a56d3a5 100644 --- a/src/ecTheoryReplay.ml +++ b/src/ecTheoryReplay.ml @@ -429,19 +429,29 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd let ue = EcUnify.UniEnv.create (Some nargs) in let ntyd = EcTyping.transty EcTyping.tp_tydecl env ue ntyd in let decl = - { tyd_params = nargs; - tyd_type = Concrete ntyd; - tyd_loca = otyd.tyd_loca; - tyd_subtype = None; } + { tyd_params = nargs; + tyd_type = Concrete ntyd; + tyd_loca = otyd.tyd_loca; + tyd_clinline = (mode <> `Alias); + tyd_subtype = None; } in (decl, ntyd) | `ByPath p -> begin match EcEnv.Ty.by_path_opt p env with | Some reftyd -> - let tyargs = List.map tvar reftyd.tyd_params in - let body = tconstr p tyargs in - let decl = { reftyd with tyd_type = Concrete body; } in + let body = + if reftyd.tyd_clinline then + (match reftyd.tyd_type with + | Concrete body -> body + | _ -> assert false) + else + let tyargs = List.map tvar reftyd.tyd_params in + tconstr p tyargs in + let decl = + { reftyd with + tyd_type = Concrete body; + tyd_clinline = (mode <> `Alias); } in (decl, body) | _ -> assert false @@ -450,10 +460,11 @@ let rec replay_tyd (ove : _ ovrenv) (subst, ops, proofs, scope) (import, x, otyd | `Direct ty -> begin assert (List.is_empty otyd.tyd_params); let decl = - { tyd_params = []; - tyd_type = Concrete ty; - tyd_loca = otyd.tyd_loca; - tyd_subtype = None; } + { tyd_params = []; + tyd_type = Concrete ty; + tyd_loca = otyd.tyd_loca; + tyd_clinline = (mode <> `Alias); + tyd_subtype = None; } in (decl, ty) end diff --git a/tests/clone-type-inline.ec b/tests/clone-type-inline.ec new file mode 100644 index 0000000000..a814e36d4c --- /dev/null +++ b/tests/clone-type-inline.ec @@ -0,0 +1,38 @@ +(* clinline (clone-inline) for types. + + A type cloned with the inline-keep override `<=` carries its body and + is tagged [tyd_clinline]. When such a type is later used as the target + of a `theory ... <=` override, the consumer receives the *body* of the + type rather than a reference to it. The two stay convertible; the + difference is only visible when printing. + + Contrast (checked below with `expect ... by print`): + - K.t cloned with `type t <= int` (clinline) -> consumer prints `int` + - L.t cloned with `type t = int` (plain alias) -> consumer prints `L.t` +*) + +require import AllCore. + +abstract theory BV. + type t. +end BV. + +(* A theory with an abstract subtheory [P] and a use of [P.t]. *) +abstract theory Use. + clone import BV as P. + op probe : P.t. +end Use. + +(* Two instances of BV: one clinline (<=), one a plain alias (=). *) +clone BV as K with type t <= int. (* K.t is clinline, body = int *) +clone BV as L with type t = int. (* L.t is a plain alias *) + +(* Override Use's subtheory P, once by each, via a `theory <=` override. *) +clone import Use as UK with theory P <= K. +clone import Use as UL with theory P <= L. + +(* UK.P.t receives K.t's *body* (K.t is clinline): prints `int`. *) +expect "type t = int." by print type UK.P.t. + +(* UL.P.t keeps the reference to L.t (L.t is a plain alias): prints `L.t`. *) +expect "type t = L.t." by print type UL.P.t. From 5b30fd4f171f4b471c503f83c185b156c21f0a5c Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sun, 31 May 2026 11:29:47 +0200 Subject: [PATCH 057/145] Revert flake.nix/flake.lock to origin/main (unrelated to circuit PR) The branch's flake changes are unrelated dev-environment churn: prover version bumps (z3, cvc5, alt-ergo, nixpkgs, ocaml), personal dev shells (emacs/proof-general, difftastic), and build-override patches. None of it concerns the circuit/bdep feature (bitwuzla is pulled via opam in dune-project, not the flake). Restore both files to match main. --- flake.lock | 146 ++++++++++++++--------------------------------------- flake.nix | 112 +++++++--------------------------------- 2 files changed, 58 insertions(+), 200 deletions(-) diff --git a/flake.lock b/flake.lock index 0ef29822ea..d66af42062 100644 --- a/flake.lock +++ b/flake.lock @@ -1,32 +1,13 @@ { "nodes": { - "emacs-overlay": { - "inputs": { - "nixpkgs": "nixpkgs", - "nixpkgs-stable": "nixpkgs-stable" - }, - "locked": { - "lastModified": 1757668180, - "narHash": "sha256-pqxwsvg8cVOY4bgEy5PUsWLVGDbgYFDnGP20bdWhjiM=", - "owner": "nix-community", - "repo": "emacs-overlay", - "rev": "b21511280c6e1ea516e551fc5e7bb27372f6c8c3", - "type": "github" - }, - "original": { - "owner": "nix-community", - "repo": "emacs-overlay", - "type": "github" - } - }, "flake-compat": { "flake": false, "locked": { - "lastModified": 1747046372, - "narHash": "sha256-CIVLLkVgvHYbgI2UpXvIIBJ12HWgX+fjA8Xf8PUmqCY=", + "lastModified": 1696426674, + "narHash": "sha256-kvjfFW7WAETZlt09AgDn1MrtKzP7t90Vf7vypd3OL1U=", "owner": "edolstra", "repo": "flake-compat", - "rev": "9100a0f413b0c601e0533d1d94ffd501ce2e7885", + "rev": "0f9255e01c2351cc7d116c072cb317785dd33b33", "type": "github" }, "original": { @@ -58,11 +39,11 @@ "systems": "systems_2" }, "locked": { - "lastModified": 1731533236, - "narHash": "sha256-l0KFg5HjrsfsO/JpG+r7fRrqm12kzFHyUHqHCVpMMbI=", + "lastModified": 1726560853, + "narHash": "sha256-X6rJYSESBVr3hBoH0WbKE5KvhPU5bloyZ2L4K60/fPQ=", "owner": "numtide", "repo": "flake-utils", - "rev": "11707dc2f618dd54ca8739b309ec4fc024de578b", + "rev": "c1dfcf08411b08f6b8615f7d8971a2bfa81d5e8a", "type": "github" }, "original": { @@ -89,43 +70,11 @@ }, "nixpkgs": { "locked": { - "lastModified": 1757487488, - "narHash": "sha256-zwE/e7CuPJUWKdvvTCB7iunV4E/+G0lKfv4kk/5Izdg=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "ab0f3607a6c7486ea22229b92ed2d355f1482ee0", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixos-unstable", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs-stable": { - "locked": { - "lastModified": 1751274312, - "narHash": "sha256-/bVBlRpECLVzjV19t5KMdMFWSwKLtb5RyXdjz3LJT+g=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "50ab793786d9de88ee30ec4e4c24fb4236fc2674", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixos-24.11", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs_2": { - "locked": { - "lastModified": 1751792365, - "narHash": "sha256-J1kI6oAj25IG4EdVlg2hQz8NZTBNYvIS0l4wpr9KcUo=", + "lastModified": 1730785428, + "narHash": "sha256-Zwl8YgTVJTEum+L+0zVAWvXAGbWAuXHax3KzuejaDyo=", "owner": "nixos", "repo": "nixpkgs", - "rev": "1fd8bada0b6117e6c7eb54aad5813023eed37ccb", + "rev": "4aa36568d413aca0ea84a1684d2d46f55dbabad7", "type": "github" }, "original": { @@ -140,17 +89,17 @@ "flake-compat": "flake-compat", "flake-utils": "flake-utils_2", "mirage-opam-overlays": "mirage-opam-overlays", - "nixpkgs": "nixpkgs_2", + "nixpkgs": "nixpkgs", "opam-overlays": "opam-overlays", "opam-repository": "opam-repository", "opam2json": "opam2json" }, "locked": { - "lastModified": 1756988401, - "narHash": "sha256-S+zc1RYWZBGKnbrEWbyJ6fGt8ft/9d4BzpigSN2PpqE=", + "lastModified": 1736955560, + "narHash": "sha256-9I42xwKXH7h+jQGJQ8t797j/mWylIItIljRLm44CHS8=", "owner": "tweag", "repo": "opam-nix", - "rev": "0c9c0e0c058dfb8de56adff612f2c776530f7f1e", + "rev": "5f760f445d6693eb086327fa7d7ae8e43c906718", "type": "github" }, "original": { @@ -162,11 +111,11 @@ "opam-overlays": { "flake": false, "locked": { - "lastModified": 1741116009, - "narHash": "sha256-Z0PIW82fHJFvAv/JYpAffnp2DaOjLhsPutqyIrORZd0=", + "lastModified": 1726822209, + "narHash": "sha256-bwM18ydNT9fYq91xfn4gmS21q322NYrKwfq0ldG9GYw=", "owner": "dune-universe", "repo": "opam-overlays", - "rev": "e031bb64e33bf93be963e9a38b28962e6e14381f", + "rev": "f2bec38beca4aea9e481f2fd3ee319c519124649", "type": "github" }, "original": { @@ -178,11 +127,11 @@ "opam-repository": { "flake": false, "locked": { - "lastModified": 1756946712, - "narHash": "sha256-jo24cfjG/Yf1yPppKtL5ogjw6YBCMaMNsfkktRUm018=", + "lastModified": 1736935757, + "narHash": "sha256-LNkGSkZJXJmxpUd+luDUIIV/1B5MZIBMTB1qZqypa4o=", "owner": "ocaml", "repo": "opam-repository", - "rev": "e28312d8e0d10f256ec9998ff7e868cb6e010778", + "rev": "a8b00ead922e2049581ab16994586ed4ddbdb784", "type": "github" }, "original": { @@ -196,15 +145,14 @@ "nixpkgs": [ "opam-nix", "nixpkgs" - ], - "systems": "systems_3" + ] }, "locked": { - "lastModified": 1749457947, - "narHash": "sha256-+QVm+HOYikF3wUhqSIV8qJbE/feSG+p48fgxIosbHS0=", + "lastModified": 1671540003, + "narHash": "sha256-5pXfbUfpVABtKbii6aaI2EdAZTjHJ2QntEf0QD2O5AM=", "owner": "tweag", "repo": "opam2json", - "rev": "0ecd66fc2bfb25d910522c990dd36412259eac1f", + "rev": "819d291ea95e271b0e6027679de6abb4d4f7f680", "type": "github" }, "original": { @@ -230,43 +178,42 @@ "type": "github" } }, - "prover_cvc5_1_3_0": { + "prover_cvc5_1_0_9": { "flake": false, "locked": { - "lastModified": 1750292852, - "narHash": "sha256-w8rIGPG9BTEPV9HG2U40A4DYYnC6HaWbzqDKCRhaT00=", + "lastModified": 1702998934, + "narHash": "sha256-AwUQHFftn51Xt6HtmDsWAdkOS8i64r2FhaHu31KYwZA=", "owner": "cvc5", "repo": "cvc5", - "rev": "02c4e43d191f86b67a8a6d615544630a8df0f18e", + "rev": "8fca72aebcb5293434c3207dca081a845ff8d6fe", "type": "github" }, "original": { "owner": "cvc5", - "ref": "cvc5-1.3.0", + "ref": "cvc5-1.0.9", "repo": "cvc5", "type": "github" } }, - "prover_z3_4_14_1": { + "prover_z3_4_12_6": { "flake": false, "locked": { - "lastModified": 1741647008, - "narHash": "sha256-pTsDzf6Frk4mYAgF81wlR5Kb1x56joFggO5Fa3G2s70=", + "lastModified": 1708814107, + "narHash": "sha256-X4wfPWVSswENV0zXJp/5u9SQwGJWocLKJ/CNv57Bt+E=", "owner": "z3prover", "repo": "z3", - "rev": "3c0d786e6e86b6a10cbc14703c3f863c568b85dd", + "rev": "fa2c0e027894a8d55d2b841e27cbeecc99692a3f", "type": "github" }, "original": { "owner": "z3prover", - "ref": "z3-4.14.1", + "ref": "z3-4.12.6", "repo": "z3", "type": "github" } }, "root": { "inputs": { - "emacs-overlay": "emacs-overlay", "flake-utils": "flake-utils", "nixpkgs": [ "opam-nix", @@ -274,23 +221,23 @@ ], "opam-nix": "opam-nix", "prover_cvc4_1_8": "prover_cvc4_1_8", - "prover_cvc5_1_3_0": "prover_cvc5_1_3_0", - "prover_z3_4_14_1": "prover_z3_4_14_1", + "prover_cvc5_1_0_9": "prover_cvc5_1_0_9", + "prover_z3_4_12_6": "prover_z3_4_12_6", "stable": "stable" } }, "stable": { "locked": { - "lastModified": 1751290243, - "narHash": "sha256-kNf+obkpJZWar7HZymXZbW+Rlk3HTEIMlpc6FCNz0Ds=", + "lastModified": 1717179513, + "narHash": "sha256-vboIEwIQojofItm2xGCdZCzW96U85l9nDW3ifMuAIdM=", "owner": "nixos", "repo": "nixpkgs", - "rev": "5ab036a8d97cb9476fbe81b09076e6e91d15e1b6", + "rev": "63dacb46bf939521bdc93981b4cbb7ecb58427a0", "type": "github" }, "original": { "owner": "nixos", - "ref": "release-24.11", + "ref": "24.05", "repo": "nixpkgs", "type": "github" } @@ -324,21 +271,6 @@ "repo": "default", "type": "github" } - }, - "systems_3": { - "locked": { - "lastModified": 1681028828, - "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", - "owner": "nix-systems", - "repo": "default", - "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", - "type": "github" - }, - "original": { - "owner": "nix-systems", - "repo": "default", - "type": "github" - } } }, "root": "root", diff --git a/flake.nix b/flake.nix index d43245edca..77d38a85ff 100644 --- a/flake.nix +++ b/flake.nix @@ -4,23 +4,22 @@ flake-utils.url = "github:numtide/flake-utils"; - # nixpkgs.url = "github:nixos/nixpkgs/release-24.11"; - stable.url = "github:nixos/nixpkgs/release-24.11"; + nixpkgs.url = "github:nixos/nixpkgs/24.05"; + stable.url = "github:nixos/nixpkgs/24.05"; nixpkgs.follows = "opam-nix/nixpkgs"; - emacs-overlay.url = "github:nix-community/emacs-overlay"; prover_cvc4_1_8 = { url = "github:CVC4/CVC4-archived/1.8"; flake = false; }; - prover_cvc5_1_3_0 = { - url = "github:cvc5/cvc5/cvc5-1.3.0"; + prover_cvc5_1_0_9 = { + url = "github:cvc5/cvc5/cvc5-1.0.9"; flake = false; }; - prover_z3_4_14_1 = { - url = "github:z3prover/z3/z3-4.14.1"; + prover_z3_4_12_6 = { + url = "github:z3prover/z3/z3-4.12.6"; flake = false; }; }; @@ -41,7 +40,7 @@ }; query = devPackagesQuery // { - ocaml-base-compiler = "4.14.1"; + ocaml-base-compiler = "4.14.2"; }; scope = on.buildOpamProject' { } ./. query; @@ -55,23 +54,9 @@ ''; doNixSupport = false; }); - conf-zlib = prev.conf-zlib.overrideAttrs (finalAttrs: prevAttrs: rec { - nativeBuildInputs = prevAttrs.nativeBuildInputs - ++ (with pkgs; [ pkg-config ]); + conf-pkg-config = prev.conf-pkg-config.overrideAttrs (oa: { + nativeBuildInputs = oa.nativeBuildInputs ++ [pkgs.pkg-config]; }); - conf-git = prev.conf-git.overrideAttrs (finalAttrs: prevAttrs: rec { - nativeBuildInputs = prevAttrs.nativeBuildInputs - ++ (with pkgs; [ git ]); - buildInputs = prevAttrs.buildInputs - ++ (with pkgs; [ git ]); - }); - alt-ergo = prev.alt-ergo.overrideAttrs (finalAttrs: prevAttrs: rec { - nativeBuildInputs = prevAttrs.nativeBuildInputs - ++ (with pkgs; [ darwin.sigtool ]); - }); - frama-c = prev.frama-c.overrideAttrs (finalAttrs: prevAttrs: rec { - configureFlags = (prevAttrs.configureFlags or []) ++ ["--prefix=${prev.frama-c}/lib"]; - }); }; scope' = scope.overrideScope overlay; @@ -93,51 +78,20 @@ src = inputs."${"prover_" + pkg + "_" + builtins.replaceStrings ["."] ["_"] version}"; }); - mkAltErgo = version: (on.queryToScope { } (query // { alt-ergo = version; })).alt-ergo; - - devTools = - (let - overlays = [ (import inputs.emacs-overlay) ]; - pkgs = import nixpkgs { - inherit system overlays; - }; - in - (with pkgs; [ - (emacsWithPackagesFromUsePackage { - config = '' - (setq easycrypt-prog-name "ec.native") - (electric-indent-mode -1) - ''; - defaultInitFile = true; - alwaysEnsure = true; - package = pkgs.emacs; - extraEmacsPackages = epkgs: [ epkgs.proof-general ]; - }) - bashInteractive - git - difftastic - ]) - ++ - (with pkgs; - lib.optionals (!stdenv.isDarwin) [ perf-tools ]) - ); + mkAltErgo = version: + ((on.queryToScope { } (query // { alt-ergo = version; })).overrideScope overlay).alt-ergo; in rec { legacyPackages = scope'; packages = rec { - z3 = mkProverPackage "z3" "4.14.1"; + z3 = mkProverPackage "z3" "4.12.6"; cvc4 = mkProverPackage "cvc4" "1.8"; - cvc5 = mkProverPackage "cvc5" "1.3.0"; - altErgo = mkAltErgo "2.4.2"; + cvc5 = mkProverPackage "cvc5" "1.0.9"; + altErgo = mkAltErgo "2.4.3"; provers = pkgs.symlinkJoin { name = "provers"; - paths = [ - altErgo - z3 - # cvc4 - cvc5 - ]; + paths = [ altErgo z3 cvc4 cvc5 ]; }; with_provers = pkgs.symlinkJoin { @@ -148,40 +102,12 @@ default = main; }; - devShells.barebones = pkgs.mkShell { + devShells.default = pkgs.mkShell { inputsFrom = [ scope'.easycrypt ]; buildInputs = - devPackages - ++ [ scope'.why3 ] - ++ (with pkgs.python3Packages; [ pyyaml ]); + devPackages + ++ [ pkgs.git scope'.why3 packages.provers ] + ++ (with pkgs.python3Packages; [ pyyaml ]); }; - - devShells.noProvers = pkgs.mkShell rec { - inputsFrom = [ scope'.easycrypt ]; - buildInputs = - devPackages - ++ devTools - ++ [ scope'.why3 ] - ++ (with pkgs.python3Packages; [ pyyaml ]); - SHELL = ''${pkgs.bashInteractive + "/bin/bash"}''; - shellHook = builtins.replaceStrings ["\n"] [" "] '' - export SHELL=${SHELL} && - export PATH=$PATH:`realpath .` - ''; - }; - - devShells.withDevTools = pkgs.mkShell rec { - inputsFrom = [ scope'.easycrypt ]; - buildInputs = - devPackages - ++ devTools - ++ [ scope'.why3 packages.provers ] - ++ (with pkgs.python3Packages; [ pyyaml ]); - SHELL = ''${pkgs.bashInteractive + "/bin/bash"}''; - shellHook = builtins.replaceStrings ["\n"] [" "] '' - export SHELL=${SHELL} && - export PATH=$PATH:`realpath .` - ''; - }; }); } From 53b543b9df47d9629fab63d821cbdde18a4197e6 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sun, 31 May 2026 11:40:30 +0200 Subject: [PATCH 058/145] Cleanup: revert README, drop .bck files, fix abstract_bind test - README.md: restore the 'LaTeX Formatting' section (its removal was unrelated to the circuit feature; eclistings.sty is kept). - Remove leftover backup files libs/lospecs/deps.ml.bck and deps.mli.bck. - tests/abstract_bind.ec: 'bdep solve' -> 'circuit' (the tactic was renamed; the test was stale and failed to parse). --- README.md | 8 ++ libs/lospecs/deps.ml.bck | 196 -------------------------------------- libs/lospecs/deps.mli.bck | 35 ------- tests/abstract_bind.ec | 2 +- 4 files changed, 9 insertions(+), 232 deletions(-) delete mode 100644 libs/lospecs/deps.ml.bck delete mode 100644 libs/lospecs/deps.mli.bck diff --git a/README.md b/README.md index 902d7bc3cb..9ef3d2917e 100644 --- a/README.md +++ b/README.md @@ -26,6 +26,7 @@ EasyCrypt is part of the [Formosa Crypto project](https://formosa-crypto.org/). - [Visual Studio Code](#visual-studio-code) - [Useful Resources](#useful-resources) - [Examples](#examples) + - [LaTeX Formatting](#latex-formatting) # Installation @@ -185,3 +186,10 @@ Examples of how to use EasyCrypt are in the `examples` directory. You will find basic examples at the root of this directory, as well as a more advanced example in the `MEE-CBC` sub-directory and a tutorial on how to use the complexity system in `cost` sub-directory. + +## LaTeX Formatting + +LaTeX style file is in `assets/latex` directory. The basic usages are +`\begin{eclst} ... \end{eclst}` (display mode) and +`\ecinl{proc main() = { ... }}` (inline mode). + diff --git a/libs/lospecs/deps.ml.bck b/libs/lospecs/deps.ml.bck deleted file mode 100644 index e9a77fe708..0000000000 --- a/libs/lospecs/deps.ml.bck +++ /dev/null @@ -1,196 +0,0 @@ -(* -------------------------------------------------------------------- *) -open Ast - -(* -------------------------------------------------------------------- *) -type symbol = string - -(* -------------------------------------------------------------------- *) -type dep1 = Set.Int.t IdentMap.t -type deps = dep1 Map.Int.t - -(* -------------------------------------------------------------------- *) -let eq_dep1 (d1 : dep1) (d2 : dep1) : bool = - IdentMap.equal Set.Int.equal d1 d2 - -(* -------------------------------------------------------------------- *) -let eq_deps (d1 : deps) (d2 : deps) : bool = Map.Int.equal eq_dep1 d1 d2 - -(* -------------------------------------------------------------------- *) -let empty ~(size : int) : deps = - 0 --^ size |> Enum.map (fun i -> (i, IdentMap.empty)) |> Map.Int.of_enum - -(* -------------------------------------------------------------------- *) -let enlarge ~(min : int) ~(max : int) (d : deps) : deps = - let change = function None -> Some IdentMap.empty | Some _ as v -> v in - - min --^ max |> Enum.fold (fun d i -> Map.Int.modify_opt i change d) d - -(* -------------------------------------------------------------------- *) -let clearout ~(min : int) ~(max : int) (d : deps) : deps = - Map.Int.filter_map - (fun i d1 -> Some (if min <= i && i < max then d1 else IdentMap.empty)) - d - -(* -------------------------------------------------------------------- *) -let restrict ~(min : int) ~(max : int) (d : deps) : deps = - Map.Int.filter (fun i _ -> min <= i && i < max) d - -(* -------------------------------------------------------------------- *) -let recast ~(min : int) ~(max : int) (d : deps) : deps = - d |> restrict ~min ~max |> enlarge ~min ~max - -(* -------------------------------------------------------------------- *) -let merge1 (d1 : dep1) (d2 : dep1) : dep1 = - IdentMap.merge - (fun _ i1 i2 -> - Some (Set.Int.union (i1 |? Set.Int.empty) (i2 |? Set.Int.empty))) - d1 d2 - -(* -------------------------------------------------------------------- *) -let merge (d1 : deps) (d2 : deps) : deps = - Map.Int.merge - (fun _ m1 m2 -> - Some (merge1 (m1 |? IdentMap.empty) (m2 |? IdentMap.empty))) - d1 d2 - -(* -------------------------------------------------------------------- *) -let merge1_all (ds : dep1 Enum.t) : dep1 = Enum.reduce merge1 ds - -(* -------------------------------------------------------------------- *) -let merge_all (ds : deps Enum.t) : deps = Enum.reduce merge ds - -(* -------------------------------------------------------------------- *) -let copy ~(offset : int) ~(size : int) (x : ident) : deps = - 0 --^ size - |> Enum.map (fun i -> - let di = IdentMap.singleton x (Set.Int.singleton (i + offset)) in - (i, di)) - |> Map.Int.of_enum - -(* -------------------------------------------------------------------- *) -let chunk ~(csize : int) ~(count : int) (d : deps) : deps = - 0 --^ count - |> Enum.map (fun ci -> - let d1 = - 0 --^ csize - |> Enum.map (fun i -> i + (ci * csize)) - |> Enum.map (fun i -> Map.Int.find_opt i d |> Option.default IdentMap.empty) - |> merge1_all - in - 0 --^ csize |> Enum.map (fun i -> (i + (ci * csize), d1))) - |> Enum.flatten |> Map.Int.of_enum - -(* -------------------------------------------------------------------- *) -let perm ~(csize : int) ~(perm : int list) (d : deps) : deps = - List.enum perm - |> Enum.mapi (fun ci x -> - Enum.map - (fun i -> (i + (ci * csize), Map.Int.find_opt (i + (x * csize)) d |> Option.default IdentMap.empty)) - (0 --^ csize)) - |> Enum.flatten |> Map.Int.of_enum - -(* -------------------------------------------------------------------- *) -let collapse ~(csize : int) ~(count : int) (d : deps) : deps = - 0 --^ count - |> Enum.map (fun ci -> - let d1 = - 0 --^ csize - |> Enum.map (fun i -> i + (ci * csize)) - |> Enum.map (fun i -> Map.Int.find_opt i d |> Option.default IdentMap.empty) - |> merge1_all - in - (ci, d1)) - |> Map.Int.of_enum - -(* -------------------------------------------------------------------- *) -let merge_all_deps (d : deps) : dep1 = - Map.Int.enum d |> Enum.map snd |> merge1_all - -(* -------------------------------------------------------------------- *) -let constant ~(size : int) (d : dep1) : deps = - 0 --^ size |> Enum.map (fun i -> (i, d)) |> Map.Int.of_enum - -(* -------------------------------------------------------------------- *) -let offset ~(offset : int) (d : deps) : deps = - Map.Int.enum d |> Enum.map (fun (i, x) -> (i + offset, x)) |> Map.Int.of_enum - -(* -------------------------------------------------------------------- *) -let split ~(csize : int) ~(count : int) (d : deps) : deps Enum.t = - 0 --^ count - |> Enum.map (fun i -> - Map.Int.filter (fun x _ -> csize * i <= x && x < csize * (i + 1)) d - |> offset ~offset:(-i * csize)) - -(* -------------------------------------------------------------------- *) -let aggregate ~(csize : int) (ds : deps Enum.t) = - Enum.foldi - (fun i d1 d -> merge (offset ~offset:(i * csize) d1) d) - (empty ~size:0) ds - -(* ==================================================================== *) -type 'a pp = Format.formatter -> 'a -> unit - -(* -------------------------------------------------------------------- *) -let pp_bitset (fmt : Format.formatter) (d : Set.Int.t) = - Format.fprintf fmt "{%a}" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") - Format.pp_print_int) - (Set.Int.elements d) - -(* -------------------------------------------------------------------- *) -let pp_bitintv (fmt : Format.formatter) (d : (int * int) list) = - Format.fprintf fmt "%a" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ", ") - (fun fmt (i, j) -> Format.fprintf fmt "[%d..%d](%d)" i j (j - i + 1))) - d - -(* -------------------------------------------------------------------- *) -let bitintv_of_bitset (d : Set.Int.t) = - let aout = ref [] in - let current = ref None in - - d - |> Set.Int.iter (fun i -> - match !current with - | None -> current := Some (i, i) - | Some (v1, v2) -> - if i = v2 + 1 then current := Some (v1, i) - else ( - aout := (v1, v2) :: !aout; - current := Some (i, i))); - - Option.may (fun (v1, v2) -> aout := (v1, v2) :: !aout) !current; - - List.rev !aout - -(* -------------------------------------------------------------------- *) -let pp_dep1 (fmt : Format.formatter) (d : dep1) = - IdentMap.iter - (fun x bits -> - Format.fprintf fmt "%s.%d -> %a@\n" (Ident.name x) (Ident.id x) pp_bitintv (bitintv_of_bitset bits)) - d - -(* -------------------------------------------------------------------- *) -let pp_deps (fmt : Format.formatter) (d : deps) = - let display (v1, v2, d) = - Format.fprintf fmt "[%d..%d](%d) -> @[@\n%a@]@\n" v1 v2 - (v2 - v1 + 1) - pp_dep1 d - in - - let current = ref None in - - Map.Int.iter - (fun i d -> - match !current with - | None -> current := Some (i, i, d) - | Some (v1, v2, d') -> - if i = v2 + 1 && eq_dep1 d d' then current := Some (v1, i, d') - else ( - display (v1, v2, d'); - current := Some (i, i, d))) - d; - - Option.may display !current diff --git a/libs/lospecs/deps.mli.bck b/libs/lospecs/deps.mli.bck deleted file mode 100644 index 7bdad64d48..0000000000 --- a/libs/lospecs/deps.mli.bck +++ /dev/null @@ -1,35 +0,0 @@ -open Ast - -(* -------------------------------------------------------------------- *) -type symbol = string -type dep1 = Set.Int.t IdentMap.t -type deps = dep1 Map.Int.t - -(* -------------------------------------------------------------------- *) -val empty : size:int -> deps -val enlarge : min:int -> max:int -> deps -> deps -val clearout : min:int -> max:int -> deps -> deps -val restrict : min:int -> max:int -> deps -> deps -val recast : min:int -> max:int -> deps -> deps -val merge1 : dep1 -> dep1 -> dep1 -val merge : deps -> deps -> deps -val merge1_all : dep1 Enum.t -> dep1 -val merge_all : deps Enum.t -> deps -val copy : offset:int -> size:int -> ident -> deps -val chunk : csize:int -> count:int -> deps -> deps -val perm : csize:int -> perm:int list -> deps -> deps -val collapse : csize:int -> count:int -> deps -> deps -val merge_all_deps : deps -> dep1 -val constant : size:int -> dep1 -> deps -val offset : offset:int -> deps -> deps -val split : csize:int -> count:int -> deps -> deps Enum.t -val aggregate : csize:int -> deps Enum.t -> deps - -(* -------------------------------------------------------------------- *) -type 'a pp = Format.formatter -> 'a -> unit - -val bitintv_of_bitset : Set.Int.t -> (int * int) list -val pp_bitset : Set.Int.t pp -val pp_bitintv : (int * int) list pp -val pp_dep1 : dep1 pp -val pp_deps : deps pp diff --git a/tests/abstract_bind.ec b/tests/abstract_bind.ec index fb04b44def..1cf97460b5 100644 --- a/tests/abstract_bind.ec +++ b/tests/abstract_bind.ec @@ -67,4 +67,4 @@ print CTest. lemma xor2_false (b: bool) : b ^^ b = CTest.ofint 0. -bdep solve. qed. +circuit. qed. From 89596a7f39e49c4010fcb3f8a126cc230c1f64f6 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sun, 31 May 2026 11:47:59 +0200 Subject: [PATCH 059/145] PHL: make eqobs-in programmatically reusable (split parse/tactic) Splits the eqobs-in machinery into a parse layer and a tactic layer: - A new elaborated 'sim_info' record (in EcPhlEqobs) holds resolved data (Mpv2.t equalities, ts_inv invariant, resolved codegap1 positions), distinct from the parsetree side which is renamed 'sim_info' -> 'psim_info'. - 'process_eqobs_in{,S,F}' now only elaborate 'psim_info' -> 'sim_info' and delegate to new tactic functions 't_eqobs_in{,S,F}' that operate on already-elaborated data. New 'empty_sim_info' helper. - This exposes a programmatic 't_eqobs_in cm info tc' entry point, used by ecPhlRwEquiv and ecPhlOutline (which previously had to go through the parser-facing path). - ecPhlRwEquiv.t_rewrite_equiv now takes an elaborated 'codepos1' (callers elaborate via EcTyping.trans_codepos1) instead of 'pcodepos1'. Behaviour-preserving refactor (uses the existing ts_inv type). --- src/ecParser.mly | 6 +- src/ecParsetree.ml | 10 +- src/phl/ecPhlEqobs.ml | 192 ++++++++++++++++++++++++++++----------- src/phl/ecPhlEqobs.mli | 17 +++- src/phl/ecPhlOutline.ml | 2 +- src/phl/ecPhlRwEquiv.ml | 26 ++++-- src/phl/ecPhlRwEquiv.mli | 7 +- 7 files changed, 185 insertions(+), 75 deletions(-) diff --git a/src/ecParser.mly b/src/ecParser.mly index 117ccf9a15..68121e583b 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -3359,9 +3359,9 @@ eqobs_in_eqpost: eqobs_in: | pos=eqobs_in_pos? i=eqobs_in_eqinv p=eqobs_in_eqpost? { - { sim_pos = pos; - sim_hint = i; - sim_eqs = p; } + { psim_pos = pos; + psim_hint = i; + psim_eqs = p; } } pgoptionkw: diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 7d060227eb..1dd721c69e 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -739,10 +739,10 @@ type conseq_contra = type conseq_ppterm = (conseq_contra * (conseq_info) option) gppterm (* -------------------------------------------------------------------- *) -type sim_info = { - sim_pos : pcodegap1 pair option; - sim_hint : (pgamepath option pair * pformula) list * pformula option; - sim_eqs : pformula option +type psim_info = { + psim_pos : pcodegap1 pair option; + psim_hint : (pgamepath option pair * pformula) list * pformula option; + psim_eqs : pformula option } (* -------------------------------------------------------------------- *) @@ -823,7 +823,7 @@ type phltactic = | Pfel of (pcodegap1 * fel_info) | Phoare | Pprbounded - | Psim of crushmode option* sim_info + | Psim of crushmode option* psim_info | Ptrans_stmt of trans_info | Prw_equiv of rw_eqv_info | Psymmetry diff --git a/src/phl/ecPhlEqobs.ml b/src/phl/ecPhlEqobs.ml index d7f9b0d1cd..ed2122ab90 100644 --- a/src/phl/ecPhlEqobs.ml +++ b/src/phl/ecPhlEqobs.ml @@ -1,6 +1,9 @@ (* -------------------------------------------------------------------- *) open EcUtils +open EcPath +open EcParsetree open EcAst +open EcMatching.Position open EcTypes open EcModules open EcFol @@ -13,6 +16,16 @@ open EcLowPhlGoal module TTC = EcProofTyping +(* -------------------------------------------------------------------- *) +type sim_info = { + sim_pos : codegap1 pair option; + sim_hint : (xpath option * xpath option * EcPV.Mpv2.t) list * ts_inv option; + sim_eqs : EcPV.Mpv2.t option; +} + +let empty_sim_info : sim_info = + { sim_pos = None; sim_hint = ([], None); sim_eqs = None; } + (* -------------------------------------------------------------------- *) let extend_body fsig body = let arg = pv_arg in @@ -397,7 +410,7 @@ let t_eqobs_inS_r sim eqo tc = tc_error !!tc "cannot apply sim"; let sg = List.map (mk_inv_spec env inv) sim.needed_spec in - let concl = f_equivS (snd es.es_ml) (snd es.es_mr) (es_pr es) sl sr pre in + let concl = f_equivS (snd es.es_ml) (snd es.es_mr) (es_pr es) sl sr pre in FApi.xmutate1 tc `EqobsIn (sg @ [concl]) @@ -423,54 +436,62 @@ let t_eqobs_inF_r sim eqo tc = let t_eqobs_inF = FApi.t_low2 "eqobs-in" t_eqobs_inF_r (* -------------------------------------------------------------------- *) -let process_eqs env tc f = - try - Mpv2.of_form env f - with Not_found -> - tc_error_lazy !!tc (fun fmt -> - let ppe = EcPrinting.PPEnv.ofenv env in - Format.fprintf fmt - "cannot recognize %a as a set of equalities" - (EcPrinting.pp_form ppe) f.inv) +let process_eqs (pe : proofenv) (env : env) (f : ts_inv) = + try + Mpv2.of_form env f + with Not_found -> + tc_error_lazy pe (fun fmt -> + let ppe = EcPrinting.PPEnv.ofenv env in + Format.fprintf fmt + "cannot recognize %a as a set of equalities" + (EcPrinting.pp_form ppe) f.inv) (* -------------------------------------------------------------------- *) -let process_hint ml mr tc hyps (feqs, inv) = +let process_hint ml mr (pe : proofenv) (hyps : LDecl.hyps) (feqs, inv : _ * _) = let env = LDecl.toenv hyps in let ienv = LDecl.push_active_ts (EcMemory.abstract ml) (EcMemory.abstract mr) hyps in - let doinv pf = {ml;mr;inv=TTC.pf_process_form !!tc ienv tbool pf} in - let doeq pf = process_eqs env tc (doinv pf) in + let doinv pf = {ml;mr;inv=TTC.pf_process_form pe ienv tbool pf} in + let doeq pf = process_eqs pe env (doinv pf) in let dof g = omap (EcTyping.trans_gamepath env) g in let geqs = - List.map (fun ((f1,f2),geq) -> dof f1, dof f2, doeq geq) + List.map + (fun ((f1, f2), geq) -> dof f1, dof f2, doeq geq) feqs in - let ginv = odfl {ml;mr;inv=f_true} (omap doinv inv) in + let ginv = (omap doinv inv) in (* FIXME: check *) geqs, ginv (* -------------------------------------------------------------------- *) -let process_eqobs_inS info tc = - let env, hyps, _ = FApi.tc1_eflat tc in +let pre_eqobs (cm : crushmode) (tc : tcenv1) = + let dt, ts = EcHiGoal.process_crushmode cm in + EcPhlConseq.t_conseqauto ~delta:dt ?tsolve:ts tc + +(* -------------------------------------------------------------------- *) +let t_eqobs_inS_ (info : sim_info) (tc : tcenv1) = + let env, _, _ = FApi.tc1_eflat tc in let es = tc1_as_equivS tc in - let ml, mr = fst es.es_ml, fst es.es_mr in - let spec, inv = process_hint ml mr tc hyps info.EcParsetree.sim_hint in + let spec, inv = info.sim_hint in + + let inv = match inv with + | Some inv -> inv + | None -> let ml, mr = fst es.es_ml, fst es.es_mr in + {ml;mr;inv=f_true} + in + let eqo = - match info.EcParsetree.sim_eqs with - | Some pf -> - process_eqs env tc (TTC.tc1_process_prhl_formula tc pf) - | None -> - try Mpv2.needed_eq env (es_po es) - with Not_found -> tc_error !!tc "cannot infer the set of equalities" in - let post = Mpv2.to_form_ts_inv eqo inv in + match info.sim_eqs with Some eqo -> eqo | None -> + try Mpv2.needed_eq env (es_po es) + with _ -> tc_error !!tc "cannot infer the set of equalities" in + let sim = init_sim env spec inv in + let post = Mpv2.to_form_ts_inv eqo inv in + let t_main tc = - match info.EcParsetree.sim_pos with + match info.sim_pos with | None -> FApi.t_last (FApi.t_try (FApi.t_seq EcPhlSkip.t_skip t_trivial)) (t_eqobs_inS sim eqo tc) | Some(p1,p2) -> - (* sim positions are gaps: sim applies to instructions after the gap *) - let p1 = EcLowPhlGoal.tc1_process_codegap1 tc (Some `Left , p1) in - let p2 = EcLowPhlGoal.tc1_process_codegap1 tc (Some `Right, p2) in let _,sl2 = s_split env p1 es.es_sl in let _,sr2 = s_split env p2 es.es_sr in let _, eqi = @@ -485,49 +506,110 @@ let process_eqobs_inS info tc = ]) tc in (EcPhlConseq.t_equivS_conseq (es_pr es) post @+ [t_trivial; - t_trivial; - t_main]) tc + t_trivial; + t_main]) tc + +(* -------------------------------------------------------------------- *) +let t_eqobs_inS (cm : crushmode option) (info : sim_info) (tc : tcenv1) = + FApi.t_last (t_eqobs_inS_ info) ((omap pre_eqobs cm |> odfl t_id) tc) (* -------------------------------------------------------------------- *) -let process_eqobs_inF info tc = - if info.EcParsetree.sim_pos <> None then - tc_error !!tc "no positions excepted"; +let process_eqobs_inS (cm : crushmode option) (info : psim_info) (tc : tcenv1) = let env, hyps, _ = FApi.tc1_eflat tc in + let es = tc1_as_equivS tc in + let ml, mr = fst es.es_ml, fst es.es_mr in + let sim_hint = process_hint ml mr !!tc hyps info.psim_hint in + let sim_eqs = + let process pf = + process_eqs !!tc env (TTC.tc1_process_prhl_formula tc pf) + in Option.map process info.psim_eqs in + let sim_pos = + info.psim_pos |> + Option.map (fun (p1, p2) -> + let p1 = EcLowPhlGoal.tc1_process_codegap1 tc (Some `Left , p1) in + let p2 = EcLowPhlGoal.tc1_process_codegap1 tc (Some `Right, p2) in + (p1, p2) + ) + in + + let info = { sim_pos; sim_hint; sim_eqs; } in + + t_eqobs_inS cm info tc + +(* -------------------------------------------------------------------- *) +let t_eqobs_inF_ (info : sim_info) (tc : tcenv1) = + assert (Option.is_none info.sim_pos); + + let env, _, _ = FApi.tc1_eflat tc in let ef = tc1_as_equivF tc in - let ml, mr = ef.ef_ml, ef.ef_mr in - let spec, inv = process_hint ml mr tc hyps info.EcParsetree.sim_hint in let fl = ef.ef_fl and fr = ef.ef_fr in + + let spec, inv = info.sim_hint in + let eqo = - match info.EcParsetree.sim_eqs with - | Some pf -> - let _,(mle,mre) = Fun.equivF_memenv ml mr fl fr env in - let hyps = LDecl.push_active_ts mle mre hyps in - process_eqs env tc {ml; mr; inv=TTC.pf_process_form !!tc hyps tbool pf} - | None -> + match info.sim_eqs with Some eqo -> eqo | None -> try Mpv2.needed_eq env (ef_po ef) with _ -> tc_error !!tc "cannot infer the set of equalities" in + let eqo = Mpv2.remove env pv_res pv_res eqo in + + let inv = match inv with + | Some inv -> inv + | None -> let ml, mr = ef.ef_ml, ef.ef_mr in + {ml;mr;inv=f_true} + in + let sim = init_sim env spec inv in let _, eqi = try f_eqobs_in fl fr sim eqo with EqObsInError -> tc_error !!tc "not able to process" in let ef' = destr_equivF (mk_inv_spec2 env inv (fl, fr, eqi, eqo)) in + (EcPhlConseq.t_equivF_conseq (ef_pr ef') (ef_po ef') @+ [ t_trivial; t_trivial; t_eqobs_inF sim eqo]) tc (* -------------------------------------------------------------------- *) -let process_eqobs_in cm info tc = - let prett cm tc = - let dt, ts = EcHiGoal.process_crushmode cm in - EcPhlConseq.t_conseqauto ~delta:dt ?tsolve:ts tc in - let tt tc = - let concl = FApi.tc1_goal tc in - match concl.f_node with - | FequivF _ -> process_eqobs_inF info tc - | FequivS _ -> process_eqobs_inS info tc - | _ -> tc_error_noXhl ~kinds:[`Equiv `Any] !!tc - in +let t_eqobs_inF (cm : crushmode option) (info : sim_info) (tc : tcenv1) = + FApi.t_last (t_eqobs_inF_ info) ((omap pre_eqobs cm |> odfl t_id) tc) + +(* -------------------------------------------------------------------- *) +let process_eqobs_inF (cm : crushmode option) (info : psim_info) (tc : tcenv1) = + if Option.is_some info.psim_pos then + tc_error !!tc "no positions excepted"; - FApi.t_last tt ((omap prett cm |> odfl t_id) tc) + let env, hyps, _ = FApi.tc1_eflat tc in + let ef = tc1_as_equivF tc in + let ml, mr = ef.ef_ml, ef.ef_mr in + let sim_hint = process_hint ml mr !!tc hyps info.psim_hint in + let fl = ef.ef_fl and fr = ef.ef_fr in + let sim_eqs = + let process pf = + let _,(mle,mre) = Fun.equivF_memenv ml mr fl fr env in + let hyps = LDecl.push_active_ts mle mre hyps in + process_eqs !!tc env {ml; mr; inv=TTC.pf_process_form !!tc hyps tbool pf} + in Option.map process info.psim_eqs in + + let info = { sim_pos = None; sim_hint; sim_eqs; } in + + t_eqobs_inF cm info tc + +(* -------------------------------------------------------------------- *) +let process_eqobs_in (cm : crushmode option) (info : psim_info) (tc : tcenv1) = + let concl = FApi.tc1_goal tc in + match concl.f_node with + | FequivF _ -> process_eqobs_inF cm info tc + | FequivS _ -> process_eqobs_inS cm info tc + | _ -> tc_error_noXhl ~kinds:[`Equiv `Any] !!tc + +(* -------------------------------------------------------------------- *) +let t_eqobs_in_r (cm : crushmode option) (info : sim_info) (tc : tcenv1) = + let concl = FApi.tc1_goal tc in + match concl.f_node with + | FequivF _ -> t_eqobs_inF cm info tc + | FequivS _ -> t_eqobs_inS cm info tc + | _ -> tc_error_noXhl ~kinds:[`Equiv `Any] !!tc + +(* -------------------------------------------------------------------- *) +let t_eqobs_in = FApi.t_low2 "eqobs-in" t_eqobs_in_r diff --git a/src/phl/ecPhlEqobs.mli b/src/phl/ecPhlEqobs.mli index d210124949..1c878dc6be 100644 --- a/src/phl/ecPhlEqobs.mli +++ b/src/phl/ecPhlEqobs.mli @@ -1,7 +1,20 @@ (* -------------------------------------------------------------------- *) - +open EcUtils +open EcPath open EcParsetree +open EcAst +open EcMatching.Position open EcCoreGoal.FApi (* -------------------------------------------------------------------- *) -val process_eqobs_in : crushmode option -> sim_info -> backward +type sim_info = { + sim_pos : codegap1 pair option; + sim_hint : (xpath option * xpath option * EcPV.Mpv2.t) list * ts_inv option; + sim_eqs : EcPV.Mpv2.t option; +} + +val empty_sim_info : sim_info + +(* -------------------------------------------------------------------- *) +val t_eqobs_in : crushmode option -> sim_info -> backward +val process_eqobs_in : crushmode option -> psim_info -> backward diff --git a/src/phl/ecPhlOutline.ml b/src/phl/ecPhlOutline.ml index d0d65536bb..803af0b5cd 100644 --- a/src/phl/ecPhlOutline.ml +++ b/src/phl/ecPhlOutline.ml @@ -12,7 +12,7 @@ open EcLowPhlGoal let t_auto_equiv_sim = t_seqs [ EcPhlInline.process_inline (`ByName (None, None, ([], None))); - EcPhlEqobs.process_eqobs_in None {sim_pos = None; sim_hint = ([], None); sim_eqs = None}; + EcPhlEqobs.process_eqobs_in None {psim_pos = None; psim_hint = ([], None); psim_eqs = None}; EcPhlAuto.t_auto; EcLowGoal.t_crush; EcHiGoal.process_done; diff --git a/src/phl/ecPhlRwEquiv.ml b/src/phl/ecPhlRwEquiv.ml index bc8c4ea7fe..3e2ff5b6b4 100644 --- a/src/phl/ecPhlRwEquiv.ml +++ b/src/phl/ecPhlRwEquiv.ml @@ -1,3 +1,4 @@ +(* -------------------------------------------------------------------- *) open EcUtils open EcLocation open EcParsetree @@ -11,7 +12,7 @@ open EcCoreGoal.FApi open EcLowGoal open EcLowPhlGoal -(*---------------------------------------------------------------------------------------*) +(* -------------------------------------------------------------------- *) type rwe_error = | RWE_InvalidFunction of xpath * xpath | RWE_InvalidPosition @@ -20,7 +21,7 @@ exception RwEquivError of rwe_error let rwe_error e = raise (RwEquivError e) -(*---------------------------------------------------------------------------------------*) +(* -------------------------------------------------------------------- *) (* `rewrite equiv` - replace a call to a procedure with an equivalent call, using an equiv @@ -34,7 +35,15 @@ let rwe_error e = raise (RwEquivError e) and return value. *) (* FIXME: What is a good interface for this tactic? *) -let t_rewrite_equiv side dir cp (equiv : equivF) equiv_pt rargslv tc = +let t_rewrite_equiv + (side : side) + (dir : [`LtoR | `RtoL]) + (cp : EcMatching.Position.codepos1) + (equiv : equivF) + (equiv_pt : proofterm) + (rargslv : (expr list * lvalue option) option) + (tc : tcenv1) += let env = tc1_env tc in let goal = tc1_as_equivS tc in @@ -56,7 +65,6 @@ let t_rewrite_equiv side dir cp (equiv : equivF) equiv_pt rargslv tc = (* Extract the call statement and surrounding code *) let prefix, (llv, func, largs), suffix = - let cp = EcLowPhlGoal.tc1_process_codepos1 tc (Some side, cp) in let p, i, s = s_split_i env cp code in if not (is_call i) then rwe_error RWE_InvalidPosition; @@ -80,8 +88,10 @@ let t_rewrite_equiv side dir cp (equiv : equivF) equiv_pt rargslv tc = t_onselect p (t_seqs [ - EcPhlEqobs.process_eqobs_in None - {sim_pos = some (GapAfter cp, GapAfter cp); sim_hint = ([], none); sim_eqs = none}; + EcPhlEqobs.t_eqobs_in + None EcPhlEqobs.{ empty_sim_info with + sim_pos = Some EcMatching.Position.(gap_after_pos cp, gap_after_pos cp) + }; (match side, dir with | `Left, `LtoR -> t_id | `Left, `RtoL -> EcPhlSym.t_equiv_sym @@ -97,7 +107,7 @@ let t_rewrite_equiv side dir cp (equiv : equivF) equiv_pt rargslv tc = ]) tc -(*---------------------------------------------------------------------------------------*) +(* -------------------------------------------------------------------- *) (* Proccess a user call to rewrite equiv *) let process_rewrite_equiv info tc = @@ -152,6 +162,8 @@ let process_rewrite_equiv info tc = end in + let cp = EcTyping.trans_codepos1 env cp in + (* Offload to the tactic *) try (* FIXME: cp should be translated to codepos in process diff --git a/src/phl/ecPhlRwEquiv.mli b/src/phl/ecPhlRwEquiv.mli index eee53c6091..0504c28b7e 100644 --- a/src/phl/ecPhlRwEquiv.mli +++ b/src/phl/ecPhlRwEquiv.mli @@ -1,12 +1,15 @@ +(* -------------------------------------------------------------------- *) open EcCoreGoal.FApi +open EcAst open EcParsetree open EcCoreGoal -open EcAst +open EcMatching.Position +(* -------------------------------------------------------------------- *) val t_rewrite_equiv : side -> [`LtoR | `RtoL ] -> - pcodepos1 -> + codepos1 -> equivF -> proofterm -> (expr list * lvalue option) option -> From 07b5aee346d45f2ede8452d2533ca090145a3c59 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sun, 31 May 2026 19:53:50 +0200 Subject: [PATCH 060/145] Cleanup: revert unrelated non-circuit changes to origin/main - ecTerminal.ml: revert err_formatter -> std_formatter (LLM-tooling residue; tooling was removed). - ecPhlLoopTx.ml: revert a botched error-message edit (a single continued string was split into two args, truncating the message). - ecLowPhlGoal.ml, ecEco.ml, ecDoc.ml, ecPhlRCond.mli: drop pure cosmetic churn (parens/whitespace/val reordering) unrelated to the circuit feature. --- src/ecDoc.ml | 4 ++-- src/ecEco.ml | 8 ++++---- src/ecLowPhlGoal.ml | 12 ++++++------ src/ecTerminal.ml | 2 +- src/phl/ecPhlLoopTx.ml | 4 ++-- src/phl/ecPhlRCond.mli | 2 +- 6 files changed, 16 insertions(+), 16 deletions(-) diff --git a/src/ecDoc.ml b/src/ecDoc.ml index f8796510e9..01b3437709 100644 --- a/src/ecDoc.ml +++ b/src/ecDoc.ml @@ -26,8 +26,8 @@ let c_filename ?(ext : string option) (nms : string list) = (* -------------------------------------------------------------------- *) let thkind_str (kind : EcLoader.kind) : string = match kind with - | `Ec -> "Theory" - | `EcA -> "Abstract Theory" + | `Ec -> "Theory" + | `EcA -> "Abstract Theory" (* -------------------------------------------------------------------- *) let itemkind_str_pl (ik : itemkind) : string = diff --git a/src/ecEco.ml b/src/ecEco.ml index c85da07111..fc8f41c986 100644 --- a/src/ecEco.ml +++ b/src/ecEco.ml @@ -64,13 +64,13 @@ let list_of_json (tx : Json.t -> 'a) (data : Json.t) : 'a list = (* -------------------------------------------------------------------- *) let kind_to_json (k : EcLoader.kind) = match k with - | `Ec -> `String "ec" - | `EcA -> `String "eca" + | `Ec -> `String "ec" + | `EcA -> `String "eca" let kind_of_json (data : Json.t) = match data with - | `String "ec" -> `Ec - | `String "eca" -> `EcA + | `String "ec" -> `Ec + | `String "eca" -> `EcA | _ -> raise InvalidEco (* -------------------------------------------------------------------- *) diff --git a/src/ecLowPhlGoal.ml b/src/ecLowPhlGoal.ml index e79a7f1c57..416bb15627 100644 --- a/src/ecLowPhlGoal.ml +++ b/src/ecLowPhlGoal.ml @@ -194,16 +194,16 @@ let is_program_logic (f : form) (ks : hlkind list) = let tc1_get_stmt side tc = let concl = FApi.tc1_goal tc in match side, concl.f_node with - | None, FhoareS hs -> (hs.hs_m, hs.hs_s) - | None, FeHoareS hs -> (hs.ehs_m, hs.ehs_s) - | None, FbdHoareS hs -> (hs.bhs_m, hs.bhs_s) + | None, FhoareS hs -> hs.hs_m, hs.hs_s + | None, FeHoareS hs -> hs.ehs_m, hs.ehs_s + | None, FbdHoareS hs -> hs.bhs_m, hs.bhs_s | Some _ , (FhoareS _ | FbdHoareS _) -> tc_error_noXhl ~kinds:[`Hoare `Stmt; `PHoare `Stmt] !!tc - | Some `Left, FequivS es -> (es.es_ml, es.es_sl) - | Some `Right, FequivS es -> (es.es_mr, es.es_sr) + | Some `Left, FequivS es -> es.es_ml, es.es_sl + | Some `Right, FequivS es -> es.es_mr, es.es_sr | None, FequivS _ -> tc_error_noXhl ~kinds:[`Equiv `Stmt] !!tc - | _ -> + | _ -> tc_error_noXhl ~kinds:(hlkinds_Xhl_r `Stmt) !!tc (* ------------------------------------------------------------------ *) diff --git a/src/ecTerminal.ml b/src/ecTerminal.ml index 2ee562aaf1..c5f85bc814 100644 --- a/src/ecTerminal.ml +++ b/src/ecTerminal.ml @@ -90,7 +90,7 @@ object(self) | EcScope.TopError (loc, e) -> (loc, e) | _ -> (LC._dummy, e) in - Format.fprintf Format.std_formatter + Format.fprintf Format.err_formatter "[error-%d-%d]%s\n%!" (max 0 (loc.LC.loc_bchar - startpos)) (max 0 (loc.LC.loc_echar - startpos)) diff --git a/src/phl/ecPhlLoopTx.ml b/src/phl/ecPhlLoopTx.ml index 453b9ccdc4..a1727ff94a 100644 --- a/src/phl/ecPhlLoopTx.ml +++ b/src/phl/ecPhlLoopTx.ml @@ -254,8 +254,8 @@ let process_unroll_for ~cfold side cpos tc = e | _ -> tc_error !!tc - "last instruction of the while loop must be" - "an \"increment\" of the loop counter" in + "last instruction of the while loop must be \ + an \"increment\" of the loop counter" in (* Apply loop increment *) let incrz = diff --git a/src/phl/ecPhlRCond.mli b/src/phl/ecPhlRCond.mli index 099093971f..87306ed994 100644 --- a/src/phl/ecPhlRCond.mli +++ b/src/phl/ecPhlRCond.mli @@ -24,5 +24,5 @@ val t_rcond : oside -> bool -> codepos1 -> backward val process_rcond : oside -> bool -> pcodepos1 -> backward (* -------------------------------------------------------------------- *) -val t_rcond_match : oside -> symbol -> codepos1 -> backward val process_rcond_match : oside -> symbol -> pcodepos1 -> backward +val t_rcond_match : oside -> symbol -> codepos1 -> backward From fc6edb432854706542f2d766772cfe788c81d7ae Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Sun, 31 May 2026 19:58:01 +0200 Subject: [PATCH 061/145] Remove dead ?kinds parameter from the loader locate API The ?kinds option (commit 9b6dd79d0 'Improve locate API') was added to let Loader.locate find .spec files, but spec-file loading was later reworked to resolve paths via Loader.current_path + Filename.concat, so ?kinds had no remaining non-default caller and no `Spec loader kind. Revert EcLoader.locate to origin/main and drop the ?kinds plumbing in EcCommands. --- src/ecCommands.ml | 11 +++++------ src/ecLoader.ml | 8 ++++---- src/ecLoader.mli | 2 +- 3 files changed, 10 insertions(+), 11 deletions(-) diff --git a/src/ecCommands.ml b/src/ecCommands.ml index e2f357b680..82b28853db 100644 --- a/src/ecCommands.ml +++ b/src/ecCommands.ml @@ -121,9 +121,8 @@ module Loader : sig val addidir : ?namespace:namespace -> ?recursive:bool -> string -> loader -> unit val aslist : loader -> ((namespace option * string) * idx_t) list - val locate : ?namespaces:namespace option list -> - ?kinds:(EcLoader.kind list) -> string -> - loader -> (namespace option * string * kind) option + val locate : ?namespaces:namespace option list -> string -> + loader -> (namespace option * string * kind) option val push : string -> loader -> unit val pop : loader -> context1 option @@ -182,8 +181,8 @@ end = struct let aslist (ld : loader) = EcLoader.aslist ld.ld_core - let locate ?namespaces ?kinds (path : string) (ld : loader) = - EcLoader.locate ?namespaces ?kinds path ld.ld_core + let locate ?namespaces (path : string) (ld : loader) = + EcLoader.locate ?namespaces path ld.ld_core let push (p : string) (ld : loader) = let ctxt1 = { cpath = ld.ld_cpath; filename = norm p; } in @@ -566,7 +565,7 @@ and process_th_require1 ld scope (nm, (sysname, thname), io) = then [Loader.namespace ld; None] else [nm] in - match Loader.locate ~kinds:[`Ec; `EcA] ~namespaces:nm sysname ld with + match Loader.locate ~namespaces:nm sysname ld with | None -> EcScope.hierror "cannot locate theory `%s'" sysname diff --git a/src/ecLoader.ml b/src/ecLoader.ml index 6a63329d12..b52f663c25 100644 --- a/src/ecLoader.ml +++ b/src/ecLoader.ml @@ -119,15 +119,15 @@ let check_case idir name (dev, ino) = with Unix.Unix_error _ -> None (* -------------------------------------------------------------------- *) -let locate ?(namespaces = [None]) ?(kinds = [`Ec; `EcA]) (name : string) (ecl : ecloader) = +let locate ?(namespaces = [None]) (name : string) (ecl : ecloader) = if not (EcRegexp.match_ (`S "^[a-zA-Z0-9_]+$") name) then None else let locate kind ((inamespace, idir), _) = let name = match kind with - | `Ec -> Printf.sprintf "%s.ec" name - | `EcA -> Printf.sprintf "%s.eca" name + | `Ec -> Printf.sprintf "%s.ec" name + | `EcA -> Printf.sprintf "%s.eca" name in let nmok = @@ -161,7 +161,7 @@ let locate ?(namespaces = [None]) ?(kinds = [`Ec; `EcA]) (name : string) (ecl : match List.rev_pmap (fun kind -> List.opick (locate kind) ecl.ecl_idirs) - kinds + [`Ec; `EcA] with | [x] -> Some x | _ -> None diff --git a/src/ecLoader.mli b/src/ecLoader.mli index 347c865c85..2338f6ad73 100644 --- a/src/ecLoader.mli +++ b/src/ecLoader.mli @@ -20,4 +20,4 @@ val aslist : ecloader -> ((namespace option * string) * idx_t) list val dup : ecloader -> ecloader val forsys : ecloader -> ecloader val addidir : ?namespace:namespace -> ?recursive:bool -> string -> ecloader -> unit -val locate : ?namespaces:(namespace option) list -> ?kinds:(kind list) -> string -> ecloader -> (namespace option * string * kind) option +val locate : ?namespaces:(namespace option) list -> string -> ecloader -> (namespace option * string * kind) option From a352713fe1548f5d1b269360b48b4f48cc1671e0 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 1 Jun 2026 09:00:37 +0200 Subject: [PATCH 062/145] Factor out AInvFHashtbl into EcAlphaInvHashtbl module Move the alpha-invariant-keyed formula hashtable (used as circuit_of_form's memoization cache) out of ecCircuits.ml into its own EcAlphaInvHashtbl module (functor over the hypotheses context), with a .mli exposing only Htbl and clear. No behavior change; circuit tests still pass. (The hash's unhandled program-logic cases / commented-out branches are left as-is here; completing them is a follow-up.) --- src/ecAlphaInvHashtbl.ml | 145 ++++++++++++++++++++++++++++++++++++++ src/ecAlphaInvHashtbl.mli | 15 ++++ src/ecCircuits.ml | 131 +--------------------------------- 3 files changed, 161 insertions(+), 130 deletions(-) create mode 100644 src/ecAlphaInvHashtbl.ml create mode 100644 src/ecAlphaInvHashtbl.mli diff --git a/src/ecAlphaInvHashtbl.ml b/src/ecAlphaInvHashtbl.ml new file mode 100644 index 0000000000..d5249a9497 --- /dev/null +++ b/src/ecAlphaInvHashtbl.ml @@ -0,0 +1,145 @@ +(* -------------------------------------------------------------------- *) +(* Hash-table over formulas whose key equality is alpha-equivalence (and + conversion) in a fixed hypotheses context. The companion [hash] is + invariant under the renaming of bound variables: when descending under + a binder, each bound variable is substituted by a canonical de-Bruijn + level identifier before being hashed, so that alpha-equivalent + formulas hash equal (a requirement for [Hashtbl.Make]). *) + +(* -------------------------------------------------------------------- *) +open EcUtils +open EcAst +open EcCoreFol +open EcIdent +open EcEnv.LDecl + +(* -------------------------------------------------------------------- *) +module Map = Batteries.Map + +(* -------------------------------------------------------------------- *) +module Make (Ctxt : sig val hyps : hyps end) = struct + type state = { + level: int; + subst: EcSubst.subst; + } + + let empty_state : state = {level = 0; subst = EcSubst.empty} + + let bruijn_idents : (int, ident) Map.t ref = ref Map.empty + + let clean_bruijn_idents : unit -> unit = + fun () -> bruijn_idents := Map.empty + + let ident_of_debruijn_level (i: int) : ident = + match Map.find_opt i !bruijn_idents with + | Some id -> id + | None -> let id = create (string_of_int i) in + bruijn_idents := Map.add i id !bruijn_idents; + id + + let add_to_state (id: ident) (ty: ty) (st: state) = + let new_id = ident_of_debruijn_level st.level in + let level = st.level + 1 in + let subst = EcSubst.add_flocal st.subst id (f_local new_id ty) in + { level; subst }, new_id + + let rec hash (st:state) (f: form) : int = + let hnode = match f.f_node with + | Fquant (qnt, bnds, f) -> + let st, bnds = + List.fold_left_map (fun st (orig_id, gty) -> + match gty with + | GTty ty -> + let st, new_id = add_to_state orig_id ty st in + st, (new_id, gty) + | _ -> + st, (orig_id, gty) + ) st bnds + in Why3.Hashcons.combine2 (qt_hash qnt) (b_hash bnds) (hash st (EcSubst.subst_form st.subst f)) + | Fif (cond, tb, fb) -> + let hash = hash st in + Why3.Hashcons.combine2 (hash cond) (hash tb) (hash fb) + | Fmatch (_, _, _) -> assert false + | Flet (lp, value, body) -> + begin match lp with + | LSymbol (orig_id, ty) -> + let hval = hash st value in + let st, new_id = add_to_state orig_id ty st in + let hbody = hash st (EcSubst.subst_form st.subst body) in + let hlp = lp_hash (LSymbol (new_id, ty)) in + Why3.Hashcons.combine2 hlp hval hbody + | LTuple bnds -> + let hval = hash st value in + let st, new_ids = List.fold_left_map (fun st (id, ty) -> add_to_state id ty st) st bnds in + let hbody = hash st (EcSubst.subst_form st.subst body) in + let hbinds = lp_hash @@ LTuple (List.combine new_ids (List.snd bnds)) in + Why3.Hashcons.combine2 hbinds hval hbody + | LRecord (_, _) -> assert false + end + | Fapp (op, args) -> + let hop = hash st op in + Why3.Hashcons.combine_list (hash st) hop args + | Ftuple comps -> + Why3.Hashcons.combine_list (hash st) 0 comps + | Fproj (tp, i) -> + Why3.Hashcons.combine (hash st tp) i + | FhoareF _hF -> + assert false +(* FIXME: do we want this case and the one below? + let hpre = doit st (hf_pr hF).inv in + let hpo = doit st (hf_po hF).inv in + let hf = x_hash hF.hf_f in + let hm = id_hash hF.hf_m in + Why3.Hashcons.combine3 hpre hpo hf hm +*) + | FhoareS _hS -> + assert false +(* + let hme = me_hash hS.hs_m in + let hpre = doit st (hs_pr hS).inv in + let hpo = doit st (hs_po hS).inv in + let hs = s_hash + f_hoareS me {inv=npre;m} hs.hs_s {inv=npo;m} +*) + | FbdHoareF _ -> assert false + | FbdHoareS _ -> assert false + | FeHoareF _ -> assert false + | FeHoareS _ -> assert false + | FequivF _ef -> + assert false +(* FIXME: do we want these cases? + let npre = doit st (ef_pr ef).inv in + let npo = doit st (ef_po ef).inv in + f_equivF {inv=npre;ml=ef.ef_ml;mr=ef.ef_mr} ef.ef_fl ef.ef_fr {inv=npo;ml=ef.ef_ml;mr=ef.ef_mr} +*) + | FequivS _es -> + assert false +(* + let ml, mel = es.es_ml in + let mr, mer = es.es_mr in + let npre = doit st (es_pr es).inv in + let npo = doit st (es_po es).inv in + f_equivS mel mer {inv=npre;ml;mr} es.es_sl es.es_sr {inv=npo;ml;mr} +*) + | FeagerF _ -> assert false + | Fpr _ -> assert false + | Fint _ + | Flocal _ + | Fpvar (_, _) + | Fglob (_, _) + | Fop (_, _) -> f_hash f (* FIXME: maybe do these cases as well? *) + in Why3.Hashcons.combine hnode (ty_hash f.f_ty) + + module Htbl = Batteries.Hashtbl.Make(struct + type t = form + + let equal f1 f2 = EcReduction.is_alpha_eq Ctxt.hyps f1 f2 + + let hash f = hash empty_state f + + end) + + let clear htbl = + clean_bruijn_idents (); + Htbl.clear htbl +end diff --git a/src/ecAlphaInvHashtbl.mli b/src/ecAlphaInvHashtbl.mli new file mode 100644 index 0000000000..2ae6d76b11 --- /dev/null +++ b/src/ecAlphaInvHashtbl.mli @@ -0,0 +1,15 @@ +(* -------------------------------------------------------------------- *) +open EcAst + +(* -------------------------------------------------------------------- *) +(* Hash-table over formulas keyed by alpha-equivalence (and conversion) + in a fixed hypotheses context [Ctxt.hyps]. The hash is invariant under + the renaming of bound variables, so alpha-equivalent formulas share a + table entry. *) +module Make (Ctxt : sig val hyps : EcEnv.LDecl.hyps end) : sig + (* The formula-keyed hash-table (keys compared up to alpha-equivalence). *) + module Htbl : Batteries.Hashtbl.S with type key = form + + (* Clear the table (and the internal de-Bruijn ident cache). *) + val clear : 'a Htbl.t -> unit +end diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index c2b2b0762b..6946b768e6 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -27,135 +27,6 @@ let circ_red (hyps: hyps) = let base_red = EcReduction.full_red in `No) } -module AInvFHashtbl(Ctxt: sig val hyps: hyps end) = struct - type state = { - level: int; - subst: EcSubst.subst; - } - - let empty_state : state = {level = 0; subst = EcSubst.empty} - - let bruijn_idents : (int, ident) Map.t ref = ref Map.empty - - let clean_bruijn_idents : unit -> unit = - fun () -> bruijn_idents := Map.empty - - let ident_of_debruijn_level (i: int) : ident = - match Map.find_opt i !bruijn_idents with - | Some id -> id - | None -> let id = create (string_of_int i) in - bruijn_idents := Map.add i id !bruijn_idents; - id - - let add_to_state (id: ident) (ty: ty) (st: state) = - let new_id = ident_of_debruijn_level st.level in - let level = st.level + 1 in - let subst = EcSubst.add_flocal st.subst id (f_local new_id ty) in - { level; subst }, new_id - - (* FIXME: maybe don't allow external calls with a state argument *) - let rec hash (st:state) (f: form) : int = - let hnode = match f.f_node with - | Fquant (qnt, bnds, f) -> - let st, bnds = - List.fold_left_map (fun st (orig_id, gty) -> - match gty with - | GTty ty -> - let st, new_id = add_to_state orig_id ty st in - st, (new_id, gty) - | _ -> - st, (orig_id, gty) - ) st bnds - in Why3.Hashcons.combine2 (qt_hash qnt) (b_hash bnds) (hash st (EcSubst.subst_form st.subst f)) - | Fif (cond, tb, fb) -> - let hash = hash st in - Why3.Hashcons.combine2 (hash cond) (hash tb) (hash fb) - | Fmatch (_, _, _) -> assert false - | Flet (lp, value, body) -> - begin match lp with - | LSymbol (orig_id, ty) -> - let hval = hash st value in - let st, new_id = add_to_state orig_id ty st in - let hbody = hash st (EcSubst.subst_form st.subst body) in - let hlp = lp_hash (LSymbol (new_id, ty)) in - Why3.Hashcons.combine2 hlp hval hbody - | LTuple bnds -> - let hval = hash st value in - let st, new_ids = List.fold_left_map (fun st (id, ty) -> add_to_state id ty st) st bnds in - let hbody = hash st (EcSubst.subst_form st.subst body) in - let hbinds = lp_hash @@ LTuple (List.combine new_ids (List.snd bnds)) in - Why3.Hashcons.combine2 hbinds hval hbody - | LRecord (_, _) -> assert false - end - | Fapp (op, args) -> - let hop = hash st op in - Why3.Hashcons.combine_list (hash st) hop args - | Ftuple comps -> - Why3.Hashcons.combine_list (hash st) 0 comps - | Fproj (tp, i) -> - Why3.Hashcons.combine (hash st tp) i - | FhoareF _hF -> - assert false -(* FIXME: do we want this case and the one below? - let hpre = doit st (hf_pr hF).inv in - let hpo = doit st (hf_po hF).inv in - let hf = x_hash hF.hf_f in - let hm = id_hash hF.hf_m in - Why3.Hashcons.combine3 hpre hpo hf hm -*) - | FhoareS _hS -> - assert false -(* - let hme = me_hash hS.hs_m in - let hpre = doit st (hs_pr hS).inv in - let hpo = doit st (hs_po hS).inv in - let hs = s_hash - f_hoareS me {inv=npre;m} hs.hs_s {inv=npo;m} -*) - | FbdHoareF _ -> assert false - | FbdHoareS _ -> assert false - | FeHoareF _ -> assert false - | FeHoareS _ -> assert false - | FequivF _ef -> - assert false -(* FIXME: do we want these cases? - let npre = doit st (ef_pr ef).inv in - let npo = doit st (ef_po ef).inv in - f_equivF {inv=npre;ml=ef.ef_ml;mr=ef.ef_mr} ef.ef_fl ef.ef_fr {inv=npo;ml=ef.ef_ml;mr=ef.ef_mr} -*) - | FequivS _es -> - assert false -(* - let ml, mel = es.es_ml in - let mr, mer = es.es_mr in - let npre = doit st (es_pr es).inv in - let npo = doit st (es_po es).inv in - f_equivS mel mer {inv=npre;ml;mr} es.es_sl es.es_sr {inv=npo;ml;mr} -*) - | FeagerF _ -> assert false - | Fpr _ -> assert false - | Fint _ - | Flocal _ - | Fpvar (_, _) - | Fglob (_, _) - | Fop (_, _) -> f_hash f (* FIXME: maybe do these cases as well? *) - in Why3.Hashcons.combine hnode (ty_hash f.f_ty) - - module Htbl = Batteries.Hashtbl.Make(struct - type t = form - - let equal f1 f2 = EcReduction.is_alpha_eq Ctxt.hyps f1 f2 - - let hash f = hash empty_state f - - end) - - let clear htbl = - clean_bruijn_idents (); - Htbl.clear htbl -end - - (* -------------------------------------------------------------------- *) type circuit_conversion_call = [ | `Convert of form @@ -623,7 +494,7 @@ let circuit_of_form (f_ : EcAst.form) : circuit = - let module AIFH = AInvFHashtbl(struct let hyps = hyps end) in + let module AIFH = EcAlphaInvHashtbl.Make(struct let hyps = hyps end) in (* Form level cache, local to each high-level call *) let cache : circuit AIFH.Htbl.t = AIFH.Htbl.create 700 in From 1aa13036faa171abefba5f24ac8fe4e87a9d6ddd Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 1 Jun 2026 09:21:12 +0200 Subject: [PATCH 063/145] EcAlphaInvHashtbl: bounded de-Bruijn-level hash; complete all cases Rewrite the alpha-invariant formula hash: - Hash bound occurrences by the de-Bruijn *level* of their binder (a stable integer) instead of substituting a canonical ident. This drops the per-binder EcSubst.subst_form (which rebuilt the whole body at every binder) and the module-global bruijn_idents table entirely. - Bound the traversal like OCaml's Hashtbl.hash (= hash_param 10 100): fold at most 10 meaningful leaves, visit at most 100 nodes, so hashing is O(1) on arbitrarily large formulas. Bounding only coarsens the hash, which stays consistent with the is_alpha_eq key equality. - Complete the previously-asserting cases: Fmatch and Flet/LRecord are hashed fully and alpha-correctly; the memory-binding forms (FhoareS, FequivS, Fpr, ...) -- which circuit translation rejects and never caches -- get a coarse, memory-invariant per-kind hash. No behavior change observable in the test-suite (the circuit cache only keys first-order/bitvector forms); 49/50 tests/ pass, the one failure (ext_test.ec) is a pre-existing parse error unrelated to this change. --- src/ecAlphaInvHashtbl.ml | 271 +++++++++++++++++++++------------------ 1 file changed, 143 insertions(+), 128 deletions(-) diff --git a/src/ecAlphaInvHashtbl.ml b/src/ecAlphaInvHashtbl.ml index d5249a9497..aa35c8cd91 100644 --- a/src/ecAlphaInvHashtbl.ml +++ b/src/ecAlphaInvHashtbl.ml @@ -1,145 +1,160 @@ (* -------------------------------------------------------------------- *) -(* Hash-table over formulas whose key equality is alpha-equivalence (and - conversion) in a fixed hypotheses context. The companion [hash] is - invariant under the renaming of bound variables: when descending under - a binder, each bound variable is substituted by a canonical de-Bruijn - level identifier before being hashed, so that alpha-equivalent - formulas hash equal (a requirement for [Hashtbl.Make]). *) +(* Hash-table over formulas whose key equality is alpha-equivalence in a + fixed hypotheses context. + + The companion [hash] is invariant under the renaming of bound + variables: a bound occurrence is hashed by the de-Bruijn *level* of + its binder (an integer, intrinsically stable) rather than by its name, + so alpha-equivalent formulas hash equal -- the requirement imposed by + [Hashtbl.Make]. Free variables, operators and types are stable under + alpha-renaming and are hashed as-is. + + Like [Hashtbl.hash] (= [Hashtbl.hash_param 10 100]) the traversal is + *bounded*: it folds at most [nmeaningful] leaves and visits at most + [nnodes] nodes, so hashing is O(1) on arbitrarily large formulas. A + bounded hash is still consistent with the equality (it only ever + *coarsens*, never distinguishes alpha-equal forms); on a bucket + collision [Hashtbl.Make] falls back to [is_alpha_eq]. *) (* -------------------------------------------------------------------- *) open EcUtils open EcAst -open EcCoreFol open EcIdent open EcEnv.LDecl (* -------------------------------------------------------------------- *) -module Map = Batteries.Map +(* Same budget as [Hashtbl.hash]. *) +let nmeaningful = 10 +let nnodes = 100 (* -------------------------------------------------------------------- *) module Make (Ctxt : sig val hyps : hyps end) = struct - type state = { - level: int; - subst: EcSubst.subst; - } - - let empty_state : state = {level = 0; subst = EcSubst.empty} - - let bruijn_idents : (int, ident) Map.t ref = ref Map.empty - - let clean_bruijn_idents : unit -> unit = - fun () -> bruijn_idents := Map.empty - - let ident_of_debruijn_level (i: int) : ident = - match Map.find_opt i !bruijn_idents with - | Some id -> id - | None -> let id = create (string_of_int i) in - bruijn_idents := Map.add i id !bruijn_idents; - id - - let add_to_state (id: ident) (ty: ty) (st: state) = - let new_id = ident_of_debruijn_level st.level in - let level = st.level + 1 in - let subst = EcSubst.add_flocal st.subst id (f_local new_id ty) in - { level; subst }, new_id - - let rec hash (st:state) (f: form) : int = - let hnode = match f.f_node with - | Fquant (qnt, bnds, f) -> - let st, bnds = - List.fold_left_map (fun st (orig_id, gty) -> - match gty with - | GTty ty -> - let st, new_id = add_to_state orig_id ty st in - st, (new_id, gty) - | _ -> - st, (orig_id, gty) - ) st bnds - in Why3.Hashcons.combine2 (qt_hash qnt) (b_hash bnds) (hash st (EcSubst.subst_form st.subst f)) - | Fif (cond, tb, fb) -> - let hash = hash st in - Why3.Hashcons.combine2 (hash cond) (hash tb) (hash fb) - | Fmatch (_, _, _) -> assert false - | Flet (lp, value, body) -> - begin match lp with - | LSymbol (orig_id, ty) -> - let hval = hash st value in - let st, new_id = add_to_state orig_id ty st in - let hbody = hash st (EcSubst.subst_form st.subst body) in - let hlp = lp_hash (LSymbol (new_id, ty)) in - Why3.Hashcons.combine2 hlp hval hbody - | LTuple bnds -> - let hval = hash st value in - let st, new_ids = List.fold_left_map (fun st (id, ty) -> add_to_state id ty st) st bnds in - let hbody = hash st (EcSubst.subst_form st.subst body) in - let hbinds = lp_hash @@ LTuple (List.combine new_ids (List.snd bnds)) in - Why3.Hashcons.combine2 hbinds hval hbody - | LRecord (_, _) -> assert false - end - | Fapp (op, args) -> - let hop = hash st op in - Why3.Hashcons.combine_list (hash st) hop args - | Ftuple comps -> - Why3.Hashcons.combine_list (hash st) 0 comps - | Fproj (tp, i) -> - Why3.Hashcons.combine (hash st tp) i - | FhoareF _hF -> - assert false -(* FIXME: do we want this case and the one below? - let hpre = doit st (hf_pr hF).inv in - let hpo = doit st (hf_po hF).inv in - let hf = x_hash hF.hf_f in - let hm = id_hash hF.hf_m in - Why3.Hashcons.combine3 hpre hpo hf hm -*) - | FhoareS _hS -> - assert false -(* - let hme = me_hash hS.hs_m in - let hpre = doit st (hs_pr hS).inv in - let hpo = doit st (hs_po hS).inv in - let hs = s_hash - f_hoareS me {inv=npre;m} hs.hs_s {inv=npo;m} -*) - | FbdHoareF _ -> assert false - | FbdHoareS _ -> assert false - | FeHoareF _ -> assert false - | FeHoareS _ -> assert false - | FequivF _ef -> - assert false -(* FIXME: do we want these cases? - let npre = doit st (ef_pr ef).inv in - let npo = doit st (ef_po ef).inv in - f_equivF {inv=npre;ml=ef.ef_ml;mr=ef.ef_mr} ef.ef_fl ef.ef_fr {inv=npo;ml=ef.ef_ml;mr=ef.ef_mr} -*) - | FequivS _es -> - assert false -(* - let ml, mel = es.es_ml in - let mr, mer = es.es_mr in - let npre = doit st (es_pr es).inv in - let npo = doit st (es_po es).inv in - f_equivS mel mer {inv=npre;ml;mr} es.es_sl es.es_sr {inv=npo;ml;mr} -*) - | FeagerF _ -> assert false - | Fpr _ -> assert false - | Fint _ - | Flocal _ - | Fpvar (_, _) - | Fglob (_, _) - | Fop (_, _) -> f_hash f (* FIXME: maybe do these cases as well? *) - in Why3.Hashcons.combine hnode (ty_hash f.f_ty) - - module Htbl = Batteries.Hashtbl.Make(struct - type t = form - let equal f1 f2 = EcReduction.is_alpha_eq Ctxt.hyps f1 f2 + (* [bound] maps each in-scope bound variable to the de-Bruijn level of + its binder; [depth] is the number of binders entered so far (the + level to assign to the next one). *) + type env = { + depth : int; + bound : int Mid.t; + } + + let empty_env : env = { depth = 0; bound = Mid.empty } + + let bind_id (e : env) (id : ident) : env = + { depth = e.depth + 1; bound = Mid.add id e.depth e.bound } + + let bind_ids (e : env) (ids : ident list) : env = + List.fold_left bind_id e ids + + let hash_form (f0 : form) : int = + (* Mutable budget, mirroring [Hashtbl.hash_param]. *) + let nmeaningful = ref nmeaningful in + let nnodes = ref nnodes in + + let acc = ref 0 in + let combine (h : int) = acc := Why3.Hashcons.combine !acc h in + + (* Fold a "meaningful" leaf, respecting the [nmeaningful] budget. *) + let leaf (h : int) = + if !nmeaningful > 0 then begin + decr nmeaningful; combine h + end + in + + let rec hash (e : env) (f : form) : unit = + if !nnodes <= 0 || !nmeaningful <= 0 then () else begin + decr nnodes; + (* The result type is always (cheaply) folded in: it distinguishes + e.g. [fun (x:bool)=>x] from [fun (x:int)=>x]. *) + leaf (ty_hash f.f_ty); + match f.f_node with + | Fint i -> + leaf (EcBigInt.hash i) + + | Flocal id -> + (* Bound -> hash the binder's level (alpha-invariant); + free -> hash the identifier. *) + leaf (match Mid.find_opt id e.bound with + | Some lvl -> Why3.Hashcons.combine 1 lvl + | None -> Why3.Hashcons.combine 2 (id_hash id)) + + | Fpvar (pv, _m) -> + (* The memory is alpha-bindable; ignore it, keep the variable. *) + leaf (pv_hash pv) - let hash f = hash empty_state f + | Fglob (mp, _m) -> + leaf (id_hash mp) - end) + | Fop (p, tys) -> + leaf (EcPath.p_hash p); + List.iter (fun ty -> leaf (ty_hash ty)) tys + + | Fif (c, t, f) -> + hash e c; hash e t; hash e f + + | Fmatch (c, bs, ty) -> + leaf (ty_hash ty); + hash e c; List.iter (hash e) bs + + | Fquant (qt, bd, f) -> + leaf (qt_hash qt); + let e = + List.fold_left (fun e (id, gty) -> + leaf (gty_hash gty); bind_id e id) e bd + in hash e f + + | Flet (lp, v, body) -> + hash e v; + let e = + match lp with + | LSymbol (id, ty) -> leaf (ty_hash ty); bind_id e id + | LTuple ids -> + List.fold_left + (fun e (id, ty) -> leaf (ty_hash ty); bind_id e id) e ids + | LRecord (p, ids) -> + leaf (EcPath.p_hash p); + List.fold_left (fun e (id, ty) -> + leaf (ty_hash ty); + match id with Some id -> bind_id e id | None -> e) e ids + in hash e body + + | Fapp (f, args) -> + hash e f; List.iter (hash e) args + + | Ftuple comps -> + List.iter (hash e) comps + + | Fproj (f, i) -> + leaf i; hash e f + + (* Forms binding memories / containing statements. These never + reach the circuit cache (circuit translation rejects them), so + a coarse, memory-invariant hash on the kind + result type is + enough: it is trivially consistent with [is_alpha_eq] (it can + only coarsen) and avoids canonicalizing memories and hashing + statements. *) + | FhoareF _ -> leaf 101 + | FhoareS _ -> leaf 102 + | FbdHoareF _ -> leaf 103 + | FbdHoareS _ -> leaf 104 + | FeHoareF _ -> leaf 105 + | FeHoareS _ -> leaf 106 + | FequivF _ -> leaf 107 + | FequivS _ -> leaf 108 + | FeagerF _ -> leaf 109 + | Fpr _ -> leaf 110 + end + in + + hash empty_env f0; + !acc + + module Htbl = Batteries.Hashtbl.Make(struct + type t = form + + let equal f1 f2 = EcReduction.is_alpha_eq Ctxt.hyps f1 f2 + let hash f = hash_form f + end) - let clear htbl = - clean_bruijn_idents (); - Htbl.clear htbl + let clear htbl = Htbl.clear htbl end From 678adb8827a72ac688768714478803266ff360c0 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 1 Jun 2026 09:27:02 +0200 Subject: [PATCH 064/145] EcAlphaInvHashtbl: drop the functor; pass hyps to table creation The hash is hypotheses-independent; only the key equality (is_alpha_eq) needs the context. So replace the Make(hyps) functor with a plain module whose 'a t carries the hyps and create/add/find_opt/clear take/use it. Entries are bucketed by the bounded alpha-invariant hash; within a bucket is_alpha_eq selects the key. ecCircuits uses EcAlphaInvHashtbl.create hyps / add / find_opt / clear directly. No behavior change (49/50 tests/, ext_test.ec pre-existing parse error). --- src/ecAlphaInvHashtbl.ml | 296 ++++++++++++++++++++------------------ src/ecAlphaInvHashtbl.mli | 28 ++-- src/ecCircuits.ml | 10 +- 3 files changed, 177 insertions(+), 157 deletions(-) diff --git a/src/ecAlphaInvHashtbl.ml b/src/ecAlphaInvHashtbl.ml index aa35c8cd91..770c978b13 100644 --- a/src/ecAlphaInvHashtbl.ml +++ b/src/ecAlphaInvHashtbl.ml @@ -2,25 +2,27 @@ (* Hash-table over formulas whose key equality is alpha-equivalence in a fixed hypotheses context. - The companion [hash] is invariant under the renaming of bound - variables: a bound occurrence is hashed by the de-Bruijn *level* of - its binder (an integer, intrinsically stable) rather than by its name, - so alpha-equivalent formulas hash equal -- the requirement imposed by - [Hashtbl.Make]. Free variables, operators and types are stable under - alpha-renaming and are hashed as-is. + The hash is invariant under the renaming of bound variables: a bound + occurrence is hashed by the de-Bruijn *level* of its binder (an + integer, intrinsically stable) rather than by its name, so + alpha-equivalent formulas hash equal. Free variables, operators and + types are stable under alpha-renaming and are hashed as-is. Like [Hashtbl.hash] (= [Hashtbl.hash_param 10 100]) the traversal is *bounded*: it folds at most [nmeaningful] leaves and visits at most [nnodes] nodes, so hashing is O(1) on arbitrarily large formulas. A - bounded hash is still consistent with the equality (it only ever - *coarsens*, never distinguishes alpha-equal forms); on a bucket - collision [Hashtbl.Make] falls back to [is_alpha_eq]. *) + bounded hash only ever *coarsens* (it never distinguishes alpha-equal + forms); collisions are resolved by [is_alpha_eq]. + + The context [hyps] is needed only by the equality ([is_alpha_eq] + compares program variables / xpaths / statements relative to its + environment), so it is supplied at table creation rather than via a + functor. *) (* -------------------------------------------------------------------- *) open EcUtils open EcAst open EcIdent -open EcEnv.LDecl (* -------------------------------------------------------------------- *) (* Same budget as [Hashtbl.hash]. *) @@ -28,133 +30,147 @@ let nmeaningful = 10 let nnodes = 100 (* -------------------------------------------------------------------- *) -module Make (Ctxt : sig val hyps : hyps end) = struct - - (* [bound] maps each in-scope bound variable to the de-Bruijn level of - its binder; [depth] is the number of binders entered so far (the - level to assign to the next one). *) - type env = { - depth : int; - bound : int Mid.t; - } - - let empty_env : env = { depth = 0; bound = Mid.empty } - - let bind_id (e : env) (id : ident) : env = - { depth = e.depth + 1; bound = Mid.add id e.depth e.bound } - - let bind_ids (e : env) (ids : ident list) : env = - List.fold_left bind_id e ids - - let hash_form (f0 : form) : int = - (* Mutable budget, mirroring [Hashtbl.hash_param]. *) - let nmeaningful = ref nmeaningful in - let nnodes = ref nnodes in - - let acc = ref 0 in - let combine (h : int) = acc := Why3.Hashcons.combine !acc h in - - (* Fold a "meaningful" leaf, respecting the [nmeaningful] budget. *) - let leaf (h : int) = - if !nmeaningful > 0 then begin - decr nmeaningful; combine h - end - in - - let rec hash (e : env) (f : form) : unit = - if !nnodes <= 0 || !nmeaningful <= 0 then () else begin - decr nnodes; - (* The result type is always (cheaply) folded in: it distinguishes - e.g. [fun (x:bool)=>x] from [fun (x:int)=>x]. *) - leaf (ty_hash f.f_ty); - match f.f_node with - | Fint i -> - leaf (EcBigInt.hash i) - - | Flocal id -> - (* Bound -> hash the binder's level (alpha-invariant); - free -> hash the identifier. *) - leaf (match Mid.find_opt id e.bound with - | Some lvl -> Why3.Hashcons.combine 1 lvl - | None -> Why3.Hashcons.combine 2 (id_hash id)) - - | Fpvar (pv, _m) -> - (* The memory is alpha-bindable; ignore it, keep the variable. *) - leaf (pv_hash pv) - - | Fglob (mp, _m) -> - leaf (id_hash mp) - - | Fop (p, tys) -> - leaf (EcPath.p_hash p); - List.iter (fun ty -> leaf (ty_hash ty)) tys - - | Fif (c, t, f) -> - hash e c; hash e t; hash e f - - | Fmatch (c, bs, ty) -> - leaf (ty_hash ty); - hash e c; List.iter (hash e) bs - - | Fquant (qt, bd, f) -> - leaf (qt_hash qt); - let e = - List.fold_left (fun e (id, gty) -> - leaf (gty_hash gty); bind_id e id) e bd - in hash e f - - | Flet (lp, v, body) -> - hash e v; - let e = - match lp with - | LSymbol (id, ty) -> leaf (ty_hash ty); bind_id e id - | LTuple ids -> - List.fold_left - (fun e (id, ty) -> leaf (ty_hash ty); bind_id e id) e ids - | LRecord (p, ids) -> - leaf (EcPath.p_hash p); - List.fold_left (fun e (id, ty) -> - leaf (ty_hash ty); - match id with Some id -> bind_id e id | None -> e) e ids - in hash e body - - | Fapp (f, args) -> - hash e f; List.iter (hash e) args - - | Ftuple comps -> - List.iter (hash e) comps - - | Fproj (f, i) -> - leaf i; hash e f - - (* Forms binding memories / containing statements. These never - reach the circuit cache (circuit translation rejects them), so - a coarse, memory-invariant hash on the kind + result type is - enough: it is trivially consistent with [is_alpha_eq] (it can - only coarsen) and avoids canonicalizing memories and hashing - statements. *) - | FhoareF _ -> leaf 101 - | FhoareS _ -> leaf 102 - | FbdHoareF _ -> leaf 103 - | FbdHoareS _ -> leaf 104 - | FeHoareF _ -> leaf 105 - | FeHoareS _ -> leaf 106 - | FequivF _ -> leaf 107 - | FequivS _ -> leaf 108 - | FeagerF _ -> leaf 109 - | Fpr _ -> leaf 110 - end - in - - hash empty_env f0; - !acc - - module Htbl = Batteries.Hashtbl.Make(struct - type t = form - - let equal f1 f2 = EcReduction.is_alpha_eq Ctxt.hyps f1 f2 - let hash f = hash_form f - end) - - let clear htbl = Htbl.clear htbl -end +(* [bound] maps each in-scope bound variable to the de-Bruijn level of + its binder; [depth] is the number of binders entered so far (the level + to assign to the next one). *) +type env = { + depth : int; + bound : int Mid.t; +} + +let empty_env : env = { depth = 0; bound = Mid.empty } + +let bind_id (e : env) (id : ident) : env = + { depth = e.depth + 1; bound = Mid.add id e.depth e.bound } + +(* -------------------------------------------------------------------- *) +let hash (f0 : form) : int = + (* Mutable budget, mirroring [Hashtbl.hash_param]. *) + let nmeaningful = ref nmeaningful in + let nnodes = ref nnodes in + + let acc = ref 0 in + let combine (h : int) = acc := Why3.Hashcons.combine !acc h in + + (* Fold a "meaningful" leaf, respecting the [nmeaningful] budget. *) + let leaf (h : int) = + if !nmeaningful > 0 then begin + decr nmeaningful; combine h + end + in + + let rec hash (e : env) (f : form) : unit = + if !nnodes <= 0 || !nmeaningful <= 0 then () else begin + decr nnodes; + (* The result type is always (cheaply) folded in: it distinguishes + e.g. [fun (x:bool)=>x] from [fun (x:int)=>x]. *) + leaf (ty_hash f.f_ty); + match f.f_node with + | Fint i -> + leaf (EcBigInt.hash i) + + | Flocal id -> + (* Bound -> hash the binder's level (alpha-invariant); + free -> hash the identifier. *) + leaf (match Mid.find_opt id e.bound with + | Some lvl -> Why3.Hashcons.combine 1 lvl + | None -> Why3.Hashcons.combine 2 (id_hash id)) + + | Fpvar (pv, _m) -> + (* The memory is alpha-bindable; ignore it, keep the variable. *) + leaf (pv_hash pv) + + | Fglob (mp, _m) -> + leaf (id_hash mp) + + | Fop (p, tys) -> + leaf (EcPath.p_hash p); + List.iter (fun ty -> leaf (ty_hash ty)) tys + + | Fif (c, t, f) -> + hash e c; hash e t; hash e f + + | Fmatch (c, bs, ty) -> + leaf (ty_hash ty); + hash e c; List.iter (hash e) bs + + | Fquant (qt, bd, f) -> + leaf (qt_hash qt); + let e = + List.fold_left (fun e (id, gty) -> + leaf (gty_hash gty); bind_id e id) e bd + in hash e f + + | Flet (lp, v, body) -> + hash e v; + let e = + match lp with + | LSymbol (id, ty) -> leaf (ty_hash ty); bind_id e id + | LTuple ids -> + List.fold_left + (fun e (id, ty) -> leaf (ty_hash ty); bind_id e id) e ids + | LRecord (p, ids) -> + leaf (EcPath.p_hash p); + List.fold_left (fun e (id, ty) -> + leaf (ty_hash ty); + match id with Some id -> bind_id e id | None -> e) e ids + in hash e body + + | Fapp (f, args) -> + hash e f; List.iter (hash e) args + + | Ftuple comps -> + List.iter (hash e) comps + + | Fproj (f, i) -> + leaf i; hash e f + + (* Forms binding memories / containing statements. These never + reach the circuit cache (circuit translation rejects them), so a + coarse, memory-invariant hash on the kind + result type is + enough: it is trivially consistent with [is_alpha_eq] (it can + only coarsen) and avoids canonicalizing memories and hashing + statements. *) + | FhoareF _ -> leaf 101 + | FhoareS _ -> leaf 102 + | FbdHoareF _ -> leaf 103 + | FbdHoareS _ -> leaf 104 + | FeHoareF _ -> leaf 105 + | FeHoareS _ -> leaf 106 + | FequivF _ -> leaf 107 + | FequivS _ -> leaf 108 + | FeagerF _ -> leaf 109 + | Fpr _ -> leaf 110 + end + in + + hash empty_env f0; + !acc + +(* -------------------------------------------------------------------- *) +(* A formula-keyed table. Entries are bucketed by [hash]; within a bucket + the alpha-equivalence [is_alpha_eq Ctxt.hyps] selects the matching + key. *) +type 'a t = { + hyps : EcEnv.LDecl.hyps; + tbl : (int, (form * 'a) list) Hashtbl.t; +} + +let create (hyps : EcEnv.LDecl.hyps) (size : int) : 'a t = + { hyps; tbl = Hashtbl.create size } + +let clear (t : 'a t) : unit = + Hashtbl.clear t.tbl + +let find_opt (t : 'a t) (f : form) : 'a option = + match Hashtbl.find_opt t.tbl (hash f) with + | None -> None + | Some bucket -> + match List.find_opt (fun (g, _) -> EcReduction.is_alpha_eq t.hyps f g) bucket with + | None -> None + | Some (_, v) -> Some v + +let add (t : 'a t) (f : form) (v : 'a) : unit = + let h = hash f in + let bucket = odfl [] (Hashtbl.find_opt t.tbl h) in + Hashtbl.replace t.tbl h ((f, v) :: bucket) diff --git a/src/ecAlphaInvHashtbl.mli b/src/ecAlphaInvHashtbl.mli index 2ae6d76b11..0a163364c4 100644 --- a/src/ecAlphaInvHashtbl.mli +++ b/src/ecAlphaInvHashtbl.mli @@ -2,14 +2,20 @@ open EcAst (* -------------------------------------------------------------------- *) -(* Hash-table over formulas keyed by alpha-equivalence (and conversion) - in a fixed hypotheses context [Ctxt.hyps]. The hash is invariant under - the renaming of bound variables, so alpha-equivalent formulas share a - table entry. *) -module Make (Ctxt : sig val hyps : EcEnv.LDecl.hyps end) : sig - (* The formula-keyed hash-table (keys compared up to alpha-equivalence). *) - module Htbl : Batteries.Hashtbl.S with type key = form - - (* Clear the table (and the internal de-Bruijn ident cache). *) - val clear : 'a Htbl.t -> unit -end +(* A hash-table over formulas keyed by alpha-equivalence (in the + hypotheses context given at creation). Bound variables are hashed by + de-Bruijn level, so alpha-equivalent formulas share an entry. *) + +(* Alpha-invariant, bounded hash of a formula. *) +val hash : form -> int + +(* -------------------------------------------------------------------- *) +type 'a t + +(* [create hyps size] builds an empty table whose key equality is + [EcReduction.is_alpha_eq hyps]. *) +val create : EcEnv.LDecl.hyps -> int -> 'a t + +val clear : 'a t -> unit +val add : 'a t -> form -> 'a -> unit +val find_opt : 'a t -> form -> 'a option diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 6946b768e6..7d1af0a794 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -494,10 +494,8 @@ let circuit_of_form (f_ : EcAst.form) : circuit = - let module AIFH = EcAlphaInvHashtbl.Make(struct let hyps = hyps end) in - (* Form level cache, local to each high-level call *) - let cache : circuit AIFH.Htbl.t = AIFH.Htbl.create 700 in + let cache : circuit EcAlphaInvHashtbl.t = EcAlphaInvHashtbl.create hyps 700 in let op_cache : circuit Mp.t ref = ref Mp.empty in let redmode = circ_red hyps in let env = toenv hyps in @@ -598,7 +596,7 @@ let circuit_of_form | Fapp (f, fs) -> (* TODO: Maybe add cache statistics? *) (* TODO: Maybe cache all forms *) - begin match AIFH.Htbl.find_opt cache f_ with + begin match EcAlphaInvHashtbl.find_opt cache f_ with | Some circ -> circ | None -> let circ = begin match f with @@ -655,7 +653,7 @@ let circuit_of_form let fcs = List.map (doit st) fs in circuit_compose f_c fcs end in - AIFH.Htbl.add cache f_ circ; + EcAlphaInvHashtbl.add cache f_ circ; circ end @@ -768,7 +766,7 @@ let circuit_of_form (* State cleanup *) begin op_cache := Mp.empty; - AIFH.clear cache + EcAlphaInvHashtbl.clear cache end; res From 587d4fcdcd5e0820d77cf5fde593e8ae56055db1 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 1 Jun 2026 10:13:42 +0200 Subject: [PATCH 065/145] ecCircuits: consolidate op classification/dispatch Replace the boolean op_is_* predicates + re-querying dispatchers with single-lookup classifiers that return the bound-op data: - classify_baseop : env -> path -> baseop option (BBvOp | BSpec) - classify_paramop : env -> path -> paramop option (PBvOp | PArray | PBs) circuit_of_op / circuit_of_op_with_args now take the classified data, so they no longer re-query the circuit-bindings registry and no longer need the 'should be guarded by op_is_*' assert-false fallbacks. The Fop/Fapp call sites in circuit_of_form classify once. Removes the now-dead op_is_base/op_is_parametric_base, the per-family op_is_bvop/op_is_parametric_bvop/op_is_bsop/op_is_arrayop/op_has_spec/ is_of_int predicates, and the unused circuit_of_baseop/ circuit_of_parametric_baseop. Net -46 lines; no behavior change (49/50 tests/, ext_test.ec pre-existing parse error). --- src/ecCircuits.ml | 192 ++++++++++++++++++---------------------------- 1 file changed, 73 insertions(+), 119 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 7d1af0a794..47b023d6af 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -188,23 +188,6 @@ let input_of_type ~name (env: env) (t: ty) : circuit = (* Should correspond to QF_ABV *) module BVOps = struct let temp_symbol = "temp_circ_input" - - let is_of_int (env: env) (p: path) : bool = - match EcEnv.Circuit.reverse_bitstring_operator env p with - | Some (_, `OfInt) -> true - | _ -> false - - let op_is_parametric_bvop (env: env) (op: path) : bool = - match EcEnv.Circuit.lookup_bvoperator_path env op with - | Some { kind = `ASliceGet _ } - | Some { kind = `ASliceSet _ } - | Some { kind = `Extract _ } - | Some { kind = `Insert _ } - | Some { kind = `Map _ } - | Some { kind = `Get _ } - | Some { kind = `AInit _ } - | Some { kind = `Init _ } -> true - | _ -> false let circuit_of_parametric_bvop (env : env) (op: [`Path of path | `BvBind of EcDecl.crb_bvoperator]) (args: arg list) : circuit = let op = match op with @@ -216,31 +199,6 @@ module BVOps = struct in circuit_of_parametric_bvop op args - let op_is_bvop (env: env) (op : path) : bool = - match EcEnv.Circuit.lookup_bvoperator_path env op with - | Some { kind = `Add _ } | Some { kind = `Sub _ } - | Some { kind = `Mul _ } | Some { kind = `Div _ } - | Some { kind = `Rem _ } | Some { kind = `Shl _ } - | Some { kind = `Shr _ } | Some { kind = `Rol _ } - | Some { kind = `Shrs _ } | Some { kind = `Shls _ } - | Some { kind = `Ror _ } | Some { kind = `And _ } - | Some { kind = `Or _ } | Some { kind = `Xor _ } - | Some { kind = `Not _ } | Some { kind = `Lt _ } - | Some { kind = `Le _ } | Some { kind = `Extend _ } - | Some { kind = `Truncate _ } | Some { kind = `Concat _ } - | Some { kind = `A2B _ } | Some { kind = `B2A _ } - | Some { kind = `Opp _ } -> true - | Some { kind = - `ASliceGet _ - | `ASliceSet _ - | `Extract _ - | `Insert _ - | `Map _ - | `AInit _ - | `Get _ - | `Init _ } - | None -> false - let circuit_of_bvop (env: env) (op: [`Path of path | `BvBind of EcDecl.crb_bvoperator]) : circuit = let op = match op with | `BvBind op -> op @@ -256,11 +214,6 @@ open BVOps module BitstringOps = struct type binding = crb_bitstring_operator - let op_is_bsop (env: env) (op: path) : bool = - match EcEnv.Circuit.reverse_bitstring_operator env op with - | Some (_, `OfInt) -> true - | _ -> false - let circuit_of_bsop (env: env) (op: [`Path of path | `BSBinding of binding]) (args: arg list) : circuit = let bnd = match op with | `BSBinding bnd -> bnd @@ -269,7 +222,8 @@ module BitstringOps = struct | None -> circ_error (MissingOpBinding p) end in - (* assert false => should be guarded by a previous call to op_is_bsop *) + (* [classify_paramop] only ever yields the [`OfInt] bitstring + operator, so the other arms are unreachable here. *) match bnd with | _bs, `From -> assert false (* doesn't translate to circuit *) | {size = (_, Some size)}, `OfInt -> begin match args with @@ -289,13 +243,6 @@ module ArrayOps = struct type binding = crb_array_operator - let op_is_arrayop (env: env) (op: path) : bool = - match EcEnv.Circuit.reverse_array_operator env op with - | Some (_, `Get) -> true - | Some (_, `Set) -> true - | Some (_, `OfList) -> true - | _ -> false - let circuit_of_arrayop (env: env) (op: [`Path of path | `ABinding of binding]) (args: arg list) : circuit = let op = match op with | `ABinding bnd -> bnd @@ -304,7 +251,8 @@ module ArrayOps = struct | None -> circ_error (MissingOpBinding p) end in - (* assert false => should be guarded by a call to op_is_arrayop *) + (* [classify_paramop] only yields the [`Get]/[`Set]/[`OfList] array + operators, so the other arms are unreachable here. *) match op with | (_arr, `ToList) -> assert false (* We do not translate this to circuit *) | (_arr, `Get) -> begin match args with @@ -356,63 +304,63 @@ module CircuitSpec = struct let arg_tys, ret_ty = unroll_fty op.op_ty in let arg_tys = List.map (ctype_of_ty env) arg_tys in let ret_ty = ctype_of_ty env ret_ty in - circuit_from_spec ~name (arg_tys, ret_ty) c.circuit - - let op_has_spec env pth = - Option.is_some @@ EcEnv.Circuit.reverse_circuit env pth + circuit_from_spec ~name (arg_tys, ret_ty) c.circuit end open CircuitSpec -let op_is_base (env: env) (p: path) : bool = - op_is_bvop env p || - op_has_spec env p - -let circuit_of_baseop (env: env) (p: path) : circuit = - if op_is_bvop env p then - circuit_of_bvop env (`Path p) - else if op_has_spec env p then - circuit_from_spec env (`Path p) - else - assert false (* Should be guarded by call to op_is_base *) - -let op_is_parametric_base (env: env) (p: path) = - op_is_parametric_bvop env p || - op_is_arrayop env p || - op_is_bsop env p - -let circuit_of_parametric_baseop (env: env) (p: path) (args: arg list) : circuit = - if op_is_parametric_bvop env p then - circuit_of_parametric_bvop env (`Path p) args - else if op_is_arrayop env p then - circuit_of_arrayop env (`Path p) args - else if op_is_bsop env p then - circuit_of_bsop env (`Path p) args - else - assert false (* Should be guarded by call to op_is_parametric_base *) +(* A bound bv-operator is "parametric" (applied to constant arguments, + e.g. slice indices) or "base" (a plain bitvector operation) depending + on its kind. *) +let bvop_is_parametric (op : EcDecl.crb_bvoperator) : bool = + match op.kind with + | `ASliceGet _ | `ASliceSet _ | `Extract _ | `Insert _ + | `Map _ | `Get _ | `AInit _ | `Init _ -> true + | _ -> false -let circuit_of_op (env: env) (p: path) : circuit = - let op = try - EcEnv.Circuit.reverse_operator env p |> List.hd - with Failure _ -> - circ_error (MissingOpBinding p) (* Will generally never happen *) - in +(* Operators that translate to a circuit when applied to NO arguments. *) +type baseop = + | BBvOp of EcDecl.crb_bvoperator + | BSpec of EcDecl.crb_circuit + +(* Operators that translate to a circuit when applied to arguments. *) +type paramop = + | PBvOp of EcDecl.crb_bvoperator + | PArray of crb_array_operator + | PBs of crb_bitstring_operator + +(* Classify an operator path against the circuit bindings with a SINGLE + registry lookup, returning the bound-op data (so the translators below + need not look it up again). [None] means the path is not a circuit + base/parametric operator. *) +let classify_baseop (env : env) (p : path) : baseop option = + match EcEnv.Circuit.lookup_bvoperator_path env p with + | Some op when not (bvop_is_parametric op) -> Some (BBvOp op) + | _ -> + match EcEnv.Circuit.reverse_circuit env p with + | Some c -> Some (BSpec c) + | None -> None + +let classify_paramop (env : env) (p : path) : paramop option = + match EcEnv.Circuit.lookup_bvoperator_path env p with + | Some op when bvop_is_parametric op -> Some (PBvOp op) + | _ -> + match EcEnv.Circuit.reverse_array_operator env p with + | Some abnd -> Some (PArray abnd) + | None -> + match EcEnv.Circuit.reverse_bitstring_operator env p with + | Some (_, `OfInt as bsbnd) -> Some (PBs bsbnd) + | _ -> None + +let circuit_of_op (env: env) (op : baseop) : circuit = match op with - | `Bitstring (_bs, _op) -> assert false (* Should be guarded by a call to op_is_base *) - | `Array _ -> assert false (* Should be guarded by a call to op_is_parametric_base *) - | `BvOperator bvbnd -> circuit_of_bvop env (`BvBind bvbnd) - | `Circuit c -> circuit_from_spec env (`Bind c) - -let circuit_of_op_with_args (env: env) (p: path) (args: arg list) : circuit = - let op = try - EcEnv.Circuit.reverse_operator env p |> List.hd - with Failure _ -> - circ_error (MissingOpBinding p) (* Will generally never happen *) - in + | BBvOp bvbnd -> circuit_of_bvop env (`BvBind bvbnd) + | BSpec c -> circuit_from_spec env (`Bind c) + +let circuit_of_op_with_args (env: env) (op : paramop) (args: arg list) : circuit = match op with - | `Bitstring bsbnd -> circuit_of_bsop env (`BSBinding bsbnd) args - | `Array abnd -> circuit_of_arrayop env (`ABinding abnd) args - | `BvOperator bvbnd -> circuit_of_parametric_bvop env (`BvBind bvbnd) args - | `Circuit _c -> assert false (* FIXME PR: Do we want to have parametric operators coming from the spec? *) + | PBvOp bvbnd -> circuit_of_parametric_bvop env (`BvBind bvbnd) args + | PArray abnd -> circuit_of_arrayop env (`ABinding abnd) args + | PBs bsbnd -> circuit_of_bsop env (`BSBinding bsbnd) args let type_has_bindings (env: env) (t: ty) : bool = @@ -571,12 +519,13 @@ let circuit_of_form match Mp.find_opt pth !op_cache with | Some op -> op - | None -> - if op_is_base env pth then - let circ = circuit_of_op env pth in + | None -> + match classify_baseop env pth with + | Some op -> + let circ = circuit_of_op env op in op_cache := Mp.add pth circ !op_cache; - circ - else + circ + | None -> let circ = match (EcEnv.Op.by_path pth env).op_kind with | OB_oper (Some (OP_Plain f)) -> doit st f @@ -599,19 +548,24 @@ let circuit_of_form begin match EcAlphaInvHashtbl.find_opt cache f_ with | Some circ -> circ | None -> - let circ = begin match f with - | {f_node = Fop (pth, _)} when op_is_parametric_base env pth -> - let args = List.map (arg_of_form st) fs in - circuit_of_op_with_args env pth args + let paramop = + match f.f_node with + | Fop (pth, _) -> classify_paramop env pth + | _ -> None + in + let circ = begin match f, paramop with + | _, Some op -> + let args = List.map (arg_of_form st) fs in + circuit_of_op_with_args env op args (* For dealing with iter cases: *) - | {f_node = Fop _} when form_is_iter f_ -> + | {f_node = Fop _}, _ when form_is_iter f_ -> trans_iter st hyps f fs - | {f_node = Fop (_p, _)} when not (List.for_all (fun f -> f.f_ty.ty_node <> EcTypes.tint.ty_node) fs) -> + | {f_node = Fop (_p, _)}, _ when not (List.for_all (fun f -> f.f_ty.ty_node <> EcTypes.tint.ty_node) fs) -> doit st (propagate_integer_arguments f fs) - | {f_node = Fop _} -> + | {f_node = Fop _}, _ -> (* Assuming correct types coming from EC *) begin match EcFol.op_kind (destr_op f |> fst), fs with | Some `Eq, [f1; f2] -> From d87db390c1ebcb00105c26e75d57b46d6203beed Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 1 Jun 2026 10:43:44 +0200 Subject: [PATCH 066/145] ecCircuits/ecLowCircuits: remove the dead 'debug' flag The 'debug : bool = false' constant (and its alias in ecCircuits) was never read anywhere -- circuit debug output goes through the engine's 'notify env `Debug' log-level mechanism, not this flag. Drop both. --- src/ecCircuits.ml | 3 --- src/ecLowCircuits.ml | 2 -- 2 files changed, 5 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 47b023d6af..e9f8e5ed12 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -15,9 +15,6 @@ module Hashtbl = Batteries.Hashtbl module Set = Batteries.Set module Option = Batteries.Option -(* -------------------------------------------------------------------- *) -let debug : bool = EcLowCircuits.debug - (* -------------------------------------------------------------------- *) let circ_red (hyps: hyps) = let base_red = EcReduction.full_red in {base_red with delta_p = (fun pth -> diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index 921f445c6a..c47e1d606c 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -25,8 +25,6 @@ module Hashtbl = Batteries.Hashtbl module Set = Batteries.Set module Option = Batteries.Option -let debug : bool = false - (* Backend implementing minimal functions needed for the translation *) (* Minimal expected functionality is QF_ABV *) (* Input are: some identifier + some bit *) From bf5a42817a0c712d674c0ffdb98439f75de35e9c Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 1 Jun 2026 11:08:04 +0200 Subject: [PATCH 067/145] circuit: unify timing behind a Circuit:timing flag Replace the four duplicated ad-hoc 'time' helpers (two ref-style in ecCircuits, two return-style in ecPhlBDep) and the scattered manual Unix.gettimeofday deltas with a single EcCircuits.stopwatch helper: 'stopwatch env' returns a 'lap msg' closure reporting the time since the previous lap. Timing is now globally toggleable via a new boolean flag 'Circuit:timing' (EcGState, wired through process_option like pp_showtvi/old_mem_restr), off by default and enabled with 'pragma +Circuit:timing.'. When off, stopwatch is a no-op; when on it emits at `Warning so it shows at the default compile verbosity. Removes the dead 'do_time' parameter (and its .mli entries) on circuit_check_posts/circuits_of_equality/circuit_simplify_equality (no caller ever disabled it) and the commented-out timing in process_instr. --- src/ecCircuits.ml | 63 ++++++++++++++++++++++++-------------------- src/ecCircuits.mli | 11 +++++--- src/ecCommands.ml | 3 ++- src/ecGState.ml | 6 +++++ src/ecGState.mli | 4 +++ src/phl/ecPhlBDep.ml | 51 ++++++++++++----------------------- 6 files changed, 72 insertions(+), 66 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index e9f8e5ed12..c378f50c8f 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -15,6 +15,25 @@ module Hashtbl = Batteries.Hashtbl module Set = Batteries.Set module Option = Batteries.Option +(* -------------------------------------------------------------------- *) +(* Profiling helper. [stopwatch env] returns a function [lap msg] that + reports the time elapsed since the previous lap (or since creation). + It is a no-op unless the [Circuit:timing] flag is set (default off), + so it can be enabled globally with [pragma Circuit:timing.]. *) +let stopwatch (env : env) : string -> unit = + if not (EcGState.get_circuit_timing (EcEnv.gstate env)) then + fun _ -> () + else begin + let last = ref (Unix.gettimeofday ()) in + fun (msg : string) -> + let now = Unix.gettimeofday () in + (* Emitted at [`Warning] so it shows even at the default + (compile-mode) verbosity; gated by the [Circuit:timing] flag. *) + EcEnv.notify ~immediate:true env `Warning + "[timing] %s: %.3fs@." msg (now -. !last); + last := now + end + (* -------------------------------------------------------------------- *) let circ_red (hyps: hyps) = let base_red = EcReduction.full_red in {base_red with delta_p = (fun pth -> @@ -721,54 +740,44 @@ let circuit_of_form end; res -let circuit_check_posts ?(do_time = true) ~(env: env) ~(pres: circuit list) (posts: circuit list) = - let tm = ref (Unix.gettimeofday ()) in - let time (env: env) (t: float ref) (msg: string) : unit = - let new_t = Unix.gettimeofday () in - EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. !t); - t := new_t - in +let circuit_check_posts ~(env: env) ~(pres: circuit list) (posts: circuit list) = + let lap = stopwatch env in EcEnv.notify env `Debug "Number of checks before batching: %d@." (List.length posts); let posts = batch_checks ~mode:`BySub posts in EcEnv.notify env `Debug "Number of checks after batching: %d@." (List.length posts); - if do_time then time env tm "Done with lane compression"; - if fillet_tauts pres posts then + lap "Done with lane compression"; + if fillet_tauts pres posts then begin - if do_time then time env tm "Done with equivalence checking (structural equality + SMT)"; + lap "Done with equivalence checking (structural equality + SMT)"; true end - else + else begin - if do_time then time env tm "Failed equivalence check"; + lap "Failed equivalence check"; false end -let circuits_of_equality ?(do_time = true) ~(st: state) ~(hyps: hyps) (f1: form) (f2: form) : circuit list = - let tm = ref (Unix.gettimeofday ()) in +let circuits_of_equality ~(st: state) ~(hyps: hyps) (f1: form) (f2: form) : circuit list = let env = toenv hyps in - let time (env: env) (t: float ref) (msg: string) : unit = - let new_t = Unix.gettimeofday () in - EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. !t); - t := new_t - in + let lap = stopwatch env in EcEnv.notify env `Debug "Filletting circuit...@."; let c1 = circuit_of_form st hyps f1 |> state_close_circuit st in - if do_time then time env tm "Left side circuit generation done"; + lap "Left side circuit generation done"; let c2 = circuit_of_form st hyps f2 |> state_close_circuit st in - if do_time then time env tm "Right side circuit generation done"; + lap "Right side circuit generation done"; assert (Option.is_none @@ circuit_has_uninitialized c1); assert (Option.is_none @@ circuit_has_uninitialized c2); let posts = circuit_eqs c1 c2 in - if do_time then time env tm "Done with postcondition circuit generation"; + lap "Done with postcondition circuit generation"; posts -let circuit_simplify_equality ?(do_time = true) ~(st: state) ~(hyps: hyps) ~(pres: circuit list) (f1: form) (f2: form) : bool = - let posts = circuits_of_equality ~do_time ~st ~hyps f1 f2 in - circuit_check_posts ~do_time ~env:(toenv hyps) ~pres posts +let circuit_simplify_equality ~(st: state) ~(hyps: hyps) ~(pres: circuit list) (f1: form) (f2: form) : bool = + let posts = circuits_of_equality ~st ~hyps f1 f2 in + circuit_check_posts ~env:(toenv hyps) ~pres posts (* FIXME: add support for spec bindings for abstract/opaque operators @@ -792,14 +801,12 @@ let vars_of_memtype (mt : memtype) = let process_instr (hyps: hyps) (mem: memory) ~(st: state) (inst: instr) : state = EcEnv.notify (toenv hyps) `Debug "[W] Processing : %a@." (EcPrinting.pp_instr (EcPrinting.PPEnv.ofenv (toenv hyps))) inst; - (* let start = Unix.gettimeofday () in *) try match inst.i_node with - | Sasgn (LvVar (PVloc v, _ty), e) -> + | Sasgn (LvVar (PVloc v, _ty), e) -> let c = ((ss_inv_of_expr mem e).inv |> circuit_of_form st hyps) in let st = update_state_pv st mem v c in st - (* EcEnv.notify env `Debug "[W] Took %f seconds@." (Unix.gettimeofday() -. start); *) | Sasgn (LvTuple (vs), {e_node = Etuple es; _}) when List.compare_lengths vs es = 0 -> let st = List.fold_left (fun st (v, e) -> let c = ((ss_inv_of_expr mem e).inv |> circuit_of_form st hyps) in diff --git a/src/ecCircuits.mli b/src/ecCircuits.mli index cf1984eac1..33fc1449a1 100644 --- a/src/ecCircuits.mli +++ b/src/ecCircuits.mli @@ -10,6 +10,11 @@ open EcLowCircuits (* -------------------------------------------------------------------- *) module Map = Batteries.Map +(* -------------------------------------------------------------------- *) +(* [stopwatch env] returns a [lap msg] function reporting the time since + the previous lap. A no-op unless the [Circuit:timing] flag is set. *) +val stopwatch : env -> (string -> unit) + (* -------------------------------------------------------------------- *) type circuit_conversion_call = [ | `Convert of form @@ -78,9 +83,9 @@ val circ_taut : circuit -> bool (* Generate circuits *) (* Form processors *) val circuit_of_form : state -> hyps -> form -> circuit -val circuit_check_posts : ?do_time:bool -> env:env -> pres:circuit list -> circuit list -> bool -val circuits_of_equality : ?do_time:bool -> st:state -> hyps:hyps -> form -> form -> circuit list -val circuit_simplify_equality : ?do_time:bool -> st:state -> hyps:hyps -> pres:circuit list -> form -> form -> bool +val circuit_check_posts : env:env -> pres:circuit list -> circuit list -> bool +val circuits_of_equality : st:state -> hyps:hyps -> form -> form -> circuit list +val circuit_simplify_equality : st:state -> hyps:hyps -> pres:circuit list -> form -> form -> bool val circ_simplify_form_bitstring_equality : ?st:state -> ?pres:circuit list -> hyps -> form -> form diff --git a/src/ecCommands.ml b/src/ecCommands.ml index 82b28853db..0d10dd26c2 100644 --- a/src/ecCommands.ml +++ b/src/ecCommands.ml @@ -708,7 +708,8 @@ and process_pragma (scope : EcScope.scope) opt = and process_option (scope : EcScope.scope) (name, value) = match value with | `Bool value when EcLocation.unloc name = EcGState.old_mem_restr - || EcLocation.unloc name = EcGState.pp_showtvi -> + || EcLocation.unloc name = EcGState.pp_showtvi + || EcLocation.unloc name = EcGState.circuit_timing -> let gs = EcEnv.gstate (EcScope.env scope) in EcGState.setflag (unloc name) value gs; scope diff --git a/src/ecGState.ml b/src/ecGState.ml index cac459c496..13607118f4 100644 --- a/src/ecGState.ml +++ b/src/ecGState.ml @@ -70,6 +70,12 @@ let pp_showtvi = "PP:showtvi" let get_pp_showtvi (g : gstate) : bool = getflag ~default:false pp_showtvi g +(* -------------------------------------------------------------------- *) +let circuit_timing = "Circuit:timing" + +let get_circuit_timing (g : gstate) : bool = + getflag ~default:false circuit_timing g + (* -------------------------------------------------------------------- *) let add_notifier (notifier : loglevel -> string Lazy.t -> unit) (gs : gstate) = let notifier = { nt_id = EcUid.unique (); nt_cb = notifier; } in diff --git a/src/ecGState.mli b/src/ecGState.mli index 3b516421cd..ae61bf8994 100644 --- a/src/ecGState.mli +++ b/src/ecGState.mli @@ -32,6 +32,10 @@ val get_old_mem_restr : gstate -> bool val pp_showtvi : string val get_pp_showtvi : gstate -> bool +(* --------------------------------------------------------------------- *) +val circuit_timing : string +val get_circuit_timing : gstate -> bool + (* --------------------------------------------------------------------- *) type nid_t type loglevel = [`Debug | `Info | `Warning | `Critical] diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index 2aa2e2127d..0f5703d013 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -18,11 +18,6 @@ module Option = Batteries.Option (* -------------------------------------------------------------------- *) let int_of_form = EcCircuits.int_of_form -let time (env: env) (t: float) (msg: string) : float = - let new_t = Unix.gettimeofday () in - EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. t); - new_t - (* FIXME: move? V *) let form_list_from_iota (hyps: hyps) (f: form) : form list = match f.f_node with @@ -166,26 +161,20 @@ let solve_post ~(st: state) ~(pres: circuit list) (hyps: hyps) (post: form) : bo (* TODO: Figure out how to not repeat computations here? *) let t_bdep_solve (tc : tcenv1) = - let time (env: env) (t: float) (msg: string) : float = - let new_t = Unix.gettimeofday () in - EcEnv.notify ~immediate:true env `Info "[W] %s, took %f s@." msg (new_t -. t); - new_t - in - let hyps = (FApi.tc1_hyps tc) in let goal = (FApi.tc1_goal tc) in let env = (FApi.tc1_env tc) in - match goal.f_node with + match goal.f_node with | FhoareS hs -> begin try - let tm = Unix.gettimeofday () in + let lap = EcCircuits.stopwatch env in let st = set_logger empty_state (EcEnv.notify env `Debug "%s") in let st = circuit_state_of_hyps ~st hyps in let st, cpres = process_pre ~st tc (hs_pr hs).inv in - let tm = time (toenv hyps) tm "Done with precondition processing" in + lap "Done with precondition processing"; (* Get open state *) let st = state_of_prog hyps (fst hs.hs_m) ~st hs.hs_s.s_node in - let _tm = time (toenv hyps) tm "Done with program circuit gen" in + lap "Done with program circuit gen"; if not (POE.is_empty (hs_po hs).hsi_inv) then tc_error !!tc "exception not supported"; @@ -201,7 +190,7 @@ let t_bdep_solve tc_error (FApi.tc1_penv tc) "circuit solve failed with error: %a" (pp_circ_error EcPrinting.PPEnv.(ofenv env)) err end | FequivS es -> begin try - let tm = Unix.gettimeofday () in + let lap = EcCircuits.stopwatch env in let st = set_logger empty_state (EcEnv.notify env `Debug "%s") in @@ -210,14 +199,14 @@ let t_bdep_solve let st = circuit_state_of_memenv ~st (FApi.tc1_env tc) es.es_mr in let st, cpres = process_pre ~st tc (es_pr es).inv in - let tm = time (toenv hyps) tm "Done with precondition processing" in + lap "Done with precondition processing"; (* Circuits from pvars are tagged by memory so we can just put everything in one state *) let st = state_of_prog hyps (fst es.es_ml) ~st es.es_sl.s_node in - let tm = time (toenv hyps) tm "Done with left program circuit gen" in + lap "Done with left program circuit gen"; let st = state_of_prog hyps (fst es.es_mr) ~st es.es_sr.s_node in - let _tm = time (toenv hyps) tm "Done with right program circuit gen" in + lap "Done with right program circuit gen"; if solve_post ~st ~pres:cpres hyps (es_po es).inv then @@ -244,26 +233,20 @@ let t_bdep_solve end let t_bdep_simplify (tc: tcenv1) = - let time (env: env) (t: float) (msg: string) : float = - let new_t = Unix.gettimeofday () in - (* FIXME: change log level to debug? maybe not *) - EcEnv.notify ~immediate:true env `Info "%s, took %f s@." msg (new_t -. t); - new_t - in let hyps = (FApi.tc1_hyps tc) in let goal = (FApi.tc1_goal tc) in let env = (FApi.tc1_env tc) in - match goal.f_node with + match goal.f_node with | FhoareS hs -> begin if not (POE.is_empty (hs_po hs).hsi_inv) then tc_error !!tc "exceptions not supported"; try let m = fst hs.hs_m in - let tm = Unix.gettimeofday () in + let lap = EcCircuits.stopwatch env in let st = circuit_state_of_hyps hyps in let st = circuit_state_of_memenv ~st env hs.hs_m in let st, pres = process_pre ~st tc (hs_pr hs).inv in - let tm = time env tm "Done with precondition processing" in + lap "Done with precondition processing"; let st = EcCircuits.state_of_prog ~st hyps (fst hs.hs_m) hs.hs_s.s_node in let post = EcCallbyValue.norm_cbv (circ_red hyps) hyps (POE.lower (hs_po hs)).inv in @@ -271,11 +254,11 @@ let t_bdep_simplify (tc: tcenv1) = EcEnv.notify env `Debug "[W] Post after simplify (before circuit pass):@. %a@." EcPrinting.(pp_form PPEnv.(ofenv env)) post; - let tm = time env tm "Done with first simplify" in + lap "Done with first simplify"; let f = EcCircuits.circ_simplify_form_bitstring_equality ~st ~pres hyps post in - let tm = time env tm "Done with circuit simplify" in + lap "Done with circuit simplify"; let f = EcCallbyValue.norm_cbv (EcReduction.full_red) hyps f in - let _tm = time env tm "Done with second simplify" in + lap "Done with second simplify"; let new_goal = f_hoareS (snd hs.hs_m) {inv=(hs_pr hs).inv; m} hs.hs_s (POE.lift {inv=f; m}) in EcEnv.notify env `Debug "[W] Goal after simplify:@. %a@." @@ -298,7 +281,7 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = let open EcAst in - let tm = Unix.gettimeofday () in + let lap = EcCircuits.stopwatch (tc1_env tc) in let solved = ref 0 in @@ -412,8 +395,8 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = in match do_all goals with - | None -> - EcEnv.notify ~immediate:true (tc1_env tc) `Warning "[W] Extens took %f seconds@." (Unix.gettimeofday () -. tm); + | None -> + lap "Extens"; close (tcenv_of_tcenv1 tc) VBdep | Some gfail -> tc_error (tc1_penv tc) "Failed to close goal:@. %a@." From 3779cdd0748959ad2b6ba754b9fe6e6ef33072da Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 1 Jun 2026 11:13:33 +0200 Subject: [PATCH 068/145] ecCircuits: trim .mli to the externally-used interface Of the 33 values exported by ecCircuits.mli, only 14 are used outside the module (by ecPhlBDep / ecPhlRwPrgm). The other 19 were either pass-through re-exports of EcLowCircuits names or internal helpers needlessly exposed. Drop them from the interface (they remain available internally); also remove the now-unused 'open EcIdent'/'open EcSymbols'. No behaviour change (release + ci builds clean, circuit tests pass). --- src/ecCircuits.mli | 38 ++++---------------------------------- 1 file changed, 4 insertions(+), 34 deletions(-) diff --git a/src/ecCircuits.mli b/src/ecCircuits.mli index 33fc1449a1..038d00d27e 100644 --- a/src/ecCircuits.mli +++ b/src/ecCircuits.mli @@ -1,6 +1,4 @@ (* -------------------------------------------------------------------- *) -open EcIdent -open EcSymbols open EcAst open EcEnv open LDecl @@ -51,59 +49,31 @@ type circuit_error = exception CircError of circuit_error -val circ_error : circuit_error -> 'a val pp_circ_error : EcPrinting.PPEnv.t -> Format.formatter -> circuit_error -> unit (* -------------------------------------------------------------------- *) (* Utilities (figure out better name) *) val circ_red : hyps -> EcReduction.reduction_info -val width_of_type : env -> ty -> int -val circuit_to_string : circuit -> string -val ctype_of_ty : env -> ty -> ctype val int_of_form : ?redmode:EcReduction.reduction_info -> hyps -> form -> BI.zint -(* State utilities *) -val state_get : state -> memory -> symbol -> circuit -val state_get_opt : state -> memory -> symbol -> circuit option -val state_get_all : state -> circuit list - -(* Create circuits *) -val input_of_type : name:[`Str of string | `Idn of ident | `Bad] -> env -> ty -> circuit - -(* Transform circuits *) -val circuit_ueq : circuit -> circuit -> circuit -val circuit_flatten : circuit -> circuit - (* Use circuits *) -val compute : sign:bool -> circuit -> BI.zint list -> BI.zint -val circ_equiv : ?pcond:circuit -> circuit -> circuit -> bool -val circ_sat : circuit -> bool -val circ_taut : circuit -> bool +val circ_taut : circuit -> bool (* Generate circuits *) (* Form processors *) val circuit_of_form : state -> hyps -> form -> circuit val circuit_check_posts : env:env -> pres:circuit list -> circuit list -> bool val circuits_of_equality : st:state -> hyps:hyps -> form -> form -> circuit list -val circuit_simplify_equality : st:state -> hyps:hyps -> pres:circuit list -> form -> form -> bool val circ_simplify_form_bitstring_equality : ?st:state -> ?pres:circuit list -> hyps -> form -> form - + (* Proc processors *) -val state_of_prog : ?close:bool -> hyps -> memory -> st:state -> instr list -> state +val state_of_prog : ?close:bool -> hyps -> memory -> st:state -> instr list -> state val instrs_equiv : hyps -> memenv -> ?keep:EcPV.PV.t -> state -> instr list -> instr list -> bool -val process_instr : hyps -> memory -> st:state -> instr -> state val circuit_state_of_memenv : ?st:state -> env -> memenv -> state -val circuit_state_of_hyps : ?st:state -> ?strict:bool -> hyps -> state - -(* Check for uninitialized inputs *) -val circuit_has_uninitialized : circuit -> int option - -val circuit_slice : circuit -> int -> int -> circuit - -val circuit_to_file : name:string -> circuit -> symbol +val circuit_state_of_hyps : ?st:state -> ?strict:bool -> hyps -> state (* Imperative state clearing *) val clear_translation_caches : unit -> unit From 6170547044e34d145ead1622163f7f4625d4353e Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 1 Jun 2026 11:20:36 +0200 Subject: [PATCH 069/145] Add a house-style ocamlformat profile; reformat ecCircuits.ml Introduce a .ocamlformat tuned to approximate the project's hand-written style: margin 80, leading-| cases, match arms not indented under match (match-indent=0 / match-indent-nested=never), no space-around-lists, exp-grouping=preserve to keep begin..end blocks, and break-fun-decl=fit-or-vertical so an over-long parameter list breaks into a vertically-aligned vbox (one parameter per line). It is globally disabled (disable=true) so the rest of the unformatted tree is left alone; .ocamlformat-enable opts in only src/ecCircuits.ml for now. Flip disable=false (and drop the enable file) for a repo-wide migration. Reformat src/ecCircuits.ml accordingly: max line length 164 -> 104 (residual lines are unbreakable strings/comments); begin..end preserved. No behaviour change (release + ci builds clean, circuit tests pass). --- .ocamlformat | 20 + .ocamlformat-enable | 1 + src/ecCircuits.ml | 1516 +++++++++++++++++++++++-------------------- 3 files changed, 844 insertions(+), 693 deletions(-) create mode 100644 .ocamlformat create mode 100644 .ocamlformat-enable diff --git a/.ocamlformat b/.ocamlformat new file mode 100644 index 0000000000..17a5bc6983 --- /dev/null +++ b/.ocamlformat @@ -0,0 +1,20 @@ +# Gradual ocamlformat adoption: globally disabled; only files listed in +# .ocamlformat-enable are formatted. Flip `disable` to false (and drop +# .ocamlformat-enable) for a repo-wide migration. +profile = default +version = 0.27.0 +margin = 80 +break-cases = toplevel +match-indent = 0 +match-indent-nested = never +cases-exp-indent = 2 +type-decl-indent = 2 +leading-nested-match-parens = false +parens-tuple = multi-line-only +space-around-lists = false +space-around-arrays = false +space-around-records = false +space-around-variants = false +disable = true +exp-grouping = preserve +break-fun-decl = fit-or-vertical diff --git a/.ocamlformat-enable b/.ocamlformat-enable new file mode 100644 index 0000000000..30b3e93a76 --- /dev/null +++ b/.ocamlformat-enable @@ -0,0 +1 @@ +src/ecCircuits.ml diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index c378f50c8f..df7e8f6887 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -21,307 +21,377 @@ module Option = Batteries.Option It is a no-op unless the [Circuit:timing] flag is set (default off), so it can be enabled globally with [pragma Circuit:timing.]. *) let stopwatch (env : env) : string -> unit = - if not (EcGState.get_circuit_timing (EcEnv.gstate env)) then - fun _ -> () + if not (EcGState.get_circuit_timing (EcEnv.gstate env)) then fun _ -> () else begin let last = ref (Unix.gettimeofday ()) in fun (msg : string) -> let now = Unix.gettimeofday () in (* Emitted at [`Warning] so it shows even at the default (compile-mode) verbosity; gated by the [Circuit:timing] flag. *) - EcEnv.notify ~immediate:true env `Warning - "[timing] %s: %.3fs@." msg (now -. !last); + EcEnv.notify ~immediate:true env `Warning "[timing] %s: %.3fs@." msg + (now -. !last); last := now end (* -------------------------------------------------------------------- *) -let circ_red (hyps: hyps) = let base_red = EcReduction.full_red in - {base_red with delta_p = (fun pth -> - if (EcEnv.Circuit.reverse_operator (LDecl.toenv hyps) pth |> List.is_empty) then - base_red.delta_p pth - else - `No) -} +let circ_red (hyps : hyps) = + let base_red = EcReduction.full_red in + { + base_red with + delta_p = + (fun pth -> + if + EcEnv.Circuit.reverse_operator (LDecl.toenv hyps) pth |> List.is_empty + then base_red.delta_p pth + else `No); + } (* -------------------------------------------------------------------- *) -type circuit_conversion_call = [ - | `Convert of form +type circuit_conversion_call = + [ `Convert of form | `ToArg of form | `ExpandIter of form * form list | `Instr of instr - | `Memenv of memenv -] + | `Memenv of memenv ] type circuit_error = -| MissingTyBinding of [`Ty of ty | `Path of path] -| AbstractTyBinding of [`Ty of ty | `Path of path] -| MissingOpBinding of path -| MissingOpSpec of path -| IntConversionFailure -| MissingOpBody of path -| CantConvertToConstant -| CantReadWriteGlobs -| BadFormForArg of form -| CantConvertToCirc of - [ `Int - | `OpK of EcFol.op_kind - | `Op of path - | `Quantif of quantif - | `Match - | `Glob - | `ModGlob - | `Record - | `Hoare - | `Instr -] -| PropagateError of circuit_conversion_call * circuit_error + | MissingTyBinding of [`Ty of ty | `Path of path] + | AbstractTyBinding of [`Ty of ty | `Path of path] + | MissingOpBinding of path + | MissingOpSpec of path + | IntConversionFailure + | MissingOpBody of path + | CantConvertToConstant + | CantReadWriteGlobs + | BadFormForArg of form + | CantConvertToCirc of + [ `Int + | `OpK of EcFol.op_kind + | `Op of path + | `Quantif of quantif + | `Match + | `Glob + | `ModGlob + | `Record + | `Hoare + | `Instr ] + | PropagateError of circuit_conversion_call * circuit_error exception CircError of circuit_error -let circ_error (err: circuit_error) = - raise (CircError err) +let circ_error (err : circuit_error) = raise (CircError err) -let propagate_circ_error (call: circuit_conversion_call) (err: circuit_error) = +let propagate_circ_error (call : circuit_conversion_call) (err : circuit_error) + = raise (CircError (PropagateError (call, err))) (* FIXME: move this to EcPrinting maybe? *) -let pp_op_kind (fmt: Format.formatter) (opk: EcFol.op_kind) : unit = +let pp_op_kind (fmt : Format.formatter) (opk : EcFol.op_kind) : unit = Format.fprintf fmt "%s" - (match opk with - | `Map_set -> "Map_set" - | `Real_le -> "Real_le" - | `Int_le -> "Int_le" - | `Iff -> "Iff" - | `Int_opp -> "Int_opp" - | `Int_lt -> "Int_lt" - | `Int_pow -> "Int_pow" - | `And `Asym -> "And (&&)" - | `And `Sym -> "And (/\\)" - | `Map_cst -> "Map_cst" - | `False -> "False" - | `Eq -> "Eq" - | `True -> "True" - | `Int_mul -> "Int_mul" - | `Real_inv -> "Real_inv" - | `Real_add -> "Real_add" - | `Int_edivz -> "Int_edivz" - | `Or `Asym -> "Or (||)" - | `Or `Sym -> "Or (\\/)" - | `Not -> "Not" - | `Int_add -> "Int_add" - | `Map_get -> "Map_get" - | `Real_lt -> "Real_lt" - | `Real_opp -> "Real_opp" - | `Real_mul -> "Real_mul" - | `Imp -> "Imp") - -let rec pp_circ_error ppe fmt (err: circuit_error) = + (match opk with + | `Map_set -> "Map_set" + | `Real_le -> "Real_le" + | `Int_le -> "Int_le" + | `Iff -> "Iff" + | `Int_opp -> "Int_opp" + | `Int_lt -> "Int_lt" + | `Int_pow -> "Int_pow" + | `And `Asym -> "And (&&)" + | `And `Sym -> "And (/\\)" + | `Map_cst -> "Map_cst" + | `False -> "False" + | `Eq -> "Eq" + | `True -> "True" + | `Int_mul -> "Int_mul" + | `Real_inv -> "Real_inv" + | `Real_add -> "Real_add" + | `Int_edivz -> "Int_edivz" + | `Or `Asym -> "Or (||)" + | `Or `Sym -> "Or (\\/)" + | `Not -> "Not" + | `Int_add -> "Int_add" + | `Map_get -> "Map_get" + | `Real_lt -> "Real_lt" + | `Real_opp -> "Real_opp" + | `Real_mul -> "Real_mul" + | `Imp -> "Imp") + +let rec pp_circ_error ppe fmt (err : circuit_error) = let open EcPrinting in match err with | MissingTyBinding t -> Format.fprintf fmt "Missing type binding for "; - begin match t with - | `Path pth -> Format.fprintf fmt "type at path %a" pp_path pth - | `Ty ty -> Format.fprintf fmt "type %a" (pp_type ppe) ty + begin + match t with + | `Path pth -> Format.fprintf fmt "type at path %a" pp_path pth + | `Ty ty -> Format.fprintf fmt "type %a" (pp_type ppe) ty end - | AbstractTyBinding t -> + | AbstractTyBinding t -> Format.fprintf fmt "No concrete (only abstract) type binding for "; - begin match t with - | `Path pth -> Format.fprintf fmt "type at path %a" pp_path pth - | `Ty ty -> Format.fprintf fmt "type %a" (pp_type ppe) ty + begin + match t with + | `Path pth -> Format.fprintf fmt "type at path %a" pp_path pth + | `Ty ty -> Format.fprintf fmt "type %a" (pp_type ppe) ty end | MissingOpBinding pth -> Format.fprintf fmt "Missing op binding for operator at path %a" pp_path pth - | MissingOpSpec pth -> - Format.fprintf fmt "Missing op spec binding for operator at path %a" pp_path pth + | MissingOpSpec pth -> + Format.fprintf fmt "Missing op spec binding for operator at path %a" pp_path + pth | IntConversionFailure -> (* FIXME: check that this actually prints the form, otherwise add it *) Format.fprintf fmt "Failed to convert form to concrete integer" - | MissingOpBody pth -> + | MissingOpBody pth -> Format.fprintf fmt "No body for operator at path %a" pp_path pth | CantConvertToConstant -> - Format.fprintf fmt "Failed to reduce circuit to constant after composition (while attempting to compute)" + Format.fprintf fmt + "Failed to reduce circuit to constant after composition (while \ + attempting to compute)" | CantReadWriteGlobs -> - Format.fprintf fmt "Cannot reason about programs which write to global variables using circuits" + Format.fprintf fmt + "Cannot reason about programs which write to global variables using \ + circuits" | BadFormForArg f -> - Format.fprintf fmt "Form %a does not match any known conversion pattern from form to argument" (pp_form ppe) f - | CantConvertToCirc reason -> + Format.fprintf fmt + "Form %a does not match any known conversion pattern from form to \ + argument" + (pp_form ppe) f + | CantConvertToCirc reason -> Format.fprintf fmt "Failed circuit conversion due to: "; - begin match reason with - | `Int -> Format.fprintf fmt "Encountered unexpected integer (maybe you are missing a binding?)" - | `OpK opk -> Format.fprintf fmt "Don't know how to translate op kind: %a" pp_op_kind opk - | `Op pth -> Format.fprintf fmt "Don't know how to convert operator at path %a to circuit (not concrete and does not match any known operator kind)" pp_path pth - | `Quantif qnt -> Format.fprintf fmt "Encountered unexpected quantifier %s" (string_of_quant qnt) - | `Match -> Format.fprintf fmt "Conversion of match statements not supported" - | `Glob -> Format.fprintf fmt "Global variables not supported in conversion" - | `ModGlob -> Format.fprintf fmt "Conversion of module globals not supported" - | `Record -> Format.fprintf fmt "Conversion of records not supported" - | `Hoare -> Format.fprintf fmt "Direct conversion of hoare statements not supported" - | `Instr -> assert false + begin + match reason with + | `Int -> + Format.fprintf fmt + "Encountered unexpected integer (maybe you are missing a binding?)" + | `OpK opk -> + Format.fprintf fmt "Don't know how to translate op kind: %a" pp_op_kind + opk + | `Op pth -> + Format.fprintf fmt + "Don't know how to convert operator at path %a to circuit (not \ + concrete and does not match any known operator kind)" + pp_path pth + | `Quantif qnt -> + Format.fprintf fmt "Encountered unexpected quantifier %s" + (string_of_quant qnt) + | `Match -> + Format.fprintf fmt "Conversion of match statements not supported" + | `Glob -> + Format.fprintf fmt "Global variables not supported in conversion" + | `ModGlob -> + Format.fprintf fmt "Conversion of module globals not supported" + | `Record -> Format.fprintf fmt "Conversion of records not supported" + | `Hoare -> + Format.fprintf fmt "Direct conversion of hoare statements not supported" + | `Instr -> assert false end - | PropagateError (call, e) -> + | PropagateError (call, e) -> pp_circ_error ppe fmt e; Format.fprintf fmt "@\nWhile attemping "; - begin match call with - | `Convert f -> Format.fprintf fmt "conversion of form %a" (pp_form ppe) f - | `ToArg f -> Format.fprintf fmt "conversion to arg of form %a" (pp_form ppe) f - | `ExpandIter (f, args) -> Format.fprintf fmt "expansion of iter %a(%a)" (pp_form ppe) f (pp_list ", " (pp_form ppe)) args - | `Instr inst -> Format.fprintf fmt "processing of instruction %a" (pp_instr ppe) inst - | `Memenv (m, mt) -> Format.fprintf fmt "entering memory %a : %a" (pp_mem ppe) m (pp_memtype ppe) mt + begin + match call with + | `Convert f -> Format.fprintf fmt "conversion of form %a" (pp_form ppe) f + | `ToArg f -> + Format.fprintf fmt "conversion to arg of form %a" (pp_form ppe) f + | `ExpandIter (f, args) -> + Format.fprintf fmt "expansion of iter %a(%a)" (pp_form ppe) f + (pp_list ", " (pp_form ppe)) + args + | `Instr inst -> + Format.fprintf fmt "processing of instruction %a" (pp_instr ppe) inst + | `Memenv (m, mt) -> + Format.fprintf fmt "entering memory %a : %a" (pp_mem ppe) m + (pp_memtype ppe) mt end - -let ty_of_path (p: path) : ty = - EcTypes.tconstr p [] +let ty_of_path (p : path) : ty = EcTypes.tconstr p [] -let rec ctype_of_ty (env: env) (ty: ty) : ctype = +let rec ctype_of_ty (env : env) (ty : ty) : ctype = match ty.ty_node with | Ttuple tys -> CTuple (List.map (ctype_of_ty env) tys) | Tconstr (pth, []) when pth = EcCoreLib.CI_Bool.p_bool -> CBool | _ -> begin match EcEnv.Circuit.lookup_array_and_bitstring env ty with - | Some ({size=(_, Some size_arr)}, {size=(_, Some size_bs)}) -> CArray {width=size_bs; count=size_arr} - | None -> - begin match EcEnv.Circuit.lookup_bitstring_size env ty with + | Some ({size = _, Some size_arr}, {size = _, Some size_bs}) -> + CArray {width = size_bs; count = size_arr} + | None -> begin + match EcEnv.Circuit.lookup_bitstring_size env ty with | Some sz -> CBitstring sz - | _ -> - circ_error (MissingTyBinding (`Ty ty)) + | _ -> circ_error (MissingTyBinding (`Ty ty)) end - | Some ({size = (_, None)}, _) -> - circ_error (AbstractTyBinding (`Ty ty)) - | Some (_, {size = (_, None)}) -> - circ_error (AbstractTyBinding (`Ty ty)) + | Some ({size = _, None}, _) -> circ_error (AbstractTyBinding (`Ty ty)) + | Some (_, {size = _, None}) -> circ_error (AbstractTyBinding (`Ty ty)) end -let width_of_type (env: env) (t: ty) : int = +let width_of_type (env : env) (t : ty) : int = let cty = ctype_of_ty env t in EcLowCircuits.size_of_ctype cty - -let input_of_type ~name (env: env) (t: ty) : circuit = + +let input_of_type ~name (env : env) (t : ty) : circuit = let ct = ctype_of_ty env t in - input_of_ctype ~name ct - -(* Should correspond to QF_ABV *) + input_of_ctype ~name ct + +(* Should correspond to QF_ABV *) module BVOps = struct let temp_symbol = "temp_circ_input" - let circuit_of_parametric_bvop (env : env) (op: [`Path of path | `BvBind of EcDecl.crb_bvoperator]) (args: arg list) : circuit = - let op = match op with - | `BvBind op -> op - | `Path p -> begin match EcEnv.Circuit.lookup_bvoperator_path env p with - | Some op -> op - | None -> circ_error (MissingOpBinding p) - end + let circuit_of_parametric_bvop + (env : env) + (op : [`Path of path | `BvBind of EcDecl.crb_bvoperator]) + (args : arg list) : circuit = + let op = + match op with + | `BvBind op -> op + | `Path p -> begin + match EcEnv.Circuit.lookup_bvoperator_path env p with + | Some op -> op + | None -> circ_error (MissingOpBinding p) + end in circuit_of_parametric_bvop op args - - let circuit_of_bvop (env: env) (op: [`Path of path | `BvBind of EcDecl.crb_bvoperator]) : circuit = - let op = match op with - | `BvBind op -> op - | `Path p -> begin match EcEnv.Circuit.lookup_bvoperator_path env p with - | Some op -> op - | None -> circ_error (MissingOpBinding p) - end + + let circuit_of_bvop + (env : env) + (op : [`Path of path | `BvBind of EcDecl.crb_bvoperator]) : circuit = + let op = + match op with + | `BvBind op -> op + | `Path p -> begin + match EcEnv.Circuit.lookup_bvoperator_path env p with + | Some op -> op + | None -> circ_error (MissingOpBinding p) + end in circuit_of_bvop op end + open BVOps module BitstringOps = struct - type binding = crb_bitstring_operator - - let circuit_of_bsop (env: env) (op: [`Path of path | `BSBinding of binding]) (args: arg list) : circuit = - let bnd = match op with - | `BSBinding bnd -> bnd - | `Path p -> begin match EcEnv.Circuit.reverse_bitstring_operator env p with - | Some bnd -> bnd - | None -> circ_error (MissingOpBinding p) + type binding = crb_bitstring_operator + + let circuit_of_bsop + (env : env) + (op : [`Path of path | `BSBinding of binding]) + (args : arg list) : circuit = + let bnd = + match op with + | `BSBinding bnd -> bnd + | `Path p -> begin + match EcEnv.Circuit.reverse_bitstring_operator env p with + | Some bnd -> bnd + | None -> circ_error (MissingOpBinding p) end in (* [classify_paramop] only ever yields the [`OfInt] bitstring operator, so the other arms are unreachable here. *) match bnd with | _bs, `From -> assert false (* doesn't translate to circuit *) - | {size = (_, Some size)}, `OfInt -> begin match args with - | [ `Constant i ] -> - circuit_of_zint ~size i - | _args -> assert false (* Should be caught by EC typechecking + binding correctness *) + | {size = _, Some size}, `OfInt -> begin + match args with + | [`Constant i] -> circuit_of_zint ~size i + | _args -> + assert + false (* Should be caught by EC typechecking + binding correctness *) end - | {size = (_, None); type_=ty}, `OfInt -> - circ_error (AbstractTyBinding (`Path ty)) + | {size = _, None; type_ = ty}, `OfInt -> + circ_error (AbstractTyBinding (`Path ty)) | _bs, `To -> assert false (* doesn't translate to circuit *) - | _bs, `ToSInt -> assert false (* doesn't translate to circuit *) + | _bs, `ToSInt -> assert false (* doesn't translate to circuit *) | _bs, `ToUInt -> assert false (* doesn't translate to circuit *) end + open BitstringOps module ArrayOps = struct - type binding = crb_array_operator - - - let circuit_of_arrayop (env: env) (op: [`Path of path | `ABinding of binding]) (args: arg list) : circuit = - let op = match op with - | `ABinding bnd -> bnd - | `Path p -> begin match EcEnv.Circuit.reverse_array_operator env p with - | Some bnd -> bnd - | None -> circ_error (MissingOpBinding p) - end + type binding = crb_array_operator + + let circuit_of_arrayop + (env : env) + (op : [`Path of path | `ABinding of binding]) + (args : arg list) : circuit = + let op = + match op with + | `ABinding bnd -> bnd + | `Path p -> begin + match EcEnv.Circuit.reverse_array_operator env p with + | Some bnd -> bnd + | None -> circ_error (MissingOpBinding p) + end in (* [classify_paramop] only yields the [`Get]/[`Set]/[`OfList] array operators, so the other arms are unreachable here. *) match op with - | (_arr, `ToList) -> assert false (* We do not translate this to circuit *) - | (_arr, `Get) -> begin match args with - | [ `Circuit (({type_ = CArray _}, _inps) as arr); `Constant i] -> + | _arr, `ToList -> assert false (* We do not translate this to circuit *) + | _arr, `Get -> begin + match args with + | [`Circuit (({type_ = CArray _}, _inps) as arr); `Constant i] -> array_get arr (BI.to_int i) - | _args -> assert false (* Should be caught by EC typechecking + binding correctness *) + | _args -> + assert + false (* Should be caught by EC typechecking + binding correctness *) end - | ({size = (_, Some size)}, `OfList) -> begin match args with - | [ `Circuit dfl; `List cs ] -> array_oflist cs dfl size - | _args -> assert false (* Should be caught by EC typechecking + binding correctness *) - end - | ({size = (_, None); type_=ty}, `OfList) -> circ_error (AbstractTyBinding (`Path ty)) - | (_arr, `Set) -> begin match args with - | [ `Circuit (({type_ = CArray _}, _) as arr); - `Constant i; - `Circuit (({type_ = CBitstring _}, _) as bs) ] -> + | {size = _, Some size}, `OfList -> begin + match args with + | [`Circuit dfl; `List cs] -> array_oflist cs dfl size + | _args -> + assert + false (* Should be caught by EC typechecking + binding correctness *) + end + | {size = _, None; type_ = ty}, `OfList -> + circ_error (AbstractTyBinding (`Path ty)) + | _arr, `Set -> begin + match args with + | [ + `Circuit (({type_ = CArray _}, _) as arr); + `Constant i; + `Circuit (({type_ = CBitstring _}, _) as bs); + ] -> array_set arr (BI.to_int i) bs - | _args -> assert false (* Should be caught by EC typechecking + binding correctness *) + | _args -> + assert + false (* Should be caught by EC typechecking + binding correctness *) end end + open ArrayOps (* Functions for dealing with uninitialized inputs *) -let circuit_uninit (env:env) (t: ty) : circuit = +let circuit_uninit (env : env) (t : ty) : circuit = circuit_uninit (ctype_of_ty env t) module CircuitSpec = struct - let circuit_from_spec env (c : [`Path of path | `Bind of EcDecl.crb_circuit ] ) : circuit = - let c = match c with - | `Path p -> begin match EcEnv.Circuit.reverse_circuit env p with - | Some c -> c - | None -> circ_error (MissingOpSpec p) (* Will generally never happen *) - end - | `Bind c -> c + let circuit_from_spec env (c : [`Path of path | `Bind of EcDecl.crb_circuit]) + : circuit = + let c = + match c with + | `Path p -> begin + match EcEnv.Circuit.reverse_circuit env p with + | Some c -> c + | None -> circ_error (MissingOpSpec p) + (* Will generally never happen *) + end + | `Bind c -> c in - let _, name = (EcPath.toqsymbol c.operator) in + let _, name = EcPath.toqsymbol c.operator in let op = EcEnv.Op.by_path c.operator env in - let unroll_fty (ty: ty) : ty list * ty = - let rec doit (acc: ty list) (ty: ty) : ty list * ty = - try + let unroll_fty (ty : ty) : ty list * ty = + let rec doit (acc : ty list) (ty : ty) : ty list * ty = + try let a, b = EcTypes.tfrom_tfun2 ty in - (doit (a::acc) b) - with - | EcTypes.TyDestrError "fun" -> List.rev acc, ty - in doit [] ty + doit (a :: acc) b + with EcTypes.TyDestrError "fun" -> List.rev acc, ty + in + doit [] ty in - let arg_tys, ret_ty = unroll_fty op.op_ty in + let arg_tys, ret_ty = unroll_fty op.op_ty in let arg_tys = List.map (ctype_of_ty env) arg_tys in let ret_ty = ctype_of_ty env ret_ty in circuit_from_spec ~name (arg_tys, ret_ty) c.circuit end + open CircuitSpec (* A bound bv-operator is "parametric" (applied to constant arguments, @@ -329,20 +399,19 @@ open CircuitSpec on its kind. *) let bvop_is_parametric (op : EcDecl.crb_bvoperator) : bool = match op.kind with - | `ASliceGet _ | `ASliceSet _ | `Extract _ | `Insert _ - | `Map _ | `Get _ | `AInit _ | `Init _ -> true + | `ASliceGet _ | `ASliceSet _ | `Extract _ | `Insert _ | `Map _ | `Get _ + | `AInit _ | `Init _ -> + true | _ -> false (* Operators that translate to a circuit when applied to NO arguments. *) -type baseop = - | BBvOp of EcDecl.crb_bvoperator - | BSpec of EcDecl.crb_circuit +type baseop = BBvOp of EcDecl.crb_bvoperator | BSpec of EcDecl.crb_circuit (* Operators that translate to a circuit when applied to arguments. *) type paramop = - | PBvOp of EcDecl.crb_bvoperator + | PBvOp of EcDecl.crb_bvoperator | PArray of crb_array_operator - | PBs of crb_bitstring_operator + | PBs of crb_bitstring_operator (* Classify an operator path against the circuit bindings with a SINGLE registry lookup, returning the bound-op data (so the translators below @@ -351,414 +420,416 @@ type paramop = let classify_baseop (env : env) (p : path) : baseop option = match EcEnv.Circuit.lookup_bvoperator_path env p with | Some op when not (bvop_is_parametric op) -> Some (BBvOp op) - | _ -> + | _ -> ( match EcEnv.Circuit.reverse_circuit env p with | Some c -> Some (BSpec c) - | None -> None + | None -> None) let classify_paramop (env : env) (p : path) : paramop option = match EcEnv.Circuit.lookup_bvoperator_path env p with | Some op when bvop_is_parametric op -> Some (PBvOp op) - | _ -> + | _ -> ( match EcEnv.Circuit.reverse_array_operator env p with | Some abnd -> Some (PArray abnd) - | None -> + | None -> ( match EcEnv.Circuit.reverse_bitstring_operator env p with - | Some (_, `OfInt as bsbnd) -> Some (PBs bsbnd) - | _ -> None + | Some ((_, `OfInt) as bsbnd) -> Some (PBs bsbnd) + | _ -> None)) -let circuit_of_op (env: env) (op : baseop) : circuit = +let circuit_of_op (env : env) (op : baseop) : circuit = match op with - | BBvOp bvbnd -> circuit_of_bvop env (`BvBind bvbnd) - | BSpec c -> circuit_from_spec env (`Bind c) + | BBvOp bvbnd -> circuit_of_bvop env (`BvBind bvbnd) + | BSpec c -> circuit_from_spec env (`Bind c) -let circuit_of_op_with_args (env: env) (op : paramop) (args: arg list) : circuit = +let circuit_of_op_with_args (env : env) (op : paramop) (args : arg list) : + circuit = match op with | PBvOp bvbnd -> circuit_of_parametric_bvop env (`BvBind bvbnd) args | PArray abnd -> circuit_of_arrayop env (`ABinding abnd) args - | PBs bsbnd -> circuit_of_bsop env (`BSBinding bsbnd) args - + | PBs bsbnd -> circuit_of_bsop env (`BSBinding bsbnd) args -let type_has_bindings (env: env) (t: ty) : bool = - (Option.is_some (EcEnv.Circuit.lookup_array_and_bitstring env t)) || - (Option.is_some (EcEnv.Circuit.lookup_bitstring env t)) +let type_has_bindings (env : env) (t : ty) : bool = + Option.is_some (EcEnv.Circuit.lookup_array_and_bitstring env t) + || Option.is_some (EcEnv.Circuit.lookup_bitstring env t) -let int_of_form ?(redmode = EcReduction.full_red) (hyps: hyps) (f: form) : zint = - match f.f_node with +let int_of_form ?(redmode = EcReduction.full_red) (hyps : hyps) (f : form) : + zint = + match f.f_node with | Fint i -> i - | _ -> - begin try - destr_int @@ EcCallbyValue.norm_cbv redmode hyps f - with - DestrError "int" - | DestrError "destr_int" -> circ_error IntConversionFailure - end + | _ -> begin + try destr_int @@ EcCallbyValue.norm_cbv redmode hyps f + with DestrError "int" | DestrError "destr_int" -> + circ_error IntConversionFailure + end -let rec form_list_of_form ?(env: env option) (f: form) : form list = +let rec form_list_of_form ?(env : env option) (f : form) : form list = match destr_op_app f with - | (pc, _), [h; {f_node = Fop(p, _)}] when - pc = EcCoreLib.CI_List.p_cons && - p = EcCoreLib.CI_List.p_empty -> + | (pc, _), [h; {f_node = Fop (p, _)}] + when pc = EcCoreLib.CI_List.p_cons && p = EcCoreLib.CI_List.p_empty -> [h] - | (pc, _), [h; t] when - pc = EcCoreLib.CI_List.p_cons -> - h::(form_list_of_form t) - | _ -> - Option.may (fun env -> - EcEnv.notify env `Debug "Failed to destructure claimed list: %a@." (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv env)) f) env; + | (pc, _), [h; t] when pc = EcCoreLib.CI_List.p_cons -> + h :: form_list_of_form t + | _ -> + Option.may + (fun env -> + EcEnv.notify env `Debug "Failed to destructure claimed list: %a@." + (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv env)) + f) + env; raise (DestrError "list") -let form_is_iter (f: form) : bool = +let form_is_iter (f : form) : bool = match f.f_node with - | Fapp ({f_node = Fop (p, _)}, _) when - p = EcCoreLib.CI_Int.p_iter || - p = EcCoreLib.CI_Int.p_fold || - p = EcCoreLib.CI_Int.p_iteri -> true + | Fapp ({f_node = Fop (p, _)}, _) + when p = EcCoreLib.CI_Int.p_iter + || p = EcCoreLib.CI_Int.p_fold + || p = EcCoreLib.CI_Int.p_iteri -> + true | _ -> false (* Expands iter, fold and iteri (for integer arguments) *) -let expand_iter_form (hyps: hyps) (f: form) : form = +let expand_iter_form (hyps : hyps) (f : form) : form = let redmode = circ_red hyps in let env = toenv hyps in let ppenv = EcPrinting.PPEnv.ofenv env in - let (@!!) f fs = - EcTypesafeFol.fapply_safe ~redmode hyps f fs - in - - let res = match f.f_node with - | Fapp ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iteri -> - let rep = int_of_form hyps rep in - let is = List.init (BI.to_int rep) BI.of_int in - EcEnv.notify env `Debug "Done generating functions!@."; - let f = List.fold_left (fun f i -> - EcEnv.notify env `Debug "Expanding iter... Step #%d@.Form: %a@." (BI.to_int i) - (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (toenv hyps))) f - ; - fn @!! [f_int i; f] - ) base is in - f - | Fapp ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iter -> - let rep = int_of_form hyps rep in - let is = List.init (BI.to_int rep) BI.of_int in - let f = List.fold_left (fun f _i -> fn @!! [f]) base is in - f - | Fapp ({f_node = Fop (p, _)}, [fn; base; rep]) when p = EcCoreLib.CI_Int.p_fold -> - let rep = int_of_form hyps rep in - let is = List.init (BI.to_int rep) BI.of_int in - let f = List.fold_left (fun f _i -> fn @!! [f]) base is in - f - | _ -> raise (DestrError "iter") + let ( @!! ) f fs = EcTypesafeFol.fapply_safe ~redmode hyps f fs in + + let res = + match f.f_node with + | Fapp ({f_node = Fop (p, _)}, [rep; fn; base]) + when p = EcCoreLib.CI_Int.p_iteri -> + let rep = int_of_form hyps rep in + let is = List.init (BI.to_int rep) BI.of_int in + EcEnv.notify env `Debug "Done generating functions!@."; + let f = + List.fold_left + (fun f i -> + EcEnv.notify env `Debug "Expanding iter... Step #%d@.Form: %a@." + (BI.to_int i) + (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (toenv hyps))) + f; + fn @!! [f_int i; f]) + base is + in + f + | Fapp ({f_node = Fop (p, _)}, [rep; fn; base]) + when p = EcCoreLib.CI_Int.p_iter -> + let rep = int_of_form hyps rep in + let is = List.init (BI.to_int rep) BI.of_int in + let f = List.fold_left (fun f _i -> fn @!! [f]) base is in + f + | Fapp ({f_node = Fop (p, _)}, [fn; base; rep]) + when p = EcCoreLib.CI_Int.p_fold -> + let rep = int_of_form hyps rep in + let is = List.init (BI.to_int rep) BI.of_int in + let f = List.fold_left (fun f _i -> fn @!! [f]) base is in + f + | _ -> raise (DestrError "iter") in - EcEnv.notify env `Debug "Expanded iter form: @.%a@." EcPrinting.(pp_form ppenv) res; + EcEnv.notify env `Debug "Expanded iter form: @.%a@." + EcPrinting.(pp_form ppenv) + res; res -let circuit_of_form - (st : state) (* Program variable values *) - (hyps : hyps) - (f_ : EcAst.form) - : circuit = - +let circuit_of_form + (st : state) + (* Program variable values *) (hyps : hyps) + (f_ : EcAst.form) : circuit = (* Form level cache, local to each high-level call *) let cache : circuit EcAlphaInvHashtbl.t = EcAlphaInvHashtbl.create hyps 700 in let op_cache : circuit Mp.t ref = ref Mp.empty in let redmode = circ_red hyps in let env = toenv hyps in let ppe = EcPrinting.PPEnv.ofenv env in - let fapply_safe f fs = + let fapply_safe f fs = let res = EcTypesafeFol.fapply_safe ~redmode hyps f fs in res in - let int_of_form (f: form) : zint = - int_of_form hyps f - in + let int_of_form (f : form) : zint = int_of_form hyps f in (* Supposed to be called on an apply *) - let propagate_integer_arguments (op: form) (args: form list) : form = - let op = + let propagate_integer_arguments (op : form) (args : form list) : form = + let op = let pth, _ = destr_op op in match (EcEnv.Op.by_path pth env).op_kind with - | OB_oper (Some (OP_Plain f)) -> - f - | _ -> - circ_error (MissingOpBody pth) + | OB_oper (Some (OP_Plain f)) -> f + | _ -> circ_error (MissingOpBody pth) in - let res = fapply_safe op args in + let res = fapply_safe op args in res in - let rec arg_of_form (st: state) (f: form) : arg = + let rec arg_of_form (st : state) (f : form) : arg = try match f.f_ty with | t when EcReduction.EqTest.is_int env t -> arg_of_zint (int_of_form f) - | t when type_has_bindings env t -> - let f = doit st f in - arg_of_circuit f - | {ty_node = Tfun(i_t, c_t)} when - i_t.ty_node = EcTypes.tint.ty_node && - type_has_bindings env c_t -> - arg_of_init (fun i -> - let f = (fapply_safe f [f_int (BI.of_int i)]) in - doit st f - ) - | {ty_node = Tconstr(p, [t])} when - p = EcCoreLib.CI_List.p_list && - type_has_bindings env t -> - let cs = List.map (fun f -> doit st f) (form_list_of_form ~env f) in - arg_of_circuits cs - | _ -> EcLowCircuits.log st @@ Format.asprintf "Failed to convert form to arg: %a@." EcPrinting.(pp_form ppe) f; + | t when type_has_bindings env t -> + let f = doit st f in + arg_of_circuit f + | {ty_node = Tfun (i_t, c_t)} + when i_t.ty_node = EcTypes.tint.ty_node && type_has_bindings env c_t -> + arg_of_init (fun i -> + let f = fapply_safe f [f_int (BI.of_int i)] in + doit st f) + | {ty_node = Tconstr (p, [t])} + when p = EcCoreLib.CI_List.p_list && type_has_bindings env t -> + let cs = List.map (fun f -> doit st f) (form_list_of_form ~env f) in + arg_of_circuits cs + | _ -> + EcLowCircuits.log st + @@ Format.asprintf "Failed to convert form to arg: %a@." + EcPrinting.(pp_form ppe) + f; circ_error (BadFormForArg f) - with CircError e -> - propagate_circ_error (`ToArg f) e - + with CircError e -> propagate_circ_error (`ToArg f) e (* State does not get backward propagated so it is not returned *) - and doit (st: state) (f_: form) : circuit = - try begin - match f_.f_node with - | Fint _z -> circ_error (CantConvertToCirc `Int) - - | Fif (c_f, t_f, f_f) -> - let t = doit st t_f in - let f = doit st f_f in - let c = doit st c_f in - circuit_ite ~c ~t ~f - - | Flocal idn -> - state_get st idn - - | Fop (pth, _) -> + and doit (st : state) (f_ : form) : circuit = + try begin - if pth = EcCoreLib.CI_Witness.p_witness then - (EcEnv.notify env `Debug "Assigning witness to var of type %a@." - EcPrinting.(pp_type ppe) f_.f_ty; - circuit_uninit env (f_.f_ty)) - else - match Mp.find_opt pth !op_cache with - | Some op -> - op - | None -> - match classify_baseop env pth with - | Some op -> - let circ = circuit_of_op env op in - op_cache := Mp.add pth circ !op_cache; - circ - | None -> - let circ = match (EcEnv.Op.by_path pth env).op_kind with - | OB_oper (Some (OP_Plain f)) -> - doit st f - | _ -> - begin match EcFol.op_kind (destr_op f_ |> fst) with - | Some `True -> - (circuit_true :> circuit) - | Some `False -> - (circuit_false :> circuit) - | Some opk -> circ_error (CantConvertToCirc (`OpK opk)) - | None -> circ_error (CantConvertToCirc (`Op (destr_op f_ |> fst))) - end - in - op_cache := Mp.add pth circ !op_cache; - circ - end - | Fapp (f, fs) -> - (* TODO: Maybe add cache statistics? *) - (* TODO: Maybe cache all forms *) - begin match EcAlphaInvHashtbl.find_opt cache f_ with - | Some circ -> circ - | None -> - let paramop = - match f.f_node with - | Fop (pth, _) -> classify_paramop env pth - | _ -> None - in - let circ = begin match f, paramop with - | _, Some op -> - let args = List.map (arg_of_form st) fs in - circuit_of_op_with_args env op args - - (* For dealing with iter cases: *) - | {f_node = Fop _}, _ when form_is_iter f_ -> - trans_iter st hyps f fs - - | {f_node = Fop (_p, _)}, _ when not (List.for_all (fun f -> f.f_ty.ty_node <> EcTypes.tint.ty_node) fs) -> - doit st (propagate_integer_arguments f fs) - - | {f_node = Fop _}, _ -> - (* Assuming correct types coming from EC *) - begin match EcFol.op_kind (destr_op f |> fst), fs with - | Some `Eq, [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_eq c1 c2 :> circuit) - | Some `Not, [f] -> - let c = doit st f in - circuit_not c - | Some `True, [] -> - (circuit_true :> circuit) - | Some `False, [] -> - (circuit_false :> circuit) - | Some `Imp, [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_or (circuit_not c1) c2 :> circuit) - | Some (`And _), [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_and c1 c2 :> circuit) - | Some (`Or _), [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_or c1 c2 :> circuit) - | Some `Iff, [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_or (circuit_and c1 c2) (circuit_and (circuit_not c1) (circuit_not c2)) :> circuit) - (* Recurse down into definition *) - | _ -> - let f_c = doit st f in - let fcs = List.map (doit st) fs in - circuit_compose f_c fcs + match f_.f_node with + | Fint _z -> circ_error (CantConvertToCirc `Int) + | Fif (c_f, t_f, f_f) -> + let t = doit st t_f in + let f = doit st f_f in + let c = doit st c_f in + circuit_ite ~c ~t ~f + | Flocal idn -> state_get st idn + | Fop (pth, _) -> begin + if pth = EcCoreLib.CI_Witness.p_witness then ( + EcEnv.notify env `Debug "Assigning witness to var of type %a@." + EcPrinting.(pp_type ppe) + f_.f_ty; + circuit_uninit env f_.f_ty) + else + match Mp.find_opt pth !op_cache with + | Some op -> op + | None -> ( + match classify_baseop env pth with + | Some op -> + let circ = circuit_of_op env op in + op_cache := Mp.add pth circ !op_cache; + circ + | None -> + let circ = + match (EcEnv.Op.by_path pth env).op_kind with + | OB_oper (Some (OP_Plain f)) -> doit st f + | _ -> begin + match EcFol.op_kind (destr_op f_ |> fst) with + | Some `True -> (circuit_true :> circuit) + | Some `False -> (circuit_false :> circuit) + | Some opk -> circ_error (CantConvertToCirc (`OpK opk)) + | None -> + circ_error (CantConvertToCirc (`Op (destr_op f_ |> fst))) + end + in + op_cache := Mp.add pth circ !op_cache; + circ) end - (* Recurse down into definition *) - | _ -> - let f_c = doit st f in - let fcs = List.map (doit st) fs in - circuit_compose f_c fcs - end in - EcAlphaInvHashtbl.add cache f_ circ; - circ - end - - | Fquant (qnt, binds, f) -> - (* FIXME Does this type conversion make sense? *) - let binds = List.map (fun (idn, t) -> (idn, gty_as_ty t |> ctype_of_ty env)) binds in - begin match qnt with - | Lforall - | Llambda -> circ_lambda_oneshot st binds (fun st -> doit st f) (* FIXME: look at this interaction *) - | Lexists -> circ_error (CantConvertToCirc (`Quantif qnt)) - (* FIXME: Do we want to handle existentials? *) - end - - | Fproj (f, i) -> - let ftp = doit st f in - (circuit_tuple_proj ftp i :> circuit) - - | Fmatch (_f, _fs, _ty) -> circ_error (CantConvertToCirc `Match) - - | Flet (LSymbol (id, _t), v, f) -> - let vc = doit st v in - let st = update_state st id vc in - doit st f - - | Flet (LTuple vs, v, f) -> - let vc = doit st v in - let comps = circuits_of_circuit_tuple vc in - let st = List.fold_left2 (fun st (id, _t) vc -> - update_state st id vc) - st - vs - comps - in doit st f - - | Flet (LRecord _, _, _) -> circ_error (CantConvertToCirc `Record) - - | Fpvar (pv, mem) -> - let v = match pv with - | PVloc v -> v - (* FIXME: Should globals be supported? *) - | _ -> circ_error (CantConvertToCirc `Glob) - in - let v = match state_get_pv_opt st mem v with - | Some v -> v - | None -> - EcEnv.notify env `Debug "Assigning unassigned program variable %a of type %a@." EcPrinting.(pp_pv ppe) pv EcPrinting.(pp_type ppe) f_.f_ty; - circuit_uninit env f_.f_ty (* Allow uninitialized program variables *) - in - v - - | Fglob (_id, _mem) -> circ_error (CantConvertToCirc `ModGlob) - - | Ftuple comps -> - let comps = - List.map (fun comp -> doit st comp) comps - in - (circuit_tuple_of_circuits comps :> circuit) - - | FhoareF _ - | FhoareS _ - | FbdHoareF _ - | FbdHoareS _ - | FeHoareF _ - | FeHoareS _ - | FequivF _ - | FequivS _ - | FeagerF _ - | Fpr _ -> circ_error (CantConvertToCirc `Hoare) - (* FIXME: do we want to allow conversion of hoare statements? + | Fapp (f, fs) -> + (* TODO: Maybe add cache statistics? *) + (* TODO: Maybe cache all forms *) + begin + match EcAlphaInvHashtbl.find_opt cache f_ with + | Some circ -> circ + | None -> + let paramop = + match f.f_node with + | Fop (pth, _) -> classify_paramop env pth + | _ -> None + in + let circ = + begin + match f, paramop with + | _, Some op -> + let args = List.map (arg_of_form st) fs in + circuit_of_op_with_args env op args + (* For dealing with iter cases: *) + | {f_node = Fop _}, _ when form_is_iter f_ -> + trans_iter st hyps f fs + | {f_node = Fop (_p, _)}, _ + when not + (List.for_all + (fun f -> f.f_ty.ty_node <> EcTypes.tint.ty_node) + fs) -> + doit st (propagate_integer_arguments f fs) + | {f_node = Fop _}, _ -> + (* Assuming correct types coming from EC *) + begin + match EcFol.op_kind (destr_op f |> fst), fs with + | Some `Eq, [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_eq c1 c2 :> circuit) + | Some `Not, [f] -> + let c = doit st f in + circuit_not c + | Some `True, [] -> (circuit_true :> circuit) + | Some `False, [] -> (circuit_false :> circuit) + | Some `Imp, [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_or (circuit_not c1) c2 :> circuit) + | Some (`And _), [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_and c1 c2 :> circuit) + | Some (`Or _), [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_or c1 c2 :> circuit) + | Some `Iff, [f1; f2] -> + let c1 = doit st f1 in + let c2 = doit st f2 in + (circuit_or (circuit_and c1 c2) + (circuit_and (circuit_not c1) (circuit_not c2)) + :> circuit) + (* Recurse down into definition *) + | _ -> + let f_c = doit st f in + let fcs = List.map (doit st) fs in + circuit_compose f_c fcs + end + (* Recurse down into definition *) + | _ -> + let f_c = doit st f in + let fcs = List.map (doit st) fs in + circuit_compose f_c fcs + end + in + EcAlphaInvHashtbl.add cache f_ circ; + circ + end + | Fquant (qnt, binds, f) -> + (* FIXME Does this type conversion make sense? *) + let binds = + List.map (fun (idn, t) -> idn, gty_as_ty t |> ctype_of_ty env) binds + in + begin + match qnt with + | Lforall | Llambda -> + circ_lambda_oneshot st binds (fun st -> doit st f) + (* FIXME: look at this interaction *) + | Lexists -> circ_error (CantConvertToCirc (`Quantif qnt)) + (* FIXME: Do we want to handle existentials? *) + end + | Fproj (f, i) -> + let ftp = doit st f in + (circuit_tuple_proj ftp i :> circuit) + | Fmatch (_f, _fs, _ty) -> circ_error (CantConvertToCirc `Match) + | Flet (LSymbol (id, _t), v, f) -> + let vc = doit st v in + let st = update_state st id vc in + doit st f + | Flet (LTuple vs, v, f) -> + let vc = doit st v in + let comps = circuits_of_circuit_tuple vc in + let st = + List.fold_left2 + (fun st (id, _t) vc -> update_state st id vc) + st vs comps + in + doit st f + | Flet (LRecord _, _, _) -> circ_error (CantConvertToCirc `Record) + | Fpvar (pv, mem) -> + let v = + match pv with + | PVloc v -> v + (* FIXME: Should globals be supported? *) + | _ -> circ_error (CantConvertToCirc `Glob) + in + let v = + match state_get_pv_opt st mem v with + | Some v -> v + | None -> + EcEnv.notify env `Debug + "Assigning unassigned program variable %a of type %a@." + EcPrinting.(pp_pv ppe) + pv + EcPrinting.(pp_type ppe) + f_.f_ty; + circuit_uninit env + f_.f_ty (* Allow uninitialized program variables *) + in + v + | Fglob (_id, _mem) -> circ_error (CantConvertToCirc `ModGlob) + | Ftuple comps -> + let comps = List.map (fun comp -> doit st comp) comps in + (circuit_tuple_of_circuits comps :> circuit) + | FhoareF _ | FhoareS _ | FbdHoareF _ | FbdHoareS _ | FeHoareF _ + | FeHoareS _ | FequivF _ | FequivS _ | FeagerF _ | Fpr _ -> + circ_error (CantConvertToCirc `Hoare) + (* FIXME: do we want to allow conversion of hoare statements? Probably not at this point *) - end - with - | CircError e -> - propagate_circ_error (`Convert f_) e - - and trans_iter (st: state) (hyps: hyps) (f: form) (fs: form list) : circuit = + end + with CircError e -> propagate_circ_error (`Convert f_) e + and trans_iter (st : state) (hyps : hyps) (f : form) (fs : form list) : + circuit = try (* FIXME: move auxiliary function out of the definitions *) let redmode = circ_red hyps in - let fapply_safe f fs = + let fapply_safe f fs = let res = EcTypesafeFol.fapply_safe ~redmode hyps f fs in res in match f, fs with - | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iteri -> + | {f_node = Fop (p, _)}, [rep; fn; base] when p = EcCoreLib.CI_Int.p_iteri + -> let rep = int_of_form rep in - let fs = List.init (BI.to_int rep) (fun i -> - fapply_safe fn [f_int (BI.of_int i)] - ) in - List.fold_lefti (fun f i fn -> - EcEnv.notify env `Debug "Translating iteri... Step #%d@." i; - let fn = doit st fn in - circuit_compose fn [f] - ) (doit st base) fs + let fs = + List.init (BI.to_int rep) (fun i -> + fapply_safe fn [f_int (BI.of_int i)]) + in + List.fold_lefti + (fun f i fn -> + EcEnv.notify env `Debug "Translating iteri... Step #%d@." i; + let fn = doit st fn in + circuit_compose fn [f]) + (doit st base) fs (* This is defined in terms of iteri, so it should get expanded and use the case above *) (* | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iter -> assert false *) - | ({f_node = Fop (p, _)}, [fn; start_val; reps]) when p = EcCoreLib.CI_Int.p_fold -> + | {f_node = Fop (p, _)}, [fn; start_val; reps] + when p = EcCoreLib.CI_Int.p_fold -> let reps = int_of_form reps |> BI.to_int in let fn = doit st fn in let start_val = doit st start_val in - List.fold_left (fun acc f -> - circuit_compose f [acc] - ) start_val (List.make reps fn) + List.fold_left + (fun acc f -> circuit_compose f [acc]) + start_val (List.make reps fn) | _ -> raise (DestrError "iter") - with CircError e -> - propagate_circ_error (`ExpandIter (f, fs)) e - in - let res = doit st f_ in + with CircError e -> propagate_circ_error (`ExpandIter (f, fs)) e + in + let res = doit st f_ in (* State cleanup *) begin op_cache := Mp.empty; EcAlphaInvHashtbl.clear cache end; res - -let circuit_check_posts ~(env: env) ~(pres: circuit list) (posts: circuit list) = + +let circuit_check_posts + ~(env : env) + ~(pres : circuit list) + (posts : circuit list) = let lap = stopwatch env in - EcEnv.notify env `Debug "Number of checks before batching: %d@." (List.length posts); + EcEnv.notify env `Debug "Number of checks before batching: %d@." + (List.length posts); let posts = batch_checks ~mode:`BySub posts in - EcEnv.notify env `Debug "Number of checks after batching: %d@." (List.length posts); + EcEnv.notify env `Debug "Number of checks after batching: %d@." + (List.length posts); lap "Done with lane compression"; - if fillet_tauts pres posts then - begin - lap "Done with equivalence checking (structural equality + SMT)"; - true - end - else - begin - lap "Failed equivalence check"; - false - end + if fillet_tauts pres posts then begin + lap "Done with equivalence checking (structural equality + SMT)"; + true + end + else begin + lap "Failed equivalence check"; + false + end -let circuits_of_equality ~(st: state) ~(hyps: hyps) (f1: form) (f2: form) : circuit list = +let circuits_of_equality ~(st : state) ~(hyps : hyps) (f1 : form) (f2 : form) : + circuit list = let env = toenv hyps in let lap = stopwatch env in @@ -774,81 +845,93 @@ let circuits_of_equality ~(st: state) ~(hyps: hyps) (f1: form) (f2: form) : circ lap "Done with postcondition circuit generation"; posts - -let circuit_simplify_equality ~(st: state) ~(hyps: hyps) ~(pres: circuit list) (f1: form) (f2: form) : bool = +let circuit_simplify_equality + ~(st : state) + ~(hyps : hyps) + ~(pres : circuit list) + (f1 : form) + (f2 : form) : bool = let posts = circuits_of_equality ~st ~hyps f1 f2 in circuit_check_posts ~env:(toenv hyps) ~pres posts - - + (* FIXME: add support for spec bindings for abstract/opaque operators = convert from Fop rather than from op body *) -let circuit_of_path (st: state) (hyps: hyps) (p: path) : circuit = +let circuit_of_path (st : state) (hyps : hyps) (p : path) : circuit = let f = EcEnv.Op.by_path p (toenv hyps) in - let f = match f.op_kind with - | OB_oper (Some (OP_Plain f)) -> f - | _ -> circ_error (MissingOpBody p) + let f = + match f.op_kind with + | OB_oper (Some (OP_Plain f)) -> f + | _ -> circ_error (MissingOpBody p) in circuit_of_form st hyps f let vars_of_memtype (mt : memtype) = - let Lmt_concrete lmt = mt in - List.filter_map (function - | { ov_name = Some name; ov_type = ty } -> - Some { v_name = name; v_type = ty; } - | _ -> None - ) (Option.get lmt).lmt_decl - - -let process_instr (hyps: hyps) (mem: memory) ~(st: state) (inst: instr) : state = - EcEnv.notify (toenv hyps) `Debug "[W] Processing : %a@." (EcPrinting.pp_instr (EcPrinting.PPEnv.ofenv (toenv hyps))) inst; + let (Lmt_concrete lmt) = mt in + List.filter_map + (function + | {ov_name = Some name; ov_type = ty} -> Some {v_name = name; v_type = ty} + | _ -> None) + (Option.get lmt).lmt_decl + +let process_instr (hyps : hyps) (mem : memory) ~(st : state) (inst : instr) : + state = + EcEnv.notify (toenv hyps) `Debug "[W] Processing : %a@." + (EcPrinting.pp_instr (EcPrinting.PPEnv.ofenv (toenv hyps))) + inst; try match inst.i_node with | Sasgn (LvVar (PVloc v, _ty), e) -> - let c = ((ss_inv_of_expr mem e).inv |> circuit_of_form st hyps) in + let c = (ss_inv_of_expr mem e).inv |> circuit_of_form st hyps in let st = update_state_pv st mem v c in st - | Sasgn (LvTuple (vs), {e_node = Etuple es; _}) when List.compare_lengths vs es = 0 -> - let st = List.fold_left (fun st (v, e) -> - let c = ((ss_inv_of_expr mem e).inv |> circuit_of_form st hyps) in - let st = update_state_pv st mem v c in - st - ) st - (List.combine - (List.map (function - | (PVloc v, _ty) -> v - | _ -> circ_error (CantConvertToCirc `Glob)) vs) - es) in + | Sasgn (LvTuple vs, {e_node = Etuple es; _}) + when List.compare_lengths vs es = 0 -> + let st = + List.fold_left + (fun st (v, e) -> + let c = (ss_inv_of_expr mem e).inv |> circuit_of_form st hyps in + let st = update_state_pv st mem v c in + st) + st + (List.combine + (List.map + (function + | PVloc v, _ty -> v + | _ -> circ_error (CantConvertToCirc `Glob)) + vs) + es) + in st - | Sasgn (LvTuple (vs), e) -> - let tp = ((ss_inv_of_expr mem e).inv |> circuit_of_form st hyps) in + | Sasgn (LvTuple vs, e) -> + let tp = (ss_inv_of_expr mem e).inv |> circuit_of_form st hyps in let comps = circuits_of_circuit_tuple tp in - let st = List.fold_left2 (fun st (pv, _ty) c -> - let v = match pv with - | PVloc v -> v - | _ -> circ_error (CantConvertToCirc `Glob) - in - update_state_pv st mem v c - ) st vs (comps :> circuit list) - in + let st = + List.fold_left2 + (fun st (pv, _ty) c -> + let v = + match pv with + | PVloc v -> v + | _ -> circ_error (CantConvertToCirc `Glob) + in + update_state_pv st mem v c) + st vs + (comps :> circuit list) + in st - | _ -> - circ_error (CantConvertToCirc `Instr) - with - | CircError e -> - propagate_circ_error (`Instr inst) e + | _ -> circ_error (CantConvertToCirc `Instr) + with CircError e -> propagate_circ_error (`Instr inst) e (* FIXME: check if memory is the right one in calls to state *) let instrs_equiv - (hyps : hyps ) - ((mem, _mt) : memenv ) - ?(keep : EcPV.PV.t option ) - (st : state ) - (s1 : instr list ) - (s2 : instr list ) : bool -= + (hyps : hyps) + ((mem, _mt) : memenv) + ?(keep : EcPV.PV.t option) + (st : state) + (s1 : instr list) + (s2 : instr list) : bool = let env = LDecl.toenv hyps in - let rd, rglobs = EcPV.PV.elements (EcPV.is_read env (s1 @ s2)) in + let rd, rglobs = EcPV.PV.elements (EcPV.is_read env (s1 @ s2)) in let wr, wglobs = EcPV.PV.elements (EcPV.is_write env (s1 @ s2)) in if not (List.is_empty rglobs && List.is_empty wglobs) then @@ -857,171 +940,218 @@ let instrs_equiv if not (List.for_all (EcTypes.is_loc -| fst) (rd @ wr)) then circ_error CantReadWriteGlobs; - let inputs = List.map (fun (pv, ty) -> { v_name = EcTypes.get_loc pv; v_type = ty; }) (rd @ wr) in - let inputs = List.map (fun {v_name; v_type} -> (create v_name, ctype_of_ty env v_type)) inputs in + let inputs = + List.map + (fun (pv, ty) -> {v_name = EcTypes.get_loc pv; v_type = ty}) + (rd @ wr) + in + let inputs = + List.map + (fun {v_name; v_type} -> create v_name, ctype_of_ty env v_type) + inputs + in let st = open_circ_lambda st inputs in let st1 = List.fold_left (fun st -> process_instr hyps mem ~st) st s1 in let st2 = List.fold_left (fun st -> process_instr hyps mem ~st) st s2 in - let st1 = close_circ_lambda st1 in + let st1 = close_circ_lambda st1 in let st2 = close_circ_lambda st2 in (* FIXME: what was the intended behaviour for keep? *) match keep with - | Some pv -> + | Some pv -> let vs = EcPV.PV.elements pv |> fst in - let vs = List.map (function - | (PVloc v, ty) -> (v, ty) - | _ -> circ_error (CantConvertToCirc `Glob) - ) vs - in List.for_all (fun (var, _ty) -> - let circ1 = state_get_pv_opt st1 mem var in - let circ2 = state_get_pv_opt st2 mem var in - match circ1, circ2 with - | None, None -> true - | None, Some _ - | Some _, None -> false (* Variable only defined on one of the blocks (and not in the prelude) *) - | Some circ1, Some circ2 -> circ_equiv circ1 circ2 - ) vs - | None -> state_get_all_memory st mem |> List.for_all (fun (var, _) -> - let circ1 = state_get_pv st1 mem var in - let circ2 = state_get_pv st2 mem var in - circ_equiv circ1 circ2 - ) + let vs = + List.map + (function + | PVloc v, ty -> v, ty + | _ -> circ_error (CantConvertToCirc `Glob)) + vs + in + List.for_all + (fun (var, _ty) -> + let circ1 = state_get_pv_opt st1 mem var in + let circ2 = state_get_pv_opt st2 mem var in + match circ1, circ2 with + | None, None -> true + | None, Some _ | Some _, None -> + false + (* Variable only defined on one of the blocks (and not in the prelude) *) + | Some circ1, Some circ2 -> circ_equiv circ1 circ2) + vs + | None -> + state_get_all_memory st mem + |> List.for_all (fun (var, _) -> + let circ1 = state_get_pv st1 mem var in + let circ2 = state_get_pv st2 mem var in + circ_equiv circ1 circ2) (* FIXME: change memory -> memenv Why? *) -let state_of_prog ?(close = false) (hyps: hyps) (mem: memory) ~(st: state) (proc: instr list) : state = - let st = - List.fold_left (fun st -> process_instr hyps mem ~st) st proc - in - if close then - close_circ_lambda st - else st +let state_of_prog + ?(close = false) + (hyps : hyps) + (mem : memory) + ~(st : state) + (proc : instr list) : state = + let st = List.fold_left (fun st -> process_instr hyps mem ~st) st proc in + if close then close_circ_lambda st else st let circ_simplify_form_bitstring_equality - ?(st: state = empty_state) - ?(pres: circuit list = []) - (hyps: hyps) - (f: form) - : form = + ?(st : state = empty_state) + ?(pres : circuit list = []) + (hyps : hyps) + (f : form) : form = let env = toenv hyps in let rec check (f : form) = match EcFol.sform_of_form f with | SFeq (f1, f2) - when (Option.is_some @@ EcEnv.Circuit.lookup_bitstring env f1.f_ty) - || (Option.is_some @@ EcEnv.Circuit.lookup_array env f1.f_ty) - -> + when (Option.is_some @@ EcEnv.Circuit.lookup_bitstring env f1.f_ty) + || (Option.is_some @@ EcEnv.Circuit.lookup_array env f1.f_ty) -> f_bool (circuit_simplify_equality ~st ~hyps ~pres f1 f2) - | _ -> f_map (fun ty -> ty) check f - in check f - + | _ -> f_map (fun ty -> ty) check f + in + check f (* Mli stuff needed: *) -let compute ~(sign: bool) (c: circuit) (args: zint list) : zint = +let compute ~(sign : bool) (c : circuit) (args : zint list) : zint = match compute ~sign c (List.map (fun z -> arg_of_zint z) args) with | Some z -> z | None -> circ_error CantConvertToConstant -let circ_equiv ?(pcond: circuit option) c1 c2 = - circ_equiv ?pcond c1 c2 - +let circ_equiv ?(pcond : circuit option) c1 c2 = circ_equiv ?pcond c1 c2 let circ_sat = circ_sat let circ_taut = circ_taut -let circuit_to_string ((circ, inps): circuit) : string = Format.asprintf "(%a => %a)" EcPrinting.(pp_list ", " pp_cinp) inps pp_circ circ -let circuit_ueq = (fun c1 c2 -> (circuit_eq c1 c2 :> circuit)) -let circuit_has_uninitialized = circuit_has_uninitialized +let circuit_to_string ((circ, inps) : circuit) : string = + Format.asprintf "(%a => %a)" + EcPrinting.(pp_list ", " pp_cinp) + inps pp_circ circ +let circuit_ueq = fun c1 c2 -> (circuit_eq c1 c2 :> circuit) +let circuit_has_uninitialized = circuit_has_uninitialized let circuit_to_file = circuit_to_file -let circuit_slice (c: circuit) (size: int) (offset: int) = +let circuit_slice (c : circuit) (size : int) (offset : int) = circuit_slice ~size c offset -let circuit_flatten (({type_; _}, _) as c: circuit) = +let circuit_flatten (({type_; _}, _) as c : circuit) = convert_type (CBitstring (size_of_ctype type_)) c let state_get = state_get_pv let state_get_opt = state_get_pv_opt let state_get_all = fun st -> state_get_all_pv st |> List.snd -let circuit_state_of_memenv ?(st: state = empty_state) (env:env) ((m, mt) as me: memenv) : state = +let circuit_state_of_memenv + ?(st : state = empty_state) + (env : env) + ((m, mt) as me : memenv) : state = match mt with - | (Lmt_concrete Some {lmt_decl=decls}) -> - let bnds = List.map (fun {ov_name; ov_type} -> - match ov_name with - | Some v -> - begin try - Some ((m, v), ctype_of_ty env ov_type) - with CircError err -> propagate_circ_error (`Memenv me) err + | Lmt_concrete (Some {lmt_decl = decls}) -> + let bnds = + List.map + (fun {ov_name; ov_type} -> + match ov_name with + | Some v -> begin + try Some ((m, v), ctype_of_ty env ov_type) + with CircError err -> propagate_circ_error (`Memenv me) err end - | None -> None - ) decls in - open_circ_lambda_pv st (List.filter_map identity bnds) + | None -> None) + decls + in + open_circ_lambda_pv st (List.filter_map identity bnds) | Lmt_concrete None -> st -let circuit_state_of_hyps ?(st: state = empty_state) ?(strict = false) (hyps: hyps) : state = +let circuit_state_of_hyps + ?(st : state = empty_state) + ?(strict = false) + (hyps : hyps) : state = let env = toenv hyps in let ppe = EcPrinting.PPEnv.ofenv env in - let st = List.fold_left (fun st (id, lk) -> - EcEnv.notify env `Debug "Processing hyp: %s@." (id.id_symb); - match lk with - (* If there is a memory, add all the variables from that memory into the translation state *) - | EcBaseLogic.LD_mem mt -> circuit_state_of_memenv ~st env (id, mt) - - (* Initialized variable. + let st = + List.fold_left + (fun st (id, lk) -> + EcEnv.notify env `Debug "Processing hyp: %s@." id.id_symb; + match lk with + (* If there is a memory, add all the variables from that memory into the translation state *) + | EcBaseLogic.LD_mem mt -> circuit_state_of_memenv ~st env (id, mt) + (* Initialized variable. Check if body is convertible to circuit, if not just process it as uninitialized. TODO: Maybe do a first pass on this, check convertibility and remove duplicates? *) - | EcBaseLogic.LD_var (t, Some f) -> - EcEnv.notify env `Debug "Assigning %a to %a@." EcPrinting.(pp_form ppe) f EcIdent.pp_ident id; - begin try - update_state st id (circuit_of_form st hyps f) - (* FIXME PR: Should only catch circuit translation errors, hack *) - with CircError e -> - EcEnv.notify env `Debug "Failed to translate hypothesis for var %s with error %a, skipping@." (tostring_internal id) (pp_circ_error ppe) e; - try - open_circ_lambda st [(id, ctype_of_ty env t)] - (* FIXME PR: Should only catch circuit translation errors, hack *) - with - | CircError (AbstractTyBinding _) - | CircError (MissingTyBinding _) as e -> - if strict then raise e else st - end - - (* Uninitialized variable. + | EcBaseLogic.LD_var (t, Some f) -> + EcEnv.notify env `Debug "Assigning %a to %a@." + EcPrinting.(pp_form ppe) + f EcIdent.pp_ident id; + begin + try + update_state st id (circuit_of_form st hyps f) + (* FIXME PR: Should only catch circuit translation errors, hack *) + with CircError e -> ( + EcEnv.notify env `Debug + "Failed to translate hypothesis for var %s with error %a, \ + skipping@." + (tostring_internal id) (pp_circ_error ppe) e; + try + open_circ_lambda st [id, ctype_of_ty env t] + (* FIXME PR: Should only catch circuit translation errors, hack *) + with + | ( CircError (AbstractTyBinding _) + | CircError (MissingTyBinding _) ) as e + -> + if strict then raise e else st) + end + (* Uninitialized variable. Treat as input *) - | EcBaseLogic.LD_var (t, None) -> - begin try - open_circ_lambda st [(id, ctype_of_ty env t)] - with - | CircError (AbstractTyBinding _) - | CircError (MissingTyBinding _) as e -> - if strict then raise e else st - end - - (* For things of the form a_ = a{&hr}, we assume the local variable takes precedence *) - | EcBaseLogic.LD_hyp f -> - begin match (EcCallbyValue.norm_cbv (circ_red hyps) hyps f) with - | {f_node=Fapp ({f_node = Fop (p, _); _}, [{f_node = Fpvar (PVloc pv, m); _}; fv])} - | {f_node=Fapp ({f_node = Fop (p, _); _}, [fv; {f_node = Fpvar (PVloc pv, m); _}])} when EcFol.op_kind p = Some `Eq -> - begin try - update_state_pv st m pv (circuit_of_form st hyps fv) - (* FIXME PR: Should only catch circuit translation errors, hack *) - with CircError e -> - EcEnv.notify env `Debug "Failed to translate hypothesis %s => %a@\nWith error: %a@\nSkipping...@\n" - id.id_symb EcPrinting.(pp_form ppe) f (pp_circ_error ppe) e; - st + | EcBaseLogic.LD_var (t, None) -> begin + try open_circ_lambda st [id, ctype_of_ty env t] + with + | (CircError (AbstractTyBinding _) | CircError (MissingTyBinding _)) + as e + -> + if strict then raise e else st end - | _ -> - EcEnv.notify env `Debug "Hypothesis %s: %a does not match any circuit translation patterns, skipping...@\n" - id.id_symb EcPrinting.(pp_form ppe) f; - st - end - - | _ -> st - ) st (List.rev (tohyps hyps).h_local) - in + (* For things of the form a_ = a{&hr}, we assume the local variable takes precedence *) + | EcBaseLogic.LD_hyp f -> begin + match EcCallbyValue.norm_cbv (circ_red hyps) hyps f with + | { + f_node = + Fapp + ( {f_node = Fop (p, _); _}, + [{f_node = Fpvar (PVloc pv, m); _}; fv] ); + } + | { + f_node = + Fapp + ( {f_node = Fop (p, _); _}, + [fv; {f_node = Fpvar (PVloc pv, m); _}] ); + } + when EcFol.op_kind p = Some `Eq -> begin + try + update_state_pv st m pv (circuit_of_form st hyps fv) + (* FIXME PR: Should only catch circuit translation errors, hack *) + with CircError e -> + EcEnv.notify env `Debug + "Failed to translate hypothesis %s => %a@\n\ + With error: %a@\n\ + Skipping...@\n" + id.id_symb + EcPrinting.(pp_form ppe) + f (pp_circ_error ppe) e; + st + end + | _ -> + EcEnv.notify env `Debug + "Hypothesis %s: %a does not match any circuit translation \ + patterns, skipping...@\n" + id.id_symb + EcPrinting.(pp_form ppe) + f; + st + end + | _ -> st) + st + (List.rev (tohyps hyps).h_local) + in st -let clear_translation_caches () = - EcLowCircuits.reset_backend_state (); +let clear_translation_caches () = EcLowCircuits.reset_backend_state () From 479d237ad792425968c8f170307c6ab6f999dfe1 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 1 Jun 2026 11:35:37 +0200 Subject: [PATCH 070/145] ecCircuits: remove dead values Warning 32 (unused value) is disabled project-wide, which had masked a set of never-used module-level bindings in this new file. Building it once with the warning enabled flagged 19 dead values; remove them: ty_of_path, width_of_type, input_of_type, temp_symbol, expand_iter_form, circuit_of_path, vars_of_memtype, compute, circ_equiv, circ_sat, circuit_to_string, circuit_ueq, circuit_has_uninitialized, circuit_to_file, circuit_slice, circuit_flatten, state_get, state_get_opt, state_get_all (mostly thin re-export shims of EcLowCircuits names that nothing consumed, plus a few genuinely-unused helpers). A second warning-32 pass confirms no further dead values remain. No behaviour change (release + ci builds clean, circuit tests pass). --- src/ecCircuits.ml | 99 ----------------------------------------------- 1 file changed, 99 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index df7e8f6887..f36f1c918f 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -204,8 +204,6 @@ let rec pp_circ_error ppe fmt (err : circuit_error) = (pp_memtype ppe) mt end -let ty_of_path (p : path) : ty = EcTypes.tconstr p [] - let rec ctype_of_ty (env : env) (ty : ty) : ctype = match ty.ty_node with | Ttuple tys -> CTuple (List.map (ctype_of_ty env) tys) @@ -223,18 +221,8 @@ let rec ctype_of_ty (env : env) (ty : ty) : ctype = | Some (_, {size = _, None}) -> circ_error (AbstractTyBinding (`Ty ty)) end -let width_of_type (env : env) (t : ty) : int = - let cty = ctype_of_ty env t in - EcLowCircuits.size_of_ctype cty - -let input_of_type ~name (env : env) (t : ty) : circuit = - let ct = ctype_of_ty env t in - input_of_ctype ~name ct - (* Should correspond to QF_ABV *) module BVOps = struct - let temp_symbol = "temp_circ_input" - let circuit_of_parametric_bvop (env : env) (op : [`Path of path | `BvBind of EcDecl.crb_bvoperator]) @@ -488,49 +476,6 @@ let form_is_iter (f : form) : bool = | _ -> false (* Expands iter, fold and iteri (for integer arguments) *) -let expand_iter_form (hyps : hyps) (f : form) : form = - let redmode = circ_red hyps in - let env = toenv hyps in - let ppenv = EcPrinting.PPEnv.ofenv env in - let ( @!! ) f fs = EcTypesafeFol.fapply_safe ~redmode hyps f fs in - - let res = - match f.f_node with - | Fapp ({f_node = Fop (p, _)}, [rep; fn; base]) - when p = EcCoreLib.CI_Int.p_iteri -> - let rep = int_of_form hyps rep in - let is = List.init (BI.to_int rep) BI.of_int in - EcEnv.notify env `Debug "Done generating functions!@."; - let f = - List.fold_left - (fun f i -> - EcEnv.notify env `Debug "Expanding iter... Step #%d@.Form: %a@." - (BI.to_int i) - (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (toenv hyps))) - f; - fn @!! [f_int i; f]) - base is - in - f - | Fapp ({f_node = Fop (p, _)}, [rep; fn; base]) - when p = EcCoreLib.CI_Int.p_iter -> - let rep = int_of_form hyps rep in - let is = List.init (BI.to_int rep) BI.of_int in - let f = List.fold_left (fun f _i -> fn @!! [f]) base is in - f - | Fapp ({f_node = Fop (p, _)}, [fn; base; rep]) - when p = EcCoreLib.CI_Int.p_fold -> - let rep = int_of_form hyps rep in - let is = List.init (BI.to_int rep) BI.of_int in - let f = List.fold_left (fun f _i -> fn @!! [f]) base is in - f - | _ -> raise (DestrError "iter") - in - EcEnv.notify env `Debug "Expanded iter form: @.%a@." - EcPrinting.(pp_form ppenv) - res; - res - let circuit_of_form (st : state) (* Program variable values *) (hyps : hyps) @@ -856,23 +801,6 @@ let circuit_simplify_equality (* FIXME: add support for spec bindings for abstract/opaque operators = convert from Fop rather than from op body *) -let circuit_of_path (st : state) (hyps : hyps) (p : path) : circuit = - let f = EcEnv.Op.by_path p (toenv hyps) in - let f = - match f.op_kind with - | OB_oper (Some (OP_Plain f)) -> f - | _ -> circ_error (MissingOpBody p) - in - circuit_of_form st hyps f - -let vars_of_memtype (mt : memtype) = - let (Lmt_concrete lmt) = mt in - List.filter_map - (function - | {ov_name = Some name; ov_type = ty} -> Some {v_name = name; v_type = ty} - | _ -> None) - (Option.get lmt).lmt_decl - let process_instr (hyps : hyps) (mem : memory) ~(st : state) (inst : instr) : state = EcEnv.notify (toenv hyps) `Debug "[W] Processing : %a@." @@ -1013,35 +941,8 @@ let circ_simplify_form_bitstring_equality in check f -(* Mli stuff needed: *) -let compute ~(sign : bool) (c : circuit) (args : zint list) : zint = - match compute ~sign c (List.map (fun z -> arg_of_zint z) args) with - | Some z -> z - | None -> circ_error CantConvertToConstant - -let circ_equiv ?(pcond : circuit option) c1 c2 = circ_equiv ?pcond c1 c2 -let circ_sat = circ_sat let circ_taut = circ_taut -let circuit_to_string ((circ, inps) : circuit) : string = - Format.asprintf "(%a => %a)" - EcPrinting.(pp_list ", " pp_cinp) - inps pp_circ circ - -let circuit_ueq = fun c1 c2 -> (circuit_eq c1 c2 :> circuit) -let circuit_has_uninitialized = circuit_has_uninitialized -let circuit_to_file = circuit_to_file - -let circuit_slice (c : circuit) (size : int) (offset : int) = - circuit_slice ~size c offset - -let circuit_flatten (({type_; _}, _) as c : circuit) = - convert_type (CBitstring (size_of_ctype type_)) c - -let state_get = state_get_pv -let state_get_opt = state_get_pv_opt -let state_get_all = fun st -> state_get_all_pv st |> List.snd - let circuit_state_of_memenv ?(st : state = empty_state) (env : env) From e7cf2a93e38f8d488d7a568437fb775fc3898a02 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 1 Jun 2026 11:43:10 +0200 Subject: [PATCH 071/145] ecCircuits: collapse CantConvertToCirc `OpK into `Op The two variants reported the same failure (an operator that is neither a circuit-bound base op nor an unfoldable definition); they differed only in whether EcFol.op_kind recognized the operator. Since the operator path is always available, drop `OpK of op_kind and report `Op of path in both cases. Removes the now-dead pp_op_kind printer. No behaviour change beyond a slightly less specific message for recognized-kind operators (release + ci clean, circuit tests pass). --- src/ecCircuits.ml | 38 +------------------------------------- src/ecCircuits.mli | 5 ++--- 2 files changed, 3 insertions(+), 40 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index f36f1c918f..cca56e342f 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -66,7 +66,6 @@ type circuit_error = | BadFormForArg of form | CantConvertToCirc of [ `Int - | `OpK of EcFol.op_kind | `Op of path | `Quantif of quantif | `Match @@ -85,37 +84,6 @@ let propagate_circ_error (call : circuit_conversion_call) (err : circuit_error) = raise (CircError (PropagateError (call, err))) -(* FIXME: move this to EcPrinting maybe? *) -let pp_op_kind (fmt : Format.formatter) (opk : EcFol.op_kind) : unit = - Format.fprintf fmt "%s" - (match opk with - | `Map_set -> "Map_set" - | `Real_le -> "Real_le" - | `Int_le -> "Int_le" - | `Iff -> "Iff" - | `Int_opp -> "Int_opp" - | `Int_lt -> "Int_lt" - | `Int_pow -> "Int_pow" - | `And `Asym -> "And (&&)" - | `And `Sym -> "And (/\\)" - | `Map_cst -> "Map_cst" - | `False -> "False" - | `Eq -> "Eq" - | `True -> "True" - | `Int_mul -> "Int_mul" - | `Real_inv -> "Real_inv" - | `Real_add -> "Real_add" - | `Int_edivz -> "Int_edivz" - | `Or `Asym -> "Or (||)" - | `Or `Sym -> "Or (\\/)" - | `Not -> "Not" - | `Int_add -> "Int_add" - | `Map_get -> "Map_get" - | `Real_lt -> "Real_lt" - | `Real_opp -> "Real_opp" - | `Real_mul -> "Real_mul" - | `Imp -> "Imp") - let rec pp_circ_error ppe fmt (err : circuit_error) = let open EcPrinting in match err with @@ -163,9 +131,6 @@ let rec pp_circ_error ppe fmt (err : circuit_error) = | `Int -> Format.fprintf fmt "Encountered unexpected integer (maybe you are missing a binding?)" - | `OpK opk -> - Format.fprintf fmt "Don't know how to translate op kind: %a" pp_op_kind - opk | `Op pth -> Format.fprintf fmt "Don't know how to convert operator at path %a to circuit (not \ @@ -562,8 +527,7 @@ let circuit_of_form match EcFol.op_kind (destr_op f_ |> fst) with | Some `True -> (circuit_true :> circuit) | Some `False -> (circuit_false :> circuit) - | Some opk -> circ_error (CantConvertToCirc (`OpK opk)) - | None -> + | _ -> circ_error (CantConvertToCirc (`Op (destr_op f_ |> fst))) end in diff --git a/src/ecCircuits.mli b/src/ecCircuits.mli index 038d00d27e..0c8157851a 100644 --- a/src/ecCircuits.mli +++ b/src/ecCircuits.mli @@ -34,9 +34,8 @@ type circuit_error = | CantReadWriteGlobs | BadFormForArg of form | CantConvertToCirc of - [ `Int - | `OpK of EcFol.op_kind - | `Op of path + [ `Int + | `Op of path | `Quantif of quantif | `Match | `Glob From 8f245b44409efd2cbba0ba8dfdeab23c2cab16a1 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 1 Jun 2026 13:36:22 +0200 Subject: [PATCH 072/145] runtest: add a file_include allow-list per test scenario tests.config sections are directory-oriented (okdirs scans whole dirs); there was no way to restrict a scenario to specific files. Add a 'file_include' key (whitespace-separated fnmatch globs, mirroring 'file_exclude'): empty means include everything (backward-compatible), otherwise a gathered file is kept only if it matches at least one glob. Also drop a stray debug 'print' in is_file_excluded. --- scripts/testing/runtest | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/scripts/testing/runtest b/scripts/testing/runtest index 3991380add..294d858d7b 100755 --- a/scripts/testing/runtest +++ b/scripts/testing/runtest @@ -140,6 +140,7 @@ def _options(): args = '', exclude = '', file_exclude = '', + file_include = '', okdirs = '', kodirs = '', ) @@ -183,6 +184,7 @@ def _options(): scenario.kodirs = config.get(test, 'kodirs') scenario.dexclude = config.get(test, 'exclude').split() scenario.fexclude = config.get(test, 'file_exclude').split() + scenario.finclude = config.get(test, 'file_include').split() options.scenarios[test[5:]] = scenario for x in options.targets: @@ -334,11 +336,18 @@ class Gather: @staticmethod def is_file_excluded(src, excludes): for exclude in excludes: - print(os.path.basename(src), exclude) if fnmatch.fnmatch(src, exclude): return True return False + @staticmethod + def is_file_included(src, includes): + # An empty include list means "include everything"; otherwise the + # file is kept only if it matches at least one glob. + if not includes: + return True + return any(fnmatch.fnmatch(src, include) for include in includes) + @staticmethod def is_file_statically_ignored(src): return os.path.basename(src).startswith('.#') @@ -398,7 +407,8 @@ class Gather: files = [ x for x in files if not cls.is_file_statically_ignored(x.filename) and - not cls.is_file_excluded(x.filename, scenario.fexclude) + not cls.is_file_excluded(x.filename, scenario.fexclude) and + cls.is_file_included(x.filename, scenario.finclude) ] return files From 5786089d6b3c9841740d678370c79b76c15bb966 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 1 Jun 2026 21:58:55 +0200 Subject: [PATCH 073/145] Remove dead t_outline_stmt from ecPhlOutline This function (added by this branch, marked 'FIXME PR: Remove?') was never called and not exported in the .mli. Removing it restores ecPhlOutline.ml to origin/main exactly. No behaviour change. --- src/phl/ecPhlOutline.ml | 34 ---------------------------------- 1 file changed, 34 deletions(-) diff --git a/src/phl/ecPhlOutline.ml b/src/phl/ecPhlOutline.ml index 69558e5ffc..803af0b5cd 100644 --- a/src/phl/ecPhlOutline.ml +++ b/src/phl/ecPhlOutline.ml @@ -7,40 +7,6 @@ open EcCoreGoal.FApi open EcLowPhlGoal (*---------------------------------------------------------------------------------------*) -(* FIXME PR: Remove? *) -let t_outline_stmt side start_pos end_pos s tc = - let env = FApi.tc1_env tc in - let goal = tc1_as_equivS tc in - - (* Check which memory/program we are outlining *) - let code = match side with - | `Left -> goal.es_sl - | `Right -> goal.es_sr - in - - (* Extract the program prefix and suffix *) - let rest, code_suff = s_split env end_pos code in - let code_pref, _, _ = s_split_i env start_pos (stmt rest) in - - let new_prog = s_seq (s_seq (stmt code_pref) s) (stmt code_suff) in - let tc = EcPhlTrans.t_equivS_trans_eq side new_prog tc in - - (* The middle goal, showing equivalence with the replaced code, ideally solves. *) - let tp = match side with | `Left -> 1 | `Right -> 2 in - let p = EcHiGoal.process_tfocus tc (Some [Some tp, Some tp], None) in - let tc = - t_onselect - p - (t_try ( - t_seqs [ - EcPhlInline.process_inline (`ByName (None, None, ([], None))); - EcPhlEqobs.t_eqobs_in None EcPhlEqobs.empty_sim_info; - EcPhlAuto.t_auto; - EcHiGoal.process_done; - ])) - tc - in - tc (* `by inline; sim; auto=> />` *) let t_auto_equiv_sim = From e114b11e38d7b8104b8886ed04990672ad614157 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 1 Jun 2026 22:05:58 +0200 Subject: [PATCH 074/145] ecUtils: drop debug oget dump and dead List.collapse - oget: revert the 'FIXME PR: Remove before merge' backtrace dump (Printexc.get_callstack ... print_raw_backtrace) before assert false; restore the plain 'assert false' as on origin/main. - List.collapse: remove (unused; distinct from the local 'collapse' in ecLowCircuits, which is a different function and stays). - Restore a stray-deleted blank line. ecUtils.ml/.mli now add only List.chunkify (used by ecLowCircuits' lane merging). Release + ci builds clean, circuit tests pass. --- src/ecUtils.ml | 9 ++------- src/ecUtils.mli | 1 - 2 files changed, 2 insertions(+), 8 deletions(-) diff --git a/src/ecUtils.ml b/src/ecUtils.ml index 08fd7a5411..2ae1c5c9cf 100644 --- a/src/ecUtils.ml +++ b/src/ecUtils.ml @@ -236,8 +236,7 @@ let oif (test : 'a -> bool) (x : 'a option) = let oget ?exn (x : 'a option) = match x, exn with - | None , None -> (* FIXME PR: Remove before merge *) - Printexc.get_callstack 100 |> Printexc.print_raw_backtrace stderr; assert false + | None , None -> assert false | None , Some exn -> raise exn | Some x, _ -> x @@ -605,11 +604,6 @@ module List = struct let has_dup ?(cmp = Stdlib.compare) (xs : 'a list) = Option.is_some (find_dup ~cmp xs) - let collapse ?(eq : 'a -> 'a -> bool = (=)) (xs : 'a list) = - match xs with - | [] -> None - | x :: xs -> if List.for_all (eq x) xs then Some x else None - (* List of size n*w into list of n lists of size w *) let chunkify (w : int) = let rec doit (acc : 'a list list) (xs : 'a list) = @@ -628,6 +622,7 @@ module List = struct | x::xs -> if p x then doit (x::acc) xs else (List.rev acc, x::xs) in doit [] xs + type 'a interruptible = [`Interrupt | `Continue of 'a] let fold_left_map_while (f : 'a -> 'b -> ('a * 'c) interruptible) = diff --git a/src/ecUtils.mli b/src/ecUtils.mli index 645ab61ce8..3f10ef1739 100644 --- a/src/ecUtils.mli +++ b/src/ecUtils.mli @@ -302,7 +302,6 @@ module List : sig val reduce1 : ('a list -> 'a) -> 'a list -> 'a val find_dup : ?cmp:('a -> 'a -> int) -> 'a list -> 'a option val has_dup : ?cmp:('a -> 'a -> int) -> 'a list -> bool - val collapse : ?eq:('a -> 'a -> bool) -> 'a list -> 'a option val chunkify : int -> 'a list -> 'a list list val takedrop_while : ('a -> bool) -> 'a list -> 'a list * 'a list From 8f4c7aa0b47179b3540d9f26109341c0a61b91c3 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 1 Jun 2026 22:13:12 +0200 Subject: [PATCH 075/145] ecCircuits: split circuit_of_form's recursion into named helpers The inner driver was a single ~210-line 'doit' with two very large match arms. Rename it to 'circuit_of_node' and extract the two heavy arms as sibling functions in the recursive group: - circuit_of_op_form : the Fop (nullary operator) arm - circuit_of_app : the Fapp (application) arm - circuit_of_logic_app: the inner logical-connective dispatch (Eq/Not/Imp/And/Or/Iff/compose) of an application circuit_of_node's match is now a one-line-per-node dispatch table. Purely a behaviour-preserving restructuring (no signature/.mli change, same shared per-call caches); release + ci clean, circuit tests pass. --- src/ecCircuits.ml | 248 +++++++++++++++++++++++----------------------- 1 file changed, 125 insertions(+), 123 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index cca56e342f..5257ce3978 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -474,16 +474,18 @@ let circuit_of_form match f.f_ty with | t when EcReduction.EqTest.is_int env t -> arg_of_zint (int_of_form f) | t when type_has_bindings env t -> - let f = doit st f in + let f = circuit_of_node st f in arg_of_circuit f | {ty_node = Tfun (i_t, c_t)} when i_t.ty_node = EcTypes.tint.ty_node && type_has_bindings env c_t -> arg_of_init (fun i -> let f = fapply_safe f [f_int (BI.of_int i)] in - doit st f) + circuit_of_node st f) | {ty_node = Tconstr (p, [t])} when p = EcCoreLib.CI_List.p_list && type_has_bindings env t -> - let cs = List.map (fun f -> doit st f) (form_list_of_form ~env f) in + let cs = + List.map (fun f -> circuit_of_node st f) (form_list_of_form ~env f) + in arg_of_circuits cs | _ -> EcLowCircuits.log st @@ -493,121 +495,19 @@ let circuit_of_form circ_error (BadFormForArg f) with CircError e -> propagate_circ_error (`ToArg f) e (* State does not get backward propagated so it is not returned *) - and doit (st : state) (f_ : form) : circuit = + and circuit_of_node (st : state) (f_ : form) : circuit = try begin match f_.f_node with | Fint _z -> circ_error (CantConvertToCirc `Int) | Fif (c_f, t_f, f_f) -> - let t = doit st t_f in - let f = doit st f_f in - let c = doit st c_f in + let t = circuit_of_node st t_f in + let f = circuit_of_node st f_f in + let c = circuit_of_node st c_f in circuit_ite ~c ~t ~f | Flocal idn -> state_get st idn - | Fop (pth, _) -> begin - if pth = EcCoreLib.CI_Witness.p_witness then ( - EcEnv.notify env `Debug "Assigning witness to var of type %a@." - EcPrinting.(pp_type ppe) - f_.f_ty; - circuit_uninit env f_.f_ty) - else - match Mp.find_opt pth !op_cache with - | Some op -> op - | None -> ( - match classify_baseop env pth with - | Some op -> - let circ = circuit_of_op env op in - op_cache := Mp.add pth circ !op_cache; - circ - | None -> - let circ = - match (EcEnv.Op.by_path pth env).op_kind with - | OB_oper (Some (OP_Plain f)) -> doit st f - | _ -> begin - match EcFol.op_kind (destr_op f_ |> fst) with - | Some `True -> (circuit_true :> circuit) - | Some `False -> (circuit_false :> circuit) - | _ -> - circ_error (CantConvertToCirc (`Op (destr_op f_ |> fst))) - end - in - op_cache := Mp.add pth circ !op_cache; - circ) - end - | Fapp (f, fs) -> - (* TODO: Maybe add cache statistics? *) - (* TODO: Maybe cache all forms *) - begin - match EcAlphaInvHashtbl.find_opt cache f_ with - | Some circ -> circ - | None -> - let paramop = - match f.f_node with - | Fop (pth, _) -> classify_paramop env pth - | _ -> None - in - let circ = - begin - match f, paramop with - | _, Some op -> - let args = List.map (arg_of_form st) fs in - circuit_of_op_with_args env op args - (* For dealing with iter cases: *) - | {f_node = Fop _}, _ when form_is_iter f_ -> - trans_iter st hyps f fs - | {f_node = Fop (_p, _)}, _ - when not - (List.for_all - (fun f -> f.f_ty.ty_node <> EcTypes.tint.ty_node) - fs) -> - doit st (propagate_integer_arguments f fs) - | {f_node = Fop _}, _ -> - (* Assuming correct types coming from EC *) - begin - match EcFol.op_kind (destr_op f |> fst), fs with - | Some `Eq, [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_eq c1 c2 :> circuit) - | Some `Not, [f] -> - let c = doit st f in - circuit_not c - | Some `True, [] -> (circuit_true :> circuit) - | Some `False, [] -> (circuit_false :> circuit) - | Some `Imp, [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_or (circuit_not c1) c2 :> circuit) - | Some (`And _), [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_and c1 c2 :> circuit) - | Some (`Or _), [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_or c1 c2 :> circuit) - | Some `Iff, [f1; f2] -> - let c1 = doit st f1 in - let c2 = doit st f2 in - (circuit_or (circuit_and c1 c2) - (circuit_and (circuit_not c1) (circuit_not c2)) - :> circuit) - (* Recurse down into definition *) - | _ -> - let f_c = doit st f in - let fcs = List.map (doit st) fs in - circuit_compose f_c fcs - end - (* Recurse down into definition *) - | _ -> - let f_c = doit st f in - let fcs = List.map (doit st) fs in - circuit_compose f_c fcs - end - in - EcAlphaInvHashtbl.add cache f_ circ; - circ - end + | Fop (pth, _) -> circuit_of_op_form st f_ pth + | Fapp (f, fs) -> circuit_of_app st f_ f fs | Fquant (qnt, binds, f) -> (* FIXME Does this type conversion make sense? *) let binds = @@ -616,28 +516,28 @@ let circuit_of_form begin match qnt with | Lforall | Llambda -> - circ_lambda_oneshot st binds (fun st -> doit st f) + circ_lambda_oneshot st binds (fun st -> circuit_of_node st f) (* FIXME: look at this interaction *) | Lexists -> circ_error (CantConvertToCirc (`Quantif qnt)) (* FIXME: Do we want to handle existentials? *) end | Fproj (f, i) -> - let ftp = doit st f in + let ftp = circuit_of_node st f in (circuit_tuple_proj ftp i :> circuit) | Fmatch (_f, _fs, _ty) -> circ_error (CantConvertToCirc `Match) | Flet (LSymbol (id, _t), v, f) -> - let vc = doit st v in + let vc = circuit_of_node st v in let st = update_state st id vc in - doit st f + circuit_of_node st f | Flet (LTuple vs, v, f) -> - let vc = doit st v in + let vc = circuit_of_node st v in let comps = circuits_of_circuit_tuple vc in let st = List.fold_left2 (fun st (id, _t) vc -> update_state st id vc) st vs comps in - doit st f + circuit_of_node st f | Flet (LRecord _, _, _) -> circ_error (CantConvertToCirc `Record) | Fpvar (pv, mem) -> let v = @@ -662,7 +562,7 @@ let circuit_of_form v | Fglob (_id, _mem) -> circ_error (CantConvertToCirc `ModGlob) | Ftuple comps -> - let comps = List.map (fun comp -> doit st comp) comps in + let comps = List.map (fun comp -> circuit_of_node st comp) comps in (circuit_tuple_of_circuits comps :> circuit) | FhoareF _ | FhoareS _ | FbdHoareF _ | FbdHoareS _ | FeHoareF _ | FeHoareS _ | FequivF _ | FequivS _ | FeagerF _ | Fpr _ -> @@ -672,6 +572,108 @@ let circuit_of_form *) end with CircError e -> propagate_circ_error (`Convert f_) e + (* Translate a nullary operator [Fop pth] (the whole form is [f_]). *) + and circuit_of_op_form (st : state) (f_ : form) (pth : path) : circuit = + if pth = EcCoreLib.CI_Witness.p_witness then ( + EcEnv.notify env `Debug "Assigning witness to var of type %a@." + EcPrinting.(pp_type ppe) + f_.f_ty; + circuit_uninit env f_.f_ty) + else + match Mp.find_opt pth !op_cache with + | Some op -> op + | None -> ( + match classify_baseop env pth with + | Some op -> + let circ = circuit_of_op env op in + op_cache := Mp.add pth circ !op_cache; + circ + | None -> + let circ = + match (EcEnv.Op.by_path pth env).op_kind with + | OB_oper (Some (OP_Plain f)) -> circuit_of_node st f + | _ -> begin + match EcFol.op_kind (destr_op f_ |> fst) with + | Some `True -> (circuit_true :> circuit) + | Some `False -> (circuit_false :> circuit) + | _ -> circ_error (CantConvertToCirc (`Op (destr_op f_ |> fst))) + end + in + op_cache := Mp.add pth circ !op_cache; + circ) + (* Translate an operator application whose head [f] is a (non-parametric, + non-iter, non-integer-specialized) operator applied to [fs]: the + logical connectives, otherwise recurse into the definition. *) + and circuit_of_logic_app (st : state) (f : form) (fs : form list) : circuit = + match EcFol.op_kind (destr_op f |> fst), fs with + | Some `Eq, [f1; f2] -> + let c1 = circuit_of_node st f1 in + let c2 = circuit_of_node st f2 in + (circuit_eq c1 c2 :> circuit) + | Some `Not, [f] -> + let c = circuit_of_node st f in + circuit_not c + | Some `True, [] -> (circuit_true :> circuit) + | Some `False, [] -> (circuit_false :> circuit) + | Some `Imp, [f1; f2] -> + let c1 = circuit_of_node st f1 in + let c2 = circuit_of_node st f2 in + (circuit_or (circuit_not c1) c2 :> circuit) + | Some (`And _), [f1; f2] -> + let c1 = circuit_of_node st f1 in + let c2 = circuit_of_node st f2 in + (circuit_and c1 c2 :> circuit) + | Some (`Or _), [f1; f2] -> + let c1 = circuit_of_node st f1 in + let c2 = circuit_of_node st f2 in + (circuit_or c1 c2 :> circuit) + | Some `Iff, [f1; f2] -> + let c1 = circuit_of_node st f1 in + let c2 = circuit_of_node st f2 in + (circuit_or (circuit_and c1 c2) + (circuit_and (circuit_not c1) (circuit_not c2)) + :> circuit) + (* Recurse down into definition *) + | _ -> + let f_c = circuit_of_node st f in + let fcs = List.map (circuit_of_node st) fs in + circuit_compose f_c fcs + (* Translate an application [Fapp (f, fs)] (the whole form is [f_]), + memoized in [cache]. *) + and circuit_of_app (st : state) (f_ : form) (f : form) (fs : form list) : + circuit = + match EcAlphaInvHashtbl.find_opt cache f_ with + | Some circ -> circ + | None -> + let paramop = + match f.f_node with + | Fop (pth, _) -> classify_paramop env pth + | _ -> None + in + let circ = + match f, paramop with + | _, Some op -> + let args = List.map (arg_of_form st) fs in + circuit_of_op_with_args env op args + (* For dealing with iter cases: *) + | {f_node = Fop _}, _ when form_is_iter f_ -> trans_iter st hyps f fs + | {f_node = Fop (_p, _)}, _ + when not + (List.for_all + (fun f -> f.f_ty.ty_node <> EcTypes.tint.ty_node) + fs) -> + circuit_of_node st (propagate_integer_arguments f fs) + | {f_node = Fop _}, _ -> + (* Assuming correct types coming from EC *) + circuit_of_logic_app st f fs + (* Recurse down into definition *) + | _ -> + let f_c = circuit_of_node st f in + let fcs = List.map (circuit_of_node st) fs in + circuit_compose f_c fcs + in + EcAlphaInvHashtbl.add cache f_ circ; + circ and trans_iter (st : state) (hyps : hyps) (f : form) (fs : form list) : circuit = try @@ -692,23 +694,23 @@ let circuit_of_form List.fold_lefti (fun f i fn -> EcEnv.notify env `Debug "Translating iteri... Step #%d@." i; - let fn = doit st fn in + let fn = circuit_of_node st fn in circuit_compose fn [f]) - (doit st base) fs + (circuit_of_node st base) fs (* This is defined in terms of iteri, so it should get expanded and use the case above *) (* | ({f_node = Fop (p, _)}, [rep; fn; base]) when p = EcCoreLib.CI_Int.p_iter -> assert false *) | {f_node = Fop (p, _)}, [fn; start_val; reps] when p = EcCoreLib.CI_Int.p_fold -> let reps = int_of_form reps |> BI.to_int in - let fn = doit st fn in - let start_val = doit st start_val in + let fn = circuit_of_node st fn in + let start_val = circuit_of_node st start_val in List.fold_left (fun acc f -> circuit_compose f [acc]) start_val (List.make reps fn) | _ -> raise (DestrError "iter") with CircError e -> propagate_circ_error (`ExpandIter (f, fs)) e in - let res = doit st f_ in + let res = circuit_of_node st f_ in (* State cleanup *) begin op_cache := Mp.empty; From bef50e2c05eb366e33a8e21178fdfeb9df9f0e62 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 2 Jun 2026 08:07:20 +0200 Subject: [PATCH 076/145] cleanup --- src/ecCircuits.ml | 170 +++++++++++++++++++++++++--------------------- 1 file changed, 94 insertions(+), 76 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 5257ce3978..659fc60563 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -440,21 +440,19 @@ let form_is_iter (f : form) : bool = true | _ -> false -(* Expands iter, fold and iteri (for integer arguments) *) -let circuit_of_form - (st : state) - (* Program variable values *) (hyps : hyps) - (f_ : EcAst.form) : circuit = - (* Form level cache, local to each high-level call *) - let cache : circuit EcAlphaInvHashtbl.t = EcAlphaInvHashtbl.create hyps 700 in - let op_cache : circuit Mp.t ref = ref Mp.empty in +let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = let redmode = circ_red hyps in let env = toenv hyps in let ppe = EcPrinting.PPEnv.ofenv env in - let fapply_safe f fs = - let res = EcTypesafeFol.fapply_safe ~redmode hyps f fs in - res + + let fapply_safe (f : form) (fs : form list) = + EcTypesafeFol.fapply_safe ~redmode hyps f fs in + + (* Form level cache, local to each high-level call *) + let cache : circuit EcAlphaInvHashtbl.t = EcAlphaInvHashtbl.create hyps 700 in + let op_cache : circuit Mp.t ref = ref Mp.empty in + let int_of_form (f : form) : zint = int_of_form hyps f in (* Supposed to be called on an apply *) @@ -472,21 +470,25 @@ let circuit_of_form let rec arg_of_form (st : state) (f : form) : arg = try match f.f_ty with - | t when EcReduction.EqTest.is_int env t -> arg_of_zint (int_of_form f) + | t when EcReduction.EqTest.is_int env t -> + arg_of_zint (int_of_form f) + | t when type_has_bindings env t -> let f = circuit_of_node st f in arg_of_circuit f - | {ty_node = Tfun (i_t, c_t)} - when i_t.ty_node = EcTypes.tint.ty_node && type_has_bindings env c_t -> + + | { ty_node = Tfun (i_t, c_t) } when + ty_equal i_t EcTypes.tint && type_has_bindings env c_t + -> arg_of_init (fun i -> let f = fapply_safe f [f_int (BI.of_int i)] in circuit_of_node st f) - | {ty_node = Tconstr (p, [t])} - when p = EcCoreLib.CI_List.p_list && type_has_bindings env t -> - let cs = - List.map (fun f -> circuit_of_node st f) (form_list_of_form ~env f) - in - arg_of_circuits cs + | { ty_node = Tconstr (p, [t]) } when + EcPath.p_equal p (EcCoreLib.CI_List.p_list) && type_has_bindings env t + -> + let cs = List.map (circuit_of_node st) (form_list_of_form ~env f) in + arg_of_circuits cs + | _ -> EcLowCircuits.log st @@ Format.asprintf "Failed to convert form to arg: %a@." @@ -494,20 +496,21 @@ let circuit_of_form f; circ_error (BadFormForArg f) with CircError e -> propagate_circ_error (`ToArg f) e + (* State does not get backward propagated so it is not returned *) and circuit_of_node (st : state) (f_ : form) : circuit = try begin match f_.f_node with - | Fint _z -> circ_error (CantConvertToCirc `Int) - | Fif (c_f, t_f, f_f) -> - let t = circuit_of_node st t_f in - let f = circuit_of_node st f_f in - let c = circuit_of_node st c_f in - circuit_ite ~c ~t ~f + | Fint _z -> + circ_error (CantConvertToCirc `Int) + | Flocal idn -> state_get st idn + | Fop (pth, _) -> circuit_of_op_form st f_ pth + | Fapp (f, fs) -> circuit_of_app st f_ f fs + | Fquant (qnt, binds, f) -> (* FIXME Does this type conversion make sense? *) let binds = @@ -518,27 +521,37 @@ let circuit_of_form | Lforall | Llambda -> circ_lambda_oneshot st binds (fun st -> circuit_of_node st f) (* FIXME: look at this interaction *) - | Lexists -> circ_error (CantConvertToCirc (`Quantif qnt)) - (* FIXME: Do we want to handle existentials? *) + | Lexists -> + circ_error (CantConvertToCirc (`Quantif qnt)) end + + | Fif (c_f, t_f, f_f) -> + let t = circuit_of_node st t_f in + let f = circuit_of_node st f_f in + let c = circuit_of_node st c_f in + circuit_ite ~c ~t ~f + | Fproj (f, i) -> let ftp = circuit_of_node st f in (circuit_tuple_proj ftp i :> circuit) - | Fmatch (_f, _fs, _ty) -> circ_error (CantConvertToCirc `Match) + + | Fmatch (_f, _fs, _ty) -> + circ_error (CantConvertToCirc `Match) + | Flet (LSymbol (id, _t), v, f) -> let vc = circuit_of_node st v in let st = update_state st id vc in circuit_of_node st f + | Flet (LTuple vs, v, f) -> let vc = circuit_of_node st v in let comps = circuits_of_circuit_tuple vc in - let st = - List.fold_left2 - (fun st (id, _t) vc -> update_state st id vc) - st vs comps - in + let st = List.fold_left2 update_state st (List.fst vs) comps in circuit_of_node st f - | Flet (LRecord _, _, _) -> circ_error (CantConvertToCirc `Record) + + | Flet (LRecord _, _, _) -> + circ_error (CantConvertToCirc `Record) + | Fpvar (pv, mem) -> let v = match pv with @@ -560,47 +573,48 @@ let circuit_of_form f_.f_ty (* Allow uninitialized program variables *) in v - | Fglob (_id, _mem) -> circ_error (CantConvertToCirc `ModGlob) + | Fglob (_id, _mem) -> + circ_error (CantConvertToCirc `ModGlob) + | Ftuple comps -> - let comps = List.map (fun comp -> circuit_of_node st comp) comps in + let comps = List.map (circuit_of_node st) comps in (circuit_tuple_of_circuits comps :> circuit) + | FhoareF _ | FhoareS _ | FbdHoareF _ | FbdHoareS _ | FeHoareF _ | FeHoareS _ | FequivF _ | FequivS _ | FeagerF _ | Fpr _ -> circ_error (CantConvertToCirc `Hoare) - (* FIXME: do we want to allow conversion of hoare statements? - Probably not at this point - *) end with CircError e -> propagate_circ_error (`Convert f_) e + (* Translate a nullary operator [Fop pth] (the whole form is [f_]). *) and circuit_of_op_form (st : state) (f_ : form) (pth : path) : circuit = - if pth = EcCoreLib.CI_Witness.p_witness then ( + if EcPath.p_equal pth EcCoreLib.CI_Witness.p_witness then begin EcEnv.notify env `Debug "Assigning witness to var of type %a@." EcPrinting.(pp_type ppe) f_.f_ty; - circuit_uninit env f_.f_ty) - else + circuit_uninit env f_.f_ty + end else match Mp.find_opt pth !op_cache with | Some op -> op - | None -> ( - match classify_baseop env pth with - | Some op -> - let circ = circuit_of_op env op in - op_cache := Mp.add pth circ !op_cache; - circ - | None -> - let circ = - match (EcEnv.Op.by_path pth env).op_kind with - | OB_oper (Some (OP_Plain f)) -> circuit_of_node st f - | _ -> begin - match EcFol.op_kind (destr_op f_ |> fst) with - | Some `True -> (circuit_true :> circuit) - | Some `False -> (circuit_false :> circuit) - | _ -> circ_error (CantConvertToCirc (`Op (destr_op f_ |> fst))) - end - in - op_cache := Mp.add pth circ !op_cache; - circ) + | None -> + let circ = circuit_of_op_form_real st f_ pth in + op_cache := Mp.add pth circ !op_cache; + circ + + and circuit_of_op_form_real (st : state) (f_ : form) (pth : path) : circuit = + match classify_baseop env pth with + | Some op -> + circuit_of_op env op + | None -> + match (EcEnv.Op.by_path pth env).op_kind with + | OB_oper (Some (OP_Plain f)) -> circuit_of_node st f + | _ -> begin + match EcFol.op_kind (destr_op f_ |> fst) with + | Some `True -> (circuit_true :> circuit) + | Some `False -> (circuit_false :> circuit) + | _ -> circ_error (CantConvertToCirc (`Op (destr_op f_ |> fst))) + end + (* Translate an operator application whose head [f] is a (non-parametric, non-iter, non-integer-specialized) operator applied to [fs]: the logical connectives, otherwise recurse into the definition. *) @@ -610,38 +624,48 @@ let circuit_of_form let c1 = circuit_of_node st f1 in let c2 = circuit_of_node st f2 in (circuit_eq c1 c2 :> circuit) + | Some `Not, [f] -> let c = circuit_of_node st f in circuit_not c - | Some `True, [] -> (circuit_true :> circuit) - | Some `False, [] -> (circuit_false :> circuit) + + | Some `True, [] -> + (circuit_true :> circuit) + + | Some `False, [] -> + (circuit_false :> circuit) + | Some `Imp, [f1; f2] -> let c1 = circuit_of_node st f1 in let c2 = circuit_of_node st f2 in (circuit_or (circuit_not c1) c2 :> circuit) + | Some (`And _), [f1; f2] -> let c1 = circuit_of_node st f1 in let c2 = circuit_of_node st f2 in (circuit_and c1 c2 :> circuit) + | Some (`Or _), [f1; f2] -> let c1 = circuit_of_node st f1 in let c2 = circuit_of_node st f2 in (circuit_or c1 c2 :> circuit) + | Some `Iff, [f1; f2] -> let c1 = circuit_of_node st f1 in let c2 = circuit_of_node st f2 in (circuit_or (circuit_and c1 c2) (circuit_and (circuit_not c1) (circuit_not c2)) :> circuit) + (* Recurse down into definition *) | _ -> let f_c = circuit_of_node st f in let fcs = List.map (circuit_of_node st) fs in circuit_compose f_c fcs + (* Translate an application [Fapp (f, fs)] (the whole form is [f_]), memoized in [cache]. *) - and circuit_of_app (st : state) (f_ : form) (f : form) (fs : form list) : - circuit = + and circuit_of_app (st : state) (f_ : form) (f : form) (fs : form list) : circuit = match EcAlphaInvHashtbl.find_opt cache f_ with | Some circ -> circ | None -> @@ -674,8 +698,8 @@ let circuit_of_form in EcAlphaInvHashtbl.add cache f_ circ; circ - and trans_iter (st : state) (hyps : hyps) (f : form) (fs : form list) : - circuit = + + and trans_iter (st : state) (hyps : hyps) (f : form) (fs : form list) : circuit = try (* FIXME: move auxiliary function out of the definitions *) let redmode = circ_red hyps in @@ -709,14 +733,8 @@ let circuit_of_form start_val (List.make reps fn) | _ -> raise (DestrError "iter") with CircError e -> propagate_circ_error (`ExpandIter (f, fs)) e - in - let res = circuit_of_node st f_ in - (* State cleanup *) - begin - op_cache := Mp.empty; - EcAlphaInvHashtbl.clear cache - end; - res + + in circuit_of_node st f_ let circuit_check_posts ~(env : env) From 555c584f9d59267ac95675c567ba21ccdf6771ab Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 2 Jun 2026 09:29:20 +0200 Subject: [PATCH 077/145] Add an interface for EcLowCircuits EcLowCircuits had no .mli, exposing its full inferred signature (backend, hash-consing tables, dependency analysis, SMT plumbing). Add a hand- authored ecLowCircuits.mli anchored on the existing module type CircuitInterface: it exposes only the circuit representation (abstract flatcirc/circ/circuit, ctype, cinp), the arg type, the translation state, the operator-translation helpers, the circuit constructors / decision procedures, and reset_backend_state. The backend (CBackend/LospecsBack), the functor, CSMT/CDeps and the global caches are now hidden. No behaviour change: builds clean under release and ci (-warn-error +a, so no value is left unused by the tightened interface); circuit tests pass (ext_test.ec is a pre-existing parse error). --- src/ecLowCircuits.mli | 174 ++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 174 insertions(+) create mode 100644 src/ecLowCircuits.mli diff --git a/src/ecLowCircuits.mli b/src/ecLowCircuits.mli new file mode 100644 index 0000000000..db63289291 --- /dev/null +++ b/src/ecLowCircuits.mli @@ -0,0 +1,174 @@ +(* -------------------------------------------------------------------- *) +open EcBigInt +open EcSymbols +open EcIdent +open EcMemory + +(* -------------------------------------------------------------------- *) +(* Low-level circuit interface: an AIG/QF_ABV circuit representation, the + translation state, and the decision procedures, on top of an (opaque) + backend. The backend, hash-consing tables, dependency analysis and SMT + plumbing are intentionally hidden. *) + +(* -------------------------------------------------------------------- *) +(* The backend's flattened circuit register (opaque). *) +type flatcirc + +(* The type of a circuit value. *) +type ctype = + | CArray of {width: int; count: int} + | CBitstring of int + | CTuple of ctype list + | CBool + +(* A circuit input. *) +type cinp = { + type_ : ctype; + id : int; +} + +(* A circuit: a register together with its type. *) +type circ = { + reg : flatcirc; + type_ : ctype; +} + +(* A circuit function: a value together with its open inputs. *) +type 'a cfun = 'a * (cinp list) +type circuit = circ cfun + +val pp_flatcirc : Format.formatter -> flatcirc -> unit + +(* -------------------------------------------------------------------- *) +(* Arguments to (parametric) circuit operators. *) +type arg = + [ `Circuit of circuit + | `Constant of zint + | `Init of int -> circuit + | `List of circuit list ] + +val arg_of_circuit : circuit -> arg +val arg_of_zint : zint -> arg +val arg_of_circuits : circuit list -> arg +val arg_of_init : (int -> circuit) -> arg +val pp_arg : Format.formatter -> arg -> unit + +(* -------------------------------------------------------------------- *) +(* Translation state: bindings from program variables / locals to the + circuits computing them, plus the circuit lambdas (open inputs). *) +type state + +val empty_state : state + +val update_state_pv : state -> memory -> symbol -> circuit -> state +val state_get_pv_opt : state -> memory -> symbol -> circuit option +val state_get_pv : state -> memory -> symbol -> circuit +val state_get_all_memory : state -> memory -> (symbol * circuit) list +val state_get_all_pv : state -> ((memory * symbol) * circuit) list + +val update_state : state -> ident -> circuit -> state +val state_get_opt : state -> ident -> circuit option +val state_get : state -> ident -> circuit +val state_bindings : state -> (ident * circuit) list +val state_lambdas : state -> cinp list +val state_is_closed : state -> bool +val state_close_circuit : state -> circuit -> circuit +val map_state_var : (ident -> circuit -> circuit) -> state -> state + +(* Circuit lambdas, for managing inputs *) +val open_circ_lambda : state -> (ident * ctype) list -> state +val open_circ_lambda_pv : state -> ((memory * symbol) * ctype) list -> state +val close_circ_lambda : state -> state +val circ_lambda_oneshot : state -> (ident * ctype) list -> (state -> circuit) -> circuit + +val set_logger : state -> (string -> unit) -> state +val log : state -> string -> unit + +(* -------------------------------------------------------------------- *) +(* Operator translation. *) +val bvget : circuit -> int -> circuit +val circuit_of_bvop : EcDecl.crb_bvoperator -> circuit +val circuit_of_parametric_bvop : EcDecl.crb_bvoperator -> arg list -> circuit + +val array_get : circuit -> int -> circuit +val array_set : circuit -> int -> circuit -> circuit +val array_oflist : circuit list -> circuit -> int -> circuit + +(* -------------------------------------------------------------------- *) +(* Circuit type utilities *) +val size_of_ctype : ctype -> int +val convert_type : ctype -> circuit -> circuit +val can_convert_input_type : ctype -> ctype -> bool + +(* Pretty printers *) +val pp_ctype : Format.formatter -> ctype -> unit +val pp_cinp : Format.formatter -> cinp -> unit +val pp_circ : Format.formatter -> circ -> unit +val pp_circuit : Format.formatter -> circuit -> unit + +(* General utilities *) +val circ_of_zint : size:int -> zint -> circ +val circuit_of_zint : size:int -> zint -> circuit + +(* Construct an input *) +val new_input_circuit : ?name:[`Str of string | `Idn of ident | `Bad] -> ctype -> circ * cinp +val input_of_ctype : ?name:[`Str of string | `Idn of ident | `Bad] -> ctype -> circuit + +(* Aggregation functions *) +val circuit_aggregate : circuit list -> circuit +val circuit_aggregate_inputs : circuit -> circuit + +(* Circuits representing booleans *) +val circuit_true : circuit +val circuit_false : circuit +val circuit_and : circuit -> circuit -> circuit +val circuit_or : circuit -> circuit -> circuit +val circuit_not : circuit -> circuit + +(* <=> circuit has no inputs (every input is unbound) *) +val circuit_is_free : circuit -> bool + +(* Direct circuit constructions *) +val circuit_ite : c:circuit -> t:circuit -> f:circuit -> circuit +val circuit_eq : circuit -> circuit -> circuit +val circuit_eqs : circuit -> circuit -> circuit list + +(* Circuit tuples *) +val circuit_tuple_proj : circuit -> int -> circuit +val circuit_tuple_of_circuits : circuit list -> circuit +val circuits_of_circuit_tuple : circuit -> circuit list + +(* Avoid nodes for uninitialized inputs *) +val circuit_uninit : ctype -> circuit +val circuit_has_uninitialized : circuit -> int option + +(* Logical reasoning over circuits *) +val circ_equiv : ?pcond:circuit -> circuit -> circuit -> bool +val circ_sat : circuit -> bool +val circ_taut : circuit -> bool + +(* Composition of circuit functions *) +val circuit_compose : circuit -> circuit list -> circuit + +(* Computing the function given by a circuit *) +val compute : sign:bool -> circuit -> arg list -> zint option + +(* Mapreduce / dependency-analysis related functions *) +val circuit_slice : size:int -> circuit -> int -> circuit +val circuit_slice_insert : circuit -> int -> circuit -> circuit +val fillet_circuit : circuit -> circuit list +val fillet_tauts : ?logger:(string -> unit) -> circuit list -> circuit list -> bool +val batch_checks : + ?logger:(string -> unit) + -> ?sort:bool + -> ?mode:[`ByEq | `BySub] + -> circuit list + -> circuit list + +val circuit_to_file : name:symbol -> circuit -> symbol +val circuit_from_spec : ?name:symbol -> (ctype list * ctype) -> Lospecs.Ast.adef -> circuit + +(* -------------------------------------------------------------------- *) +(* Reset the process-global backend state (AIG hash-cons table and the + dependency cache). *) +val reset_backend_state : unit -> unit From 56e6015b29399cb77947c5c7c4239911d4c7dadf Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 2 Jun 2026 10:04:43 +0200 Subject: [PATCH 078/145] ecLowCircuits: add section separators (house (* === *) / (* --- *) style) Apply EC's comment-separator convention to the previously unstructured 1.8k-line module: level-1 (* === *) framed headers before each top-level block (backend bindings, CBackend interface, lospecs backend, public CircuitInterface, the functor, the assembly) and level-2 (* --- *) headers for the sub-sections (Module Types, Exceptions, Helper functions, Pretty printers, CArgs, TranslationState, BVOps, ArrayOps). Comments only; release + ci build clean, circuit tests pass. --- src/ecLowCircuits.ml | 40 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 39 insertions(+), 1 deletion(-) diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index c47e1d606c..206ff03eb8 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -5,7 +5,9 @@ open EcDecl open EcIdent open EcMemory -(* -------------------------------------------------------------------- *) +(* ==================================================================== *) +(* Backend bindings (lospecs) and library aliases *) +(* ==================================================================== *) module C = struct include Lospecs.Aig include Lospecs.Circuit @@ -28,6 +30,10 @@ module Option = Batteries.Option (* Backend implementing minimal functions needed for the translation *) (* Minimal expected functionality is QF_ABV *) (* Input are: some identifier + some bit *) + +(* ==================================================================== *) +(* Backend interface (minimal QF_ABV functionality) *) +(* ==================================================================== *) module type CBackend = sig type node (* Corresponds to a single output node *) type reg @@ -159,6 +165,9 @@ module type CBackend = sig end end +(* ==================================================================== *) +(* Lospecs backend implementation *) +(* ==================================================================== *) module LospecsBack : CBackend = struct type node = C.node type reg = C.node array @@ -448,6 +457,9 @@ module LospecsBack : CBackend = struct end end +(* ==================================================================== *) +(* Public circuit interface *) +(* ==================================================================== *) module type CircuitInterface = sig type flatcirc type ctype = @@ -598,8 +610,13 @@ module type CircuitInterface = sig val circuit_from_spec : ?name:symbol -> (ctype list * ctype) -> Lospecs.Ast.adef -> circuit end +(* ==================================================================== *) +(* Circuit interface, built from a backend *) +(* ==================================================================== *) module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = struct + (* -------------------------------------------------------------------- *) (* Module Types *) + (* -------------------------------------------------------------------- *) type flatcirc = Backend.reg type ctype = CArray of {width: int; count: int; } @@ -617,7 +634,9 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = type 'a cfun = 'a * (cinp list) type circuit = circ cfun + (* -------------------------------------------------------------------- *) (* Exceptions *) + (* -------------------------------------------------------------------- *) type circconstructor = | Slice of { slice_size: int; bitstring_size: int; offset: int } | ASlice of { slice_size: int; container_size: int; offset: int } @@ -653,7 +672,9 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = raise (LowCircError err) + (* -------------------------------------------------------------------- *) (* Helper functions *) + (* -------------------------------------------------------------------- *) let (|->) ((a,b)) ((f,g)) = (f a, g b) let idnt = fun x -> x @@ -676,7 +697,9 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = | CTuple tys -> List.sum (List.map size_of_ctype tys) | CBool -> 1 + (* -------------------------------------------------------------------- *) (* Pretty printers *) + (* -------------------------------------------------------------------- *) let rec pp_ctype (fmt: Format.formatter) (t: ctype) : unit = match t with | CArray {width; count} -> Format.fprintf fmt "Array(%d@%d)" count width @@ -696,6 +719,9 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (fun fmt inps -> List.iter (fun inp -> Format.fprintf fmt "%a@\n" pp_cinp inp) inps) inps (* arg for circuit construction *) + (* -------------------------------------------------------------------- *) + (* Arguments for circuit construction *) + (* -------------------------------------------------------------------- *) module CArgs = struct type arg = [ `Circuit of circuit @@ -720,6 +746,9 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = end open CArgs + (* -------------------------------------------------------------------- *) + (* Translation state *) + (* -------------------------------------------------------------------- *) module TranslationState = struct type state = { circs : circuit Mid.t; @@ -1449,6 +1478,9 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = { reg = c; type_ = ret_ty}, inps (* TODO: type checking ? *) (* { reg = c; CBitstring c, inps) |> convert_type ret_ty *) + (* -------------------------------------------------------------------- *) + (* Bit-vector operators *) + (* -------------------------------------------------------------------- *) module BVOps = struct let bvget (c: circuit) (i: int) : circuit = match c with @@ -1729,6 +1761,9 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = -> assert false (* Should be guarded by call to op_is_bvop *) end + (* -------------------------------------------------------------------- *) + (* Array operators *) + (* -------------------------------------------------------------------- *) module ArrayOps = struct let array_get (c: circuit) (i: int) : circuit = match c with @@ -1773,6 +1808,9 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = end end +(* ==================================================================== *) +(* Assembly: instantiate the interface on the lospecs backend *) +(* ==================================================================== *) include MakeCircuitInterfaceFromCBackend(LospecsBack) include CArgs include TranslationState From 375a41f26c714d03b2e5635c6e4d564bc791e774 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 2 Jun 2026 10:22:45 +0200 Subject: [PATCH 079/145] ecLowCircuits: remove dead code Now that the .mli hides the functor internals, a warning-32/37 build flags dead module-level values and constructors (masked otherwise by the project-wide -32). Remove: values: (|->), idnt, merge_circuit_inputs, inputs_contained, convert_input_types, circuit_aslice constructors: circconstructor.ASlice, circconstructor.ASliceTy (only built by the now-removed circuit_aslice) A second warning pass confirms no further dead code remains. Release + ci builds clean, circuit tests pass. --- src/ecLowCircuits.ml | 51 -------------------------------------------- 1 file changed, 51 deletions(-) diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index 206ff03eb8..404507bc16 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -639,8 +639,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (* -------------------------------------------------------------------- *) type circconstructor = | Slice of { slice_size: int; bitstring_size: int; offset: int } - | ASlice of { slice_size: int; container_size: int; offset: int } - | ASliceTy of ctype | SliceSet of { slice_size: int; bitstring_size: int; offset: int } | AGet of { container_size: int; index: int } | ASet of { container_size: int; index: int } @@ -675,8 +673,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (* -------------------------------------------------------------------- *) (* Helper functions *) (* -------------------------------------------------------------------- *) - let (|->) ((a,b)) ((f,g)) = (f a, g b) - let idnt = fun x -> x let pp_flatcirc fmt fc = let r = Backend.node_list_of_reg fc in @@ -858,9 +854,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let merge_inputs_list (cs: cinp list list) : cinp list = List.fold_right (merge_inputs) cs [] - let merge_circuit_inputs (c: circuit) (d: circuit) : cinp list = - merge_inputs (snd c) (snd d) - let unify_inputs_renamer (target: cinp list) (inps: cinp list) : Backend.inp -> Backend.node option = let map = List.fold_left2 (fun map inp1 inp2 -> match inp1, inp2 with | {type_ = CBitstring w ; id=id_tgt}, @@ -888,10 +881,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let map_ = unify_inputs_renamer target inps in {c with reg = Backend.applys map_ c.reg} - let inputs_contained (subi: cinp list) (supi: cinp list) : bool = - List.compare_lengths subi supi < 0 && - List.for_all2 (=) (subi) (List.take (List.length subi) supi) - let circuit_input_compatible ?(strict = false) ((c, _): circuit) (cinp: cinp) : bool = match c.type_, cinp with | CBitstring n, { type_ = CBitstring n' } when n = n' -> true @@ -944,14 +933,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let can_convert_input_type (t1: ctype) (t2: ctype) : bool = size_of_ctype t1 = size_of_ctype t2 - let convert_input_types ((c, inps) : circuit) (tys: ctype list) : circuit = - c, List.map2 (fun inp ty -> - if can_convert_input_type inp.type_ ty then - { inp with type_ = ty } - else lowcircerror CircTyConversionFailure - ) inps tys - - let input_of_ctype ?(name : [`Str of string | `Idn of ident | `Bad ] = `Str "input") (ct: ctype) : circuit = let id, c = match name with | `Str name -> let id = EcIdent.create name |> tag in @@ -1135,38 +1116,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = }) (* Slice by container index *) - let circuit_aslice ~(size:int) ((c, inps): circuit) (offset: int) : circuit = - match c.type_ with - | CArray {width=w; count=n} -> - if (n < size + offset) || size < 0 || offset < 0 then - lowcircerror @@ CircConstructorInvalidArguments (ASlice { - slice_size = size; - container_size = n; - offset; - }); - - {reg = Backend.slice c.reg offset size; type_ = CArray {width=w; count=size}}, inps - - | CBitstring w -> lowcircerror @@ CircConstructorInvalidArguments (ASliceTy (CBitstring w)) - | CTuple tys -> - if List.compare_length_with tys (offset + size) < 0 - || offset < 0 || size < 0 then - lowcircerror @@ CircConstructorInvalidArguments (ASlice { - slice_size = size; - container_size = List.length tys; - offset; - }); - - let offset, tys = List.takedrop offset tys in - let offset = List.sum @@ List.map size_of_ctype offset in - let tys = (List.take size tys) in - let sz = List.sum @@ List.map size_of_ctype tys in - {reg = (Backend.slice c.reg offset sz); type_ = CTuple tys}, inps - - | CBool -> - lowcircerror @@ CircConstructorInvalidArguments (ASliceTy CBool) - - (* Does not type check *) let circuit_slice_insert ((orig_c, orig_inps): circuit) (idx: int) ((new_c, new_inps): circuit) : circuit = try From 1509da2c023f81267feb4bb94058a98292d93d8a Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 2 Jun 2026 10:30:30 +0200 Subject: [PATCH 080/145] lospecs/smt: reformat with the house ocamlformat profile (one-off) One-off ocamlformat pass (same profile as ecCircuits: margin 80, leading-| de-indented cases, begin..end preserved, vbox fun-decls) applied to libs/lospecs/smt.ml; max line length 109 -> 81. No config change (lospecs is not ocamlformat-managed; used --disable-conf-files to bypass the repo-root disable). No behaviour change: release + ci build clean, circuit tests pass. --- libs/lospecs/smt.ml | 383 ++++++++++++++++++++++++-------------------- 1 file changed, 210 insertions(+), 173 deletions(-) diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index d94eaae6fc..dccc2deab7 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -5,7 +5,7 @@ module type SMTInstance = sig type bvterm exception SMTError - + (* Expected params: sort, value *) val bvterm_of_int : int -> int -> bvterm @@ -17,7 +17,7 @@ module type SMTInstance = sig val assert' : bvterm -> unit (* Check satisfiability of current asserts *) - val check_sat : unit -> bool + val check_sat : unit -> bool (* equality over bitvectors, res is a size 1 bitvector *) val bvterm_equal : bvterm -> bvterm -> bvterm @@ -30,242 +30,279 @@ module type SMTInstance = sig (* bvnot *) val bvand : bvterm -> bvterm -> bvterm - val get_value : bvterm -> bvterm - val pp_term : Format.formatter -> bvterm -> unit end module type SMTInterface = sig - val circ_equiv : ?inps:(int * int) list -> reg -> reg -> node -> bool - + val circ_equiv : ?inps:(int * int) list -> reg -> reg -> node -> bool val circ_sat : ?inps:(int * int) list -> node -> bool - val circ_taut : ?inps:(int * int) list -> node -> bool end (* TODO Add model printing for circ_sat and circ_taut *) (* Assumes circuit inputs have already been appropriately renamed *) -module MakeSMTInterface(SMT: SMTInstance) : SMTInterface = struct - let circ_equiv ?(inps: (int * int) list option) (r1 : Aig.reg) (r2 : Aig.reg) (pcond : Aig.node) : bool = - if not ((Array.length r1 > 0) && (Array.length r2 > 0)) then - (Format.eprintf "Sizes differ in circ_equiv"; false) +module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct + let circ_equiv + ?(inps : (int * int) list option) + (r1 : Aig.reg) + (r2 : Aig.reg) + (pcond : Aig.node) : bool = + if not (Array.length r1 > 0 && Array.length r2 > 0) then ( + Format.eprintf "Sizes differ in circ_equiv"; + false) else - let bvvars : SMT.bvterm Map.String.t ref = ref Map.String.empty in - - let rec bvterm_of_node : Aig.node -> SMT.bvterm = - let cache = Hashtbl.create 0 in - - let rec doit (n : Aig.node) = - let mn = - match Hashtbl.find_option cache (Int.abs n.id) with - | None -> - let mn = doit_r n.gate in - Hashtbl.add cache (Int.abs n.id) mn; - mn - | Some mn -> - mn - in + let bvvars : SMT.bvterm Map.String.t ref = ref Map.String.empty in + + let rec bvterm_of_node : Aig.node -> SMT.bvterm = + let cache = Hashtbl.create 0 in + + let rec doit (n : Aig.node) = + let mn = + match Hashtbl.find_option cache (Int.abs n.id) with + | None -> + let mn = doit_r n.gate in + Hashtbl.add cache (Int.abs n.id) mn; + mn + | Some mn -> mn + in if 0 < n.id then mn else SMT.bvnot mn + and doit_r (n : Aig.node_r) = + match n with + | False -> SMT.bvterm_of_int 1 0 + | Input v -> + let name = + "BV_" + ^ (fst v |> string_of_int) + ^ "_" + ^ Printf.sprintf "%X" (snd v) + in + begin + match Map.String.find_opt name !bvvars with + | None -> + bvvars := + Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars; + Map.String.find name !bvvars + | Some t -> t + end + | And (n1, n2) -> SMT.bvand (doit n1) (doit n2) + in + fun n -> doit n + in + + let bvterm_of_reg (r : Aig.reg) : _ = + Array.map bvterm_of_node r + |> Array.reduce (fun acc b -> SMT.bvterm_concat b acc) + in + + let bvinpt1 = bvterm_of_reg r1 in + let bvinpt2 = bvterm_of_reg r2 in + let formula = SMT.bvterm_equal bvinpt1 bvinpt2 in + let pcond = bvterm_of_node pcond in + let inps = + Option.bind inps (fun l -> if List.is_empty l then None else Some l) + in + + let inps = + Option.map + (fun inps -> + List.map + (fun (id, sz) -> + List.init sz (fun i -> + "BV_" ^ (id |> string_of_int) ^ "_" ^ Printf.sprintf "%X" i)) + inps) + inps + in + let inps = + Option.map + (fun inps -> + List.map + (List.map (fun name -> + match Map.String.find_opt name !bvvars with + | Some bv -> bv + | None -> SMT.bvterm_of_name 1 name)) + inps) + inps + in + let bvinp = + Option.map + (fun inps -> List.map (fun i -> List.reduce SMT.bvterm_concat i) inps) + inps + in - and doit_r (n : Aig.node_r) = - match n with - | False -> SMT.bvterm_of_int 1 0 - | Input v -> let name = ("BV_" ^ (fst v |> string_of_int) ^ "_" ^ (Printf.sprintf "%X" (snd v))) in - begin - match Map.String.find_opt name !bvvars with - | None -> - bvvars := Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars; - Map.String.find name !bvvars - | Some t -> t + begin + SMT.assert' @@ SMT.bvand pcond (SMT.bvnot formula); + if SMT.check_sat () = false then true + else begin + Format.eprintf "bvout1: %a@." SMT.pp_term (SMT.get_value bvinpt1); + Format.eprintf "bvout2: %a@." SMT.pp_term (SMT.get_value bvinpt2); + Format.eprintf "Terms in formula: "; + List.iter (Format.eprintf "%s ") + (List.of_enum @@ Map.String.keys !bvvars); + Format.eprintf "@\n"; + Option.may + (fun bvinp -> + List.iteri + (fun i bv -> + Format.eprintf "input[%d]: %a@." i SMT.pp_term + (SMT.get_value bv)) + bvinp) + bvinp; + false end - | And (n1, n2) -> SMT.bvand (doit n1) (doit n2) - - in fun n -> doit n - in - - let bvterm_of_reg (r: Aig.reg) : _ = - Array.map bvterm_of_node r |> Array.reduce (fun acc b -> SMT.bvterm_concat b acc) - in - - let bvinpt1 = (bvterm_of_reg r1) in - let bvinpt2 = (bvterm_of_reg r2) in - let formula = SMT.bvterm_equal bvinpt1 bvinpt2 in - let pcond = (bvterm_of_node pcond) in - let inps = Option.bind inps (fun l -> - if List.is_empty l then None - else Some l - ) in - - let inps = Option.map (fun inps -> - List.map (fun (id,sz) -> - List.init sz (fun i -> ("BV_" ^ (id |> string_of_int) ^ "_" ^ (Printf.sprintf "%X" (i))))) inps - ) inps in - let inps = Option.map (fun inps -> - List.map (List.map (fun name -> match Map.String.find_opt name !bvvars with - | Some bv -> bv - | None -> SMT.bvterm_of_name 1 name)) inps) inps - in - let bvinp = Option.map (fun inps -> - List.map (fun i -> List.reduce (SMT.bvterm_concat) i) inps) inps - in - - begin - SMT.assert' @@ SMT.bvand pcond (SMT.bvnot formula); - if SMT.check_sat () = false then true - else begin - Format.eprintf "bvout1: %a@." SMT.pp_term (SMT.get_value bvinpt1); - Format.eprintf "bvout2: %a@." SMT.pp_term (SMT.get_value bvinpt2); - Format.eprintf "Terms in formula: "; - List.iter (Format.eprintf "%s ") (List.of_enum @@ Map.String.keys !bvvars); - Format.eprintf "@\n"; - Option.may (fun bvinp -> - List.iteri (fun i bv -> - Format.eprintf "input[%d]: %a@." i SMT.pp_term (SMT.get_value bv) - ) bvinp) bvinp; - false end - end - (* TODO: better encoding of smt terms ? *) - let circ_sat ?(inps: (int * int) list option) (n : Aig.node) : bool = + let circ_sat ?(inps : (int * int) list option) (n : Aig.node) : bool = let bvvars : SMT.bvterm Map.String.t ref = ref Map.String.empty in - begin match inps with - | None -> () - | Some inps -> List.iter (fun (id, sz) -> - List.iter (fun i -> - let name = ("BV_" ^ (string_of_int id) ^ "_" ^ (Printf.sprintf "%05X" i)) in - bvvars := Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars) - (List.init sz identity)) inps + begin + match inps with + | None -> () + | Some inps -> + List.iter + (fun (id, sz) -> + List.iter + (fun i -> + let name = + "BV_" ^ string_of_int id ^ "_" ^ Printf.sprintf "%05X" i + in + bvvars := + Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars) + (List.init sz identity)) + inps end; let rec bvterm_of_node : Aig.node -> SMT.bvterm = let cache = Hashtbl.create 0 in - + let rec doit (n : Aig.node) = - let mn = + let mn = match Hashtbl.find_option cache (Int.abs n.id) with | None -> let mn = doit_r n.gate in Hashtbl.add cache (Int.abs n.id) mn; mn - | Some mn -> - mn - in - if 0 < n.id then mn else SMT.bvnot mn - - and doit_r (n : Aig.node_r) = + | Some mn -> mn + in + if 0 < n.id then mn else SMT.bvnot mn + and doit_r (n : Aig.node_r) = match n with - | False -> SMT.bvterm_of_int 1 0 - | Input v -> let name = ("BV_" ^ (fst v |> string_of_int) ^ "_" ^ (Printf.sprintf "%05X" (snd v))) in - begin - match Map.String.find_opt name !bvvars with - | None -> - bvvars := Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars; - Map.String.find name !bvvars - | Some t -> t - end + | False -> SMT.bvterm_of_int 1 0 + | Input v -> + let name = + "BV_" + ^ (fst v |> string_of_int) + ^ "_" + ^ Printf.sprintf "%05X" (snd v) + in + begin + match Map.String.find_opt name !bvvars with + | None -> + bvvars := Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars; + Map.String.find name !bvvars + | Some t -> t + end | And (n1, n2) -> SMT.bvand (doit n1) (doit n2) + in + fun n -> doit n + in - in fun n -> doit n - in - - let form = bvterm_of_node n in + let form = bvterm_of_node n in let form = SMT.(bvterm_equal form @@ bvterm_of_int 1 1) in - let inps = Option.bind inps (fun l -> - if List.is_empty l then None - else Some l - ) in - - let inps = Option.map (fun inps -> - List.map (fun (id,sz) -> - List.init sz (fun i -> ("BV_" ^ (id |> string_of_int) ^ "_" ^ (Printf.sprintf "%05X" (i))))) inps - ) inps in - let inps = Option.map (fun inps -> - List.map (List.map (fun name -> match Map.String.find_opt name !bvvars with - | Some bv -> bv - | None -> SMT.bvterm_of_name 1 name)) inps) inps + let inps = + Option.bind inps (fun l -> if List.is_empty l then None else Some l) in - let bvinp = Option.map (fun inps -> - List.map (fun i -> List.reduce (SMT.bvterm_concat) i) inps) inps + + let inps = + Option.map + (fun inps -> + List.map + (fun (id, sz) -> + List.init sz (fun i -> + "BV_" ^ (id |> string_of_int) ^ "_" ^ Printf.sprintf "%05X" i)) + inps) + inps + in + let inps = + Option.map + (fun inps -> + List.map + (List.map (fun name -> + match Map.String.find_opt name !bvvars with + | Some bv -> bv + | None -> SMT.bvterm_of_name 1 name)) + inps) + inps + in + let bvinp = + Option.map + (fun inps -> List.map (fun i -> List.reduce SMT.bvterm_concat i) inps) + inps in begin SMT.assert' @@ form; - if SMT.check_sat () = true then - begin + if SMT.check_sat () = true then begin Format.eprintf "Input BVVars: "; let () = Enum.iter (Format.eprintf "%s, ") (Map.String.keys !bvvars) in Format.eprintf "@."; - Option.may (fun bvinp -> List.iteri (fun i bv -> - Format.eprintf "input[%d]: %a@." i SMT.pp_term (SMT.get_value bv) - ) bvinp) bvinp; - true + Option.may + (fun bvinp -> + List.iteri + (fun i bv -> + Format.eprintf "input[%d]: %a@." i SMT.pp_term + (SMT.get_value bv)) + bvinp) + bvinp; + true end else false end - - let circ_taut ?inps (n: Aig.node) : bool = - not @@ circ_sat ?inps (Aig.neg n) + let circ_taut ?inps (n : Aig.node) : bool = not @@ circ_sat ?inps (Aig.neg n) end - -let makeBWZinstance () : (module SMTInstance) = +let makeBWZinstance () : (module SMTInstance) = let options = Options.default () in Options.set options Produce_models true; let bitwuzla = Solver.create options in - - (module struct - type bvterm = Term.t - exception SMTError - - let bvterm_of_int (sort: int) (v: int) : bvterm = - mk_bv_value_int (mk_bv_sort sort) v - + (module struct + type bvterm = Term.t - let bvterm_of_name (sort: int) (name: string) : bvterm = - mk_const (mk_bv_sort sort) ~symbol:name - + exception SMTError - let assert' (f: bvterm) : unit = - Solver.assert_formula bitwuzla f + let bvterm_of_int (sort : int) (v : int) : bvterm = + mk_bv_value_int (mk_bv_sort sort) v - let check_sat () : bool = - match Solver.check_sat bitwuzla with - | Sat -> true - | Unsat -> false - | Unknown -> raise SMTError - + let bvterm_of_name (sort : int) (name : string) : bvterm = + mk_const (mk_bv_sort sort) ~symbol:name - let bvterm_equal (bv1: bvterm) (bv2: bvterm) : bvterm = - mk_term2 Kind.Equal bv1 bv2 + let assert' (f : bvterm) : unit = Solver.assert_formula bitwuzla f - let bvterm_concat (bv1: bvterm) (bv2: bvterm) : bvterm = - mk_term2 Kind.Bv_concat bv1 bv2 + let check_sat () : bool = + match Solver.check_sat bitwuzla with + | Sat -> true + | Unsat -> false + | Unknown -> raise SMTError - let bvnot (bv: bvterm) : bvterm = - mk_term1 Kind.Bv_not bv + let bvterm_equal (bv1 : bvterm) (bv2 : bvterm) : bvterm = + mk_term2 Kind.Equal bv1 bv2 - let bvand (bv1: bvterm) (bv2: bvterm) : bvterm = - mk_term2 Kind.Bv_and bv1 bv2 + let bvterm_concat (bv1 : bvterm) (bv2 : bvterm) : bvterm = + mk_term2 Kind.Bv_concat bv1 bv2 - let get_value (bv: bvterm) : bvterm = - Solver.get_value bitwuzla bv + let bvnot (bv : bvterm) : bvterm = mk_term1 Kind.Bv_not bv - let pp_term (fmt: Format.formatter) (bv: bvterm) : unit = - Term.pp fmt bv + let bvand (bv1 : bvterm) (bv2 : bvterm) : bvterm = + mk_term2 Kind.Bv_and bv1 bv2 + let get_value (bv : bvterm) : bvterm = Solver.get_value bitwuzla bv + let pp_term (fmt : Format.formatter) (bv : bvterm) : unit = Term.pp fmt bv end : SMTInstance) - let makeBWZinterface () : (module SMTInterface) = (module MakeSMTInterface ((val makeBWZinstance () : SMTInstance))) - - - From 546a992bf8dc36b0f4c2e7f1ffe536eccfb46cb6 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 2 Jun 2026 11:36:56 +0200 Subject: [PATCH 081/145] lospecs/smt: factor out SMT input-variable name encoding The variable-name encoding was inlined at five sites with two inconsistent bit-index formats (%X in circ_equiv, %05X in circ_sat). Extract a single name_of_var helper in MakeSMTInterface and unify on %05X. --- libs/lospecs/smt.ml | 210 +++++++++++++++++++++----------------------- 1 file changed, 101 insertions(+), 109 deletions(-) diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index dccc2deab7..39574cffff 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -1,6 +1,8 @@ +(* ==================================================================== *) open Aig open Bitwuzla_cxx +(* ==================================================================== *) module type SMTInstance = sig type bvterm @@ -34,123 +36,121 @@ module type SMTInstance = sig val pp_term : Format.formatter -> bvterm -> unit end +(* ==================================================================== *) module type SMTInterface = sig val circ_equiv : ?inps:(int * int) list -> reg -> reg -> node -> bool val circ_sat : ?inps:(int * int) list -> node -> bool val circ_taut : ?inps:(int * int) list -> node -> bool end +(* ==================================================================== *) (* TODO Add model printing for circ_sat and circ_taut *) (* Assumes circuit inputs have already been appropriately renamed *) module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct + (* SMT variable name for bit [bit] of circuit input [id]. *) + let name_of_var (id : int) (bit : int) : string = + Printf.sprintf "BV_%d_%05X" id bit + let circ_equiv ?(inps : (int * int) list option) (r1 : Aig.reg) (r2 : Aig.reg) (pcond : Aig.node) : bool = - if not (Array.length r1 > 0 && Array.length r2 > 0) then ( - Format.eprintf "Sizes differ in circ_equiv"; - false) - else - let bvvars : SMT.bvterm Map.String.t ref = ref Map.String.empty in - - let rec bvterm_of_node : Aig.node -> SMT.bvterm = - let cache = Hashtbl.create 0 in - - let rec doit (n : Aig.node) = - let mn = - match Hashtbl.find_option cache (Int.abs n.id) with - | None -> - let mn = doit_r n.gate in - Hashtbl.add cache (Int.abs n.id) mn; - mn - | Some mn -> mn - in - if 0 < n.id then mn else SMT.bvnot mn - and doit_r (n : Aig.node_r) = - match n with - | False -> SMT.bvterm_of_int 1 0 - | Input v -> - let name = - "BV_" - ^ (fst v |> string_of_int) - ^ "_" - ^ Printf.sprintf "%X" (snd v) - in - begin - match Map.String.find_opt name !bvvars with - | None -> - bvvars := - Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars; - Map.String.find name !bvvars - | Some t -> t - end - | And (n1, n2) -> SMT.bvand (doit n1) (doit n2) + assert (Array.length r1 = Array.length r2); + assert (Array.length r1 > 0); + assert (Array.length r2 > 0); + + let bvvars : SMT.bvterm Map.String.t ref = ref Map.String.empty in + + let rec bvterm_of_node : Aig.node -> SMT.bvterm = + let cache = Hashtbl.create 0 in + + let rec doit (n : Aig.node) = + let mn = + match Hashtbl.find_option cache (Int.abs n.id) with + | None -> + let mn = doit_r n.gate in + Hashtbl.add cache (Int.abs n.id) mn; + mn + | Some mn -> mn in - fun n -> doit n + if 0 < n.id then mn else SMT.bvnot mn + and doit_r (n : Aig.node_r) = + match n with + | False -> SMT.bvterm_of_int 1 0 + | Input v -> + let name = name_of_var (fst v) (snd v) in + begin + match Map.String.find_opt name !bvvars with + | None -> + bvvars := Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars; + Map.String.find name !bvvars + | Some t -> t + end + | And (n1, n2) -> SMT.bvand (doit n1) (doit n2) in + fun n -> doit n + in - let bvterm_of_reg (r : Aig.reg) : _ = - Array.map bvterm_of_node r - |> Array.reduce (fun acc b -> SMT.bvterm_concat b acc) - in + let bvterm_of_reg (r : Aig.reg) : _ = + Array.map bvterm_of_node r + |> Array.reduce (fun acc b -> SMT.bvterm_concat b acc) + in - let bvinpt1 = bvterm_of_reg r1 in - let bvinpt2 = bvterm_of_reg r2 in - let formula = SMT.bvterm_equal bvinpt1 bvinpt2 in - let pcond = bvterm_of_node pcond in - let inps = - Option.bind inps (fun l -> if List.is_empty l then None else Some l) - in + let bvinpt1 = bvterm_of_reg r1 in + let bvinpt2 = bvterm_of_reg r2 in + let formula = SMT.bvterm_equal bvinpt1 bvinpt2 in + let pcond = bvterm_of_node pcond in + let inps = + Option.bind inps (fun l -> if List.is_empty l then None else Some l) + in - let inps = - Option.map - (fun inps -> - List.map - (fun (id, sz) -> - List.init sz (fun i -> - "BV_" ^ (id |> string_of_int) ^ "_" ^ Printf.sprintf "%X" i)) - inps) - inps - in - let inps = - Option.map - (fun inps -> - List.map - (List.map (fun name -> - match Map.String.find_opt name !bvvars with - | Some bv -> bv - | None -> SMT.bvterm_of_name 1 name)) - inps) - inps - in - let bvinp = - Option.map - (fun inps -> List.map (fun i -> List.reduce SMT.bvterm_concat i) inps) - inps - in + let inps = + Option.map + (fun inps -> + List.map + (fun (id, sz) -> List.init sz (fun i -> name_of_var id i)) + inps) + inps + in + let inps = + Option.map + (fun inps -> + List.map + (List.map (fun name -> + match Map.String.find_opt name !bvvars with + | Some bv -> bv + | None -> SMT.bvterm_of_name 1 name)) + inps) + inps + in + let bvinp = + Option.map + (fun inps -> List.map (fun i -> List.reduce SMT.bvterm_concat i) inps) + inps + in - begin - SMT.assert' @@ SMT.bvand pcond (SMT.bvnot formula); - if SMT.check_sat () = false then true - else begin - Format.eprintf "bvout1: %a@." SMT.pp_term (SMT.get_value bvinpt1); - Format.eprintf "bvout2: %a@." SMT.pp_term (SMT.get_value bvinpt2); - Format.eprintf "Terms in formula: "; - List.iter (Format.eprintf "%s ") - (List.of_enum @@ Map.String.keys !bvvars); - Format.eprintf "@\n"; - Option.may - (fun bvinp -> - List.iteri - (fun i bv -> - Format.eprintf "input[%d]: %a@." i SMT.pp_term - (SMT.get_value bv)) - bvinp) - bvinp; - false - end + begin + SMT.assert' @@ SMT.bvand pcond (SMT.bvnot formula); + if SMT.check_sat () = false then true + else begin + Format.eprintf "bvout1: %a@." SMT.pp_term (SMT.get_value bvinpt1); + Format.eprintf "bvout2: %a@." SMT.pp_term (SMT.get_value bvinpt2); + Format.eprintf "Terms in formula: "; + List.iter (Format.eprintf "%s ") + (List.of_enum @@ Map.String.keys !bvvars); + Format.eprintf "@\n"; + Option.may + (fun bvinp -> + List.iteri + (fun i bv -> + Format.eprintf "input[%d]: %a@." i SMT.pp_term + (SMT.get_value bv)) + bvinp) + bvinp; + false end + end (* TODO: better encoding of smt terms ? *) let circ_sat ?(inps : (int * int) list option) (n : Aig.node) : bool = @@ -164,9 +164,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct (fun (id, sz) -> List.iter (fun i -> - let name = - "BV_" ^ string_of_int id ^ "_" ^ Printf.sprintf "%05X" i - in + let name = name_of_var id i in bvvars := Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars) (List.init sz identity)) @@ -190,12 +188,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct match n with | False -> SMT.bvterm_of_int 1 0 | Input v -> - let name = - "BV_" - ^ (fst v |> string_of_int) - ^ "_" - ^ Printf.sprintf "%05X" (snd v) - in + let name = name_of_var (fst v) (snd v) in begin match Map.String.find_opt name !bvvars with | None -> @@ -219,9 +212,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct Option.map (fun inps -> List.map - (fun (id, sz) -> - List.init sz (fun i -> - "BV_" ^ (id |> string_of_int) ^ "_" ^ Printf.sprintf "%05X" i)) + (fun (id, sz) -> List.init sz (fun i -> name_of_var id i)) inps) inps in @@ -261,9 +252,10 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct else false end - let circ_taut ?inps (n : Aig.node) : bool = not @@ circ_sat ?inps (Aig.neg n) + let circ_taut ?inps (n : Aig.node) : bool = not (circ_sat ?inps (Aig.neg n)) end +(* ==================================================================== *) let makeBWZinstance () : (module SMTInstance) = let options = Options.default () in Options.set options Produce_models true; From 16c44a65ae315112cdefdf622f129d28a4f1a230 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 2 Jun 2026 11:43:30 +0200 Subject: [PATCH 082/145] lospecs/smt: factor out the shared AIG-to-SMT node translation circ_equiv and circ_sat each contained a byte-identical inner bvterm_of_node (cache + doit/doit_r recursion). Lift it to a single helper in MakeSMTInterface, parameterized over the bvvars ref. --- libs/lospecs/smt.ml | 95 +++++++++++++++++---------------------------- 1 file changed, 36 insertions(+), 59 deletions(-) diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index 39574cffff..cf4ddd48d5 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -51,6 +51,40 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct let name_of_var (id : int) (bit : int) : string = Printf.sprintf "BV_%d_%05X" id bit + (* Translate an AIG node to an SMT bitvector term. Input bits become + size-1 variables, allocated on demand and memoized in [bvvars] + (shared with the caller for model extraction). Structural sharing + is preserved via a per-call cache keyed on the node id. *) + let bvterm_of_node (bvvars : SMT.bvterm Map.String.t ref) : + Aig.node -> SMT.bvterm = + let cache = Hashtbl.create 0 in + + let rec doit (n : Aig.node) = + let mn = + match Hashtbl.find_option cache (Int.abs n.id) with + | None -> + let mn = doit_r n.gate in + Hashtbl.add cache (Int.abs n.id) mn; + mn + | Some mn -> mn + in + if 0 < n.id then mn else SMT.bvnot mn + and doit_r (n : Aig.node_r) = + match n with + | False -> SMT.bvterm_of_int 1 0 + | Input v -> + let name = name_of_var (fst v) (snd v) in + begin + match Map.String.find_opt name !bvvars with + | None -> + bvvars := Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars; + Map.String.find name !bvvars + | Some t -> t + end + | And (n1, n2) -> SMT.bvand (doit n1) (doit n2) + in + doit + let circ_equiv ?(inps : (int * int) list option) (r1 : Aig.reg) @@ -61,36 +95,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct assert (Array.length r2 > 0); let bvvars : SMT.bvterm Map.String.t ref = ref Map.String.empty in - - let rec bvterm_of_node : Aig.node -> SMT.bvterm = - let cache = Hashtbl.create 0 in - - let rec doit (n : Aig.node) = - let mn = - match Hashtbl.find_option cache (Int.abs n.id) with - | None -> - let mn = doit_r n.gate in - Hashtbl.add cache (Int.abs n.id) mn; - mn - | Some mn -> mn - in - if 0 < n.id then mn else SMT.bvnot mn - and doit_r (n : Aig.node_r) = - match n with - | False -> SMT.bvterm_of_int 1 0 - | Input v -> - let name = name_of_var (fst v) (snd v) in - begin - match Map.String.find_opt name !bvvars with - | None -> - bvvars := Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars; - Map.String.find name !bvvars - | Some t -> t - end - | And (n1, n2) -> SMT.bvand (doit n1) (doit n2) - in - fun n -> doit n - in + let bvterm_of_node = bvterm_of_node bvvars in let bvterm_of_reg (r : Aig.reg) : _ = Array.map bvterm_of_node r @@ -171,35 +176,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct inps end; - let rec bvterm_of_node : Aig.node -> SMT.bvterm = - let cache = Hashtbl.create 0 in - - let rec doit (n : Aig.node) = - let mn = - match Hashtbl.find_option cache (Int.abs n.id) with - | None -> - let mn = doit_r n.gate in - Hashtbl.add cache (Int.abs n.id) mn; - mn - | Some mn -> mn - in - if 0 < n.id then mn else SMT.bvnot mn - and doit_r (n : Aig.node_r) = - match n with - | False -> SMT.bvterm_of_int 1 0 - | Input v -> - let name = name_of_var (fst v) (snd v) in - begin - match Map.String.find_opt name !bvvars with - | None -> - bvvars := Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars; - Map.String.find name !bvvars - | Some t -> t - end - | And (n1, n2) -> SMT.bvand (doit n1) (doit n2) - in - fun n -> doit n - in + let bvterm_of_node = bvterm_of_node bvvars in let form = bvterm_of_node n in let form = SMT.(bvterm_equal form @@ bvterm_of_int 1 1) in From 479acf1a74021e5fd5d3b6c8dc58a789980f4dcc Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 2 Jun 2026 11:47:11 +0200 Subject: [PATCH 083/145] lospecs/smt: make the node-translation cache per-instance The node memoization cache (and the bvvars input map it populates) was local to each circ_equiv/circ_sat call. AIG node ids are globally hash-consed and stable and the cached terms belong to the instance's solver, so both can be hoisted to the functor body and shared across all queries on a given SMT instance. --- libs/lospecs/smt.ml | 25 +++++++++++-------------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index cf4ddd48d5..2a6e747685 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -51,14 +51,18 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct let name_of_var (id : int) (bit : int) : string = Printf.sprintf "BV_%d_%05X" id bit - (* Translate an AIG node to an SMT bitvector term. Input bits become - size-1 variables, allocated on demand and memoized in [bvvars] - (shared with the caller for model extraction). Structural sharing - is preserved via a per-call cache keyed on the node id. *) - let bvterm_of_node (bvvars : SMT.bvterm Map.String.t ref) : - Aig.node -> SMT.bvterm = - let cache = Hashtbl.create 0 in + (* Per-instance translation state. AIG ids are globally hash-consed and + stable, and the terms below live in this instance's solver, so both + are shared across every query on this instance: + - [cache] memoizes node translation, keyed on the positive node id; + - [bvvars] holds the size-1 input variables, by name, and is read + back for model extraction. *) + let cache : (int, SMT.bvterm) Hashtbl.t = Hashtbl.create 0 + let bvvars : SMT.bvterm Map.String.t ref = ref Map.String.empty + (* Translate an AIG node to an SMT bitvector term. Input bits become + size-1 variables allocated on demand into [bvvars]. *) + let bvterm_of_node : Aig.node -> SMT.bvterm = let rec doit (n : Aig.node) = let mn = match Hashtbl.find_option cache (Int.abs n.id) with @@ -94,9 +98,6 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct assert (Array.length r1 > 0); assert (Array.length r2 > 0); - let bvvars : SMT.bvterm Map.String.t ref = ref Map.String.empty in - let bvterm_of_node = bvterm_of_node bvvars in - let bvterm_of_reg (r : Aig.reg) : _ = Array.map bvterm_of_node r |> Array.reduce (fun acc b -> SMT.bvterm_concat b acc) @@ -159,8 +160,6 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct (* TODO: better encoding of smt terms ? *) let circ_sat ?(inps : (int * int) list option) (n : Aig.node) : bool = - let bvvars : SMT.bvterm Map.String.t ref = ref Map.String.empty in - begin match inps with | None -> () @@ -176,8 +175,6 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct inps end; - let bvterm_of_node = bvterm_of_node bvvars in - let form = bvterm_of_node n in let form = SMT.(bvterm_equal form @@ bvterm_of_int 1 1) in From 6b1aa9f31784c9f04b2ba7ae3968ab17648bb7b5 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 2 Jun 2026 11:56:48 +0200 Subject: [PATCH 084/145] lospecs/smt: wrap the translation caches in an internal Cache module The node-memoization table and the input-variable map were threaded and mutated by hand at every site. Pack them into one internal Cache module with effectful operations (create / find_node / add_node / var / var_opt / var_names); the underlying Hashtbl and Map.String now live only inside it. Input variables are built through the single bvterm_of_name point in Cache.var, so callers no longer construct or look up names by hand. --- libs/lospecs/smt.ml | 118 +++++++++++++++++++++++++++----------------- 1 file changed, 74 insertions(+), 44 deletions(-) diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index 2a6e747685..5e05882b5c 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -51,24 +51,72 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct let name_of_var (id : int) (bit : int) : string = Printf.sprintf "BV_%d_%05X" id bit - (* Per-instance translation state. AIG ids are globally hash-consed and - stable, and the terms below live in this instance's solver, so both - are shared across every query on this instance: - - [cache] memoizes node translation, keyed on the positive node id; - - [bvvars] holds the size-1 input variables, by name, and is read - back for model extraction. *) - let cache : (int, SMT.bvterm) Hashtbl.t = Hashtbl.create 0 - let bvvars : SMT.bvterm Map.String.t ref = ref Map.String.empty - - (* Translate an AIG node to an SMT bitvector term. Input bits become - size-1 variables allocated on demand into [bvvars]. *) - let bvterm_of_node : Aig.node -> SMT.bvterm = + (* Per-instance translation state, shared across every query on this + instance. AIG ids are globally hash-consed and stable, and the terms + below live in this instance's solver, so both maps can persist: + - the node table memoizes node translation, keyed on the positive id; + - the variable table holds the size-1 input variables, by name, and + is read back for model extraction. + Every input variable is built through a single [bvterm_of_name 1] + point, so callers never construct names by hand. *) + module Cache : sig + type t + + val create : unit -> t + + (* Memoized node translation. *) + val find_node : t -> int -> SMT.bvterm option + val add_node : t -> int -> SMT.bvterm -> unit + + (* Size-1 input variable named [name], allocated and memoized on the + first request. *) + val var : t -> string -> SMT.bvterm + + (* Same, but a name unseen so far yields a fresh (non-memoized) + variable — used when reading back a model. *) + val var_opt : t -> string -> SMT.bvterm + + (* Names of all the variables allocated so far. *) + val var_names : t -> string list + end = struct + type t = { + nodes : (int, SMT.bvterm) Hashtbl.t; + mutable vars : SMT.bvterm Map.String.t; + } + + let create () : t = {nodes = Hashtbl.create 0; vars = Map.String.empty} + + let find_node (c : t) (id : int) : SMT.bvterm option = + Hashtbl.find_option c.nodes id + + let add_node (c : t) (id : int) (bv : SMT.bvterm) : unit = + Hashtbl.add c.nodes id bv + + let var (c : t) (name : string) : SMT.bvterm = + match Map.String.find_opt name c.vars with + | Some bv -> bv + | None -> + let bv = SMT.bvterm_of_name 1 name in + c.vars <- Map.String.add name bv c.vars; + bv + + let var_opt (c : t) (name : string) : SMT.bvterm = + match Map.String.find_opt name c.vars with + | Some bv -> bv + | None -> SMT.bvterm_of_name 1 name + + let var_names (c : t) : string list = List.of_enum (Map.String.keys c.vars) + end + + (* Translate an AIG node to an SMT bitvector term, using [cache] both to + memoize nodes and to allocate the size-1 input variables. *) + let bvterm_of_node (cache : Cache.t) : Aig.node -> SMT.bvterm = let rec doit (n : Aig.node) = let mn = - match Hashtbl.find_option cache (Int.abs n.id) with + match Cache.find_node cache (Int.abs n.id) with | None -> let mn = doit_r n.gate in - Hashtbl.add cache (Int.abs n.id) mn; + Cache.add_node cache (Int.abs n.id) mn; mn | Some mn -> mn in @@ -76,15 +124,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct and doit_r (n : Aig.node_r) = match n with | False -> SMT.bvterm_of_int 1 0 - | Input v -> - let name = name_of_var (fst v) (snd v) in - begin - match Map.String.find_opt name !bvvars with - | None -> - bvvars := Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars; - Map.String.find name !bvvars - | Some t -> t - end + | Input v -> Cache.var cache (name_of_var (fst v) (snd v)) | And (n1, n2) -> SMT.bvand (doit n1) (doit n2) in doit @@ -98,6 +138,9 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct assert (Array.length r1 > 0); assert (Array.length r2 > 0); + let cache = Cache.create () in + let bvterm_of_node = bvterm_of_node cache in + let bvterm_of_reg (r : Aig.reg) : _ = Array.map bvterm_of_node r |> Array.reduce (fun acc b -> SMT.bvterm_concat b acc) @@ -121,13 +164,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct in let inps = Option.map - (fun inps -> - List.map - (List.map (fun name -> - match Map.String.find_opt name !bvvars with - | Some bv -> bv - | None -> SMT.bvterm_of_name 1 name)) - inps) + (fun inps -> List.map (List.map (Cache.var_opt cache)) inps) inps in let bvinp = @@ -143,8 +180,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct Format.eprintf "bvout1: %a@." SMT.pp_term (SMT.get_value bvinpt1); Format.eprintf "bvout2: %a@." SMT.pp_term (SMT.get_value bvinpt2); Format.eprintf "Terms in formula: "; - List.iter (Format.eprintf "%s ") - (List.of_enum @@ Map.String.keys !bvvars); + List.iter (Format.eprintf "%s ") (Cache.var_names cache); Format.eprintf "@\n"; Option.may (fun bvinp -> @@ -160,6 +196,9 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct (* TODO: better encoding of smt terms ? *) let circ_sat ?(inps : (int * int) list option) (n : Aig.node) : bool = + let cache = Cache.create () in + let bvterm_of_node = bvterm_of_node cache in + begin match inps with | None -> () @@ -167,10 +206,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct List.iter (fun (id, sz) -> List.iter - (fun i -> - let name = name_of_var id i in - bvvars := - Map.String.add name (SMT.bvterm_of_name 1 name) !bvvars) + (fun i -> ignore (Cache.var cache (name_of_var id i))) (List.init sz identity)) inps end; @@ -192,13 +228,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct in let inps = Option.map - (fun inps -> - List.map - (List.map (fun name -> - match Map.String.find_opt name !bvvars with - | Some bv -> bv - | None -> SMT.bvterm_of_name 1 name)) - inps) + (fun inps -> List.map (List.map (Cache.var_opt cache)) inps) inps in let bvinp = @@ -211,7 +241,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct SMT.assert' @@ form; if SMT.check_sat () = true then begin Format.eprintf "Input BVVars: "; - let () = Enum.iter (Format.eprintf "%s, ") (Map.String.keys !bvvars) in + List.iter (Format.eprintf "%s, ") (Cache.var_names cache); Format.eprintf "@."; Option.may (fun bvinp -> From 221c285064a30ec19110a66794453151a85ad986 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 2 Jun 2026 11:58:57 +0200 Subject: [PATCH 085/145] lospecs/smt: back the Cache variable table with a Hashtbl The Cache module mixed a Hashtbl (nodes) with an immutable Map.String (vars) carried in a mutable field. Use a Hashtbl for both; the vars field is then mutated in place and no longer needs to be mutable. --- libs/lospecs/smt.ml | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index 5e05882b5c..0a997e6c33 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -81,10 +81,10 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct end = struct type t = { nodes : (int, SMT.bvterm) Hashtbl.t; - mutable vars : SMT.bvterm Map.String.t; + vars : (string, SMT.bvterm) Hashtbl.t; } - let create () : t = {nodes = Hashtbl.create 0; vars = Map.String.empty} + let create () : t = {nodes = Hashtbl.create 0; vars = Hashtbl.create 0} let find_node (c : t) (id : int) : SMT.bvterm option = Hashtbl.find_option c.nodes id @@ -93,19 +93,19 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct Hashtbl.add c.nodes id bv let var (c : t) (name : string) : SMT.bvterm = - match Map.String.find_opt name c.vars with + match Hashtbl.find_option c.vars name with | Some bv -> bv | None -> let bv = SMT.bvterm_of_name 1 name in - c.vars <- Map.String.add name bv c.vars; + Hashtbl.add c.vars name bv; bv let var_opt (c : t) (name : string) : SMT.bvterm = - match Map.String.find_opt name c.vars with + match Hashtbl.find_option c.vars name with | Some bv -> bv | None -> SMT.bvterm_of_name 1 name - let var_names (c : t) : string list = List.of_enum (Map.String.keys c.vars) + let var_names (c : t) : string list = List.of_enum (Hashtbl.keys c.vars) end (* Translate an AIG node to an SMT bitvector term, using [cache] both to From 333934fc9456bb9ab4419e8223ed92556289771f Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 2 Jun 2026 12:23:08 +0200 Subject: [PATCH 086/145] lospecs/smt: factor out SAT-model printing into print_model circ_equiv and circ_sat each rebuilt the per-input bitvectors and dumped the model inline, via a four-step inps -> bvinp pipeline that existed only for that diagnostic output. Replace both with a shared print_model helper that lists the allocated variables (under a caller-supplied header) and prints the solver value of each input. circ_equiv keeps its own bvout1/bvout2 lines; the two name-list footers are unified on one format. --- libs/lospecs/smt.ml | 93 +++++++++++++-------------------------------- 1 file changed, 26 insertions(+), 67 deletions(-) diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index 0a997e6c33..3eb02eded8 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -108,6 +108,30 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct let var_names (c : t) : string list = List.of_enum (Hashtbl.keys c.vars) end + (* Dump the current SMT model to stderr (diagnostic only, emitted when a + query comes back satisfiable). [names_header] labels the listing of + allocated variables; [inps] are the circuit inputs as (id, width) + pairs, each printed as the solver value of the concatenation of its + size-1 bit variables. *) + let print_model + (cache : Cache.t) + ~(names_header : string) + (inps : (int * int) list option) : unit = + Format.eprintf "%s" names_header; + List.iter (Format.eprintf "%s ") (Cache.var_names cache); + Format.eprintf "@\n"; + Option.may + (fun inps -> + List.iteri + (fun i (id, sz) -> + let bv = + List.init sz (fun b -> Cache.var_opt cache (name_of_var id b)) + |> List.reduce SMT.bvterm_concat + in + Format.eprintf "input[%d]: %a@." i SMT.pp_term (SMT.get_value bv)) + inps) + inps + (* Translate an AIG node to an SMT bitvector term, using [cache] both to memoize nodes and to allocate the size-1 input variables. *) let bvterm_of_node (cache : Cache.t) : Aig.node -> SMT.bvterm = @@ -150,28 +174,6 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct let bvinpt2 = bvterm_of_reg r2 in let formula = SMT.bvterm_equal bvinpt1 bvinpt2 in let pcond = bvterm_of_node pcond in - let inps = - Option.bind inps (fun l -> if List.is_empty l then None else Some l) - in - - let inps = - Option.map - (fun inps -> - List.map - (fun (id, sz) -> List.init sz (fun i -> name_of_var id i)) - inps) - inps - in - let inps = - Option.map - (fun inps -> List.map (List.map (Cache.var_opt cache)) inps) - inps - in - let bvinp = - Option.map - (fun inps -> List.map (fun i -> List.reduce SMT.bvterm_concat i) inps) - inps - in begin SMT.assert' @@ SMT.bvand pcond (SMT.bvnot formula); @@ -179,17 +181,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct else begin Format.eprintf "bvout1: %a@." SMT.pp_term (SMT.get_value bvinpt1); Format.eprintf "bvout2: %a@." SMT.pp_term (SMT.get_value bvinpt2); - Format.eprintf "Terms in formula: "; - List.iter (Format.eprintf "%s ") (Cache.var_names cache); - Format.eprintf "@\n"; - Option.may - (fun bvinp -> - List.iteri - (fun i bv -> - Format.eprintf "input[%d]: %a@." i SMT.pp_term - (SMT.get_value bv)) - bvinp) - bvinp; + print_model cache ~names_header:"Terms in formula: " inps; false end end @@ -214,43 +206,10 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct let form = bvterm_of_node n in let form = SMT.(bvterm_equal form @@ bvterm_of_int 1 1) in - let inps = - Option.bind inps (fun l -> if List.is_empty l then None else Some l) - in - - let inps = - Option.map - (fun inps -> - List.map - (fun (id, sz) -> List.init sz (fun i -> name_of_var id i)) - inps) - inps - in - let inps = - Option.map - (fun inps -> List.map (List.map (Cache.var_opt cache)) inps) - inps - in - let bvinp = - Option.map - (fun inps -> List.map (fun i -> List.reduce SMT.bvterm_concat i) inps) - inps - in - begin SMT.assert' @@ form; if SMT.check_sat () = true then begin - Format.eprintf "Input BVVars: "; - List.iter (Format.eprintf "%s, ") (Cache.var_names cache); - Format.eprintf "@."; - Option.may - (fun bvinp -> - List.iteri - (fun i bv -> - Format.eprintf "input[%d]: %a@." i SMT.pp_term - (SMT.get_value bv)) - bvinp) - bvinp; + print_model cache ~names_header:"Input BVVars: " inps; true end else false From f9ae3974c730724b7f6dcdb801f2c197391cff4a Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 2 Jun 2026 12:26:39 +0200 Subject: [PATCH 087/145] lospecs/smt: drop print_model's header parameter, use one label Both call sites now want the same listing header, so inline "Input bvvars: " in print_model and remove the ~names_header argument. --- libs/lospecs/smt.ml | 20 ++++++++------------ 1 file changed, 8 insertions(+), 12 deletions(-) diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index 3eb02eded8..8cf606b3cf 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -109,15 +109,11 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct end (* Dump the current SMT model to stderr (diagnostic only, emitted when a - query comes back satisfiable). [names_header] labels the listing of - allocated variables; [inps] are the circuit inputs as (id, width) - pairs, each printed as the solver value of the concatenation of its - size-1 bit variables. *) - let print_model - (cache : Cache.t) - ~(names_header : string) - (inps : (int * int) list option) : unit = - Format.eprintf "%s" names_header; + query comes back satisfiable): the allocated input variables, then + the solver value of each input in [inps] (a circuit input as an + (id, width) pair) as the concatenation of its size-1 bit variables. *) + let print_model (cache : Cache.t) (inps : (int * int) list option) : unit = + Format.eprintf "Input bvvars: "; List.iter (Format.eprintf "%s ") (Cache.var_names cache); Format.eprintf "@\n"; Option.may @@ -151,7 +147,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct | Input v -> Cache.var cache (name_of_var (fst v) (snd v)) | And (n1, n2) -> SMT.bvand (doit n1) (doit n2) in - doit + fun (n : Aig.node) -> doit n let circ_equiv ?(inps : (int * int) list option) @@ -181,7 +177,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct else begin Format.eprintf "bvout1: %a@." SMT.pp_term (SMT.get_value bvinpt1); Format.eprintf "bvout2: %a@." SMT.pp_term (SMT.get_value bvinpt2); - print_model cache ~names_header:"Terms in formula: " inps; + print_model cache inps; false end end @@ -209,7 +205,7 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct begin SMT.assert' @@ form; if SMT.check_sat () = true then begin - print_model cache ~names_header:"Input BVVars: " inps; + print_model cache inps; true end else false From 449ad581abae44c66e6df0375c53bdf8aed20395 Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Tue, 2 Jun 2026 12:17:09 +0100 Subject: [PATCH 088/145] First FIXME/TODO cleanup pass --- examples/bindings.ec | 19 -------------- libs/lospecs/aig.ml | 3 --- libs/lospecs/circuit.ml | 6 ----- libs/lospecs/circuit_spec.ml | 1 - libs/lospecs/deps.ml | 3 +-- libs/lospecs/ptree.ml | 1 - libs/lospecs/smt.ml | 2 -- libs/lospecs/typing.ml | 2 -- src/ecCircuits.ml | 17 ++---------- src/ecCoreFol.ml | 2 -- src/ecCoreFol.mli | 3 --- src/ecEnv.ml | 3 +-- src/ecLowCircuits.ml | 50 +++++++++--------------------------- src/ecScope.ml | 2 +- src/phl/ecPhlBDep.ml | 14 ++-------- src/phl/ecPhlCodeTx.ml | 2 +- src/phl/ecPhlRwPrgm.ml | 2 +- tests/circuit_test.ec | 5 ++-- tests/conseq_metavars.ec | 44 +++++++++++++++++++++++++++++++ 19 files changed, 67 insertions(+), 114 deletions(-) create mode 100644 tests/conseq_metavars.ec diff --git a/examples/bindings.ec b/examples/bindings.ec index 1dc74cb333..130995b25f 100644 --- a/examples/bindings.ec +++ b/examples/bindings.ec @@ -53,9 +53,6 @@ realize bvorP by admit. bind op bool [!] "not". realize bvnotP by admit. -(* TODO: Add shifts once we have truncate/extend *) - - (* ----------- BEGIN W8 BINDINGS ---------- *) bind bitstring W8.w2bits W8.bits2w W8.to_uint W8.to_sint W8.of_int W8.t 8. realize size_tolist by auto. @@ -196,9 +193,6 @@ lemma shl_shift w sa : bind op W16.t shl16 "shl". realize bvshlP by admit. -(* TODO: Add shifts once we have truncate/extend *) - - (* ----------- BEGIN W32 BINDINGS ---------- *) bind bitstring W32.w2bits W32.bits2w W32.to_uint W32.to_sint W32.of_int W32.t 32. realize size_tolist by auto. @@ -241,9 +235,6 @@ realize bvnotP by admit. bind op [W32.t & bool] W32."_.[_]" "get". realize bvgetP by admit. -(* TODO: Add shifts once we have truncate/extend *) - - (* ----------- BEGIN W64 BINDINGS ---------- *) bind bitstring W64.w2bits W64.bits2w W64.to_uint W64.to_sint W64.of_int W64.t 64. @@ -284,9 +275,6 @@ realize bvxorP by admit. bind op W64.t W64.invw "not". realize bvnotP by admit. -(* TODO: Add shifts once we have truncate/extend *) - - (* ----------- BEGIN W128 BINDINGS ---------- *) bind bitstring W128.w2bits W128.bits2w W128.to_uint W128.to_sint W128.of_int W128.t 128. @@ -327,8 +315,6 @@ realize bvxorP by admit. bind op W128.t W128.invw "not". realize bvnotP by admit. -(* TODO: Add shifts once we have truncate/extend *) - (* ----------- BEGIN W256 BINDINGS ---------- *) bind bitstring W256.w2bits W256.bits2w W256.to_uint W256.to_sint W256.of_int W256.t 256. @@ -369,8 +355,6 @@ realize bvxorP by admit. bind op W256.t W256.invw "not". realize bvnotP by admit. -(* TODO: Add shifts once we have truncate/extend *) - (* ----------- BEGIN SPEC FILE BINDINDS ---------- *) @@ -392,11 +376,8 @@ bind circuit VPACKUS_16u16 "VPACKUS_16u16". bind circuit VPMADDUBSW_256 "VPMADDUBSW_256". bind circuit VPERMD "VPERMD". - -(* FIXME: Check new types *) bind circuit VPSRA_16u16 "VPSRA_16u16_new". - bind op [bool & W16.t] W16.init "init". realize bvinitP by admit. diff --git a/libs/lospecs/aig.ml b/libs/lospecs/aig.ml index 8968f52c88..0fbda8203c 100644 --- a/libs/lospecs/aig.ml +++ b/libs/lospecs/aig.ml @@ -409,9 +409,6 @@ let aiger_serialize_int (id: int) : string = let pp_aiger_int fmt (id: int) : unit = Format.fprintf fmt "%s" (aiger_serialize_int id) -(* FIXME PR: Look at correction of this and after making sure it is correct *) -(* we can remove or do something else with the asserts *) -(* but they should not be triggered on a normal execution *) let pp_aiger_and fmt ((gid, id1, id2): int * int * int) : unit = if not (gid > id1 && id1 > id2) then Format.eprintf "gid : %d | id1: %d | id2: %d@." gid id1 id2; assert (gid > id1 && id1 > id2); diff --git a/libs/lospecs/circuit.ml b/libs/lospecs/circuit.ml index 7b468a3f5f..4f30e17b9a 100644 --- a/libs/lospecs/circuit.ml +++ b/libs/lospecs/circuit.ml @@ -58,7 +58,6 @@ let ubigint_of_bools (bs: bool array) : Z.t = bs Z.zero -(* FIXME: Check this *) let sbigint_of_bools (bs: bool array) : Z.t = let bs = Array.rev bs in let msb = bs.(0) in @@ -148,14 +147,12 @@ let of_bigint ~(size : int) (v : Z.t) : reg = assert (Z.numbits v <= size); Array.init size (fun i -> constant (Z.testbit v i)) -(* FIXME: Check *) let of_bigint_all ~(size : int) (v : Z.t) : reg = let mod_ = Z.(lsl) Z.one (size) in let v = Z.rem v mod_ in let v = if Z.sign v < 0 then Z.add mod_ v else v in of_bigint ~size v -(* FIXME: Check *) let of_bigint_repr_size (v : Z.t) : reg = let size = Z.numbits v + (if Z.sign v <= 0 then 1 else 0) in of_bigint_all ~size v @@ -311,8 +308,6 @@ let c_rshift ~(lg2o : int) ~(sign : node) (c : node) (r : reg) = in Array.map2 (fun r1 s1 -> mux2 r1 s1 c) r s -(* TODO: change array appends into inits *) - (* -------------------------------------------------------------------- *) let arshift ~(offset : int) (r : reg) = let sign = if Array.length r = 0 then false_ else r.(Array.length r - 1) in @@ -766,7 +761,6 @@ let popcount ~(size : int) (r : reg) : reg = (* -------------------------------------------------------------------- *) (* Assumes input is array of 16 bit words *) -(* FIXME: Maybe do something a bit more principled here? *) let compute ?(input_block_size = 16) ?(output_block_size = 16) (r: reg) (inp: int array) : int array = assert (input_block_size <= 32); let m = (1 lsl input_block_size) - 1 in diff --git a/libs/lospecs/circuit_spec.ml b/libs/lospecs/circuit_spec.ml index abc3677be0..c18a008f2d 100644 --- a/libs/lospecs/circuit_spec.ml +++ b/libs/lospecs/circuit_spec.ml @@ -8,7 +8,6 @@ let load_from_file ~(filename : string) = let specs = Typing.tt_program Typing.Env.empty specs in specs -(* FIXME: Duplicated from circuit.ml *) let split_at_arr (type t) (n: int) (r: t array) : t array * t array = Array.sub r 0 n, Array.right r (Array.length r - n) diff --git a/libs/lospecs/deps.ml b/libs/lospecs/deps.ml index 89f478d7e2..f05fabddf0 100644 --- a/libs/lospecs/deps.ml +++ b/libs/lospecs/deps.ml @@ -3,7 +3,6 @@ open Aig module Hashtbl = Batteries.Hashtbl (* ------------------------------------------------------------------------------- *) -(* FIXME: CHECK THIS *) let rec inputs_of_node : _ -> Aig.var Set.t = let cache : (int, Aig.var Set.t) Hashtbl.t = Hashtbl.create 0 in @@ -156,7 +155,7 @@ let collapse_blocks (d: tdblock list) : tdblock option = (* -------------------------------------------------------------------- *) (* Uses dependency analysis to realign inputs to start at 0 *) (* Corresponds to taking the relevant subcircuit to this output *) -(* Assumes that inputs are contiguous FIXME *) +(* Assumes that inputs are contiguous *) let realign_inputs ?(renamings: (int -> int option) option) (n: node) : node * (int, int * int) Map.t = let d = dep n in let shifts = Map.map (fun s -> diff --git a/libs/lospecs/ptree.ml b/libs/lospecs/ptree.ml index 8131fb3155..feb065bb2b 100644 --- a/libs/lospecs/ptree.ml +++ b/libs/lospecs/ptree.ml @@ -31,7 +31,6 @@ module Lc = struct rg_begin = min p1.rg_begin p2.rg_begin; rg_end = max p1.rg_end p2.rg_end; } - (* Dead code? FIXME PR *) let mergeall (p : range list) = match p with | [] -> assert false diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index d94eaae6fc..794c01d7df 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -44,7 +44,6 @@ module type SMTInterface = sig val circ_taut : ?inps:(int * int) list -> node -> bool end -(* TODO Add model printing for circ_sat and circ_taut *) (* Assumes circuit inputs have already been appropriately renamed *) module MakeSMTInterface(SMT: SMTInstance) : SMTInterface = struct let circ_equiv ?(inps: (int * int) list option) (r1 : Aig.reg) (r2 : Aig.reg) (pcond : Aig.node) : bool = @@ -128,7 +127,6 @@ module MakeSMTInterface(SMT: SMTInstance) : SMTInterface = struct end - (* TODO: better encoding of smt terms ? *) let circ_sat ?(inps: (int * int) list option) (n : Aig.node) : bool = let bvvars : SMT.bvterm Map.String.t ref = ref Map.String.empty in diff --git a/libs/lospecs/typing.ml b/libs/lospecs/typing.ml index fa2308fd82..fb7d93eadf 100644 --- a/libs/lospecs/typing.ml +++ b/libs/lospecs/typing.ml @@ -12,8 +12,6 @@ let as_seq1 (type t) (xs : t list) : t = let as_seq2 (type t) (xs : t list) : t * t = match xs with [ x; y ] -> (x, y) | _ -> raise (DestrError "as_seq2") -(* FIXME: check where used and catch error if needed *) - (* -------------------------------------------------------------------- *) module Env : sig type env diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 659fc60563..f06b6c1966 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -107,7 +107,6 @@ let rec pp_circ_error ppe fmt (err : circuit_error) = Format.fprintf fmt "Missing op spec binding for operator at path %a" pp_path pth | IntConversionFailure -> - (* FIXME: check that this actually prints the form, otherwise add it *) Format.fprintf fmt "Failed to convert form to concrete integer" | MissingOpBody pth -> Format.fprintf fmt "No body for operator at path %a" pp_path pth @@ -512,7 +511,6 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = | Fapp (f, fs) -> circuit_of_app st f_ f fs | Fquant (qnt, binds, f) -> - (* FIXME Does this type conversion make sense? *) let binds = List.map (fun (idn, t) -> idn, gty_as_ty t |> ctype_of_ty env) binds in @@ -520,7 +518,6 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = match qnt with | Lforall | Llambda -> circ_lambda_oneshot st binds (fun st -> circuit_of_node st f) - (* FIXME: look at this interaction *) | Lexists -> circ_error (CantConvertToCirc (`Quantif qnt)) end @@ -556,7 +553,6 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = let v = match pv with | PVloc v -> v - (* FIXME: Should globals be supported? *) | _ -> circ_error (CantConvertToCirc `Glob) in let v = @@ -701,7 +697,6 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = and trans_iter (st : state) (hyps : hyps) (f : form) (fs : form list) : circuit = try - (* FIXME: move auxiliary function out of the definitions *) let redmode = circ_red hyps in let fapply_safe f fs = let res = EcTypesafeFol.fapply_safe ~redmode hyps f fs in @@ -783,8 +778,6 @@ let circuit_simplify_equality let posts = circuits_of_equality ~st ~hyps f1 f2 in circuit_check_posts ~env:(toenv hyps) ~pres posts -(* FIXME: add support for spec bindings for abstract/opaque operators - = convert from Fop rather than from op body *) let process_instr (hyps : hyps) (mem : memory) ~(st : state) (inst : instr) : state = EcEnv.notify (toenv hyps) `Debug "[W] Processing : %a@." @@ -833,7 +826,6 @@ let process_instr (hyps : hyps) (mem : memory) ~(st : state) (inst : instr) : | _ -> circ_error (CantConvertToCirc `Instr) with CircError e -> propagate_circ_error (`Instr inst) e -(* FIXME: check if memory is the right one in calls to state *) let instrs_equiv (hyps : hyps) ((mem, _mt) : memenv) @@ -869,7 +861,6 @@ let instrs_equiv let st1 = close_circ_lambda st1 in let st2 = close_circ_lambda st2 in - (* FIXME: what was the intended behaviour for keep? *) match keep with | Some pv -> let vs = EcPV.PV.elements pv |> fst in @@ -898,7 +889,6 @@ let instrs_equiv let circ2 = state_get_pv st2 mem var in circ_equiv circ1 circ2) -(* FIXME: change memory -> memenv Why? *) let state_of_prog ?(close = false) (hyps : hyps) @@ -961,8 +951,8 @@ let circuit_state_of_hyps (* If there is a memory, add all the variables from that memory into the translation state *) | EcBaseLogic.LD_mem mt -> circuit_state_of_memenv ~st env (id, mt) (* Initialized variable. - Check if body is convertible to circuit, if not just process it as uninitialized. - TODO: Maybe do a first pass on this, check convertibility and remove duplicates? *) + Check if body is convertible to circuit, if not just process it as uninitialized. + *) | EcBaseLogic.LD_var (t, Some f) -> EcEnv.notify env `Debug "Assigning %a to %a@." EcPrinting.(pp_form ppe) @@ -970,7 +960,6 @@ let circuit_state_of_hyps begin try update_state st id (circuit_of_form st hyps f) - (* FIXME PR: Should only catch circuit translation errors, hack *) with CircError e -> ( EcEnv.notify env `Debug "Failed to translate hypothesis for var %s with error %a, \ @@ -978,7 +967,6 @@ let circuit_state_of_hyps (tostring_internal id) (pp_circ_error ppe) e; try open_circ_lambda st [id, ctype_of_ty env t] - (* FIXME PR: Should only catch circuit translation errors, hack *) with | ( CircError (AbstractTyBinding _) | CircError (MissingTyBinding _) ) as e @@ -1013,7 +1001,6 @@ let circuit_state_of_hyps when EcFol.op_kind p = Some `Eq -> begin try update_state_pv st m pv (circuit_of_form st hyps fv) - (* FIXME PR: Should only catch circuit translation errors, hack *) with CircError e -> EcEnv.notify env `Debug "Failed to translate hypothesis %s => %a@\n\ diff --git a/src/ecCoreFol.ml b/src/ecCoreFol.ml index 6bdd4d485a..c11b189430 100644 --- a/src/ecCoreFol.ml +++ b/src/ecCoreFol.ml @@ -183,8 +183,6 @@ let f_false = f_op EcCoreLib.CI_Bool.p_false [] tbool let f_bool = fun b -> if b then f_true else f_false (* -------------------------------------------------------------------- *) -(* TODO: check types here *) -(* FIXME CIRCUIT PR: do we want to keep this? *) let ty_ftlist1 ty = toarrow (List.make 1 ty) (tlist ty) let ty_ftlist2 ty = toarrow ([ty; (tlist ty)]) (tlist ty) let ty_flist1 ty = toarrow (List.make 1 (tlist ty)) (tlist ty) diff --git a/src/ecCoreFol.mli b/src/ecCoreFol.mli index fa5d492243..ed852a845f 100644 --- a/src/ecCoreFol.mli +++ b/src/ecCoreFol.mli @@ -147,8 +147,6 @@ val f_eagerF : ts_inv -> stmt -> xpath -> xpath -> stmt -> ts_inv -> form val f_pr_r : pr -> form val f_pr : memory -> xpath -> form -> ss_inv -> form -(* FIXME: Check this V *) -(* FIXME CIRCUIT PR: do we want to keep this? *) val ty_ftlist1 : ty -> ty val ty_ftlist2 : ty -> ty val ty_flist1 : ty -> ty @@ -157,7 +155,6 @@ val ty_lmap : ty -> ty -> ty val ty_chunk : ty -> ty val ty_all : ty -> ty -(* FIXME CIRCUIT PR: if keeping, maybe change names *) val fop_empty : ty -> form val fop_cons : ty -> form val fop_append : ty -> form diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 7fd0354814..8430b543a7 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -177,7 +177,6 @@ type crb_tyrev_binding = [ | `Array of crb_array ] -(* FIXME: rename `To ? *) type crb_bitstring_operator = crb_bitstring * [`From | `To | `OfInt | `ToUInt | `ToSInt ] type crb_array_operator = crb_array * [`Get | `Set | `ToList | `OfList] @@ -2976,7 +2975,7 @@ module LDecl = struct | LD_hyp f -> LD_hyp (Fsubst.f_subst s f) - | LD_abs_st _ -> (* FIXME *) + | LD_abs_st _ -> assert false (* ------------------------------------------------------------------ *) diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index 404507bc16..d4406f4f1a 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -42,8 +42,8 @@ module type CBackend = sig val pp_node : Format.formatter -> node -> unit - exception NonConstantCircuit (* FIXME: Rename later *) - exception GetOutOfRange (* FIXME: Do we even need this? *) + exception NonConstantCircuit + exception GetOutOfRange exception BadSlice of [`Get | `Set] val true_ : node @@ -100,15 +100,13 @@ module type CBackend = sig val bnor : node -> node -> node (* SMTLib Base Operations *) - (* FIXME: decide if boolean ops are going to be defined - on registers or on nodes *) val add : reg -> reg -> reg val sub : reg -> reg -> reg val opp : reg -> reg val mul : reg -> reg -> reg val udiv : reg -> reg -> reg val sdiv : reg -> reg -> reg - val umod : reg -> reg -> reg (* FIXME: mod or rem here? *) + val umod : reg -> reg -> reg val smod : reg -> reg -> reg val lshl : reg -> reg -> reg val lshr : reg -> reg -> reg @@ -160,7 +158,6 @@ module type CBackend = sig val forall_inputs : (int -> int -> bool) -> reg -> bool val rename_inputs : ((int * int) -> (int * int) option) -> reg -> reg - (* TODO: Rename *) val excise_bit : ?renamings:(int -> int option) -> node -> node * (int, int * int) Map.t end end @@ -176,8 +173,8 @@ module LospecsBack : CBackend = struct let pp_node (fmt : Format.formatter) (n: node) = Format.fprintf fmt "%a" (fun fmt -> Lospecs.Aig.pp_node fmt) n - exception NonConstantCircuit (* FIXME: Rename later *) - exception GetOutOfRange (* FIXME: Do we even need this? *) + exception NonConstantCircuit + exception GetOutOfRange exception BadSlice of [`Get | `Set] let true_ = C.true_ @@ -324,7 +321,6 @@ module LospecsBack : CBackend = struct let mul (r1: reg) (r2: reg) : reg = C.umull r1 r2 let udiv (r1: reg) (r2: reg) : reg = C.udiv r1 r2 let sdiv (r1: reg) (r2: reg) : reg = C.sdiv r1 r2 - (* FIXME: mod or rem here? *) let umod (r1: reg) (r2: reg) : reg = C.umod r1 r2 let smod (r1: reg) (r2: reg) : reg = C.smod r1 r2 let lshl (r1: reg) (r2: reg) : reg = C.shift ~side:`L ~sign:`L r1 r2 @@ -394,8 +390,6 @@ module LospecsBack : CBackend = struct idx + w ) 0 bd - (* FIXME: Some of these are unused as of now, but they seem useful - as part of the library, do we keep them? *) let dep_var_count (d: deps) : int = Set.cardinal (Array.fold_left (Set.union) Set.empty @@ -655,7 +649,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = | CircInputUnificationFailure of (cinp * cinp) | CircTyConversionFailure | CircConstructorInvalidArguments of circconstructor - | CircComposeInvalidArguments (* FIXME: what is a useful error to print here ? *) + | CircComposeInvalidArguments | CircComposeBadNumberOfArguments of { expected: int; received: int} | CircEquivNonBoolPCond | CircSmtNonBoolCirc @@ -824,7 +818,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = { st with pv_ids = Map.add (m, s) id st.pv_ids}, (id, t)) st bnds in open_circ_lambda st bnds - (* FIXME: should we remove id from the mapping? *) let close_circ_lambda (st: state) : state = match st.lambdas with | [] -> lowcircerror (CloseWithoutLambda) @@ -845,7 +838,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = end (* Inputs helper functions *) - (* FIXME: maybe do something a bit more principled here ? After merge *) let merge_inputs (cs: cinp list) (ds: cinp list) : cinp list = (* if List.for_all2 (fun {id=id1; type_=ct1} {id=id2; type_=ct2} -> id1 = id2 && ct1 = ct2) cs ds then cs *) if cs = ds then cs @@ -969,7 +961,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let circuit_is_free (f: circuit) : bool = List.is_empty @@ snd f let circuit_ite ~(c: circuit) ~(t: circuit) ~(f: circuit) : circuit = - let strict = true in (* FIXME: Decide which behaviour we want, post PR *) + let strict = true in let inps = match c, t, f with | (_, []), (_, []), (_, []) when strict -> [] | (_, cinps), (_, tinps), (_, finps) when (not strict) && cinps = tinps && cinps = finps -> cinps @@ -987,7 +979,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = | CBool, CBool -> {reg = res_r; type_ = (fst t).type_}, inps | _ -> lowcircerror @@ CircConstructorInvalidArguments Ite - (* TODO: type check? *) let circuit_eq (c: circuit) (d: circuit) : circuit = match (fst c).type_, (fst d).type_ with | (CArray _), (CArray _) @@ -1135,8 +1126,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = to equivalence between the subcircuits Implicitly flattens everything to bitstrings - - TODO: add functionality for user specified lane size *) let fillet_circuit ((c, inps) : circuit) : circuit list = let r = c.reg |> Backend.node_list_of_reg in @@ -1188,14 +1177,13 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let checks = List.stable_sort (fun (_, d1) (_, d2) -> let m1 = (Map.keys d1 |> Set.of_enum |> Set.min_elt_opt) in let m2 = (Map.keys d2 |> Set.of_enum |> Set.min_elt_opt) in - (* FIXME: Check this *) match m1, m2 with | None, None -> 0 | None, Some _ -> -1 | Some _, None -> 1 | Some m1, Some m2 -> let c1 = Int.compare m1 m2 in - if c1 = 0 then (* FIXME: check default value V V *) + if c1 = 0 then Int.compare (Map.find m1 d1 |> Set.min_elt_opt |> Option.default (-1)) (Map.find m1 d2 |> Set.min_elt_opt |> Option.default (-1)) else c1 @@ -1210,8 +1198,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = match cs with | [] -> (cur::acc) | (c, d')::cs -> -(* - FIXME: do we keep this? also add log levels *) Option.may (fun f -> f @@ Format.asprintf "Comparing deps:@.%a@.To deps:@.%a@." Backend.Deps.pp_dep d @@ -1261,7 +1247,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = { reg = c; type_ = CBool}, inps - (* FIXME: Review later? *) let collapse_lanes ?(logger : (string -> unit) option) (lanes: circuit list) = (* Circuit structural equality after renaming *) let (===) (c1: circ) (c2: circ) : bool = @@ -1278,7 +1263,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = else collapse (cur::acc) c cs in - (* FIXME: optimize later *) let rec doit (cs: circuit list) : circuit list = match cs with | [] -> [] @@ -1308,7 +1292,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = - SMT check for any remainings ones *) let fillet_tauts ?(logger: (string -> unit) option) (pres: circuit list) (posts: circuit list) : bool = - (* Assumes everything is single bit outputs. FIXME: does it? *) + (* Assumes everything is single bit outputs. *) let posts = List.filter_map (fun ((postc, _) as post) -> if Backend.nodes_eq (Backend.node_of_reg postc.reg) Backend.true_ then None else Some post @@ -1341,7 +1325,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let compute ~(sign: bool) ((r, inps) as c: circuit) (args: arg list) : zint option = begin match r.type_ with | CBitstring _ -> () - | _ -> assert false (* TODO: FIXME Add functionality for other or add exception *) + | _ -> assert false end; if List.compare_lengths args inps <> 0 @@ -1403,10 +1387,9 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let inp, renamer = input_aggregate_renamer inps in {c with reg = Backend.applys renamer c.reg}, [inp] - (* FIXME: do implicit conversion to this type before writing or enforce explicit conversion ? *) let circuit_to_file ~(name: string) ((c, inps): circuit) : symbol = match c, inps with - | {reg = r; type_ = CBitstring _}, {type_ = CBitstring w; id}::[] -> (* TODO: rename inputs? *) + | {reg = r; type_ = CBitstring _}, {type_ = CBitstring w; id}::[] -> Backend.reg_to_file ~input_count:w ~name (Backend.applys (fun (id_, i) -> if id_ = id then Some (Backend.input_node ~id:0 (i+1)) else None) r) | _ -> lowcircerror @@ UnsupportedTypeForFileOutput @@ -1424,7 +1407,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (Backend.input_of_size ~id size, { type_ = ty; id = id; } ) ) arg_tys |> List.split in let c = c cinps in - { reg = c; type_ = ret_ty}, inps (* TODO: type checking ? *) + { reg = c; type_ = ret_ty}, inps (* { reg = c; CBitstring c, inps) |> convert_type ret_ty *) (* -------------------------------------------------------------------- *) @@ -1471,7 +1454,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = | _ -> assert false (* Should be caught by EC typechecking + binding correctness *) end - (* FIXME: what do we want for out of bounds extract? Decide later *) | { kind = `Extract ((_, Some _), (_, Some w_out), aligned) } -> begin match args with | [ `Circuit (({type_ = CBitstring _}, _ ) as c) ; `Constant i ] -> @@ -1497,8 +1479,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = in (* Inputs of all components should match after map *) if not (List.for_all ((=) (List.hd inps)) inps) then - (* FIXME: Careful with input modelling, if abstraction breaks this breaks - post PR work *) assert false; (* Should be caught by EC typechecking + binding correctness *) let inps = List.hd inps in let circ = { reg = (Backend.flatten circs); type_ = CArray {width=w_o; count=n}} in @@ -1522,8 +1502,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = circs in (* Inputs should be uniform across components after mapping *) if not (List.for_all ((=) (List.hd cinps)) cinps) then - (* FIXME: Careful with input modelling, if abstraction breaks this breaks - post PR work *) assert false; (* Should be caught by EC typechecking + binding correctness *) let cinps = List.hd cinps in {type_ = CArray {width=w_o; count=n} ; reg = Backend.flatten circs}, cinps @@ -1535,7 +1513,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let circs, cinps = List.split @@ List.init w init_f in let circs = List.map (function - (* FIXME: bad abstraction, fix after PR *) | {type_ = CBitstring 1; reg = b} | {type_ = CBool; reg = b} -> Backend.node_of_reg b (* Return type should be bool (= bit) for components *) @@ -1543,8 +1520,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = circs in if not (List.for_all ((=) (List.hd cinps)) cinps) then - (* FIXME: Careful with input modelling, if abstraction breaks this breaks - post PR work *) assert false; (* Should be caught by EC typechecking + binding correctness *) let cinps = List.hd cinps in {type_ = CBitstring w; reg = (Backend.reg_of_node_list circs)}, cinps @@ -1589,7 +1564,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in let {reg = c2;_}, inp2 = new_input_circuit (CBitstring size) in {type_ = CBitstring size; reg = (Backend.smod c1 c2)}, [inp1; inp2] - (* Should this be mod or rem? TODO FIXME*) | { kind = `Shl (_, Some size) } -> let {reg = c1;_}, inp1 = new_input_circuit (CBitstring size) in diff --git a/src/ecScope.ml b/src/ecScope.ml index d591a6d2aa..7021a941e5 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -577,7 +577,7 @@ let for_loading (scope : scope) = sc_options = GenOptions.for_loading scope.sc_options; sc_globdoc = []; sc_locdoc = DocState.empty; - sc_specs = scope.sc_specs; } (* FIXME: is this correct? *) + sc_specs = scope.sc_specs; } (* -------------------------------------------------------------------- *) let subscope (scope : scope) (mode : EcTheory.thmode) (name : symbol) lc = diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index 0f5703d013..7f8afbf8a6 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -38,7 +38,6 @@ let rec form_list_of_form (f: form) : form list = pc = EcCoreLib.CI_List.p_cons -> h::(form_list_of_form t) | _ -> - (* FIXME: Bad error? *) raise (DestrError "list") (* FIXME: move? A *) @@ -86,13 +85,7 @@ let process_pre ?(st : state option) (tc: tcenv1) (f: form) : state * circuit li (* If f is of the form (a_ = a) (aka prog_var = log_var) then add it to the state, otherwise do nothing *) - (* FIXME: are all the simplifications necessary ? *) (* Processes explicit equations *) - (* FIXME PR: Make sure this works with things of the form - a{hr} = b{hr} /\ b{hr} = a{hr} - or even - a{hr} = b{hr} /\ b{hr} = c{hr} /\ c{hr} = a{hr} - *) let process_equality (s: state) (f: form) : state = let f = (EcCallbyValue.norm_cbv (circ_red hyps) hyps f) in match f.f_node with @@ -158,7 +151,6 @@ let solve_post ~(st: state) ~(pres: circuit list) (hyps: hyps) (post: form) : bo | _ -> Seq.return (circuit_of_form st hyps post |> state_close_circuit st) ) |> List.of_seq |> circuit_check_posts ~env ~pres -(* TODO: Figure out how to not repeat computations here? *) let t_bdep_solve (tc : tcenv1) = let hyps = (FApi.tc1_hyps tc) in @@ -222,8 +214,6 @@ let t_bdep_solve assert (ctxt.h_tvar = []); let st = circuit_state_of_hyps hyps in let cgoal = (circuit_of_form st hyps goal |> state_close_circuit st) in - (* FIXME: make this lazy *) -(* EcEnv.notify env `Debug "goal: %a@." pp_flatcirc (fst cgoal).reg; *) if circ_taut cgoal then FApi.close (!@ tc) VBdep else @@ -268,7 +258,7 @@ let t_bdep_simplify (tc: tcenv1) = with CircError err -> tc_error (FApi.tc1_penv tc) "Circuit simplify failed with error: %a" (pp_circ_error EcPrinting.PPEnv.(ofenv env)) err end - | _ -> assert false (* FIXME : Do we want to handle other cases before merge? *) + | _ -> assert false (* ================ EXTENS TACTIC ==================== *) (* FIXME: Maybe move later? *) @@ -319,7 +309,7 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = raise CannotTranslate in EcCoreModules.i_asgn (lv, e) - | _ -> raise (CannotTranslate) (* FIXME: Errors *) + | _ -> raise (CannotTranslate) ) s.s_node) in diff --git a/src/phl/ecPhlCodeTx.ml b/src/phl/ecPhlCodeTx.ml index 3bb8a6cd50..03b4579b52 100644 --- a/src/phl/ecPhlCodeTx.ml +++ b/src/phl/ecPhlCodeTx.ml @@ -527,7 +527,7 @@ let process_case ((side, pos) : side option * pcodepos) (tc : tcenv1) = let lv, e = destr_asgn i in - let pvl = (* FIXME: do we want to do this TCB-wise? *) + let pvl = match lv with | LvVar _ -> PV.empty | LvTuple lvs -> diff --git a/src/phl/ecPhlRwPrgm.ml b/src/phl/ecPhlRwPrgm.ml index c1a88eebbf..2e590ff55f 100644 --- a/src/phl/ecPhlRwPrgm.ml +++ b/src/phl/ecPhlRwPrgm.ml @@ -34,7 +34,7 @@ let process_change ((cpos, bindings, i, s) : change_t) (tc : tcenv1) = let x = Option.map EcLocation.unloc (EcLocation.unloc x) in let vr = EcAst.{ ov_name = x; ov_type = ty; } in let (mem, _) = EcMemory.bind_fresh vr mem in - (mem, (EcTypes.pv_loc (oget x), ty)) (* FIXME *) + (mem, (EcTypes.pv_loc (oget x), ty)) (* FIXME: oget? *) ) hs.hs_m bindings in let env = EcEnv.Memory.push_active_ss mem env in diff --git a/tests/circuit_test.ec b/tests/circuit_test.ec index 0ce429f464..2512b9e8f0 100644 --- a/tests/circuit_test.ec +++ b/tests/circuit_test.ec @@ -87,9 +87,8 @@ qed. lemma W8_xor_ext (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. proof. proc. -(* extens [a] : (wp; skip; smt()). *) -(* FIXME : while debugging fhash *) -admit. (* *) +extens [a] : (wp; skip; smt()). +admit. qed. lemma W8_xor_circuit (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. diff --git a/tests/conseq_metavars.ec b/tests/conseq_metavars.ec new file mode 100644 index 0000000000..aecabb4ec8 --- /dev/null +++ b/tests/conseq_metavars.ec @@ -0,0 +1,44 @@ +require import AllCore Int Real. + +theory ConseqPrePostHoare. +module M = { + proc f(x: int) = { + var y : int; + + y <- x; + x <- y + x; + return x; + } +}. + +lemma bar (x: int) (y: int): true. proof. by done. qed. + +lemma foo : hoare[M.f : 2 < arg /\ arg < 5 ==> res = 4]. +proof. +conseq (_: #pre ==> #post). +proc. +conseq (_: #pre ==> #post). +abort. +end ConseqPrePostHoare. + + +theory ConseqPrePostEquiv. +module M = { + proc f(x: int) = { + var y : int; + + y <- x; + x <- y + x; + return x; + } +}. + + +lemma foobar : equiv[M.f ~ M.f : ={arg} /\ arg{1} = 2 ==> ={res} /\ res{1} = 3]. +proof. +conseq (_: #pre /\ arg{2} = 2 ==> #post /\ res{2} = 3); auto. +proc. +conseq (_: #{/x{1}}pre ==> #{/x{1}}post). auto. +move=> ? ? ? ? ? <*>> //. +abort. +end ConseqPrePostEquiv. From b2472038926f089b6a7e0d3704d13785ef109aac Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 2 Jun 2026 14:21:05 +0200 Subject: [PATCH 089/145] circuit: return a lazy SMT counter-model; add Circuit:debug_smt flag The SMT queries used to print the model to stderr unconditionally on SAT, via an inps -> bvinp pipeline that only existed for that dump. Instead: - smt.ml circ_equiv/circ_sat/circ_taut now return `bool * model Lazy.t`, where the model is read back from the solver as (id, bit, value) triples. Readback no longer resolves variable names: the Cache keys input variables by (id, bit) and the model reads those terms directly; name_of_var is used only when creating an input variable during node translation. The lazy is forced only if the caller wants the model. - ecLowCircuits threads the lazy model up through Backend and CSMT (new `type model`), handing it back to the caller rather than printing. - ecCircuits gates the dump behind a new Circuit:debug_smt gstate flag (mirrors Circuit:timing; enable with `pragma +Circuit:debug_smt.`), via a check_with_model helper used by instrs_equiv. --- libs/lospecs/smt.ml | 137 +++++++++++++++--------------------------- src/ecCircuits.ml | 24 +++++++- src/ecCommands.ml | 3 +- src/ecGState.ml | 6 ++ src/ecGState.mli | 4 ++ src/ecLowCircuits.ml | 108 ++++++++++++++++----------------- src/ecLowCircuits.mli | 12 +++- 7 files changed, 143 insertions(+), 151 deletions(-) diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index 8cf606b3cf..2fcfe5d5d0 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -37,10 +37,16 @@ module type SMTInstance = sig end (* ==================================================================== *) +(* The queries below return the decision together with a lazy model: when + forced, it reads back the solver's value for every input bit the query + materialized, as an (id, bit, value) triple. It is only meaningful when + the query came back satisfiable, and must be forced before the next + query reuses the solver; being lazy, the cost is paid only if wanted. + Grouping the bits into per-input values is left to the caller. *) module type SMTInterface = sig - val circ_equiv : ?inps:(int * int) list -> reg -> reg -> node -> bool - val circ_sat : ?inps:(int * int) list -> node -> bool - val circ_taut : ?inps:(int * int) list -> node -> bool + val circ_equiv : reg -> reg -> node -> bool * (int * int * string) list Lazy.t + val circ_sat : node -> bool * (int * int * string) list Lazy.t + val circ_taut : node -> bool * (int * int * string) list Lazy.t end (* ==================================================================== *) @@ -55,10 +61,8 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct instance. AIG ids are globally hash-consed and stable, and the terms below live in this instance's solver, so both maps can persist: - the node table memoizes node translation, keyed on the positive id; - - the variable table holds the size-1 input variables, by name, and - is read back for model extraction. - Every input variable is built through a single [bvterm_of_name 1] - point, so callers never construct names by hand. *) + - the variable table maps an input-variable name to its size-1 + bitvector, so each input bit is built exactly once. *) module Cache : sig type t @@ -68,20 +72,16 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct val find_node : t -> int -> SMT.bvterm option val add_node : t -> int -> SMT.bvterm -> unit - (* Size-1 input variable named [name], allocated and memoized on the - first request. *) - val var : t -> string -> SMT.bvterm + (* Size-1 variable for bit [bit] of input [id], allocated and memoized + on the first request. *) + val var : t -> int -> int -> SMT.bvterm - (* Same, but a name unseen so far yields a fresh (non-memoized) - variable — used when reading back a model. *) - val var_opt : t -> string -> SMT.bvterm - - (* Names of all the variables allocated so far. *) - val var_names : t -> string list + (* The input bit variables built so far, as ((id, bit), term) pairs. *) + val inputs : t -> ((int * int) * SMT.bvterm) list end = struct type t = { nodes : (int, SMT.bvterm) Hashtbl.t; - vars : (string, SMT.bvterm) Hashtbl.t; + vars : (int * int, SMT.bvterm) Hashtbl.t; } let create () : t = {nodes = Hashtbl.create 0; vars = Hashtbl.create 0} @@ -92,41 +92,28 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct let add_node (c : t) (id : int) (bv : SMT.bvterm) : unit = Hashtbl.add c.nodes id bv - let var (c : t) (name : string) : SMT.bvterm = - match Hashtbl.find_option c.vars name with + let var (c : t) (id : int) (bit : int) : SMT.bvterm = + match Hashtbl.find_option c.vars (id, bit) with | Some bv -> bv | None -> - let bv = SMT.bvterm_of_name 1 name in - Hashtbl.add c.vars name bv; + let bv = SMT.bvterm_of_name 1 (name_of_var id bit) in + Hashtbl.add c.vars (id, bit) bv; bv - let var_opt (c : t) (name : string) : SMT.bvterm = - match Hashtbl.find_option c.vars name with - | Some bv -> bv - | None -> SMT.bvterm_of_name 1 name - - let var_names (c : t) : string list = List.of_enum (Hashtbl.keys c.vars) + let inputs (c : t) : ((int * int) * SMT.bvterm) list = + List.of_enum (Hashtbl.enum c.vars) end - (* Dump the current SMT model to stderr (diagnostic only, emitted when a - query comes back satisfiable): the allocated input variables, then - the solver value of each input in [inps] (a circuit input as an - (id, width) pair) as the concatenation of its size-1 bit variables. *) - let print_model (cache : Cache.t) (inps : (int * int) list option) : unit = - Format.eprintf "Input bvvars: "; - List.iter (Format.eprintf "%s ") (Cache.var_names cache); - Format.eprintf "@\n"; - Option.may - (fun inps -> - List.iteri - (fun i (id, sz) -> - let bv = - List.init sz (fun b -> Cache.var_opt cache (name_of_var id b)) - |> List.reduce SMT.bvterm_concat - in - Format.eprintf "input[%d]: %a@." i SMT.pp_term (SMT.get_value bv)) - inps) - inps + (* Read back the solver's current model: the value of every input bit + the query materialized, keyed by its (id, bit). Only meaningful right + after a query returned satisfiable, and reads the live solver, so it + must run before the solver is reused. The variables are taken from + [cache], so no variable naming happens here; grouping the bits into + per-input values is left to the caller. *) + let model (cache : Cache.t) : (int * int * string) list = + Cache.inputs cache + |> List.map (fun ((id, bit), bv) -> + id, bit, Format.asprintf "%a" SMT.pp_term (SMT.get_value bv)) (* Translate an AIG node to an SMT bitvector term, using [cache] both to memoize nodes and to allocate the size-1 input variables. *) @@ -144,16 +131,13 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct and doit_r (n : Aig.node_r) = match n with | False -> SMT.bvterm_of_int 1 0 - | Input v -> Cache.var cache (name_of_var (fst v) (snd v)) + | Input v -> Cache.var cache (fst v) (snd v) | And (n1, n2) -> SMT.bvand (doit n1) (doit n2) in fun (n : Aig.node) -> doit n - let circ_equiv - ?(inps : (int * int) list option) - (r1 : Aig.reg) - (r2 : Aig.reg) - (pcond : Aig.node) : bool = + let circ_equiv (r1 : Aig.reg) (r2 : Aig.reg) (pcond : Aig.node) : + bool * (int * int * string) list Lazy.t = assert (Array.length r1 = Array.length r2); assert (Array.length r1 > 0); assert (Array.length r2 > 0); @@ -171,47 +155,24 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct let formula = SMT.bvterm_equal bvinpt1 bvinpt2 in let pcond = bvterm_of_node pcond in - begin - SMT.assert' @@ SMT.bvand pcond (SMT.bvnot formula); - if SMT.check_sat () = false then true - else begin - Format.eprintf "bvout1: %a@." SMT.pp_term (SMT.get_value bvinpt1); - Format.eprintf "bvout2: %a@." SMT.pp_term (SMT.get_value bvinpt2); - print_model cache inps; - false - end - end + SMT.assert' @@ SMT.bvand pcond (SMT.bvnot formula); + (* equivalent iff the disequality is unsat; the model (a witness to + non-equivalence) is meaningful only in the sat case. *) + let sat = SMT.check_sat () in + not sat, lazy (model cache) (* TODO: better encoding of smt terms ? *) - let circ_sat ?(inps : (int * int) list option) (n : Aig.node) : bool = + let circ_sat (n : Aig.node) : bool * (int * int * string) list Lazy.t = let cache = Cache.create () in - let bvterm_of_node = bvterm_of_node cache in - - begin - match inps with - | None -> () - | Some inps -> - List.iter - (fun (id, sz) -> - List.iter - (fun i -> ignore (Cache.var cache (name_of_var id i))) - (List.init sz identity)) - inps - end; - - let form = bvterm_of_node n in + let form = bvterm_of_node cache n in let form = SMT.(bvterm_equal form @@ bvterm_of_int 1 1) in + SMT.assert' form; + let sat = SMT.check_sat () in + sat, lazy (model cache) - begin - SMT.assert' @@ form; - if SMT.check_sat () = true then begin - print_model cache inps; - true - end - else false - end - - let circ_taut ?inps (n : Aig.node) : bool = not (circ_sat ?inps (Aig.neg n)) + let circ_taut (n : Aig.node) : bool * (int * int * string) list Lazy.t = + let sat, m = circ_sat (Aig.neg n) in + not sat, m end (* ==================================================================== *) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 659fc60563..f798789860 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -33,6 +33,24 @@ let stopwatch (env : env) : string -> unit = last := now end +(* -------------------------------------------------------------------- *) +(* Take the boolean verdict of a backend query [(valid, model)], dumping + the counter-model to the user when the query failed (i.e. [not valid], + so the lazy model is a genuine witness). The dump is gated by the + [Circuit:debug_smt] flag (default off), enabled with + [pragma Circuit:debug_smt.]; being lazy, the model is only forced when + it is going to be printed. *) +let check_with_model (env : env) ((valid, model) : bool * model Lazy.t) : bool = + if (not valid) && EcGState.get_circuit_debug_smt (EcEnv.gstate env) then begin + EcEnv.notify ~immediate:true env `Warning "[debug_smt] counter-model:@."; + List.iter + (fun (id, bit, value) -> + EcEnv.notify ~immediate:true env `Warning + "[debug_smt] input %d bit %d = %s@." id bit value) + (Lazy.force model) + end; + valid + (* -------------------------------------------------------------------- *) let circ_red (hyps : hyps) = let base_red = EcReduction.full_red in @@ -889,14 +907,14 @@ let instrs_equiv | None, Some _ | Some _, None -> false (* Variable only defined on one of the blocks (and not in the prelude) *) - | Some circ1, Some circ2 -> circ_equiv circ1 circ2) + | Some circ1, Some circ2 -> check_with_model env (circ_equiv circ1 circ2)) vs | None -> state_get_all_memory st mem |> List.for_all (fun (var, _) -> let circ1 = state_get_pv st1 mem var in let circ2 = state_get_pv st2 mem var in - circ_equiv circ1 circ2) + check_with_model env (circ_equiv circ1 circ2)) (* FIXME: change memory -> memenv Why? *) let state_of_prog @@ -925,7 +943,7 @@ let circ_simplify_form_bitstring_equality in check f -let circ_taut = circ_taut +let circ_taut (c : circuit) : bool = fst (circ_taut c) let circuit_state_of_memenv ?(st : state = empty_state) diff --git a/src/ecCommands.ml b/src/ecCommands.ml index a69692e2a1..d65c4bb283 100644 --- a/src/ecCommands.ml +++ b/src/ecCommands.ml @@ -720,7 +720,8 @@ and process_option (scope : EcScope.scope) (name, value) = match value with | `Bool value when EcLocation.unloc name = EcGState.old_mem_restr || EcLocation.unloc name = EcGState.pp_showtvi - || EcLocation.unloc name = EcGState.circuit_timing -> + || EcLocation.unloc name = EcGState.circuit_timing + || EcLocation.unloc name = EcGState.circuit_debug_smt -> let gs = EcEnv.gstate (EcScope.env scope) in EcGState.setflag (unloc name) value gs; scope diff --git a/src/ecGState.ml b/src/ecGState.ml index 13607118f4..a9b20e7965 100644 --- a/src/ecGState.ml +++ b/src/ecGState.ml @@ -76,6 +76,12 @@ let circuit_timing = "Circuit:timing" let get_circuit_timing (g : gstate) : bool = getflag ~default:false circuit_timing g +(* -------------------------------------------------------------------- *) +let circuit_debug_smt = "Circuit:debug_smt" + +let get_circuit_debug_smt (g : gstate) : bool = + getflag ~default:false circuit_debug_smt g + (* -------------------------------------------------------------------- *) let add_notifier (notifier : loglevel -> string Lazy.t -> unit) (gs : gstate) = let notifier = { nt_id = EcUid.unique (); nt_cb = notifier; } in diff --git a/src/ecGState.mli b/src/ecGState.mli index ae61bf8994..9340aec4c8 100644 --- a/src/ecGState.mli +++ b/src/ecGState.mli @@ -36,6 +36,10 @@ val get_pp_showtvi : gstate -> bool val circuit_timing : string val get_circuit_timing : gstate -> bool +(* --------------------------------------------------------------------- *) +val circuit_debug_smt : string +val get_circuit_debug_smt : gstate -> bool + (* --------------------------------------------------------------------- *) type nid_t type loglevel = [`Debug | `Info | `Warning | `Critical] diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index 404507bc16..cd6a6a1098 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -75,10 +75,17 @@ module type CBackend = sig val apply : (inp -> node option) -> node -> node val applys : (inp -> node option) -> reg -> reg - val circuit_from_spec : Lospecs.Ast.adef -> reg list -> reg - val equiv : ?inps:inp list -> pcond:node -> reg -> reg -> bool - val sat : ?inps:inp list -> node -> bool - val taut : ?inps:inp list -> node -> bool + val circuit_from_spec : Lospecs.Ast.adef -> reg list -> reg + + (* The queries return the decision and a lazy model: when forced, the + solver's value for each input bit it materialized, as (id, bit, + value) triples. Only meaningful (and only to be forced) when the + decision witnesses a counter-model. *) + type model = (int * int * string) list + + val equiv : pcond:node -> reg -> reg -> bool * model Lazy.t + val sat : node -> bool * model Lazy.t + val taut : node -> bool * model Lazy.t val slice : reg -> int -> int -> reg val subcirc : reg -> (int list) -> reg @@ -172,6 +179,7 @@ module LospecsBack : CBackend = struct type node = C.node type reg = C.node array type inp = int * int + type model = (int * int * string) list let pp_node (fmt : Format.formatter) (n: node) = Format.fprintf fmt "%a" (fun fmt -> Lospecs.Aig.pp_node fmt) n @@ -243,22 +251,22 @@ module LospecsBack : CBackend = struct let node_ite (c: node) (t: node) (f: node) = C.mux2 f t c let reg_ite (c: node) = Array.map2 (node_ite c) - let equiv ?(inps: inp list option) ~(pcond: node) (r1: reg) (r2: reg) : bool = + let equiv ~(pcond: node) (r1: reg) (r2: reg) : bool * model Lazy.t = let open CSMT in let module BWZ = (val makeBWZinterface ()) in - BWZ.circ_equiv ?inps r1 r2 pcond + BWZ.circ_equiv r1 r2 pcond - let sat ?(inps: inp list option) (n: node) : bool = + let sat (n: node) : bool * model Lazy.t = let open CSMT in let module BWZ = (val makeBWZinterface ()) in - BWZ.circ_sat ?inps n + BWZ.circ_sat n - let taut ?(inps: inp list option) (n: node) : bool = + let taut (n: node) : bool * model Lazy.t = let open CSMT in let module BWZ = (val makeBWZinterface ()) in - BWZ.circ_taut ?inps n + BWZ.circ_taut n - let slice (r: reg) (idx: int) (len: int) : reg = + let slice (r: reg) (idx: int) (len: int) : reg = try Array.sub r idx len with Invalid_argument _ -> raise (BadSlice `Get) @@ -476,10 +484,16 @@ module type CircuitInterface = sig type_: ctype ; } type 'a cfun = 'a * (cinp list) - type circuit = circ cfun + type circuit = circ cfun + + (* A satisfying assignment, read back from the SMT solver: the value of + each input bit it materialized, as (id, bit, value) triples. The + queries below return it lazily, grouping into per-input values is + left to the caller. *) + type model = (int * int * string) list val pp_flatcirc : Format.formatter -> flatcirc -> unit - + module CArgs : sig type arg = [ `Circuit of circuit @@ -586,10 +600,12 @@ module type CircuitInterface = sig val circuit_uninit : ctype -> circuit val circuit_has_uninitialized : circuit -> int option - (* Logical reasoning over circuits *) - val circ_equiv : ?pcond:circuit -> circuit -> circuit -> bool - val circ_sat : circuit -> bool - val circ_taut : circuit -> bool + (* Logical reasoning over circuits. Each query returns the decision and + a lazy counter-model (see [Backend.model]); forcing it is only + meaningful when the decision is a counter-model witness. *) + val circ_equiv : ?pcond:circuit -> circuit -> circuit -> bool * model Lazy.t + val circ_sat : circuit -> bool * model Lazy.t + val circ_taut : circuit -> bool * model Lazy.t (* Composition of circuit functions, should deal with inputs and call some backend *) val circuit_compose : circuit -> circuit list -> circuit @@ -632,7 +648,8 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = id : int; } type 'a cfun = 'a * (cinp list) - type circuit = circ cfun + type circuit = circ cfun + type model = Backend.model (* -------------------------------------------------------------------- *) (* Exceptions *) @@ -1054,54 +1071,33 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let circuit_has_uninitialized (c: circuit) : int option = Backend.have_bad (fst c).reg - let circ_equiv ?(pcond:circuit option) ((c1, inps1): circuit) ((c2, inps2): circuit) : bool = - let pcond = Option.map (convert_type CBool) pcond in (* Try to convert to bool *) + let circ_equiv ?(pcond:circuit option) ((c1, inps1): circuit) ((c2, inps2): circuit) : bool * Backend.model Lazy.t = + let pcond = Option.map (convert_type CBool) pcond in (* Try to convert to bool *) let pcc = match pcond with - | Some ({reg = b; type_ = CBool}, pcinps) -> + | Some ({reg = b; type_ = CBool}, pcinps) -> Backend.apply (unify_inputs_renamer inps1 pcinps) (Backend.node_of_reg b) - | None -> Backend.true_ - | _ -> lowcircerror CircEquivNonBoolPCond + | None -> Backend.true_ + | _ -> lowcircerror CircEquivNonBoolPCond in (* This throws, but we let it propagate upwards *) let c2 = unify_inputs inps1 (c2, inps2) in - let inps = List.map (function - | { type_ = CBool; id } -> (id, 1) - | { type_ = CBitstring w; id } -> (id, w) - | { type_ = CArray {width=w1; count=w2}; id } -> (id, w1*w2) - | { type_ = CTuple tys; id } -> (id, List.sum @@ List.map size_of_ctype tys) - - ) inps1 in if (c1.type_ = c2.type_) then - Backend.equiv ~inps ~pcond:pcc c1.reg c2.reg - else false - - let circ_sat ((c, inps): circuit) : bool = - let c = match c with + Backend.equiv ~pcond:pcc c1.reg c2.reg + else (false, lazy []) + + let circ_sat ((c, _): circuit) : bool * Backend.model Lazy.t = + let c = match c with | {type_ = CBool; reg} -> Backend.node_of_reg reg | _ -> lowcircerror CircSmtNonBoolCirc in - let inps = List.map (function - | { type_ = CBool; id } -> (id, 1) - | { type_ = CBitstring w; id } -> (id, w) - | { type_ = CArray {width=w1; count=w2}; id } -> (id, w1*w2) - | { type_ = CTuple tys; id } -> (id, List.sum @@ List.map size_of_ctype tys) - - ) inps in - Backend.sat ~inps c - - let circ_taut ((c, inps): circuit) : bool = - let c = match c with + Backend.sat c + + let circ_taut ((c, _): circuit) : bool * Backend.model Lazy.t = + let c = match c with | {type_ = CBool; reg} -> Backend.node_of_reg reg | _ -> lowcircerror CircSmtNonBoolCirc in - let inps = List.map (function - | { type_ = CBool; id } -> (id, 1) - | { type_ = CBitstring w; id } -> (id, w) - | { type_ = CArray {width=w1; count=w2}; id } -> (id, w1*w2) - | { type_ = CTuple tys; id } -> (id, List.sum @@ List.map size_of_ctype tys) - - ) inps in - Backend.taut ~inps c + Backend.taut c (* Inputs mean different things depending on circuit type *) (* Allow unaligned slices *) @@ -1332,8 +1328,8 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (* let res = fillet_taut pres post in *) let post = sublimate_inputs post in - let res = circ_taut post in - if not res then + let res = fst (circ_taut post) in + if not res then Option.may (fun f -> f @@ Format.asprintf "Failed for bit %d@." i) logger; res) posts |> List.for_all identity diff --git a/src/ecLowCircuits.mli b/src/ecLowCircuits.mli index db63289291..6b6c11e109 100644 --- a/src/ecLowCircuits.mli +++ b/src/ecLowCircuits.mli @@ -37,6 +37,12 @@ type circ = { type 'a cfun = 'a * (cinp list) type circuit = circ cfun +(* A satisfying assignment read back from the SMT solver: the value of + each input bit it materialized, as (id, bit, value) triples. The + queries below return it lazily; grouping into per-input values is left + to the caller. *) +type model = (int * int * string) list + val pp_flatcirc : Format.formatter -> flatcirc -> unit (* -------------------------------------------------------------------- *) @@ -143,9 +149,9 @@ val circuit_uninit : ctype -> circuit val circuit_has_uninitialized : circuit -> int option (* Logical reasoning over circuits *) -val circ_equiv : ?pcond:circuit -> circuit -> circuit -> bool -val circ_sat : circuit -> bool -val circ_taut : circuit -> bool +val circ_equiv : ?pcond:circuit -> circuit -> circuit -> bool * model Lazy.t +val circ_sat : circuit -> bool * model Lazy.t +val circ_taut : circuit -> bool * model Lazy.t (* Composition of circuit functions *) val circuit_compose : circuit -> circuit list -> circuit From 79d304c5e5ac9cfaa8e608716ef8c456db41766f Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 2 Jun 2026 15:18:45 +0200 Subject: [PATCH 090/145] lospecs/smt: make the solving state an explicit context MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The SMT bridge had no first-class value for "the state of one solve": the Bitwuzla solver was hidden in the SMTInstance closure (one packed module per query via makeBWZinterface), while the memo tables were a separate Cache value threaded alongside. Replace both with one explicit context: - SMTInstance now exposes an abstract `solver` with `create_solver` and stateful ops (assert'/check_sat/get_value) that take it, instead of capturing a solver in a closure. - MakeSMTInterface exposes `type ctx` (solver + node memo + input-var memo), `create`, and `equiv`/`sat`/`taut`/`model` taking it. The Cache submodule is gone; its tables are ctx fields. - The Bitwuzla backend is a plain module BWZInstance, and BWZ = MakeSMTInterface(BWZInstance); makeBWZinstance/makeBWZinterface and the per-query first-class-module packing are removed. ecLowCircuits's Backend.equiv/sat/taut become one-liners: create a ctx, run the query, and return (decision, lazy (BWZ.model ctx)) — same `bool * model Lazy.t` contract, so all consumers (ecCircuits, ecPhlBDep, fillet_tauts) are untouched. One solver per query is preserved (one ctx per query); the model lazy is forced before the next ctx, as before. --- libs/lospecs/smt.ml | 230 +++++++++++++++++++++---------------------- src/ecLowCircuits.ml | 15 ++- 2 files changed, 116 insertions(+), 129 deletions(-) diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index 2fcfe5d5d0..5e3ec9de94 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -6,8 +6,15 @@ open Bitwuzla_cxx module type SMTInstance = sig type bvterm + (* A solver instance: holds the assertion stack and, after a satisfiable + check, the model. The stateful operations below act on one. *) + type solver + exception SMTError + (* Create a fresh solver (empty assertion stack). *) + val create_solver : unit -> solver + (* Expected params: sort, value *) val bvterm_of_int : int -> int -> bvterm @@ -15,11 +22,11 @@ module type SMTInstance = sig val bvterm_of_name : int -> string -> bvterm (* argument must be of size 1, assert it true *) - (* Should affect internal state of SMT *) - val assert' : bvterm -> unit + (* Affects the solver's assertion stack *) + val assert' : solver -> bvterm -> unit - (* Check satisfiability of current asserts *) - val check_sat : unit -> bool + (* Check satisfiability of the solver's current asserts *) + val check_sat : solver -> bool (* equality over bitvectors, res is a size 1 bitvector *) val bvterm_equal : bvterm -> bvterm -> bvterm @@ -32,98 +39,86 @@ module type SMTInstance = sig (* bvnot *) val bvand : bvterm -> bvterm -> bvterm - val get_value : bvterm -> bvterm + val get_value : solver -> bvterm -> bvterm val pp_term : Format.formatter -> bvterm -> unit end (* ==================================================================== *) -(* The queries below return the decision together with a lazy model: when - forced, it reads back the solver's value for every input bit the query - materialized, as an (id, bit, value) triple. It is only meaningful when - the query came back satisfiable, and must be forced before the next - query reuses the solver; being lazy, the cost is paid only if wanted. - Grouping the bits into per-input values is left to the caller. *) +(* A solving context bundles everything one query needs: the backend + solver together with the per-query memoization tables. It is created + per query (one solver per query gives assertion isolation) and carried + explicitly. The queries return the decision; [model] reads the model + back from the same context and is only meaningful after a satisfiable + query, before the context's solver is re-used. Grouping the input bits + into per-input values is left to the caller. *) module type SMTInterface = sig - val circ_equiv : reg -> reg -> node -> bool * (int * int * string) list Lazy.t - val circ_sat : node -> bool * (int * int * string) list Lazy.t - val circ_taut : node -> bool * (int * int * string) list Lazy.t + type ctx + + val create : unit -> ctx + val equiv : ctx -> reg -> reg -> node -> bool + val sat : ctx -> node -> bool + val taut : ctx -> node -> bool + val model : ctx -> (int * int * string) list end (* ==================================================================== *) -(* TODO Add model printing for circ_sat and circ_taut *) (* Assumes circuit inputs have already been appropriately renamed *) module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct (* SMT variable name for bit [bit] of circuit input [id]. *) let name_of_var (id : int) (bit : int) : string = Printf.sprintf "BV_%d_%05X" id bit - (* Per-instance translation state, shared across every query on this - instance. AIG ids are globally hash-consed and stable, and the terms - below live in this instance's solver, so both maps can persist: - - the node table memoizes node translation, keyed on the positive id; - - the variable table maps an input-variable name to its size-1 - bitvector, so each input bit is built exactly once. *) - module Cache : sig - type t - - val create : unit -> t - - (* Memoized node translation. *) - val find_node : t -> int -> SMT.bvterm option - val add_node : t -> int -> SMT.bvterm -> unit - - (* Size-1 variable for bit [bit] of input [id], allocated and memoized - on the first request. *) - val var : t -> int -> int -> SMT.bvterm - - (* The input bit variables built so far, as ((id, bit), term) pairs. *) - val inputs : t -> ((int * int) * SMT.bvterm) list - end = struct - type t = { - nodes : (int, SMT.bvterm) Hashtbl.t; - vars : (int * int, SMT.bvterm) Hashtbl.t; + (* The explicit per-query state. AIG ids are globally hash-consed and + stable, and the terms below live in [solver], so the two memo tables + are valid for the whole life of the context: + - [nodes] memoizes node translation, keyed on the positive node id; + - [vars] maps an input bit (id, bit) to its size-1 bitvector, so each + input bit is built exactly once. *) + type ctx = { + solver : SMT.solver; + nodes : (int, SMT.bvterm) Hashtbl.t; + vars : (int * int, SMT.bvterm) Hashtbl.t; + } + + let create () : ctx = + { + solver = SMT.create_solver (); + nodes = Hashtbl.create 0; + vars = Hashtbl.create 0; } - let create () : t = {nodes = Hashtbl.create 0; vars = Hashtbl.create 0} - - let find_node (c : t) (id : int) : SMT.bvterm option = - Hashtbl.find_option c.nodes id - - let add_node (c : t) (id : int) (bv : SMT.bvterm) : unit = - Hashtbl.add c.nodes id bv - - let var (c : t) (id : int) (bit : int) : SMT.bvterm = - match Hashtbl.find_option c.vars (id, bit) with - | Some bv -> bv - | None -> - let bv = SMT.bvterm_of_name 1 (name_of_var id bit) in - Hashtbl.add c.vars (id, bit) bv; - bv - - let inputs (c : t) : ((int * int) * SMT.bvterm) list = - List.of_enum (Hashtbl.enum c.vars) - end + (* Size-1 variable for bit [bit] of input [id], allocated and memoized + on the first request. *) + let var (ctx : ctx) (id : int) (bit : int) : SMT.bvterm = + match Hashtbl.find_option ctx.vars (id, bit) with + | Some bv -> bv + | None -> + let bv = SMT.bvterm_of_name 1 (name_of_var id bit) in + Hashtbl.add ctx.vars (id, bit) bv; + bv (* Read back the solver's current model: the value of every input bit the query materialized, keyed by its (id, bit). Only meaningful right - after a query returned satisfiable, and reads the live solver, so it - must run before the solver is reused. The variables are taken from - [cache], so no variable naming happens here; grouping the bits into - per-input values is left to the caller. *) - let model (cache : Cache.t) : (int * int * string) list = - Cache.inputs cache + after a satisfiable query, and reads the live solver, so it must run + before the context's solver is re-used. The variables are taken from + [ctx.vars], so no variable naming happens here; grouping the bits + into per-input values is left to the caller. *) + let model (ctx : ctx) : (int * int * string) list = + Hashtbl.enum ctx.vars |> List.of_enum |> List.map (fun ((id, bit), bv) -> - id, bit, Format.asprintf "%a" SMT.pp_term (SMT.get_value bv)) + ( id, + bit, + Format.asprintf "%a" SMT.pp_term (SMT.get_value ctx.solver bv) )) - (* Translate an AIG node to an SMT bitvector term, using [cache] both to - memoize nodes and to allocate the size-1 input variables. *) - let bvterm_of_node (cache : Cache.t) : Aig.node -> SMT.bvterm = + (* Translate an AIG node to an SMT bitvector term, memoizing nodes and + allocating the size-1 input variables in [ctx]. *) + let bvterm_of_node (ctx : ctx) : Aig.node -> SMT.bvterm = let rec doit (n : Aig.node) = let mn = - match Cache.find_node cache (Int.abs n.id) with + match Hashtbl.find_option ctx.nodes (Int.abs n.id) with | None -> let mn = doit_r n.gate in - Cache.add_node cache (Int.abs n.id) mn; + Hashtbl.add ctx.nodes (Int.abs n.id) mn; mn | Some mn -> mn in @@ -131,19 +126,18 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct and doit_r (n : Aig.node_r) = match n with | False -> SMT.bvterm_of_int 1 0 - | Input v -> Cache.var cache (fst v) (snd v) + | Input v -> var ctx (fst v) (snd v) | And (n1, n2) -> SMT.bvand (doit n1) (doit n2) in fun (n : Aig.node) -> doit n - let circ_equiv (r1 : Aig.reg) (r2 : Aig.reg) (pcond : Aig.node) : - bool * (int * int * string) list Lazy.t = + let equiv (ctx : ctx) (r1 : Aig.reg) (r2 : Aig.reg) (pcond : Aig.node) : bool + = assert (Array.length r1 = Array.length r2); assert (Array.length r1 > 0); assert (Array.length r2 > 0); - let cache = Cache.create () in - let bvterm_of_node = bvterm_of_node cache in + let bvterm_of_node = bvterm_of_node ctx in let bvterm_of_reg (r : Aig.reg) : _ = Array.map bvterm_of_node r @@ -155,66 +149,62 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct let formula = SMT.bvterm_equal bvinpt1 bvinpt2 in let pcond = bvterm_of_node pcond in - SMT.assert' @@ SMT.bvand pcond (SMT.bvnot formula); - (* equivalent iff the disequality is unsat; the model (a witness to - non-equivalence) is meaningful only in the sat case. *) - let sat = SMT.check_sat () in - not sat, lazy (model cache) + SMT.assert' ctx.solver @@ SMT.bvand pcond (SMT.bvnot formula); + (* equivalent iff the disequality is unsat; a model is then a witness + to non-equivalence. *) + not (SMT.check_sat ctx.solver) (* TODO: better encoding of smt terms ? *) - let circ_sat (n : Aig.node) : bool * (int * int * string) list Lazy.t = - let cache = Cache.create () in - let form = bvterm_of_node cache n in + let sat (ctx : ctx) (n : Aig.node) : bool = + let form = bvterm_of_node ctx n in let form = SMT.(bvterm_equal form @@ bvterm_of_int 1 1) in - SMT.assert' form; - let sat = SMT.check_sat () in - sat, lazy (model cache) + SMT.assert' ctx.solver form; + SMT.check_sat ctx.solver - let circ_taut (n : Aig.node) : bool * (int * int * string) list Lazy.t = - let sat, m = circ_sat (Aig.neg n) in - not sat, m + let taut (ctx : ctx) (n : Aig.node) : bool = not (sat ctx (Aig.neg n)) end (* ==================================================================== *) -let makeBWZinstance () : (module SMTInstance) = - let options = Options.default () in - Options.set options Produce_models true; - - let bitwuzla = Solver.create options in +(* The Bitwuzla backend. The solver is an explicit value (no longer hidden + in a closure), so it can be owned by a solving context. *) +module BWZInstance : SMTInstance = struct + type bvterm = Term.t + type solver = Solver.t - (module struct - type bvterm = Term.t + exception SMTError - exception SMTError + let create_solver () : solver = + let options = Options.default () in + Options.set options Produce_models true; + Solver.create options - let bvterm_of_int (sort : int) (v : int) : bvterm = - mk_bv_value_int (mk_bv_sort sort) v + let bvterm_of_int (sort : int) (v : int) : bvterm = + mk_bv_value_int (mk_bv_sort sort) v - let bvterm_of_name (sort : int) (name : string) : bvterm = - mk_const (mk_bv_sort sort) ~symbol:name + let bvterm_of_name (sort : int) (name : string) : bvterm = + mk_const (mk_bv_sort sort) ~symbol:name - let assert' (f : bvterm) : unit = Solver.assert_formula bitwuzla f + let assert' (s : solver) (f : bvterm) : unit = Solver.assert_formula s f - let check_sat () : bool = - match Solver.check_sat bitwuzla with - | Sat -> true - | Unsat -> false - | Unknown -> raise SMTError + let check_sat (s : solver) : bool = + match Solver.check_sat s with + | Sat -> true + | Unsat -> false + | Unknown -> raise SMTError - let bvterm_equal (bv1 : bvterm) (bv2 : bvterm) : bvterm = - mk_term2 Kind.Equal bv1 bv2 + let bvterm_equal (bv1 : bvterm) (bv2 : bvterm) : bvterm = + mk_term2 Kind.Equal bv1 bv2 - let bvterm_concat (bv1 : bvterm) (bv2 : bvterm) : bvterm = - mk_term2 Kind.Bv_concat bv1 bv2 + let bvterm_concat (bv1 : bvterm) (bv2 : bvterm) : bvterm = + mk_term2 Kind.Bv_concat bv1 bv2 - let bvnot (bv : bvterm) : bvterm = mk_term1 Kind.Bv_not bv + let bvnot (bv : bvterm) : bvterm = mk_term1 Kind.Bv_not bv - let bvand (bv1 : bvterm) (bv2 : bvterm) : bvterm = - mk_term2 Kind.Bv_and bv1 bv2 + let bvand (bv1 : bvterm) (bv2 : bvterm) : bvterm = + mk_term2 Kind.Bv_and bv1 bv2 - let get_value (bv : bvterm) : bvterm = Solver.get_value bitwuzla bv - let pp_term (fmt : Format.formatter) (bv : bvterm) : unit = Term.pp fmt bv - end : SMTInstance) + let get_value (s : solver) (bv : bvterm) : bvterm = Solver.get_value s bv + let pp_term (fmt : Format.formatter) (bv : bvterm) : unit = Term.pp fmt bv +end -let makeBWZinterface () : (module SMTInterface) = - (module MakeSMTInterface ((val makeBWZinstance () : SMTInstance))) +module BWZ = MakeSMTInterface (BWZInstance) diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index cd6a6a1098..c2500881ad 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -252,19 +252,16 @@ module LospecsBack : CBackend = struct let reg_ite (c: node) = Array.map2 (node_ite c) let equiv ~(pcond: node) (r1: reg) (r2: reg) : bool * model Lazy.t = - let open CSMT in - let module BWZ = (val makeBWZinterface ()) in - BWZ.circ_equiv r1 r2 pcond + let ctx = CSMT.BWZ.create () in + (CSMT.BWZ.equiv ctx r1 r2 pcond, lazy (CSMT.BWZ.model ctx)) let sat (n: node) : bool * model Lazy.t = - let open CSMT in - let module BWZ = (val makeBWZinterface ()) in - BWZ.circ_sat n + let ctx = CSMT.BWZ.create () in + (CSMT.BWZ.sat ctx n, lazy (CSMT.BWZ.model ctx)) let taut (n: node) : bool * model Lazy.t = - let open CSMT in - let module BWZ = (val makeBWZinterface ()) in - BWZ.circ_taut n + let ctx = CSMT.BWZ.create () in + (CSMT.BWZ.taut ctx n, lazy (CSMT.BWZ.model ctx)) let slice (r: reg) (idx: int) (len: int) : reg = try Array.sub r idx len From db45c7eaefd5fa99d7b5a27f33cd119885a4e9d0 Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Tue, 2 Jun 2026 17:31:54 +0100 Subject: [PATCH 091/145] Added QFABV theories --- examples/bindings.ec | 1 + flake.nix | 178 ++++++-- tests/circuit_test.ec | 3 +- theories/datatypes/QFABV.ec | 26 +- theories/distributions/#Dexcepted.ec# | 622 ++++++++++++++++++++++++++ theories/distributions/DFSet.ec | 456 +++++++++++++++++++ 6 files changed, 1243 insertions(+), 43 deletions(-) create mode 100644 theories/distributions/#Dexcepted.ec# create mode 100644 theories/distributions/DFSet.ec diff --git a/examples/bindings.ec b/examples/bindings.ec index 130995b25f..787b09422e 100644 --- a/examples/bindings.ec +++ b/examples/bindings.ec @@ -4,6 +4,7 @@ from Jasmin require import JModel JArray. clone import PolyArray as Array2 with op size <- 2. bind array Array2."_.[_]" Array2."_.[_<-_]" Array2.to_list Array2.of_list Array2.t 2. +realize oflistP by admit. realize tolistP by admit. realize eqP by admit. realize get_setP by admit. diff --git a/flake.nix b/flake.nix index 77d38a85ff..f4787ffb65 100644 --- a/flake.nix +++ b/flake.nix @@ -1,35 +1,60 @@ { + nixConfig = { + extra-substituters = [ + "https://easycrypt.cachix.org" + ]; + extra-trusted-public-keys = [ + "easycrypt.cachix.org-1:d0hAur+ZAUIM7rAi1TlG2ZCra6AXS50CggshQcT6f7g=" + ]; + }; inputs = { opam-nix.url = "github:tweag/opam-nix"; flake-utils.url = "github:numtide/flake-utils"; + treefmt-nix.url = "github:numtide/treefmt-nix"; - nixpkgs.url = "github:nixos/nixpkgs/24.05"; - stable.url = "github:nixos/nixpkgs/24.05"; nixpkgs.follows = "opam-nix/nixpkgs"; + emacs-overlay.url = "github:nix-community/emacs-overlay"; prover_cvc4_1_8 = { url = "github:CVC4/CVC4-archived/1.8"; flake = false; }; - prover_cvc5_1_0_9 = { - url = "github:cvc5/cvc5/cvc5-1.0.9"; + prover_cvc5_1_3_0 = { + url = "github:cvc5/cvc5/cvc5-1.3.0"; flake = false; }; - prover_z3_4_12_6 = { - url = "github:z3prover/z3/z3-4.12.6"; + prover_z3_4_14_1 = { + url = "github:z3prover/z3/z3-4.14.1"; flake = false; }; }; - outputs = { self, flake-utils, opam-nix, nixpkgs, ... }@inputs: - let package = "easycrypt"; in - - flake-utils.lib.eachDefaultSystem (system: - let - pkgs = nixpkgs.legacyPackages.${system}; + outputs = { + flake-utils, + opam-nix, + nixpkgs, + emacs-overlay, + treefmt-nix, + ... + } @ inputs: let + package = "easycrypt"; + in + flake-utils.lib.eachDefaultSystem ( + system: let + overlays = [(import emacs-overlay)]; + pkgs = import nixpkgs {inherit system overlays;}; + treefmtEval = treefmt-nix.lib.evalModule pkgs { + projectRootFile = "flake.nix"; + + # Enable formatters + programs.alejandra.enable = true; + # programs.ocamlformat.enable = true; # TODO: Enable when we have a repo .ocamlformat + + # Add any extra formatters here (for MD, docs, whatever) + }; on = opam-nix.lib.${system}; @@ -39,36 +64,64 @@ ocamlformat = "*"; }; - query = devPackagesQuery // { - ocaml-base-compiler = "4.14.2"; + query = + devPackagesQuery + // { + ocaml-base-compiler = "5.3.0"; + }; + + opamSource = pkgs.lib.cleanSourceWith { + src = ./.; + filter = path: type: + type + == "directory" + || pkgs.lib.strings.hasSuffix ".opam" path + || builtins.baseNameOf path == "dune-project" + || builtins.baseNameOf path == "dune"; }; - scope = on.buildOpamProject' { } ./. query; + scope = on.buildOpamProject' {} opamSource query; - overlay = final: prev: { + overlay = _final: prev: { ${package} = prev.${package}.overrideAttrs (oa: { - nativeBuildInputs = oa.nativeBuildInputs - ++ pkgs.lib.optionals pkgs.stdenv.isDarwin [ pkgs.darwin.sigtool ]; + src = pkgs.lib.cleanSource ./.; + nativeBuildInputs = + oa.nativeBuildInputs ++ pkgs.lib.optionals pkgs.stdenv.isDarwin [pkgs.darwin.sigtool]; postInstall = '' ln -s "$out/lib/ocaml/$opam__ocaml__version/site-lib/easycrypt" $out/lib/ ''; doNixSupport = false; }); - conf-pkg-config = prev.conf-pkg-config.overrideAttrs (oa: { - nativeBuildInputs = oa.nativeBuildInputs ++ [pkgs.pkg-config]; - }); + conf-zlib = prev.conf-zlib.overrideAttrs ( + _finalAttrs: prevAttrs: { + nativeBuildInputs = prevAttrs.nativeBuildInputs ++ (with pkgs; [pkg-config]); + } + ); + conf-git = prev.conf-git.overrideAttrs ( + _finalAttrs: prevAttrs: { + nativeBuildInputs = prevAttrs.nativeBuildInputs ++ (with pkgs; [git]); + buildInputs = prevAttrs.buildInputs ++ (with pkgs; [git]); + } + ); + alt-ergo = prev.alt-ergo.overrideAttrs ( + _finalAttrs: prevAttrs: { + nativeBuildInputs = prevAttrs.nativeBuildInputs ++ (with pkgs; [darwin.sigtool]); + } + ); }; scope' = scope.overrideScope overlay; # Packages from devPackagesQuery - devPackages = builtins.attrValues - (pkgs.lib.getAttrs (builtins.attrNames devPackagesQuery) scope'); + devPackages = builtins.attrValues (pkgs.lib.getAttrs (builtins.attrNames devPackagesQuery) scope'); # The main package containing the executable main = pkgs.symlinkJoin { name = "main"; - paths = [ scope'.${package} scope'.why3 ]; + paths = [ + scope'.${package} + scope'.why3 + ]; }; # Create provers packages @@ -78,36 +131,85 @@ src = inputs."${"prover_" + pkg + "_" + builtins.replaceStrings ["."] ["_"] version}"; }); - mkAltErgo = version: - ((on.queryToScope { } (query // { alt-ergo = version; })).overrideScope overlay).alt-ergo; + mkAltErgo = version: (on.queryToScope {} (query // {alt-ergo = version;})).alt-ergo; + + devTools = with pkgs; + [ + (emacsWithPackagesFromUsePackage { + config = ''(setq easycrypt-prog-name "ec.native")''; + defaultInitFile = true; + alwaysEnsure = true; + package = pkgs.emacs; + extraEmacsPackages = epkgs: [epkgs.proof-general]; + }) + bashInteractive + git + difftastic + ] + ++ lib.optionals (!stdenv.isDarwin) [perf-tools]; + + ecShell = "${pkgs.bashInteractive + "/bin/bash"}"; + ecShellHook = '' + export SHELL=${ecShell} + export PATH=$PATH:`realpath .` + ''; in rec { legacyPackages = scope'; packages = rec { - z3 = mkProverPackage "z3" "4.12.6"; + z3 = mkProverPackage "z3" "4.14.1"; cvc4 = mkProverPackage "cvc4" "1.8"; - cvc5 = mkProverPackage "cvc5" "1.0.9"; - altErgo = mkAltErgo "2.4.3"; + cvc5 = mkProverPackage "cvc5" "1.3.0"; + altErgo = mkAltErgo "2.4.2"; provers = pkgs.symlinkJoin { name = "provers"; - paths = [ altErgo z3 cvc4 cvc5 ]; + paths = + [ + altErgo + z3 + cvc5 + ] + ++ (pkgs.lib.optionals (!pkgs.stdenv.isDarwin) [cvc4]); # Cvc4 build is broken in MacOS }; with_provers = pkgs.symlinkJoin { name = "with-provers"; - paths = [ main provers ]; + paths = [ + main + provers + ]; }; default = main; }; - devShells.default = pkgs.mkShell { - inputsFrom = [ scope'.easycrypt ]; - buildInputs = - devPackages - ++ [ pkgs.git scope'.why3 packages.provers ] - ++ (with pkgs.python3Packages; [ pyyaml ]); + devShells.barebones = pkgs.mkShell { + inputsFrom = [scope'.easycrypt]; + buildInputs = devPackages ++ [scope'.why3] ++ (with pkgs.python3Packages; [pyyaml]); }; - }); + + devShells.noProvers = pkgs.mkShell { + inputsFrom = [ + scope'.easycrypt + devShells.barebones + ]; + buildInputs = devTools; + SHELL = ecShell; + shellHook = ecShellHook; + }; + + devShells.withDevTools = pkgs.mkShell { + inputsFrom = [ + scope'.easycrypt + devShells.noProvers + ]; + buildInputs = [packages.provers]; + SHELL = ecShell; + shellHook = ecShellHook; + }; + + formatter = treefmtEval.config.build.wrapper; + } + ); } diff --git a/tests/circuit_test.ec b/tests/circuit_test.ec index 2512b9e8f0..84508b3190 100644 --- a/tests/circuit_test.ec +++ b/tests/circuit_test.ec @@ -88,7 +88,6 @@ lemma W8_xor_ext (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ proof. proc. extens [a] : (wp; skip; smt()). -admit. qed. lemma W8_xor_circuit (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. @@ -148,11 +147,11 @@ end Array8. bind array Array8."_.[_]" Array8."_.[_<-_]" Array8.tolist Array8.oflist Array8.t 8. realize gt0_size by auto. realize tolistP by admit. +realize oflistP by admit. realize eqP by admit. realize get_setP by admit. realize get_out by admit. - op init_8_8 (f: int -> W8) : W8 Array8.t. bind op [W8 & Array8.t] init_8_8 "ainit". diff --git a/theories/datatypes/QFABV.ec b/theories/datatypes/QFABV.ec index a09af42771..c5e6e42bc4 100644 --- a/theories/datatypes/QFABV.ec +++ b/theories/datatypes/QFABV.ec @@ -58,9 +58,16 @@ abstract theory A. op to_list ['a] : 'a t -> 'a list. + op of_list ['a] : 'a -> 'a list -> 'a t. + axiom tolistP ['a] (a : 'a t) : to_list a = mkseq (fun i => get a i) size. + axiom oflistP ['a] (a : 'a list) : + (forall (i: int) (dfl: 'a), + 0 <= i /\ i < size => + List.nth dfl a i = get (of_list dfl a) i). + axiom eqP ['a] (a1 a2 : 'a t) : (forall i, 0 <= i < size => get a1 i = get a2 i) <=> (a1 = a2). @@ -108,7 +115,8 @@ theory BVOperators. (* ------------------------------------------------------------------ *) abstract theory BVMul. - clone import BV. + + clone import BV. op bvmul : bv -> bv -> bv. @@ -137,8 +145,20 @@ theory BVOperators. end BVURem. (* ------------------------------------------------------------------ *) - (* abstract theory BVSRem. FIXME: TODO *) - (* end BVSRem. *) + abstract theory BVSRem. + clone import BV. + + op bvsrem : bv -> bv -> bv. + + (* FIXME: PY check this please *) + op srem (i1 i2 : int) = + let s = if i1 < 0 then -1 else if i1 = 0 then 0 else 1 in + let r = s * (`|i1| %% `|i2|) in + if 2 ^ (size - 1) <= r then r - 2^(size) else r. + + axiom bvsremP (bv1 bv2 : bv) : + tosint (bvsrem bv1 bv2) = srem (tosint bv1) (tosint bv2). + end BVSRem. (* ------------------------------------------------------------------ *) abstract theory BVSHL. diff --git a/theories/distributions/#Dexcepted.ec# b/theories/distributions/#Dexcepted.ec# new file mode 100644 index 0000000000..688b7ca169 --- /dev/null +++ b/theories/distributions/#Dexcepted.ec# @@ -0,0 +1,622 @@ +(* -------------------------------------------------------------------- *) +require import AllCore Distr FSet StdRing. +(*---*) import RField StdOrder.RealOrder. + +pragma +implicits. + +(* -------------------------------------------------------------------- *) +op (\) (d : 'a distr) (P : 'a -> bool) : 'a distr = dscale (drestrict d (predC P)). + +lemma supp_dexcepted (x:'a) d P : + support (d \ P) x <=> (support d x /\ !P x). +proof. by rewrite supp_dscale supp_drestrict. qed. + +lemma dexcepted1E d P (x : 'a) : + mu1 (d \ P) x + = if P x + then 0%r + else (mu1 d x / (weight d - mu d (P))). +proof. +by rewrite dscale1E weight_drestrict drestrict1E mu_not /predC; case: (P x). +qed. + +lemma dexcepted1E_notin (d : 'a distr) P x: + !P x => mu1 (d \ P) x = (mu1 d x / (weight d - mu d (P))). +proof. by rewrite dexcepted1E => ->. qed. + +lemma dexcepted1E_in d P (x:'a): + P x => mu1 (d \ P) x = 0%r. +proof. by rewrite dexcepted1E => ->. qed. + +lemma dexceptedE d P (E : 'a -> bool) : + mu (d \ P) E + = mu d (predI E (predC P)) / (weight d - mu d P). +proof. by rewrite dscaleE weight_drestrict drestrictE predIC mu_not. qed. + +lemma weight_dexcepted (d:'a distr) P : + weight (d \ P) = b2r (weight d <> mu d P). +proof. +by rewrite weight_dscale weight_drestrict mu_not /#. +qed. + +lemma dexcepted_ll (d : 'a distr) P: + is_lossless d => mu d P < 1%r => + is_lossless (d \ P). +proof. +move=> d_ll P_neq_d. +by rewrite /is_lossless weight_dexcepted d_ll /#. +qed. + +lemma dexcepted_uni (d : 'a distr) P: + is_uniform d => is_uniform (d \ P). +proof. +move=> uni x y; rewrite !supp_dexcepted !dexcepted1E. +by move=> [? ->] [? ->] /=; congr; apply uni. +qed. + +(* -------------------------------------------------------------------- *) +lemma dexcepted_dscale (dt : 'a distr) X: dt \ X = (dscale dt) \ X. +proof. +apply eq_distr => a; rewrite !dexcepted1E !dscaleE; congr. +smt(mu_bounded invr0 mu_le_weight). +qed. + + +(* -------------------------------------------------------------------- *) +abstract theory TwoStepSampling. +type i, t. + +op dt: i -> t distr. + +module S = { + proc direct(x : i, X : i -> t -> bool) = { + var r; + + r <$ dt x \ X x; + return r; + } + + proc indirect(x : i, X : i -> t -> bool) = { + var r; + + r <$ dt x; + if (X x r) { + r <$ dt x \ X x; + } + return r; + } +}. + +(* -------------------------------------------------------------------- *) +lemma pr_direct &m x' X' P: + Pr[S.direct(x',X') @ &m: P res] = mu (dt x' \ X' x') P. +proof. +byphoare (: x = x' /\ X = X' ==> _)=> //=. +by proc; rnd P; auto. +qed. + +phoare phoare_direct x' X' P: + [ S.direct: x = x' /\ X = X' ==> P res ] = (mu (dt x' \ X' x') P). +proof. by bypr=> &m [] -> ->; exact/(@pr_direct &m x' X' P). qed. + +(* -------------------------------------------------------------------- *) +lemma pr_indirect &m x' X' P: + Pr[S.indirect(x',X') @ &m: P res] = weight (dt x') * mu (dt x' \ X' x') P. +proof. +byphoare (: x = x' /\ X = X' ==> _)=> //=. +case: (forall x, (x \in dt x' => !P x) \/ !(P x /\ !X' x' x)). ++ move=> P_nsub_supp; hoare. + + move=> &m' [#] <<*>; rewrite eq_sym dexceptedE mulf_eq0; right. + rewrite mulf_eq0; left; apply/mu0_false. + move=> x @/predI @/predC x_in_dt. + by case: (P_nsub_supp x)=> [/(_ x_in_dt) ->|]. + proc. seq 1: (r \in dt x /\ x = x' /\ X = X'); auto. + if; auto=> /> &m'. + + move=> _ _ r /supp_dexcepted [] r_in_dt. + by case: (P_nsub_supp r)=> [/(_ r_in_dt) ->|/negb_and /implybE /contra]. + move=> r_in_dt ; case: (P_nsub_supp r{m'})=> [/(_ r_in_dt) -> //|]. + by rewrite negb_and -implybE=> /contra. +rewrite negb_forall=> - [a]; rewrite /= negb_or=> /> + Pa; rewrite Pa /=. +move=> a_in_dt a_notin_X. +proc. alias 2 r0 = r. +phoare split (mu (dt x) (predI P (predC (X' x')))) + (mu (dt x) (X x) * mu (dt x \ X x) P) + : (P r0 /\ !X' x' r0). ++ move=> /= &m' [] ->> ->> {&m'}; rewrite dexceptedE. + rewrite -{1}(mulr1 (mu (dt x') (predI _ _))). + rewrite -(@divrr (weight (dt x') - mu (dt x') (X' x'))). + + rewrite -mu_not; apply/ltr0_neq0. + by rewrite witness_support; exists a; rewrite /predC a_in_dt a_notin_X. + rewrite mulrA mulrA mulrA -mulrDl; congr. + by rewrite mulrDr mulrC mulrN (mulrC (_ _ (X' x'))) subrK. ++ seq 2: (P r0 /\ !X' x' r0) + (mu (dt x') (predI P (predC (X' x')))) 1%r + _ 0%r + (r0 = r /\ x = x' /\ X = X')=> //=. + + by auto. + + by wp; rnd (predI P (predC (X' x'))); auto=> />. + + by rcondf 1. + by hoare; conseq (: _ ==> true)=> // /#. +seq 2: (!X' x' r0) + _ 0%r + (mu (dt x') (X' x')) (mu (dt x' \ X' x') P) + (r0 = r /\ x = x' /\ X = X')=> //=. ++ by auto. ++ by hoare; rcondf 1=> //; auto=> /#. ++ by wp; rnd. +by rcondt 1=> //; rnd P; skip=> /#. +qed. + +phoare phoare_indirect x' X' P: + [ S.indirect: x = x' /\ X = X' ==> P res ] + = (weight (dt x) * mu (dt x \ X x) P). +proof. by bypr=> &m [] -> ->; rewrite (@pr_indirect &m x' X' P). qed. + +(* -------------------------------------------------------------------- *) +lemma ll_pr_indirect &m x' X' P: + is_lossless (dt x') + => Pr[S.indirect(x',X') @ &m: P res] = mu (dt x' \ X' x') P. +proof. by move=> dt_ll; rewrite (@pr_indirect &m x' X' P) dt_ll. qed. + +phoare ll_phoare_indirect x' X' P: + [ S.indirect: x = x' /\ X = X' /\ is_lossless (dt x') ==> P res ] + = (mu (dt x \ X x) P). +proof. +by bypr=> &m [] -> [] -> dt_ll; rewrite (@ll_pr_indirect &m x' X' P). +qed. + +(* -------------------------------------------------------------------- *) +lemma indirect_direct &m x X P: + Pr[S.indirect(x,X) @ &m: P res] + = weight (dt x) * Pr[S.direct(x,X) @ &m: P res]. +proof. by rewrite (@pr_direct &m x X P) (@pr_indirect &m x X P). qed. + +lemma ll_direct_indirect &m x X P: + is_lossless (dt x) + => Pr[S.direct(x,X) @ &m: P res] = Pr[S.indirect(x,X) @ &m: P res]. +proof. by rewrite (@indirect_direct &m x X P)=> ->. qed. + +(* -------------------------------------------------------------------- *) +equiv ll_direct_indirect_eq: S.direct ~ S.indirect: + ={x, X} /\ is_lossless (dt x{1}) ==> ={res}. +proof. +bypr (res{1}) (res{2})=> //= &1 &2 a [#] <<*> <- <- dt_ll. +rewrite (@indirect_direct &2 x{1} X{1} (pred1 a)) dt_ll /=. +by byequiv (: ={arg} ==> ={res})=> //=; sim. +qed. + +end TwoStepSampling. + +(* -------------------------------------------------------------------- *) +abstract theory WhileSampling. +type input, t. + +op dt: input -> t distr. + +module SampleE = { + proc init () = { } + + proc sample(i : input, test) = { + var r; + + r <$ dt i \ test i; + return r; + } +}. + +module SampleI = { + proc init () = { } + + proc sample(i:input, test) = { + var r; + r <$ dt i; + if (test i r) { + r <$ dt i \ test i; + } + return r; + } +}. + +module SampleWi = { + proc init () = { } + + proc sample(i : input, r : t, test) = { + while (test i r) { + r <$ dt i; + } + return r; + } +}. + +module SampleW = { + proc init () = { } + + proc sample(i : input, test) = { + var r; + r <$ dt i; + r <@ SampleWi.sample(i, r, test); + return r; + } +}. + +(* -------------------------------------------------------------------- *) +lemma pr_sampleE &m x X P : + Pr[SampleE.sample(x, X) @ &m : P res] = mu (dt x \ X x) P. +proof. +by byphoare (_ : i = x /\ test = X ==> P res) => //; proc; rnd P; skip. +qed. + +lemma phoare_sampleE P : + phoare [SampleE.sample : true ==> P res ] = (mu (dt i \ test i) P). +proof. by bypr=> &m _; apply (@pr_sampleE &m i{m} test{m} P). qed. + +(* -------------------------------------------------------------------- *) +section. +local clone TwoStepSampling as TS with + type i <- input, + type t <- t, + op dt <- dt. + +lemma pr_sampleI &m x' X' P : + is_lossless (dt x') => + Pr[SampleI.sample(x',X') @ &m : P res] = mu (dt x' \ X' x') P. +proof. +move=> d_ll; rewrite -(@TS.ll_pr_indirect &m x' X' P) //. +byequiv (: ={arg} ==> ={res})=> //=. +proc; seq 1 1: (={r} /\ i{1} = x{2} /\ test{1} = X{2}). ++ by auto. +by if=> //=; auto. +qed. +end section. + +phoare phoare_sampleI P : + [ SampleI.sample : is_lossless (dt i) ==> P res ] = (mu (dt i \ test i) P). +proof. by bypr=> &m; apply (@pr_sampleI &m i{m} test{m} P). qed. + +(* -------------------------------------------------------------------- *) +lemma pr_sampleWi &m x y X P : + is_lossless (dt x) => + Pr[SampleWi.sample(x,y,X) @ &m : P res] + = if X x y then mu (dt x \ X x) P else b2r (P y). +proof. +move=> dt_ll. +case: (X x y)=> [y_in_Xx|y_notin_Xx]; last first. ++ case: (P y)=> [y_in_P|y_notin_P]. + + byphoare (: i = x /\ r = y /\ test = X ==> P res)=> //. + by proc; rcondf 1; auto. + byphoare (: i = x /\ r = y /\ test = X ==> P res)=> //. + by hoare; proc; rcondf 1; auto. +byphoare (: i = x /\ r = y /\ test = X ==> P res)=> //; proc=> /=. +case @[ambient]: (mu (dt x) (X x) = weight (dt x))=> Hpt. ++ hoare. + + by move=> />; rewrite dexceptedE Hpt. + while (X x r /\ i = x /\ test = X)=> //=. + auto=> &m' [#] _ -> -> _ r; move: (mu_in_weight (X x) (dt x) r). + by rewrite Hpt. +conseq (: _: =(if X x r then mu (dt x \ X x) P else b2r (P r))). ++ by move=> />; rewrite y_in_Xx. +conseq (_ : i = x /\ test = X ==> _) => //. +while (i = x /\ test = X) (if test x r then 1 else 0) 1 (mu (dt x) (predC (X x)))=> //=. ++ smt(). ++ smt(). ++ move=> ih. alias 2 r0 = r. +(* weakmem ih (r0:t) => {ih} ih. *) + (** TRANSITIVITY FOR PHOARE!! **) + phoare split (mu (dt x) (predI P (predC (X x)))) + (mu (dt x) (X x) * mu (dt x \ X x) P) + : (P r0 /\ !X x r0). + + move=> &m' [#] -> -> -> /=; rewrite dexceptedE. + rewrite -{1}(mulr1 (mu (dt x) (predI _ _))). + rewrite -(@divrr (weight (dt x) - mu (dt x) (X x))). + + smt(). + rewrite mulrA mulrA -mulrDl; congr. + by rewrite mulrDr mulrC mulrN (mulrC (_ _ (X x))) subrK dt_ll. + + seq 2: (P r0 /\ !X x r0) + (mu (dt x) (predI P (predC (X x)))) 1%r + _ 0%r + (r0 = r /\ i = x /\ test = X)=> //=. + + by auto. + + by wp; rnd (predI P (predC (X x))); auto=> />. + + weakmem ih (r0:t) => ih2. + + by conseq ih2=> />. + by hoare; conseq (: _ ==> true)=> // /#. + seq 2: (!X x r0) + _ 0%r + (mu (dt x) (X x)) (mu (dt x \ X x) P) + (r0 = r /\ i = x /\ test = X)=> //=. + + by auto. + + case: (P r0); last by conseq ih=> />. + by hoare; conseq (: true)=> />. + + by wp; rnd. + by conseq ih=> &m' />; rewrite dexceptedE. ++ by auto. +split. ++ by move=> &m' />; rewrite mu_not #smt:(mu_bounded). +by move=> z; conseq (: _ ==> !X x r)=> />; rnd; skip. +qed. + +lemma phoare_sampleWi P : + phoare [SampleWi.sample : is_lossless (dt i) ==> P res] + = (if test i r then mu (dt i \ test i) P else b2r (P r)). +proof. by bypr=> &m'; exact/(@pr_sampleWi &m' i{m'} r{m'} test{m'} P). qed. + +(* -------------------------------------------------------------------- *) +lemma pr_sampleW &m x X P : + is_lossless (dt x) => + Pr[SampleW.sample(x, X) @ &m : P res] = mu (dt x \ X x) P. +proof. +move=> dt_ll. +byphoare (: i = x /\ test = X ==> P res)=> //; proc=> /=. +case @[ambient]: (mu (dt x) (X x) = weight (dt x))=> Hpt. ++ conseq (: : = 0%r)=> //. + + by move=> &m' _; rewrite dexceptedE Hpt. + seq 1 : true _ 0%r 0%r _ (i = x /\ test = X /\ X x r)=> //. + + auto=> &m' [#] -> -> r; move: (mu_in_weight (X x) (dt x) r). + by rewrite Hpt. + call (: is_lossless (dt x) /\ i = x /\ test = X /\ X x r ==> P res)=> //. + by conseq (phoare_sampleWi P)=> // &m' [#] _ -> -> ->; rewrite dexceptedE Hpt. +alias 2 r0 = r. +(** TRANSITIVITY FOR PHOARE!! **) +phoare split (mu (dt x) (predI P (predC (X x)))) + (mu (dt x) (X x) * mu (dt x \ X x) P) + : (P r0 /\ !X x r0). ++ move=> &m' _ /=; rewrite dexceptedE. + rewrite -{1}(mulr1 (mu (dt x) (predI _ _))). + rewrite -(@divrr (weight (dt x) - mu (dt x) (X x))). + + smt(). + rewrite mulrA mulrA -mulrDl; congr. + by rewrite mulrDr mulrC mulrN (mulrC (_ _ (X x))) subrK dt_ll. (* dt_ll *) ++ seq 2: (P r0 /\ !X x r0) + (mu (dt x) (predI P (predC (X x)))) 1%r + _ 0%r + (r0 = r /\ i = x /\ test = X)=> //=. + + by auto. + + by wp; rnd (predI P (predC (X x))); auto=> />. + + by inline *; rcondf 4; auto. + by hoare; conseq (: true)=> />. +seq 2: (!X x r0) + _ 0%r + (mu (dt x) (X x)) (mu (dt x \ X x) P) + (r0 = r /\ i = x /\ test = X)=> //=. ++ by auto. ++ by hoare; inline *; rcondf 4; auto=> &m' /#. ++ by wp; rnd. +call (: is_lossless (dt x) /\ i = x /\ test = X /\ X x r ==> P res)=> //. ++ by conseq (phoare_sampleWi P)=> // &m' />. +by skip=> &m' />. +qed. + +phoare phoare_sampleW P : + [ SampleW.sample: is_lossless (dt i) ==> P res ] = (mu (dt i \ test i) P). +proof. by bypr=> &m; exact/(@pr_sampleW &m i{m} test{m} P). qed. + +(* -------------------------------------------------------------------- *) +equiv sampleE_sampleI : SampleE.sample ~ SampleI.sample : + ={i, test} /\ is_lossless (dt i{1}) ==> ={res}. +proof. +bypr (res{1}) (res{2})=> /> &m1 &m2 a <- <- d_ll. +rewrite (@pr_sampleE &m1 i{m1} test{m1} (pred1 a)). +by rewrite (@pr_sampleI &m2 i{m1} test{m1} (pred1 a)). +qed. + +lemma sampleE_sampleI_pr &m x X P : + is_lossless (dt x) + => Pr[SampleE.sample(x,X) @ &m: P res] = Pr[SampleI.sample(x,X) @ &m: P res]. +proof. by move=> dt_ll; byequiv sampleE_sampleI. qed. + +equiv sampleE_sampleWi: SampleE.sample ~ SampleWi.sample : + ={i,test} /\ is_lossless (dt i{1}) /\ test{2} i{2} r{2} ==> ={res}. +proof. +bypr (res{1}) (res{2})=> /> &m1 &m2 a <- <- d_ll Htr. +rewrite (@pr_sampleE &m1 i{m1} test{m1} (pred1 a)). +by rewrite (@pr_sampleWi &m2 i{m1} r{m2} test{m1} (pred1 a)) // Htr. +qed. + +lemma sampleE_sampleWi_pr &m x y X P: + is_lossless (dt x) + => X x y + => Pr[SampleE.sample(x,X) @ &m: P res] = Pr[SampleWi.sample(x,y,X) @ &m: P res]. +proof. by move=> dt_ll y_in_Xx; byequiv sampleE_sampleWi. qed. + +equiv sampleE_sampleW : SampleE.sample ~ SampleW.sample : + ={i,test} /\ is_lossless (dt i{1}) ==> ={res}. +proof. +bypr (res{1}) (res{2})=> /> &m1 &m2 a <- <- d_ll. +rewrite (@pr_sampleE &m1 i{m1} test{m1} (pred1 a)). +by rewrite (@pr_sampleW &m2 i{m1} test{m1} (pred1 a)). +qed. + +lemma sampleE_sampleW_pr &m x X P: + is_lossless (dt x) + => Pr[SampleE.sample(x,X) @ &m: P res] = Pr[SampleW.sample(x,X) @ &m: P res]. +proof. by move=> dt_ll; byequiv sampleE_sampleW. qed. +end WhileSampling. + +(* -------------------------------------------------------------------- *) +abstract theory WhileSamplingFixedTest. +type input, t. + +op dt: input -> t distr. +op test: input -> t -> bool. + +module SampleE = { + proc init () = { } + + proc sample(i : input) = { + var r; + + r <$ dt i \ test i; + return r; + } +}. + +module SampleI = { + proc init () = { } + + proc sample(i:input) = { + var r; + r <$ dt i; + if (test i r) { + r <$ dt i \ test i; + } + return r; + } +}. + +module SampleWi = { + proc init () = { } + + proc sample(i : input, r : t) = { + while (test i r) { + r <$ dt i; + } + return r; + } +}. + +module SampleW = { + proc init () = { } + + proc sample(i : input) = { + var r; + r <$ dt i; + r <@ SampleWi.sample(i, r); + return r; + } +}. + +(* -------------------------------------------------------------------- *) +section. +local clone WhileSampling as WS with + type input <- input, + type t <- t, + op dt <- dt. + +(* -------------------------------------------------------------------- *) +local lemma sampleE_fixed &m x P : + Pr[SampleE.sample(x) @ &m : P res] + = Pr[WS.SampleE.sample(x,test) @ &m : P res]. +proof. +byequiv (: ={i} /\ test{2} = test ==> ={res})=> //=. +by proc; auto. +qed. + +lemma pr_sampleE &m x P : + Pr[SampleE.sample(x) @ &m : P res] = mu (dt x \ test x) P. +proof. by rewrite (@sampleE_fixed &m x P) (@WS.pr_sampleE &m x test P). qed. + +phoare phoare_sampleE P : + [ SampleE.sample : true ==> P res ] = (mu (dt i \ test i) P). +proof. by bypr=> &m _; exact/(@pr_sampleE &m i{m} P). qed. + +(* -------------------------------------------------------------------- *) +local lemma sampleI_fixed &m x P : + Pr[SampleI.sample(x) @ &m : P res] + = Pr[WS.SampleI.sample(x,test) @ &m : P res]. +proof. +byequiv (: ={i} /\ test{2} = test ==> ={res})=> //=. +proc=> /=. seq 1 1: (={i, r} /\ test{2} = test). ++ by auto. +by if; auto. +qed. + +lemma pr_sampleI &m x P : + is_lossless (dt x) + => Pr[SampleI.sample(x) @ &m : P res] = mu (dt x \ test x) P. +proof. +move=> dt_ll. +by rewrite (@sampleI_fixed &m x P) (@WS.pr_sampleI &m x test P dt_ll). +qed. + +phoare phoare_sampleI P : + [ SampleI.sample: is_lossless (dt i) ==> P res ] = (mu (dt i \ test i) P). +proof. bypr=> &m; exact/(@pr_sampleI &m i{m} P). qed. + +(* -------------------------------------------------------------------- *) +local lemma sampleWi_fixed &m x y P : + Pr[SampleWi.sample(x,y) @ &m : P res] + = Pr[WS.SampleWi.sample(x,y,test) @ &m : P res]. +proof. +byequiv (: ={i,r} /\ test{2} = test ==> ={res})=> //=. +by proc=> /=; while (={i,r} /\ test{2} = test)=> //=; auto. +qed. + +lemma pr_sampleWi &m x y P : + is_lossless (dt x) + => Pr[SampleWi.sample(x,y) @ &m : P res] + = if test x y then mu (dt x \ test x) P else b2r (P y). +proof. +move=> dt_ll. +rewrite (@sampleWi_fixed &m x y P). +by rewrite (@WS.pr_sampleWi &m x y test P). +qed. + +phoare phoare_sampleWi P : + [ SampleWi.sample : is_lossless (dt i) ==> P res ] + = (if test i r then mu (dt i \ test i) P else b2r (P r)). +proof. by bypr=> &m; exact/(@pr_sampleWi &m i{m} r{m} P). qed. + +(* -------------------------------------------------------------------- *) +local lemma sampleW_fixed &m x P : + Pr[SampleW.sample(x) @ &m : P res] + = Pr[WS.SampleW.sample(x,test) @ &m : P res]. +proof. +byequiv (: ={i} /\ test{2} = test ==> ={res})=> //=. +proc; inline *; wp. +by while (={i0,r0} /\ test0{2} = test)=> //=; auto. +qed. + +lemma pr_sampleW &m x P : + is_lossless (dt x) + => Pr[SampleW.sample(x) @ &m : P res] = mu (dt x \ test x) P. +proof. +move=> dt_ll. +rewrite (@sampleW_fixed &m x P). +by rewrite (@WS.pr_sampleW &m x test P). +qed. + +phoare phoare_sampleW P : + [ SampleW.sample: is_lossless (dt i) ==> P res ] = (mu (dt i \ test i) P). +proof. by bypr=> &m; exact/(@pr_sampleW &m i{m} P). qed. + +(* -------------------------------------------------------------------- *) +equiv sampleE_sampleI : SampleE.sample ~ SampleI.sample : + ={i} /\ is_lossless (dt i{1}) ==> ={res}. +proof. +bypr (res{1}) (res{2}) => /> &m1 &m2 a dt_ll. +by rewrite (@pr_sampleE &m1 i{m2} (pred1 a)) (@pr_sampleI &m2 i{m2} (pred1 a)). +qed. + +lemma sampleE_sampleI_pr &m x P: + is_lossless (dt x) + => Pr[SampleE.sample(x) @ &m: P res] = Pr[SampleI.sample(x) @ &m: P res]. +proof. by move=> dt_ll; byequiv sampleE_sampleI. qed. + +equiv sampleE_sampleWi : SampleE.sample ~ SampleWi.sample : + ={i} /\ is_lossless (dt i{1}) /\ test i{2} r{2} ==> ={res}. +proof. +bypr (res{1}) (res{2})=> /> &m1 &m2 a dt_ll Htr. +rewrite (@pr_sampleE &m1 i{m2} (pred1 a)). +by rewrite (@pr_sampleWi &m2 i{m2} r{m2} (pred1 a)) // Htr. +qed. + +lemma sampleE_sampleWi_pr &m x y P: + is_lossless (dt x) + => test x y + => Pr[SampleE.sample(x) @ &m: P res] = Pr[SampleWi.sample(x,y) @ &m: P res]. +proof. by move=> dt_ll test_i_r; byequiv sampleE_sampleWi. qed. + +equiv sampleE_sampleW : SampleE.sample ~ SampleW.sample : + ={i} /\ is_lossless (dt i{1}) ==> ={res}. +proof. +bypr (res{1}) (res{2})=> /> &m1 &m2 a dt_ll. +by rewrite (@pr_sampleE &m1 i{m2} (pred1 a)) (@pr_sampleW &m2 i{m2} (pred1 a)). +qed. + +lemma sampleE_sampleW_pr &m x P: + is_lossless (dt x) + => Pr[SampleE.sample(x) @ &m: P res] = Pr[SampleW.sample(x) @ &m: P res]. +proof. by move=> dt_ll; byequiv sampleE_sampleW. qed. +end section. + +end WhileSamplingFixedTest. diff --git a/theories/distributions/DFSet.ec b/theories/distributions/DFSet.ec new file mode 100644 index 0000000000..8fbe6dcf9c --- /dev/null +++ b/theories/distributions/DFSet.ec @@ -0,0 +1,456 @@ +(* -------------------------------------------------------------------- *) +require import AllCore List FSet Distr DProd DList StdOrder StdBigop. +(*---*) import Bigreal Bigreal.BRM MUnit. + +op [opaque] dfset (d : 'a distr) (n : int): 'a fset distr = + dcond (dmap (dlist d n) oflist) (fun fs => card fs = n). + +lemma dfset_def (d : 'a distr) n: dfset d n = + dcond (dmap (dlist d n) oflist) (fun fs => card fs = n) by rewrite/dfset. + +(* FIXME: move *) +lemma dscale_of_ll ['a] (d: 'a distr) : + is_lossless d => + dscale d = d. +proof. +rewrite /dscale /is_lossless => LL; rewrite LL; apply dscalar1. +qed. + +lemma dscale_dunit ['a] (x: 'a) : + dscale (dunit x) = dunit x. +apply dscale_of_ll; apply dunit_ll. +qed. + +lemma drestrict_dunit ['a] (x: 'a) (p: 'a -> bool) : + drestrict (dunit x) p = + if p x then dunit x else dnull. +admitted. + +search dnull. + +lemma dscale_dnull ['a] : + dscale dnull<:'a> = dnull. +proof. by rewrite /dscale weight_dnull invr0; apply dscalar0r. qed. + +(* FIXME: move *) +lemma dcond_dunit ['a] (x: 'a) (p: 'a -> bool) : + dcond (dunit x) p = + if p x then dunit x else dnull. +proof. + rewrite /dcond drestrict_dunit; + case (p x) => P; 1: apply dscale_dunit; 1: apply dscale_dnull. +qed. + +lemma dfset0 (d : 'a distr) n: n <= 0 => dfset d n = dunit (fset0). +proof. +move => ge0_n; rewrite dfset_def /fset0 dlist0; 1:apply ge0_n; 1:rewrite dmap_dunit dcond_dunit. cbv. +search dcond. +qed. + +print FSet. + +lemma dfset1 (d : 'a distr) : dfset d 1 = dmap d fset1. +proof. +by rewrite dfset_def /fset1 dlist1 dmap_comp //. +qed. + +(* +lemma dfsetS (d : 'a distr) n: + 0 <= n => + dfset d (n + 1) + = dapply (fun (xy : 'a * 'a list) => xy.`1 :: xy.`2) (d `*` (dlist d n)). +proof. +elim n=> [|n le0_n ih]. ++ by rewrite !dlist_def /= -foldpos // fold0. +by rewrite dlist_def -foldpos 1:/# -dlist_def /=. +qed. +*) + +print djoin. + +print FSet. + +print fold. +print djoin. +print nseq. + +op djoin_fset ['a] (ds: 'a Distr.distr fset) : 'a fset Distr.distr = + + + +lemma dfset_djoin (d : 'a distr) n: 0 <= n => dlist d n = djoin (nseq n d). +proof. +elim: n => [|n Hn IHn]; first by rewrite dlist0 // /nseq iter0 // djoin_nil. +by rewrite dlistS // nseqS // djoin_cons IHn. +qed. + +lemma dapply_dmap ['a 'b] (d:'a distr) (F:'a -> 'b): dapply F d = dmap d F by done. + +lemma dlist_add (d:'a distr) n1 n2: + 0 <= n1 => 0 <= n2 => + dlist d (n1 + n2) = + dmap (dlist d n1 `*` dlist d n2) (fun (p:'a list * 'a list) => p.`1 ++ p.`2). +proof. +elim: n1 => [hn2|n1 hn1 IHn1 hn2]. + by rewrite (dlist0 d 0) //= dmap_dprodE dlet_unit /= dmap_id_eq_in. +rewrite addzAC !dlistS 1:/# //= IHn1 //. +rewrite !dmap_dprodE /= dlet_dlet; apply eq_dlet => //= x. +rewrite dmap_dlet dlet_dmap; apply eq_dlet => //= x1. +rewrite /dmap dlet_dlet /(\o); apply eq_dlet => //= x2. +by rewrite dlet_dunit dmap_dunit. +qed. + +lemma dlistSr (d : 'a distr) (n : int) : 0 <= n => + dlist d (n + 1) = dapply (fun (xy : 'a list * 'a) => rcons xy.`1 xy.`2) (dlist d n `*` d). +proof. +move => hn; rewrite dlist_add // dlist1 /= !dmap_dprodE. +apply eq_dlet => // xs; rewrite dmap_comp. +by apply eq_dmap => x //=; rewrite /(\o) cats1. +qed. + +lemma dlist01E (d : 'a distr) n x: + n <= 0 => mu1 (dlist d n) x = b2r (x = []). +proof. by move=> /(dlist0 d) ->;rewrite dunit1E (eq_sym x). qed. + +lemma dlistS1E (d : 'a distr) x xs: + mu1 (dlist d (size (x::xs))) (x::xs) = + mu1 d x * mu1 (dlist d (size xs)) xs. +proof. +rewrite /= addzC dlistS 1:size_ge0 /= dmap1E -dprod1E &(mu_eq) => z /#. +qed. + +lemma dlist0_ll (d : 'a distr) n: + n <= 0 => + is_lossless (dlist d n). +proof. by move=> /(dlist0 d) ->;apply dunit_ll. qed. + +lemma dlist_ll (d : 'a distr) n: + is_lossless d => + is_lossless (dlist d n). +proof. +move=> d_ll; case (0 <= n); first last. ++ move=> lt0_n; rewrite dlist0 1:/#;apply dunit_ll. +elim n=> [|n le0_n ih];first by rewrite dlist0 //;apply dunit_ll. +by rewrite dlistS //;apply/dmap_ll/dprod_ll. +qed. + +hint exact random : dlist_ll. + +lemma supp_dlist0 (d : 'a distr) n xs: + n <= 0 => + xs \in dlist d n <=> xs = []. +proof. by move=> le0; rewrite dlist0 // supp_dunit. qed. + +lemma supp_dlist (d : 'a distr) n xs: + 0 <= n => + xs \in dlist d n <=> size xs = n /\ all (support d) xs. +proof. +move=> le0_n;elim: n le0_n xs => [xs | i le0 Hrec xs]. ++ by smt (supp_dlist0 size_eq0). +rewrite dlistS // supp_dmap /=;split => [[p]|]. ++ rewrite supp_dprod => [# Hp /Hrec [<- Ha] ->] /=. + by rewrite Hp Ha addzC. +case xs => //= [/# | x xs [# Hs Hin Ha]];exists (x,xs);smt (supp_dprod). +qed. + +lemma supp_dlist_size (d : 'a distr) n xs: + 0 <= n => xs \in dlist d n => size xs = n. +proof. by move=> ge0_n; case/(supp_dlist d n xs ge0_n). qed. + +lemma dlistE x0 (d : 'a distr) (p : int -> 'a -> bool) n : + mu (dlist d n) (fun xs : 'a list => + forall i, (0 <= i) && (i < n) => (p i (nth x0 xs i))) + = bigi predT (fun i => mu d (p i)) 0 n. +proof. +elim/natind : n p => [n n_le0|n n_ge0 IHn] p. +- rewrite dlist0 // dunitE range_geq //= big_nil; smt(). +rewrite rangeSr // -cats1 big_cat big_seq1. +rewrite dlistSr //= dmapE. +pose P1 xs := forall i, 0 <= i && i < n => p i (nth x0 xs i). +pose P2 x := p n x. +pose P (a : 'a list * 'a) := P1 a.`1 /\ P2 a.`2. +rewrite (mu_eq_support _ _ P); 2: by rewrite dprodE IHn. +case => xs x /=. rewrite supp_dprod /= supp_dlist // => -[[? ?] ?]. +rewrite /(\o) /P /P1 /P2 /= eq_iff; subst n; split; 2: smt(nth_rcons). +move => H; split => [i|];[have := (H i)|have := H (size xs)]; smt(nth_rcons). +qed. + +lemma dlist1E (d : 'a distr) n xs: + 0 <= n => + mu1 (dlist d n) xs + = if n = size xs + then big predT (fun x => mu1 d x) xs + else 0%r. +proof. +move=> le0_n; case (n = size xs)=> [->|]. ++ elim xs=> [|x xs ih];first by rewrite dlist01E. + by rewrite dlistS1E /= big_cons ih. +by move=> ?; rewrite -supportPn supp_dlist /#. +qed. + +lemma dlist0E n (d : 'a distr) P : n <= 0 => mu (dlist d n) P = b2r (P []). +proof. by move=> le0;rewrite dlist0 // dunitE. qed. + +lemma dlistSE (a:'a) (d: 'a distr) n P1 P2 : + 0 <= n => + mu (dlist d (n+1)) (fun (xs:'a list) => P1 (head a xs) /\ P2 (behead xs)) = + mu d P1 * mu (dlist d n) P2. +proof. by move=> Hle;rewrite dlistS // /= dmapE -dprodE. qed. + +lemma dlist_perm_eq (d : 'a distr) s1 s2: + perm_eq s1 s2 => + mu1 (dlist d (size s1)) s1 = mu1 (dlist d (size s2)) s2. +proof. +by rewrite !dlist1E ?size_ge0 /=;apply eq_big_perm. +qed. + +lemma weight_dlist0 n (d:'a distr): + n <= 0 => weight (dlist d n) = 1%r. +proof. by move=> le0;rewrite dlist0E. qed. + +lemma weight_dlistS n (d:'a distr): + 0 <= n => weight (dlist d (n + 1)) = weight d * weight (dlist d n). +proof. by move=> ge0;rewrite -(dlistSE witness) //. qed. + +lemma weight_dlist (d : 'a distr) n : + 0 <= n => weight (dlist d n) = (weight d)^n. +proof. +elim: n => [|n ? IHn]; 1: by rewrite weight_dlist0 // RField.expr0. +by rewrite weight_dlistS // IHn RField.exprS. +qed. + + +lemma dlist_fu (d: 'a distr) (xs:'a list): + (forall x, x \in xs => x \in d) => + xs \in dlist d (size xs). +proof. +move=> fu; rewrite /support dlist1E 1:size_ge0 /=. +by apply Bigreal.prodr_gt0_seq => /= a Hin _;apply fu. +qed. + +lemma dlist_uni (d:'a distr) n : + is_uniform d => is_uniform (dlist d n). +proof. +case (n < 0)=> [Hlt0 Hu xs ys| /lezNgt Hge0 Hu xs ys]. ++ rewrite !supp_dlist0 ?ltzW //. +rewrite !supp_dlist // => -[eqxs Hxs] [eqys Hys]. +rewrite !dlist1E // eqxs eqys /=;move: eqys;rewrite -eqxs => {eqxs}. +elim: xs ys Hxs Hys => [ | x xs Hrec] [ | y ys] //=; 1,2:smt (size_ge0). +rewrite !big_consT. +move=> /= /> x_in_d all_in_d_xs y_in_d all_in_d_ys /addzI eq_size. +rewrite (Hrec ys) //. +by congr=> //; exact: Hu. +qed. + +lemma dlist_dmap ['a 'b] (d : 'a distr) (f : 'a -> 'b) n : + dlist (dmap d f) n = dmap (dlist d n) (map f). +proof. +elim/natind: n => [n le0_n| n ge0_n ih]. +- by rewrite !dlist0 // dmap_dunit. +- by rewrite !dlistS //= ih -dmap_dprod_comp dmap_comp. +qed. + +lemma dlist_rev (d:'a distr) n s: + mu1 (dlist d n) (rev s) = mu1 (dlist d n) s. +proof. +case (n <= 0) => [?|?]. ++ rewrite !dlist0E // /pred1 /= -{1}rev_nil. + by congr; rewrite eq_iff; split=> />; exact: rev_inj. +case (size s = n) => [<-|?]; 2: smt(dlist1E supp_dlist_size size_rev). +by rewrite -{1}size_rev &(dlist_perm_eq) perm_eq_sym perm_eq_rev. +qed. + +lemma dlist_dlist ['a] (d : 'a distr) (m n : int) : + 0 <= m => 0 <= n => + dmap (dlist (dlist d m) n) flatten = dlist d (m * n). +proof. +move=> ge0_m; elim: n => /= [|n ge0_n ih]. +- by rewrite !dlist0 // dmap_dunit. +rewrite mulrDr /= [dlist d (m * n + m)]dlist_add //. +- by apply: IntOrder.mulr_ge0. +rewrite dlistSr //= dmap_comp !dmap_dprodE /=. +rewrite -ih dlet_dmap /= &(eq_dlet) // => xss /=. +by rewrite &(eq_dmap) /(\o) /= => xs; rewrite flatten_rcons. +qed. + +lemma dlist_insert ['a] (x0 : 'a) (i n : int) (d : 'a distr) : + 0 <= n => 0 <= i <= n => dlist d (n+1) = + dmap (d `*` dlist d n) (fun x_xs : 'a * 'a list => insert x_xs.`1 x_xs.`2 i). +proof. +move=> ge0_n [ge0_i lti]; apply/eq_sym. +pose f (x_xs : _ * _) := insert x_xs.`1 x_xs.`2 i. +pose g (xs : 'a list) := (nth x0 xs i, take i xs ++ drop (i+1) xs). +have ge0_Sn: 0 <= n + 1 by smt(). apply: (dmap_bij _ _ f g). +- case=> [x xs] /supp_dprod[/=] x_in_d. + case/(supp_dlist _ _ _ ge0_n)=> sz_xs /allP xs_in_d. + move=> @/f /=; apply/supp_dlist; first smt(). + rewrite size_insert ?sz_xs //=; apply/allP. + by move=> y /mem_insert[->>//|/xs_in_d]. +- move=> xs /(supp_dlist _ _ _ ge0_Sn)[sz_xs /allP xs_in_d] @/g. + rewrite dprod1E !dlist1E ~-1://# sz_xs /=. + rewrite size_cat size_take // size_drop 1:/#. + rewrite iftrue 1:/# -(BRM.big_consT (mu1 d)) &(BRM.eq_big_perm). + by rewrite -cat_cons perm_eq_sym &(perm_eq_nth_take_drop) //#. +- case=> x xs /supp_dprod[/=] _ /(supp_dlist _ _ _ ge0_n)[sz_xs _]. + rewrite /g /f /= nth_insert ?sz_xs //= take_insert_le 1:/#. + by rewrite drop_insert_gt 1:/# /= cat_take_drop. +- move=> xs /(supp_dlist _ _ _ ge0_Sn)[/=] sz_xs _ @/f @/g /=. + have sz_take: size (take i xs) = i by rewrite size_take //#. + by apply/insert_nth_take_drop => //#. +qed. + +(* 0 <= n could be removed, but applying the lemma is pointless in that case *) +lemma dlist_set2E x0 (d : 'a distr) (p : 'a -> bool) n (I J : int fset) : + is_lossless d => 0 <= n => + (forall i, i \in I => 0 <= i && i < n) => + (forall j, j \in J => 0 <= j && j < n) => + (forall k, !(k \in I /\ k \in J)) => + mu (dlist d n) + (fun xs => (forall i, i \in I => p (nth x0 xs i)) /\ + (forall j, j \in J => !p (nth x0 xs j))) + = (mu d p)^(card I) * (mu d (predC p))^(card J). +proof. +move => d_ll n_ge0 I_range J_range disjIJ. +pose q i x := (i \in I => p x) /\ (i \in J => !p x). +rewrite (mu_eq_support _ _ + (fun xs => forall i, (0 <= i) && (i < n) => q i (nth x0 xs i))); 1: smt(supp_dlist). +rewrite dlistE (bigEM (mem (I `|` J))). +rewrite (big1 (predC (mem (I `|` J)))) ?mulr1. + move => i; rewrite /predC in_fsetU negb_or /= /q => -[iNI iNJ]. + rewrite (mu_eq _ _ predT) 1:/# //. +rewrite -big_filter (eq_big_perm _ _ _ (elems I ++ elems J)) ?big_cat. +- apply uniq_perm_eq => [| |x]. + + by rewrite filter_uniq range_uniq. + + rewrite cat_uniq !uniq_elems => />; apply/hasPn; smt(). + + by rewrite mem_filter mem_range mem_cat -!memE in_fsetU /#. +rewrite big_seq_cond (eq_bigr _ _ (fun _ => mu d p)) -?big_seq_cond. + move => i; rewrite /= /q -memE => -[iI _]; apply mu_eq => /#. +rewrite mulr_const big_seq_cond (eq_bigr _ _ (fun _ => mu d (predC p))) -?big_seq_cond. + move => i; rewrite /= /q -memE => -[iI _]; apply mu_eq => /#. +by rewrite mulr_const /card. +qed. + +lemma dlist_setE x0 (d : 'a distr) (p : 'a -> bool) n (I : int fset) : + is_lossless d => 0 <= n => (forall i, i \in I => 0 <= i && i < n) => + mu (dlist d n) (fun xs => forall i, i \in I => p (nth x0 xs i)) = (mu d p)^(card I). +proof. +move => d_ll n_ge0 hI. +have := dlist_set2E x0 d p n I fset0 d_ll n_ge0 hI _ _; 1,2 : smt(in_fset0). +rewrite fcards0 RField.expr0 RField.mulr1 => <-. +apply: mu_eq_support => xs; rewrite supp_dlist //= => -[? ?]; smt(in_fset0). +qed. + + +abstract theory Program. + type t. + op d: t distr. + + module Sample = { + proc sample(n:int): t list = { + var r; + + r <$ dlist d n; + return r; + } + }. + + module SampleCons = { + proc sample(n:int): t list = { + var r, rs; + + rs <$ dlist d (n - 1); + r <$ d; + return r::rs; + } + }. + + module Loop = { + proc sample(n:int): t list = { + var i, r, l; + + i <- 0; + l <- []; + while (i < n) { + r <$ d; + l <- r :: l; + i <- i + 1; + } + return l; + } + }. + + module LoopSnoc = { + proc sample(n:int): t list = { + var i, r, l; + + i <- 0; + l <- []; + while (i < n) { + r <$ d; + l <- l ++ [r]; + i <- i + 1; + } + return l; + } + }. + + lemma pr_Sample _n &m xs: Pr[Sample.sample(_n) @ &m: res = xs] = mu (dlist d _n) (pred1 xs). + proof. by byphoare (_: n = _n ==> res = xs)=> //=; proc; rnd. qed. + + equiv Sample_SampleCons_eq: Sample.sample ~ SampleCons.sample: 0 < n{1} /\ ={n} ==> ={res}. + proof. + bypr (res{1}) (res{2})=> //= &1 &2 xs [lt0_n] <-. + rewrite (pr_Sample n{1} &1 xs); case (size xs = n{1})=> [<<-|]. + case xs lt0_n=> [|x xs lt0_n]; 1: smt(). + rewrite dlistS1E. + byphoare (_: n = size xs + 1 ==> x::xs = res)=> //=; 2: by rewrite addrC. + proc; seq 1: (rs = xs) (mu (dlist d (size xs)) (pred1 xs)) (mu d (pred1 x)) _ 0%r => //. + by rnd (pred1 xs); skip; smt(). + by rnd (pred1 x); skip; smt(). + by hoare; auto; smt(). + smt(). + move=> len_xs; rewrite dlist1E 1:/# ifF 1:/#. + byphoare (_: n = n{1} ==> xs = res)=> //=; hoare. + proc; auto=> />; smt(supp_dlist_size). + qed. + + equiv Sample_Loop_eq: Sample.sample ~ Loop.sample: ={n} ==> ={res}. + proof. + proc*; exists* n{1}; elim* => _n. + move: (eq_refl _n); case (_n <= 0)=> //= h. + + inline *;rcondf{2} 4;auto;smt (supp_dlist0 weight_dlist0). + have {h} h: 0 <= _n by smt (). + call (_: _n = n{1} /\ ={n} ==> ={res})=> //=. + elim _n h=> //= [|_n le0_n ih]. + proc; rcondf{2} 3; auto=> />. smt(supp_dlist0 weight_dlist0). + case (_n = 0)=> [-> | h]. + proc; rcondt{2} 3; 1:(by auto); rcondf{2} 6; 1:by auto. + wp; rnd (fun x => head witness x) (fun x => [x]). + auto => />;split => [ rR ? | _ rL ]. + + by rewrite dlist1E //= big_consT big_nil. + rewrite supp_dlist //;case rL => //=; smt (size_eq0). + transitivity SampleCons.sample + (={n} /\ 0 < n{1} ==> ={res}) + (_n + 1 = n{1} /\ ={n} /\ 0 < n{1} ==> ={res})=> //=; 1:smt(). + by conseq Sample_SampleCons_eq. + proc; splitwhile{2} 3: (i < n - 1). + rcondt{2} 4; 1:by auto; while (i < n); auto; smt(). + rcondf{2} 7; 1:by auto; while (i < n); auto; smt(). + wp; rnd. + outline {1} 1 ~ Sample.sample. + rewrite equiv[{1} 1 ih]. + inline. + by wp; while (={i} /\ ={l} /\ n0{1} = n{2} - 1); auto; smt(). + qed. + + equiv Sample_LoopSnoc_eq: Sample.sample ~ LoopSnoc.sample: ={n} ==> ={res}. + proof. + proc*. + replace* {1} { x } by { x; r <- rev r; }. + inline *; wp; rnd rev; auto. + smt(revK dlist_rev). + rewrite equiv[{1} 1 Sample_Loop_eq]. + inline *; wp; while (={i, n0} /\ rev l{1} = l{2}); auto => />. + smt(rev_cons cats1). + qed. +end Program. From 4f981123354b55347506b6406c11f7831f9f7cf4 Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Tue, 2 Jun 2026 18:23:58 +0100 Subject: [PATCH 092/145] Second FIXME pass --- examples/exclude/rejection.ec | 2 +- libs/lospecs/aig.ml | 6 ++++-- libs/lospecs/ast.ml | 2 +- libs/lospecs/circuit_spec.ml | 2 +- libs/lospecs/typing.ml | 2 +- src/ecCircuits.mli | 2 +- src/ecEnv.ml | 2 +- src/ecHiTacticals.ml | 1 - src/ecLowCircuits.ml | 1 - src/ecParser.mly | 2 +- src/ecScope.ml | 11 +++++------ src/ecSection.ml | 6 +++--- src/ecSubst.ml | 4 ++-- src/ecTypesafeFol.ml | 5 ----- src/phl/ecPhlBDep.ml | 11 +++++------ src/phl/ecPhlRwPrgm.ml | 9 +++++++-- tests/circuit_test.ec | 4 +--- theories/datatypes/QFABV.ec | 1 - 18 files changed, 34 insertions(+), 39 deletions(-) diff --git a/examples/exclude/rejection.ec b/examples/exclude/rejection.ec index cf163d88e8..a51555c322 100644 --- a/examples/exclude/rejection.ec +++ b/examples/exclude/rejection.ec @@ -62,7 +62,7 @@ module M = { var counter : w64 <- W64.zero; - permq <- W8.of_int 148; (* FIXME: hex/bin notations *) + permq <- W8.of_int 148; (* FIXME: PY hex/bin notations *) shfb <- W32u8.pack32 (List.map W8.of_int [ 0; 1; 1; 2; 3; 4; 4; 5; 6; 7; 7; 8; 9; 10; 10; 11; diff --git a/libs/lospecs/aig.ml b/libs/lospecs/aig.ml index 0fbda8203c..7cefdc5ae8 100644 --- a/libs/lospecs/aig.ml +++ b/libs/lospecs/aig.ml @@ -485,7 +485,6 @@ let abc_check_equiv BatIO.write_string abc_in (abc_command ^ "\n"); BatIO.close_out abc_in; (* let abc_output_c = BatIO.input_channel ~autoclose:true ~cleanup:true abc_output_c in *) - (* FIXME: Get the actual output in all cases from abc *) let re = Str.regexp {|.*Networks are equivalent.*|} in Format.eprintf "Before read@."; let abc_output = BatIO.read_all abc_output_c in @@ -521,7 +520,10 @@ let load (inp : IO.input) : reg * (Set.String.t * string array) option = let doit (x : string) = if not (Str.string_match re x 0) then raise (InvalidAIG ("not a valid uint: " ^ x)); - int_of_string x (* FIXME: overflow *) + (match int_of_string_opt x with + | Some x -> x + | None -> raise (InvalidAIG ("error in parsing in from string: " ^ x)) + ) in fun x -> doit x in let header = String.trim (IO.read_line inp) in diff --git a/libs/lospecs/ast.ml b/libs/lospecs/ast.ml index f10383f2df..c4a0819e95 100644 --- a/libs/lospecs/ast.ml +++ b/libs/lospecs/ast.ml @@ -1,7 +1,7 @@ (* -------------------------------------------------------------------- *) type symbol = Ptree.symbol [@@deriving yojson] -(* FIXME PR: Maybe get a decl file to declare errors and other common things? *) +(* FIXME PY: Maybe get a decl file to declare errors and other common things? *) exception DestrError of string (* -------------------------------------------------------------------- *) diff --git a/libs/lospecs/circuit_spec.ml b/libs/lospecs/circuit_spec.ml index c18a008f2d..8bb65eeff1 100644 --- a/libs/lospecs/circuit_spec.ml +++ b/libs/lospecs/circuit_spec.ml @@ -11,7 +11,7 @@ let load_from_file ~(filename : string) = let split_at_arr (type t) (n: int) (r: t array) : t array * t array = Array.sub r 0 n, Array.right r (Array.length r - n) -exception CircuitSpecError of symbol (* FIXME PR: Rename? *) +exception CircuitSpecError of symbol (* ==================================================================== *) module Env : sig diff --git a/libs/lospecs/typing.ml b/libs/lospecs/typing.ml index fb7d93eadf..b683d980c7 100644 --- a/libs/lospecs/typing.ml +++ b/libs/lospecs/typing.ml @@ -458,7 +458,7 @@ let rec tt_expr_ (env : env) (e : pexpr) : aargs option * aexpr = (None, { node; type_; }) | PECond (c, (pe1, pe2)) -> - let c = tt_expr env c in (* FIXME: must be a word *) + let c = tt_expr ~check:(`W 1) env c in let e1 = tt_expr env pe1 in let e2 = tt_expr env pe2 in diff --git a/src/ecCircuits.mli b/src/ecCircuits.mli index 0c8157851a..586705c3f8 100644 --- a/src/ecCircuits.mli +++ b/src/ecCircuits.mli @@ -44,7 +44,7 @@ type circuit_error = | `Hoare | `Instr ] -| PropagateError of circuit_conversion_call * circuit_error (* FIXME: make this lazy *) +| PropagateError of circuit_conversion_call * circuit_error exception CircError of circuit_error diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 8430b543a7..037d61a1aa 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -2905,7 +2905,7 @@ type ebinding = [ | `ModType of module_sig ] -(* FIXME section : Global ? *) +(* FIXME PY section : Global ? *) let bind1 ((x, eb) : symbol * ebinding) (env : env) = match eb with | `Variable ty -> Var .bind_pvglob x ty env diff --git a/src/ecHiTacticals.ml b/src/ecHiTacticals.ml index c523f1f65f..b91ff1e3a9 100644 --- a/src/ecHiTacticals.ml +++ b/src/ecHiTacticals.ml @@ -54,7 +54,6 @@ and process1_try (ttenv : ttenv) (t : ptactic_core) (tc : tcenv1) = FApi.t_try (process1_core ttenv t) tc (* -------------------------------------------------------------------- *) -(* FIXME: Maybe move the extens tactic to this file as well? *) and process1_extens (ttenv : ttenv) ((t, v) : ptactic_core * psymbol option) (tc : tcenv1) = let v = Option.map unloc v in EcPhlBDep.t_extens v (process1_core ttenv t) tc diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index d4406f4f1a..73af0c3194 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -1715,7 +1715,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = end | _ -> assert false (* Programming error *) - (* FIXME: review this functiono | FIXME: Not axiomatized in QFABV.ec file *) let array_oflist (circs : circuit list) (dfl: circuit) (len: int) : circuit = let circs, inps = List.split circs in let dif = len - List.length circs in assert (dif >= 0); diff --git a/src/ecParser.mly b/src/ecParser.mly index fd31a5c888..da5dc77a63 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -3953,7 +3953,7 @@ user_red_option: (* -------------------------------------------------------------------- *) (* Circuit & bo bindings *) -(* FIXME:merge-bdep generic option parser *) +(* FIXME PY: merge-bdep generic option parser *) spec_binding: | op=qoident LARROW circ=loc(STRING) diff --git a/src/ecScope.ml b/src/ecScope.ml index 7021a941e5..a6abcdb130 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -2762,7 +2762,6 @@ module Circuit = struct evc_empty with evc_lemmas = { evc_empty.evc_lemmas with ev_global = [ - (* (Some (loced (Pby None)), Some [`Include, "bydone"]); *) (* FIXME *) (None, None); (None, None); ]; @@ -2792,7 +2791,7 @@ module Circuit = struct | EcTheory.Th_type (name, _) -> { name; kind = CRBT_Type (pqname root name) } | EcTheory.Th_operator (name, op) -> - (* FIXME: refresh type parameters? *) + (* FIXME PY: refresh type parameters? *) let tvars = List.map tvar op.op_tparams in let body = e_op (pqname root name) tvars op.op_ty in { name; kind = CRBT_Op (op.op_tparams, body) } @@ -2823,7 +2822,7 @@ module Circuit = struct let touint, _ = EcEnv.Op.lookup bs.touint.pl_desc env in let tosint, _ = EcEnv.Op.lookup bs.tosint.pl_desc env in let ofint, _ = EcEnv.Op.lookup bs.ofint.pl_desc env in - let name = String.concat "_" ("BVA" :: EcPath.tolist bspath) (* FIXME: not stable*) in + let name = String.concat "_" ("BVA" :: EcPath.tolist bspath) (* FIXME PY: not stable *) in let preclone = { path = EcPath.fromqsymbol (["Top"; "QFABV"], "BV") @@ -2879,7 +2878,7 @@ module Circuit = struct "cannot find named type: `%s'" (string_of_qsymbol (unloc ba.type_)) - | Some (path, decl) -> (* FIXME: normalize? *) + | Some (path, decl) -> (* FIXME PY: normalize? *) if List.length decl.tyd_params <> 1 then hierror ~loc:(loc ba.type_) "type constructor should take exactly one parameter: `%s'" @@ -3047,7 +3046,7 @@ module Circuit = struct "cannot find named type: `%s'" (string_of_qsymbol (unloc ty)) - | Some (path, decl), `BV _ -> (* FIXME: normalize? *) + | Some (path, decl), `BV _ -> (* FIXME PY: normalize? *) if List.length decl.tyd_params <> 0 then hierror ~loc:(loc ty) "a bit-string type must be a monomorphic named type"; @@ -3101,7 +3100,7 @@ module Circuit = struct let name = let suffix = List.map (EcPath.tolist -| proj3_1) types in let suffix = List.flatten suffix in - String.concat "_" ("BVA" :: unloc op.name :: suffix) (* FIXME: not stable*) in + String.concat "_" ("BVA" :: unloc op.name :: suffix) (* FIXME PY: not stable*) in let _, cltheories = let string_of_mode = function `A -> "A" | `BV -> "BV" in diff --git a/src/ecSection.ml b/src/ecSection.ml index 1ef5d570b4..8b2ac192c7 100644 --- a/src/ecSection.ml +++ b/src/ecSection.ml @@ -1121,7 +1121,7 @@ let generalize_auto to_gen auto_rl = to_gen, Some (Th_auto {auto_rl with axioms}) let generalize_crbinding (to_gen : to_gen) ((bd, lc) : crbinding * is_local) = - (* FIXME: not complete? *) + (* FIXME PY: not complete? *) let bd = EcSubst.subst_crbinding to_gen.tg_subst bd in let item = if lc = `Local then None else Some (Th_crbinding (bd, lc)) @@ -1226,7 +1226,7 @@ let can_depend (cd : can_depend) (who : cbarg) = | `ModuleType _ -> cd.d_modty | `Typeclass _ -> cd.d_tc | `Instance _ -> assert false - | `Crbind _ -> assert false (* FIXME *) + | `Crbind _ -> assert false (* FIXME PY *) let cb scenv from cd who = let env = scenv.sc_env in @@ -1612,7 +1612,7 @@ let check_item scenv item = | Th_auto { locality } -> if (locality = `Local && not scenv.sc_insec) then hierror "local hint can only be declared inside section"; - | Th_reduction _ -> () (* FIXME *) + | Th_reduction _ -> () (* FIXME PY *) | Th_crbinding (crb, lc) -> check_crbinding scenv (crb, lc) | Th_theory _ -> assert false | Th_alias _ -> () (* FIXME:ALIAS *) diff --git a/src/ecSubst.ml b/src/ecSubst.ml index dc6edad10a..4679e2c2d5 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -1029,7 +1029,7 @@ let subst_tc (s : subst) tc = (* -------------------------------------------------------------------- *) let subst_binding_size ?(red: (form -> int option) option) (s: subst) (bsize: binding_size) = - (* FIXME: add reduction? *) + (* FIXME PY: add reduction? *) let fsize = subst_form s (fst bsize) in let csize = match red with | Some red when Option.is_none (snd bsize) -> red fsize @@ -1103,7 +1103,7 @@ let subst_crbinding ?(red: (form -> int option) option) (s : subst) (crb : crbin assert (not (Mp.mem bs.touint s.sb_def)); assert (not (Mp.mem bs.tosint s.sb_def)); assert (not (Mp.mem bs.ofint s.sb_def)); - (* FIXME : maybe add an assert here? *) + (* FIXME PY: maybe add an assert here? *) CRB_Bitstring { type_ = subst_path s bs.type_; from_ = subst_path s bs.from_; diff --git a/src/ecTypesafeFol.ml b/src/ecTypesafeFol.ml index 1b1b3e04f4..445f1663a1 100644 --- a/src/ecTypesafeFol.ml +++ b/src/ecTypesafeFol.ml @@ -43,11 +43,6 @@ let unroll_ftype (ty:ty) : ty list * ty = doit [] ty -let ty_var_from_ty (ty:ty) : ty list = - match ty.ty_node with - | Tconstr (_, args) -> args - | _ -> assert false (* FIXME: how to handle this case ? *) - (* Returned list is (tyvar, ty) *) let rec match_ty_tyargs (ty: ty) (tyargs: ty) : (ty * ty) list = match (ty.ty_node, tyargs.ty_node) with diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index 7f8afbf8a6..8e019c8b5b 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -18,7 +18,7 @@ module Option = Batteries.Option (* -------------------------------------------------------------------- *) let int_of_form = EcCircuits.int_of_form -(* FIXME: move? V *) +(* FIXME PY: move? V *) let form_list_from_iota (hyps: hyps) (f: form) : form list = match f.f_node with | Fapp ({f_node = Fop(p, _)}, [n; m]) when p = EcCoreLib.CI_List.p_iota -> @@ -40,7 +40,7 @@ let rec form_list_of_form (f: form) : form list = | _ -> raise (DestrError "list") -(* FIXME: move? A *) +(* FIXME PY: move? A *) let rec destr_conj (hyps: hyps) (f: form) : form list = let redmode = {(circ_red hyps) with zeta = false} in @@ -261,7 +261,7 @@ let t_bdep_simplify (tc: tcenv1) = | _ -> assert false (* ================ EXTENS TACTIC ==================== *) -(* FIXME: Maybe move later? *) +(* FIXME PY: Maybe move later? *) open FApi let t_extens (v: string option) (tt : backward) (tc : tcenv1) = (* Find goal shape @@ -348,10 +348,9 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = | Some (v, _, _) -> v | None -> tc_error (tc1_penv tc) "Failed to find var %s in memory %s" v (EcIdent.name m) in - (* FIXME: Assumes is not array, fix later *) let size = match EcEnv.Circuit.lookup_bitstring_size (tc1_env tc) v.v_type with | Some size -> size - | None -> tc_error (tc1_penv tc) "Failed to get size for type %a (is it finite and does it have a binding?)" + | None -> tc_error (tc1_penv tc) "Failed to get size for type %a (is it finite and does it have a binding to a bistring type (arrays unsupported)?)" EcPrinting.(pp_type PPEnv.(ofenv (tc1_env tc))) v.v_type in let tpath = match v.v_type.ty_node with @@ -361,7 +360,7 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = let of_int = match EcEnv.Circuit.reverse_type (tc1_env tc) tpath with | [] -> tc_error (tc1_penv tc) "No bindings found for type of var" | `Bitstring { ofint }::_ -> ofint - | _ -> tc_error (tc1_penv tc) "FIXME: Unhandled case" + | _ -> tc_error (tc1_penv tc) "Only finite size bitstring supported" in let ngoals = 1 lsl size in (* let ngoals = min ngoals 5 in *) diff --git a/src/phl/ecPhlRwPrgm.ml b/src/phl/ecPhlRwPrgm.ml index 2e590ff55f..852d5748ed 100644 --- a/src/phl/ecPhlRwPrgm.ml +++ b/src/phl/ecPhlRwPrgm.ml @@ -34,7 +34,11 @@ let process_change ((cpos, bindings, i, s) : change_t) (tc : tcenv1) = let x = Option.map EcLocation.unloc (EcLocation.unloc x) in let vr = EcAst.{ ov_name = x; ov_type = ty; } in let (mem, _) = EcMemory.bind_fresh vr mem in - (mem, (EcTypes.pv_loc (oget x), ty)) (* FIXME: oget? *) + let x = match x with + | Some x -> x + | None -> tc_error !!tc "Missing name for variable" + in + (mem, (EcTypes.pv_loc x, ty)) ) hs.hs_m bindings in let env = EcEnv.Memory.push_active_ss mem env in @@ -43,7 +47,8 @@ let process_change ((cpos, bindings, i, s) : change_t) (tc : tcenv1) = let ue = EcProofTyping.unienv_of_hyps (FApi.tc1_hyps tc) in let s = EcTyping.transstmt env ue s in - assert (EcUnify.UniEnv.closed ue); (* FIXME *) + if not (EcUnify.UniEnv.closed ue) + then tc_error !!tc "Failed to infer all types for type variables"; let sb = EcCoreSubst.Tuni.subst (EcUnify.UniEnv.close ue) in EcCoreSubst.s_subst sb s in diff --git a/tests/circuit_test.ec b/tests/circuit_test.ec index 84508b3190..3dffb6d23e 100644 --- a/tests/circuit_test.ec +++ b/tests/circuit_test.ec @@ -121,11 +121,9 @@ qed. lemma W8_xor_ext_simp (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. proof. proc. -extens [a] : by circuit simplify; trivial. (* FIXME: without by does not work *) +extens [a] : by circuit simplify; trivial. qed. - - lemma xor_com (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b /\ a_ = b_ ==> res = b_ +^ a_]. proof. proc. diff --git a/theories/datatypes/QFABV.ec b/theories/datatypes/QFABV.ec index c5e6e42bc4..10cf02a472 100644 --- a/theories/datatypes/QFABV.ec +++ b/theories/datatypes/QFABV.ec @@ -44,7 +44,6 @@ abstract theory BV. end BV. (* ==================================================================== *) -(* FIXME: Missing of_list axiomatization *) abstract theory A. op size : int. From d27b8663f07a4470190997f6a89b52367c9ee4c3 Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Wed, 3 Jun 2026 10:35:40 +0100 Subject: [PATCH 093/145] Third FIXME pass --- libs/lospecs/ast.ml | 1 - src/ecLowCircuits.ml | 1 - src/ecParser.mly | 3 --- src/ecScope.ml | 4 ++-- src/ecSubst.ml | 2 -- src/phl/ecPhlBDep.ml | 1 - tests/procchange.ec | 5 +---- 7 files changed, 3 insertions(+), 14 deletions(-) diff --git a/libs/lospecs/ast.ml b/libs/lospecs/ast.ml index c4a0819e95..372e8e36ea 100644 --- a/libs/lospecs/ast.ml +++ b/libs/lospecs/ast.ml @@ -1,7 +1,6 @@ (* -------------------------------------------------------------------- *) type symbol = Ptree.symbol [@@deriving yojson] -(* FIXME PY: Maybe get a decl file to declare errors and other common things? *) exception DestrError of string (* -------------------------------------------------------------------- *) diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index 73af0c3194..2fef2b2849 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -1237,7 +1237,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = assert (c.type_ = CBool); let node_c = Backend.node_of_reg c.reg in let node_c, shifts = Backend.Deps.excise_bit node_c in - (* FIXME: do this in a more principled way (the types) after merge *) let inps = List.filter_map (fun {id; _} -> match Map.find_opt id shifts with | Some (low, hi) -> Some {id; type_ = CBitstring (hi - low + 1)} diff --git a/src/ecParser.mly b/src/ecParser.mly index da5dc77a63..db98c48058 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -3952,9 +3952,6 @@ user_red_option: (* -------------------------------------------------------------------- *) (* Circuit & bo bindings *) - -(* FIXME PY: merge-bdep generic option parser *) - spec_binding: | op=qoident LARROW circ=loc(STRING) { (op, circ) } diff --git a/src/ecScope.ml b/src/ecScope.ml index a6abcdb130..f3b8c1b576 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -2878,7 +2878,7 @@ module Circuit = struct "cannot find named type: `%s'" (string_of_qsymbol (unloc ba.type_)) - | Some (path, decl) -> (* FIXME PY: normalize? *) + | Some (path, decl) -> if List.length decl.tyd_params <> 1 then hierror ~loc:(loc ba.type_) "type constructor should take exactly one parameter: `%s'" @@ -3046,7 +3046,7 @@ module Circuit = struct "cannot find named type: `%s'" (string_of_qsymbol (unloc ty)) - | Some (path, decl), `BV _ -> (* FIXME PY: normalize? *) + | Some (path, decl), `BV _ -> if List.length decl.tyd_params <> 0 then hierror ~loc:(loc ty) "a bit-string type must be a monomorphic named type"; diff --git a/src/ecSubst.ml b/src/ecSubst.ml index 4679e2c2d5..b0bf344b2c 100644 --- a/src/ecSubst.ml +++ b/src/ecSubst.ml @@ -1029,7 +1029,6 @@ let subst_tc (s : subst) tc = (* -------------------------------------------------------------------- *) let subst_binding_size ?(red: (form -> int option) option) (s: subst) (bsize: binding_size) = - (* FIXME PY: add reduction? *) let fsize = subst_form s (fst bsize) in let csize = match red with | Some red when Option.is_none (snd bsize) -> red fsize @@ -1103,7 +1102,6 @@ let subst_crbinding ?(red: (form -> int option) option) (s : subst) (crb : crbin assert (not (Mp.mem bs.touint s.sb_def)); assert (not (Mp.mem bs.tosint s.sb_def)); assert (not (Mp.mem bs.ofint s.sb_def)); - (* FIXME PY: maybe add an assert here? *) CRB_Bitstring { type_ = subst_path s bs.type_; from_ = subst_path s bs.from_; diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index 8e019c8b5b..edd2d5c27c 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -261,7 +261,6 @@ let t_bdep_simplify (tc: tcenv1) = | _ -> assert false (* ================ EXTENS TACTIC ==================== *) -(* FIXME PY: Maybe move later? *) open FApi let t_extens (v: string option) (tt : backward) (tc : tcenv1) = (* Find goal shape diff --git a/tests/procchange.ec b/tests/procchange.ec index e65e4b9132..a267b420bd 100644 --- a/tests/procchange.ec +++ b/tests/procchange.ec @@ -136,13 +136,10 @@ theory ProcChangeWhileEquiv. x <- x + 1 + 0; } }. - (* proc rewrite {1} 1 /=. *) - admit. (* FIXME *) - (* + proc rewrite {1} 1 /=. proc rewrite {1} 1 /=. proc rewrite {2} 1.1 /=. sim. - *) abort. end ProcChangeWhileEquiv. From 4ddac8bbf011eb8c34ba6d55619fed325af94cd0 Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Wed, 3 Jun 2026 14:41:03 +0100 Subject: [PATCH 094/145] Fix unit tests --- tests/circuit_test.ec | 2 +- tests/conseq_metavars.ec | 44 ---------------------------------------- tests/ext_test.ec | 13 ------------ 3 files changed, 1 insertion(+), 58 deletions(-) delete mode 100644 tests/conseq_metavars.ec delete mode 100644 tests/ext_test.ec diff --git a/tests/circuit_test.ec b/tests/circuit_test.ec index 3dffb6d23e..9384d5304b 100644 --- a/tests/circuit_test.ec +++ b/tests/circuit_test.ec @@ -136,7 +136,7 @@ theory Array8. type 'a t. op tolist : 'a t -> 'a list. -op oflist : 'a list -> 'a t. +op oflist : 'a -> 'a list -> 'a t. op "_.[_]" : 'a t -> int -> 'a. op "_.[_<-_]" : 'a t -> int -> 'a -> 'a t. diff --git a/tests/conseq_metavars.ec b/tests/conseq_metavars.ec deleted file mode 100644 index aecabb4ec8..0000000000 --- a/tests/conseq_metavars.ec +++ /dev/null @@ -1,44 +0,0 @@ -require import AllCore Int Real. - -theory ConseqPrePostHoare. -module M = { - proc f(x: int) = { - var y : int; - - y <- x; - x <- y + x; - return x; - } -}. - -lemma bar (x: int) (y: int): true. proof. by done. qed. - -lemma foo : hoare[M.f : 2 < arg /\ arg < 5 ==> res = 4]. -proof. -conseq (_: #pre ==> #post). -proc. -conseq (_: #pre ==> #post). -abort. -end ConseqPrePostHoare. - - -theory ConseqPrePostEquiv. -module M = { - proc f(x: int) = { - var y : int; - - y <- x; - x <- y + x; - return x; - } -}. - - -lemma foobar : equiv[M.f ~ M.f : ={arg} /\ arg{1} = 2 ==> ={res} /\ res{1} = 3]. -proof. -conseq (_: #pre /\ arg{2} = 2 ==> #post /\ res{2} = 3); auto. -proc. -conseq (_: #{/x{1}}pre ==> #{/x{1}}post). auto. -move=> ? ? ? ? ? <*>> //. -abort. -end ConseqPrePostEquiv. diff --git a/tests/ext_test.ec b/tests/ext_test.ec deleted file mode 100644 index b6e679925b..0000000000 --- a/tests/ext_test.ec +++ /dev/null @@ -1,13 +0,0 @@ -require import AllCore Int List. - -print List.Iota.iota_. -print List.all. -print List.Iota. - -lemma random : List.all (fun i => i = i) - (List.Iota.iota_ 0 10). - proof. - - extens trivial. - qed. - From dd479873ce5215c790c816a7fba19d876222dd87 Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Wed, 3 Jun 2026 14:41:38 +0100 Subject: [PATCH 095/145] Remove DFSet --- theories/distributions/DFSet.ec | 456 -------------------------------- 1 file changed, 456 deletions(-) delete mode 100644 theories/distributions/DFSet.ec diff --git a/theories/distributions/DFSet.ec b/theories/distributions/DFSet.ec deleted file mode 100644 index 8fbe6dcf9c..0000000000 --- a/theories/distributions/DFSet.ec +++ /dev/null @@ -1,456 +0,0 @@ -(* -------------------------------------------------------------------- *) -require import AllCore List FSet Distr DProd DList StdOrder StdBigop. -(*---*) import Bigreal Bigreal.BRM MUnit. - -op [opaque] dfset (d : 'a distr) (n : int): 'a fset distr = - dcond (dmap (dlist d n) oflist) (fun fs => card fs = n). - -lemma dfset_def (d : 'a distr) n: dfset d n = - dcond (dmap (dlist d n) oflist) (fun fs => card fs = n) by rewrite/dfset. - -(* FIXME: move *) -lemma dscale_of_ll ['a] (d: 'a distr) : - is_lossless d => - dscale d = d. -proof. -rewrite /dscale /is_lossless => LL; rewrite LL; apply dscalar1. -qed. - -lemma dscale_dunit ['a] (x: 'a) : - dscale (dunit x) = dunit x. -apply dscale_of_ll; apply dunit_ll. -qed. - -lemma drestrict_dunit ['a] (x: 'a) (p: 'a -> bool) : - drestrict (dunit x) p = - if p x then dunit x else dnull. -admitted. - -search dnull. - -lemma dscale_dnull ['a] : - dscale dnull<:'a> = dnull. -proof. by rewrite /dscale weight_dnull invr0; apply dscalar0r. qed. - -(* FIXME: move *) -lemma dcond_dunit ['a] (x: 'a) (p: 'a -> bool) : - dcond (dunit x) p = - if p x then dunit x else dnull. -proof. - rewrite /dcond drestrict_dunit; - case (p x) => P; 1: apply dscale_dunit; 1: apply dscale_dnull. -qed. - -lemma dfset0 (d : 'a distr) n: n <= 0 => dfset d n = dunit (fset0). -proof. -move => ge0_n; rewrite dfset_def /fset0 dlist0; 1:apply ge0_n; 1:rewrite dmap_dunit dcond_dunit. cbv. -search dcond. -qed. - -print FSet. - -lemma dfset1 (d : 'a distr) : dfset d 1 = dmap d fset1. -proof. -by rewrite dfset_def /fset1 dlist1 dmap_comp //. -qed. - -(* -lemma dfsetS (d : 'a distr) n: - 0 <= n => - dfset d (n + 1) - = dapply (fun (xy : 'a * 'a list) => xy.`1 :: xy.`2) (d `*` (dlist d n)). -proof. -elim n=> [|n le0_n ih]. -+ by rewrite !dlist_def /= -foldpos // fold0. -by rewrite dlist_def -foldpos 1:/# -dlist_def /=. -qed. -*) - -print djoin. - -print FSet. - -print fold. -print djoin. -print nseq. - -op djoin_fset ['a] (ds: 'a Distr.distr fset) : 'a fset Distr.distr = - - - -lemma dfset_djoin (d : 'a distr) n: 0 <= n => dlist d n = djoin (nseq n d). -proof. -elim: n => [|n Hn IHn]; first by rewrite dlist0 // /nseq iter0 // djoin_nil. -by rewrite dlistS // nseqS // djoin_cons IHn. -qed. - -lemma dapply_dmap ['a 'b] (d:'a distr) (F:'a -> 'b): dapply F d = dmap d F by done. - -lemma dlist_add (d:'a distr) n1 n2: - 0 <= n1 => 0 <= n2 => - dlist d (n1 + n2) = - dmap (dlist d n1 `*` dlist d n2) (fun (p:'a list * 'a list) => p.`1 ++ p.`2). -proof. -elim: n1 => [hn2|n1 hn1 IHn1 hn2]. - by rewrite (dlist0 d 0) //= dmap_dprodE dlet_unit /= dmap_id_eq_in. -rewrite addzAC !dlistS 1:/# //= IHn1 //. -rewrite !dmap_dprodE /= dlet_dlet; apply eq_dlet => //= x. -rewrite dmap_dlet dlet_dmap; apply eq_dlet => //= x1. -rewrite /dmap dlet_dlet /(\o); apply eq_dlet => //= x2. -by rewrite dlet_dunit dmap_dunit. -qed. - -lemma dlistSr (d : 'a distr) (n : int) : 0 <= n => - dlist d (n + 1) = dapply (fun (xy : 'a list * 'a) => rcons xy.`1 xy.`2) (dlist d n `*` d). -proof. -move => hn; rewrite dlist_add // dlist1 /= !dmap_dprodE. -apply eq_dlet => // xs; rewrite dmap_comp. -by apply eq_dmap => x //=; rewrite /(\o) cats1. -qed. - -lemma dlist01E (d : 'a distr) n x: - n <= 0 => mu1 (dlist d n) x = b2r (x = []). -proof. by move=> /(dlist0 d) ->;rewrite dunit1E (eq_sym x). qed. - -lemma dlistS1E (d : 'a distr) x xs: - mu1 (dlist d (size (x::xs))) (x::xs) = - mu1 d x * mu1 (dlist d (size xs)) xs. -proof. -rewrite /= addzC dlistS 1:size_ge0 /= dmap1E -dprod1E &(mu_eq) => z /#. -qed. - -lemma dlist0_ll (d : 'a distr) n: - n <= 0 => - is_lossless (dlist d n). -proof. by move=> /(dlist0 d) ->;apply dunit_ll. qed. - -lemma dlist_ll (d : 'a distr) n: - is_lossless d => - is_lossless (dlist d n). -proof. -move=> d_ll; case (0 <= n); first last. -+ move=> lt0_n; rewrite dlist0 1:/#;apply dunit_ll. -elim n=> [|n le0_n ih];first by rewrite dlist0 //;apply dunit_ll. -by rewrite dlistS //;apply/dmap_ll/dprod_ll. -qed. - -hint exact random : dlist_ll. - -lemma supp_dlist0 (d : 'a distr) n xs: - n <= 0 => - xs \in dlist d n <=> xs = []. -proof. by move=> le0; rewrite dlist0 // supp_dunit. qed. - -lemma supp_dlist (d : 'a distr) n xs: - 0 <= n => - xs \in dlist d n <=> size xs = n /\ all (support d) xs. -proof. -move=> le0_n;elim: n le0_n xs => [xs | i le0 Hrec xs]. -+ by smt (supp_dlist0 size_eq0). -rewrite dlistS // supp_dmap /=;split => [[p]|]. -+ rewrite supp_dprod => [# Hp /Hrec [<- Ha] ->] /=. - by rewrite Hp Ha addzC. -case xs => //= [/# | x xs [# Hs Hin Ha]];exists (x,xs);smt (supp_dprod). -qed. - -lemma supp_dlist_size (d : 'a distr) n xs: - 0 <= n => xs \in dlist d n => size xs = n. -proof. by move=> ge0_n; case/(supp_dlist d n xs ge0_n). qed. - -lemma dlistE x0 (d : 'a distr) (p : int -> 'a -> bool) n : - mu (dlist d n) (fun xs : 'a list => - forall i, (0 <= i) && (i < n) => (p i (nth x0 xs i))) - = bigi predT (fun i => mu d (p i)) 0 n. -proof. -elim/natind : n p => [n n_le0|n n_ge0 IHn] p. -- rewrite dlist0 // dunitE range_geq //= big_nil; smt(). -rewrite rangeSr // -cats1 big_cat big_seq1. -rewrite dlistSr //= dmapE. -pose P1 xs := forall i, 0 <= i && i < n => p i (nth x0 xs i). -pose P2 x := p n x. -pose P (a : 'a list * 'a) := P1 a.`1 /\ P2 a.`2. -rewrite (mu_eq_support _ _ P); 2: by rewrite dprodE IHn. -case => xs x /=. rewrite supp_dprod /= supp_dlist // => -[[? ?] ?]. -rewrite /(\o) /P /P1 /P2 /= eq_iff; subst n; split; 2: smt(nth_rcons). -move => H; split => [i|];[have := (H i)|have := H (size xs)]; smt(nth_rcons). -qed. - -lemma dlist1E (d : 'a distr) n xs: - 0 <= n => - mu1 (dlist d n) xs - = if n = size xs - then big predT (fun x => mu1 d x) xs - else 0%r. -proof. -move=> le0_n; case (n = size xs)=> [->|]. -+ elim xs=> [|x xs ih];first by rewrite dlist01E. - by rewrite dlistS1E /= big_cons ih. -by move=> ?; rewrite -supportPn supp_dlist /#. -qed. - -lemma dlist0E n (d : 'a distr) P : n <= 0 => mu (dlist d n) P = b2r (P []). -proof. by move=> le0;rewrite dlist0 // dunitE. qed. - -lemma dlistSE (a:'a) (d: 'a distr) n P1 P2 : - 0 <= n => - mu (dlist d (n+1)) (fun (xs:'a list) => P1 (head a xs) /\ P2 (behead xs)) = - mu d P1 * mu (dlist d n) P2. -proof. by move=> Hle;rewrite dlistS // /= dmapE -dprodE. qed. - -lemma dlist_perm_eq (d : 'a distr) s1 s2: - perm_eq s1 s2 => - mu1 (dlist d (size s1)) s1 = mu1 (dlist d (size s2)) s2. -proof. -by rewrite !dlist1E ?size_ge0 /=;apply eq_big_perm. -qed. - -lemma weight_dlist0 n (d:'a distr): - n <= 0 => weight (dlist d n) = 1%r. -proof. by move=> le0;rewrite dlist0E. qed. - -lemma weight_dlistS n (d:'a distr): - 0 <= n => weight (dlist d (n + 1)) = weight d * weight (dlist d n). -proof. by move=> ge0;rewrite -(dlistSE witness) //. qed. - -lemma weight_dlist (d : 'a distr) n : - 0 <= n => weight (dlist d n) = (weight d)^n. -proof. -elim: n => [|n ? IHn]; 1: by rewrite weight_dlist0 // RField.expr0. -by rewrite weight_dlistS // IHn RField.exprS. -qed. - - -lemma dlist_fu (d: 'a distr) (xs:'a list): - (forall x, x \in xs => x \in d) => - xs \in dlist d (size xs). -proof. -move=> fu; rewrite /support dlist1E 1:size_ge0 /=. -by apply Bigreal.prodr_gt0_seq => /= a Hin _;apply fu. -qed. - -lemma dlist_uni (d:'a distr) n : - is_uniform d => is_uniform (dlist d n). -proof. -case (n < 0)=> [Hlt0 Hu xs ys| /lezNgt Hge0 Hu xs ys]. -+ rewrite !supp_dlist0 ?ltzW //. -rewrite !supp_dlist // => -[eqxs Hxs] [eqys Hys]. -rewrite !dlist1E // eqxs eqys /=;move: eqys;rewrite -eqxs => {eqxs}. -elim: xs ys Hxs Hys => [ | x xs Hrec] [ | y ys] //=; 1,2:smt (size_ge0). -rewrite !big_consT. -move=> /= /> x_in_d all_in_d_xs y_in_d all_in_d_ys /addzI eq_size. -rewrite (Hrec ys) //. -by congr=> //; exact: Hu. -qed. - -lemma dlist_dmap ['a 'b] (d : 'a distr) (f : 'a -> 'b) n : - dlist (dmap d f) n = dmap (dlist d n) (map f). -proof. -elim/natind: n => [n le0_n| n ge0_n ih]. -- by rewrite !dlist0 // dmap_dunit. -- by rewrite !dlistS //= ih -dmap_dprod_comp dmap_comp. -qed. - -lemma dlist_rev (d:'a distr) n s: - mu1 (dlist d n) (rev s) = mu1 (dlist d n) s. -proof. -case (n <= 0) => [?|?]. -+ rewrite !dlist0E // /pred1 /= -{1}rev_nil. - by congr; rewrite eq_iff; split=> />; exact: rev_inj. -case (size s = n) => [<-|?]; 2: smt(dlist1E supp_dlist_size size_rev). -by rewrite -{1}size_rev &(dlist_perm_eq) perm_eq_sym perm_eq_rev. -qed. - -lemma dlist_dlist ['a] (d : 'a distr) (m n : int) : - 0 <= m => 0 <= n => - dmap (dlist (dlist d m) n) flatten = dlist d (m * n). -proof. -move=> ge0_m; elim: n => /= [|n ge0_n ih]. -- by rewrite !dlist0 // dmap_dunit. -rewrite mulrDr /= [dlist d (m * n + m)]dlist_add //. -- by apply: IntOrder.mulr_ge0. -rewrite dlistSr //= dmap_comp !dmap_dprodE /=. -rewrite -ih dlet_dmap /= &(eq_dlet) // => xss /=. -by rewrite &(eq_dmap) /(\o) /= => xs; rewrite flatten_rcons. -qed. - -lemma dlist_insert ['a] (x0 : 'a) (i n : int) (d : 'a distr) : - 0 <= n => 0 <= i <= n => dlist d (n+1) = - dmap (d `*` dlist d n) (fun x_xs : 'a * 'a list => insert x_xs.`1 x_xs.`2 i). -proof. -move=> ge0_n [ge0_i lti]; apply/eq_sym. -pose f (x_xs : _ * _) := insert x_xs.`1 x_xs.`2 i. -pose g (xs : 'a list) := (nth x0 xs i, take i xs ++ drop (i+1) xs). -have ge0_Sn: 0 <= n + 1 by smt(). apply: (dmap_bij _ _ f g). -- case=> [x xs] /supp_dprod[/=] x_in_d. - case/(supp_dlist _ _ _ ge0_n)=> sz_xs /allP xs_in_d. - move=> @/f /=; apply/supp_dlist; first smt(). - rewrite size_insert ?sz_xs //=; apply/allP. - by move=> y /mem_insert[->>//|/xs_in_d]. -- move=> xs /(supp_dlist _ _ _ ge0_Sn)[sz_xs /allP xs_in_d] @/g. - rewrite dprod1E !dlist1E ~-1://# sz_xs /=. - rewrite size_cat size_take // size_drop 1:/#. - rewrite iftrue 1:/# -(BRM.big_consT (mu1 d)) &(BRM.eq_big_perm). - by rewrite -cat_cons perm_eq_sym &(perm_eq_nth_take_drop) //#. -- case=> x xs /supp_dprod[/=] _ /(supp_dlist _ _ _ ge0_n)[sz_xs _]. - rewrite /g /f /= nth_insert ?sz_xs //= take_insert_le 1:/#. - by rewrite drop_insert_gt 1:/# /= cat_take_drop. -- move=> xs /(supp_dlist _ _ _ ge0_Sn)[/=] sz_xs _ @/f @/g /=. - have sz_take: size (take i xs) = i by rewrite size_take //#. - by apply/insert_nth_take_drop => //#. -qed. - -(* 0 <= n could be removed, but applying the lemma is pointless in that case *) -lemma dlist_set2E x0 (d : 'a distr) (p : 'a -> bool) n (I J : int fset) : - is_lossless d => 0 <= n => - (forall i, i \in I => 0 <= i && i < n) => - (forall j, j \in J => 0 <= j && j < n) => - (forall k, !(k \in I /\ k \in J)) => - mu (dlist d n) - (fun xs => (forall i, i \in I => p (nth x0 xs i)) /\ - (forall j, j \in J => !p (nth x0 xs j))) - = (mu d p)^(card I) * (mu d (predC p))^(card J). -proof. -move => d_ll n_ge0 I_range J_range disjIJ. -pose q i x := (i \in I => p x) /\ (i \in J => !p x). -rewrite (mu_eq_support _ _ - (fun xs => forall i, (0 <= i) && (i < n) => q i (nth x0 xs i))); 1: smt(supp_dlist). -rewrite dlistE (bigEM (mem (I `|` J))). -rewrite (big1 (predC (mem (I `|` J)))) ?mulr1. - move => i; rewrite /predC in_fsetU negb_or /= /q => -[iNI iNJ]. - rewrite (mu_eq _ _ predT) 1:/# //. -rewrite -big_filter (eq_big_perm _ _ _ (elems I ++ elems J)) ?big_cat. -- apply uniq_perm_eq => [| |x]. - + by rewrite filter_uniq range_uniq. - + rewrite cat_uniq !uniq_elems => />; apply/hasPn; smt(). - + by rewrite mem_filter mem_range mem_cat -!memE in_fsetU /#. -rewrite big_seq_cond (eq_bigr _ _ (fun _ => mu d p)) -?big_seq_cond. - move => i; rewrite /= /q -memE => -[iI _]; apply mu_eq => /#. -rewrite mulr_const big_seq_cond (eq_bigr _ _ (fun _ => mu d (predC p))) -?big_seq_cond. - move => i; rewrite /= /q -memE => -[iI _]; apply mu_eq => /#. -by rewrite mulr_const /card. -qed. - -lemma dlist_setE x0 (d : 'a distr) (p : 'a -> bool) n (I : int fset) : - is_lossless d => 0 <= n => (forall i, i \in I => 0 <= i && i < n) => - mu (dlist d n) (fun xs => forall i, i \in I => p (nth x0 xs i)) = (mu d p)^(card I). -proof. -move => d_ll n_ge0 hI. -have := dlist_set2E x0 d p n I fset0 d_ll n_ge0 hI _ _; 1,2 : smt(in_fset0). -rewrite fcards0 RField.expr0 RField.mulr1 => <-. -apply: mu_eq_support => xs; rewrite supp_dlist //= => -[? ?]; smt(in_fset0). -qed. - - -abstract theory Program. - type t. - op d: t distr. - - module Sample = { - proc sample(n:int): t list = { - var r; - - r <$ dlist d n; - return r; - } - }. - - module SampleCons = { - proc sample(n:int): t list = { - var r, rs; - - rs <$ dlist d (n - 1); - r <$ d; - return r::rs; - } - }. - - module Loop = { - proc sample(n:int): t list = { - var i, r, l; - - i <- 0; - l <- []; - while (i < n) { - r <$ d; - l <- r :: l; - i <- i + 1; - } - return l; - } - }. - - module LoopSnoc = { - proc sample(n:int): t list = { - var i, r, l; - - i <- 0; - l <- []; - while (i < n) { - r <$ d; - l <- l ++ [r]; - i <- i + 1; - } - return l; - } - }. - - lemma pr_Sample _n &m xs: Pr[Sample.sample(_n) @ &m: res = xs] = mu (dlist d _n) (pred1 xs). - proof. by byphoare (_: n = _n ==> res = xs)=> //=; proc; rnd. qed. - - equiv Sample_SampleCons_eq: Sample.sample ~ SampleCons.sample: 0 < n{1} /\ ={n} ==> ={res}. - proof. - bypr (res{1}) (res{2})=> //= &1 &2 xs [lt0_n] <-. - rewrite (pr_Sample n{1} &1 xs); case (size xs = n{1})=> [<<-|]. - case xs lt0_n=> [|x xs lt0_n]; 1: smt(). - rewrite dlistS1E. - byphoare (_: n = size xs + 1 ==> x::xs = res)=> //=; 2: by rewrite addrC. - proc; seq 1: (rs = xs) (mu (dlist d (size xs)) (pred1 xs)) (mu d (pred1 x)) _ 0%r => //. - by rnd (pred1 xs); skip; smt(). - by rnd (pred1 x); skip; smt(). - by hoare; auto; smt(). - smt(). - move=> len_xs; rewrite dlist1E 1:/# ifF 1:/#. - byphoare (_: n = n{1} ==> xs = res)=> //=; hoare. - proc; auto=> />; smt(supp_dlist_size). - qed. - - equiv Sample_Loop_eq: Sample.sample ~ Loop.sample: ={n} ==> ={res}. - proof. - proc*; exists* n{1}; elim* => _n. - move: (eq_refl _n); case (_n <= 0)=> //= h. - + inline *;rcondf{2} 4;auto;smt (supp_dlist0 weight_dlist0). - have {h} h: 0 <= _n by smt (). - call (_: _n = n{1} /\ ={n} ==> ={res})=> //=. - elim _n h=> //= [|_n le0_n ih]. - proc; rcondf{2} 3; auto=> />. smt(supp_dlist0 weight_dlist0). - case (_n = 0)=> [-> | h]. - proc; rcondt{2} 3; 1:(by auto); rcondf{2} 6; 1:by auto. - wp; rnd (fun x => head witness x) (fun x => [x]). - auto => />;split => [ rR ? | _ rL ]. - + by rewrite dlist1E //= big_consT big_nil. - rewrite supp_dlist //;case rL => //=; smt (size_eq0). - transitivity SampleCons.sample - (={n} /\ 0 < n{1} ==> ={res}) - (_n + 1 = n{1} /\ ={n} /\ 0 < n{1} ==> ={res})=> //=; 1:smt(). - by conseq Sample_SampleCons_eq. - proc; splitwhile{2} 3: (i < n - 1). - rcondt{2} 4; 1:by auto; while (i < n); auto; smt(). - rcondf{2} 7; 1:by auto; while (i < n); auto; smt(). - wp; rnd. - outline {1} 1 ~ Sample.sample. - rewrite equiv[{1} 1 ih]. - inline. - by wp; while (={i} /\ ={l} /\ n0{1} = n{2} - 1); auto; smt(). - qed. - - equiv Sample_LoopSnoc_eq: Sample.sample ~ LoopSnoc.sample: ={n} ==> ={res}. - proof. - proc*. - replace* {1} { x } by { x; r <- rev r; }. - inline *; wp; rnd rev; auto. - smt(revK dlist_rev). - rewrite equiv[{1} 1 Sample_Loop_eq]. - inline *; wp; while (={i, n0} /\ rev l{1} = l{2}); auto => />. - smt(rev_cons cats1). - qed. -end Program. From a7b138ca5c2b0546cf45922e364cd5cdae616caa Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Mon, 8 Jun 2026 17:12:28 +0100 Subject: [PATCH 096/145] Fixed proc change circuit bug and added tests --- libs/lospecs/smt.ml | 22 ++++++++++- tests/circuit_test.ec | 2 - tests/proc-change-circuit.ec | 71 ++++++++++++++++++++++++++++++++++++ 3 files changed, 91 insertions(+), 4 deletions(-) create mode 100644 tests/proc-change-circuit.ec diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index 794c01d7df..ad1d1aca48 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -31,6 +31,13 @@ module type SMTInstance = sig (* bvnot *) val bvand : bvterm -> bvterm -> bvterm + (* Boolean negation; argument and result are of Boolean sort + (as produced by [bvterm_equal]). *) + val bool_not : bvterm -> bvterm + + (* Boolean conjunction; both arguments and the result are of Boolean sort. *) + val bool_and : bvterm -> bvterm -> bvterm + val get_value : bvterm -> bvterm val pp_term : Format.formatter -> bvterm -> unit @@ -109,9 +116,14 @@ module MakeSMTInterface(SMT: SMTInstance) : SMTInterface = struct List.map (fun i -> List.reduce (SMT.bvterm_concat) i) inps) inps in + (* [pcond] is a 1-bit BV; lift to Boolean by comparing with #b1. + [formula] is already Boolean (built via [bvterm_equal]). + We search for a counterexample: a model under which [pcond] holds + and [r1 <> r2], i.e. [pcond_bool /\ not formula]. *) + let pcond_bool = SMT.bvterm_equal pcond (SMT.bvterm_of_int 1 1) in begin - SMT.assert' @@ SMT.bvand pcond (SMT.bvnot formula); - if SMT.check_sat () = false then true + SMT.assert' @@ SMT.bool_and pcond_bool (SMT.bool_not formula); + if SMT.check_sat () = false then true else begin Format.eprintf "bvout1: %a@." SMT.pp_term (SMT.get_value bvinpt1); Format.eprintf "bvout2: %a@." SMT.pp_term (SMT.get_value bvinpt2); @@ -253,6 +265,12 @@ let makeBWZinstance () : (module SMTInstance) = let bvand (bv1: bvterm) (bv2: bvterm) : bvterm = mk_term2 Kind.Bv_and bv1 bv2 + let bool_not (bv: bvterm) : bvterm = + mk_term1 Kind.Not bv + + let bool_and (bv1: bvterm) (bv2: bvterm) : bvterm = + mk_term2 Kind.And bv1 bv2 + let get_value (bv: bvterm) : bvterm = Solver.get_value bitwuzla bv diff --git a/tests/circuit_test.ec b/tests/circuit_test.ec index 9384d5304b..fabb0d40a9 100644 --- a/tests/circuit_test.ec +++ b/tests/circuit_test.ec @@ -51,8 +51,6 @@ realize ofintP by admit. realize touintP by admit. realize tosintP by done. realize gt0_size by done. - - type W8. diff --git a/tests/proc-change-circuit.ec b/tests/proc-change-circuit.ec new file mode 100644 index 0000000000..a4c5e5d0b8 --- /dev/null +++ b/tests/proc-change-circuit.ec @@ -0,0 +1,71 @@ +(* -------------------------------------------------------------------- *) +(* Tests for [proc change circuit]: replace a run of program statements + by an alternative block, with circuit-equivalence as the soundness + check. *) + +require import AllCore List QFABV. + +type W8. + +op to_bits : W8 -> bool list. +op from_bits : bool list -> W8. +op of_int : int -> W8. +op to_uint : W8 -> int. +op to_sint : W8 -> int. + +bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. +realize gt0_size by admit. +realize tolistP by admit. +realize oflistP by admit. +realize touintP by admit. +realize tosintP by admit. +realize ofintP by admit. +realize size_tolist by admit. + +op (+^) : W8 -> W8 -> W8. +bind op W8 (+^) "xor". +realize bvxorP by admit. + +module M = { + proc f (a : W8, b : W8) = { + var c : W8; + c <- a +^ b; + return c; + } +}. + +(* -------------------------------------------------------------------- *) +(* Swap the arguments of an XOR; the replacement is equivalent by + commutativity. *) +lemma swap_xor_args (a_ b_ : W8) : + hoare[M.f : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. + proc. + proc change circuit 1 + 1 { c <- b +^ a; }. + circuit. +qed. + +(* -------------------------------------------------------------------- *) +(* Introduce a fresh local [d] in the replacement block using the + [[d : W8]] binding list. *) +lemma with_fresh_local (a_ b_ : W8) : + hoare[M.f : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. + proc. + proc change circuit [d : W8] 1 + 1 { d <- a; c <- d +^ b; }. + circuit. +qed. + +(* -------------------------------------------------------------------- *) +(* A non-equivalent replacement is rejected: dropping the XOR with [b] + changes the value written to [c], so the equivalence check refuses + the rewrite. *) +lemma reject_inequivalent (a_ b_ : W8) : + hoare[M.f : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. + proc. + fail proc change circuit 1 + 1 { c <- a; }. + (* A genuinely equivalent rewrite is accepted, letting the proof close. *) + proc change circuit 1 + 1 { c <- b +^ a; }. + circuit. +qed. From 6056a16252addae39049c2cbdc3a86be521a2bdd Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Mon, 8 Jun 2026 17:45:24 +0100 Subject: [PATCH 097/145] Circuit documentation --- doc/tactics/bindings.rst | 374 +++++++++++++++++++++++------- doc/tactics/circuit.rst | 477 +++++++++++++++++++++++++++++++-------- doc/tactics/extens.rst | 235 +++++++++++++++++++ 3 files changed, 902 insertions(+), 184 deletions(-) create mode 100644 doc/tactics/extens.rst diff --git a/doc/tactics/bindings.rst b/doc/tactics/bindings.rst index d3859c62d3..bafe8a2e57 100644 --- a/doc/tactics/bindings.rst +++ b/doc/tactics/bindings.rst @@ -2,27 +2,36 @@ Command: `bind` ======================================================================== -The ``bind`` family of commands is used to allow translation of EasyCrypt -objects into boolean circuits for use in the `circuit` family of tactics. +The ``bind`` family of commands declares a correspondence between +EasyCrypt objects and their counterparts in the boolean-circuit world +used by the `circuit` family of tactics. -We have the following possibilities for these commands: +Four variants are available: -- `bind bitstring`, which establishes a bijection between the given type - and a type of fixed size bitstrings through given isomorphisms with lists - of booleans (plus necessary side conditions) +- ``bind bitstring`` — declares that a type is a fixed-size bitstring, + by giving an isomorphism with ``bool list`` together with conversions + from/to (signed and unsigned) integers. -- `bind array`, which establishes the bijection between the given type constructor - (which must be polymorphic over a given type which must be bound to a - bitstring type in instantiations) and the type of arrays of a given fixed size. +- ``bind array`` — declares that a polymorphic type constructor is a + fixed-size array, by giving access/update operators plus an + isomorphism with ``list``. The element type need not be a bitstring + at the time of binding, but it must become one whenever the array + type is used at a circuit-translated site. -- `bind op`, which establishes the semantic equivalence of the given operator to - a specified operator from a fixed list (detailed below), which roughly corresponds - to the operators supported by the QFABV theory of SMTLib. +- ``bind op`` — declares that a user-defined operator implements one + of a fixed catalog of bitvector/array primitives (corresponding to + the operators of the QFABV theory of SMT-LIB). A monomorphic and a + multi-type form are available. -- `bind circuit`, which asserts the semantic equivalence of the given operator to - the one given by a definition in the low level specification (spec) language. - All equivalences establishes through this particular mean are trusted (rather than - verified) and so become part of the TCB for the given proof. +- ``bind circuit`` — asserts that a user-defined operator is + semantically equivalent to a circuit definition given in the + low-level specification (``.spec``) language. **These bindings are + trusted and become part of the TCB** (see the warning below). + +Each variant may be prefixed with the locality modifier ``local`` or +``global``, with the usual section-locality semantics. The default, +inside a section, is to be exported; outside a section the modifier is +ignored. .. contents:: :local: @@ -31,6 +40,17 @@ We have the following possibilities for these commands: Variant: ``bind bitstring`` ------------------------------------------------------------------------ +.. admonition:: Syntax + + ``bind bitstring`` *to_bits* *from_bits* *to_uint* *to_sint* *of_int* *type* *size* ``.`` + +The seven arguments are: the two halves of the ``type ↔ bool list`` +isomorphism (``to_bits``, ``from_bits``), the two integer projections +(``to_uint`` for the unsigned reading and ``to_sint`` for the +two's-complement signed reading), the integer injection +(``of_int``), the type being bound, and its size in bits (an integer +formula). + .. ecproof:: :title: Bitstring Binding Example @@ -43,13 +63,13 @@ Variant: ``bind bitstring`` op of_int : int -> W8. op to_uint : W8 -> int. op to_sint : W8 -> int. - + (*$*) bind bitstring - to_bits - from_bits - to_uint + to_bits + from_bits + to_uint to_sint - of_int + of_int W8 8. @@ -61,18 +81,46 @@ Variant: ``bind bitstring`` realize ofintP by admit. realize size_tolist by admit. - -Here we have an example of defining a type and establishing -its equivalence with the type of bitstring of size 8, along -with the side conditions needed to verify that equivalence. -Since we only give an abstract type, these side conditions -are admitted, but in a real example they would need to be -proven using the semantics of whatever type we were using. +The command leaves seven side conditions to be discharged via +``realize`` (in this example with ``admit``; in practice they should +be proved from the type's defining equations). The axioms are those of +the abstract ``BV`` theory in ``theories/datatypes/QFABV.ec``: + +.. list-table:: + :header-rows: 1 + :widths: 18 82 + + * - Axiom + - Statement + * - ``gt0_size`` + - ``0 < size`` + * - ``size_tolist`` + - ``size (tolist bv) = size`` (the list image has the expected length) + * - ``tolistP`` + - ``oflist (tolist bv) = bv`` (round-trip via the list isomorphism) + * - ``oflistP`` + - ``size xs = size => tolist (oflist xs) = xs`` (other direction, on lists of the right length) + * - ``touintP`` + - ``touint bv = bs2int (tolist bv)`` (unsigned reading) + * - ``tosintP`` + - two's-complement reading: ``tosint bv = touint bv`` when the MSB is 0, and ``touint bv - 2^size`` otherwise (with ``size = 1`` as a degenerate case) + * - ``ofintP`` + - ``ofint i = oflist (int2bs size i)`` (integer injection is the inverse of ``bs2int`` on size-many bits) ------------------------------------------------------------------------ -Variant: ``bind array`` +Variant: ``bind array`` ------------------------------------------------------------------------ +.. admonition:: Syntax + + ``bind array`` *get* *set* *tolist* *oflist* *type* *size* ``.`` + +The six arguments are: read/write operators (``get`` of type +``'a t -> int -> 'a`` and ``set`` of type ``'a t -> int -> 'a -> 'a +t``), the two halves of the ``type ↔ list`` isomorphism (``tolist``, +``oflist``), the (polymorphic) type constructor being bound, and the +array length. + .. ecproof:: :title: Array Binding Example @@ -82,7 +130,7 @@ Variant: ``bind array`` type 'a t. op tolist : 'a t -> 'a list. - op oflist : 'a list -> 'a t. + op oflist : 'a -> 'a list -> 'a t. op "_.[_]" : 'a t -> int -> 'a. op "_.[_<-_]" : 'a t -> int -> 'a -> 'a t. @@ -91,24 +139,54 @@ Variant: ``bind array`` (*$*) bind array Array8."_.[_]" Array8."_.[_<-_]" Array8.tolist Array8.oflist Array8.t 8. realize gt0_size by auto. realize tolistP by admit. + realize oflistP by admit. realize eqP by admit. realize get_setP by admit. realize get_out by admit. - -In this example, we can see how the correspondence is established -for a given polymorphic array type. As in the example above, we -use an abstract type and admit the side conditions for simplicity -of presentation, but in a real case we would have to use the -semantics of our array type in order to discharge these conditions. - +The command leaves six side conditions to be discharged. The axioms +are those of the abstract ``A`` theory in +``theories/datatypes/QFABV.ec``: + +.. list-table:: + :header-rows: 1 + :widths: 18 82 + + * - Axiom + - Statement + * - ``gt0_size`` + - ``0 < size`` + * - ``tolistP`` + - ``to_list a = mkseq (fun i => get a i) size`` (the list view is the canonical enumeration) + * - ``oflistP`` + - for indices ``0 <= i < size``, ``nth dfl xs i = get (of_list dfl xs) i`` (the list-to-array constructor preserves indexing in range) + * - ``eqP`` + - extensional equality: two arrays are equal iff they agree at every in-range index + * - ``get_setP`` + - ``get (set a j v) i`` is ``v`` if ``i = j``, else ``get a i`` (in-range) + * - ``get_out`` + - out-of-range reads agree across all arrays (i.e. the value at an out-of-range index is unspecified-but-uniform) ------------------------------------------------------------------------ -Variant: ``bind op`` +Variant: ``bind op`` ------------------------------------------------------------------------ +.. admonition:: Syntax + + | ``bind op`` *type* *operator* ``"`` *name* ``" .`` + | ``bind op [`` *type₁* ``&`` *type₂* ``&`` … ``]`` *operator* ``"`` *name* ``" .`` + +The first (monomorphic) form is for operators whose signature mentions +a single bound type. The second (multi-type) form takes a +``&``-separated list of types inside brackets and is needed for +operators whose signature mixes types — for instance ``get`` (a +bitstring and a single-bit bitstring) or ``ainit`` (a bitstring index +type and an array element type). + +The ``name`` string must be one of the operator catalog below. + .. ecproof:: - :title: Operator Binding Example + :title: Operator Binding Example (monomorphic) require import AllCore List QFABV. @@ -119,13 +197,13 @@ Variant: ``bind op`` op of_int : int -> W8. op to_uint : W8 -> int. op to_sint : W8 -> int. - + bind bitstring - to_bits - from_bits - to_uint + to_bits + from_bits + to_uint to_sint - of_int + of_int W8 8. @@ -142,24 +220,8 @@ Variant: ``bind op`` (*$*) bind op W8 (+^) "xor". realize bvxorP by admit. - -Here we give an example of giving the semantic equivalence for -an operator. We again instantiate this abstractly and admit the -side conditions for ease of exposition, assuming that in a real -case the semantics of the operator itself would be used in order -to show that the conditions hold. - -Of note that these bindings are only necessary for a base subset -of operators, and further operators defined in terms of these basic -ones are translated through recursive descent through their definition, -usage of these base cases and a notion of composition for boolean circuits. - - ------------------------------------------------------------------------- -Variant: ``bind circuit`` ------------------------------------------------------------------------- .. ecproof:: - :title: Spec Binding Example + :title: Operator Binding Example (multi-type) require import AllCore List QFABV. @@ -170,13 +232,13 @@ Variant: ``bind circuit`` op of_int : int -> W8. op to_uint : W8 -> int. op to_sint : W8 -> int. - + bind bitstring - to_bits - from_bits - to_uint + to_bits + from_bits + to_uint to_sint - of_int + of_int W8 8. @@ -188,29 +250,171 @@ Variant: ``bind circuit`` realize ofintP by admit. realize size_tolist by admit. - op (+^) : W8 -> W8 -> W8. + op bool2bits (b : bool) : bool list = [b]. + op bits2bool (b : bool list) : bool = List.nth false b 0. + op i2b : int -> bool. + op b2si (b : bool) = 0. + + bind bitstring bool2bits bits2bool b2i b2si i2b bool 1. + realize gt0_size by done. + realize size_tolist by auto. + realize tolistP by auto. + realize oflistP by rewrite /bool2bits /bits2bool; smt(size_eq1). + realize touintP by admit. + realize tosintP by done. + realize ofintP by admit. + + op "_.[_]" : W8 -> int -> bool. + + (*$*) bind op [W8 & bool] "_.[_]" "get". + realize le_size by auto. + realize eq1_size by auto. + realize bvgetP by admit. + +The ``[W8 & bool]`` syntax names the two bitstring types involved in +``get``'s signature: the bitvector being indexed, and the single-bit +bitvector holding the extracted bit. Since ``bool`` is a primitive +type, it must itself be ``bind bitstring``-bound (to size 1) before +it can appear in a multi-type ``bind op``. + +Each ``bind op`` leaves a single side condition of the form +``bvP``, stating the semantics of the operator (e.g. ``bvxorP`` +for ``xor``, ``bvgetP`` for ``get``). Multi-type bindings may also +leave size-relation side conditions, e.g. ``le_size`` (one bitstring +size bounds another), ``eq1_size`` (a bitstring has size one). These +all come from the corresponding sub-theories of ``BVOperators`` in +``theories/datatypes/QFABV.ec``. + +Only this base catalog of operators needs an explicit binding. +Operators built on top of them are translated into circuits by +recursive descent through their definitions, applying the bindings at +the leaves and composing the resulting sub-circuits. + +Operator catalog +~~~~~~~~~~~~~~~~ + +The ``name`` argument to ``bind op`` must be one of the following. +The "Types" column shows the shape of the bracketed type list expected +by the multi-type form (``BV`` = a bitstring type, ``BV[1]`` = a +bitstring type of size 1, ``A`` = an array type); single-``BV`` +operators may also be given to the monomorphic form. + +Arithmetic (one ``BV`` argument): + +``add``, ``sub``, ``mul``, ``opp`` + signed-wrap arithmetic on bitvectors of size ``n``. +``udiv``, ``urem``, ``sdiv``, ``srem`` + unsigned and signed division and remainder. - (*$*) bind circuit - (+^) <- "BVXOR_8". +Bitwise (one ``BV`` argument): -Here we have an example of attributing semantics coming from a -low level specification language (spec) file to an operator. -We remark again that these equivalences are trusted and so a -potential source of error and unsoundness. This will be subject -to change in the future, but until then the recommended way -to use them is to be very careful or otherwise just bind -operators which are abstract and use these bindings as an -axiomatization (proving lemmas about these through the use -of the circuit family of tactics which is able to make use -of these semantics). +``and``, ``or``, ``xor``, ``not`` + pointwise boolean operations. -The definition of the ``BVXOR_8`` operator in the spec language -is as follows:: +Constant shifts (one ``BV`` argument): + +``shl``, ``shr``, ``ashr`` + shift left, logical shift right, arithmetic (sign-extending) shift right. +``rol``, ``ror`` + rotate left, rotate right. + +Variable shifts (``BV & BV`` — value, amount): + +``shls``, ``shrs``, ``ashrs`` + shift left / logical shift right / arithmetic shift right where the + shift amount is itself a bitvector. + +Comparisons (``BV[1] & BV`` — result and operand): + +``ult``, ``ule``, ``slt``, ``sle`` + unsigned and signed strict and non-strict ordering, returning a + one-bit bitvector. + +Size manipulation (``BV & BV`` — source and target sizes): + +``zextend``, ``sextend`` + zero- and sign-extension to a wider bitvector. +``truncate`` + truncation to a narrower bitvector. +``insert``, ``extract``, ``aextract`` + insert/extract a sub-bitvector; ``aextract`` is the + arithmetic-extracting variant. +``concat`` (``BV & BV & BV``) + concatenation of two bitvectors. + +Bit-level indexing: + +``init`` (``BV[1] & BV``) + build a bitvector from a function ``int -> bit``. +``get`` (``BV & BV[1]``) + extract a single bit at a given index. + +Array primitives: + +``ainit`` (``BV & A``) + build an array of bitvectors from a function ``int -> BV``. +``asliceget`` (``BV & BV & A``), ``asliceset`` (``BV & BV & A``) + read/write a sub-bitvector slice spanning array cells. +``a2b`` (``BV & BV & A``), ``b2a`` (``BV & BV & A``) + reshape between a single wide bitvector and an array of bitvectors + whose concatenation has the same width. +``map`` (``BV & BV & A``) + pointwise map of a bitvector function over an array of bitvectors. + +------------------------------------------------------------------------ +Variant: ``bind circuit`` +------------------------------------------------------------------------ + +.. admonition:: Syntax + + ``bind circuit`` *op₁* ``<- "`` *name₁* ``" ,`` … ``,`` *opₖ* ``<- "`` *nameₖ* ``" from "`` *file* ``" .`` + +A non-empty comma-separated list of ``op <- "name"`` associations is +followed by a mandatory ``from ""`` clause naming the +``.spec`` file from which the named circuit definitions are loaded. + +.. warning:: + + The equivalences declared by ``bind circuit`` are **trusted**: no + proof obligation is generated, and so an incorrect binding silently + becomes part of the trusted computing base of every proof that + uses it. Use ``bind op`` whenever possible. The recommended use of + ``bind circuit`` is to attach circuit semantics to operators that + are otherwise abstract, treating the binding as an axiomatisation + rather than as a definition — proofs about the operator are then + discharged via the ``circuit`` tactic, which makes use of these + semantics. + +A typical use looks like the following (this example is shown as +plain text rather than as a checked proof because it depends on a +spec file outside the example's working directory):: + + require import AllCore List QFABV. + + type W8. + + op to_bits : W8 -> bool list. + op from_bits : bool list -> W8. + op of_int : int -> W8. + op to_uint : W8 -> int. + op to_sint : W8 -> int. + + bind bitstring + to_bits from_bits to_uint to_sint of_int W8 8. + (* ... realize side conditions ... *) + + op (+^) : W8 -> W8 -> W8. + + bind circuit + (+^) <- "BVXOR_8" from "specs.spec". + +The definition of the ``BVXOR_8`` circuit, in the +companion ``specs.spec`` file, is:: BVXOR_8(w1@8, w2@8) -> @8 = xor<8>(w1, w2) - -.. - This is similar to what is done to establish a correspondence - between the basic types and their counterparts in the SMTs. +Each ``op`` named in the binding list must already be declared, its +arity must match the corresponding spec definition, and every argument +and the return type must be ``bind bitstring``-bound to a bitstring of +the size declared in the spec. diff --git a/doc/tactics/circuit.rst b/doc/tactics/circuit.rst index 2381be15de..0e9887445a 100644 --- a/doc/tactics/circuit.rst +++ b/doc/tactics/circuit.rst @@ -1,77 +1,98 @@ - ======================================================================== Tactic: `circuit` ======================================================================== -The ``circuit`` tactic can be used to resolve a multitude of goals where -the semantics in question are over finite types. +The ``circuit`` tactic discharges or simplifies goals over finite +types by translating them into boolean circuits and reasoning about +the resulting bit-level representation. It applies to three goal +shapes — first-order propositions, Hoare triples, and program +equivalences — and has two modes, ``circuit`` and ``circuit +simplify``. -There are currently two variants of this tactic: +``circuit`` attempts to close the current goal by translating it into +a boolean circuit and checking that the circuit is identically true. -- `circuit`, which attempts to automatically solve/prove the goal +``circuit simplify`` performs the same translation but does not close +the goal: instead, it rewrites the postcondition using bit-level +equalities derived from the circuit, leaving a simpler residual goal +to be discharged by other tactics. -- `circuit simplify`, which performs a simplification over the goal structure - augmented by equivalence checks whenever an equality between two finite types - with bindings is encountered. +The translation uses the type and operator bindings declared by the +``bind`` family of commands (see :doc:`bindings`). Every type +appearing in the goal must be ``bind bitstring`` or ``bind array``; +every operator must be ``bind op`` or ``bind circuit``, or definable +in terms of bound operators; and every program statement must be an +assignment whose right-hand side translates to a circuit. .. contents:: :local: -.. - ------------------------------------------------------------------------ - Variant: ``circuit`` (FOL) - ------------------------------------------------------------------------ - .. ecproof:: - :title: First-order logic example - - require import AllCore List QFABV. - - type W8. - - op to_bits : W8 -> bool list. - op from_bits : bool list -> W8. - op of_int : int -> W8. - op to_uint : W8 -> int. - op to_sint : W8 -> int. - - bind bitstring - to_bits - from_bits - to_uint - to_sint - of_int - W8 - 8. - - realize gt0_size by admit. - realize tolistP by admit. - realize oflistP by admit. - realize touintP by admit. - realize tosintP by admit. - realize ofintP by admit. - realize size_tolist by admit. - - op (+^) : W8 -> W8 -> W8. - bind op W8 (+^) "xor". - realize bvxorP by admit. - - lemma L (w1 w2 : W8) : w1 +^ w2 = w2 +^ w1. - proof. - proc. (*$*) circuit solve. - abort. - - As we can see, the tactic can, through the generation of the appropriate - circuit representing validity of the proposition for a given value and - the equation of this function with the constant function equal to true, - establish the truth of the lemma. - This is, in a sense, a reverse use of function extensionality, to convert - statements about functions to statements about universal quantification. +------------------------------------------------------------------------ +Variant: ``circuit`` (FOL) +------------------------------------------------------------------------ + +When the goal is a first-order proposition (i.e., not a Hoare or +equivalence judgement), ``circuit`` translates the formula directly +into a boolean circuit and checks that it is a tautology. + +.. ecproof:: + :title: First-order example + + require import AllCore List QFABV. + + type W8. + + op to_bits : W8 -> bool list. + op from_bits : bool list -> W8. + op of_int : int -> W8. + op to_uint : W8 -> int. + op to_sint : W8 -> int. + bind bitstring + to_bits + from_bits + to_uint + to_sint + of_int + W8 + 8. + + realize gt0_size by admit. + realize tolistP by admit. + realize oflistP by admit. + realize touintP by admit. + realize tosintP by admit. + realize ofintP by admit. + realize size_tolist by admit. + + op (+^) : W8 -> W8 -> W8. + bind op W8 (+^) "xor". + realize bvxorP by admit. + + lemma L (w1 w2 : W8) : w1 +^ w2 = w2 +^ w1. + proof. + (*$*) circuit. + qed. + +The equality ``w1 +^ w2 = w2 +^ w1`` is translated into a boolean +circuit parameterised by the bits of ``w1`` and ``w2`` and equal to +``true`` exactly when the two sides agree. The tactic closes the goal +by checking that this circuit is identically true — in effect, a +case-analysis over all assignments of the input bits, but performed +symbolically on the circuit structure. + +The goal must contain no free type variables (the FOL case requires a +ground context). ------------------------------------------------------------------------ Variant: ``circuit`` (HL) ------------------------------------------------------------------------ +When the goal is a Hoare triple, ``circuit`` translates the +precondition, the program, and the postcondition into circuits and +checks that the postcondition circuit is implied by the precondition +on every initial state. + .. ecproof:: :title: Hoare logic example @@ -84,13 +105,13 @@ Variant: ``circuit`` (HL) op of_int : int -> W8. op to_uint : W8 -> int. op to_sint : W8 -> int. - + bind bitstring - to_bits - from_bits - to_uint + to_bits + from_bits + to_uint to_sint - of_int + of_int W8 8. @@ -117,37 +138,43 @@ Variant: ``circuit`` (HL) proc. (*$*) circuit. abort. - -As we can see from the output, the execution of the tactic has several components: - -- The translation of the precondition to a circuit, using any explicit equations - that define values of program variables at the start of execution in the further - construction of circuits henceforth. - -- The translation of the program to a (collection of) circuits. This is done instruction-wise - by keeping and updating a mapping from program variables to circuits determining how their - value is obtained from the value of some initial "input" variables. In the case of a program - these are either logical variables constraining initial values of program variables or the - program variables themselves, interpreted as symbols which are then universally quantified. - -- The translation of the postcondition into a circuit outputting a boolean, representing whether - the postcondition holds for given values of the input variables. The knowledge of how the - inputs relate to the outputs through the program and the knowledge of any initial relations - or known facts about these variables coming from the precondition or proof context is also - incorporated into this circuit. The goal of the tactic is then to prove that this circuit - is identically true for all values of the input, which is equivalent to the given hoare triple - being valid/true under the current proof context. - -In the case where the goal is an equality, some extra optimization are effected. -This corresponds to a heuristic inferrence procedure which tries to find structurally identical -conditions in order to avoid having to check the same condition more than once and also reduce -the number of inputs which are considered for each condition check, in order to reduce checking time. - +The execution proceeds in three phases: + +1. **Precondition processing.** The precondition is split along its + top-level conjunctions. Each equation of the form ``prog_var = + expr`` (in either direction) is treated as a definition: it is + added to the symbolic state and used to specialise the + construction of all later circuits. Each remaining clause that + translates to a boolean circuit is recorded as an antecedent; + clauses that do not translate are silently dropped. + +2. **Program translation.** The body is processed instruction by + instruction, maintaining a mapping from each program variable to + the circuit that computes its current value from the program's + inputs. The inputs are the program variables (treated as + universally quantified bit-vectors) together with any logical + variables constrained by the precondition. + +3. **Postcondition discharge.** The postcondition is split along its + conjuncts; each conjunct is translated into a boolean circuit + using the input-to-output map computed in phase 2. The tactic then + checks that, on every input satisfying the precondition + antecedents, every postcondition circuit is true. + +When the goal is an equality, the postcondition is decomposed +bit-by-bit and the tactic looks for structurally identical +sub-conditions across the bits, sharing them so that each input bit +is examined only once. ------------------------------------------------------------------------ Variant: ``circuit`` (rHL) ------------------------------------------------------------------------ +When the goal is a program equivalence (``equiv[M.f1 ~ M.f2 : pre +==> post]``), the tactic produces a separate input-to-output map for +each program, then checks that the postcondition relating the two +sides holds on every joint initial state satisfying the precondition. + .. ecproof:: :title: Program equivalence example @@ -160,13 +187,13 @@ Variant: ``circuit`` (rHL) op of_int : int -> W8. op to_uint : W8 -> int. op to_sint : W8 -> int. - + bind bitstring - to_bits - from_bits - to_uint + to_bits + from_bits + to_uint to_sint - of_int + of_int W8 8. @@ -201,10 +228,262 @@ Variant: ``circuit`` (rHL) proc. (*$*) circuit. abort. +------------------------------------------------------------------------ +Variant: ``circuit simplify`` +------------------------------------------------------------------------ + +``circuit simplify`` runs the same translation as ``circuit`` (HL) but +does not attempt to close the goal. Instead, it rewrites the +postcondition using the bit-level equalities derived from the circuit +translation of the program, then normalises by callbyvalue reduction. +The result is a new Hoare triple with the same precondition and +program but a simplified postcondition, which can then be discharged +by ordinary tactics. + +.. ecproof:: + :title: Simplification mode + + require import AllCore List QFABV. + + type W8. + + op to_bits : W8 -> bool list. + op from_bits : bool list -> W8. + op of_int : int -> W8. + op to_uint : W8 -> int. + op to_sint : W8 -> int. + + bind bitstring + to_bits + from_bits + to_uint + to_sint + of_int + W8 + 8. + + realize gt0_size by admit. + realize tolistP by admit. + realize oflistP by admit. + realize touintP by admit. + realize tosintP by admit. + realize ofintP by admit. + realize size_tolist by admit. + + op (+^) : W8 -> W8 -> W8. + bind op W8 (+^) "xor". + realize bvxorP by admit. + + module M = { + proc test (a : W8, b : W8) = { + var c : W8; + c <- a +^ b; + return c; + } + }. + + lemma L (a_ b_ : W8) : hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. + proof. + proc. (*$*) circuit simplify. trivial. + qed. + +Here the original postcondition ``res = a_ +^ b_`` becomes ``true`` +after the circuit-level simplification, which ``trivial`` then closes. +More generally, ``circuit simplify`` is useful as a preprocessing step +when the full ``circuit`` translation would succeed only on part of +the postcondition and other reasoning is needed for the rest. + +``circuit simplify`` only applies to Hoare triples. + +------------------------------------------------------------------------ +Failure modes +------------------------------------------------------------------------ + +Both ``circuit`` and ``circuit simplify`` may fail in the following +ways: + +``failed to verify postcondition`` + The translation succeeded but the resulting circuit is not a + tautology — i.e., the postcondition is genuinely false on some + input satisfying the precondition, or its translation was too weak + to capture the property. + +``exception(s) not supported`` + The Hoare triple's postcondition includes an + exception-monad invariant component; the circuit translation + handles only the pure (``inv``-empty) part of the goal. + +``circuit solve failed with error: …`` (or ``Circuit simplify failed with error: …``) + A ``CircError`` was raised during translation. The most common + causes are: an operator with no ``bind op`` or ``bind circuit`` + binding; a type with no ``bind bitstring`` or ``bind array`` + binding; a program statement that is not a translatable + assignment. + +``Wrong goal shape`` + ``circuit simplify`` was invoked on a goal that is not a Hoare + triple. + +------------------------------------------------------------------------ +Limitations +------------------------------------------------------------------------ + +- Program statements must be assignments whose right-hand sides + translate into circuits. Control flow (``if``, ``while``, ``match``) + and module/procedure calls are not handled — they must be + eliminated (e.g. via unrolling or inlining) before ``circuit`` is + invoked. +- Sampling statements (``<$``) and exception-raising statements are + not supported. +- Every type appearing in the goal must be either ``bind + bitstring``-bound to a concrete (non-abstract) size, or ``bind + array``-bound with a bound element type. +- The FOL variant additionally requires that the goal has no free + type variables. +- The cost of the equivalence check grows with the bit-width of the + variables and the depth of the resulting circuit; goals over + large bitstrings or with many independent inputs may be infeasible + to check directly. ``circuit simplify`` and the ``extens`` tactical + (see :doc:`extens`) are the usual escape hatches. + +======================================================================== +Tactic: ``proc change circuit`` +======================================================================== + +``proc change circuit`` rewrites a contiguous run of program +statements into an alternative block, using circuit equivalence as the +soundness check. Unlike the regular ``proc change`` — which generates +a separate proof obligation for the equivalence of the two fragments +— ``proc change circuit`` discharges that obligation automatically +through the same machinery as the ``circuit`` tactic. + +.. admonition:: Syntax + + ``proc change circuit`` *[bindings]*? *cpos* ``+`` *N* ``{`` *stmt* ``} .`` + +- *cpos* is the code position at which to begin rewriting. +- *N* is the number of source instructions to replace, starting at + *cpos*. +- *stmt* is the replacement block, enclosed in braces. +- *[bindings]* (optional) introduces fresh local variables visible + only inside the replacement block, using the standard + ``[x : ty, …]`` syntax. This lets the new code use intermediate + names that did not exist in the original procedure. + +The equivalence check considers only those variables that are +**live** at the end of the rewritten region — i.e., read by the rest +of the procedure body or by the postcondition. Variables written by +the replacement block but never read again may freely differ. + +.. ecproof:: + :title: Replacing a fragment with an equivalent one + + require import AllCore List QFABV. + + type W8. + + op to_bits : W8 -> bool list. + op from_bits : bool list -> W8. + op of_int : int -> W8. + op to_uint : W8 -> int. + op to_sint : W8 -> int. + + bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. + realize gt0_size by admit. + realize tolistP by admit. + realize oflistP by admit. + realize touintP by admit. + realize tosintP by admit. + realize ofintP by admit. + realize size_tolist by admit. + + op (+^) : W8 -> W8 -> W8. + bind op W8 (+^) "xor". + realize bvxorP by admit. + + module M = { + proc f (a : W8, b : W8) = { + var c : W8; + c <- a +^ b; + return c; + } + }. + + lemma swap_xor_args (a_ b_ : W8) : + hoare[M.f : a_ = a /\ b_ = b ==> res = a_ +^ b_]. + proof. + proc. + (*$*) proc change circuit 1 + 1 { c <- b +^ a; }. + circuit. + qed. + +The single instruction at code position ``1`` is replaced by +``c <- b +^ a``; the circuit-equivalence checker establishes that the +two fragments agree on the value of ``c``, which is the only variable +read downstream. + +.. ecproof:: + :title: Introducing a fresh local + + require import AllCore List QFABV. + + type W8. + + op to_bits : W8 -> bool list. + op from_bits : bool list -> W8. + op of_int : int -> W8. + op to_uint : W8 -> int. + op to_sint : W8 -> int. + + bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. + realize gt0_size by admit. + realize tolistP by admit. + realize oflistP by admit. + realize touintP by admit. + realize tosintP by admit. + realize ofintP by admit. + realize size_tolist by admit. + + op (+^) : W8 -> W8 -> W8. + bind op W8 (+^) "xor". + realize bvxorP by admit. + + module M = { + proc f (a : W8, b : W8) = { + var c : W8; + c <- a +^ b; + return c; + } + }. + + lemma with_fresh_local (a_ b_ : W8) : + hoare[M.f : a_ = a /\ b_ = b ==> res = a_ +^ b_]. + proof. + proc. + (*$*) proc change circuit [d : W8] 1 + 1 { d <- a; c <- d +^ b; }. + circuit. + qed. + +The ``[d : W8]`` binding introduces a fresh local that exists only +inside the replacement block; the original procedure body has no such +variable. + +------------------------------------------------------------------------ +Failure modes (``proc change circuit``) +------------------------------------------------------------------------ -As we can see in this example, the tactic is also able to automatically prove -equivalence of these two programs. The way this is done is similar to the way -that single procedures are handled, but now we consider two sets of transformations -from input to outputs variables, one for each program. We then use this knowledge -to convert the postcondition into the appropriate circuit and use the same procedure -to attempt to automatically discharge it. +``statements are not circuit-equivalent`` + Both fragments translated into circuits, but the equivalence check + failed. This means the rewrite is genuinely unsound on at least one + live output. (Use ``fail proc change circuit …`` to assert that a + rewrite is rejected — see ``tests/proc-change-circuit.ec`` for an + example.) + +``circuit-equivalence checker error: …`` + Translation of one of the fragments raised an exception. The + typical cause is the same as for ``circuit``: an unbound operator, + an unbound type, or a non-assignment instruction inside the + region being replaced. + +``exceptions not supported`` + The postcondition's exception-monad invariant is non-empty. diff --git a/doc/tactics/extens.rst b/doc/tactics/extens.rst new file mode 100644 index 0000000000..805a8b8323 --- /dev/null +++ b/doc/tactics/extens.rst @@ -0,0 +1,235 @@ +======================================================================== +Tactical: `extens` +======================================================================== + +``extens`` is a tactical that performs an extensionality-style +case-split: it enumerates the concrete values of a finite quantity, +generates one subgoal per case, and runs a user-supplied tactic on +each generated subgoal. The original goal closes only when every +subgoal closes. + +Two goal shapes are recognised, distinguished by the presence or +absence of the bracketed binder: + +- A first-order proposition of the form ``all P (iota_ start len)`` + (over ``int``) — no binder. The split produces one subgoal ``P i`` + per integer ``i`` in the range ``[start, start+len)``. + +- A Hoare triple ``hoare[M.f : pre ==> post]`` together with a binder + ``[v]`` naming a program variable. The variable's type must be + ``bind bitstring``-bound (see :doc:`bindings`). The split produces + ``2^n`` Hoare triples (with ``n`` the bound bitstring size), in + each of which the program variable ``v`` has been substituted by + the corresponding ``of_int i`` everywhere — in the program, in the + precondition, and in the postcondition. + +In both cases the inner tactic is then run on each generated subgoal. +If a subgoal fails to close, the residual goal is reported as an +error. + +.. admonition:: Syntax + + ``extens`` *[v]*? ``:`` *tactic* + +The bracketed binder ``[v]`` is required for the Hoare-triple variant +(it picks the program variable to enumerate) and forbidden for the +``iota_`` variant. + +The most common use is ``extens [v] : circuit`` (or, with +simplification first, ``extens [v] : (circuit simplify; ...)``). +The benefit over a bare ``circuit`` is that the per-case translation +sees a program in which one input has been replaced by a concrete +constant, which lets circuit translation succeed on programs whose +whole-input translation would fail or blow up. + +.. contents:: + :local: + +------------------------------------------------------------------------ +Variant: List enumeration over ``iota_`` +------------------------------------------------------------------------ + +.. ecproof:: + :title: List-all enumeration example + + require import AllCore List QFABV IntDiv. + + type W8. + + op to_bits : W8 -> bool list. + op from_bits : bool list -> W8. + op of_int : int -> W8. + op to_uint : W8 -> int. + op to_sint : W8 -> int. + + bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. + realize gt0_size by admit. + realize tolistP by admit. + realize oflistP by admit. + realize touintP by admit. + realize tosintP by admit. + realize ofintP by admit. + realize size_tolist by admit. + + op bool2bits (b : bool) : bool list = [b]. + op bits2bool (b : bool list) : bool = List.nth false b 0. + op i2b : int -> bool. + op b2si (b : bool) = 0. + + bind bitstring bool2bits bits2bool b2i b2si i2b bool 1. + realize gt0_size by done. + realize size_tolist by auto. + realize tolistP by auto. + realize oflistP by rewrite /bool2bits /bits2bool; smt(size_eq1). + realize touintP by admit. + realize tosintP by done. + realize ofintP by admit. + + op "_.[_]" : W8 -> int -> bool. + bind op [W8 & bool] "_.[_]" "get". + realize le_size by auto. + realize eq1_size by auto. + realize bvgetP by admit. + + lemma W8_ext (a : W8) : all (fun i => a.[i] = a.[i]) (iota_ 0 8). + proof. + (*$*) extens : circuit. + qed. + +The goal ``all (fun i => a.[i] = a.[i]) (iota_ 0 8)`` is split into +eight independent subgoals (one per ``i`` in ``[0, 8)``), each of +which is then discharged by ``circuit``. + +Both the ``start`` and ``len`` arguments of ``iota_`` must be ground +integer literals; ``extens`` rejects a non-constant range with +``Iota start should be constant`` or ``Iota length should be +constant``. + +------------------------------------------------------------------------ +Variant: Hoare-triple enumeration over a bitstring variable +------------------------------------------------------------------------ + +.. ecproof:: + :title: Hoare triple bitstring enumeration + + require import AllCore List QFABV IntDiv. + + type W8. + + op to_bits : W8 -> bool list. + op from_bits : bool list -> W8. + op of_int : int -> W8. + op to_uint : W8 -> int. + op to_sint : W8 -> int. + + bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. + realize gt0_size by admit. + realize tolistP by admit. + realize oflistP by admit. + realize touintP by admit. + realize tosintP by admit. + realize ofintP by admit. + realize size_tolist by admit. + + op (+^) : W8 -> W8 -> W8. + bind op W8 (+^) "xor". + realize bvxorP by admit. + + module M = { + proc test (a : W8, b : W8) = { + var c : W8; + c <- a +^ b; + return c; + } + }. + + lemma L (a_ b_ : W8) : + hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. + proof. + proc. + (*$*) extens [a] : (wp; skip; smt()). + qed. + +The binder ``[a]`` picks the program variable to enumerate. Since +``a : W8`` is bound to an eight-bit bitstring, the tactic produces +``2^8 = 256`` Hoare triples in which ``a`` has been replaced by each +concrete value ``of_int i``; the supplied tactic +``wp; skip; smt()`` then closes each. + +This pattern is most useful when the inner tactic is ``circuit`` +itself: replacing one program input by a concrete constant often lets +the per-case circuit translation succeed even when the +whole-program circuit translation would not. The same example with +``circuit`` as the inner tactic: + +.. ecproof:: + :title: Bitstring enumeration paired with ``circuit`` + + require import AllCore List QFABV IntDiv. + + type W8. + + op to_bits : W8 -> bool list. + op from_bits : bool list -> W8. + op of_int : int -> W8. + op to_uint : W8 -> int. + op to_sint : W8 -> int. + + bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. + realize gt0_size by admit. + realize tolistP by admit. + realize oflistP by admit. + realize touintP by admit. + realize tosintP by admit. + realize ofintP by admit. + realize size_tolist by admit. + + op (+^) : W8 -> W8 -> W8. + bind op W8 (+^) "xor". + realize bvxorP by admit. + + module M = { + proc test (a : W8, b : W8) = { + var c : W8; + c <- a +^ b; + return c; + } + }. + + lemma L (a_ b_ : W8) : + hoare[M.test : a_ = a /\ b_ = b ==> res = a_ +^ b_]. + proof. + (*$*) by proc; extens [a] : circuit. + qed. + +The ``2^n`` blow-up makes this variant practical only for small bit +widths: ``n = 8`` already produces 256 subgoals, and the cost grows +exponentially. + +------------------------------------------------------------------------ +Failure modes +------------------------------------------------------------------------ + +``Wrong goal shape`` + The goal is neither ``all _ (iota_ _ _)`` nor a Hoare triple, or + the binder presence does not match the goal shape (binder given on + an ``iota_`` goal, or omitted on a Hoare triple). + +``Failed to find var in memory `` + The bracketed binder names a variable that does not exist in the + Hoare triple's memory. + +``Failed to get size for type <τ>`` + The bracketed binder names a variable whose type is not + ``bind bitstring``-bound (or is bound only abstractly, without a + concrete size). Arrays are not currently supported for the binder. + +``Iota start should be constant`` / ``Iota length should be constant`` + The ``iota_`` arguments are not ground integer literals. + +``Unsupported List pattern`` + The list inside ``all`` is not of the form ``iota_ start len``. + +``Failed to close goal: `` + The inner tactic ran on every subgoal but left at least one + unclosed. The residual goal is reported as part of the error. From 724ec4c0a0690b845048afb6d5d6423835d082c7 Mon Sep 17 00:00:00 2001 From: Gustavo2622 Date: Thu, 11 Jun 2026 14:49:56 +0100 Subject: [PATCH 098/145] Circuit documentation --- doc/tactics/circuit.rst | 33 +++++++++++++++++++++++++++------ doc/tactics/extens.rst | 6 ++++++ 2 files changed, 33 insertions(+), 6 deletions(-) diff --git a/doc/tactics/circuit.rst b/doc/tactics/circuit.rst index 0e9887445a..d2848d1b9f 100644 --- a/doc/tactics/circuit.rst +++ b/doc/tactics/circuit.rst @@ -17,12 +17,21 @@ the goal: instead, it rewrites the postcondition using bit-level equalities derived from the circuit, leaving a simpler residual goal to be discharged by other tactics. -The translation uses the type and operator bindings declared by the -``bind`` family of commands (see :doc:`bindings`). Every type -appearing in the goal must be ``bind bitstring`` or ``bind array``; -every operator must be ``bind op`` or ``bind circuit``, or definable -in terms of bound operators; and every program statement must be an -assignment whose right-hand side translates to a circuit. +.. important:: + + The ``circuit`` family of tactics relies entirely on the + ``bind`` family of commands to know how EasyCrypt types and + operators correspond to their bit-level counterparts. Every type + appearing in the goal must be ``bind bitstring``- or ``bind + array``-bound; every operator must be ``bind op``- or ``bind + circuit``-bound, or definable in terms of bound operators; and + every program statement must be an assignment whose right-hand + side translates to a circuit. + + See :doc:`bindings` for the syntax and semantics of the ``bind`` + commands and the catalog of supported operator names — the + examples below all begin with ``bind`` declarations, whose side + conditions (the ``realize`` lines) come from that catalog. .. contents:: :local: @@ -57,6 +66,8 @@ into a boolean circuit and checks that it is a tautology. W8 8. + (* The realizes below discharge the side conditions left by + [bind bitstring]; refer to the [bind] command documentation. *) realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. @@ -115,6 +126,8 @@ on every initial state. W8 8. + (* The realizes below discharge the side conditions left by + [bind bitstring]; refer to the [bind] command documentation. *) realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. @@ -197,6 +210,8 @@ sides holds on every joint initial state satisfying the precondition. W8 8. + (* The realizes below discharge the side conditions left by + [bind bitstring]; refer to the [bind] command documentation. *) realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. @@ -262,6 +277,8 @@ by ordinary tactics. W8 8. + (* The realizes below discharge the side conditions left by + [bind bitstring]; refer to the [bind] command documentation. *) realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. @@ -389,6 +406,8 @@ the replacement block but never read again may freely differ. op to_sint : W8 -> int. bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. + (* The realizes below discharge the side conditions left by + [bind bitstring]; refer to the [bind] command documentation. *) realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. @@ -436,6 +455,8 @@ read downstream. op to_sint : W8 -> int. bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. + (* The realizes below discharge the side conditions left by + [bind bitstring]; refer to the [bind] command documentation. *) realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. diff --git a/doc/tactics/extens.rst b/doc/tactics/extens.rst index 805a8b8323..e5c88461fc 100644 --- a/doc/tactics/extens.rst +++ b/doc/tactics/extens.rst @@ -63,6 +63,8 @@ Variant: List enumeration over ``iota_`` op to_sint : W8 -> int. bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. + (* The realizes below discharge the side conditions left by + [bind bitstring]; refer to the [bind] command documentation. *) realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. @@ -123,6 +125,8 @@ Variant: Hoare-triple enumeration over a bitstring variable op to_sint : W8 -> int. bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. + (* The realizes below discharge the side conditions left by + [bind bitstring]; refer to the [bind] command documentation. *) realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. @@ -176,6 +180,8 @@ whole-program circuit translation would not. The same example with op to_sint : W8 -> int. bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. + (* The realizes below discharge the side conditions left by + [bind bitstring]; refer to the [bind] command documentation. *) realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. From b94be7b9fbba5cc5db061fb1a6d768ac27bb6f0c Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 09:13:43 +0200 Subject: [PATCH 099/145] circuit: render the SMT counter-model per input; rename circ_taut -> circ_valid The lazy counter-model is now read back one value per input rather than per bit: - smt.ml: model takes the inputs as (id, width) pairs and concatenates each input's size-1 bit variables (bit 0 most significant) into a single bitvector, rendered as one string. Bits the formula never referenced are allocated on readback so the value stays at the full declared width instead of compacting over gaps. - ecLowCircuits: model is (int * string) list; Backend.equiv/sat/valid take ~inps (the (id, width) list, derived from the circuit's cinp list via inps_of_cinps) only to feed the lazy model. circ_taut is renamed circ_valid throughout (and in ecCircuits / ecPhlBDep). - ecCircuits: check_with_model prints "input = ". Note: ~inps is currently a parameter of the backend queries (they build the lazy internally); folding it back to a model-only parameter is left for a follow-up. --- libs/lospecs/smt.ml | 52 +++++++++++++++++++++------------------- src/ecCircuits.ml | 8 +++---- src/ecCircuits.mli | 2 +- src/ecLowCircuits.ml | 56 +++++++++++++++++++++++-------------------- src/ecLowCircuits.mli | 11 ++++----- src/phl/ecPhlBDep.ml | 2 +- 6 files changed, 68 insertions(+), 63 deletions(-) diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index 5e3ec9de94..f5e19b308d 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -34,10 +34,10 @@ module type SMTInstance = sig (* bvterm concat, res sort is sum of sorts *) val bvterm_concat : bvterm -> bvterm -> bvterm - (* bvand *) + (* bvnot *) val bvnot : bvterm -> bvterm - (* bvnot *) + (* bvand *) val bvand : bvterm -> bvterm -> bvterm val get_value : solver -> bvterm -> bvterm val pp_term : Format.formatter -> bvterm -> unit @@ -48,17 +48,16 @@ end solver together with the per-query memoization tables. It is created per query (one solver per query gives assertion isolation) and carried explicitly. The queries return the decision; [model] reads the model - back from the same context and is only meaningful after a satisfiable - query, before the context's solver is re-used. Grouping the input bits - into per-input values is left to the caller. *) + back from the same context, one value per input, and is only meaningful + after a satisfiable query, before the context's solver is re-used. *) module type SMTInterface = sig type ctx val create : unit -> ctx val equiv : ctx -> reg -> reg -> node -> bool val sat : ctx -> node -> bool - val taut : ctx -> node -> bool - val model : ctx -> (int * int * string) list + val valid : ctx -> node -> bool + val model : ctx -> (int * int) list -> (int * string) list end (* ==================================================================== *) @@ -97,18 +96,24 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct Hashtbl.add ctx.vars (id, bit) bv; bv - (* Read back the solver's current model: the value of every input bit - the query materialized, keyed by its (id, bit). Only meaningful right - after a satisfiable query, and reads the live solver, so it must run - before the context's solver is re-used. The variables are taken from - [ctx.vars], so no variable naming happens here; grouping the bits - into per-input values is left to the caller. *) - let model (ctx : ctx) : (int * int * string) list = - Hashtbl.enum ctx.vars |> List.of_enum - |> List.map (fun ((id, bit), bv) -> - ( id, - bit, - Format.asprintf "%a" SMT.pp_term (SMT.get_value ctx.solver bv) )) + (* Read back the solver's current model, one value per input. [inps] + gives the inputs as (id, width) pairs; for each, the [width] size-1 + bit variables are concatenated into a single bitvector (bit 0 most + significant, as in the register encoding) and its value rendered as a + string. Bits the formula never referenced are allocated here so they + still appear (the solver assigns them a default), keeping the value at + the full declared width rather than compacting over gaps. Only + meaningful right after a satisfiable query, and reads the live solver, + so it must run before the context's solver is re-used. *) + let model (ctx : ctx) (inps : (int * int) list) : (int * string) list = + List.map + (fun (id, width) -> + let bv = + List.init width (fun bit -> var ctx id bit) + |> List.reduce SMT.bvterm_concat + in + id, Format.asprintf "%a" SMT.pp_term (SMT.get_value ctx.solver bv)) + inps (* Translate an AIG node to an SMT bitvector term, memoizing nodes and allocating the size-1 input variables in [ctx]. *) @@ -149,19 +154,16 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct let formula = SMT.bvterm_equal bvinpt1 bvinpt2 in let pcond = bvterm_of_node pcond in - SMT.assert' ctx.solver @@ SMT.bvand pcond (SMT.bvnot formula); - (* equivalent iff the disequality is unsat; a model is then a witness - to non-equivalence. *) + SMT.assert' ctx.solver (SMT.bvand pcond (SMT.bvnot formula)); not (SMT.check_sat ctx.solver) - (* TODO: better encoding of smt terms ? *) let sat (ctx : ctx) (n : Aig.node) : bool = let form = bvterm_of_node ctx n in - let form = SMT.(bvterm_equal form @@ bvterm_of_int 1 1) in + let form = SMT.(bvterm_equal form (bvterm_of_int 1 1)) in SMT.assert' ctx.solver form; SMT.check_sat ctx.solver - let taut (ctx : ctx) (n : Aig.node) : bool = not (sat ctx (Aig.neg n)) + let valid (ctx : ctx) (n : Aig.node) : bool = not (sat ctx (Aig.neg n)) end (* ==================================================================== *) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index f798789860..ad0a7b5ddc 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -44,9 +44,9 @@ let check_with_model (env : env) ((valid, model) : bool * model Lazy.t) : bool = if (not valid) && EcGState.get_circuit_debug_smt (EcEnv.gstate env) then begin EcEnv.notify ~immediate:true env `Warning "[debug_smt] counter-model:@."; List.iter - (fun (id, bit, value) -> - EcEnv.notify ~immediate:true env `Warning - "[debug_smt] input %d bit %d = %s@." id bit value) + (fun (id, value) -> + EcEnv.notify ~immediate:true env `Warning "[debug_smt] input %d = %s@." + id value) (Lazy.force model) end; valid @@ -943,7 +943,7 @@ let circ_simplify_form_bitstring_equality in check f -let circ_taut (c : circuit) : bool = fst (circ_taut c) +let circ_valid (c : circuit) : bool = fst (circ_valid c) let circuit_state_of_memenv ?(st : state = empty_state) diff --git a/src/ecCircuits.mli b/src/ecCircuits.mli index 0c8157851a..5f3b507bd2 100644 --- a/src/ecCircuits.mli +++ b/src/ecCircuits.mli @@ -56,7 +56,7 @@ val circ_red : hyps -> EcReduction.reduction_info val int_of_form : ?redmode:EcReduction.reduction_info -> hyps -> form -> BI.zint (* Use circuits *) -val circ_taut : circuit -> bool +val circ_valid : circuit -> bool (* Generate circuits *) (* Form processors *) diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index c2500881ad..a9c58c01a7 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -78,14 +78,15 @@ module type CBackend = sig val circuit_from_spec : Lospecs.Ast.adef -> reg list -> reg (* The queries return the decision and a lazy model: when forced, the - solver's value for each input bit it materialized, as (id, bit, - value) triples. Only meaningful (and only to be forced) when the - decision witnesses a counter-model. *) - type model = (int * int * string) list + solver's value for each input, as (id, value) pairs. [inps] gives the + inputs as (id, width) pairs, needed to render each at its full width. + The model is only meaningful (and only to be forced) when the decision + witnesses a counter-model. *) + type model = (int * string) list - val equiv : pcond:node -> reg -> reg -> bool * model Lazy.t - val sat : node -> bool * model Lazy.t - val taut : node -> bool * model Lazy.t + val equiv : inps:inp list -> pcond:node -> reg -> reg -> bool * model Lazy.t + val sat : inps:inp list -> node -> bool * model Lazy.t + val valid : inps:inp list -> node -> bool * model Lazy.t val slice : reg -> int -> int -> reg val subcirc : reg -> (int list) -> reg @@ -179,7 +180,7 @@ module LospecsBack : CBackend = struct type node = C.node type reg = C.node array type inp = int * int - type model = (int * int * string) list + type model = (int * string) list let pp_node (fmt : Format.formatter) (n: node) = Format.fprintf fmt "%a" (fun fmt -> Lospecs.Aig.pp_node fmt) n @@ -251,17 +252,17 @@ module LospecsBack : CBackend = struct let node_ite (c: node) (t: node) (f: node) = C.mux2 f t c let reg_ite (c: node) = Array.map2 (node_ite c) - let equiv ~(pcond: node) (r1: reg) (r2: reg) : bool * model Lazy.t = + let equiv ~(inps: inp list) ~(pcond: node) (r1: reg) (r2: reg) : bool * model Lazy.t = let ctx = CSMT.BWZ.create () in - (CSMT.BWZ.equiv ctx r1 r2 pcond, lazy (CSMT.BWZ.model ctx)) + (CSMT.BWZ.equiv ctx r1 r2 pcond, lazy (CSMT.BWZ.model ctx inps)) - let sat (n: node) : bool * model Lazy.t = + let sat ~(inps: inp list) (n: node) : bool * model Lazy.t = let ctx = CSMT.BWZ.create () in - (CSMT.BWZ.sat ctx n, lazy (CSMT.BWZ.model ctx)) + (CSMT.BWZ.sat ctx n, lazy (CSMT.BWZ.model ctx inps)) - let taut (n: node) : bool * model Lazy.t = + let valid ~(inps: inp list) (n: node) : bool * model Lazy.t = let ctx = CSMT.BWZ.create () in - (CSMT.BWZ.taut ctx n, lazy (CSMT.BWZ.model ctx)) + (CSMT.BWZ.valid ctx n, lazy (CSMT.BWZ.model ctx inps)) let slice (r: reg) (idx: int) (len: int) : reg = try Array.sub r idx len @@ -483,11 +484,10 @@ module type CircuitInterface = sig type 'a cfun = 'a * (cinp list) type circuit = circ cfun - (* A satisfying assignment, read back from the SMT solver: the value of - each input bit it materialized, as (id, bit, value) triples. The - queries below return it lazily, grouping into per-input values is - left to the caller. *) - type model = (int * int * string) list + (* A satisfying assignment, read back from the SMT solver: one value per + input it materialized, as (id, value) pairs. The queries below return + it lazily. *) + type model = (int * string) list val pp_flatcirc : Format.formatter -> flatcirc -> unit @@ -602,7 +602,7 @@ module type CircuitInterface = sig meaningful when the decision is a counter-model witness. *) val circ_equiv : ?pcond:circuit -> circuit -> circuit -> bool * model Lazy.t val circ_sat : circuit -> bool * model Lazy.t - val circ_taut : circuit -> bool * model Lazy.t + val circ_valid : circuit -> bool * model Lazy.t (* Composition of circuit functions, should deal with inputs and call some backend *) val circuit_compose : circuit -> circuit list -> circuit @@ -1068,6 +1068,10 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let circuit_has_uninitialized (c: circuit) : int option = Backend.have_bad (fst c).reg + (* The (id, width) of each input, for rendering a counter-model. *) + let inps_of_cinps (inps: cinp list) : Backend.inp list = + List.map (fun (i: cinp) -> (i.id, size_of_ctype i.type_)) inps + let circ_equiv ?(pcond:circuit option) ((c1, inps1): circuit) ((c2, inps2): circuit) : bool * Backend.model Lazy.t = let pcond = Option.map (convert_type CBool) pcond in (* Try to convert to bool *) let pcc = match pcond with @@ -1079,22 +1083,22 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (* This throws, but we let it propagate upwards *) let c2 = unify_inputs inps1 (c2, inps2) in if (c1.type_ = c2.type_) then - Backend.equiv ~pcond:pcc c1.reg c2.reg + Backend.equiv ~inps:(inps_of_cinps inps1) ~pcond:pcc c1.reg c2.reg else (false, lazy []) - let circ_sat ((c, _): circuit) : bool * Backend.model Lazy.t = + let circ_sat ((c, inps): circuit) : bool * Backend.model Lazy.t = let c = match c with | {type_ = CBool; reg} -> Backend.node_of_reg reg | _ -> lowcircerror CircSmtNonBoolCirc in - Backend.sat c + Backend.sat ~inps:(inps_of_cinps inps) c - let circ_taut ((c, _): circuit) : bool * Backend.model Lazy.t = + let circ_valid ((c, inps): circuit) : bool * Backend.model Lazy.t = let c = match c with | {type_ = CBool; reg} -> Backend.node_of_reg reg | _ -> lowcircerror CircSmtNonBoolCirc in - Backend.taut c + Backend.valid ~inps:(inps_of_cinps inps) c (* Inputs mean different things depending on circuit type *) (* Allow unaligned slices *) @@ -1325,7 +1329,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (* let res = fillet_taut pres post in *) let post = sublimate_inputs post in - let res = fst (circ_taut post) in + let res = fst (circ_valid post) in if not res then Option.may (fun f -> f @@ Format.asprintf "Failed for bit %d@." i) logger; res) posts |> diff --git a/src/ecLowCircuits.mli b/src/ecLowCircuits.mli index 6b6c11e109..2f7af43c91 100644 --- a/src/ecLowCircuits.mli +++ b/src/ecLowCircuits.mli @@ -37,11 +37,10 @@ type circ = { type 'a cfun = 'a * (cinp list) type circuit = circ cfun -(* A satisfying assignment read back from the SMT solver: the value of - each input bit it materialized, as (id, bit, value) triples. The - queries below return it lazily; grouping into per-input values is left - to the caller. *) -type model = (int * int * string) list +(* A satisfying assignment read back from the SMT solver: one value per + input it materialized, as (id, value) pairs. The queries below return + it lazily. *) +type model = (int * string) list val pp_flatcirc : Format.formatter -> flatcirc -> unit @@ -151,7 +150,7 @@ val circuit_has_uninitialized : circuit -> int option (* Logical reasoning over circuits *) val circ_equiv : ?pcond:circuit -> circuit -> circuit -> bool * model Lazy.t val circ_sat : circuit -> bool * model Lazy.t -val circ_taut : circuit -> bool * model Lazy.t +val circ_valid : circuit -> bool * model Lazy.t (* Composition of circuit functions *) val circuit_compose : circuit -> circuit list -> circuit diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index 0f5703d013..864a80c16b 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -224,7 +224,7 @@ let t_bdep_solve let cgoal = (circuit_of_form st hyps goal |> state_close_circuit st) in (* FIXME: make this lazy *) (* EcEnv.notify env `Debug "goal: %a@." pp_flatcirc (fst cgoal).reg; *) - if circ_taut cgoal then + if circ_valid cgoal then FApi.close (!@ tc) VBdep else tc_error (FApi.tc1_penv tc) "Failed to solve goal through circuit reasoning@\n" From c637cb570122f06dfecd86d527171a17f6702c01 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 10:04:16 +0200 Subject: [PATCH 100/145] examples: add circuit.ec demonstrating the circuit tactic family A focused, runnable example file over an abstract bound 8-bit word (bind side-conditions admitted, tactic usage real). Covers: - circuit (FOL): xor commutativity/associativity/self-inverse, and-comm; - circuit (HL): xor procedure, precondition-constrained inputs; - circuit (rHL): equivalence of commuted-xor procedures; - circuit simplify; - proc change circuit: plain rewrite and fresh-local form; - failure modes: false postcondition and unbound operator (fail circuit). Picked up automatically by the [test-examples] runner scenario. --- examples/circuit.ec | 181 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 181 insertions(+) create mode 100644 examples/circuit.ec diff --git a/examples/circuit.ec b/examples/circuit.ec new file mode 100644 index 0000000000..65392058fa --- /dev/null +++ b/examples/circuit.ec @@ -0,0 +1,181 @@ +(* ==================================================================== *) +(* Examples for the [circuit] tactic family. *) +(* *) +(* The [circuit] tactics discharge (or simplify) goals over finite *) +(* types by translating them into boolean circuits. They rely on the *) +(* [bind] commands to know how types and operators map to their *) +(* bit-level counterparts; see doc/tactics/{circuit,bindings}.rst. *) +(* *) +(* To keep the focus on the tactic itself, this file works over an *) +(* abstract 8-bit word [W8]: the [bind] side conditions (the [realize] *) +(* lines) are admitted. The tactic invocations below are real and run. *) +(* ==================================================================== *) +require import AllCore List QFABV IntDiv. + +(* -------------------------------------------------------------------- *) +(* An abstract bound word. [bind bitstring] connects the type [W8] to *) +(* its 8-bit representation; the [realize]s discharge the laws relating *) +(* the conversion operators (admitted here). *) +type W8. + +op to_bits : W8 -> bool list. +op from_bits : bool list -> W8. +op of_int : int -> W8. +op to_uint : W8 -> int. +op to_sint : W8 -> int. + +bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. + +realize gt0_size by admit. +realize tolistP by admit. +realize oflistP by admit. +realize touintP by admit. +realize tosintP by admit. +realize ofintP by admit. +realize size_tolist by admit. + +op zero : W8 = of_int 0. + +(* Bit-level operators, bound to their circuit gates by name. *) +op (+^) : W8 -> W8 -> W8. (* xor *) +bind op W8 (+^) "xor". +realize bvxorP by admit. + +op (&&&) : W8 -> W8 -> W8. (* and *) +bind op W8 (&&&) "and". +realize bvandP by admit. + +(* An operator with no circuit binding, used to illustrate a failure. *) +op opaque : W8 -> W8. + +(* ==================================================================== *) +(* Variant: [circuit] (FOL) *) +(* *) +(* On a first-order goal, [circuit] translates the proposition into a *) +(* circuit and checks that it is identically true. *) +(* ==================================================================== *) + +(* xor is commutative. *) +lemma xor_comm (a b : W8) : a +^ b = b +^ a. +proof. circuit. qed. + +(* xor is associative. *) +lemma xor_assoc (a b c : W8) : (a +^ b) +^ c = a +^ (b +^ c). +proof. circuit. qed. + +(* xor with itself is zero. *) +lemma xor_self (a : W8) : a +^ a = zero. +proof. circuit. qed. + +(* and distributes over... itself trivially; a small mixed-gate goal. *) +lemma and_comm (a b : W8) : a &&& b = b &&& a. +proof. circuit. qed. + +(* ==================================================================== *) +(* Variant: [circuit] (HL) *) +(* *) +(* On a Hoare triple, [circuit] translates the precondition, the *) +(* (assignment-only) program, and the postcondition, then checks the *) +(* postcondition holds on every input satisfying the precondition. *) +(* ==================================================================== *) + +module M = { + proc xor (a b : W8) : W8 = { + var c : W8; + c <- a +^ b; + return c; + } +}. + +lemma hl_xor (a_ b_ : W8) : + hoare[M.xor : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. proc; circuit. qed. + +(* The precondition can also constrain the inputs: with [a = b], the + result [a +^ b] is forced to [zero]. *) +lemma hl_xor_eq : hoare[M.xor : a = b ==> res = zero]. +proof. proc; circuit. qed. + +(* ==================================================================== *) +(* Variant: [circuit] (rHL) *) +(* *) +(* On an equivalence, [circuit] builds an input-to-output map for each *) +(* program and checks the relational postcondition on every joint *) +(* initial state satisfying the precondition. *) +(* ==================================================================== *) + +module N = { + proc f1 (a b : W8) : W8 = { + var c : W8; + c <- a +^ b; + return c; + } + + proc f2 (a b : W8) : W8 = { + var c : W8; + c <- b +^ a; + return c; + } +}. + +lemma rhl_xor_comm : equiv[N.f1 ~ N.f2 : ={arg} ==> ={res}]. +proof. proc; circuit. qed. + +(* ==================================================================== *) +(* Variant: [circuit simplify] *) +(* *) +(* Same translation as [circuit] (HL), but instead of closing the goal *) +(* it rewrites the postcondition with the bit-level equalities and *) +(* leaves a residual goal for ordinary tactics. *) +(* ==================================================================== *) + +lemma hl_simplify (a_ b_ : W8) : + hoare[M.xor : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. proc; circuit simplify; trivial. qed. + +(* ==================================================================== *) +(* [proc change circuit] *) +(* *) +(* Rewrite a run of statements into an equivalent block, discharging *) +(* the equivalence with the circuit checker. Only variables live after *) +(* the region need agree. *) +(* ==================================================================== *) + +lemma pcc_swap (a_ b_ : W8) : + hoare[M.xor : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. + proc. + (* replace [c <- a +^ b] by the commuted [c <- b +^ a] *) + proc change circuit 1 + 1 { c <- b +^ a; }. + circuit. +qed. + +(* The optional [bindings] introduce fresh locals visible only inside *) +(* the replacement block. *) +lemma pcc_fresh_local (a_ b_ : W8) : + hoare[M.xor : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. + proc. + proc change circuit [d : W8] 1 + 1 { d <- a; c <- d +^ b; }. + circuit. +qed. + +(* ==================================================================== *) +(* Failure modes *) +(* ==================================================================== *) + +(* A genuinely false postcondition: the circuit is not a tautology. *) +lemma fail_false (a_ b_ : W8) : + hoare[M.xor : a_ = a /\ b_ = b ==> res = a_ +^ zero]. +proof. + proc. + fail circuit. +abort. + +(* An operator with no circuit binding: translation raises an error. *) +lemma fail_translate (a_ b_ : W8) : + hoare[M.xor : a_ = a /\ b_ = b ==> res = opaque (a_ +^ b_)]. +proof. + proc. + fail circuit. +abort. From 9673b69521b01f17caa85fdb0844e76d8869c040 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 10:21:00 +0200 Subject: [PATCH 101/145] examples: add circuit examples over arrays and multiple word sizes MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit circuit_arrays.ec: [circuit] on a bound 8-element array — get/set laws (read-after-write same/other slot, set/set overwrite and commute), init/ainit composition of index permutations, and an in-program slot swap. circuit_words.ec: [circuit] at three widths (W8/W16/W32) with per-width xor/add, plus the size-changing operators concat (W8&W8->W16), zextend and truncate (W8<->W16) — including trunc (zext a) = a and a mixed-width program. Size-relation side conditions (le_size / eq_size) are discharged by done; the rest are admitted. Both pass and are picked up by the [test-examples] runner. --- examples/circuit_arrays.ec | 126 +++++++++++++++++++++++++++++++++++++ examples/circuit_words.ec | 113 +++++++++++++++++++++++++++++++++ 2 files changed, 239 insertions(+) create mode 100644 examples/circuit_arrays.ec create mode 100644 examples/circuit_words.ec diff --git a/examples/circuit_arrays.ec b/examples/circuit_arrays.ec new file mode 100644 index 0000000000..f6c2da49da --- /dev/null +++ b/examples/circuit_arrays.ec @@ -0,0 +1,126 @@ +(* ==================================================================== *) +(* [circuit] over arrays. *) +(* *) +(* [bind array] connects a polymorphic type constructor to a fixed-size *) +(* array of bit-vectors, and auto-registers its [get]/[set] operators *) +(* for circuit translation. Array-producing operators (like [init]) are *) +(* bound with the multi-type [bind op [Elt & Arr] ... "ainit"] form. *) +(* *) +(* As in examples/circuit.ec, the [bind] side conditions are admitted; *) +(* the tactic invocations are real and run. *) +(* ==================================================================== *) +require import AllCore List QFABV IntDiv. + +(* -------------------------------------------------------------------- *) +(* An abstract 8-bit element word, with xor. *) +type W8. + +op to_bits : W8 -> bool list. +op from_bits : bool list -> W8. +op of_int : int -> W8. +op to_uint : W8 -> int. +op to_sint : W8 -> int. + +bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. + +realize gt0_size by admit. +realize tolistP by admit. +realize oflistP by admit. +realize touintP by admit. +realize tosintP by admit. +realize ofintP by admit. +realize size_tolist by admit. + +op (+^) : W8 -> W8 -> W8. +bind op W8 (+^) "xor". +realize bvxorP by admit. + +(* -------------------------------------------------------------------- *) +(* A length-8 array of elements. [bind array] gives the read/write *) +(* operators ["_.[_]"]/["_.[_<-_]"], the list view, and the size. *) +theory A. + type 'a t. + + op tolist : 'a t -> 'a list. + op oflist : 'a -> 'a list -> 'a t. + op "_.[_]" : 'a t -> int -> 'a. + op "_.[_<-_]" : 'a t -> int -> 'a -> 'a t. +end A. + +bind array A."_.[_]" A."_.[_<-_]" A.tolist A.oflist A.t 8. + +realize gt0_size by admit. +realize tolistP by admit. +realize oflistP by admit. +realize eqP by admit. +realize get_setP by admit. +realize get_out by admit. + +(* Bring the array read/write operators into scope so the [a.[i]] and + [a.[i <- v]] bracket notations resolve. *) +export A. + +(* ==================================================================== *) +(* get / set *) +(* *) +(* The array read/write operators translate directly once [bind array] *) +(* has registered them. Indices must be concrete (statically known). *) +(* ==================================================================== *) + +(* Reading back the slot just written returns the written value. *) +lemma get_set_same (a : W8 A.t) (v : W8) : a.[3 <- v].[3] = v. +proof. circuit. qed. + +(* Writing one slot leaves another untouched. *) +lemma get_set_other (a : W8 A.t) (v : W8) : a.[3 <- v].[5] = a.[5]. +proof. circuit. qed. + +(* Two writes to the same slot: the last one wins. *) +lemma set_set_same (a : W8 A.t) (v w : W8) : a.[2 <- v].[2 <- w] = a.[2 <- w]. +proof. circuit. qed. + +(* Writes to distinct slots commute. *) +lemma set_set_swap (a : W8 A.t) (v w : W8) : + a.[1 <- v].[6 <- w] = a.[6 <- w].[1 <- v]. +proof. circuit. qed. + +(* ==================================================================== *) +(* init (ainit) *) +(* *) +(* [ainit f] builds the array whose slot [i] holds [f i]. Bound via the *) +(* multi-type [bind op [W8 & A.t] ... "ainit"]. *) +(* ==================================================================== *) + +op init (f : int -> W8) : W8 A.t. +bind op [W8 & A.t] init "ainit". +realize bvainitP by admit. + +op get : W8 A.t -> int -> W8 = A."_.[_]". + +(* Composing two index permutations under [init] collapses to a single + pass: reading [_a] at [(i*5)%%8] then re-indexing by [(i*3)%%8] equals + the direct composite permutation. The circuit checker verifies the + two array-valued expressions agree slot-by-slot. *) +lemma init_compose (_a : W8 A.t) : + init (fun i => get (init (fun k => get _a ((k * 5) %% 8))) ((i * 3) %% 8)) + = init (fun i => get _a (((i * 3) %% 8 * 5) %% 8)). +proof. circuit. qed. + +(* ==================================================================== *) +(* Arrays in a program *) +(* ==================================================================== *) + +module M = { + proc swap2 (a : W8 A.t) : W8 A.t = { + var t : W8; + t <- a.[0]; + a <- a.[0 <- a.[1]]; + a <- a.[1 <- t]; + return a; + } +}. + +(* Swapping slots 0 and 1 via a temporary is the two commuted writes. *) +lemma hl_swap2 (a_ : W8 A.t) : + hoare[M.swap2 : a = a_ ==> res = a_.[0 <- a_.[1]].[1 <- a_.[0]]]. +proof. proc; circuit. qed. diff --git a/examples/circuit_words.ec b/examples/circuit_words.ec new file mode 100644 index 0000000000..73147955c7 --- /dev/null +++ b/examples/circuit_words.ec @@ -0,0 +1,113 @@ +(* ==================================================================== *) +(* [circuit] over words of several sizes. *) +(* *) +(* Each width is a separate [bind bitstring]-bound type with its own *) +(* operators (suffixed by the width to keep them distinct). Size- *) +(* changing operators (concat, zextend, truncate) are multi-type *) +(* [bind op]s relating two (or three) widths. *) +(* *) +(* As elsewhere, the [bind] side conditions are admitted; the tactic *) +(* invocations are real and run. *) +(* ==================================================================== *) +require import AllCore List QFABV IntDiv. + +(* -------------------------------------------------------------------- *) +(* An 8-bit word. *) +type W8. +op to_bits8 : W8 -> bool list. op from_bits8 : bool list -> W8. +op of_int8 : int -> W8. op to_uint8 : W8 -> int. +op to_sint8 : W8 -> int. + +bind bitstring to_bits8 from_bits8 to_uint8 to_sint8 of_int8 W8 8. +realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. +realize touintP by admit. realize tosintP by admit. realize ofintP by admit. +realize size_tolist by admit. + +op xor8 : W8 -> W8 -> W8. bind op W8 xor8 "xor". realize bvxorP by admit. + +(* -------------------------------------------------------------------- *) +(* A 16-bit word. *) +type W16. +op to_bits16 : W16 -> bool list. op from_bits16 : bool list -> W16. +op of_int16 : int -> W16. op to_uint16 : W16 -> int. +op to_sint16 : W16 -> int. + +bind bitstring to_bits16 from_bits16 to_uint16 to_sint16 of_int16 W16 16. +realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. +realize touintP by admit. realize tosintP by admit. realize ofintP by admit. +realize size_tolist by admit. + +op xor16 : W16 -> W16 -> W16. bind op W16 xor16 "xor". realize bvxorP by admit. +op add16 : W16 -> W16 -> W16. bind op W16 add16 "add". realize bvaddP by admit. + +(* -------------------------------------------------------------------- *) +(* A 32-bit word. *) +type W32. +op to_bits32 : W32 -> bool list. op from_bits32 : bool list -> W32. +op of_int32 : int -> W32. op to_uint32 : W32 -> int. +op to_sint32 : W32 -> int. + +bind bitstring to_bits32 from_bits32 to_uint32 to_sint32 of_int32 W32 32. +realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. +realize touintP by admit. realize tosintP by admit. realize ofintP by admit. +realize size_tolist by admit. + +op xor32 : W32 -> W32 -> W32. bind op W32 xor32 "xor". realize bvxorP by admit. +op add32 : W32 -> W32 -> W32. bind op W32 add32 "add". realize bvaddP by admit. + +(* ==================================================================== *) +(* Same-size reasoning at each width *) +(* ==================================================================== *) + +lemma xor_comm8 (a b : W8) : xor8 a b = xor8 b a by circuit. +lemma xor_comm16 (a b : W16) : xor16 a b = xor16 b a by circuit. +lemma xor_comm32 (a b : W32) : xor32 a b = xor32 b a by circuit. + +(* add is commutative at 32 bits. *) +lemma add_comm32 (a b : W32) : add32 a b = add32 b a by circuit. + +(* A slightly deeper 16-bit goal. *) +lemma xor_rot16 (a b c : W16) : + xor16 (xor16 a b) c = xor16 (xor16 c a) b by circuit. + +(* ==================================================================== *) +(* concat : combine two W8s into a W16 *) +(* ==================================================================== *) + +op concat8 : W8 -> W8 -> W16. +bind op [W8 & W8 & W16] concat8 "concat". +realize eq_size by done. (* 8 + 8 = 16 *) +realize bvconcatP by admit. + +(* ==================================================================== *) +(* zextend / truncate : move between W8 and W16 *) +(* ==================================================================== *) + +op zext : W8 -> W16. +bind op [W8 & W16] zext "zextend". +realize le_size by done. (* 8 <= 16 *) +realize bvzextendP by admit. + +op trunc : W16 -> W8. +bind op [W16 & W8] trunc "truncate". +realize le_size by done. (* 8 <= 16 *) +realize bvtruncateP by admit. + +(* Truncating a zero-extended word returns the original. *) +lemma trunc_zext (a : W8) : trunc (zext a) = a by circuit. + +(* ==================================================================== *) +(* A small program mixing widths *) +(* ==================================================================== *) + +module M = { + proc widen_xor (a b : W8) : W16 = { + var r : W16; + r <- zext (xor8 a b); + return r; + } +}. + +lemma hl_widen_xor (a_ b_ : W8) : + hoare[M.widen_xor : a_ = a /\ b_ = b ==> res = zext (xor8 a_ b_)]. +proof. proc; circuit. qed. From bea610c2eea1d860daa6ca991690878c3d240d45 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 10:25:44 +0200 Subject: [PATCH 102/145] examples: add extens.ec demonstrating the extens tactical Covers both variants of [extens]: - iota_ enumeration: per-bit reflexivity and bitwise xor-commutativity over [iota_ 0 8], each split into 8 subgoals closed by circuit (needs the [W8 & bool] "get" bit-access binding + bool-as-size-1 bitstring); - Hoare-triple enumeration with a binder [a] over the 8-bit input (2^8 = 256 cases), with three inner tactics: circuit, circuit simplify, and a plain wp/skip/smt pass (showing the inner tactic need not be circuit). Picked up by the [test-examples] runner. --- examples/extens.ec | 116 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 116 insertions(+) create mode 100644 examples/extens.ec diff --git a/examples/extens.ec b/examples/extens.ec new file mode 100644 index 0000000000..438113fdfa --- /dev/null +++ b/examples/extens.ec @@ -0,0 +1,116 @@ +(* ==================================================================== *) +(* The [extens] tactical. *) +(* *) +(* [extens] performs an extensionality-style case split, enumerating a *) +(* finite quantity and running an inner tactic on each case. Two shapes: *) +(* *) +(* - [all P (iota_ start len)] (no binder): one subgoal [P i] per *) +(* integer i in [start, start+len); *) +(* - [hoare[M.f : pre ==> post]] with a binder [v] naming a bound *) +(* bitstring program variable: 2^n subgoals, one per concrete value *) +(* of v. *) +(* *) +(* The usual use is [extens [v] : circuit] — replacing one input by a *) +(* concrete constant per case lets circuit translation succeed where a *) +(* whole-input translation might not. See doc/tactics/extens.rst. *) +(* *) +(* As elsewhere, the [bind] side conditions are admitted where they *) +(* would need real proofs; the tactic invocations are real and run. *) +(* ==================================================================== *) +require import AllCore List QFABV IntDiv. + +(* -------------------------------------------------------------------- *) +(* An abstract 8-bit word with xor. *) +type W8. + +op to_bits : W8 -> bool list. +op from_bits : bool list -> W8. +op of_int : int -> W8. +op to_uint : W8 -> int. +op to_sint : W8 -> int. + +bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. +realize gt0_size by admit. +realize tolistP by admit. +realize oflistP by admit. +realize touintP by admit. +realize tosintP by admit. +realize ofintP by admit. +realize size_tolist by admit. + +op (+^) : W8 -> W8 -> W8. +bind op W8 (+^) "xor". +realize bvxorP by admit. + +(* -------------------------------------------------------------------- *) +(* [bool] as a size-1 bitstring: the per-bit output type that the array- *) +(* style bit-access operator [get] returns. *) +op bool2bits (b : bool) : bool list = [b]. +op bits2bool (b : bool list) : bool = List.nth false b 0. +op i2b : int -> bool. +op b2si (b : bool) = 0. + +bind bitstring bool2bits bits2bool b2i b2si i2b bool 1. +realize gt0_size by done. +realize size_tolist by auto. +realize tolistP by auto. +realize oflistP by rewrite /bool2bits /bits2bool; smt(size_eq1). +realize touintP by admit. +realize tosintP by done. +realize ofintP by admit. + +(* The bit-access operator: [a.[i]] is bit i of [a]. [extens] over an + [iota_] range needs this to express the per-bit subgoals. *) +op "_.[_]" : W8 -> int -> bool. +bind op [W8 & bool] "_.[_]" "get". +realize le_size by auto. +realize eq1_size by auto. +realize bvgetP by admit. + +(* ==================================================================== *) +(* Variant: list enumeration over [iota_] *) +(* *) +(* [all (fun i => P i) (iota_ 0 8)] splits into the 8 subgoals [P 0], *) +(* ..., [P 7], each discharged by the inner tactic. *) +(* ==================================================================== *) + +(* Trivial per-bit reflexivity (the canonical first example). *) +lemma ext_refl (a : W8) : all (fun i => a.[i] = a.[i]) (iota_ 0 8). +proof. extens : circuit. qed. + +(* A real per-bit fact: xor is bitwise-commutative at every index. *) +lemma ext_xor_comm (a b : W8) : + all (fun i => (a +^ b).[i] = (b +^ a).[i]) (iota_ 0 8). +proof. extens : circuit. qed. + +(* ==================================================================== *) +(* Variant: Hoare-triple enumeration over a bitstring variable *) +(* *) +(* The binder [a] picks the program variable to enumerate; since *) +(* [a : W8] is 8 bits, this produces 2^8 = 256 subgoals in which [a] is *) +(* replaced by each concrete [of_int i]. The inner tactic closes each. *) +(* ==================================================================== *) + +module M = { + proc xor (a b : W8) : W8 = { + var c : W8; + c <- a +^ b; + return c; + } +}. + +(* Inner tactic = circuit: each per-constant case is a circuit goal. *) +lemma ext_hoare_circuit (a_ b_ : W8) : + hoare[M.xor : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. by proc; extens [a] : circuit. qed. + +(* Inner tactic = circuit simplify then trivial. *) +lemma ext_hoare_simplify (a_ b_ : W8) : + hoare[M.xor : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. proc; extens [a] : by circuit simplify; trivial. qed. + +(* Inner tactic need not be circuit at all: any tactic closing each + per-constant case works (here a plain weakest-precondition pass). *) +lemma ext_hoare_wp (a_ b_ : W8) : + hoare[M.xor : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. proc; extens [a] : (wp; skip; smt()). qed. From d15a6bf5c7b6c92c835d459f268f39241b15dded Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 10:53:08 +0200 Subject: [PATCH 103/145] circuit: read the SMT counter-model from the solved circuit's variables MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The lazy counter-model used to be reconstructed from externally-supplied (id, width) pairs (circ1's cinp ids), but input unification renames the AIG input ids actually asserted in the solver, so model lookup named variables absent from the formula and get_value returned solver defaults (all-zero non-witnesses). Read the model back from ctx.vars instead — exactly the input bits the query materialized — so the values are always those of variables the solver constrained. This also drops the ~inps parameter threaded through Backend.equiv/sat/valid and CSMT.circ_equiv/sat/valid, and the inps_of_cinps helper. (Surfaced a separate, pre-existing soundness bug in proc change circuit: instrs_equiv collapses distinct program variables to one uninitialized input. Recorded for a follow-up; not addressed here.) --- libs/lospecs/smt.ml | 38 +++++++++++++++++++++----------------- src/ecLowCircuits.ml | 39 +++++++++++++++++---------------------- 2 files changed, 38 insertions(+), 39 deletions(-) diff --git a/libs/lospecs/smt.ml b/libs/lospecs/smt.ml index cb2d8d336f..c72c864947 100644 --- a/libs/lospecs/smt.ml +++ b/libs/lospecs/smt.ml @@ -64,7 +64,7 @@ module type SMTInterface = sig val equiv : ctx -> reg -> reg -> node -> bool val sat : ctx -> node -> bool val valid : ctx -> node -> bool - val model : ctx -> (int * int) list -> (int * string) list + val model : ctx -> (int * string) list end (* ==================================================================== *) @@ -103,24 +103,28 @@ module MakeSMTInterface (SMT : SMTInstance) : SMTInterface = struct Hashtbl.add ctx.vars (id, bit) bv; bv - (* Read back the solver's current model, one value per input. [inps] - gives the inputs as (id, width) pairs; for each, the [width] size-1 - bit variables are concatenated into a single bitvector (bit 0 most - significant, as in the register encoding) and its value rendered as a - string. Bits the formula never referenced are allocated here so they - still appear (the solver assigns them a default), keeping the value at - the full declared width rather than compacting over gaps. Only + (* Read back the solver's current model, one value per input. We report + exactly the input bits the query materialized — the contents of + [ctx.vars] — so the values are always those of variables the solver + actually constrained (reading externally-supplied ids could name + variables absent from the formula, whose model value is an arbitrary + default). Bits are grouped by input id and concatenated, lowest bit + last (bit 0 most significant, as in the register encoding). Only meaningful right after a satisfiable query, and reads the live solver, so it must run before the context's solver is re-used. *) - let model (ctx : ctx) (inps : (int * int) list) : (int * string) list = - List.map - (fun (id, width) -> - let bv = - List.init width (fun bit -> var ctx id bit) - |> List.reduce SMT.bvterm_concat - in - id, Format.asprintf "%a" SMT.pp_term (SMT.get_value ctx.solver bv)) - inps + let model (ctx : ctx) : (int * string) list = + Hashtbl.enum ctx.vars |> List.of_enum + (* group the (id, bit) -> term entries by input id *) + |> List.group (fun ((id1, _), _) ((id2, _), _) -> Int.compare id1 id2) + |> List.map (fun bits -> + let id = fst (fst (List.hd bits)) in + let bv = + bits + |> List.sort (fun ((_, b1), _) ((_, b2), _) -> Int.compare b1 b2) + |> List.map snd + |> List.reduce SMT.bvterm_concat + in + id, Format.asprintf "%a" SMT.pp_term (SMT.get_value ctx.solver bv)) (* Translate an AIG node to an SMT bitvector term, memoizing nodes and allocating the size-1 input variables in [ctx]. *) diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index 4d5a4c29bd..6cdb691b08 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -78,15 +78,14 @@ module type CBackend = sig val circuit_from_spec : Lospecs.Ast.adef -> reg list -> reg (* The queries return the decision and a lazy model: when forced, the - solver's value for each input, as (id, value) pairs. [inps] gives the - inputs as (id, width) pairs, needed to render each at its full width. - The model is only meaningful (and only to be forced) when the decision - witnesses a counter-model. *) + solver's value for each input the query materialized, as (id, value) + pairs read back from the solved circuit. Only meaningful (and only to + be forced) when the decision witnesses a counter-model. *) type model = (int * string) list - val equiv : inps:inp list -> pcond:node -> reg -> reg -> bool * model Lazy.t - val sat : inps:inp list -> node -> bool * model Lazy.t - val valid : inps:inp list -> node -> bool * model Lazy.t + val equiv : pcond:node -> reg -> reg -> bool * model Lazy.t + val sat : node -> bool * model Lazy.t + val valid : node -> bool * model Lazy.t val slice : reg -> int -> int -> reg val subcirc : reg -> (int list) -> reg @@ -249,17 +248,17 @@ module LospecsBack : CBackend = struct let node_ite (c: node) (t: node) (f: node) = C.mux2 f t c let reg_ite (c: node) = Array.map2 (node_ite c) - let equiv ~(inps: inp list) ~(pcond: node) (r1: reg) (r2: reg) : bool * model Lazy.t = + let equiv ~(pcond: node) (r1: reg) (r2: reg) : bool * model Lazy.t = let ctx = CSMT.BWZ.create () in - (CSMT.BWZ.equiv ctx r1 r2 pcond, lazy (CSMT.BWZ.model ctx inps)) + (CSMT.BWZ.equiv ctx r1 r2 pcond, lazy (CSMT.BWZ.model ctx)) - let sat ~(inps: inp list) (n: node) : bool * model Lazy.t = + let sat (n: node) : bool * model Lazy.t = let ctx = CSMT.BWZ.create () in - (CSMT.BWZ.sat ctx n, lazy (CSMT.BWZ.model ctx inps)) + (CSMT.BWZ.sat ctx n, lazy (CSMT.BWZ.model ctx)) - let valid ~(inps: inp list) (n: node) : bool * model Lazy.t = + let valid (n: node) : bool * model Lazy.t = let ctx = CSMT.BWZ.create () in - (CSMT.BWZ.valid ctx n, lazy (CSMT.BWZ.model ctx inps)) + (CSMT.BWZ.valid ctx n, lazy (CSMT.BWZ.model ctx)) let slice (r: reg) (idx: int) (len: int) : reg = try Array.sub r idx len @@ -1059,10 +1058,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let circuit_has_uninitialized (c: circuit) : int option = Backend.have_bad (fst c).reg - (* The (id, width) of each input, for rendering a counter-model. *) - let inps_of_cinps (inps: cinp list) : Backend.inp list = - List.map (fun (i: cinp) -> (i.id, size_of_ctype i.type_)) inps - let circ_equiv ?(pcond:circuit option) ((c1, inps1): circuit) ((c2, inps2): circuit) : bool * Backend.model Lazy.t = let pcond = Option.map (convert_type CBool) pcond in (* Try to convert to bool *) let pcc = match pcond with @@ -1074,22 +1069,22 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (* This throws, but we let it propagate upwards *) let c2 = unify_inputs inps1 (c2, inps2) in if (c1.type_ = c2.type_) then - Backend.equiv ~inps:(inps_of_cinps inps1) ~pcond:pcc c1.reg c2.reg + Backend.equiv ~pcond:pcc c1.reg c2.reg else (false, lazy []) - let circ_sat ((c, inps): circuit) : bool * Backend.model Lazy.t = + let circ_sat ((c, _): circuit) : bool * Backend.model Lazy.t = let c = match c with | {type_ = CBool; reg} -> Backend.node_of_reg reg | _ -> lowcircerror CircSmtNonBoolCirc in - Backend.sat ~inps:(inps_of_cinps inps) c + Backend.sat c - let circ_valid ((c, inps): circuit) : bool * Backend.model Lazy.t = + let circ_valid ((c, _): circuit) : bool * Backend.model Lazy.t = let c = match c with | {type_ = CBool; reg} -> Backend.node_of_reg reg | _ -> lowcircerror CircSmtNonBoolCirc in - Backend.valid ~inps:(inps_of_cinps inps) c + Backend.valid c (* Inputs mean different things depending on circuit type *) (* Allow unaligned slices *) From 0357c262a33a0b3d02ccecc557a6225b86703d63 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 10:59:22 +0200 Subject: [PATCH 104/145] circuit: fix proc change circuit unsoundness (collapsed inputs) instrs_equiv opened its read/written program variables as circuit inputs via the ident-based open_circ_lambda (under fresh `create v_name` idents), which never populates the (memory, name) -> ident table that Fpvar reads consult. So every program-variable read missed the table and fell through to circuit_uninit, collapsing ALL variables to one shared uninitialized input. Two distinct expressions over those variables then compared equal, so proc change circuit accepted non-equivalent rewrites (e.g. replacing `c <- a +^ b` by `c <- zero`). Open the inputs as program variables with open_circ_lambda_pv, keyed by (mem, name), deduping a variable that is both read and written. Also fix the surrounding error handling in ecPhlRwPrgm: the "statements are not circuit-equivalent" tc_error sat inside the try whose handler caught all exceptions, so a legitimate rejection was re-reported as a "circuit-equivalence checker error: TcError(_)". Guard only the checker call; raise the rejection outside. --- src/ecCircuits.ml | 19 ++++++++++--------- src/phl/ecPhlRwPrgm.ml | 14 +++++++------- 2 files changed, 17 insertions(+), 16 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index ba54aeae1e..4ab18ab56b 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -862,17 +862,18 @@ let instrs_equiv if not (List.for_all (EcTypes.is_loc -| fst) (rd @ wr)) then circ_error CantReadWriteGlobs; + (* Open the read/written program variables as the circuit inputs, keyed + by their (memory, name) so that [Fpvar] reads in [process_instr] + resolve to them. Opening them with the ident-based [open_circ_lambda] + (under fresh idents) would leave every read unbound, collapsing all + variables to a single uninitialized input. A variable that is both + read and written must be opened only once. *) let inputs = - List.map - (fun (pv, ty) -> {v_name = EcTypes.get_loc pv; v_type = ty}) - (rd @ wr) + List.map (fun (pv, ty) -> (EcTypes.get_loc pv, ty)) (rd @ wr) + |> List.sort_uniq (fun (a, _) (b, _) -> String.compare a b) + |> List.map (fun (s, ty) -> ((mem, s), ctype_of_ty env ty)) in - let inputs = - List.map - (fun {v_name; v_type} -> create v_name, ctype_of_ty env v_type) - inputs - in - let st = open_circ_lambda st inputs in + let st = open_circ_lambda_pv st inputs in let st1 = List.fold_left (fun st -> process_instr hyps mem ~st) st s1 in let st2 = List.fold_left (fun st -> process_instr hyps mem ~st) st s2 in diff --git a/src/phl/ecPhlRwPrgm.ml b/src/phl/ecPhlRwPrgm.ml index 852d5748ed..1411dce86a 100644 --- a/src/phl/ecPhlRwPrgm.ml +++ b/src/phl/ecPhlRwPrgm.ml @@ -75,13 +75,13 @@ let process_change ((cpos, bindings, i, s) : change_t) (tc : tcenv1) = let keep = EcPV.PV.union keep (EcPV.PV.fv env (EcMemory.memory mem) (POE.lower (EcAst.hs_po hs)).inv) in let st = EcLowCircuits.(set_logger empty_state EcEnv.(notify env `Debug "%s")) in - begin - try - if not (EcCircuits.instrs_equiv (FApi.tc1_hyps tc) ~keep mem st target s.s_node) then - tc_error !!tc "statements are not circuit-equivalent" - with e -> - tc_error !!tc "circuit-equivalence checker error: %s" (Printexc.to_string e) - end; + let equiv = + try EcCircuits.instrs_equiv (FApi.tc1_hyps tc) ~keep mem st target s.s_node + with e -> + tc_error !!tc "circuit-equivalence checker error: %s" (Printexc.to_string e) + in + if not equiv then + tc_error !!tc "statements are not circuit-equivalent"; { zp with z_tail = s.s_node @ tl } in let hs = { hs with hs_s = Zpr.zip zp; hs_m = mem; } in From ab3159f819803a9a68a112b634191169be0c081d Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 11:23:21 +0200 Subject: [PATCH 105/145] circuit: open hoare-triple program variables up front; uninit read is internal error The hoare branch of t_bdep_solve never opened the program's memory variables as inputs (unlike the equiv branch, which opens es_ml/es_mr, and instrs_equiv). So a local not pinned down by the precondition fell through to circuit_uninit, which models every uninitialized value with ONE shared variable (bad = input(-1,-1)) -- collapsing distinct values to equal and letting `circuit` prove false triples (e.g. the xor of two uninitialized bytes is 0). Open hs.hs_m up front with circuit_state_of_memenv, mirroring the equiv branch. Every program variable is now a distinct, consistent input. Consequently a program-variable read that misses the translation state can no longer be a legitimate "uninitialized variable": it is a setup bug, so the Fpvar fallback is now an internal error (assert false) rather than a silent circuit_uninit. (circuit_uninit itself remains for `witness`; sharing one variable across distinct witness occurrences is a separate, narrower issue.) --- src/ecCircuits.ml | 10 +--------- src/phl/ecPhlBDep.ml | 1 + 2 files changed, 2 insertions(+), 9 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 4ab18ab56b..fcebea2305 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -576,15 +576,7 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = let v = match state_get_pv_opt st mem v with | Some v -> v - | None -> - EcEnv.notify env `Debug - "Assigning unassigned program variable %a of type %a@." - EcPrinting.(pp_pv ppe) - pv - EcPrinting.(pp_type ppe) - f_.f_ty; - circuit_uninit env - f_.f_ty (* Allow uninitialized program variables *) + | None -> assert false (* opened up front: internal error *) in v | Fglob (_id, _mem) -> diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index 31cff26d39..6eb0f9831a 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -161,6 +161,7 @@ let t_bdep_solve let lap = EcCircuits.stopwatch env in let st = set_logger empty_state (EcEnv.notify env `Debug "%s") in let st = circuit_state_of_hyps ~st hyps in + let st = circuit_state_of_memenv ~st env hs.hs_m in let st, cpres = process_pre ~st tc (hs_pr hs).inv in lap "Done with precondition processing"; From 080d9af3d75068d30b62a56cdc61b092da86c288 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 13:46:09 +0200 Subject: [PATCH 106/145] circuit: model an arbitrary (witness) value as a fresh input, not shared bad circuit_uninit built its register from a single shared node bad = input(-1,-1), reused for every bit and every call. So an arbitrary value was modeled as one unknown bit replicated, and all arbitrary values were the same bit -- letting `circuit` prove false facts, e.g. that the two (independent) components of an arbitrary W8*W8 pair are equal. Make circuit_uninit allocate a fresh input (input_of_ctype ~name:"uninit") with distinct bits, matching the sound fresh-input model the translator already uses for unknown variable values (open_circ_lambda). To keep completeness -- repeated occurrences of the same witness<:T> must stay equal -- route the witness branch through the form-level cache that is already in scope, so identical witness forms share one input while a single witness of a product type keeps distinct bits per component. witness<:W8> = witness<:W8> and witness +^ witness = of_int 0 still close; (witness<:W8*W8>).`1 = (witness<:W8*W8>).`2 is now correctly rejected. --- src/ecCircuits.ml | 7 ++++++- src/ecLowCircuits.ml | 4 ++-- 2 files changed, 8 insertions(+), 3 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index fcebea2305..0cc21e8ded 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -598,7 +598,12 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = EcEnv.notify env `Debug "Assigning witness to var of type %a@." EcPrinting.(pp_type ppe) f_.f_ty; - circuit_uninit env f_.f_ty + match EcAlphaInvHashtbl.find_opt cache f_ with + | Some circ -> circ + | None -> + let circ = circuit_uninit env f_.f_ty in + EcAlphaInvHashtbl.add cache f_ circ; + circ end else match Mp.find_opt pth !op_cache with | Some op -> op diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index 6cdb691b08..d0df11cee2 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -1051,8 +1051,8 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (circ, inps) (* Functions for dealing with uninitialized inputs *) - let circuit_uninit (t: ctype) : circuit = - let c, _ = input_of_ctype ~name:`Bad t in + let circuit_uninit (t: ctype) : circuit = + let c, _ = input_of_ctype ~name:(`Str "uninit") t in c, [] let circuit_has_uninitialized (c: circuit) : int option = From cce5804dab8e4c09ff1450bd7557d4f73422bedf Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 13:48:41 +0200 Subject: [PATCH 107/145] tests: regression tests for circuit-tactic soundness fixes Self-contained unit test (picked up by [test-unit]) guarding the three soundness fixes: - proc change circuit rejects a non-equivalent rewrite (c <- a+^b vs c <- zero) -- and still accepts an equivalent one (commutation); - circuit does not prove a false fact over uninitialized locals; - circuit does not equate the independent components of a witness pair, while witness=witness and witness+^witness=0 still close. Each unsound case is asserted via [fail ], so a regression flips the inner tactic back to success and fails the test. --- tests/circuit_soundness.ec | 81 ++++++++++++++++++++++++++++++++++++++ 1 file changed, 81 insertions(+) create mode 100644 tests/circuit_soundness.ec diff --git a/tests/circuit_soundness.ec b/tests/circuit_soundness.ec new file mode 100644 index 0000000000..a170fdfeaf --- /dev/null +++ b/tests/circuit_soundness.ec @@ -0,0 +1,81 @@ +(* ==================================================================== *) +(* Regression tests for circuit-tactic soundness fixes. *) +(* *) +(* Each [fail ] asserts that a previously-UNSOUND acceptance is now *) +(* rejected: if the bug regresses, the inner tactic succeeds and [fail] *) +(* turns that into a test failure. The positive lemmas guard that the *) +(* fixes did not cost completeness. *) +(* *) +(* History: all three [fail] lemmas below used to close (proving false *) +(* facts) -- see commits 0357c262a (proc change circuit), ab3159f81 *) +(* (uninitialized locals) and 080d9af3d (witness). *) +(* ==================================================================== *) +require import AllCore List QFABV IntDiv. + +type W8. +op to_bits : W8 -> bool list. op from_bits : bool list -> W8. +op of_int : int -> W8. op to_uint : W8 -> int. op to_sint : W8 -> int. +bind bitstring to_bits from_bits to_uint to_sint of_int W8 8. +realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. +realize touintP by admit. realize tosintP by admit. realize ofintP by admit. +realize size_tolist by admit. + +op (+^) : W8 -> W8 -> W8. bind op W8 (+^) "xor". realize bvxorP by admit. +op zero : W8 = of_int 0. + +(* -------------------------------------------------------------------- *) +(* proc change circuit must REJECT a non-equivalent rewrite. The check *) +(* used to collapse all program variables to one input, so [c <- a +^ b] *) +(* and the constant [c <- zero] looked equivalent. *) +module M = { + proc f (a b : W8) : W8 = { + var c : W8; + c <- a +^ b; + return c; + } +}. + +lemma pcc_reject_unsound : hoare[M.f : true ==> res = zero]. +proof. + proc. + fail proc change circuit 1 + 1 { c <- zero; }. +abort. + +(* A genuinely equivalent rewrite is still accepted (no over-rejection). *) +lemma pcc_accept_equiv (a_ b_ : W8) : + hoare[M.f : a_ = a /\ b_ = b ==> res = a_ +^ b_]. +proof. + proc. + proc change circuit 1 + 1 { c <- b +^ a; }. + circuit. +qed. + +(* -------------------------------------------------------------------- *) +(* circuit must not prove false facts about uninitialized locals. [x] *) +(* and [y] used to collapse to one shared input, so [x +^ y] looked 0. *) +module G = { + proc g () : W8 = { + var x : W8; + var y : W8; + var z : W8; + z <- x +^ y; + return z; + } +}. + +lemma uninit_reject : hoare[G.g : true ==> res = zero]. +proof. proc. fail circuit. abort. + +(* -------------------------------------------------------------------- *) +(* circuit must not equate the (independent) components of an arbitrary *) +(* value. A witness used to be one shared bit, so its bits were equal. *) +lemma witness_reject : (witness<:W8 * W8>).`1 = (witness<:W8 * W8>).`2. +proof. fail circuit. abort. + +(* Completeness: a witness still equals itself, and xors to zero with *) +(* itself (the fix shares identical witness forms via the form cache). *) +lemma witness_refl : witness<:W8> = witness<:W8>. +proof. circuit. qed. + +lemma witness_xor_self : witness<:W8> +^ witness<:W8> = zero. +proof. circuit. qed. From b69aadf87f102a64162360067791b54390fe22e9 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 13:54:50 +0200 Subject: [PATCH 108/145] circuit: remove the dead uninitialized-marker machinery With circuit_uninit now allocating a fresh input (no longer the shared bad = input(-1,-1) node), nothing produces the -1 marker anymore, so the detection/marker code is dead: - bad, bad_reg, has_bad, have_bad (CBackend sig + LospecsBack impl); - the `Bad variant of input_of_ctype / new_input_circuit; - circuit_has_uninitialized (and its .mli export); - the two fillet asserts that consumed it (now vacuous). --- src/ecCircuits.ml | 2 -- src/ecLowCircuits.ml | 45 +++++++------------------------------------ src/ecLowCircuits.mli | 7 +++---- 3 files changed, 10 insertions(+), 44 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 0cc21e8ded..37cd1ac947 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -778,8 +778,6 @@ let circuits_of_equality ~(st : state) ~(hyps : hyps) (f1 : form) (f2 : form) : let c2 = circuit_of_form st hyps f2 |> state_close_circuit st in lap "Right side circuit generation done"; - assert (Option.is_none @@ circuit_has_uninitialized c1); - assert (Option.is_none @@ circuit_has_uninitialized c2); let posts = circuit_eqs c1 c2 in lap "Done with postcondition circuit generation"; posts diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index d0df11cee2..eb0d2fd20b 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -51,10 +51,6 @@ module type CBackend = sig val nodes_eq : node -> node -> bool - val bad : node - val bad_reg : int -> reg - val has_bad : node -> bool - val have_bad : reg -> int option val node_array_of_reg : reg -> node array val node_list_of_reg : reg -> node list @@ -189,27 +185,6 @@ module LospecsBack : CBackend = struct let false_ = C.false_ let nodes_eq ({id=id1; _}: node) ({id=id2; _}: node) = id1 = id2 let size_of_reg = Array.length - let bad = C.input (-1, -1) - let bad_reg = fun i -> Array.make i bad - let has_bad : node -> bool = - let cache : (int, bool) Hashtbl.t = Hashtbl.create 0 in - let rec doit (n: node) : bool = - match Hashtbl.find_option cache (Int.abs n.id) with - | Some b -> b - | None -> let b = doit_r n.gate in - Hashtbl.add cache (Int.abs n.id) b; - b - and doit_r (n: C.node_r) : bool = - match n with - | C.Input (-1, -1) -> true - | C.Input _ - | C.False -> false - | C.And (n1, n2) -> (doit n1) || (doit n2) - in - fun b -> doit b - - let have_bad (r: reg) : int option = - Array.find_opt (fun (_, r) -> has_bad r) (Array.mapi (fun i r -> (i,r)) r) |> Option.map fst let node_array_of_reg : reg -> node array = fun x -> x @@ -558,8 +533,8 @@ module type CircuitInterface = sig (* Construct an input *) - val new_input_circuit : ?name:[`Str of string | `Idn of ident | `Bad] -> ctype -> circ * cinp - val input_of_ctype : ?name:[`Str of string | `Idn of ident | `Bad] -> ctype -> circuit + val new_input_circuit : ?name:[`Str of string | `Idn of ident] -> ctype -> circ * cinp + val input_of_ctype : ?name:[`Str of string | `Idn of ident] -> ctype -> circuit (* Aggregation functions *) val circuit_aggregate : circuit list -> circuit @@ -586,9 +561,8 @@ module type CircuitInterface = sig val circuit_tuple_of_circuits : circuit list -> circuit val circuits_of_circuit_tuple : circuit -> circuit list - (* Avoid nodes for uninitialized inputs *) + (* Fresh arbitrary value (used for [witness] and unknown values) *) val circuit_uninit : ctype -> circuit - val circuit_has_uninitialized : circuit -> int option (* Logical reasoning over circuits. Each query returns the decision and a lazy counter-model (see [Backend.model]); forcing it is only @@ -938,14 +912,12 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let can_convert_input_type (t1: ctype) (t2: ctype) : bool = size_of_ctype t1 = size_of_ctype t2 - let input_of_ctype ?(name : [`Str of string | `Idn of ident | `Bad ] = `Str "input") (ct: ctype) : circuit = + let input_of_ctype ?(name : [`Str of string | `Idn of ident] = `Str "input") (ct: ctype) : circuit = let id, c = match name with | `Str name -> let id = EcIdent.create name |> tag in - id, Backend.input_of_size ~id (size_of_ctype ct) + id, Backend.input_of_size ~id (size_of_ctype ct) | `Idn idn -> let id = idn.id_tag in - id, Backend.input_of_size ~id (size_of_ctype ct) - | `Bad -> - -1, Backend.bad_reg (size_of_ctype ct) + id, Backend.input_of_size ~id (size_of_ctype ct) in { reg = c; type_ = ct; }, [{ id; type_ = ct; }] @@ -1050,13 +1022,10 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let inps = merge_inputs_list (List.snd args) in (circ, inps) - (* Functions for dealing with uninitialized inputs *) + (* Fresh arbitrary value (used for [witness] and unknown values) *) let circuit_uninit (t: ctype) : circuit = let c, _ = input_of_ctype ~name:(`Str "uninit") t in c, [] - - let circuit_has_uninitialized (c: circuit) : int option = - Backend.have_bad (fst c).reg let circ_equiv ?(pcond:circuit option) ((c1, inps1): circuit) ((c2, inps2): circuit) : bool * Backend.model Lazy.t = let pcond = Option.map (convert_type CBool) pcond in (* Try to convert to bool *) diff --git a/src/ecLowCircuits.mli b/src/ecLowCircuits.mli index 2f7af43c91..92c2912163 100644 --- a/src/ecLowCircuits.mli +++ b/src/ecLowCircuits.mli @@ -116,8 +116,8 @@ val circ_of_zint : size:int -> zint -> circ val circuit_of_zint : size:int -> zint -> circuit (* Construct an input *) -val new_input_circuit : ?name:[`Str of string | `Idn of ident | `Bad] -> ctype -> circ * cinp -val input_of_ctype : ?name:[`Str of string | `Idn of ident | `Bad] -> ctype -> circuit +val new_input_circuit : ?name:[`Str of string | `Idn of ident] -> ctype -> circ * cinp +val input_of_ctype : ?name:[`Str of string | `Idn of ident] -> ctype -> circuit (* Aggregation functions *) val circuit_aggregate : circuit list -> circuit @@ -143,9 +143,8 @@ val circuit_tuple_proj : circuit -> int -> circuit val circuit_tuple_of_circuits : circuit list -> circuit val circuits_of_circuit_tuple : circuit -> circuit list -(* Avoid nodes for uninitialized inputs *) +(* Fresh arbitrary value (used for [witness] and unknown values) *) val circuit_uninit : ctype -> circuit -val circuit_has_uninitialized : circuit -> int option (* Logical reasoning over circuits *) val circ_equiv : ?pcond:circuit -> circuit -> circuit -> bool * model Lazy.t From a289c6384aa7f1198b4cdf401bb5aeaa7e7545fb Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 15:20:33 +0200 Subject: [PATCH 109/145] ecTypesafeFol: add a .mli Expose only the surface used elsewhere -- f_app_safe, fapply_safe, and the InsufficientArguments exception they can raise -- hiding the type-inference and reduction helpers. Drop the now-unused `f_node` type alias (only the record field is used). --- src/ecTypesafeFol.ml | 1 - src/ecTypesafeFol.mli | 29 +++++++++++++++++++++++++++++ 2 files changed, 29 insertions(+), 1 deletion(-) create mode 100644 src/ecTypesafeFol.mli diff --git a/src/ecTypesafeFol.ml b/src/ecTypesafeFol.ml index 445f1663a1..dfd3c451dd 100644 --- a/src/ecTypesafeFol.ml +++ b/src/ecTypesafeFol.ml @@ -16,7 +16,6 @@ module Sx = EcPath.Sx module UE = EcUnify.UniEnv type form = EcAst.form -type f_node = EcAst.f_node type ty = EcTypes.ty let (%) f g = fun x -> f (g x) diff --git a/src/ecTypesafeFol.mli b/src/ecTypesafeFol.mli new file mode 100644 index 0000000000..197af6b777 --- /dev/null +++ b/src/ecTypesafeFol.mli @@ -0,0 +1,29 @@ +(* -------------------------------------------------------------------- *) +open EcAst + +(* -------------------------------------------------------------------- *) +(* Type-aware construction of operator/function applications as forms, + with on-the-fly normalisation. Used by the circuit translation to bring + applications into a reduced, translatable shape. The type-inference and + reduction helpers are internal. *) + +(* Raised by [f_app_safe ~full:true] when the operator is applied to too + few arguments (its result type is still a function). *) +exception InsufficientArguments + +(* [f_app_safe ~full env p args] builds the application of the operator at + path [p] to [args], inferring and instantiating its type variables. + With [~full:true] (the default) it raises [InsufficientArguments] when + the result type is still a function. *) +val f_app_safe : + ?full:bool -> EcEnv.env -> EcPath.path -> form list -> form + +(* [fapply_safe ~redmode hyps f fs] applies the function-form [f] to the + argument-forms [fs], normalising the result by call-by-value under + [redmode] (default [EcReduction.full_red]). *) +val fapply_safe : + ?redmode:EcReduction.reduction_info + -> EcEnv.LDecl.hyps + -> form + -> form list + -> form From 492bbc6ed99da721610f127c13d36b372299dcfa Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 15:25:31 +0200 Subject: [PATCH 110/145] ecTypesafeFol: remove dead code exposed by the .mli With the interface hiding everything but f_app_safe / fapply_safe, the internal helpers that nothing (internal or external) used are dead: tfrom_tlist, tfrom_tfun2, unroll_ftype, match_ty_tyargs, sub_ty_tyargs, fop_from_path, the (%) combinator, the `ty` type alias, and the unused module aliases (Map, BI, Mp, Sp, Sm, Sx). Confirmed via a temporary +32+34+60 build; UE, open_oper_ue, `form` and the two public functions remain. --- src/ecTypesafeFol.ml | 58 -------------------------------------------- 1 file changed, 58 deletions(-) diff --git a/src/ecTypesafeFol.ml b/src/ecTypesafeFol.ml index dfd3c451dd..e583680eba 100644 --- a/src/ecTypesafeFol.ml +++ b/src/ecTypesafeFol.ml @@ -6,76 +6,18 @@ open EcUnify open EcSubst open EcEnv -module Map = Batteries.Map - -module BI = EcBigInt -module Mp = EcPath.Mp -module Sp = EcPath.Sp -module Sm = EcPath.Sm -module Sx = EcPath.Sx module UE = EcUnify.UniEnv type form = EcAst.form -type ty = EcTypes.ty - -let (%) f g = fun x -> f (g x) exception InsufficientArguments -let tfrom_tlist ty = - let p_list = EcCoreLib.CI_List.p_list in - match ty.ty_node with - | Tconstr (p, [ty]) when p = p_list -> ty - | _ -> assert false - -let tfrom_tfun2 ty = - match ty.ty_node with - | Tfun (a, b) -> (a, b) - | _ -> assert false - -let unroll_ftype (ty:ty) : ty list * ty = - let rec doit (tys: ty list) (ty: ty) : ty list * ty = - match ty.ty_node with - | Tfun _ -> let t1, t2 = tfrom_tfun2 ty in doit (t1::tys) t2 - | _ -> (List.rev tys, ty) - in - - doit [] ty - -(* Returned list is (tyvar, ty) *) -let rec match_ty_tyargs (ty: ty) (tyargs: ty) : (ty * ty) list = - match (ty.ty_node, tyargs.ty_node) with - | (Tconstr (p1, args1), Tconstr (p2, args2)) when p1 = p2 && (List.compare_lengths args1 args2 = 0) -> - List.flatten @@ List.map2 match_ty_tyargs args1 args2 - | (Ttuple args1, Ttuple args2) when (List.compare_lengths args1 args2 = 0) -> - List.flatten @@ List.map2 match_ty_tyargs args1 args2 - | (Tfun (ty11, ty12), Tfun (ty21, ty22)) -> - (match_ty_tyargs ty11 ty21) @ (match_ty_tyargs ty12 ty22) - | (_, Tvar _) -> [(ty, tyargs)] - | (_, Tunivar _) -> [(ty, tyargs)] - | _ -> assert false - -let rec sub_ty_tyargs (vals: (ty, ty) Map.t) (ty: ty) : ty = - match ty.ty_node with - | (Tconstr (p1, args1)) -> tconstr p1 (List.map (sub_ty_tyargs vals) args1) - | (Ttuple args1) -> ttuple (List.map (sub_ty_tyargs vals) args1) - | (Tfun (ty_arg, ty_ret)) -> tfun (sub_ty_tyargs vals ty_arg) (sub_ty_tyargs vals ty_ret) - | (Tvar _) -> Map.find ty vals - | (Tunivar _) -> Map.find ty vals - | (Tglob _) -> assert false - let open_oper_ue op ue = (* Maybe list map works fine because ue is imperative? *) let open EcDecl in let _ue, tys = List.fold_left_map (fun ue _ -> (ue, EcUnify.UniEnv.fresh ue)) ue op.op_tparams in (tys, open_oper op tys) -let fop_from_path (env: env) (f: EcPath.path) : form = - let ue = UE.create None in - let _p_f, o_f = EcEnv.Op.lookup (EcPath.toqsymbol f) env in - let tvars,(newt, _f_kind) = open_oper_ue o_f ue in - f_op f tvars newt - let f_app_safe ?(full=true) (env: env) (f: EcPath.path) (args: form list) = let ue = UE.create None in let p_f, o_f = EcEnv.Op.lookup (EcPath.toqsymbol f) env in From 7726dcfbea242aa3cc59f0091b2020dd743df518 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 17:09:14 +0200 Subject: [PATCH 111/145] ecTypesafeFol: simplify fapply_safe to build-and-reduce (no case analysis) fapply_safe received a fully-typed form, so the operator's type arguments are already opened -- there was nothing to re-infer, and f_app_safe (which re-runs unification from a bare path) was only needed for the path-based entry point. Drop the per-head case analysis (Fop / Fapp / Llambda / assert-false): just build the application with f_app (which flattens a curried head) and normalise. f_app needs the result type, computed by peeling one arrow per argument while head-normalising at each step, so arrows hidden behind type abbreviations (e.g. u = int -> t, t = int -> int) are exposed. A non-reducible head (an opaque local, etc.) now normalises to the application f fs instead of hitting `_ -> assert false`. (This removes the fapply_safe anomaly of defect #3; circuit_of_node still needs to reject the resulting opaque application cleanly -- a separate follow-up.) --- src/ecTypesafeFol.ml | 50 ++++++++++++-------------------------------- 1 file changed, 13 insertions(+), 37 deletions(-) diff --git a/src/ecTypesafeFol.ml b/src/ecTypesafeFol.ml index e583680eba..9409ba0d69 100644 --- a/src/ecTypesafeFol.ml +++ b/src/ecTypesafeFol.ml @@ -50,40 +50,16 @@ let f_app_safe ?(full=true) (env: env) (f: EcPath.path) (args: form list) = else f_app op args rty -let rec fapply_safe ?(redmode = EcReduction.full_red) (hyps: LDecl.hyps) (f: form) (fs: form list) : form = -(* - Format.eprintf "Applying forms:@.%a@.To form: %a@." - (fun fmt fs -> List.iter (fun f -> Format.fprintf fmt "%a@." (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (LDecl.toenv hyps))) f) fs) fs - (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (LDecl.toenv hyps))) f; -*) - match f.f_node with - | Fop (pth, _) -> - f_app_safe ~full:false (LDecl.toenv hyps) pth fs |> EcCallbyValue.norm_cbv redmode hyps - | Fapp (fop, args) -> - (* let new_args = args @ fs in *) - (* let pp_form = EcPrinting.pp_form (EcPrinting.PPEnv.ofenv (LDecl.toenv hyps)) in *) - (* let pp_forms fmt = List.iter (Format.fprintf fmt "%a, " pp_form) in *) - (* Format.eprintf "new_args: %a@." pp_forms new_args; *) - fapply_safe ~redmode hyps fop (args @ fs) - | Fquant (Llambda, binds, f) -> - assert (List.compare_lengths binds fs >= 0); - let subst_bnds, rem_bnds = List.takedrop (List.length fs) binds in - let subst = - List.fold_left2 - (fun subst b f -> EcSubst.add_flocal subst (fst b) f) EcSubst.empty subst_bnds fs - in - let f = f_quant Llambda rem_bnds (EcSubst.subst_form subst f) in - EcCallbyValue.norm_cbv redmode hyps f -(* FIXME PR - | Fquant (qtf, _, _) -> assert false - | Fif (f, ft, ff) -> assert false - | Fmatch (f, fs, t) -> assert false - | Flet (lpat, f, fb) -> assert false - | Fint (i) -> assert false - | Flocal (id) -> assert false - | Fpvar (pv, m) -> assert false - | Fglob (id, m) -> assert false - | Ftuple (fs) -> assert false - | Fproj (f, i) -> assert false -*) - | _ -> assert false +let fapply_safe + ?(redmode = EcReduction.full_red) (hyps: LDecl.hyps) + (f: form) (fs: form list) : form = + let env = LDecl.toenv hyps in + (* type of [f] applied to its first [n] arguments *) + let rec result_ty (n : int) (ty : ty) : ty = + if n <= 0 then ty + else match (ty_hnorm ty env).ty_node with + | Tfun (_, codom) -> result_ty (n - 1) codom + | _ -> ty + in + let rty = result_ty (List.length fs) f.f_ty in + f_app f fs rty |> EcCallbyValue.norm_cbv redmode hyps From c1c94a167fbc0405dc42aaf653643d39ebd5ecaa Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 17:15:13 +0200 Subject: [PATCH 112/145] ecTypesafeFol: drop f_app_safe's `full` flag and InsufficientArguments `full` only gated a check that raised InsufficientArguments (with a debug eprintf) when the operator's result type was still a function. The sole remaining caller uses the default and never triggers it, and fapply_safe no longer calls f_app_safe at all. Always build the application; remove the flag, the check, and the now-dead InsufficientArguments exception. --- src/ecTypesafeFol.ml | 13 ++----------- src/ecTypesafeFol.mli | 13 +++---------- 2 files changed, 5 insertions(+), 21 deletions(-) diff --git a/src/ecTypesafeFol.ml b/src/ecTypesafeFol.ml index 9409ba0d69..a344cc125d 100644 --- a/src/ecTypesafeFol.ml +++ b/src/ecTypesafeFol.ml @@ -8,9 +8,7 @@ open EcEnv module UE = EcUnify.UniEnv -type form = EcAst.form - -exception InsufficientArguments +type form = EcAst.form let open_oper_ue op ue = (* Maybe list map works fine because ue is imperative? *) @@ -18,7 +16,7 @@ let open_oper_ue op ue = let _ue, tys = List.fold_left_map (fun ue _ -> (ue, EcUnify.UniEnv.fresh ue)) ue op.op_tparams in (tys, open_oper op tys) -let f_app_safe ?(full=true) (env: env) (f: EcPath.path) (args: form list) = +let f_app_safe (env: env) (f: EcPath.path) (args: form list) = let ue = UE.create None in let p_f, o_f = EcEnv.Op.lookup (EcPath.toqsymbol f) env in let tvars,(newt, _f_kind) = open_oper_ue o_f ue in @@ -41,13 +39,6 @@ let f_app_safe ?(full=true) (env: env) (f: EcPath.path) (args: form list) = let newt = EcCoreSubst.ty_subst subst newt in let tvars = List.map (EcCoreSubst.ty_subst subst) tvars in let op = f_op p_f tvars newt in - if full then - match rty.ty_node with - | Tfun _ -> Format.eprintf "op: %a@.args: " (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv env)) op; - List.iter (fun a -> Format.eprintf "%a, " (EcPrinting.pp_form (EcPrinting.PPEnv.ofenv env)) a) args; Format.eprintf "@."; - raise InsufficientArguments - | _ -> f_app op args rty - else f_app op args rty let fapply_safe diff --git a/src/ecTypesafeFol.mli b/src/ecTypesafeFol.mli index 197af6b777..4ae91e9b11 100644 --- a/src/ecTypesafeFol.mli +++ b/src/ecTypesafeFol.mli @@ -7,16 +7,9 @@ open EcAst applications into a reduced, translatable shape. The type-inference and reduction helpers are internal. *) -(* Raised by [f_app_safe ~full:true] when the operator is applied to too - few arguments (its result type is still a function). *) -exception InsufficientArguments - -(* [f_app_safe ~full env p args] builds the application of the operator at - path [p] to [args], inferring and instantiating its type variables. - With [~full:true] (the default) it raises [InsufficientArguments] when - the result type is still a function. *) -val f_app_safe : - ?full:bool -> EcEnv.env -> EcPath.path -> form list -> form +(* [f_app_safe env p args] builds the application of the operator at path + [p] to [args], inferring and instantiating its type variables. *) +val f_app_safe : EcEnv.env -> EcPath.path -> form list -> form (* [fapply_safe ~redmode hyps f fs] applies the function-form [f] to the argument-forms [fs], normalising the result by call-by-value under From b4f259cb8b93889d4c7fa41defd01ff7b5f24858 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 17:17:19 +0200 Subject: [PATCH 113/145] ecTypesafeFol: a unification failure in f_app_safe is an internal error f_app_safe builds the arrow type from the actual argument types and unifies it with the looked-up operator's type; for a well-typed form this cannot fail unless the construction is wrong. So catch UnificationFailure and `assert false` rather than the previous debug-eprintf-and-reraise (which also used the let () = begin ... end idiom and only re-raised the same exception). --- src/ecTypesafeFol.ml | 12 +----------- 1 file changed, 1 insertion(+), 11 deletions(-) diff --git a/src/ecTypesafeFol.ml b/src/ecTypesafeFol.ml index a344cc125d..f6ab8aa0f0 100644 --- a/src/ecTypesafeFol.ml +++ b/src/ecTypesafeFol.ml @@ -22,17 +22,7 @@ let f_app_safe (env: env) (f: EcPath.path) (args: form list) = let tvars,(newt, _f_kind) = open_oper_ue o_f ue in let rty = UE.fresh ue in let fty = toarrow (List.map (fun f -> f.f_ty) args) rty in - let () = begin - try - (EcUnify.unify env ue fty newt) - with - | UnificationFailure (`TyUni (ty1, ty2)) -> - let pp_type = (EcPrinting.pp_type (EcPrinting.PPEnv.ofenv env)) in - Format.eprintf "Failed to unify types (%a, %a) in call to %s@." pp_type ty1 pp_type ty2 - (let h,t = EcPath.toqsymbol f in List.fold_right (fun a b -> a ^ "." ^ b) h t); - raise (UnificationFailure (`TyUni (ty1, ty2))) - end - in + (try EcUnify.unify env ue fty newt with UnificationFailure _ -> assert false); let uidmap = UE.assubst ue in let subst = EcCoreSubst.Tuni.subst uidmap in let rty = EcCoreSubst.ty_subst subst rty in From 37d2fc6145088852cab3b9c5608a1f2002d1228f Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 17:23:02 +0200 Subject: [PATCH 114/145] ecTypesafeFol: look the operator up by path in f_app_safe Use EcEnv.Op.by_path f env instead of converting the path to a qsymbol and re-resolving it by name (EcEnv.Op.lookup (toqsymbol f)); the resolved path is then just f. --- src/ecTypesafeFol.ml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/ecTypesafeFol.ml b/src/ecTypesafeFol.ml index f6ab8aa0f0..6f922e8cf4 100644 --- a/src/ecTypesafeFol.ml +++ b/src/ecTypesafeFol.ml @@ -18,7 +18,7 @@ let open_oper_ue op ue = let f_app_safe (env: env) (f: EcPath.path) (args: form list) = let ue = UE.create None in - let p_f, o_f = EcEnv.Op.lookup (EcPath.toqsymbol f) env in + let o_f = EcEnv.Op.by_path f env in let tvars,(newt, _f_kind) = open_oper_ue o_f ue in let rty = UE.fresh ue in let fty = toarrow (List.map (fun f -> f.f_ty) args) rty in @@ -28,7 +28,7 @@ let f_app_safe (env: env) (f: EcPath.path) (args: form list) = let rty = EcCoreSubst.ty_subst subst rty in let newt = EcCoreSubst.ty_subst subst newt in let tvars = List.map (EcCoreSubst.ty_subst subst) tvars in - let op = f_op p_f tvars newt in + let op = f_op f tvars newt in f_app op args rty let fapply_safe From cd19ff2d3e7d727848d5372c27331a25883b7c54 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 17:29:16 +0200 Subject: [PATCH 115/145] ecTypesafeFol: open the operator type with UE.openty Replace the bespoke open_oper_ue (fresh univar per tparam, ignoring the tparam constraints) with EcUnify.UniEnv.openty, which opens the operator's type respecting its type-parameter constraints. Removes open_oper_ue and the now-unused open EcSubst. --- src/ecTypesafeFol.ml | 9 +-------- 1 file changed, 1 insertion(+), 8 deletions(-) diff --git a/src/ecTypesafeFol.ml b/src/ecTypesafeFol.ml index 6f922e8cf4..f05d8e895f 100644 --- a/src/ecTypesafeFol.ml +++ b/src/ecTypesafeFol.ml @@ -3,23 +3,16 @@ open EcAst open EcTypes open EcCoreFol open EcUnify -open EcSubst open EcEnv module UE = EcUnify.UniEnv type form = EcAst.form -let open_oper_ue op ue = - (* Maybe list map works fine because ue is imperative? *) - let open EcDecl in - let _ue, tys = List.fold_left_map (fun ue _ -> (ue, EcUnify.UniEnv.fresh ue)) ue op.op_tparams in - (tys, open_oper op tys) - let f_app_safe (env: env) (f: EcPath.path) (args: form list) = let ue = UE.create None in let o_f = EcEnv.Op.by_path f env in - let tvars,(newt, _f_kind) = open_oper_ue o_f ue in + let newt, tvars = UE.openty ue o_f.EcDecl.op_tparams None o_f.EcDecl.op_ty in let rty = UE.fresh ue in let fty = toarrow (List.map (fun f -> f.f_ty) args) rty in (try EcUnify.unify env ue fty newt with UnificationFailure _ -> assert false); From 1a4feeb2258ef03588acbe9a069f00b12641e917 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 17:38:09 +0200 Subject: [PATCH 116/145] ecTypesafeFol: f_app_safe gains ?typarams/?rty; sync .mli f_app_safe now takes optional ?typarams (seeding the unification environment) and ?rty (the expected result type), and treats an unresolved unification environment (not UE.closed) as an internal error alongside a unification failure. Update the .mli signature and doc to match. --- src/ecTypesafeFol.ml | 45 +++++++++++++++++++++++++++++-------------- src/ecTypesafeFol.mli | 19 +++++++++++++----- 2 files changed, 45 insertions(+), 19 deletions(-) diff --git a/src/ecTypesafeFol.ml b/src/ecTypesafeFol.ml index f05d8e895f..37b0821119 100644 --- a/src/ecTypesafeFol.ml +++ b/src/ecTypesafeFol.ml @@ -1,29 +1,46 @@ +(* -------------------------------------------------------------------- *) open EcUtils open EcAst +open EcDecl open EcTypes -open EcCoreFol +open EcFol open EcUnify open EcEnv module UE = EcUnify.UniEnv -type form = EcAst.form +(* -------------------------------------------------------------------- *) +let f_app_safe + (env : env) + ?(typarams : ty_params option) + ?(rty : ty option) + (op : EcPath.path) + (args : form list) += + let ue = UE.create typarams in + let opdecl = EcEnv.Op.by_path op env in + let opty, tvars = UE.openty ue opdecl.op_tparams None opdecl.op_ty in -let f_app_safe (env: env) (f: EcPath.path) (args: form list) = - let ue = UE.create None in - let o_f = EcEnv.Op.by_path f env in - let newt, tvars = UE.openty ue o_f.EcDecl.op_tparams None o_f.EcDecl.op_ty in - let rty = UE.fresh ue in + let rty = ofdfl (fun () -> UE.fresh ue) rty in let fty = toarrow (List.map (fun f -> f.f_ty) args) rty in - (try EcUnify.unify env ue fty newt with UnificationFailure _ -> assert false); - let uidmap = UE.assubst ue in - let subst = EcCoreSubst.Tuni.subst uidmap in - let rty = EcCoreSubst.ty_subst subst rty in - let newt = EcCoreSubst.ty_subst subst newt in + + begin + try + EcUnify.unify env ue fty opty + with UnificationFailure _ -> assert false + end; + + if not (UE.closed ue) then + assert false; + + let subst = EcCoreSubst.Tuni.subst (UE.assubst ue) in + let rty = EcCoreSubst.ty_subst subst rty in + let opty = EcCoreSubst.ty_subst subst opty in let tvars = List.map (EcCoreSubst.ty_subst subst) tvars in - let op = f_op f tvars newt in - f_app op args rty + + f_app (f_op op tvars opty) args rty +(* -------------------------------------------------------------------- *) let fapply_safe ?(redmode = EcReduction.full_red) (hyps: LDecl.hyps) (f: form) (fs: form list) : form = diff --git a/src/ecTypesafeFol.mli b/src/ecTypesafeFol.mli index 4ae91e9b11..a3d2a78c5b 100644 --- a/src/ecTypesafeFol.mli +++ b/src/ecTypesafeFol.mli @@ -4,12 +4,21 @@ open EcAst (* -------------------------------------------------------------------- *) (* Type-aware construction of operator/function applications as forms, with on-the-fly normalisation. Used by the circuit translation to bring - applications into a reduced, translatable shape. The type-inference and - reduction helpers are internal. *) + applications into a reduced, translatable shape. *) -(* [f_app_safe env p args] builds the application of the operator at path - [p] to [args], inferring and instantiating its type variables. *) -val f_app_safe : EcEnv.env -> EcPath.path -> form list -> form +(* [f_app_safe env ?typarams ?rty op args] builds the application of the + operator at path [op] to [args], instantiating its type variables. + [?typarams] seeds the type parameters of the unification environment and + [?rty] fixes the expected result type. It is an internal error (assert) + if the application does not type — unification fails, or type variables + remain unresolved. *) +val f_app_safe : + EcEnv.env + -> ?typarams:EcDecl.ty_params + -> ?rty:EcTypes.ty + -> EcPath.path + -> form list + -> form (* [fapply_safe ~redmode hyps f fs] applies the function-form [f] to the argument-forms [fs], normalising the result by call-by-value under From c1d480d5d841c55f8238bb1f60bac2fca5f97e9f Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 17:41:05 +0200 Subject: [PATCH 117/145] ecTypesafeFol: head-reduce in fapply_safe instead of full CBV The application only needs its head exposed for the circuit translator to dispatch (and for lambdas to beta-reduce); the translator reduces the sub-terms it needs (e.g. array indices) itself. Use EcReduction.h_red_until (reduce to weak head normal form) instead of EcCallbyValue.norm_cbv. --- src/ecTypesafeFol.ml | 2 +- src/ecTypesafeFol.mli | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/ecTypesafeFol.ml b/src/ecTypesafeFol.ml index 37b0821119..ef2973f28b 100644 --- a/src/ecTypesafeFol.ml +++ b/src/ecTypesafeFol.ml @@ -53,4 +53,4 @@ let fapply_safe | _ -> ty in let rty = result_ty (List.length fs) f.f_ty in - f_app f fs rty |> EcCallbyValue.norm_cbv redmode hyps + f_app f fs rty |> EcReduction.h_red_until redmode hyps diff --git a/src/ecTypesafeFol.mli b/src/ecTypesafeFol.mli index a3d2a78c5b..21e3fccfd5 100644 --- a/src/ecTypesafeFol.mli +++ b/src/ecTypesafeFol.mli @@ -21,8 +21,8 @@ val f_app_safe : -> form (* [fapply_safe ~redmode hyps f fs] applies the function-form [f] to the - argument-forms [fs], normalising the result by call-by-value under - [redmode] (default [EcReduction.full_red]). *) + argument-forms [fs], head-reducing the result under [redmode] (default + [EcReduction.full_red]). *) val fapply_safe : ?redmode:EcReduction.reduction_info -> EcEnv.LDecl.hyps From c78c00bedc6452fe54675651bc95e946f23e4eb4 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 17:45:18 +0200 Subject: [PATCH 118/145] ecTypesafeFol: over-application in fapply_safe is a hard error result_ty now asserts when arguments remain but the type is not a function (more arguments than arrows), instead of silently returning the non-function type. --- src/ecTypesafeFol.ml | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/src/ecTypesafeFol.ml b/src/ecTypesafeFol.ml index ef2973f28b..83d1e9ba1c 100644 --- a/src/ecTypesafeFol.ml +++ b/src/ecTypesafeFol.ml @@ -42,15 +42,18 @@ let f_app_safe (* -------------------------------------------------------------------- *) let fapply_safe - ?(redmode = EcReduction.full_red) (hyps: LDecl.hyps) - (f: form) (fs: form list) : form = + ?(redmode : EcReduction.reduction_info = EcReduction.full_red) + (hyps : LDecl.hyps) + (f : form) + (args : form list) +: form = let env = LDecl.toenv hyps in (* type of [f] applied to its first [n] arguments *) let rec result_ty (n : int) (ty : ty) : ty = if n <= 0 then ty else match (ty_hnorm ty env).ty_node with | Tfun (_, codom) -> result_ty (n - 1) codom - | _ -> ty + | _ -> assert false in - let rty = result_ty (List.length fs) f.f_ty in - f_app f fs rty |> EcReduction.h_red_until redmode hyps + let rty = result_ty (List.length args) f.f_ty in + f_app f args rty |> EcReduction.h_red_until redmode hyps From 7c22ebcfae8aa2b087e3b8b8c333e2be59ae88da Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 17:48:44 +0200 Subject: [PATCH 119/145] ecTypesafeFol: rename f_app_safe -> f_op_app, fapply_safe -> f_app The module name (EcTypesafeFol) already conveys the "safe" aspect, so the suffix was redundant. f_op_app applies an operator (by path); f_app applies a function form. Update the .mli and the call sites in ecCircuits and ecPhlBDep. --- src/ecCircuits.ml | 4 ++-- src/ecTypesafeFol.ml | 4 ++-- src/ecTypesafeFol.mli | 8 ++++---- src/phl/ecPhlBDep.ml | 4 ++-- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 37cd1ac947..b80addf456 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -463,7 +463,7 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = let ppe = EcPrinting.PPEnv.ofenv env in let fapply_safe (f : form) (fs : form list) = - EcTypesafeFol.fapply_safe ~redmode hyps f fs + EcTypesafeFol.f_app ~redmode hyps f fs in (* Form level cache, local to each high-level call *) @@ -714,7 +714,7 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = try let redmode = circ_red hyps in let fapply_safe f fs = - let res = EcTypesafeFol.fapply_safe ~redmode hyps f fs in + let res = EcTypesafeFol.f_app ~redmode hyps f fs in res in match f, fs with diff --git a/src/ecTypesafeFol.ml b/src/ecTypesafeFol.ml index 83d1e9ba1c..c6e638cd00 100644 --- a/src/ecTypesafeFol.ml +++ b/src/ecTypesafeFol.ml @@ -10,7 +10,7 @@ open EcEnv module UE = EcUnify.UniEnv (* -------------------------------------------------------------------- *) -let f_app_safe +let f_op_app (env : env) ?(typarams : ty_params option) ?(rty : ty option) @@ -41,7 +41,7 @@ let f_app_safe f_app (f_op op tvars opty) args rty (* -------------------------------------------------------------------- *) -let fapply_safe +let f_app ?(redmode : EcReduction.reduction_info = EcReduction.full_red) (hyps : LDecl.hyps) (f : form) diff --git a/src/ecTypesafeFol.mli b/src/ecTypesafeFol.mli index 21e3fccfd5..b82d76ad2c 100644 --- a/src/ecTypesafeFol.mli +++ b/src/ecTypesafeFol.mli @@ -6,13 +6,13 @@ open EcAst with on-the-fly normalisation. Used by the circuit translation to bring applications into a reduced, translatable shape. *) -(* [f_app_safe env ?typarams ?rty op args] builds the application of the +(* [f_op_app env ?typarams ?rty op args] builds the application of the operator at path [op] to [args], instantiating its type variables. [?typarams] seeds the type parameters of the unification environment and [?rty] fixes the expected result type. It is an internal error (assert) if the application does not type — unification fails, or type variables remain unresolved. *) -val f_app_safe : +val f_op_app : EcEnv.env -> ?typarams:EcDecl.ty_params -> ?rty:EcTypes.ty @@ -20,10 +20,10 @@ val f_app_safe : -> form list -> form -(* [fapply_safe ~redmode hyps f fs] applies the function-form [f] to the +(* [f_app ~redmode hyps f fs] applies the function-form [f] to the argument-forms [fs], head-reducing the result under [redmode] (default [EcReduction.full_red]). *) -val fapply_safe : +val f_app : ?redmode:EcReduction.reduction_info -> EcEnv.LDecl.hyps -> form diff --git a/src/phl/ecPhlBDep.ml b/src/phl/ecPhlBDep.ml index 6eb0f9831a..47c22ec9b3 100644 --- a/src/phl/ecPhlBDep.ml +++ b/src/phl/ecPhlBDep.ml @@ -332,7 +332,7 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = in let goals = List.init len (fun i -> - EcTypesafeFol.fapply_safe (tc1_hyps tc) fpred [f_int EcBigInt.(of_int (i + start))] + EcTypesafeFol.f_app (tc1_hyps tc) fpred [f_int EcBigInt.(of_int (i + start))] ) in EcEnv.notify (tc1_env tc) `Debug "Got iota => [%d, %d)@.Goals: %a@." start len @@ -368,7 +368,7 @@ let t_extens (v: string option) (tt : backward) (tc : tcenv1) = (* let ngoals = min ngoals 5 in *) List.init ngoals (fun i -> let subst = EcPV.PVM.(add (tc1_env tc) (PVloc v.v_name) (fst hs.hs_m) - (EcTypesafeFol.f_app_safe (tc1_env tc) of_int [f_int BI.(of_int i)]) empty) + (EcTypesafeFol.f_op_app (tc1_env tc) of_int [f_int BI.(of_int i)]) empty) in let s = subst_pv_stmt (tc1_hyps tc) m subst hs.hs_s in let subst = EcPV.PVM.subst (tc1_env tc) subst in From 2028a4164654259956c4bb3ea674833e7a9de979 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 19:25:42 +0200 Subject: [PATCH 120/145] circuit: translate opaque circuit-typed leaves as fresh inputs A form whose type is a circuit type but which has no structural circuit translation -- a free variable, [witness], or an application of an opaque head such as [f 4] for an abstract [f : int -> W8] -- denotes an arbitrary value of that type. Model it uniformly as a fresh, form-cached input via the new [circuit_of_uninterpreted] (generalising the [witness] handling), so alpha-equal occurrences share one input while distinct terms get distinct ones. Previously such a leaf reached [Flocal _ -> state_get st idn] (or the opaque-head case of [circuit_of_app]) and raised [Not_found], surfacing as an anomaly. This left e.g. [(init f).[4] = f 4] unprovable even though it holds by the array axiom: element 4 of [init f] is [f 4], and both sides now resolve to the same cached input. The fallback is placed at the leaf, never as a [try/with] around the recursion: wrapping [circuit_of_node] would swallow a genuine error from a sub-term of a circuit-typed parent (e.g. a tuple) and mask the bug. [circuit_uninit] still raises a clean [CircError] for non-circuit types, so functions and ints fail as before. Regression tests in tests/circuit_soundness.ec: the positive lemmas guard completeness (shared inputs for alpha-equal leaves); the [fail circuit] negatives guard soundness (distinct leaves are not equated). --- src/ecCircuits.ml | 32 ++++++++++++++++++++++------- tests/circuit_soundness.ec | 41 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 66 insertions(+), 7 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index b80addf456..db62ba2966 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -472,6 +472,20 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = let int_of_form (f : form) : zint = int_of_form hyps f in + (* A circuit-typed form with no structural translation (an opaque leaf: + a free variable, [witness], or an application of an opaque head) is an + arbitrary value of its type, modelled as a fresh input and cached so + that alpha-equal occurrences share it. [circuit_uninit] raises a clean + [CircError] when the type is not circuit-translatable. *) + let circuit_of_uninterpreted (f_ : form) : circuit = + match EcAlphaInvHashtbl.find_opt cache f_ with + | Some circ -> circ + | None -> + let circ = circuit_uninit env f_.f_ty in + EcAlphaInvHashtbl.add cache f_ circ; + circ + in + (* Supposed to be called on an apply *) let propagate_integer_arguments (op : form) (args : form list) : form = let op = @@ -522,7 +536,11 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = | Fint _z -> circ_error (CantConvertToCirc `Int) - | Flocal idn -> state_get st idn + | Flocal idn -> + begin match state_get_opt st idn with + | Some c -> c + | None -> circuit_of_uninterpreted f_ + end | Fop (pth, _) -> circuit_of_op_form st f_ pth @@ -598,12 +616,7 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = EcEnv.notify env `Debug "Assigning witness to var of type %a@." EcPrinting.(pp_type ppe) f_.f_ty; - match EcAlphaInvHashtbl.find_opt cache f_ with - | Some circ -> circ - | None -> - let circ = circuit_uninit env f_.f_ty in - EcAlphaInvHashtbl.add cache f_ circ; - circ + circuit_of_uninterpreted f_ end else match Mp.find_opt pth !op_cache with | Some op -> op @@ -701,6 +714,11 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = | {f_node = Fop _}, _ -> (* Assuming correct types coming from EC *) circuit_of_logic_app st f fs + (* An application of an opaque (unbound) local is itself an opaque + leaf: model the whole application as a fresh input (cached below + by [f_]). *) + | {f_node = Flocal idn}, _ when Option.is_none (state_get_opt st idn) -> + circuit_uninit env f_.f_ty (* Recurse down into definition *) | _ -> let f_c = circuit_of_node st f in diff --git a/tests/circuit_soundness.ec b/tests/circuit_soundness.ec index a170fdfeaf..b8728eef0d 100644 --- a/tests/circuit_soundness.ec +++ b/tests/circuit_soundness.ec @@ -79,3 +79,44 @@ proof. circuit. qed. lemma witness_xor_self : witness<:W8> +^ witness<:W8> = zero. proof. circuit. qed. + +(* -------------------------------------------------------------------- *) +(* Completeness: a circuit-typed term with no structural translation *) +(* (a free variable, or an application of an opaque head) is an opaque *) +(* leaf modelled as a fresh, form-cached input -- not a [Not_found] *) +(* anomaly. Alpha-equal occurrences share their input. *) +theory A. + type 'a t. + op tolist : 'a t -> 'a list. + op oflist : 'a -> 'a list -> 'a t. + op "_.[_]" : 'a t -> int -> 'a. + op "_.[_<-_]" : 'a t -> int -> 'a -> 'a t. +end A. +bind array A."_.[_]" A."_.[_<-_]" A.tolist A.oflist A.t 8. +realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. +realize eqP by admit. realize get_setP by admit. realize get_out by admit. +export A. + +op init (f : int -> W8) : W8 A.t. +bind op [W8 & A.t] init "ainit". +realize bvainitP by admit. + +(* [(init f).[4]] applies the opaque [f] at index 4; both that occurrence *) +(* and the right-hand [f 4] resolve to the same cached input. *) +lemma opaque_app_shared (f : int -> W8) : (init f).[4] = f 4. +proof. circuit. qed. + +lemma opaque_app_xor_self (f : int -> W8) : f 4 +^ f 4 = zero. +proof. circuit. qed. + +(* A free variable of circuit type is itself an opaque leaf. *) +lemma free_var_refl (x : W8) : x = x. +proof. circuit. qed. + +(* Soundness of the sharing: DISTINCT opaque leaves get DISTINCT inputs, *) +(* so non-alpha-equal terms must NOT be equated. *) +lemma opaque_app_distinct (f : int -> W8) : f 4 = f 5. +proof. fail circuit. abort. + +lemma free_var_distinct (x y : W8) : x = y. +proof. fail circuit. abort. From c7b662d5a31e32cf3d2a1e2cca892776f930819e Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 20:11:26 +0200 Subject: [PATCH 121/145] circuit: label counter-model inputs with their source names The SMT counter-model printed under [Circuit:debug_smt] identified each input by its raw AIG id (e.g. "input 106225 = #b11111111"), which is opaque. Carry the source-level name on [cinp] (the [`Idn]/[`Str] used to create the input, e.g. a program variable's symbol) and resolve ids to names when rendering, so the dump reads "input a = #b11111111". Name resolution stays at the display boundary in [check_with_model]: the solver and [model] keep speaking in ids (the right layer for the backend), and the two [circ_equiv] call sites build the id->name map from the compared circuits' [cinp] lists. Unmapped ids fall back to their integer. --- src/ecCircuits.ml | 23 +++++++++++++++++----- src/ecLowCircuits.ml | 45 +++++++++++++++++++++++-------------------- src/ecLowCircuits.mli | 1 + 3 files changed, 43 insertions(+), 26 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index db62ba2966..e0b35a5231 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -40,17 +40,27 @@ let stopwatch (env : env) : string -> unit = [Circuit:debug_smt] flag (default off), enabled with [pragma Circuit:debug_smt.]; being lazy, the model is only forced when it is going to be printed. *) -let check_with_model (env : env) ((valid, model) : bool * model Lazy.t) : bool = +let check_with_model + (env : env) ?(names : (int * string) list = []) + ((valid, model) : bool * model Lazy.t) : bool = if (not valid) && EcGState.get_circuit_debug_smt (EcEnv.gstate env) then begin EcEnv.notify ~immediate:true env `Warning "[debug_smt] counter-model:@."; List.iter (fun (id, value) -> - EcEnv.notify ~immediate:true env `Warning "[debug_smt] input %d = %s@." - id value) + let label = odfl (string_of_int id) (List.assoc_opt id names) in + EcEnv.notify ~immediate:true env `Warning "[debug_smt] input %s = %s@." + label value) (Lazy.force model) end; valid +(* The [(input-id, source-name)] pairs of the inputs of [cs], for labelling + the counter-model. *) +let model_names (cs : circuit list) : (int * string) list = + List.concat_map + (fun (_, inps) -> List.map (fun (i : cinp) -> (i.id, i.name)) inps) + cs + (* -------------------------------------------------------------------- *) let circ_red (hyps : hyps) = let base_red = EcReduction.full_red in @@ -912,14 +922,17 @@ let instrs_equiv | None, Some _ | Some _, None -> false (* Variable only defined on one of the blocks (and not in the prelude) *) - | Some circ1, Some circ2 -> check_with_model env (circ_equiv circ1 circ2)) + | Some circ1, Some circ2 -> + check_with_model env ~names:(model_names [circ1; circ2]) + (circ_equiv circ1 circ2)) vs | None -> state_get_all_memory st mem |> List.for_all (fun (var, _) -> let circ1 = state_get_pv st1 mem var in let circ2 = state_get_pv st2 mem var in - check_with_model env (circ_equiv circ1 circ2)) + check_with_model env ~names:(model_names [circ1; circ2]) + (circ_equiv circ1 circ2)) let state_of_prog ?(close = false) diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index eb0d2fd20b..7dabf9ea3c 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -443,9 +443,10 @@ module type CircuitInterface = sig | CBool type cinp = { type_ : ctype; - id: int + id : int; + name : string; (* source-level name, for counter-model display *) } - type circ = { + type circ = { reg: flatcirc ; type_: ctype ; } @@ -609,7 +610,8 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = } type cinp = { type_ : ctype; - id : int; + id : int; + name : string; (* source-level name, for counter-model display *) } type 'a cfun = 'a * (cinp list) type circuit = circ cfun @@ -784,7 +786,7 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = | `Idn id -> id | `Str s -> EcIdent.create s in - { id = name.id_tag; type_ = t}, + { id = name.id_tag; type_ = t; name = EcIdent.name name}, ({ reg = Backend.input_of_size ~id:name.id_tag (size_of_ctype t); type_ = t}, []) (* Circuit lambdas, for managing inputs *) @@ -913,13 +915,13 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = size_of_ctype t1 = size_of_ctype t2 let input_of_ctype ?(name : [`Str of string | `Idn of ident] = `Str "input") (ct: ctype) : circuit = - let id, c = match name with + let id, nm, c = match name with | `Str name -> let id = EcIdent.create name |> tag in - id, Backend.input_of_size ~id (size_of_ctype ct) + id, name, Backend.input_of_size ~id (size_of_ctype ct) | `Idn idn -> let id = idn.id_tag in - id, Backend.input_of_size ~id (size_of_ctype ct) + id, EcIdent.name idn, Backend.input_of_size ~id (size_of_ctype ct) in - { reg = c; type_ = ct; }, [{ id; type_ = ct; }] + { reg = c; type_ = ct; }, [{ id; type_ = ct; name = nm }] let new_input_circuit ?(name = `Str "input") (ty: ctype) : circ * cinp = let c, inps = input_of_ctype ~name ty in @@ -1091,8 +1093,8 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let fillet_circuit ((c, inps) : circuit) : circuit list = let r = c.reg |> Backend.node_list_of_reg in List.map (fun n -> - let new_inps = List.map (fun {id=_;type_} -> - {id=EcIdent.create "_" |> tag; type_}) inps + let new_inps = List.map (fun {id=_;type_;name} -> + {id=EcIdent.create "_" |> tag; type_; name}) inps in let renamings = List.combine (List.map (fun {id} -> id) inps) @@ -1102,9 +1104,9 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let renamings = fun v -> Map.find_opt v renamings in let n', shifts = Backend.Deps.excise_bit ~renamings n in - let new_inps = List.filter_map (fun {id;_} -> + let new_inps = List.filter_map (fun {id;name;_} -> match Map.find_opt id shifts with - | Some (low, hi) -> Some {id; type_ = CBitstring (hi - low + 1)} + | Some (low, hi) -> Some {id; type_ = CBitstring (hi - low + 1); name} | None -> None ) new_inps in { reg = Backend.reg_of_node n'; @@ -1198,11 +1200,11 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = assert (c.type_ = CBool); let node_c = Backend.node_of_reg c.reg in let node_c, shifts = Backend.Deps.excise_bit node_c in - let inps = List.filter_map (fun {id; _} -> + let inps = List.filter_map (fun {id; name; _} -> match Map.find_opt id shifts with - | Some (low, hi) -> Some {id; type_ = CBitstring (hi - low + 1)} - | None -> None - ) cinps in + | Some (low, hi) -> Some {id; type_ = CBitstring (hi - low + 1); name} + | None -> None + ) cinps in let c = Backend.reg_of_node node_c in { reg = c; type_ = CBool}, inps @@ -1333,8 +1335,8 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = (size + 1, Map.add id (size, 1) map) ) (0, Map.empty) inps in - {type_ = CBitstring size; id=new_id}, - fun (id, bit) -> + {type_ = CBitstring size; id=new_id; name = "aggregated"}, + fun (id, bit) -> let base_sz = Map.find_opt id map in Option.bind base_sz (fun (base, sz) -> let idx = bit + base in @@ -1361,10 +1363,11 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = | None -> "spec_input" in - let cinps, inps = List.mapi (fun i ty -> - let id = EcIdent.create (name ^ "_" ^ (string_of_int i)) |> tag in + let cinps, inps = List.mapi (fun i ty -> + let nm = name ^ "_" ^ (string_of_int i) in + let id = EcIdent.create nm |> tag in let size : int = size_of_ctype ty in - (Backend.input_of_size ~id size, { type_ = ty; id = id; } ) + (Backend.input_of_size ~id size, { type_ = ty; id = id; name = nm } ) ) arg_tys |> List.split in let c = c cinps in { reg = c; type_ = ret_ty}, inps diff --git a/src/ecLowCircuits.mli b/src/ecLowCircuits.mli index 92c2912163..af47ca011f 100644 --- a/src/ecLowCircuits.mli +++ b/src/ecLowCircuits.mli @@ -25,6 +25,7 @@ type ctype = type cinp = { type_ : ctype; id : int; + name : string; (* source-level name, for counter-model display *) } (* A circuit: a register together with its type. *) From e759decb5b289142ecd009681366f0f5d207a643 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 20:25:26 +0200 Subject: [PATCH 122/145] lospecs/aig: add an interface exposing only the used surface Restrict Aig's public API to what its consumers (circuit, circuit_spec, deps, smt, ecLowCircuits) actually use: the AIG node/reg types, the gate combinators, [map]/[maps], [pp_node], [HCons.clear] and [write_aiger_bin_temp]. --- libs/lospecs/aig.mli | 61 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 61 insertions(+) create mode 100644 libs/lospecs/aig.mli diff --git a/libs/lospecs/aig.mli b/libs/lospecs/aig.mli new file mode 100644 index 0000000000..134cac0735 --- /dev/null +++ b/libs/lospecs/aig.mli @@ -0,0 +1,61 @@ +(* -------------------------------------------------------------------- *) +(* And-Inverter Graphs: hash-consed boolean circuits. A [node] is a + shared, structurally-unique gate; [neg] points to its complement and + the sign of [id] gives the polarity (so negation is free). *) +type name = int + +type var = name * int + +type node_r = + | False + | Input of var + | And of node * node + +and node = { + gate : node_r; + id : int; + neg : node; +} + +type reg = node array + +(* -------------------------------------------------------------------- *) +(* Leaves and constants. *) +val false_ : node +val true_ : node +val constant : bool -> node +val input : var -> node + +(* -------------------------------------------------------------------- *) +(* Boolean combinators (structure-sharing, with constant folding). *) +val neg : node -> node +val and_ : node -> node -> node +val nand : node -> node -> node +val or_ : node -> node -> node +val xor : node -> node -> node +val xnor : node -> node -> node + +(* -------------------------------------------------------------------- *) +(* [map env] / [maps env] rewrite the inputs of a node / register, [env] + giving the replacement node for an input (or [None] to keep it). *) +val map : (var -> node option) -> node -> node +val maps : (var -> node option) -> reg -> reg + +(* -------------------------------------------------------------------- *) +val pp_node : + ?input_namer:(int -> string) -> Format.formatter -> node -> unit + +(* -------------------------------------------------------------------- *) +(* Clears the global hash-consing table. *) +module HCons : sig + val clear : unit -> unit +end + +(* -------------------------------------------------------------------- *) +(* Serialize [r] to a fresh temporary ".aig" file; returns its path. *) +val write_aiger_bin_temp : + input_count:int + -> ?inp_name_map:(int -> string) + -> ?name:string + -> reg + -> string From 33a5188fe266354a787a84ace7e669671f7af0d6 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 20:25:26 +0200 Subject: [PATCH 123/145] lospecs/aig: remove dead code With the interface in place, these were unreachable (no consumer uses them and they are unused internally): the input evaluator [eval]/[evals]/ [eval0]/[env_of_regs]/[get_bit], structural equivalence [equivs], the [VarRange]/[deps_]/[deps] dependency analysis (superseded by the Deps module), the AIGER reader [load] with [u2si]/[si2u]/[InvalidWire]/ [InvalidAIG], [abc_check_equiv], [fresh], and the unused [@@deriving yojson] serializers. --- libs/lospecs/aig.ml | 408 -------------------------------------------- 1 file changed, 408 deletions(-) diff --git a/libs/lospecs/aig.ml b/libs/lospecs/aig.ml index 7cefdc5ae8..53b1c084ab 100644 --- a/libs/lospecs/aig.ml +++ b/libs/lospecs/aig.ml @@ -1,33 +1,23 @@ (* -------------------------------------------------------------------- *) type name = int -[@@deriving yojson] (* -------------------------------------------------------------------- *) type var = name * int -[@@deriving yojson] (* -------------------------------------------------------------------- *) type node_r = | False | Input of var | And of node * node -[@@deriving yojson] and node = { gate : node_r; id : int; neg : node; } -[@@deriving yojson] - -(* -------------------------------------------------------------------- *) -let fresh = - let counter = ref 0 in - fun () -> incr counter; !counter (* -------------------------------------------------------------------- *) type reg = node array -[@@deriving yojson] (* -------------------------------------------------------------------- *) module HCons : sig @@ -146,15 +136,6 @@ let xor (n1 : node) (n2 : node) : node = let xnor (n1 : node) (n2 : node) : node = neg (xor n1 n2) -(* -------------------------------------------------------------------- *) -let get_bit (b : bytes) (i : int) = - Char.code (Bytes.get b (i / 8)) lsr (i mod 8) land 0b1 <> 0 - -(* -------------------------------------------------------------------- *) -let env_of_regs (rs : bytes list) = - let rs = Array.of_list rs in - fun ((n, i) : var) -> get_bit rs.(n) i - (* ==================================================================== *) let map (env : var -> node option) : node -> node = let cache : (int, node) Hashtbl.t = Hashtbl.create 0 in @@ -186,171 +167,6 @@ let map (env : var -> node option) : node -> node = let maps (env : var -> node option) : reg -> reg = fun r -> Array.map (map env) r -(* ==================================================================== *) -let equivs (inputs : (var * var) list) (c1 : reg) (c2 : reg) : bool = - let inputs = Map.of_seq (List.to_seq inputs) in - let env (v : var) = Option.map input (Map.find_opt v inputs) in - Array.for_all2 (==) (maps env c1) c2 - -(* ==================================================================== *) -let eval (env : var -> bool) = - let cache : (int, bool) Hashtbl.t = Hashtbl.create 0 in - - let rec for_node (n : node) = - let value = - match Hashtbl.find_option cache (abs n.id) with - | None -> - let value = for_node_r n.gate in - Hashtbl.add cache (abs n.id) value; - value - | Some value -> - value - - in if 0 < n.id then value else not value - - and for_node_r (n : node_r) = - match n with - | False -> false - | Input x -> env x - | And (n1, n2) -> for_node n1 && for_node n2 - - in fun (n : node) -> for_node n - -(* -------------------------------------------------------------------- *) -let evals (env : var -> bool) = - List.map (eval env) - -(* -------------------------------------------------------------------- *) -let eval0 (n : node) = - eval (fun (_ : var) -> false) n - -(* ==================================================================== *) -module VarRange : sig - type 'a t - - val empty : 'a t - - val push : 'a t -> ('a * int) -> 'a t - - val contents : 'a t -> ('a * (int * int) list) list - - val pp : - (Format.formatter -> 'a -> unit) - -> Format.formatter - -> 'a t - -> unit -end = struct - type range = int * int - - type ranges = range list - - type 'a dep1 = 'a * ranges - - type 'a t = ('a, ranges) Map.t - - let empty : 'a t = - Map.empty - - let rec add (rg : ranges) (v : int) = - match rg with - | [] -> - [(v, v)] - - (* join two segments *) - | (lo, hi) :: (lo', hi') :: tl when hi+1 = v && v+1 = lo' -> - (lo, hi') :: tl - - (* add to the front of a segment *) - | (lo, hi) :: tl when v+1 = lo -> - (v, hi) :: tl - - (* add to the back of a segment *) - | (lo, hi) :: tl when hi+1 = v -> - (lo, v) :: tl - - | hd :: tl -> - hd :: add tl v - - let push (r : 'a t) ((n, i) : 'a * int) : 'a t = - let change (rg : ranges option) = - Some (add (Option.default [] rg) i) - in Map.modify_opt n change r - - let contents (r : 'a t) : ('a * ranges) list = - Map.bindings r - - let pp - (pp : Format.formatter -> 'a -> unit) - (fmt : Format.formatter) - (r : 'a t) - = - let pp_range (fmt : Format.formatter) ((lo, hi) : range) = - if lo = hi then - Format.fprintf fmt "%d" lo - else - Format.fprintf fmt "%d-%d" lo hi in - - let pp_ranges (fmt : Format.formatter) (rgs : ranges) = - Format.fprintf fmt "%a" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt ",") - pp_range) - rgs in - - let pp_dep1 (fmt : Format.formatter) ((v, rgs) : 'a dep1) = - Format.fprintf fmt "%a#%a" pp v pp_ranges rgs in - - Format.fprintf fmt "%a" - (Format.pp_print_list - ~pp_sep:(fun fmt () -> Format.fprintf fmt "; ") - pp_dep1) - (Map.bindings r) -end - -(* ==================================================================== *) -let deps_ () = - let cache : (int, var Set.t) Hashtbl.t = Hashtbl.create 0 in - - let rec doit_force (n : node) = - match n.gate with - | False -> Set.empty - | Input v -> Set.singleton v - | And (n1, n2) -> Set.union (doit n1) (doit n2) - - and doit (n : node) = - match Hashtbl.find_option cache (abs n.id) with - | Some value -> - value - | None -> - let value = doit_force n in - Hashtbl.add cache (abs n.id) value; value - - in fun (n : node) -> doit n - -(* -------------------------------------------------------------------- *) -let deps (r : reg) = - let out = ref [] in - - let push (hi : int) (dhi : var Set.t) = - match !out with - | _ when Set.is_empty dhi -> - () - | ((lo, v), dlo) :: tl when v+1 = hi && not (Set.disjoint dlo dhi) -> - out := ((lo, hi), Set.union dlo dhi) :: tl - | _ -> - out := ((hi, hi), dhi) :: !out in - - Array.iteri push (Array.map (deps_ ()) r); - !out - |> List.rev_map (fun (r, vs) -> - let vs = - Set.fold - (fun v vs -> VarRange.push vs v) - vs VarRange.empty - in (r, vs) - ) - |> List.sort (fun (r1, _) (r2, _) -> compare r1 r2) - exception AigerError of string (* -------------------------------------------------------------------- *) @@ -460,227 +276,3 @@ let write_aiger_bin_temp let tf_oc = BatIO.output_channel ~cleanup:true tf_oc in write_aiger_bin ~input_count ?inp_name_map tf_oc r; tf_name - -(* Assumes inputs are already matched *) -let abc_check_equiv - ?(r1_name = "r1") - ?(r2_name = "r2") - ~(input_count: int) - ?(inp_name_map: (int -> string) option) - (r1: reg) (r2: reg) : bool = - - let tf1_name, tf1_oc = Filename.open_temp_file ~mode:[Open_binary] r1_name ".aig" in - let tf2_name, tf2_oc = Filename.open_temp_file ~mode:[Open_binary] r2_name ".aig" in - Format.eprintf "Created temp files (%s) (%s)!@." tf1_name tf2_name; - let tf1_oc = BatIO.output_channel ~cleanup:true tf1_oc in - let tf2_oc = BatIO.output_channel ~cleanup:true tf2_oc in - write_aiger_bin ~input_count ?inp_name_map tf1_oc r1; - write_aiger_bin ~input_count ?inp_name_map tf2_oc r2; - Format.eprintf "Wrote aig files!@."; - BatIO.close_out tf1_oc; BatIO.close_out tf2_oc; - let abc_command = Format.sprintf "cec %s %s" tf1_name tf2_name in - Format.eprintf "Abc command: %s@." abc_command; - let abc_output_c, abc_in = Unix.open_process "abc" in -(* let abc_in = BatIO.output_channel ~cleanup:true abc_in in *) - BatIO.write_string abc_in (abc_command ^ "\n"); - BatIO.close_out abc_in; -(* let abc_output_c = BatIO.input_channel ~autoclose:true ~cleanup:true abc_output_c in *) - let re = Str.regexp {|.*Networks are equivalent.*|} in - Format.eprintf "Before read@."; - let abc_output = BatIO.read_all abc_output_c in - Format.eprintf "====== BEGIN ABC OUTPUT =====@.%s@.======= END ABC OUTPUT =====@." abc_output; - let abc_output = String.replace_chars (function | '\n' -> "|" | c -> String.of_char c) abc_output in - if Str.string_match re abc_output 0 then true else false - -(* -------------------------------------------------------------------- *) -exception InvalidWire - -(* -------------------------------------------------------------------- *) -(* true -> positive wire *) -let u2si (u : int) : bool * int = - if u < 0 then raise InvalidWire; - let s = (u land 0b1) = 0 in - let i = u lsr 1 in (* We divide by 2 *) - (s, i) - -(* -------------------------------------------------------------------- *) -let si2u ((b, i) : bool * int) : int = - assert (0 <= i); - (i lsl 1) lor (match b with true -> 0 | false -> 1) - -(* -------------------------------------------------------------------- *) -exception InvalidAIG of string - -(* -------------------------------------------------------------------- *) -(* Load an aig file *) -let load (inp : IO.input) : reg * (Set.String.t * string array) option = - let parse_asuint = - let re = Str.regexp "^[0-9]+$" in - - let doit (x : string) = - if not (Str.string_match re x 0) then - raise (InvalidAIG ("not a valid uint: " ^ x)); - (match int_of_string_opt x with - | Some x -> x - | None -> raise (InvalidAIG ("error in parsing in from string: " ^ x)) - ) - in fun x -> doit x in - - let header = String.trim (IO.read_line inp) in - let header = Str.split (Str.regexp "[ \t]+") header in - let header = Array.of_list header in - - if Array.length header <> 6 || header.(0) <> "aig" then - raise (InvalidAIG "invalid header"); - - let c_m = parse_asuint header.(1) in (* maximum variable index *) - let c_i = parse_asuint header.(2) in (* number of inputs *) - let c_l = parse_asuint header.(3) in (* number of latches *) - let c_o = parse_asuint header.(4) in (* number of outputs *) - let c_a = parse_asuint header.(5) in (* number of AND gates *) - - (* We have c_l = 0 so /\ c_m = c_i + c_l + c_a - * - * Hence: c_m = c_i + c_a - *) - - if c_m <> c_i + c_l + c_a || c_l <> 0 then - raise (InvalidAIG "invalid header (sum)"); - - let outputs = ref [] in - - (* Reading outputs *) - for _ = 1 to c_o do - let output = String.trim (IO.read_line inp) in - let (_, u) as output = u2si (parse_asuint output) in - - if not (0 <= u && u <= c_m) then - raise (InvalidAIG "invalid output"); - - outputs := output :: !outputs - done; - - let outputs = Array.of_list (List.rev !outputs) in - - (* Reading arguments of AND gate *) - let read_uint () = - let exception Done in - - let i, o = ref 0, ref 0 in - try - while true do - assert (!o < 4); - let d = IO.read_byte inp in - i := !i lor ((d land 0x7f) lsl (7 * !o)); - o := !o + 1; - if (d land 0x80) = 0 then - raise Done - done; - assert false - with Done -> !i - in - - - let gates = List.fold_left (fun map -> function - | 0 -> - Map.add 0 false_ map - - | i when 0 < i && i <= c_i -> - Map.add i (input (0, i-1)) map - - | i when c_i < i && i <= c_i + c_a -> - let delta0 = read_uint () in - let delta1 = read_uint () in - - if delta0 = 0 then - raise (InvalidAIG "invalid delta0"); - - (* delta0 = lhs - rhs0, delta1 = rhs0 - rhs1 *) - - let lhs = 2 * i in - let rhs0_ = lhs - delta0 in - let rhs1_ = rhs0_ - delta1 in - - if lhs = c_i*2 + 2 then - Format.eprintf "Lhs: %d | Rhs0: %d | Rhs1: %d@." lhs rhs0_ rhs1_; - - let (b1, u1) = try - u2si rhs0_ - with InvalidWire -> - Format.eprintf "Invalid wire for rhs0 for params: lhs: %d | rhs0: %d | rhs1: %d@." lhs rhs0_ rhs1_; assert false - in - let (b2, u2) = try - u2si rhs1_ - with InvalidWire -> - Format.eprintf "Invalid wire for rhs1 for params: lhs: %d | rhs0: %d | rhs1: %d@." lhs rhs0_ rhs1_; assert false - in - - let n1 = Map.find u1 map in - let n1 = if b1 then n1 else n1.neg in - let n2 = Map.find u2 map in - let n2 = if b2 then n2 else n2.neg in - - if not (u1 <= c_m && u2 <= c_m) then - raise (InvalidAIG "invalid delta1"); - - Map.add i (and_ n1 n2) map - - | _ -> - assert false - ) Map.empty (List.init (c_i + c_a + 1) (fun i -> i)) in - - (* Reading annotations *) - let ainputs = Array.make c_i None in - - begin try - while true do - let exception Continue in - - try - let line = String.trim (IO.read_line inp) in - - if line = "" then - raise Continue; - if line = "c" then - raise IO.No_more_input; - - if not ( - Str.string_match - (Str.regexp "^i\\([0-9]+\\)[ \t]+\\(.*\\)$") - line 0 - ) then raise (InvalidAIG ("invalid annotation: " ^ line)); - - let s = Str.matched_group 2 line in - let i = parse_asuint (Str.matched_group 1 line) in - - if not (i < c_i) then - raise (InvalidAIG "invalid annotation (index)"); - - if Option.is_some ainputs.(i) then - raise (InvalidAIG "invalid annotation (dup. index)"); - - ainputs.(i) <- Some s - - with Continue -> () - done - - with IO.No_more_input -> () end; - - let ainputs = - if Array.for_all Option.is_none ainputs then - None - else if Array.exists Option.is_none ainputs then - raise (InvalidAIG "invalid annotation (partial)") - else - let ainputs = Array.map Option.get ainputs in - let keys = Set.String.of_array ainputs in - - if Set.String.cardinal keys <> Array.length ainputs then - raise (InvalidAIG "invalid annotation (dup)"); - Some (keys, ainputs) - in - - (* Construct network *) - Array.map (fun (b, i) -> - if b then (Map.find i gates).neg else Map.find i gates - ) outputs, ainputs From 6d3401d26e71223af3bfb74f0fa331a5573e0ff2 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 20:29:15 +0200 Subject: [PATCH 124/145] lospecs: drop the dead AIGER-file-writing chain [circuit_to_file] (ecLowCircuits) was exported but never called, keeping alive [reg_to_file] and, through it, the whole AIGER serialization in aig.ml. Remove the chain end to end: [circuit_to_file]/[reg_to_file] and the now-unused [UnsupportedTypeForFileOutput] error in ecLowCircuits, and [write_aiger_bin_temp]/[write_aiger_bin]/[aiger_preprocess]/ [aiger_serialize_int]/[pp_aiger_int]/[pp_aiger_and]/[AigerError] in aig.ml. aig.ml is now just the AIG core: node/reg types, gate combinators, map/maps, pp_node and HCons. --- libs/lospecs/aig.ml | 110 ------------------------------------------ libs/lospecs/aig.mli | 9 ---- src/ecLowCircuits.ml | 17 +------ src/ecLowCircuits.mli | 1 - 4 files changed, 1 insertion(+), 136 deletions(-) diff --git a/libs/lospecs/aig.ml b/libs/lospecs/aig.ml index 53b1c084ab..f09b58acb4 100644 --- a/libs/lospecs/aig.ml +++ b/libs/lospecs/aig.ml @@ -166,113 +166,3 @@ let map (env : var -> node option) : node -> node = (* -------------------------------------------------------------------- *) let maps (env : var -> node option) : reg -> reg = fun r -> Array.map (map env) r - -exception AigerError of string - -(* -------------------------------------------------------------------- *) -(* SERIALIZATION *) -(* Return map of indice renaming + list of and gates (increasing order) + (max variable index, and gate count, input gate count) *) -let aiger_preprocess ~(input_count: int) (r: reg) : (node -> int) * (node list) * (int * int * int) = - let cache : (int, int) Hashtbl.t = Hashtbl.create 0 in - let count_and = ref 0 in - let and_gates = ref [] in - - let rec doit (n: node) : unit = - match Hashtbl.find_option cache (abs n.id) with - | Some v -> () - | None -> - let value = doit_force n in - Hashtbl.add cache (abs n.id) value - - and doit_force (n: node) = - match n.gate with - | False -> 0 - | Input (v, i) -> 64*v + i - | And (n1, n2) -> - doit n1; doit n2; - incr count_and; - and_gates := n::(!and_gates); - !count_and - in - - Array.iter doit r; - let and_cnt = !count_and in - let inp_cnt = input_count in - let id_map = - Hashtbl.to_seq cache |> Map.of_seq - in - let id_map = (function - | { gate = False; id } -> (if 0 < id then 0 else 1) - | { gate = And _; id } -> ((Map.find (abs id) id_map) + inp_cnt) lsl 1 + (if 0 < id then 0 else 1) - | { gate = Input _; id } -> (Map.find (abs id) id_map) lsl 1 + (if 0 < id then 0 else 1) - ) in - id_map, - List.sort (fun n1 n2 -> compare (id_map n1) (id_map n2)) !and_gates, - (and_cnt + inp_cnt, and_cnt, inp_cnt) - -let aiger_serialize_int (id: int) : string = - if not (id > 0) then raise (AigerError "serialize_int"); - let mask = 0x7f in - let rec doit (id: int) : int list = - if id < 0x80 then - [id] - else - ((id land mask) lor (0x80))::(doit (id lsr 7)) - in - - List.fold_left (fun acc id -> (Format.sprintf "%c" (char_of_int id)) ^ acc) "" (List.rev (doit id)) - -let pp_aiger_int fmt (id: int) : unit = - Format.fprintf fmt "%s" (aiger_serialize_int id) - -let pp_aiger_and fmt ((gid, id1, id2): int * int * int) : unit = - if not (gid > id1 && id1 > id2) then Format.eprintf "gid : %d | id1: %d | id2: %d@." gid id1 id2; - assert (gid > id1 && id1 > id2); - let delta0 = gid - id1 in - let delta1 = id1 - id2 in - assert(delta0 > 0 && delta1 > 0); - assert(id1 = gid - delta0); - assert(gid - delta0 - delta1 = id2); - Format.fprintf fmt "%a%a" pp_aiger_int (gid - id1) pp_aiger_int (id1 - id2) - -(* - mvi -> Max Variable Index - agc -> And Gate Count - igc -> Input Gate Count - lgc -> Latch Gate Count - ogc -> Output Gate Count -*) -let write_aiger_bin - ~(input_count: int) - ?(inp_name_map : int -> string = fun (i: int) -> "inp" ^ (string_of_int i)) - oc - (r: reg) = - let aiger_id_of_node, and_gates, (mvi, agc, igc) = aiger_preprocess ~input_count r in - - let ogc = Array.length r in - let lgc = 0 in - Printf.fprintf oc "aig %d %d %d %d %d\n" mvi igc lgc ogc agc; - Array.iter (fun n -> Printf.fprintf oc "%d\n" (aiger_id_of_node n)) r; - List.iter (function - | { gate = And (n1, n2); } as n -> - let id = aiger_id_of_node n in - let id1 = aiger_id_of_node n1 in - let id2 = aiger_id_of_node n2 in - let id = id - (id land 1) in - let id1, id2 = if id1 > id2 then id1, id2 else id2, id1 in - Printf.fprintf oc "%s" (Format.asprintf "%a" pp_aiger_and (id, id1, id2)) - | _ -> assert false (* Should not be triggered *) - ) and_gates; - for i = 0 to igc-1 do - Printf.fprintf oc "i%d %s@\n" i (inp_name_map i) - done - -let write_aiger_bin_temp - ~(input_count: int) - ?(inp_name_map: (int -> string) option) - ?(name: string = "circuit") - (r: reg) = - let tf_name, tf_oc = Filename.open_temp_file ~mode:[Open_binary] name ".aig" in - let tf_oc = BatIO.output_channel ~cleanup:true tf_oc in - write_aiger_bin ~input_count ?inp_name_map tf_oc r; - tf_name diff --git a/libs/lospecs/aig.mli b/libs/lospecs/aig.mli index 134cac0735..dc586315df 100644 --- a/libs/lospecs/aig.mli +++ b/libs/lospecs/aig.mli @@ -50,12 +50,3 @@ val pp_node : module HCons : sig val clear : unit -> unit end - -(* -------------------------------------------------------------------- *) -(* Serialize [r] to a fresh temporary ".aig" file; returns its path. *) -val write_aiger_bin_temp : - input_count:int - -> ?inp_name_map:(int -> string) - -> ?name:string - -> reg - -> string diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index 7dabf9ea3c..e74104e57b 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -131,8 +131,6 @@ module type CBackend = sig val flatten : reg list -> reg - val reg_to_file : input_count:int -> ?inp_name_map:(int -> string) -> name:string -> reg -> symbol - module Deps : sig type dep = (int, int Set.t) Map.t type deps = dep array @@ -322,10 +320,7 @@ module LospecsBack : CBackend = struct let concat (r1: reg) (r2: reg) : reg = Array.append r1 r2 let flatten (rs: reg list) : reg = Array.concat rs - let reg_to_file ~(input_count: int) ?(inp_name_map: (int -> string) option) ~(name: string) (r: reg) : symbol = - C.write_aiger_bin_temp ~input_count ?inp_name_map ~name r - - module Deps = struct + module Deps = struct type dep = (int, int Set.t) Map.t type deps = dep array type block_deps = (int * dep) array @@ -585,9 +580,6 @@ module type CircuitInterface = sig val fillet_tauts : ?logger:(string -> unit) -> circuit list -> circuit list -> bool val batch_checks : ?logger:(string -> unit) -> ?sort:bool -> ?mode:[`ByEq | `BySub ] -> circuit list -> circuit list - (* Wraps the backend call to deal with args/inputs *) - val circuit_to_file : name:string -> circuit -> symbol - val circuit_from_spec : ?name:symbol -> (ctype list * ctype) -> Lospecs.Ast.adef -> circuit end @@ -644,7 +636,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = | CircSmtNonBoolCirc | CircComputeBadNumberOfArguments of { expected: int; received: int} | CircComputeInvalidArguments of int - | UnsupportedTypeForFileOutput | CloseWithoutLambda exception LowCircError of lowcircerror @@ -1349,12 +1340,6 @@ module MakeCircuitInterfaceFromCBackend(Backend: CBackend) : CircuitInterface = let inp, renamer = input_aggregate_renamer inps in {c with reg = Backend.applys renamer c.reg}, [inp] - let circuit_to_file ~(name: string) ((c, inps): circuit) : symbol = - match c, inps with - | {reg = r; type_ = CBitstring _}, {type_ = CBitstring w; id}::[] -> - Backend.reg_to_file ~input_count:w ~name (Backend.applys (fun (id_, i) -> if id_ = id then Some (Backend.input_node ~id:0 (i+1)) else None) r) - | _ -> lowcircerror @@ UnsupportedTypeForFileOutput - let circuit_from_spec ?(name: symbol option) ((arg_tys, ret_ty) : (ctype list * ctype)) (spec: Lospecs.Ast.adef) : circuit = let c = Backend.circuit_from_spec spec in diff --git a/src/ecLowCircuits.mli b/src/ecLowCircuits.mli index af47ca011f..381b529e7d 100644 --- a/src/ecLowCircuits.mli +++ b/src/ecLowCircuits.mli @@ -170,7 +170,6 @@ val batch_checks : -> circuit list -> circuit list -val circuit_to_file : name:symbol -> circuit -> symbol val circuit_from_spec : ?name:symbol -> (ctype list * ctype) -> Lospecs.Ast.adef -> circuit (* -------------------------------------------------------------------- *) From 1206f614b62758ae3f7b71404433563d2a8d0608 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 20:31:01 +0200 Subject: [PATCH 125/145] lospecs/aig: make the node type private Nodes are hash-consed: a valid [node] can only come from the smart constructors, which maintain the [id]/[neg] sharing invariant. Exposing the record as [private] lets consumers read fields and pattern-match while forbidding hand-built nodes that would break that invariant. No consumer constructed nodes directly, so this is interface-only. --- libs/lospecs/aig.mli | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/libs/lospecs/aig.mli b/libs/lospecs/aig.mli index dc586315df..bcacd5dc71 100644 --- a/libs/lospecs/aig.mli +++ b/libs/lospecs/aig.mli @@ -6,12 +6,15 @@ type name = int type var = name * int +(* [node] is private: nodes are hash-consed, so the only way to build one + is through the smart constructors below (which preserve the [id]/[neg] + sharing invariant). Fields stay readable and the type matchable. *) type node_r = | False | Input of var | And of node * node -and node = { +and node = private { gate : node_r; id : int; neg : node; From 5da59d64479bb3a67a89b0c281ba5982606b837d Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 20:33:41 +0200 Subject: [PATCH 126/145] lospecs/deps: add an interface exposing only the used surface Restrict Deps' public API to what ecLowCircuits actually uses: the [tdeps] map type (exposed concretely, as callers manipulate it as a plain map), [reset_state], [dep]/[deps], [merge_deps] and [realign_inputs]. --- libs/lospecs/deps.mli | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) create mode 100644 libs/lospecs/deps.mli diff --git a/libs/lospecs/deps.mli b/libs/lospecs/deps.mli new file mode 100644 index 0000000000..bbb049c89b --- /dev/null +++ b/libs/lospecs/deps.mli @@ -0,0 +1,27 @@ +(* -------------------------------------------------------------------- *) +(* Bit-level dependency analysis over AIGs: for each output bit, which + bits of which inputs it depends on. *) + +(* [tdeps] maps an input variable [i] to the set of its bits [j] that a + given output bit depends on. Exposed concretely: consumers manipulate + it as a plain map. *) +type tdeps = (int, int Set.t) Map.t + +(* -------------------------------------------------------------------- *) +(* Clears the memoization cache. *) +val reset_state : unit -> unit + +(* [dep n] / [deps r] are the dependencies of a node / of each output bit + of a register. *) +val dep : Aig.node -> tdeps +val deps : Aig.reg -> tdeps array + +val merge_deps : tdeps -> tdeps -> tdeps + +(* [realign_inputs ?renamings n] rewrites [n] so each input's used bits + start at 0, returning the rewritten node and the per-input [(lo, hi)] + shift that was applied. *) +val realign_inputs : + ?renamings:(int -> int option) + -> Aig.node + -> Aig.node * (int, int * int) Map.t From 32e4ca54e4403615476ae484684af960d3af052a Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 20:36:39 +0200 Subject: [PATCH 127/145] lospecs/deps: remove dead code With the interface in place, these were unreachable (ecLowCircuits uses only dep/deps/merge_deps/realign_inputs/reset_state): the input collectors inputs_of_node/inputs_of_reg, the whole block-dependency layer (block_deps, blocks_indep, block_list_indep, split_deps, check_dep_width, tdblock_of_tdeps, compare_dep_size, compare_tdblocks, collapse_blocks) and its tdblock type, and the pretty-printers pp_dep/pp_deps/pp_bdep/pp_bdeps. --- libs/lospecs/deps.ml | 127 ------------------------------------------- 1 file changed, 127 deletions(-) diff --git a/libs/lospecs/deps.ml b/libs/lospecs/deps.ml index f05fabddf0..415f1599a0 100644 --- a/libs/lospecs/deps.ml +++ b/libs/lospecs/deps.ml @@ -2,39 +2,9 @@ open Aig module Hashtbl = Batteries.Hashtbl -(* ------------------------------------------------------------------------------- *) -let rec inputs_of_node : _ -> Aig.var Set.t = - let cache : (int, Aig.var Set.t) Hashtbl.t = Hashtbl.create 0 in - - let rec doit (n : Aig.node) : Aig.var Set.t = - match Hashtbl.find_option cache (Int.abs n.id) with - | None -> - let mn = doit_r n.gate in - Hashtbl.add cache (Int.abs n.id) mn; - mn - | Some mn -> - mn - - and doit_r (n : Aig.node_r) = - match n with - | False -> Set.empty - | Input v -> Set.singleton v - | And (n1, n2) -> Set.union (doit n1) (doit n2) - - in fun n -> doit n - -(* ------------------------------------------------------------------------------- *) -let inputs_of_reg (r : Aig.reg) : Aig.var Set.t = - Array.fold_left (fun acc x -> Set.union acc (inputs_of_node x)) Set.empty r - (* tdeps : int -> int set ; dependency for a single output bit i |-> {j | output depends on bit j of var i }*) type tdeps = (int, int Set.t) Map.t -(* tdblock (n, d) = merged dependencies as above for n bits - aka, the tdep represents dependencies for n bits rather than 1 -*) -type tdblock = (int * tdeps) - let cache : (int, tdeps) Hashtbl.t = Hashtbl.create 5003 @@ -66,92 +36,9 @@ let rec dep : _ -> tdeps = let deps (n: reg) : tdeps array = Array.map dep n -let block_deps (d: tdeps array) : tdblock list = - let drop_while_count (f: 'a -> bool) (l: 'a list) : int * ('a list) = - let rec doit (n: int) (l: 'a list) = - match l with - | [] -> (n, []) - | a::l' -> if f a then doit (n+1) l' else (n, l) - in - let n, tl = doit 0 l in - (n, tl) - in - let rec decompose (l: tdeps list) : tdblock list = - match l with - | [] -> [] - | h::_ -> let n, l' = - (drop_while_count (fun a -> Map.equal (Set.equal) h a) l) in - (n, h)::(decompose l') - in - decompose (Array.to_list d) - -let blocks_indep ((_,b):tdblock) ((_,d):tdblock) : bool = - let keys = Set.intersect (Set.of_enum @@ Map.keys b) (Set.of_enum @@ Map.keys d) in - let intersects = Set.map (fun k -> - let b1 = Map.find k b in - let d1 = Map.find k d in - (Set.cardinal @@ Set.intersect b1 d1) = 0 - ) keys in - Set.fold (&&) intersects true - -let block_list_indep (bs: tdblock list) : bool = - let rec doit (bs: tdblock list) (acc: tdblock list) : bool = - match bs with - | [] -> true - | b::bs -> List.for_all (blocks_indep b) acc && doit bs (b::acc) - in - doit bs [] - let merge_deps (d1: tdeps) (d2: tdeps) : tdeps = Map.union_stdlib (fun _ a b -> Option.some (Set.union a b)) d1 d2 -let split_deps (n: int) (d: tdeps array) : tdblock list = - assert (Array.length d mod n = 0); - let combine (d: tdeps list) : tdeps = - List.reduce merge_deps d - in - let rec aggregate (acc: tdblock list) (d: tdeps array) : tdblock list = - match d with - | [| |] -> acc - | _ -> (aggregate ((n, combine (Array.head d n |> Array.to_list))::acc) (Array.tail d n)) - in - List.rev @@ aggregate [] d - -let check_dep_width ?(eq=false) (n: int) (d: tdeps) : bool = - Map.fold (fun s acc -> let m = (Set.cardinal s) in - if eq then - acc && (n = m) - else - acc && (m <= n) - ) d true - -(* maybe optimize this? *) -let tdblock_of_tdeps (d: tdeps list) : tdblock = - (List.length d, List.reduce merge_deps d) - -(* - Take a list of blocks and drop all but the first block if the - sizes are the same and the dependecy amounts are the same -*) -let compare_dep_size (a: tdeps) (b: tdeps) : bool = - (Map.fold (fun s acc -> acc + (Set.cardinal s)) a 0) = - (Map.fold (fun s acc -> acc + (Set.cardinal s)) b 0) - -let compare_tdblocks ((na, da): tdblock) ((nb, db): tdblock) : bool = - (na = nb) && compare_dep_size da db - -let collapse_blocks (d: tdblock list) : tdblock option = - match d with - | [] -> None - | h::t -> - List.fold_left - (fun a b -> - match a with - | None -> None - | Some a -> if compare_tdblocks a b - then Some a else None) - (Some h) t - (* -------------------------------------------------------------------- *) (* Uses dependency analysis to realign inputs to start at 0 *) (* Corresponds to taking the relevant subcircuit to this output *) @@ -183,17 +70,3 @@ let realign_inputs ?(renamings: (int -> int option) option) (n: node) : node * ( Option.default k (renamings k), v) |> Map.of_seq in Aig.map map_ n, shifts - -let pp_dep ?(namer = string_of_int) (fmt : Format.formatter) (d: tdeps) : unit = - let print_set fmt s = Set.iter (Format.fprintf fmt "%d ") s in - Map.iter (fun id ints -> Format.fprintf fmt "%s: %a@." (namer id) print_set ints) d - -let pp_deps ?(namer = string_of_int) (fmt: Format.formatter) (ds: tdeps list) : unit = - List.iteri (fun i d -> Format.fprintf fmt "Output #%d:@.%a@." i (pp_dep ~namer) d) ds - -let pp_bdep ?(start_index = 0) ?(oname="") ?(namer=string_of_int) (fmt: Format.formatter) ((n, d): tdblock) : unit = - Format.fprintf fmt "[%d-%d]%s:@." start_index (start_index+n-1) oname; - pp_dep ~namer fmt d - -let pp_bdeps ?(oname="") ?(namer=string_of_int) (fmt: Format.formatter) (bs: tdblock list) : unit = - List.fold_left (fun acc (n,d) -> (pp_bdep ~start_index:acc ~oname ~namer fmt (n,d)); acc + n) 0 bs |> ignore From c4cfb0042e82be726da581fe52dd192a2ed8959c Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 20:40:03 +0200 Subject: [PATCH 128/145] lospecs/deps: remove the no-op global cache The module-level [cache] was never populated: [dep] memoizes in its own local table (which it clears after each call), so [reset_state] only ever reset an empty table. Drop the [cache] binding, [reset_state] (and its interface entry), and the now-empty [CDeps.reset_state ()] call in reset_backend_state. --- libs/lospecs/deps.ml | 6 +----- libs/lospecs/deps.mli | 3 --- src/ecLowCircuits.ml | 5 ++--- 3 files changed, 3 insertions(+), 11 deletions(-) diff --git a/libs/lospecs/deps.ml b/libs/lospecs/deps.ml index 415f1599a0..d712b882ed 100644 --- a/libs/lospecs/deps.ml +++ b/libs/lospecs/deps.ml @@ -6,12 +6,8 @@ module Hashtbl = Batteries.Hashtbl i |-> {j | output depends on bit j of var i }*) type tdeps = (int, int Set.t) Map.t -let cache : (int, tdeps) Hashtbl.t = Hashtbl.create 5003 - -let reset_state : unit -> unit = fun () -> Hashtbl.reset cache - (* ==================================================================== *) -let rec dep : _ -> tdeps = +let rec dep : _ -> tdeps = let cache : (int, tdeps) Hashtbl.t = Hashtbl.create 0 in let rec doit (n: Aig.node) : tdeps = diff --git a/libs/lospecs/deps.mli b/libs/lospecs/deps.mli index bbb049c89b..00a5412ec0 100644 --- a/libs/lospecs/deps.mli +++ b/libs/lospecs/deps.mli @@ -8,9 +8,6 @@ type tdeps = (int, int Set.t) Map.t (* -------------------------------------------------------------------- *) -(* Clears the memoization cache. *) -val reset_state : unit -> unit - (* [dep n] / [deps r] are the dependencies of a node / of each output bit of a register. *) val dep : Aig.node -> tdeps diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index e74104e57b..0c12135c31 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -1687,6 +1687,5 @@ include TranslationState include BVOps include ArrayOps -let reset_backend_state () = - C.HCons.clear (); - CDeps.reset_state () +let reset_backend_state () = + C.HCons.clear () From 73d48d9ce6f952b8247ec20681a1caca389064bf Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 20:44:56 +0200 Subject: [PATCH 129/145] lospecs/deps: document merge_deps; cosmetic cleanup Document [merge_deps] in the interface (pointwise union of bit-sets) and reformat deps.ml. --- libs/lospecs/deps.ml | 57 +++++++++++++++++++++++++++---------------- libs/lospecs/deps.mli | 3 +++ 2 files changed, 39 insertions(+), 21 deletions(-) diff --git a/libs/lospecs/deps.ml b/libs/lospecs/deps.ml index d712b882ed..e97e0348bf 100644 --- a/libs/lospecs/deps.ml +++ b/libs/lospecs/deps.ml @@ -1,12 +1,14 @@ +(* -------------------------------------------------------------------- *) open Aig module Hashtbl = Batteries.Hashtbl -(* tdeps : int -> int set ; dependency for a single output bit - i |-> {j | output depends on bit j of var i }*) +(* -------------------------------------------------------------------- *) +(* tdeps : int -> int set ; dependency for a single output bit *) +(* i |-> { j | output depends on bit j of var i } *) type tdeps = (int, int Set.t) Map.t -(* ==================================================================== *) +(* -------------------------------------------------------------------- *) let rec dep : _ -> tdeps = let cache : (int, tdeps) Hashtbl.t = Hashtbl.create 0 in @@ -22,29 +24,39 @@ let rec dep : _ -> tdeps = match n with | False -> Map.empty | Input (v, i) -> Map.add v (Set.add i (Set.empty)) Map.empty - | And (n1, n2) -> Map.union_stdlib (fun k s1 s2 -> Some (Set.union s1 s2)) (doit n1) (doit n2) + | And (n1, n2) -> + Map.union_stdlib + (fun k s1 s2 -> Some (Set.union s1 s2)) + (doit n1) + (doit n2) - in (fun n -> - let res = doit n in - Hashtbl.clear cache; - res) + in + fun (node : node) -> + let aout = doit node in + Hashtbl.clear cache; + aout +(* -------------------------------------------------------------------- *) let deps (n: reg) : tdeps array = Array.map dep n +(* -------------------------------------------------------------------- *) let merge_deps (d1: tdeps) (d2: tdeps) : tdeps = - Map.union_stdlib (fun _ a b -> Option.some (Set.union a b)) d1 d2 + Map.union_stdlib (fun _ a b -> Option.some (Set.union a b)) d1 d2 (* -------------------------------------------------------------------- *) -(* Uses dependency analysis to realign inputs to start at 0 *) -(* Corresponds to taking the relevant subcircuit to this output *) -(* Assumes that inputs are contiguous *) -let realign_inputs ?(renamings: (int -> int option) option) (n: node) : node * (int, int * int) Map.t = - let d = dep n in +let realign_inputs + ?(renamings : (int -> int option) option) + (node : node) + : node * (int, int * int) Map.t += + let dependencies = dep node in + let shifts = Map.map (fun s -> Set.min_elt_opt s |> Option.default 0, Set.max_elt_opt s |> Option.default 0 - ) d in + ) dependencies in + let map_ = match renamings with | Some renamings -> begin fun (v, i) -> @@ -59,10 +71,13 @@ let realign_inputs ?(renamings: (int -> int option) option) (n: node) : node * ( | Some (k, _) -> Some (Aig.input (v, i-k)) end in - let shifts = match renamings with - | None -> shifts - | Some renamings -> - Map.to_seq shifts |> Seq.map (fun (k, v) -> - Option.default k (renamings k), v) |> Map.of_seq + + let shifts = + match renamings with + | None -> shifts + | Some renamings -> + Map.to_seq shifts |> Seq.map (fun (k, v) -> + Option.default k (renamings k), v) |> Map.of_seq in - Aig.map map_ n, shifts + + Aig.map map_ node, shifts diff --git a/libs/lospecs/deps.mli b/libs/lospecs/deps.mli index 00a5412ec0..fa32b4cd99 100644 --- a/libs/lospecs/deps.mli +++ b/libs/lospecs/deps.mli @@ -13,6 +13,9 @@ type tdeps = (int, int Set.t) Map.t val dep : Aig.node -> tdeps val deps : Aig.reg -> tdeps array +(* [merge_deps d1 d2] is the pointwise union of [d1] and [d2]: each input + variable maps to the union of its bit-sets in the two. Use it to pool + the dependencies of several output bits (e.g. into one block). *) val merge_deps : tdeps -> tdeps -> tdeps (* [realign_inputs ?renamings n] rewrites [n] so each input's used bits From 60173f6f546478e8ef30745bb6839b932c53f237 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 20:47:36 +0200 Subject: [PATCH 130/145] lospecs/typing: add an interface exposing only the used surface circuit_spec is the only consumer and uses just [tt_program] and [Env.empty], so the interface exposes those plus the abstract [env] type. --- libs/lospecs/typing.mli | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) create mode 100644 libs/lospecs/typing.mli diff --git a/libs/lospecs/typing.mli b/libs/lospecs/typing.mli new file mode 100644 index 0000000000..f38446798d --- /dev/null +++ b/libs/lospecs/typing.mli @@ -0,0 +1,17 @@ +(* -------------------------------------------------------------------- *) +open Ptree +open Ast + +(* -------------------------------------------------------------------- *) +module Env : sig + type env + + val empty : env +end + +type env = Env.env + +(* -------------------------------------------------------------------- *) +(* Type-check a parsed lospecs program, returning each named definition + with its elaborated body. *) +val tt_program : env -> pprogram -> (symbol * adef) list From 1d3020ff8f81f7ea136d113e0b631f22bf976508 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 20:49:11 +0200 Subject: [PATCH 131/145] lospecs/typing: tt_program builds the empty env itself The only caller always passed [Env.empty]; fold that in so [tt_program] takes just the program. The interface no longer needs to expose [Env] or the [env] type. --- libs/lospecs/circuit_spec.ml | 2 +- libs/lospecs/typing.ml | 4 ++-- libs/lospecs/typing.mli | 11 +---------- 3 files changed, 4 insertions(+), 13 deletions(-) diff --git a/libs/lospecs/circuit_spec.ml b/libs/lospecs/circuit_spec.ml index 8bb65eeff1..7186c2044d 100644 --- a/libs/lospecs/circuit_spec.ml +++ b/libs/lospecs/circuit_spec.ml @@ -5,7 +5,7 @@ open Aig (* ==================================================================== *) let load_from_file ~(filename : string) = let specs = File.with_file_in filename (Io.parse filename) in - let specs = Typing.tt_program Typing.Env.empty specs in + let specs = Typing.tt_program specs in specs let split_at_arr (type t) (n: int) (r: t array) : t array * t array = diff --git a/libs/lospecs/typing.ml b/libs/lospecs/typing.ml index b683d980c7..6557512afa 100644 --- a/libs/lospecs/typing.ml +++ b/libs/lospecs/typing.ml @@ -652,5 +652,5 @@ let tt_def (env : env) (p : pdef) : symbol * adef = (p.name, { name = p.name; arguments = args; body = bod; rettype = rty; }) (* -------------------------------------------------------------------- *) -let tt_program (env : env) (p : pprogram) : (symbol * adef) list = - List.map (tt_def env) p +let tt_program (p : pprogram) : (symbol * adef) list = + List.map (tt_def Env.empty) p diff --git a/libs/lospecs/typing.mli b/libs/lospecs/typing.mli index f38446798d..610b7765d6 100644 --- a/libs/lospecs/typing.mli +++ b/libs/lospecs/typing.mli @@ -2,16 +2,7 @@ open Ptree open Ast -(* -------------------------------------------------------------------- *) -module Env : sig - type env - - val empty : env -end - -type env = Env.env - (* -------------------------------------------------------------------- *) (* Type-check a parsed lospecs program, returning each named definition with its elaborated body. *) -val tt_program : env -> pprogram -> (symbol * adef) list +val tt_program : pprogram -> (symbol * adef) list From dfe21bfbb8e895e866af7fa44f27b2eddfdb47fb Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 20:51:03 +0200 Subject: [PATCH 132/145] lospecs/typing: remove dead code With the interface in place, these were unreachable from [tt_program]: [Env.export], [tt_type] and [as_int_constant]. --- libs/lospecs/typing.ml | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/libs/lospecs/typing.ml b/libs/lospecs/typing.ml index 6557512afa..a254bebf8a 100644 --- a/libs/lospecs/typing.ml +++ b/libs/lospecs/typing.ml @@ -21,7 +21,6 @@ module Env : sig val empty : env val lookup : env -> symbol -> (ident * sig_) option val push : env -> symbol -> sig_ -> env * ident - val export : env -> (symbol, ident * sig_) Map.t end = struct type sig_ = aword list option * atype @@ -35,8 +34,6 @@ end = struct let idx = Ident.create x in let env = { vars = Map.add x (idx, sig_) env.vars } in (env, idx) - - let export (env : env) : (symbol, ident * sig_) Map.t = env.vars end (* -------------------------------------------------------------------- *) @@ -66,10 +63,6 @@ let mk_tyerror (range : range) msg = let tyerror (range : range) msg = mk_tyerror_r range (fun e -> raise e) msg -(* -------------------------------------------------------------------- *) -let tt_type (_ : env) (t : ptype) : atype = - (t.data :> atype) - (* -------------------------------------------------------------------- *) let tt_type_parameters (env : env) @@ -106,12 +99,6 @@ let check_plain_arg (_ : env) (arg : pexpr option loced) = | Some arg -> arg -(* -------------------------------------------------------------------- *) -let as_int_constant (e : pexpr) : int64 = - match e.data with - | PEInt (i, None) -> i - | _ -> tyerror e.range "integer constant expected" - (* -------------------------------------------------------------------- *) let as_nativeint_constant (e : pexpr) : int = match e.data with From fe2239a1206065c2c2b7e082e57afc127ad993a9 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 20:56:10 +0200 Subject: [PATCH 133/145] lospecs: drop unused yojson derivation and ppx dependencies The [@@deriving yojson] serializers on the Ast/Ptree types were used only in a debug [eprintf] on circuit_spec's bitstring-length-mismatch error path. Drop that debug print, remove every [@@deriving yojson], the lospecs [pps ppx_deriving_yojson] preprocessor, and the now-unused ppx_deriving / ppx_deriving_yojson project dependencies (regenerated easycrypt.opam). --- dune-project | 2 -- easycrypt.opam | 2 -- libs/lospecs/ast.ml | 33 ++++++++++++++++----------------- libs/lospecs/circuit_spec.ml | 7 +------ libs/lospecs/dune | 2 -- libs/lospecs/ptree.ml | 30 ++++++++++++++---------------- 6 files changed, 31 insertions(+), 45 deletions(-) diff --git a/dune-project b/dune-project index 014f6f02c9..d16e231731 100644 --- a/dune-project +++ b/dune-project @@ -23,8 +23,6 @@ markdown (pcre2 (>= 8)) (why3 (and (>= 1.8.0) (< 1.9))) - ppx_deriving - ppx_deriving_yojson hex iter cmdliner diff --git a/easycrypt.opam b/easycrypt.opam index daee24aa32..83fcfdff3c 100644 --- a/easycrypt.opam +++ b/easycrypt.opam @@ -11,8 +11,6 @@ depends: [ "markdown" "pcre2" {>= "8"} "why3" {>= "1.8.0" & < "1.9"} - "ppx_deriving" - "ppx_deriving_yojson" "hex" "iter" "cmdliner" diff --git a/libs/lospecs/ast.ml b/libs/lospecs/ast.ml index 372e8e36ea..8b96c9e104 100644 --- a/libs/lospecs/ast.ml +++ b/libs/lospecs/ast.ml @@ -1,17 +1,17 @@ (* -------------------------------------------------------------------- *) -type symbol = Ptree.symbol [@@deriving yojson] +type symbol = Ptree.symbol exception DestrError of string (* -------------------------------------------------------------------- *) module Ident : sig - type ident [@@deriving yojson] + type ident val create : string -> ident val name : ident -> string val id : ident -> int end = struct - type ident = symbol * int [@@deriving yojson] + type ident = symbol * int let create (x : string) : ident = (x, Oo.id (object end)) let name ((x, _) : ident) : string = x @@ -24,27 +24,27 @@ module IdentMap = Map.Make(struct end) (* -------------------------------------------------------------------- *) -type ident = Ident.ident [@@deriving yojson] +type ident = Ident.ident (* -------------------------------------------------------------------- *) -type aword = [ `W of int ] [@@deriving yojson] +type aword = [ `W of int ] (* -------------------------------------------------------------------- *) -type atype = [ aword | `Signed | `Unsigned ] [@@deriving yojson] +type atype = [ aword | `Signed | `Unsigned ] (* -------------------------------------------------------------------- *) -type aarg = ident * aword [@@deriving yojson] +type aarg = ident * aword (* -------------------------------------------------------------------- *) -type aargs = aarg list [@@deriving yojson] +type aargs = aarg list (* -------------------------------------------------------------------- *) -type lr = [`L | `R] [@@deriving yojson] -type la = [`L | `A] [@@deriving yojson] -type us = [`U | `S] [@@deriving yojson] -type hl = [`H | `L] [@@deriving yojson] -type hld = [hl | `D] [@@deriving yojson] -type mulk = [`U of hld | `S of hld | `US] [@@deriving yojson] +type lr = [`L | `R] +type la = [`L | `A] +type us = [`U | `S] +type hl = [`H | `L] +type hld = [hl | `D] +type mulk = [`U of hld | `S of hld | `US] (* -------------------------------------------------------------------- *) type aexpr_ = @@ -72,9 +72,8 @@ type aexpr_ = | EEq of aword * (aexpr * aexpr) | ECmp of aword * us * [`Gt | `Ge] * (aexpr * aexpr) | EPopCount of aword * aexpr -[@@deriving yojson] -and aexpr = { node : aexpr_; type_ : atype } [@@deriving yojson] +and aexpr = { node : aexpr_; type_ : atype } (* -------------------------------------------------------------------- *) type adef = { @@ -82,7 +81,7 @@ type adef = { arguments : aargs; body : aexpr; rettype : aword; -} [@@deriving yojson] +} (* -------------------------------------------------------------------- *) let atype_as_aword (ty : atype) = diff --git a/libs/lospecs/circuit_spec.ml b/libs/lospecs/circuit_spec.ml index 7186c2044d..3d61c16f1d 100644 --- a/libs/lospecs/circuit_spec.ml +++ b/libs/lospecs/circuit_spec.ml @@ -265,13 +265,8 @@ let circuit_of_specification (rs : reg list) (p : adef) : reg = begin match e.type_ with | `W n -> - if Array.length r <> n then begin - Format.eprintf "%d %d@." (Array.length r) n; - Format.eprintf "%a@." - (Yojson.Safe.pretty_print ~std:true) - (Ast.aexpr_to_yojson e); + if Array.length r <> n then raise (CircuitSpecError (Format.asprintf "Bitstring length mismatch (expected %d, got %d)" n (Array.length r))) - end | _ -> () end; r in diff --git a/libs/lospecs/dune b/libs/lospecs/dune index 97f642aa86..317e1bd277 100644 --- a/libs/lospecs/dune +++ b/libs/lospecs/dune @@ -3,8 +3,6 @@ (public_name easycrypt.lospecs) (flags (:standard -open Batteries)) - (preprocess - (pps ppx_deriving_yojson)) (libraries batteries bitwuzla-cxx menhirLib zarith)) (ocamllex lexer) diff --git a/libs/lospecs/ptree.ml b/libs/lospecs/ptree.ml index feb065bb2b..9364611081 100644 --- a/libs/lospecs/ptree.ml +++ b/libs/lospecs/ptree.ml @@ -6,9 +6,9 @@ type range = { rg_fname : string; rg_begin : int * int; rg_end : int * int; -} [@@deriving yojson] +} -type 'a loced = { range : range; data : 'a; } [@@deriving yojson] +type 'a loced = { range : range; data : 'a; } (* -------------------------------------------------------------------- *) module Lc = struct @@ -71,17 +71,17 @@ end exception ParseError of range (* -------------------------------------------------------------------- *) -type symbol = string [@@deriving yojson] -type word = [ `W of int ] [@@deriving yojson] -type type_ = [ `Unsigned | `Signed | word ] [@@deriving yojson] +type symbol = string +type word = [ `W of int ] +type type_ = [ `Unsigned | `Signed | word ] (* -------------------------------------------------------------------- *) -type psymbol = symbol loced [@@deriving yojson] -type pword = word loced [@@deriving yojson] -type ptype = type_ loced [@@deriving yojson] -type parg = psymbol * pword [@@deriving yojson] -type pargs = parg list [@@deriving yojson] -type pfname = (psymbol * pword list option) loced [@@deriving yojson] +type psymbol = symbol loced +type pword = word loced +type ptype = type_ loced +type parg = psymbol * pword +type pargs = parg list +type pfname = (psymbol * pword list option) loced (* -------------------------------------------------------------------- *) type pexpr_ = @@ -94,13 +94,11 @@ type pexpr_ = | PESlice of pexpr * pslice | PEAssign of pexpr * pslice * pexpr | PEApp of pfname * pexpr option loced list -[@@deriving yojson] -and pexpr = pexpr_ loced [@@deriving yojson] +and pexpr = pexpr_ loced -and pslice = (pexpr * pexpr option * pexpr option) [@@deriving yojson] +and pslice = (pexpr * pexpr option * pexpr option) type pdef = { name : symbol; args : pargs; rty : pword; body : pexpr } -[@@deriving yojson] -type pprogram = pdef list [@@deriving yojson] +type pprogram = pdef list From 31fcef6ef9e087d1562afbf4612bf461454147e6 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 20:58:38 +0200 Subject: [PATCH 134/145] lospecs/smt: add an interface exposing only the used surface ecLowCircuits uses only the Bitwuzla backend [BWZ], so the interface exposes just that module (the abstract solving context and its create/equiv/sat/valid/model operations), hiding the SMTInstance/ SMTInterface signatures, the MakeSMTInterface functor and BWZInstance. --- libs/lospecs/smt.mli | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 libs/lospecs/smt.mli diff --git a/libs/lospecs/smt.mli b/libs/lospecs/smt.mli new file mode 100644 index 0000000000..06fd80c094 --- /dev/null +++ b/libs/lospecs/smt.mli @@ -0,0 +1,26 @@ +(* -------------------------------------------------------------------- *) +(* SMT (Bitwuzla) decision procedures for AIG circuits. *) + +(* A solving context bundles a backend solver with per-query memoization. + Create one per query: a fresh solver gives assertion isolation. The + procedures assert into [ctx] and return a verdict; [model] reads the + satisfying assignment back from the same context, so it is only + meaningful right after a query that left the solver satisfiable (a [sat] + that returned [true], or a refuted [equiv]/[valid]), and before [ctx] is + reused. *) +module BWZ : sig + type ctx + + val create : unit -> ctx + + (* [equiv ctx r1 r2 pcond] is [true] iff [r1] and [r2] agree on every + input satisfying the 1-bit precondition [pcond]. *) + val equiv : ctx -> Aig.reg -> Aig.reg -> Aig.node -> bool + + val sat : ctx -> Aig.node -> bool + val valid : ctx -> Aig.node -> bool + + (* The satisfying assignment, as [(input-id, value)] pairs over the input + bit-groups the last query materialized. *) + val model : ctx -> (int * string) list +end From 474a754643f75476b55ca069e6bcab1c0e30d780 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 21:39:50 +0200 Subject: [PATCH 135/145] lospecs: rename circuit_spec to specifications Rename the module (file circuit_spec.ml/.mli -> specifications.ml/.mli) and update its two references (the C backend's include in ecLowCircuits and EcEnv.get_specification_by_name). --- libs/lospecs/{circuit_spec.ml => specifications.ml} | 0 libs/lospecs/{circuit_spec.mli => specifications.mli} | 0 src/ecEnv.ml | 2 +- src/ecLowCircuits.ml | 2 +- 4 files changed, 2 insertions(+), 2 deletions(-) rename libs/lospecs/{circuit_spec.ml => specifications.ml} (100%) rename libs/lospecs/{circuit_spec.mli => specifications.mli} (100%) diff --git a/libs/lospecs/circuit_spec.ml b/libs/lospecs/specifications.ml similarity index 100% rename from libs/lospecs/circuit_spec.ml rename to libs/lospecs/specifications.ml diff --git a/libs/lospecs/circuit_spec.mli b/libs/lospecs/specifications.mli similarity index 100% rename from libs/lospecs/circuit_spec.mli rename to libs/lospecs/specifications.mli diff --git a/src/ecEnv.ml b/src/ecEnv.ml index 037d61a1aa..ea141e9b73 100644 --- a/src/ecEnv.ml +++ b/src/ecEnv.ml @@ -3430,7 +3430,7 @@ module Circuit = struct ~filter:(function `Circuit x -> Some x | _ -> None) let get_specification_by_name ~(filename : string) (name : symbol) : Lospecs.Ast.adef option = - let specs = Lospecs.Circuit_spec.load_from_file ~filename in + let specs = Lospecs.Specifications.load_from_file ~filename in List.Exceptionless.assoc name specs end diff --git a/src/ecLowCircuits.ml b/src/ecLowCircuits.ml index 0c12135c31..e07dc00f7b 100644 --- a/src/ecLowCircuits.ml +++ b/src/ecLowCircuits.ml @@ -11,7 +11,7 @@ open EcMemory module C = struct include Lospecs.Aig include Lospecs.Circuit - include Lospecs.Circuit_spec + include Lospecs.Specifications end module CDeps = struct From dd62640938a6336f96d5d39c968bacdfe4fc2ecf Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 21:43:44 +0200 Subject: [PATCH 136/145] lospecs/io: add an interface; drop dead print_source_for_range The only consumer (specifications) uses just [parse], so the interface exposes that alone. [print_source_for_range] was unused; remove it (and the now-redundant [open Ptree]). --- libs/lospecs/io.ml | 33 --------------------------------- libs/lospecs/io.mli | 7 +++++++ 2 files changed, 7 insertions(+), 33 deletions(-) create mode 100644 libs/lospecs/io.mli diff --git a/libs/lospecs/io.ml b/libs/lospecs/io.ml index dff9a0193c..b57f4316ef 100644 --- a/libs/lospecs/io.ml +++ b/libs/lospecs/io.ml @@ -1,38 +1,5 @@ -(* -------------------------------------------------------------------- *) -open Ptree - (* -------------------------------------------------------------------- *) let parse (name : string) (input : IO.input) : Ptree.pprogram = let lexbuf = Lexing.from_channel input in Lexing.set_filename lexbuf name; Parser.program Lexer.main lexbuf - -(* -------------------------------------------------------------------- *) -let print_source_for_range (fmt : Format.formatter) (range : range) (name : string) = - let lines = File.lines_of name in - let nlines = Enum.count lines in - - let begin_ = fst range.rg_begin - 1 in - let end_ = fst range.rg_end in - - let ctxt = 2 in - let ctxt_s = max 0 (begin_ - ctxt) in - let ctxt_e = min nlines (end_ + ctxt) in - - let lines = Enum.skip ctxt_s lines in - let lines = Enum.take (ctxt_e - ctxt_s) lines in - - let sz = int_of_float (ceil (log10 (float_of_int end_ +. 1.))) in - - begin - let doline (i : int) = Format.sprintf "%d---------" i in - Format.fprintf fmt "%*s | %s@." - sz "" - (String.concat "" (List.map doline (List.init 7 identity))); - end; - Enum.iteri - (fun i line -> - let lineno = ctxt_s + i in - let mark = if begin_ <= lineno && lineno < end_ then ">" else " " in - Format.fprintf fmt "%*d %s| %s@." sz (lineno + 1) mark line) - lines diff --git a/libs/lospecs/io.mli b/libs/lospecs/io.mli new file mode 100644 index 0000000000..468ef6e456 --- /dev/null +++ b/libs/lospecs/io.mli @@ -0,0 +1,7 @@ +(* -------------------------------------------------------------------- *) +open Ptree + +(* -------------------------------------------------------------------- *) +(* [parse name input] parses a lospecs program from [input], tagging + source locations with the file name [name]. *) +val parse : string -> IO.input -> pprogram From b61da524854fab58a1058131c7d2cc8e970ec5a1 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 21:48:30 +0200 Subject: [PATCH 137/145] lospecs/ast: add an interface; drop dead Ident.name/id and IdentMap Expose the AST data model (types kept concrete, as consumers construct and pattern-match them) plus the used helpers [atype_as_aword], [get_size] and [pp_atype]. [Ident] narrows to [create]; [pp_aword] stays internal (used by [pp_atype]). The interface revealed the unused module [IdentMap] and, with it, the unused [Ident.name]/[Ident.id]; remove them. --- libs/lospecs/ast.ml | 9 ------ libs/lospecs/ast.mli | 67 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 67 insertions(+), 9 deletions(-) create mode 100644 libs/lospecs/ast.mli diff --git a/libs/lospecs/ast.ml b/libs/lospecs/ast.ml index 8b96c9e104..148ec5305d 100644 --- a/libs/lospecs/ast.ml +++ b/libs/lospecs/ast.ml @@ -8,21 +8,12 @@ module Ident : sig type ident val create : string -> ident - val name : ident -> string - val id : ident -> int end = struct type ident = symbol * int let create (x : string) : ident = (x, Oo.id (object end)) - let name ((x, _) : ident) : string = x - let id ((_, i) : ident) : int = i end -module IdentMap = Map.Make(struct - type t = Ident.ident - let compare a b = (Ident.id a) - (Ident.id b) -end) - (* -------------------------------------------------------------------- *) type ident = Ident.ident diff --git a/libs/lospecs/ast.mli b/libs/lospecs/ast.mli new file mode 100644 index 0000000000..34e507fc85 --- /dev/null +++ b/libs/lospecs/ast.mli @@ -0,0 +1,67 @@ +(* -------------------------------------------------------------------- *) +type symbol = Ptree.symbol + +(* -------------------------------------------------------------------- *) +module Ident : sig + type ident + + val create : string -> ident +end + +type ident = Ident.ident + +(* -------------------------------------------------------------------- *) +type aword = [ `W of int ] +type atype = [ aword | `Signed | `Unsigned ] + +type aarg = ident * aword +type aargs = aarg list + +type lr = [`L | `R] +type la = [`L | `A] +type us = [`U | `S] +type hl = [`H | `L] +type hld = [hl | `D] +type mulk = [`U of hld | `S of hld | `US] + +(* -------------------------------------------------------------------- *) +type aexpr_ = + | EVar of ident + | EInt of int64 + | ESlice of aexpr * (aexpr * int * int) + | EAssign of aexpr * (aexpr * int * int) * aexpr + | EApp of ident * aexpr list + | EMap of (aword * aword) * (aargs * aexpr) * aexpr list + | EConcat of aword * aexpr list + | ERepeat of aword * (aexpr * int) + | EShift of lr * la * (aexpr * aexpr) + | EExtend of us * aword * aexpr + | ESat of us * aword * aexpr + | ELet of (ident * aargs option * aexpr) * aexpr + | ECond of aexpr * (aexpr * aexpr) + | ENot of aword * aexpr + | EIncr of aword * aexpr + | EAdd of aword * [`Sat of us | `Word] * (aexpr * aexpr) + | ESub of aword * (aexpr * aexpr) + | EMul of mulk * aword * (aexpr * aexpr) + | EOr of aword * (aexpr * aexpr) + | EXor of aword * (aexpr * aexpr) + | EAnd of aword * (aexpr * aexpr) + | EEq of aword * (aexpr * aexpr) + | ECmp of aword * us * [`Gt | `Ge] * (aexpr * aexpr) + | EPopCount of aword * aexpr + +and aexpr = { node : aexpr_; type_ : atype } + +(* -------------------------------------------------------------------- *) +type adef = { + name : string; + arguments : aargs; + body : aexpr; + rettype : aword; +} + +(* -------------------------------------------------------------------- *) +val atype_as_aword : atype -> int +val get_size : aword -> int +val pp_atype : Format.formatter -> atype -> unit From 830028a8eacf179e5b98b1e96d07d26460da56e0 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 21:55:52 +0200 Subject: [PATCH 138/145] lospecs/ptree: add an interface; drop dead Lc helpers Expose the parse-tree types concretely (the parser builds them, the typer matches them), plus [ParseError] and the used [Lc] helpers (of_positions, of_lexbuf, merge, unloc, mk, map). The interface revealed dead [Lc] helpers: remove [mergeall], [range], [pp_range] and [string_of_range]. --- libs/lospecs/ptree.ml | 26 -------------------- libs/lospecs/ptree.mli | 56 ++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 56 insertions(+), 26 deletions(-) create mode 100644 libs/lospecs/ptree.mli diff --git a/libs/lospecs/ptree.ml b/libs/lospecs/ptree.ml index 9364611081..3271c1a7d7 100644 --- a/libs/lospecs/ptree.ml +++ b/libs/lospecs/ptree.ml @@ -30,41 +30,15 @@ module Lc = struct { rg_fname = p1.rg_fname; rg_begin = min p1.rg_begin p2.rg_begin; rg_end = max p1.rg_end p2.rg_end; } - - let mergeall (p : range list) = - match p with - | [] -> assert false - | t :: ts -> List.fold_left merge t ts let unloc (x : 'a loced) : 'a = x.data - let range (x : 'a loced) : range = - x.range - let mk (range : range) (data : 'a) : 'a loced = { range; data; } let map (f : 'a -> 'b) (x : 'a loced) : 'b loced = { x with data = f x.data } - - let string_of_range (range : range) = - let spos = - if range.rg_begin = range.rg_end then - Printf.sprintf "line %d (%d)" - (fst range.rg_begin) (snd range.rg_begin + 1) - else if fst range.rg_begin = fst range.rg_end then - Printf.sprintf "line %d (%d-%d)" - (fst range.rg_begin) (snd range.rg_begin + 1) (snd range.rg_end + 1) - else - Printf.sprintf "line %d (%d) to line %d (%d)" - (fst range.rg_begin) (snd range.rg_begin + 1) - (fst range.rg_end ) (snd range.rg_end + 1) - in - Printf.sprintf "%s: %s" range.rg_fname spos - - let pp_range (fmt : Format.formatter) (range : range) = - Format.fprintf fmt "%s" (string_of_range range) end (* -------------------------------------------------------------------- *) diff --git a/libs/lospecs/ptree.mli b/libs/lospecs/ptree.mli new file mode 100644 index 0000000000..160b3c1d00 --- /dev/null +++ b/libs/lospecs/ptree.mli @@ -0,0 +1,56 @@ +(* -------------------------------------------------------------------- *) +type range = { + rg_fname : string; + rg_begin : int * int; + rg_end : int * int; +} + +type 'a loced = { range : range; data : 'a; } + +(* -------------------------------------------------------------------- *) +(* Source ranges and located-value helpers. *) +module Lc : sig + val of_positions : Lexing.position -> Lexing.position -> range + val of_lexbuf : Lexing.lexbuf -> range + val merge : range -> range -> range + val unloc : 'a loced -> 'a + val mk : range -> 'a -> 'a loced + val map : ('a -> 'b) -> 'a loced -> 'b loced +end + +(* -------------------------------------------------------------------- *) +exception ParseError of range + +(* -------------------------------------------------------------------- *) +type symbol = string +type word = [ `W of int ] +type type_ = [ `Unsigned | `Signed | word ] + +(* -------------------------------------------------------------------- *) +type psymbol = symbol loced +type pword = word loced +type ptype = type_ loced +type parg = psymbol * pword +type pargs = parg list +type pfname = (psymbol * pword list option) loced + +(* -------------------------------------------------------------------- *) +type pexpr_ = + | PEParens of pexpr + | PEFName of pfname + | PEInt of int64 * pword option + | PECond of pexpr * (pexpr * pexpr) + | PEFun of pargs * pexpr + | PELet of (psymbol * pargs option * pexpr) * pexpr + | PESlice of pexpr * pslice + | PEAssign of pexpr * pslice * pexpr + | PEApp of pfname * pexpr option loced list + +and pexpr = pexpr_ loced + +and pslice = (pexpr * pexpr option * pexpr option) + +(* -------------------------------------------------------------------- *) +type pdef = { name : symbol; args : pargs; rty : pword; body : pexpr } + +type pprogram = pdef list From 0aa30529f9fc14121b61b2b6cc54eb8a74adce4a Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 22:03:26 +0200 Subject: [PATCH 139/145] lospecs/circuit: drop dead conversions/printers; export ult/ule/slt/sle Remove the unused int64_of_bools, pp_reg, of_int_repr_size and trunc, along with their now-orphaned private helpers (pp_reg_ + int32_of_bools, and of_bigint_repr_size). Export the unsigned/signed less-than/-equal comparisons ult/ule/slt/sle (siblings of the already-exported ugt/uge/sgt/sge). --- libs/lospecs/circuit.ml | 50 ---------------------------------------- libs/lospecs/circuit.mli | 8 +++++++ 2 files changed, 8 insertions(+), 50 deletions(-) diff --git a/libs/lospecs/circuit.ml b/libs/lospecs/circuit.ml index 4f30e17b9a..194739ee50 100644 --- a/libs/lospecs/circuit.ml +++ b/libs/lospecs/circuit.ml @@ -32,25 +32,6 @@ let uint_of_bools (bs : bool array) : int = (fun v i b -> if b then (1 lsl i) lor v else v) 0 bs -(* -------------------------------------------------------------------- *) -let int32_of_bools (bs : bool array) : int32 = - Array.fold_lefti - (fun v i b -> - if b then - Int32.logor (Int32.shift_left 1l i) v - else - v) - 0l bs - -let int64_of_bools (bs : bool array) : int64 = - Array.fold_lefti - (fun v i b -> - if b then - Int64.(logor (shift_left 1L i) v) - else - v) - 0L bs - let ubigint_of_bools (bs: bool array) : Z.t = Array.fold_right (fun b acc -> @@ -91,26 +72,6 @@ let bools_of_reg (r: reg) : bool array = let bool_list_of_reg : reg -> bool list = fun r -> bools_of_reg r |> Array.to_list -(* -------------------------------------------------------------------- *) -let pp_reg_ ~(size : int) (fmt : Format.formatter) (r : bool array) = - assert (Array.length r mod (size * 4) = 0); - - let r = explode ~size:(size * 4) r in -(* let r = explode ~size:(size * 4) r in *) - let r = Array.map int32_of_bools r in - - Format.fprintf fmt "%a" - (fun fmt arr -> Array.iteri (fun i x -> - Format.fprintf fmt "%0.8lx" x; - if i < Array.length arr - 1 then - Format.fprintf fmt "_" - ) arr) - r - -let pp_reg ~(size: int) (fmt: Format.formatter) (r: reg) = - assert (size mod 4 = 0); - pp_reg_ ~size:(size / 4) fmt (bools_of_reg r) - (* ==================================================================== *) let bit ~(position : int) (v : int) : bool = (v lsr position) land 0b1 <> 0 @@ -153,13 +114,6 @@ let of_bigint_all ~(size : int) (v : Z.t) : reg = let v = if Z.sign v < 0 then Z.add mod_ v else v in of_bigint ~size v -let of_bigint_repr_size (v : Z.t) : reg = - let size = Z.numbits v + (if Z.sign v <= 0 then 1 else 0) in - of_bigint_all ~size v - -let of_int_repr_size (v: int) : reg = - of_bigint_repr_size (Z.of_int v) - (* -------------------------------------------------------------------- *) let of_string ~(size : int) (s : string) : reg = of_bigint ~size (Z.of_string s) @@ -248,10 +202,6 @@ let sextend ~(size : int) (r : reg) : reg = else r -(* -------------------------------------------------------------------- *) -let trunc ~(size: int) (r: reg) : reg = - Array.sub r 0 size - (* -------------------------------------------------------------------- *) let mux2 (n1 : node) (n2 : node) (c : node) = or_ (and_ (neg c) n1) (and_ c n2) diff --git a/libs/lospecs/circuit.mli b/libs/lospecs/circuit.mli index d784860438..46e2994434 100644 --- a/libs/lospecs/circuit.mli +++ b/libs/lospecs/circuit.mli @@ -142,12 +142,20 @@ val ugt : reg -> reg -> node val uge : reg -> reg -> node +val ult : reg -> reg -> node + +val ule : reg -> reg -> node + val sgte : node -> reg -> reg -> node val sgt : reg -> reg -> node val sge : reg -> reg -> node +val slt : reg -> reg -> node + +val sle : reg -> reg -> node + val bvueq : reg -> reg -> node val bvseq : reg -> reg -> node From acca891cb869eaa2d12d5ed33d2f43bae5e87d04 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 22:05:45 +0200 Subject: [PATCH 140/145] lospecs: remove the unused Word module word.ml/word.mli (fixed-width modular arithmetic via first-class modules) was referenced nowhere; delete it. --- libs/lospecs/word.ml | 193 ------------------------------------------ libs/lospecs/word.mli | 37 -------- 2 files changed, 230 deletions(-) delete mode 100644 libs/lospecs/word.ml delete mode 100644 libs/lospecs/word.mli diff --git a/libs/lospecs/word.ml b/libs/lospecs/word.ml deleted file mode 100644 index 70601c824d..0000000000 --- a/libs/lospecs/word.ml +++ /dev/null @@ -1,193 +0,0 @@ -(* -------------------------------------------------------------------- *) -module type S = sig - type t - - val nbits : int - - val zero : t - val one : t - - val neg : t -> t - val add : t -> t -> t - val sub : t -> t -> t - val mul : t -> t -> t - val div : t -> t -> t - - val lognot : t -> t - val logand : t -> t -> t - val logor : t -> t -> t - val logxor : t -> t -> t - - val shiftl : t -> int -> t - val shiftr : t -> int -> t - - val abs : t -> t - - val of_int : int -> t - val to_int : t -> int - - val mod_ : t -> t -> t -end - -(* -------------------------------------------------------------------- *) -module type Size = sig - val nbits : int -end - -(* -------------------------------------------------------------------- *) -module SWord(I : Size) : S = struct - type t = int - - let () = assert (I.nbits < Sys.int_size) - - let nbits = I.nbits - - let of_int (x : int) : t = - x lsl (Sys.int_size - nbits) - - let to_int (x : t) : int = - x asr (Sys.int_size - nbits) - - let mask : int = - (1 lsl nbits) - 1 - - let zero : t = - of_int 0 - - let one : t = - of_int 1 - - let add (x : t) (y : t) = - x + y - - let sub (x : t) (y : t) = - x - y - - let neg (x : t) : t = - -x - - let mul (x : t) (y : t) : t = - (to_int x) * y - - let div (x : t) (y : t) : t = - of_int (x / y) - - let logand (x : t) (y : t) : t = - x land y - - let logor (x : t) (y : t) : t = - x lor y - - let logxor (x : t) (y : t) : t = - (x lxor y) land (of_int mask) - - let lognot (x : t) : t = - logxor x (of_int (-1)) - - let shiftl (x : t) (y : int) : t = - x lsl y - - let shiftr (x : t) (y : t) : t = - (x asr y) land (of_int mask) - - let abs (x : t) : t = - abs x - - (* Careful with size *) - let urem (x : t) (y : t) : t = - assert (Sys.int_size - nbits >= 1); - let x = x lsr 1 in - let y = y lsr 1 in - (x mod y) lsl 1 - - let mod_ (x: t) (y: t) : t = - if y = zero then x else - let u = urem (abs x) (abs y) in - if u = zero - then u - else if (x >= zero) && (y >= zero) - then u - else if (x < zero) && (y >= zero) - then (-u + y) - else if (x >= zero) && (y < zero) - then (u + y) - else -u - -end - -(* -------------------------------------------------------------------- *) -module UWord(I : Size) : S = struct - type t = int - - let () = assert (I.nbits < Sys.int_size) - - let nbits = I.nbits - - let mask : int = - (1 lsl nbits) - 1 - - let of_int (x : int) : t = - x land mask - - let to_int (x : t) : int = - x - - let zero : t = - of_int 0 - - let one : t = - of_int 1 - - let add (x : t) (y : t) = - of_int (x + y) - - let sub (x : t) (y : t) = - of_int (x - y) - - let neg (x : t) : t = - of_int (-x) - - let mul (x : t) (y : t) = - of_int (x * y) - - let div (x : t) (y : t) : t = - of_int (x / y) - - let logand (x : t) (y : t) : t = - x land y - - let logor (x : t) (y : t) : t = - x lor y - - let logxor (x : t) (y : t) = - x lxor y - - let lognot (x : t) : t = - x lxor mask - - let shiftl (x : t) (y : int) = - of_int (x lsl y) - - let shiftr (x : t) (y : int) = - x lsr y - - let abs (x : t) : t = - x - - let mod_ (x: t) (y : t) : t = - if y = 0 then x else x mod y -end - -(* -------------------------------------------------------------------- *) -let sword ~(size : int) : (module S) = - (module SWord(struct let nbits = size end)) - -(* -------------------------------------------------------------------- *) -let uword ~(size : int) : (module S) = - (module UWord(struct let nbits = size end)) - -(* -------------------------------------------------------------------- *) -let word ~(sign : [`U | `S]) ~(size : int) : (module S) = - match sign with - | `U -> uword ~size - | `S -> sword ~size diff --git a/libs/lospecs/word.mli b/libs/lospecs/word.mli deleted file mode 100644 index 6871239ed9..0000000000 --- a/libs/lospecs/word.mli +++ /dev/null @@ -1,37 +0,0 @@ -(* -------------------------------------------------------------------- *) -module type S = sig - type t - - val nbits : int - - val zero : t - val one : t - - val neg : t -> t - val add : t -> t -> t - val sub : t -> t -> t - val mul : t -> t -> t - val div : t -> t -> t - - val lognot : t -> t - val logand : t -> t -> t - val logor : t -> t -> t - val logxor : t -> t -> t - - val shiftl : t -> int -> t - val shiftr : t -> int -> t - - val abs : t -> t - - val of_int : int -> t - val to_int : t -> int - - val mod_ : t -> t -> t -end - -(* -------------------------------------------------------------------- *) -val sword : size:int -> (module S) -val uword : size:int -> (module S) - -(* -------------------------------------------------------------------- *) -val word : sign:[`U | `S] -> size:int -> (module S) From f5712bebc677fc390b5c746e8aafe6a33023fc5f Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 22:49:53 +0200 Subject: [PATCH 141/145] lospecs/aig: restore eval and get_bit (public API) These were dropped as "dead" based on EasyCrypt-internal usage, but easycrypt.lospecs is a published library and they are used by downstream consumers (e.g. formosa-crypto/arch-specs' checkspecs). Re-expose them. --- libs/lospecs/aig.ml | 28 ++++++++++++++++++++++++++++ libs/lospecs/aig.mli | 7 +++++++ 2 files changed, 35 insertions(+) diff --git a/libs/lospecs/aig.ml b/libs/lospecs/aig.ml index f09b58acb4..4e209ff039 100644 --- a/libs/lospecs/aig.ml +++ b/libs/lospecs/aig.ml @@ -166,3 +166,31 @@ let map (env : var -> node option) : node -> node = (* -------------------------------------------------------------------- *) let maps (env : var -> node option) : reg -> reg = fun r -> Array.map (map env) r + +(* -------------------------------------------------------------------- *) +let get_bit (b : bytes) (i : int) = + Char.code (Bytes.get b (i / 8)) lsr (i mod 8) land 0b1 <> 0 + +(* -------------------------------------------------------------------- *) +let eval (env : var -> bool) = + let cache : (int, bool) Hashtbl.t = Hashtbl.create 0 in + + let rec for_node (n : node) = + let value = + match Hashtbl.find_option cache (abs n.id) with + | None -> + let value = for_node_r n.gate in + Hashtbl.add cache (abs n.id) value; + value + | Some value -> + value + + in if 0 < n.id then value else not value + + and for_node_r (n : node_r) = + match n with + | False -> false + | Input x -> env x + | And (n1, n2) -> for_node n1 && for_node n2 + + in fun (n : node) -> for_node n diff --git a/libs/lospecs/aig.mli b/libs/lospecs/aig.mli index bcacd5dc71..b28356cdae 100644 --- a/libs/lospecs/aig.mli +++ b/libs/lospecs/aig.mli @@ -44,6 +44,13 @@ val xnor : node -> node -> node val map : (var -> node option) -> node -> node val maps : (var -> node option) -> reg -> reg +(* -------------------------------------------------------------------- *) +(* [get_bit b i] is bit [i] (little-endian) of the byte buffer [b]. *) +val get_bit : bytes -> int -> bool + +(* [eval env n] evaluates the AIG [n] under the input assignment [env]. *) +val eval : (var -> bool) -> node -> bool + (* -------------------------------------------------------------------- *) val pp_node : ?input_namer:(int -> string) -> Format.formatter -> node -> unit From fa757122507c75dc6c83122ea0c7790d60bce791 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Mon, 15 Jun 2026 23:05:45 +0200 Subject: [PATCH 142/145] Revert "circuit: translate opaque circuit-typed leaves as fresh inputs" This reverts commit 2028a4164654259956c4bb3ea674833e7a9de979. --- src/ecCircuits.ml | 32 +++++++---------------------- tests/circuit_soundness.ec | 41 -------------------------------------- 2 files changed, 7 insertions(+), 66 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index e0b35a5231..de6d54da1f 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -482,20 +482,6 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = let int_of_form (f : form) : zint = int_of_form hyps f in - (* A circuit-typed form with no structural translation (an opaque leaf: - a free variable, [witness], or an application of an opaque head) is an - arbitrary value of its type, modelled as a fresh input and cached so - that alpha-equal occurrences share it. [circuit_uninit] raises a clean - [CircError] when the type is not circuit-translatable. *) - let circuit_of_uninterpreted (f_ : form) : circuit = - match EcAlphaInvHashtbl.find_opt cache f_ with - | Some circ -> circ - | None -> - let circ = circuit_uninit env f_.f_ty in - EcAlphaInvHashtbl.add cache f_ circ; - circ - in - (* Supposed to be called on an apply *) let propagate_integer_arguments (op : form) (args : form list) : form = let op = @@ -546,11 +532,7 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = | Fint _z -> circ_error (CantConvertToCirc `Int) - | Flocal idn -> - begin match state_get_opt st idn with - | Some c -> c - | None -> circuit_of_uninterpreted f_ - end + | Flocal idn -> state_get st idn | Fop (pth, _) -> circuit_of_op_form st f_ pth @@ -626,7 +608,12 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = EcEnv.notify env `Debug "Assigning witness to var of type %a@." EcPrinting.(pp_type ppe) f_.f_ty; - circuit_of_uninterpreted f_ + match EcAlphaInvHashtbl.find_opt cache f_ with + | Some circ -> circ + | None -> + let circ = circuit_uninit env f_.f_ty in + EcAlphaInvHashtbl.add cache f_ circ; + circ end else match Mp.find_opt pth !op_cache with | Some op -> op @@ -724,11 +711,6 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = | {f_node = Fop _}, _ -> (* Assuming correct types coming from EC *) circuit_of_logic_app st f fs - (* An application of an opaque (unbound) local is itself an opaque - leaf: model the whole application as a fresh input (cached below - by [f_]). *) - | {f_node = Flocal idn}, _ when Option.is_none (state_get_opt st idn) -> - circuit_uninit env f_.f_ty (* Recurse down into definition *) | _ -> let f_c = circuit_of_node st f in diff --git a/tests/circuit_soundness.ec b/tests/circuit_soundness.ec index b8728eef0d..a170fdfeaf 100644 --- a/tests/circuit_soundness.ec +++ b/tests/circuit_soundness.ec @@ -79,44 +79,3 @@ proof. circuit. qed. lemma witness_xor_self : witness<:W8> +^ witness<:W8> = zero. proof. circuit. qed. - -(* -------------------------------------------------------------------- *) -(* Completeness: a circuit-typed term with no structural translation *) -(* (a free variable, or an application of an opaque head) is an opaque *) -(* leaf modelled as a fresh, form-cached input -- not a [Not_found] *) -(* anomaly. Alpha-equal occurrences share their input. *) -theory A. - type 'a t. - op tolist : 'a t -> 'a list. - op oflist : 'a -> 'a list -> 'a t. - op "_.[_]" : 'a t -> int -> 'a. - op "_.[_<-_]" : 'a t -> int -> 'a -> 'a t. -end A. -bind array A."_.[_]" A."_.[_<-_]" A.tolist A.oflist A.t 8. -realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. -realize eqP by admit. realize get_setP by admit. realize get_out by admit. -export A. - -op init (f : int -> W8) : W8 A.t. -bind op [W8 & A.t] init "ainit". -realize bvainitP by admit. - -(* [(init f).[4]] applies the opaque [f] at index 4; both that occurrence *) -(* and the right-hand [f 4] resolve to the same cached input. *) -lemma opaque_app_shared (f : int -> W8) : (init f).[4] = f 4. -proof. circuit. qed. - -lemma opaque_app_xor_self (f : int -> W8) : f 4 +^ f 4 = zero. -proof. circuit. qed. - -(* A free variable of circuit type is itself an opaque leaf. *) -lemma free_var_refl (x : W8) : x = x. -proof. circuit. qed. - -(* Soundness of the sharing: DISTINCT opaque leaves get DISTINCT inputs, *) -(* so non-alpha-equal terms must NOT be equated. *) -lemma opaque_app_distinct (f : int -> W8) : f 4 = f 5. -proof. fail circuit. abort. - -lemma free_var_distinct (x y : W8) : x = y. -proof. fail circuit. abort. From 00a977e4d720df355667225bc6ffb9e3a7e9031c Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 16 Jun 2026 06:26:14 +0200 Subject: [PATCH 143/145] circuit: skip non-circuit-typed locals when entering a memory circuit_state_of_memenv opened every program local up front and failed the whole translation if any had a non-circuit type, so a memory with an int local (e.g. a loop counter) aborted with "Missing type binding for type int". Skip such locals instead -- they are not circuit inputs -- mirroring circuit_state_of_hyps. Assigning to a non-circuit variable in the body is still rejected, as before. --- src/ecCircuits.ml | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index de6d54da1f..4a977292be 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -956,7 +956,12 @@ let circuit_state_of_memenv match ov_name with | Some v -> begin try Some ((m, v), ctype_of_ty env ov_type) - with CircError err -> propagate_circ_error (`Memenv me) err + with + (* A local of a non-circuit type (e.g. [int]) is not a circuit + input; skip it rather than failing the whole translation. + Mirrors [circuit_state_of_hyps]. *) + | CircError (MissingTyBinding _ | AbstractTyBinding _) -> None + | CircError err -> propagate_circ_error (`Memenv me) err end | None -> None) decls From 423e1a4ebb51646827d3319c7fe73db50e674dd7 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 16 Jun 2026 06:26:38 +0200 Subject: [PATCH 144/145] Reapply "circuit: translate opaque circuit-typed leaves as fresh inputs" This reverts commit fa757122507c75dc6c83122ea0c7790d60bce791. --- src/ecCircuits.ml | 32 ++++++++++++++++++++++------- tests/circuit_soundness.ec | 41 ++++++++++++++++++++++++++++++++++++++ 2 files changed, 66 insertions(+), 7 deletions(-) diff --git a/src/ecCircuits.ml b/src/ecCircuits.ml index 4a977292be..0919806b71 100644 --- a/src/ecCircuits.ml +++ b/src/ecCircuits.ml @@ -482,6 +482,20 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = let int_of_form (f : form) : zint = int_of_form hyps f in + (* A circuit-typed form with no structural translation (an opaque leaf: + a free variable, [witness], or an application of an opaque head) is an + arbitrary value of its type, modelled as a fresh input and cached so + that alpha-equal occurrences share it. [circuit_uninit] raises a clean + [CircError] when the type is not circuit-translatable. *) + let circuit_of_uninterpreted (f_ : form) : circuit = + match EcAlphaInvHashtbl.find_opt cache f_ with + | Some circ -> circ + | None -> + let circ = circuit_uninit env f_.f_ty in + EcAlphaInvHashtbl.add cache f_ circ; + circ + in + (* Supposed to be called on an apply *) let propagate_integer_arguments (op : form) (args : form list) : form = let op = @@ -532,7 +546,11 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = | Fint _z -> circ_error (CantConvertToCirc `Int) - | Flocal idn -> state_get st idn + | Flocal idn -> + begin match state_get_opt st idn with + | Some c -> c + | None -> circuit_of_uninterpreted f_ + end | Fop (pth, _) -> circuit_of_op_form st f_ pth @@ -608,12 +626,7 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = EcEnv.notify env `Debug "Assigning witness to var of type %a@." EcPrinting.(pp_type ppe) f_.f_ty; - match EcAlphaInvHashtbl.find_opt cache f_ with - | Some circ -> circ - | None -> - let circ = circuit_uninit env f_.f_ty in - EcAlphaInvHashtbl.add cache f_ circ; - circ + circuit_of_uninterpreted f_ end else match Mp.find_opt pth !op_cache with | Some op -> op @@ -711,6 +724,11 @@ let circuit_of_form (st : state) (hyps : hyps) (f_ : EcAst.form) : circuit = | {f_node = Fop _}, _ -> (* Assuming correct types coming from EC *) circuit_of_logic_app st f fs + (* An application of an opaque (unbound) local is itself an opaque + leaf: model the whole application as a fresh input (cached below + by [f_]). *) + | {f_node = Flocal idn}, _ when Option.is_none (state_get_opt st idn) -> + circuit_uninit env f_.f_ty (* Recurse down into definition *) | _ -> let f_c = circuit_of_node st f in diff --git a/tests/circuit_soundness.ec b/tests/circuit_soundness.ec index a170fdfeaf..b8728eef0d 100644 --- a/tests/circuit_soundness.ec +++ b/tests/circuit_soundness.ec @@ -79,3 +79,44 @@ proof. circuit. qed. lemma witness_xor_self : witness<:W8> +^ witness<:W8> = zero. proof. circuit. qed. + +(* -------------------------------------------------------------------- *) +(* Completeness: a circuit-typed term with no structural translation *) +(* (a free variable, or an application of an opaque head) is an opaque *) +(* leaf modelled as a fresh, form-cached input -- not a [Not_found] *) +(* anomaly. Alpha-equal occurrences share their input. *) +theory A. + type 'a t. + op tolist : 'a t -> 'a list. + op oflist : 'a -> 'a list -> 'a t. + op "_.[_]" : 'a t -> int -> 'a. + op "_.[_<-_]" : 'a t -> int -> 'a -> 'a t. +end A. +bind array A."_.[_]" A."_.[_<-_]" A.tolist A.oflist A.t 8. +realize gt0_size by admit. realize tolistP by admit. realize oflistP by admit. +realize eqP by admit. realize get_setP by admit. realize get_out by admit. +export A. + +op init (f : int -> W8) : W8 A.t. +bind op [W8 & A.t] init "ainit". +realize bvainitP by admit. + +(* [(init f).[4]] applies the opaque [f] at index 4; both that occurrence *) +(* and the right-hand [f 4] resolve to the same cached input. *) +lemma opaque_app_shared (f : int -> W8) : (init f).[4] = f 4. +proof. circuit. qed. + +lemma opaque_app_xor_self (f : int -> W8) : f 4 +^ f 4 = zero. +proof. circuit. qed. + +(* A free variable of circuit type is itself an opaque leaf. *) +lemma free_var_refl (x : W8) : x = x. +proof. circuit. qed. + +(* Soundness of the sharing: DISTINCT opaque leaves get DISTINCT inputs, *) +(* so non-alpha-equal terms must NOT be equated. *) +lemma opaque_app_distinct (f : int -> W8) : f 4 = f 5. +proof. fail circuit. abort. + +lemma free_var_distinct (x y : W8) : x = y. +proof. fail circuit. abort. From 0436c6dc946d7ba006958bcba4d85dc233324e13 Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 16 Jun 2026 06:51:11 +0200 Subject: [PATCH 145/145] parser: remove shift/reduce conflicts in `bind bitstring` `bind bitstring`'s type used `loc(simpl_type_exp)`, an applicative type expression, which was ambiguous against the following size form (two shift/reduce conflicts: the parser could not tell whether the next token extended the type via `type_args qident` or began the size). The handler already required the type to be a monomorphic named type, so accept a qualified name (`qoident`) instead -- matching `bind array`/`bind op` -- and resolve it by [EcEnv.Ty.lookup_opt]. Grammar is now conflict-free. --- src/ecParser.mly | 2 +- src/ecParsetree.ml | 2 +- src/ecScope.ml | 21 ++++++++++----------- 3 files changed, 12 insertions(+), 13 deletions(-) diff --git a/src/ecParser.mly b/src/ecParser.mly index 5061f837e4..5fe5ad975a 100644 --- a/src/ecParser.mly +++ b/src/ecParser.mly @@ -3961,7 +3961,7 @@ spec_binding: { (op, circ) } cr_binding_r: -| BIND BITSTRING from_=qoident to_=qoident touint=qoident tosint=qoident ofint=qoident type_=loc(simpl_type_exp) size=sform +| BIND BITSTRING from_=qoident to_=qoident touint=qoident tosint=qoident ofint=qoident type_=qoident size=sform { CRB_Bitstring { from_; to_; touint; tosint; ofint; type_; size; } } | BIND ARRAY get=qoident set=qoident tolist=qoident oflist=qoident type_=qoident size=sform diff --git a/src/ecParsetree.ml b/src/ecParsetree.ml index 754c4d2514..70cf6c4940 100644 --- a/src/ecParsetree.ml +++ b/src/ecParsetree.ml @@ -1395,7 +1395,7 @@ type pbind_bitstring = ; touint : pqsymbol ; tosint : pqsymbol ; ofint : pqsymbol - ; type_ : pty + ; type_ : pqsymbol ; size : pformula } (* -------------------------------------------------------------------- *) diff --git a/src/ecScope.ml b/src/ecScope.ml index f746ac16b5..62bf805a45 100644 --- a/src/ecScope.ml +++ b/src/ecScope.ml @@ -2798,18 +2798,17 @@ module Circuit = struct let add_bitstring (scope : scope) (local : is_local) (bs : pbind_bitstring) : scope = let env = env scope in - let type_ = - let ue = EcUnify.UniEnv.create None in - let ty = EcTyping.transty tp_tydecl env ue bs.type_ in - assert (EcUnify.UniEnv.closed ue); - ty_subst (Tuni.subst (EcUnify.UniEnv.close ue)) ty in - let bspath = - match (EcEnv.ty_hnorm type_ env).ty_node with - | Tconstr (p, []) -> p - | _ -> - hierror ~loc:(bs.type_.pl_loc) - "bit-string type must be a monomorphic named type" in + match EcEnv.Ty.lookup_opt (unloc bs.type_) env with + | None -> + hierror ~loc:(loc bs.type_) + "cannot find named type: `%s'" (string_of_qsymbol (unloc bs.type_)) + | Some (path, decl) -> + if not (List.is_empty decl.tyd_params) then + hierror ~loc:(loc bs.type_) + "bit-string type must be a monomorphic named type: `%s'" + (string_of_qsymbol (unloc bs.type_)); + path in let from_, _ = EcEnv.Op.lookup bs.to_.pl_desc env in let to_ , _ = EcEnv.Op.lookup bs.from_.pl_desc env in