diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 000000000..ec2b9457c --- /dev/null +++ b/.editorconfig @@ -0,0 +1,10 @@ +root=true + +[*] +end_of_line = lf +insert_final_newline = true +charset = utf-8 + +[*.{ml,mli}] +indent_style = space +indent_size = 2 diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml new file mode 100644 index 000000000..088ff639d --- /dev/null +++ b/.gitlab-ci.yml @@ -0,0 +1,281 @@ +stages: +- prepare +- prove +- build +- test +- deploy + +image: nixos/nix:2.18.2 + +variables: + NIX_PATH: nixpkgs=channel:nixpkgs-unstable + + EXTRA_SUBSTITUTERS: https://jasmin.cachix.org + EXTRA_PUBLIC_KEYS: jasmin.cachix.org-1:aA5r1ovq4HYKUa+8QHVvIP7K6Fi9L75b0SaN/sooWSY= + NIXOS_PUBLIC_KEY: cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= + NIXPKGS_ALLOW_UNFREE: 1 + + VERSION: development version at commit $CI_COMMIT_SHA on branch $CI_COMMIT_REF_NAME + +.common: + before_script: + - >- + nix-shell + --extra-substituters "$EXTRA_SUBSTITUTERS" + --trusted-public-keys "$NIXOS_PUBLIC_KEY $EXTRA_PUBLIC_KEYS" + --arg inCI true + $EXTRA_NIX_ARGUMENTS + --run 'echo done' + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'sed -i -e "s|@VERSION@|$VERSION|" compiler/src/glob_options.ml' + +cache dependencies: + stage: prepare + extends: .common + variables: + EXTRA_NIX_ARGUMENTS: --arg coqDeps true --arg ocamlDeps true --arg testDeps true --argstr ecRef release --arg opamDeps true + environment: cachix + only: + variables: + - $CACHIX_SIGNING_KEY + script: + - >- + nix-shell -p cachix --run + 'nix-store --query --references $(nix-instantiate --arg inCI true $EXTRA_NIX_ARGUMENTS default.nix) + | xargs nix-store --realise + | xargs nix-store --query --requisites + | cachix push jasmin' + +coq-program: + stage: prove + variables: + EXTRA_NIX_ARGUMENTS: --arg coqDeps true + extends: .common + script: + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'make -j$NIX_BUILD_CORES -C compiler CIL' + artifacts: + paths: + - proofs/ + - compiler/src/CIL/ + +coq-proof: + stage: prove + variables: + EXTRA_NIX_ARGUMENTS: --arg coqDeps true + extends: .common + needs: + - coq-program + script: + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'make -j$NIX_BUILD_CORES -C proofs' + +coq-master: + stage: prove + allow_failure: true + rules: + - if: $CI_COMMIT_BRANCH !~ /^release-/ + variables: + EXTRA_NIX_ARGUMENTS: --arg coqDeps true --arg coqMaster true + extends: .common + script: + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'make -j$NIX_BUILD_CORES -C proofs' + +ocaml: + stage: build + variables: + EXTRA_NIX_ARGUMENTS: --arg ocamlDeps true + extends: .common + needs: + - coq-program + script: + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'make -j$NIX_BUILD_CORES -C compiler' + artifacts: + paths: + - compiler/_build/ + - compiler/jasmin2tex + - compiler/jasminc + - compiler/jasmin-ct + +eclib: + stage: prove + parallel: + matrix: + - EASYCRYPT_REF: [release, dev] + variables: + EXTRA_NIX_ARGUMENTS: --argstr ecRef $EASYCRYPT_REF + extends: .common + script: + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'easycrypt why3config -why3 eclib/why3.conf' + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'easycrypt config -why3 eclib/why3.conf' + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'make ECARGS="-why3 why3.conf" -C eclib' + +opam-compiler: + stage: build + variables: + OPAMROOTISOK: 'true' + OPAMROOT: mapo + EXTRA_NIX_ARGUMENTS: --arg opamDeps true + extends: .common + needs: + - coq-program + cache: + key: + files: + - scripts/nixpkgs.nix + prefix: opam + paths: + - $OPAMROOT + script: + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'scripts/opam-setup.sh' + - >- + nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run + 'eval $(opam env) && + make -C compiler -j$NIX_BUILD_CORES && + (cd compiler && mkdir -p bin && cp -L _build/install/default/bin/* bin/ && mkdir -p lib/jasmin/easycrypt && cp ../eclib/*.ec lib/jasmin/easycrypt/)' + artifacts: + paths: + - compiler/bin/ + - compiler/lib/ + +tarball: + stage: build + variables: + EXTRA_NIX_ARGUMENTS: --arg testDeps true + TARBALL: jasmin-compiler-$CI_COMMIT_SHORT_SHA + extends: .common + needs: + - coq-program + script: + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'make -C compiler dist DISTDIR=$TARBALL' + artifacts: + paths: + - compiler/$TARBALL.tgz + +build-from-tarball: + stage: test + variables: + TARBALL: jasmin-compiler-$CI_COMMIT_SHORT_SHA + needs: + - tarball + script: + - tar xvf compiler/$TARBALL.tgz + - nix-build -o out $TARBALL + - ./out/bin/jasminc -version + +check: + stage: test + variables: + EXTRA_NIX_ARGUMENTS: --arg testDeps true --arg ocamlDeps true + extends: .common + needs: + - coq-program + - ocaml + script: + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run './compiler/jasminc -version' + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'cd compiler && dune runtest' + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'make -j$NIX_BUILD_CORES -C compiler check-ci $EXTRA_MAKE_ARGUMENTS' + +check-proofs: + stage: test + parallel: + matrix: + - EASYCRYPT_REF: [release, dev] + variables: + EXTRA_NIX_ARGUMENTS: --arg testDeps true --argstr ecRef $EASYCRYPT_REF + WHY3_CONF: $CI_PROJECT_DIR/why3.conf + ECARGS: -why3 $WHY3_CONF -I Jasmin:$CI_PROJECT_DIR/eclib + extends: .common + needs: + - coq-program + - ocaml + script: + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run './compiler/jasminc -version' + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'easycrypt why3config -why3 $WHY3_CONF' + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'easycrypt config -why3 $WHY3_CONF' + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'make -C compiler/examples/gimli/proofs' + +libjade-compile-to-asm: + stage: test + variables: + EXTRA_NIX_ARGUMENTS: --arg testDeps true + extends: .common + needs: + - coq-program + - ocaml + script: + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run './scripts/test-libjade.sh src' + artifacts: + when: always + paths: + - libjade/src/check.tar.gz + +libjade-extract-to-ec: + stage: test + variables: + EXTRA_NIX_ARGUMENTS: --arg testDeps true --argstr ecRef release + WHY3_CONF: $CI_PROJECT_DIR/why3.conf + ECARGS: -why3 $WHY3_CONF -I Jasmin:$CI_PROJECT_DIR/eclib + ECJOBS: '$(NIX_BUILD_CORES)' + extends: .common + needs: + - coq-program + - ocaml + script: + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'easycrypt why3config -why3 $WHY3_CONF' + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run './scripts/test-libjade.sh proof' + artifacts: + when: always + paths: + - libjade/proof/check.tar.gz + +test-extract-to-ec: + stage: test + parallel: + matrix: + - EASYCRYPT_REF: [release, dev] + variables: + EXTRA_NIX_ARGUMENTS: --arg ocamlDeps true --arg testDeps true --argstr ecRef $EASYCRYPT_REF + WHY3_CONF: $CI_PROJECT_DIR/why3.conf + ECARGS: -why3 $WHY3_CONF -I Jasmin:$CI_PROJECT_DIR/eclib + JSJOBS: $(NIX_BUILD_CORES) + extends: .common + needs: + - coq-program + - ocaml + script: + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'easycrypt why3config -why3 $WHY3_CONF' + - nix-shell --arg inCI true $EXTRA_NIX_ARGUMENTS --run 'make -C compiler CHECKCATS="x86-64-extraction arm-m4-extraction" check' + artifacts: + when: always + paths: + - compiler/report.log + +push-compiler-code: + stage: deploy + environment: deployment + only: + variables: + - $DEPLOY_KEY + variables: + TARBALL: jasmin-compiler-$CI_COMMIT_SHORT_SHA + needs: + - tarball + before_script: + - nix-env -iA nixpkgs.git + - nix-env -iA nixpkgs.openssh + - eval $(ssh-agent -s) + - mkdir -p ~/.ssh + - chmod 700 ~/.ssh + - ssh-keyscan gitlab.com >> ~/.ssh/known_hosts + - git config --global user.name "Jasmin Contributors" + - git config --global user.email "nobody@noreply.example.com" + script: + - echo "$DEPLOY_KEY" | tr -d '\r' | ssh-add - > /dev/null + - git clone git@gitlab.com:jasmin-lang/jasmin-compiler.git _deploy + - cd _deploy + - git checkout $CI_COMMIT_REF_NAME || git checkout --orphan $CI_COMMIT_REF_NAME + - rm -rf compiler eclib + - tar xzvf ../compiler/$TARBALL.tgz + - mv $TARBALL/ compiler + - mv ../eclib . + - git add compiler eclib + - git commit -m "Jasmin compiler on branch “$CI_COMMIT_REF_NAME” at $CI_COMMIT_SHORT_SHA" || true + - git push --set-upstream origin $CI_COMMIT_REF_NAME diff --git a/AUTHORS b/AUTHORS index e36ba1ed1..49249fdf5 100644 --- a/AUTHORS +++ b/AUTHORS @@ -2,6 +2,7 @@ The following people have contributed code and/or ideas to Jasmin: Aaron Kaiser Adrien Koutsos +Alexandre Bourbeillon Amber Sprenkels Antoine Séré Antoine Toussaint @@ -14,6 +15,7 @@ Clément Sartori François Dupressoir Gaëtan Cassiers Gilles Barthe +Ján Jančár Jean-Christophe Léchenet José Bacelar Almeida Kai-Chun Ning diff --git a/CHANGELOG.md b/CHANGELOG.md index 77ce45d4c..0dec003ca 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,57 @@ ## New features +- Support more integer notations + ([PR#897](https://github.com/jasmin-lang/jasmin/pull/897)): + * Octal: `0O777`, `0o52` + * Binary: `0b11101`, `0B11100` + * `_` characters: `100_000_00___111` + +## Bug fixes + +- Easycrypt extraction for CT : fix decreasing for loops + ([PR #859](https://github.com/jasmin-lang/jasmin/pull/859); + fixes [#858](https://github.com/jasmin-lang/jasmin/issues/858)). + +- Array copy operator `#copy` support slices as arguments and results + ([PR #880](https://github.com/jasmin-lang/jasmin/pull/880); + fixes [#842](https://github.com/jasmin-lang/jasmin/issues/842)). + +- Fix SCT check of `while` loops + ([PR #888](https://github.com/jasmin-lang/jasmin/pull/888)); + fixes [#887](https://github.com/jasmin-lang/jasmin/issues/887)). + +- Fix compilation of functions with system calls but not making other use of + the stack + ([PR #892](https://github.com/jasmin-lang/jasmin/pull/892)); + fixes [#870](https://github.com/jasmin-lang/jasmin/issues/870)). + +- Safety checker handles dynamically scoped global variables + ([PR #890](https://github.com/jasmin-lang/jasmin/pull/890); + fixes [#662](https://github.com/jasmin-lang/jasmin/issues/662)). + +## Other changes + +- The deprecated legacy interface to the LATEX pretty-printer has been removed + ([PR #869](https://github.com/jasmin-lang/jasmin/pull/869)). + +- The checker for S-CT accepts copies of outdated MSF + ([PR #885](https://github.com/jasmin-lang/jasmin/pull/885)). + +- Preserve formatting of integer literals in the lexer and when pretty-printing to LATEX + ([PR #886](https://github.com/jasmin-lang/jasmin/pull/886)). + +- Improve handling of instruction `LEA` in the safety checker + ([PR #900](https://github.com/jasmin-lang/jasmin/pull/900)). + +- Extraction to EasyCrypt for safety verification is now removed, it was + deprecated in the previous release + ([PR #846](https://github.com/jasmin-lang/jasmin/pull/846)). + +# Jasmin 2024.07.0 — Sophia-Antipolis, 2024-07-09 + +## New features + - The stack allocation checker accepts more programs. This checker is run during the stack allocation pass to verify that the transformation done by the pass (mostly, turning arrays accesses into memory accesses) @@ -19,6 +70,7 @@ - ARM now compiles `x = imm;` smartly: for small immediates, a single `MOV`; for immediates whose negation is small, a single `MVN`; and for large immediates a pair of `MOV` and `MOVT`. + ([PR #795](https://github.com/jasmin-lang/jasmin/pull/795)). - Export functions can have `ptr` arrays as arguments and results. The compiler assumes that writable `ptr` are disjoint from the other @@ -28,6 +80,12 @@ returned first and in the same order in the list of results. ([PR #707](https://github.com/jasmin-lang/jasmin/pull/707)). +- The (speculative) constant-time checker can optionally check that secrets are + only used with guaranteed constant time instructions (DOIT for Intel, DIT for + ARM) + ([PR #736](https://github.com/jasmin-lang/jasmin/pull/736), + [PR #811](https://github.com/jasmin-lang/jasmin/pull/811)). + - Add spill/unspill primitives allowing to spill/unspill reg and reg ptr to/from the stack without need to declare the corresponding stack variable. If the annotation #spill_to_mmx is used at the variable declaration the variable @@ -51,13 +109,13 @@ [PR #818](https://github.com/jasmin-lang/jasmin/pull/818)). - Support Selective Speculative Load Hardening. - We now support operators SLH operators as in [Typing High-Speed Cryptography + We now support SLH operators as in [Typing High-Speed Cryptography against Spectre v1](https://ia.cr/2022/1270). The compilation of these is proven to preserve functional semantics. We also provide a speculative CCT checker, via the `jasmin-ct` flag `--sct`. ([PR #447](https://github.com/jasmin-lang/jasmin/pull/447), [PR #723](https://github.com/jasmin-lang/jasmin/pull/723), - [PR #814](https://github.com/jasmin-lang/jasmin/pull/814)) + [PR #814](https://github.com/jasmin-lang/jasmin/pull/814)). - Register arrays and sub-arrays can appear as arguments and return values of local functions; @@ -69,6 +127,7 @@ - Add the instruction `MULX_hi`, `hi = #MULX_hi(x, y);` is equivalent to `hi, _ = #MULX(x, y);` but no extra register is used for the low half of the result. + ([PR #531](https://github.com/jasmin-lang/jasmin/pull/531)). - Definition of parameters can now use arbritrary expressions and depend on other parameters. See `tests/success/common/test_globals.jazz`. @@ -110,7 +169,11 @@ ## Bug fixes -- The compiler rejects ARM intrincics with the `S` suffix if the instruction +- Truncation of stack variables is handled correctly + ([PR #848](https://github.com/jasmin-lang/jasmin/pull/848); + fixes [#681](https://github.com/jasmin-lang/jasmin/issues/681)). + +- The compiler rejects ARM intrinsics with the `S` suffix if the instruction does not set flags ([PR #809](https://github.com/jasmin-lang/jasmin/pull/809); fixes [#808](https://github.com/jasmin-lang/jasmin/issues/808)). @@ -143,7 +206,7 @@ [PR 712](https://github.com/jasmin-lang/jasmin/pull/697); fixes [#696](https://github.com/jasmin-lang/jasmin/issues/696)). -- Fix code generation for ARMv7 when export function have large stack frames +- Fix code generation for ARMv7 when export functions have large stack frames ([PR #710](https://github.com/jasmin-lang/jasmin/pull/710); fixes [#709](https://github.com/jasmin-lang/jasmin/issues/709)). @@ -162,6 +225,10 @@ ## Other changes +- Extraction to EasyCrypt for safety verification is deprecated; + it has been broken for a while, and is now explicitly unmaintained + ([PR #849](https://github.com/jasmin-lang/jasmin/pull/849)). + - Pretty-printing of Jasmin programs is more precise ([PR #491](https://github.com/jasmin-lang/jasmin/pull/491)). diff --git a/compiler/.gitignore b/compiler/.gitignore index 024b7e9a4..171cb13df 100644 --- a/compiler/.gitignore +++ b/compiler/.gitignore @@ -8,5 +8,4 @@ report.log /jasmin.mlpack /jasminc /jazz2tex -/jazz2cl /jasmin-ct diff --git a/compiler/CCT/fail/doit/x86_64/rol.jazz b/compiler/CCT/fail/doit/x86_64/rol.jazz new file mode 100644 index 000000000..f7abdc754 --- /dev/null +++ b/compiler/CCT/fail/doit/x86_64/rol.jazz @@ -0,0 +1,6 @@ +// This is CT in the ordinary sense, but not DOIT as ROL is not DOIT. +export fn rol(#secret reg u32 x) -> #secret reg u32 { + x < #secret reg u32, #secret reg u32 { + a = a; + b = b; + a, b = #swap(a, b); + return a, b; +} diff --git a/compiler/CCT/success/doit/by_stack.jazz b/compiler/CCT/success/doit/by_stack.jazz new file mode 100644 index 000000000..efb358ade --- /dev/null +++ b/compiler/CCT/success/doit/by_stack.jazz @@ -0,0 +1,6 @@ +export fn id(#secret reg u32 x) -> #secret reg u32 { + stack u32 s; + s = x; + x = s; + return x; +} diff --git a/compiler/Makefile b/compiler/Makefile index 5d2dd6afe..2a4804aa2 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -7,7 +7,7 @@ CHECK := $(CHECKPY) scripts/runtest --jobs="$(JSJOBS)" CHECK += config/tests.config CHECKCATS ?= \ safety \ - CCT \ + CCT CCT-DOIT SCT \ x86-64-ATT \ x86-64-Intel \ x86-64-print \ diff --git a/compiler/config/tests.config b/compiler/config/tests.config index 205f398cf..90ef5aadf 100644 --- a/compiler/config/tests.config +++ b/compiler/config/tests.config @@ -14,6 +14,13 @@ kodirs = safety/fail bin = ./scripts/check-cct okdirs = CCT/success kodirs = CCT/fail +exclude = CCT/success/doit CCT/fail/doit + +[test-CCT-DOIT] +bin = ./scripts/check-cct +args = --doit +okdirs = CCT/success/doit +kodirs = CCT/fail/doit [test-SCT] bin = ./scripts/check-cct diff --git a/compiler/entry/jasmin_ct.ml b/compiler/entry/jasmin_ct.ml index 2d7409935..7722e0f1f 100644 --- a/compiler/entry/jasmin_ct.ml +++ b/compiler/entry/jasmin_ct.ml @@ -5,7 +5,7 @@ open Utils let parse_and_check arch call_conv = let module A = (val get_arch_module arch call_conv) in - let check infer ct_list speculative pass file = + let check ~doit infer ct_list speculative pass file = let _env, pprog, _ast = try Compile.parse_file A.arch_info file with | Annot.AnnotationError (loc, code) -> @@ -44,7 +44,7 @@ let parse_and_check arch call_conv = in if speculative then - match Sct_checker_forward.ty_prog A.is_ct_sopn prog ct_list with + match Sct_checker_forward.ty_prog (A.is_ct_sopn ~doit) prog ct_list with | exception Annot.AnnotationError (loc, code) -> hierror ~loc:(Lone loc) ~kind:"annotation error" "%t" code | sigs -> @@ -53,7 +53,7 @@ let parse_and_check arch call_conv = sigs else let sigs, errs = - Ct_checker_forward.ty_prog A.is_ct_sopn ~infer prog ct_list + Ct_checker_forward.ty_prog (A.is_ct_sopn ~doit) ~infer prog ct_list in Format.printf "/* Security types:\n@[%a@]*/@." (pp_list "@ " (Ct_checker_forward.pp_signature prog)) @@ -63,8 +63,13 @@ let parse_and_check arch call_conv = in Stdlib.Option.iter on_err errs in - fun infer ct_list speculative compile file -> - match check infer ct_list speculative compile file with + fun infer ct_list speculative compile file doit -> + let compile = + if doit && compile < Compiler.PropagateInline then + Compiler.PropagateInline + else compile + in + match check ~doit infer ct_list speculative compile file with | () -> () | exception HiError e -> Format.eprintf "%a@." pp_hierror e; @@ -104,6 +109,10 @@ let file = let doc = "The Jasmin source file to verify" in Arg.(required & pos 0 (some non_dir_file) None & info [] ~docv:"JAZZ" ~doc) +let doit = + let doc = "Allow only DOIT instructions on secrets" in + Arg.(value & flag & info [ "doit" ] ~doc) + let () = let doc = "Check Constant-Time security of Jasmin programs" in let man = @@ -114,9 +123,11 @@ let () = `I ("JASMINPATH", "To resolve $(i,require) directives"); ] in - let info = Cmd.info "jasmin-ct" ~version:Glob_options.version_string ~doc ~man in + let info = + Cmd.info "jasmin-ct" ~version:Glob_options.version_string ~doc ~man + in Cmd.v info Term.( const parse_and_check $ arch $ call_conv $ infer $ slice $ speculative - $ compile $ file) + $ compile $ file $ doit) |> Cmd.eval |> exit diff --git a/compiler/jasmin.opam b/compiler/jasmin.opam index 6c98ab76f..385144222 100644 --- a/compiler/jasmin.opam +++ b/compiler/jasmin.opam @@ -32,7 +32,7 @@ depends: [ "apron" {>= "v0.9.12"} "conf-ppl" "yojson" {>= "1.6.0"} - "angstrom" + "angstrom" {>= "0.14.0"} "ocamlfind" { build } ] conflicts: [ diff --git a/compiler/safety/success/dynglob.jazz b/compiler/safety/success/dynglob.jazz new file mode 100644 index 000000000..0c849a7e4 --- /dev/null +++ b/compiler/safety/success/dynglob.jazz @@ -0,0 +1,9 @@ +export fn main(reg ptr u8[8] s) -> reg u8 { + global u64 index; + index = 5; + reg u64 i; + i = index; + reg u8 r; + r = s[i]; + return r; +} diff --git a/compiler/safety/success/lea.jazz b/compiler/safety/success/lea.jazz new file mode 100644 index 000000000..009781fd4 --- /dev/null +++ b/compiler/safety/success/lea.jazz @@ -0,0 +1,29 @@ +param int N = 4; + +export +fn nested_loops(reg ptr u16[N] array) -> reg ptr u16[N] { + reg u64 i; + ?{}, i = #set0(); + while (i < N - 1) { + reg u64 j; + j = #LEA(i + 1); + while (j < N) { + array[j] += 1; + j += 1; + } + i += 1; + } + return array; +} + +export +fn truncate() -> reg u64 { + stack u64[2] s; + s[1] = 0; + reg u64 x; + x = (1<<32); + reg u64 y; + y = (64u)#LEA_32(x +64u 1); + x = s[y]; + return x; +} diff --git a/compiler/safetylib/safetyAbsExpr.ml b/compiler/safetylib/safetyAbsExpr.ml index 8a1f5f35e..cc69cc5bd 100644 --- a/compiler/safetylib/safetyAbsExpr.ml +++ b/compiler/safetylib/safetyAbsExpr.ml @@ -1032,11 +1032,9 @@ module AbsExpr (AbsDom : AbsNumBoolType) = struct | Lmem _ -> MLnone | Lvar x -> let ux = L.unloc x in - begin match ux.v_kind, ux.v_ty with - | Global,_ -> assert false (* this case should not be possible *) - (* MLvar (Mglobal (ux.v_name,ux.v_ty)) *) - | _, Bty _ -> MLvar (loc, Mlocal (Avar ux)) - | _, Arr _ -> MLvar (loc, Mlocal (Aarray ux)) end + begin match ux.v_ty with + | Bty _ -> MLvar (loc, Mlocal (Avar ux)) + | Arr _ -> MLvar (loc, Mlocal (Aarray ux)) end | Laset (_, acc, ws, x, ei) -> begin diff --git a/compiler/safetylib/safetyInterpreter.ml b/compiler/safetylib/safetyInterpreter.ml index 908a05160..44c939992 100644 --- a/compiler/safetylib/safetyInterpreter.ml +++ b/compiler/safetylib/safetyInterpreter.ml @@ -1360,6 +1360,14 @@ end = struct let e = Papp1 (E.Olnot ws, e1) in [Some e] + | Sopn.Oasm (Arch_extra.BaseOp (x, X86_instr_decl.LEA ws)) -> + let e1 = as_seq1 es in + let e = + match ty_expr e1 with + | Bty (U ws') when int_of_ws ws < int_of_ws ws' -> Papp1 (E.Ozeroext (ws, ws'), e1) + | _ -> e1 in + [Some e] + | Sopn.Oslh op -> begin match op with | SLHinit -> [ Some (pcast U64 (Pconst (Z.of_int 0))) ] diff --git a/compiler/scripts/runtest b/compiler/scripts/runtest index 1df1a15b8..a07364ca9 100755 --- a/compiler/scripts/runtest +++ b/compiler/scripts/runtest @@ -121,7 +121,6 @@ class ANSITerm: isatty = hasattr(sys.stdout, "isatty") and sys.stdout.isatty() hascolors = False - (term_cols, term_lines) = shutil.get_terminal_size() if isatty: try: @@ -141,12 +140,13 @@ class ANSITerm: @classmethod def progress_write(cls, s): if cls.isatty: - print("\033[J" + s, end="", file=sys.stderr, flush=True) - up = len(s) // int(cls.term_cols) - bs = "" - if up != 0: - bs += f"\033[{bs}A" - print(bs + "\r", file=sys.stderr, end="", flush=False) + # Truncate s according to terminal width + # taking into account the eleven bytes that change colors + term_cols, _ = shutil.get_terminal_size() + s = s[0:int(term_cols) + 11] + print(f"\033[J{s}\r", end="", file=sys.stderr) + else: + print(s, file=sys.stderr) def rcolor(txt, b): @@ -264,7 +264,7 @@ def _dump_report(results, out): grouped.setdefault(result.config.group, []).append(result) hostname = socket.gethostname() - timestamp = datetime.datetime.utcnow().isoformat() + timestamp = datetime.datetime.now(datetime.timezone.utc).isoformat() for gname, group in grouped.items(): ko = [x for x in group if not x.success] node = cl.OrderedDict() @@ -359,9 +359,11 @@ def _main(): file=sys.stderr, ) ANSITerm.progress_write( - f"Tests: {i: 4}/{n: 4} | Failed: {fails: 4} | [{success}] {last_cmd}" + f"Tests: {(i+1): 4}/{n: 4} | Failed: {fails: 4} | [{success}] {last_cmd}" ) + print('', file=sys.stderr, flush=True) + errors = [x for x in result if not x.success] if errors: logging.info("--- BEGIN FAILING SCRIPTS ---") diff --git a/compiler/src/CLI_errors.ml b/compiler/src/CLI_errors.ml index 66bc3a061..d22cf5dbb 100644 --- a/compiler/src/CLI_errors.ml +++ b/compiler/src/CLI_errors.ml @@ -54,8 +54,4 @@ let check_options () = then warning Experimental Location.i_dummy "support of the ARMv7 architecture is experimental"; - if !latexfile <> "" - then warning Deprecated Location.i_dummy - "the [-latex] option has been deprecated since March 2023; use [jasmin2tex] instead"; - - List.iter chk_out_file [ outfile; latexfile; ecfile ] + List.iter chk_out_file [ outfile; ecfile ] diff --git a/compiler/src/arch_full.ml b/compiler/src/arch_full.ml index 187178b0d..b7a5a2ee2 100644 --- a/compiler/src/arch_full.ml +++ b/compiler/src/arch_full.ml @@ -35,7 +35,9 @@ module type Core_arch = sig val known_implicits : (Name.t * string) list val is_ct_asm_op : asm_op -> bool + val is_doit_asm_op : asm_op -> bool val is_ct_asm_extra : extra_op -> bool + val is_doit_asm_extra : extra_op -> bool end @@ -71,7 +73,7 @@ module type Arch = sig val arch_info : (reg, regx, xreg, rflag, cond, asm_op, extra_op) Pretyping.arch_info - val is_ct_sopn : (reg, regx, xreg, rflag, cond, asm_op, extra_op) Arch_extra.extended_op -> bool + val is_ct_sopn : ?doit:bool -> (reg, regx, xreg, rflag, cond, asm_op, extra_op) Arch_extra.extended_op -> bool end module Arch_from_Core_arch (A : Core_arch) : @@ -198,9 +200,9 @@ module Arch_from_Core_arch (A : Core_arch) : flagnames = List.map fst known_implicits; } - let is_ct_sopn (o : (reg, regx, xreg, rflag, cond, asm_op, extra_op) Arch_extra.extended_op) = + let is_ct_sopn ?(doit = false) (o : (reg, regx, xreg, rflag, cond, asm_op, extra_op) Arch_extra.extended_op) = match o with - | BaseOp (_, o) -> is_ct_asm_op o - | ExtOp o -> is_ct_asm_extra o + | BaseOp (_, o) -> (if doit then is_doit_asm_op else is_ct_asm_op) o + | ExtOp o -> (if doit then is_doit_asm_extra else is_ct_asm_extra) o end diff --git a/compiler/src/arch_full.mli b/compiler/src/arch_full.mli index 3b99dd576..d9ce086f8 100644 --- a/compiler/src/arch_full.mli +++ b/compiler/src/arch_full.mli @@ -36,7 +36,9 @@ module type Core_arch = sig val known_implicits : (Name.t * string) list val is_ct_asm_op : asm_op -> bool + val is_doit_asm_op : asm_op -> bool val is_ct_asm_extra : extra_op -> bool + val is_doit_asm_extra : extra_op -> bool end @@ -72,7 +74,7 @@ module type Arch = sig val arch_info : (reg, regx, xreg, rflag, cond, asm_op, extra_op) Pretyping.arch_info - val is_ct_sopn : (reg, regx, xreg, rflag, cond, asm_op, extra_op) Arch_extra.extended_op -> bool + val is_ct_sopn : ?doit:bool -> (reg, regx, xreg, rflag, cond, asm_op, extra_op) Arch_extra.extended_op -> bool end module Arch_from_Core_arch (A : Core_arch) : Arch diff --git a/compiler/src/arm_arch_full.ml b/compiler/src/arm_arch_full.ml index 806f0dc66..f2d7e4b2d 100644 --- a/compiler/src/arm_arch_full.ml +++ b/compiler/src/arm_arch_full.ml @@ -33,8 +33,71 @@ module Arm_core = struct | ARM_op( (SDIV | UDIV), _) -> false | _ -> true - - let is_ct_asm_extra (_ : extra_op) = true + let is_doit_asm_op (o : asm_op) = + match o with + | ARM_op(ADC, _) -> true + | ARM_op(ADD, _) -> true + | ARM_op(ADR, _) -> false (* Not DIT *) + | ARM_op(AND, _) -> true + | ARM_op(ASR, _) -> true + | ARM_op(BFC, _) -> true + | ARM_op(BFI, _) -> true + | ARM_op(BIC, _) -> true + | ARM_op(CLZ, _) -> true + | ARM_op(CMN, _) -> true + | ARM_op(CMP, _) -> true + | ARM_op(EOR, _) -> true + | ARM_op(LDR, _) -> true + | ARM_op(LDRB, _) -> true + | ARM_op(LDRH, _) -> true + | ARM_op(LDRSB, _) -> true + | ARM_op(LDRSH, _) -> true + | ARM_op(LSL, _) -> true + | ARM_op(LSR, _) -> true + | ARM_op(MLA, _) -> true + | ARM_op(MLS, _) -> true + | ARM_op(MOV, _) -> true + | ARM_op(MOVT, _) -> true + | ARM_op(MUL, _) -> true + | ARM_op(MVN, _) -> true + | ARM_op(ORR, _) -> true + | ARM_op(REV, _) -> true + | ARM_op(REV16, _) -> true + | ARM_op(REVSH, _) -> false (* Not DIT *) + | ARM_op(ROR, _) -> true + | ARM_op(RSB, _) -> false (* Not DIT *) + | ARM_op(SBFX, _) -> true + | ARM_op(SDIV, _) -> false (* Not DIT *) + | ARM_op(SMLA_hw _, _) -> false (* Not DIT *) + | ARM_op(SMLAL, _) -> true + | ARM_op(SMMUL, _) -> false (* Not DIT *) + | ARM_op(SMMULR, _) -> false (* Not DIT *) + | ARM_op(SMUL_hw _, _) -> false (* Not DIT *) + | ARM_op(SMULL, _) -> true + | ARM_op(SMULW_hw _, _) -> false (* Not DIT *) + | ARM_op(STR, _) -> true + | ARM_op(STRB, _) -> true + | ARM_op(STRH, _) -> true + | ARM_op(SUB, _) -> true + | ARM_op(TST, _) -> true + | ARM_op(UBFX, _) -> true + | ARM_op(UDIV, _) -> false (* Not DIT *) + | ARM_op(UMAAL, _) -> false (* Not DIT *) + | ARM_op(UMLAL, _) -> true + | ARM_op(UMULL, _) -> true + | ARM_op(UXTB, _) -> true + | ARM_op(UXTH, _) -> true + + + (* All of the extra ops compile into CT instructions (no DIV). *) + let is_ct_asm_extra (o : extra_op) = true + + (* All of the extra ops compile into DIT instructions only, but this needs to be checked manually. *) + let is_doit_asm_extra (o : extra_op) = + match o with + | Oarm_swap _ -> true + | Oarm_add_large_imm -> true + | (Osmart_li _ | Osmart_li_cc _) -> true (* emit MOVT *) end diff --git a/compiler/src/checkAnnot.ml b/compiler/src/checkAnnot.ml index 020bb6435..dca26d870 100644 --- a/compiler/src/checkAnnot.ml +++ b/compiler/src/checkAnnot.ml @@ -40,7 +40,6 @@ let check_stack_size fds = | None -> () | Some expected -> let actual = sf_align in - let expected = Pretyping.tt_ws expected in if actual = expected then ( if !debug then Format.eprintf "INFO: %s has the expected stack alignment (%s)@." diff --git a/compiler/src/compile.ml b/compiler/src/compile.ml index b0cfd7c52..3012c102a 100644 --- a/compiler/src/compile.ml +++ b/compiler/src/compile.ml @@ -222,9 +222,7 @@ struct "invalid annotation table." let szs_of_fn cprog fn = - match (get_annot cprog fn).stack_zero_strategy with - | Some (s, ows) -> Some (s, Option.map Pretyping.tt_ws ows) - | None -> None + (get_annot cprog fn).stack_zero_strategy let cparams ~onlyreg visit_prog_after_pass cprog = { diff --git a/compiler/src/coreIdent.mli b/compiler/src/coreIdent.mli index 472efa38b..80e0f02e9 100644 --- a/compiler/src/coreIdent.mli +++ b/compiler/src/coreIdent.mli @@ -38,7 +38,7 @@ val tint : 'len gty (* ------------------------------------------------------------------------ *) -type 'len gvar = private { +type +'len gvar = private { v_name : Name.t; v_id : uid; v_kind : v_kind; diff --git a/compiler/src/ct_checker_forward.ml b/compiler/src/ct_checker_forward.ml index c7031e09f..891b64314 100644 --- a/compiler/src/ct_checker_forward.ml +++ b/compiler/src/ct_checker_forward.ml @@ -389,7 +389,6 @@ let rec ty_expr ~(public:bool) env (e:expr) = let env, _ = Env.get ~public:true env x in let env, _ = ty_expr ~public:true env i in env, Secret - | Papp1(o, e) -> let public = public || not (is_ct_op1 o) in ty_expr ~public env e @@ -399,7 +398,7 @@ let rec ty_expr ~(public:bool) env (e:expr) = | PappN(o, es) -> let public = public || not (is_ct_opN o) in ty_exprs_max ~public env es - | Pabstract(_, es) -> ty_exprs_max ~public env es + | Pabstract(_, es) -> assert false | Pif(_, e1, e2, e3) -> ty_exprs_max ~public env [e1; e2; e3] | Pfvar _ -> assert false | Pbig _ -> assert false diff --git a/compiler/src/evaluator.ml b/compiler/src/evaluator.ml index 96d78b913..c8efc8778 100644 --- a/compiler/src/evaluator.ml +++ b/compiler/src/evaluator.ml @@ -232,7 +232,7 @@ let pp_word fmt ws w = let z = Conv.z_of_cz z in Printer.pp_print_X fmt z -let pp_abstract fmt s = +let pp_abstract fmt s = Format.fprintf fmt "abstract<%a>" Utils.pp_string s let pp_val fmt v = @@ -256,11 +256,3 @@ let pp_val fmt v = | Vword(ws, w) -> pp_word fmt ws w | Vundef ty -> pp_undef fmt ty | Vabstract (s, _) -> pp_abstract fmt s - - - - - - - - diff --git a/compiler/src/glob_options.ml b/compiler/src/glob_options.ml index 6dedcc1f6..81cf19112 100644 --- a/compiler/src/glob_options.ml +++ b/compiler/src/glob_options.ml @@ -3,7 +3,6 @@ open Utils let version_string = "Jasmin Compiler @VERSION@" (*--------------------------------------------------------------------- *) let outfile = ref "" -let latexfile = ref "" let dwarf = ref false let debug = ref false let timings = ref false @@ -84,7 +83,7 @@ let set_slice f = slice := f :: !slice let set_constTime () = model := ConstantTime -let set_safety () = model := Safety +let set_annotations () = model := Annotations let set_checksafety () = check_safety := true let set_safetyparam s = safety_param := Some s @@ -176,7 +175,6 @@ let options = [ "-debug" , Arg.Set debug , " Print debug information"; "-timings" , Arg.Set timings , " Print a timestamp and elapsed time after each pass"; "-I" , Arg.String set_idirs , "[ident:path] Bind ident to path for from ident require ..."; - "-latex" , Arg.Set_string latexfile, "[filename] Generate the corresponding LATEX file (deprecated)"; "-lea" , Arg.Set lea , " Use lea as much as possible (default is nolea)"; "-nolea" , Arg.Clear lea , " Try to use add and mul instead of lea"; "-set0" , Arg.Set set0 , " Use [xor x x] to set x to 0 (default is not)"; @@ -185,8 +183,8 @@ let options = [ "-oec" , Arg.Set_string ecfile , "[filename] Use filename as output destination for easycrypt extraction"; "-oecarray" , Arg.String set_ec_array_path, "[dir] Output easycrypt array theories to the given path"; "-CT" , Arg.Unit set_constTime , " Generate model for constant time verification"; + "-Annotations" , Arg.Unit set_annotations , " Generate model for Cryptline verification"; "-slice" , Arg.String set_slice , "[f] Keep function [f] and everything it needs"; - "-safety", Arg.Unit set_safety , " Generate model for safety verification"; "-checksafety", Arg.Unit set_checksafety, " Automatically check for safety"; "-safetyparam", Arg.String set_safetyparam, " Parameter for automatic safety verification:\n \ diff --git a/compiler/src/insert_copy_and_fix_length.ml b/compiler/src/insert_copy_and_fix_length.ml index f42414558..0e6342557 100644 --- a/compiler/src/insert_copy_and_fix_length.ml +++ b/compiler/src/insert_copy_and_fix_length.ml @@ -26,6 +26,12 @@ let is_array_copy (x:lval) (e:expr) = end | _ -> None +let size_of_lval = + function + | Lvar x -> size_of (L.unloc x).v_ty + | Lasub (_, ws, len, _, _) -> arr_size ws len + | Lnone _ | Lmem _ | Laset _ -> assert false + let rec iac_stmt pd is = List.map (iac_instr pd) is and iac_instr pd i = { i with i_desc = iac_instr_r pd i.i_loc i.i_desc } and iac_instr_r pd loc ir = @@ -50,15 +56,14 @@ and iac_instr_r pd loc ir = let tys = List.map (fun e -> Conv.cty_of_ty (Typing.ty_expr pd loc e)) es in Copn(xs,t, Sopn.Opseudo_op(Pseudo_operator.Ospill(o, tys)), es) - | Sopn.Opseudo_op(Pseudo_operator.Ocopy(ws, _)), [Lvar x] -> + | Sopn.Opseudo_op(Pseudo_operator.Ocopy(ws, _)), [x] -> (* Fix the size it is dummy for the moment *) - let xn = size_of (L.unloc x).v_ty in + let xn = size_of_lval x in let wsn = size_of_ws ws in if xn mod wsn <> 0 then - Typing.error loc - "the variable %a has type %a, its size (%i) should be a multiple of %i" - (Printer.pp_var ~debug:false) (L.unloc x) - PrintCommon.pp_ty (L.unloc x).v_ty + Typing.error loc + "the destination %a has size %i: it should be a multiple of %i" + (Printer.pp_lval ~debug:false) x xn wsn else let op = Pseudo_operator.Ocopy (ws, Conv.pos_of_int (xn / wsn)) in diff --git a/compiler/src/latex_printer.ml b/compiler/src/latex_printer.ml index 2dc207c7d..e2e33143e 100644 --- a/compiler/src/latex_printer.ml +++ b/compiler/src/latex_printer.ml @@ -160,7 +160,7 @@ let rec pp_expr_rec prio fmt pe = | PEpack (vs,es) -> F.fprintf fmt "(%a)[@[%a@]]" pp_svsize vs (pp_list ",@ " pp_expr) es | PEBool b -> F.fprintf fmt "%s" (if b then "true" else "false") - | PEInt i -> F.fprintf fmt "%a" Z.pp_print i + | PEInt i -> F.fprintf fmt "%s" i | PECall (f, args) -> F.fprintf fmt "%a(%a)" pp_var f (pp_list ", " pp_expr) args | PECombF (f, args) -> F.fprintf fmt "%a(%a)" pp_var f (pp_list ", " pp_expr) args diff --git a/compiler/src/lexer.mll b/compiler/src/lexer.mll index c9ec5b954..fb2784099 100644 --- a/compiler/src/lexer.mll +++ b/compiler/src/lexer.mll @@ -128,6 +128,8 @@ let blank = [' ' '\t' '\r'] let newline = ['\n'] let digit = ['0'-'9'] +let octdigit = ['0'-'7'] +let bindigit = ['0'-'1'] let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F'] let lower = ['a'-'z'] let upper = ['A'-'Z'] @@ -153,12 +155,14 @@ rule main = parse | '"' (([^'"' '\\']|'\\' _)* as s) '"' { STRING (unescape (L.of_lexbuf lexbuf) s) } - (* Why this is needed *) - | ((*'-'?*) digit+) as s - { INT (Z.of_string s) } + | (digit+(('_')+ digit+)*) as s - | ('0' ['x' 'X'] hexdigit+) as s - { INT (Z.of_string s) } + | ('0' ['x' 'X'] hexdigit+(('_')+hexdigit+)*) as s + + | ('0' ['b' 'B'] bindigit+(('_')+bindigit+)*) as s + + | ('0' ['o' 'O'] octdigit+(('_')+octdigit+)*) as s + {INT s} | ident as s { Option.default (NID s) (Hash.find_option keywords s) } diff --git a/compiler/src/liveness.ml b/compiler/src/liveness.ml index a58b50473..d5ea24fea 100644 --- a/compiler/src/liveness.ml +++ b/compiler/src/liveness.ml @@ -10,16 +10,19 @@ let dep_lv s_o x = let dep_lvs s_o xs = List.fold_left dep_lv s_o xs -let writev_lval s = function +(** Adds to [s] variables that are used as destination or to compute a +destination (array index, memory offset) *) +let weak_dep_lv s = function | Lnone _ -> s | Lvar x -> Sv.add (L.unloc x) s - | Lmem _ -> s - | Laset(_, _, _, x, _) - | Lasub(_, _, _, x, _) -> Sv.add (L.unloc x) s + | Lmem(_, _, x, e) + | Laset(_, _, _, x, e) + | Lasub(_, _, _, x, e) -> Sv.add (L.unloc x) (Sv.union (vars_e e) s) -let writev_lvals s lvs = List.fold_left writev_lval s lvs +let weak_dep_lvs s lvs = List.fold_left weak_dep_lv s lvs -(* When [weak] is true, the out live-set contains also the written variables. *) +(* When [weak] is true, the out live-set contains also the written variables and +the variables that are used for evaluating LHS expressions. *) let rec live_i weak i s_o = let s_i, s_o, d = live_d weak i.i_desc s_o in s_i, { i with i_desc = d; i_info = (s_i, s_o); i_annot = i.i_annot} @@ -29,7 +32,7 @@ and live_d weak d (s_o: Sv.t) = | Cassgn(x, tg, ty, e) -> let s_i = Sv.union (vars_e e) (dep_lv s_o x) in let s_o = - if weak then writev_lval s_o x + if weak then weak_dep_lv s_o x else s_o in s_i, s_o, Cassgn(x, tg, ty, e) @@ -37,7 +40,7 @@ and live_d weak d (s_o: Sv.t) = let s_i = Sv.union (vars_es es) (dep_lvs s_o xs) in let s_o = if weak - then writev_lvals s_o xs + then weak_dep_lvs s_o xs else s_o in s_i, s_o, Copn(xs,t,o,es) @@ -66,11 +69,11 @@ and live_d weak d (s_o: Sv.t) = | Ccall(xs,f,es) -> let s_i = Sv.union (vars_es es) (dep_lvs s_o xs) in - s_i, (if weak then writev_lvals s_o xs else s_o), Ccall(xs,f,es) + s_i, (if weak then weak_dep_lvs s_o xs else s_o), Ccall(xs,f,es) | Csyscall(xs,o,es) -> let s_i = Sv.union (vars_es es) (dep_lvs s_o xs) in - s_i, (if weak then writev_lvals s_o xs else s_o), Csyscall(xs,o,es) + s_i, (if weak then weak_dep_lvs s_o xs else s_o), Csyscall(xs,o,es) and live_c weak c s_o = List.fold_right diff --git a/compiler/src/main_compiler.ml b/compiler/src/main_compiler.ml index 44d79e5be..fa36f25f4 100644 --- a/compiler/src/main_compiler.ml +++ b/compiler/src/main_compiler.ml @@ -108,7 +108,7 @@ let main () = | Some conf -> SafetyConfig.load_config conf | None -> () in - let env, pprog, ast = + let env, pprog, _ast = try Compile.parse_file Arch.arch_info infile with | Annot.AnnotationError (loc, code) -> hierror ~loc:(Lone loc) ~kind:"annotation error" "%t" code @@ -128,15 +128,7 @@ let main () = (List.tl (List.rev (Pretyping.Env.dependencies env))); exit 0 end; - - if !latexfile <> "" then begin - let out = open_out !latexfile in - let fmt = Format.formatter_of_out_channel out in - Format.fprintf fmt "%a@." Latex_printer.pp_prog ast; - close_out out; - if !debug then Format.eprintf "Pretty printed to LATEX@." - end; - + eprint Compiler.Typing (Printer.pp_pprog Arch.reg_size Arch.asmOp) pprog; let prog = diff --git a/compiler/src/parser.mly b/compiler/src/parser.mly index 821e7e0a8..b026634b2 100644 --- a/compiler/src/parser.mly +++ b/compiler/src/parser.mly @@ -95,7 +95,7 @@ %token EXPORT %token ARRAYINIT %token NID -%token INT +%token INT %token STRING %nonassoc COLON QUESTIONMARK %left PIPEPIPE @@ -140,8 +140,8 @@ annotationlabel: | s=loc(STRING) { s } int: - | i=INT { i } - | MINUS i=INT { Z.neg i } + | i=INT { Syntax.parse_int i } + | MINUS i=INT { Z.neg (Syntax.parse_int i ) } simple_attribute: | i=int { Aint i } @@ -316,10 +316,10 @@ pexpr_r: { PEbig (bo, e1, e2, v, b) } | RESULT DOT i=INT - { PEResult (Z.to_int i)} + { PEResult i} | RESULT DOT index=INT i=arr_access - { let aa, (ws, e, len, al) = i in PEResultGet (al, aa, ws, Z.to_int index, e, len) } + { let aa, (ws, e, len, al) = i in PEResultGet (al, aa, ws, index, e, len) } pexpr: @@ -400,11 +400,9 @@ pinstr_r: | FOR v=var EQ ce1=pexpr DOWNTO ce2=pexpr is=pblock { PIFor (v, (`Down, ce2, ce1), is) } -| WHILE is1=pblock? LPAREN b=pexpr RPAREN - { PIWhile (is1, b, None) } +| WHILE is1=pblock? LPAREN b=pexpr RPAREN is2=pblock? + { PIWhile (is1, b, is2) } -| WHILE is1=pblock? LPAREN b=pexpr RPAREN is2=pblock - { PIWhile (is1, b, Some is2) } | vd=postfix(pvardecl(COMMA?), SEMICOLON) { PIdecl vd } diff --git a/compiler/src/pretyping.ml b/compiler/src/pretyping.ml index 3ad9d0643..ac1fb239c 100644 --- a/compiler/src/pretyping.ml +++ b/compiler/src/pretyping.ml @@ -577,9 +577,6 @@ end = struct end -(* -------------------------------------------------------------------- *) -let tt_ws (ws : A.wsize) = ws - (* -------------------------------------------------------------------- *) let tt_pointer dfl_writable (p:S.ptr) : W.reference = match p with @@ -790,7 +787,6 @@ let op_info exn op (castop:S.castop) ty ws_cmp vs_cmp = | CSS(Some sz, s) -> let s = tt_sign s in - let sz = tt_ws sz in check_op loc op (Some (snd ws_cmp)) sz; OpKE(E.Cmp_w(s, sz)) @@ -1122,7 +1118,7 @@ let rec tt_expr pd ?(mode=`AllVar) (env : 'asm Env.env) pe = P.Pbool b, P.tbool | S.PEInt i -> - P.Pconst i, P.tint + P.Pconst (S.parse_int i), P.tint | S.PEVar x -> tt_fvar_global mode env x @@ -1134,7 +1130,7 @@ let rec tt_expr pd ?(mode=`AllVar) (env : 'asm Env.env) pe = | S.PEGet (al, aa, ws, ({ L.pl_loc = xlc } as x), pi, olen) -> let x, ty = tt_var_global mode env x in let ty, _ = tt_as_array (xlc, ty) in - let ws = Option.map_default tt_ws (P.ws_of_ty ty) ws in + let ws = Option.default (P.ws_of_ty ty) ws in let ty = P.tu ws in let i,ity = tt_expr ~mode pd env pi in let i = ensure_int (L.loc pi) i ity in @@ -1159,7 +1155,6 @@ let rec tt_expr pd ?(mode=`AllVar) (env : 'asm Env.env) pe = e, P.tint | `Cast (`ToWord (sz, sg)) -> - let sz = tt_ws sz in let e, ws = cast_word (L.loc pe) sz e ety in let e = if W.wsize_cmp ws sz = Datatypes.Lt then @@ -1303,6 +1298,7 @@ let rec tt_expr pd ?(mode=`AllVar) (env : 'asm Env.env) pe = P.Pbig(e1, e2, o, L.mk_loc (L.loc px) x, e0, b), ty | S.PEResult i -> + let i = Z.to_int ( S.parse_int i) in let si = try Env.get_f_result env i with | _ -> rs_tyerror ~loc:(L.loc pe) (UnknownResult i) @@ -1311,13 +1307,14 @@ let rec tt_expr pd ?(mode=`AllVar) (env : 'asm Env.env) pe = P.Presult (i,x), ty | S.PEResultGet (al, aa, ws, v, pi, olen) -> + let v = Z.to_int ( S.parse_int v) in let si = try Env.get_f_result env v with | _ -> rs_tyerror ~loc:(L.loc pe) (UnknownResult v) in let x, ty = tt_var_global mode env si in let ty, _ = tt_as_array (L.loc pe, ty) in - let ws = Option.map_default tt_ws (P.ws_of_ty ty) ws in + let ws = Option.default (P.ws_of_ty ty) ws in let ty = P.tu ws in let e,ity = tt_expr ~mode pd env pi in check_ty_eq ~loc:(L.loc pi) ~from:ity ~to_:P.tint; @@ -1344,7 +1341,7 @@ and tt_mem_access pd ?(mode=`AllVar) (env : 'asm Env.env) match k with | `Add -> e | `Sub -> Papp1(E.Oneg (E.Op_w pd), e) in - let ct = ct |> Option.map_default tt_ws pd in + let ct = ct |> Option.default pd in let al = tt_al AAdirect al in (ct,L.mk_loc xlc x,e, al) @@ -1353,9 +1350,9 @@ and tt_type pd (env : 'asm Env.env) (pty : S.ptype) : P.pty = match L.unloc pty with | S.TBool -> P.tbool | S.TInt -> P.tint - | S.TWord ws -> P.Bty (P.U (tt_ws ws)) + | S.TWord ws -> P.Bty (P.U ws) | S.TArray (ws, e) -> - P.Arr (tt_ws ws, fst (tt_expr ~mode:`OnlyParam pd env e)) + P.Arr (ws, fst (tt_expr ~mode:`OnlyParam pd env e)) | S.Tabstract s -> P.Bty (P.Abstract (L.unloc s)) (* -------------------------------------------------------------------- *) @@ -1381,10 +1378,6 @@ let tt_vardecls_push dfl_writable pd (env : 'asm Env.env) pxs = List.fold_left (fun env x -> Env.Vars.push_local env (L.unloc x)) env xs in (env, xs) -(* -------------------------------------------------------------------- *) -let tt_vardecl_push dfl_writable pd (env : 'asm Env.env) px = - snd_map as_seq1 (tt_vardecls_push dfl_writable pd env [px]) - (* -------------------------------------------------------------------- *) let tt_param pd (env : 'asm Env.env) _loc (pp : S.pparam) : 'asm Env.env = let ty = tt_type pd env pp.ppa_ty in @@ -1419,7 +1412,7 @@ let tt_lvalue pd (env : 'asm Env.env) { L.pl_desc = pl; L.pl_loc = loc; } = let x = tt_var `NoParam env x in reject_constant_pointers xlc x ; let ty,_ = tt_as_array (xlc, x.P.v_ty) in - let ws = Option.map_default tt_ws (P.ws_of_ty ty) ws in + let ws = Option.default (P.ws_of_ty ty) ws in let ty = P.tu ws in let i,ity = tt_expr ~mode:`AllVar pd env pi in let i = ensure_int (L.loc pi) i ity in @@ -1979,7 +1972,6 @@ let rec tt_instr arch_info (env : 'asm Env.env) ((annot,pi) : S.pinstr) : 'asm E | S.PIAssign (ls, `Raw, { pl_desc = PEOp1 (`Cast(`ToWord ct), {pl_desc = PEPrim (f, args) })} , None) -> let ws, s = ct in - let ws = tt_ws ws in assert (s = `Unsigned); (* FIXME *) let p = tt_prim arch_info.asmOp f in let id = Sopn.asm_op_instr Build_Tabstract arch_info.asmOp p in @@ -2089,8 +2081,6 @@ and tt_cmd arch_info env c = (* -------------------------------------------------------------------- *) let tt_funbody arch_info env (pb : S.pfunbody) = - (* let vars = List.(pb.pdb_vars |> map (fun (ty, vs) -> map (fun v -> (ty, v)) vs) |> flatten) in - let env = fst (tt_vardecls_push (fun _ -> true) env vars) in *) let env, bdy = tt_cmd arch_info env pb.S.pdb_instr in let ret = let for1 x = L.mk_loc (L.loc x) (tt_var `AllVar env x) in @@ -2363,6 +2353,7 @@ let tt_global pd (env : 'asm Env.env) _loc (gd: S.pglobal) : 'asm Env.env = Env.Vars.push_global env (x,d) + (* -------------------------------------------------------------------- *) let tt_abstract_typ env _loc (t: S.pabstract_ty) : 'asm Env.env = Env.add_abstract_typ env (L.unloc t.pat_name) @@ -2378,7 +2369,10 @@ let rec tt_item arch_info (env : 'asm Env.env) pt : 'asm Env.env = | S.PFundef pf -> tt_fundef arch_info env (L.loc pt) pf | S.PGlobal pg -> tt_global arch_info.pd env (L.loc pt) pg | S.Pexec pf -> - Env.Exec.push (L.loc pt) (fst (tt_fun env pf.pex_name)).P.f_name pf.pex_mem env + Env.Exec.push (L.loc pt) + (fst (tt_fun env pf.pex_name)).P.f_name + (List.map (fun (x, y) -> S.parse_int x, S.parse_int y) pf.pex_mem) + env | S.Prequire (from, fs) -> List.fold_left (tt_file_loc arch_info from) env fs | S.Pabstract_ty pat -> tt_abstract_typ env (L.loc pt) pat diff --git a/compiler/src/pretyping.mli b/compiler/src/pretyping.mli index 5bc09806a..435d09dea 100644 --- a/compiler/src/pretyping.mli +++ b/compiler/src/pretyping.mli @@ -39,7 +39,6 @@ module Env : sig end end -val tt_ws : Annotations.wsize -> Wsize.wsize val tt_prim : 'op Sopn.asmOp -> Annotations.symbol Location.located -> 'op type ('a, 'b, 'c, 'd, 'e, 'f, 'g) arch_info = { diff --git a/compiler/src/sct_checker_forward.ml b/compiler/src/sct_checker_forward.ml index fbcc2d7f6..62755540f 100644 --- a/compiler/src/sct_checker_forward.ml +++ b/compiler/src/sct_checker_forward.ml @@ -802,7 +802,9 @@ module MSF : sig val enter_if : t -> expr -> t val max : t -> t -> t + val check_msf : t -> var_i -> unit val check_msf_trans : t -> var_i -> expr -> unit + val is_msf : t -> var_i -> bool val is_msf_exact : t -> var_i -> bool val check_msf_exact : t -> var_i -> unit val loop : Env.env -> L.i_loc -> t -> t @@ -823,9 +825,14 @@ module MSF : sig exact (Sv.singleton (L.unloc x)) let add x (xs, oe) = - assert (oe = None); ensure_register ~direct:true x; - exact (Sv.add (L.unloc x) xs) + let loc = L.loc x in + let x = L.unloc x in + Stdlib.Option.iter (fun e -> + if Sv.mem x (vars_e e) then + error ~loc "%a cannot become an MSF as the current status depends on it (%a)" pp_var x pp_expr e + ) oe; + (Sv.add x xs, oe) let update (xs, oe) x = match oe with @@ -843,7 +850,13 @@ module MSF : sig | Some e1, Some e2 when expr_equal e1 e2 -> Sv.inter xs1 xs2, Some e1 | _, _ -> toinit - let check_msf_trans (xs, ob) ms b = + let check_msf (xs, _) ms = + if not (Sv.mem (L.unloc ms) xs) then + error ~loc:(L.loc ms) + "the variable %a is not known to be a msf, only %a are" + pp_var_i ms pp_vset xs + + let check_msf_trans ((_, ob) as msf) ms b = match ob with | None -> error ~loc:(L.loc ms) "MSF is not Trans" | Some b' -> @@ -851,25 +864,20 @@ module MSF : sig error ~loc:(L.loc ms) "the expression %a need to be equal to@ %a" pp_expr b pp_expr b'; - if not (Sv.mem (L.unloc ms) xs) then - error ~loc:(L.loc ms) - "the variable %a is not known to be a msf, only %a are" - pp_var_i ms pp_vset xs + check_msf msf ms + + let is_msf (xs, _) ms = Sv.mem (L.unloc ms) xs let is_msf_exact (xs, ob) ms = match ob with | Some _ -> false | None -> Sv.mem (L.unloc ms) xs - let check_msf_exact (xs, ob) ms = + let check_msf_exact ((_, ob) as msf) ms = match ob with | Some b -> error ~loc:(L.loc ms) "MSF is Trans@ %a" pp_expr b - | None -> - if not (Sv.mem (L.unloc ms) xs) then - error ~loc:(L.loc ms) - "the variable %a is not known to be a msf, only %a are" - pp_var_i ms pp_vset xs + | None -> check_msf msf ms let pp fmt (xs, oe) = match oe with @@ -1009,6 +1017,13 @@ let ensure_public_address_expr env venv loc e = | Indirect (le, _) -> try VlPairs.add_le le (Env.public2 env) with Lvl.Unsat unsat -> error_unsat loc unsat pp_expr e ety (Direct (Env.public2 env)) +(* --------------------------------------------------------------- *) +let move_msf ~loc env (msf, venv) mso msi = + let mso = reg_lval ~direct:true loc mso + and msi = reg_expr ~direct:true loc msi in + MSF.check_msf msf msi; + MSF.add mso msf, Env.set_ty env venv mso (Env.dpublic env) + (* --------------------------------------------------------------- *) (* [ty_instr env msf i] return msf' such that env, msf |- i : msf' *) @@ -1022,10 +1037,8 @@ let rec ty_instr is_ct_asm fenv env ((msf,venv) as msf_e :msf_e) i = (* We don't known what happen to MSF after external function call *) ty_lvals1 env (MSF.toinit, venv) xs (Env.dsecret env) - | Cassgn(mso, _, _, (Pvar x as msi)) when MSF.is_msf_exact msf x.gv -> - let mso = reg_lval ~direct:true loc mso and msi = reg_expr ~direct:true loc msi in - MSF.check_msf_exact msf msi; - MSF.add mso msf, Env.set_ty env venv mso (Env.dpublic env) + | Cassgn(mso, _, _, (Pvar x as msi)) when MSF.is_msf msf x.gv -> + move_msf ~loc env msf_e mso msi | Cassgn(x, _, _, e) -> let ety = ty_expr env venv loc e in @@ -1051,9 +1064,7 @@ let rec ty_instr is_ct_asm fenv env ((msf,venv) as msf_e :msf_e) i = | Update_msf, _, _ -> assert false | Mov_msf, [mso], [msi] -> - let mso = reg_lval ~direct:true loc mso and msi = reg_expr ~direct:true loc msi in - MSF.check_msf_exact msf msi; - MSF.add mso msf, Env.set_ty env venv mso (Env.dpublic env) + move_msf ~loc env msf_e mso msi | Mov_msf, _, _ -> assert false @@ -1126,9 +1137,9 @@ let rec ty_instr is_ct_asm fenv env ((msf,venv) as msf_e :msf_e) i = let (msf2, venv2) = ty_cmd is_ct_asm fenv env (msf1, venv1) c1 in ensure_public env venv2 loc e; let (msf', venv') = ty_cmd is_ct_asm fenv env (MSF.enter_if msf2 e, venv2) c2 in - let msf' = MSF.end_loop loc msf1 msf' in + let _ = MSF.end_loop loc msf1 msf' in Env.ensure_le loc venv' venv1; (* venv' <= venv1 *) - MSF.enter_if msf' (Papp1(Onot, e)), venv1 + MSF.enter_if msf2 (Papp1(Onot, e)), venv2 | Ccall (xs, f, es) -> let fty = FEnv.get_fty fenv f in @@ -1319,7 +1330,9 @@ let init_constraint fenv f = error ~loc "%s annotation not allowed here" smsf in - let mk_vty loc ~(msf:bool) x ls an = + (** The [is_local] argument is true when variable [x] is a local variable as + opposed to an argument or a returned value which inherits constraints from the call-sites. *) + let mk_vty loc ~is_local ~(msf:bool) x ls an = let msf, ovty = match ls, an with | [], None -> None, None @@ -1343,7 +1356,9 @@ let init_constraint fenv f = | None -> begin match x.v_kind with | Const -> Env.dpublic env + | Stack Direct when is_local -> Direct (Env.fresh env, Env.secret env) | Stack Direct -> Direct (Env.fresh2 env) + | Stack (Pointer _) when is_local -> Indirect((Env.fresh env, Env.secret env), Env.fresh2 env) | Stack (Pointer _) -> Indirect(Env.fresh2 env, Env.fresh2 env) | Reg (_, Direct) -> Direct (Env.fresh2 env) | Reg (_, Pointer _) -> Indirect(Env.fresh2 env, Env.fresh2 env) @@ -1369,7 +1384,7 @@ let init_constraint fenv f = let loc = L.loc x and x = L.unloc x in let an = Option.bind sig_annot (SecurityAnnotations.get_nth_result i) in let ls, _ = parse_var_annot ~kind_allowed:false ~msf:(not export) annot in - mk_vty loc ~msf:(not export) x ls an in + mk_vty ~is_local:false loc ~msf:(not export) x ls an in (* process function outputs *) let tyout = List.map2i process_return f.f_ret f.f_outannot in @@ -1399,7 +1414,7 @@ let init_constraint fenv f = let process_param i venv x = let an = Option.bind sig_annot (SecurityAnnotations.get_nth_argument i) in let ls, vk = parse_var_annot ~kind_allowed:true ~msf:(not export) x.v_annot in - let msf, vty = mk_vty x.v_dloc ~msf:(not export) x ls an in + let msf, vty = mk_vty ~is_local:false x.v_dloc ~msf:(not export) x ls an in let msf = match msf with | None -> Sv.mem x msfs @@ -1444,7 +1459,7 @@ let init_constraint fenv f = (* init type for local *) let do_local x venv = let ls, vk = parse_var_annot ~kind_allowed:true ~msf:false x.v_annot in - let _, vty = mk_vty x.v_dloc ~msf:false x ls None in + let _, vty = mk_vty x.v_dloc ~is_local:true ~msf:false x ls None in Env.add_var env venv x vk vty in let venv = Sv.fold do_local (locals f) venv in diff --git a/compiler/src/stackAlloc.ml b/compiler/src/stackAlloc.ml index c7be7e7dc..4c09191b3 100644 --- a/compiler/src/stackAlloc.ml +++ b/compiler/src/stackAlloc.ml @@ -377,7 +377,6 @@ let memory_analysis pp_err ~debug up = (* no stack to clear, we don't change the alignment *) align else - let ws = Pretyping.tt_ws ws in if wsize_lt align ws then ws else align | _, _ -> align in @@ -416,7 +415,7 @@ let memory_analysis pp_err ~debug up = | Export _, Some (_, ows) -> let ws = match ows with - | Some ws -> Pretyping.tt_ws ws + | Some ws -> ws | None -> align (* the default clear step is the alignment *) in Conv.z_of_cz (Memory_model.round_ws ws (Conv.cz_of_z max_size)) diff --git a/compiler/src/subst.ml b/compiler/src/subst.ml index de5915215..e1a0c0e59 100644 --- a/compiler/src/subst.ml +++ b/compiler/src/subst.ml @@ -35,7 +35,6 @@ let rec gsubst_e (flen: ?loc:L.t -> 'len1 -> 'len2) (f: 'len1 ggvar -> 'len2 gex in Pabstract (o, List.map (gsubst_e flen f) es) | Pif (ty, e, e1, e2)-> Pif(gsubst_ty (flen ?loc:None) ty, gsubst_e flen f e, gsubst_e flen f e1, gsubst_e flen f e2) - | Pfvar x -> Pfvar (gsubst_vdest f x) | Pbig (e1, e2, o, x, e0, b) -> Pbig(gsubst_e flen f e1, gsubst_e flen f e2, o, diff --git a/compiler/src/syntax.ml b/compiler/src/syntax.ml index 0a85120ed..85a42f526 100644 --- a/compiler/src/syntax.ml +++ b/compiler/src/syntax.ml @@ -1,4 +1,5 @@ open Annotations +open Utils (* -------------------------------------------------------------------- *) module L = Location @@ -23,6 +24,11 @@ type svsize = vsize * sign * vesize type castop1 = CSS of sowsize | CVS of svsize type castop = castop1 L.located option +type int_representation = string +let parse_int (i: int_representation) : Z.t = + let s = String.filter (( <> ) '_') i in + Z.of_string s + let bits_of_wsize : wsize -> int = Annotations.int_of_ws let suffix_of_sign : sign -> string = @@ -153,7 +159,7 @@ type pexpr_r = | PEFetch of mem_access | PEpack of svsize * pexpr list | PEBool of bool - | PEInt of Z.t + | PEInt of int_representation | PECall of pident * pexpr list | PECombF of pident * pexpr list | PEPrim of pident * pexpr list @@ -162,8 +168,8 @@ type pexpr_r = | PEIf of pexpr * pexpr * pexpr | PEbig of pbig * pexpr * pexpr * pident * pexpr | PEAbstract of pident * pexpr list - | PEResult of int - | PEResultGet of [`Aligned|`Unaligned] option * arr_access * wsize option * int * pexpr * pexpr option + | PEResult of int_representation + | PEResultGet of [`Aligned|`Unaligned] option * arr_access * wsize option * int_representation * pexpr * pexpr option and pexpr = pexpr_r L.located @@ -227,12 +233,19 @@ type assert_prover = pident type pinstr_r = | PIArrayInit of pident + (** ArrayInit(x); *) | PIAssign of plvals * peqop * pexpr * pexpr option + (** x, y += z >> 4 if c; *) | PIAssert of pexpr + (** assert (x > 0); *) | PIIf of pexpr * pblock * pblock option + (** if e { … } else { … } *) | PIFor of pident * (fordir * pexpr * pexpr) * pblock + (** for i = 0 to N { … } *) | PIWhile of pblock option * pexpr * pblock option + (** while { … } (x > 0) { … } *) | PIdecl of vardecls + (** reg u32 x y z; *) and pblock_r = pinstr list and fordir = [ `Down | `Up ] @@ -285,7 +298,7 @@ type pglobal = { pgd_type: ptype; pgd_name: pident ; pgd_val: gpexpr } (* -------------------------------------------------------------------- *) type pexec = { pex_name: pident; - pex_mem: (Z.t * Z.t) list; + pex_mem: (int_representation * int_representation) list; } (* -------------------------------------------------------------------- *) @@ -319,3 +332,4 @@ type pitem = (* -------------------------------------------------------------------- *) type pprogram = pitem L.located list + diff --git a/compiler/src/toEC.ml b/compiler/src/toEC.ml index 58c868053..e5021ee68 100644 --- a/compiler/src/toEC.ml +++ b/compiler/src/toEC.ml @@ -4,119 +4,356 @@ open Prog open PrintCommon module E = Expr -let pp_size fmt sz = - Format.fprintf fmt "%i" (int_of_ws sz) +module Ec = struct + + type ec_op2 = + | ArrayGet + | Plus + | Infix of string + + type ec_op3 = + | Ternary + | If + | InORange + + type quantif = + | Lforall + | Lexists + | Llambda + + type ec_ident = string list + + type ec_ty = + | Base of string + | Tuple of ec_ty list + + type ec_var = string * ec_ty + + type ec_expr = + | Equant of quantif * string list * ec_expr (*use ec_var list for binders*) + | Econst of Z.t (* int. literal *) + | Ebool of bool (* bool literal *) + | Eident of ec_ident (* variable *) + | Eapp of ec_expr * ec_expr list (* op. application *) + | Eop2 of ec_op2 * ec_expr * ec_expr (* binary operator *) + | Eop3 of ec_op3 * ec_expr * ec_expr * ec_expr (* ternary operator *) + | Elist of ec_expr list (* list litteral *) + | Etuple of ec_expr list (* tuple litteral *) + | Eproj of ec_expr * int (* projection of a tuple *) + | EHoare of ec_ident * ec_expr * ec_expr + + type ec_fun_decl = { + fname: string; + args: ec_var list; + rtys: ec_ty; + } -let pp_Tsz fmt sz = - Format.fprintf fmt "W%a" pp_size sz + type ec_lvalue = + | LvIdent of ec_ident + | LvArrItem of ec_ident * ec_expr -let pp_sz_t fmt sz = - Format.fprintf fmt "%a.t" pp_Tsz sz + type ec_lvalues = ec_lvalue list -module Scmp = struct - type t = string - let compare = compare -end + type ec_instr = + | ESasgn of ec_lvalues * ec_expr + | EScall of ec_lvalues * ec_ident * ec_expr list + | ESsample of ec_lvalues * ec_expr + | ESif of ec_expr * ec_stmt * ec_stmt + | ESwhile of ec_expr * ec_stmt + | ESreturn of ec_expr + | EScomment of string (* comment line *) -module Ss = Set.Make(Scmp) -module Ms = Map.Make(Scmp) + and ec_stmt = ec_instr list -module Tcmp = struct - type t = ty - let compare = compare -end + type ec_fun = { + decl: ec_fun_decl; + locals: ec_var list; + stmt: ec_stmt; + } -module Mty = Map.Make (Tcmp) + type ec_modty = string -type proofvar = { - assume_ : Ss.elt; - assert_ : Ss.elt; - assert_proof : Ss.elt; - assume_proof : Ss.elt; -} + type ec_module_type = { + name: ec_modty; + funs: ec_fun_decl list; + } -type ('len) env = { - model : model; - alls : Ss.t; - vars : (string * bool) Mv.t; (* true means option type *) - glob : (string * ty) Ms.t; - funs : (string * (ty list * ty list)) Mf.t; - tmplvs : ('len CoreIdent.gvar list) Mf.t; - contra : ('len Prog.gfcontract * 'len CoreIdent.gvar list * 'len CoreIdent.gvar list) Mf.t; - arrsz : Sint.t ref; - warrsz : Sint.t ref; - auxv : string list Mty.t; - randombytes : Sint.t ref; - proofv : proofvar Mf.t ref; - func : funname option; - freturn : Prog.var list + type ec_module = { + name: string; + params: (string * ec_modty) list; + ty: ec_modty option; + vars: ec_var list; + funs: ec_fun list; } -let for_safety env = env.model = Utils.Safety + type ec_proposition = string * string list * ec_expr -(* --------------------------------------------------------------- *) + type ec_tactic_args = + | Conti of ec_tactic + | Seq of ec_tactic + | Param of string list + | Form of ec_proposition + | Ident of ec_ident + | Pattern of string + | Prop of string + | Comment of string -let rec read_mem_e = function - | Pconst _ | Pbool _ | Parr_init _ |Pvar _ -> false - | Pload _ -> true - | Papp1 (_, e) | Pget (_, _, _, _, e) | Psub (_, _, _, _, e) -> read_mem_e e - | Papp2 (_, e1, e2) -> read_mem_e e1 || read_mem_e e2 - | PappN (_, es) -> read_mem_es es - | Pabstract (_, es) -> read_mem_es es - | Pif (_, e1, e2, e3) -> read_mem_e e1 || read_mem_e e2 || read_mem_e e3 - | Pfvar _ -> false - | Pbig (e1, e2, _, _, ei, e)-> read_mem_e e1 || read_mem_e e2 || read_mem_e ei || read_mem_e e - | Presult _ -> false - | Presultget (_, _, _, _, _, e) -> read_mem_e e + and ec_tactic = + { tname : string; + targs : ec_tactic_args list; + (* subgoals : ec_tactic list *) + } -and read_mem_es es = List.exists read_mem_e es + type ec_proof = ec_tactic list -let read_mem_lval = function - | Lnone _ | Lvar _ -> false - | Lmem (_,_,_,_) -> true - | Laset (_,_,_,_,e) | Lasub (_,_,_,_,e)-> read_mem_e e + type ec_item = + | IrequireImport of string list + | Iimport of string list + | IfromImport of string * (string list) + | IfromRequireImport of string * (string list) + | Iabbrev of string * ec_expr + | ImoduleType of ec_module_type + | Imodule of ec_module + | Icomment of string (* comment line *) + | Axiom of ec_proposition + | Lemma of ec_proposition * ec_proof + type ec_prog = ec_item list -let write_mem_lval = function - | Lnone _ | Lvar _ | Laset _ | Lasub _ -> false - | Lmem _ -> true + (* Printer*) -let read_mem_lvals = List.exists read_mem_lval -let write_mem_lvals = List.exists write_mem_lval + let ec_print_i z = + if Z.leq Z.zero z then Z.to_string z + else Format.asprintf "(%a)" Z.pp_print z -let rec read_mem_i s i = - match i.i_desc with - | Cassgn (x, _, _, e) -> read_mem_lval x || read_mem_e e - | Copn (xs, _, _, es) | Csyscall (xs, Syscall_t.RandomBytes _, es) -> read_mem_lvals xs || read_mem_es es - | Cassert (_, _, e) -> read_mem_e e - | Cif (e, c1, c2) -> read_mem_e e || read_mem_c s c1 || read_mem_c s c2 - | Cwhile (_, c1, e, c2) -> read_mem_c s c1 || read_mem_e e || read_mem_c s c2 - | Ccall (xs, fn, es) -> read_mem_lvals xs || Sf.mem fn s || read_mem_es es - | Cfor (_, (_, e1, e2), c) -> read_mem_e e1 || read_mem_e e2 || read_mem_c s c + let pp_option pp fmt = function + | Some x -> pp fmt x + | None -> () -and read_mem_c s = List.exists (read_mem_i s) + let pp_list_paren sep pp fmt xs = + if xs = [] then () + else pp_paren (pp_list sep pp) fmt xs -let read_mem_f s f = read_mem_c s f.f_body + let pp_Tsz sz = Format.asprintf "W%i" (int_of_ws sz) -let rec write_mem_i s i = - match i.i_desc with - | Cassgn (x, _, _, _) -> write_mem_lval x - | Copn (xs, _, _, _) | Csyscall(xs, Syscall_t.RandomBytes _, _) -> write_mem_lvals xs - | Cassert _ -> false - | Cif (_, c1, c2) -> write_mem_c s c1 ||write_mem_c s c2 - | Cwhile (_, c1, _, c2) -> write_mem_c s c1 ||write_mem_c s c2 - | Ccall (xs, fn, _) -> write_mem_lvals xs || Sf.mem fn s - | Cfor (_, _, c) -> write_mem_c s c + let pp_sz_t sz = Format.sprintf "W%i.t" (int_of_ws sz) -and write_mem_c s = List.exists (write_mem_i s) + let pp_ec_ident fmt ident = Format.fprintf fmt "@[%a@]" (pp_list "." pp_string) ident -let write_mem_f s f = write_mem_c s f.f_body + let string_of_quant = function + | Lforall -> "forall" + | Lexists -> "exists" + | Llambda -> "fun" -let init_use fs = - let add t s f = if t s f then Sf.add f.f_name s else s in - List.fold_left - (fun (sr,sw) f -> add read_mem_f sr f, add write_mem_f sw f) - (Sf.empty, Sf.empty) fs + let rec pp_ec_ty fmt ty = + match ty with + | Base t -> Format.fprintf fmt "%s" t + | Tuple tl -> + if tl = [] then Format.fprintf fmt "unit" + else Format.fprintf fmt "@[(%a)@]" (pp_list " *@ " pp_ec_ty) tl + + let rec pp_ec_ast_expr fmt e = match e with + | Econst z -> Format.fprintf fmt "%s" (ec_print_i z) + | Ebool b -> pp_bool fmt b + | Eident s -> pp_ec_ident fmt s + | Eapp (f, ops) -> + Format.fprintf fmt "@[(@,%a@,)@]" + (Format.(pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt "@ ")) pp_ec_ast_expr) + (f::ops) + | Eop2 (op, e1, e2) -> pp_ec_op2 fmt (op, e1, e2) + | Eop3 (op, e1, e2, e3) -> pp_ec_op3 fmt (op, e1, e2, e3) + | Elist es -> Format.fprintf fmt "@[[%a]@]" (pp_list ";@ " pp_ec_ast_expr) es + | Etuple es -> Format.fprintf fmt "@[(%a)@]" (pp_list ",@ " pp_ec_ast_expr) es + | Equant (q, i, f) -> + begin + match q with + | Llambda -> + Format.fprintf fmt "@[(%s %a =>@ %a)@]" + (string_of_quant q) (pp_list " " pp_string) i pp_ec_ast_expr f + | _ -> + Format.fprintf fmt "@[%s %a,@ %a@]" + (string_of_quant q) (pp_list " " pp_string) i pp_ec_ast_expr f + end + | Eproj (e,i) -> Format.fprintf fmt "@[%a.`%i@]" pp_ec_ast_expr e i + | EHoare (i,fpre,fpost) -> + Format.fprintf fmt "@[hoare [%a :@ @[%a ==>@ %a@]]@]" + pp_ec_ident i + (pp_ec_ast_expr) fpre + (pp_ec_ast_expr) fpost + + and pp_ec_op2 fmt (op2, e1, e2) = + let f = match op2 with + | ArrayGet -> Format.fprintf fmt "@[%a.[%a]@]" + | Plus -> Format.fprintf fmt "@[(%a +@ %a)@]" + | Infix s -> (fun pp1 e1 -> Format.fprintf fmt "@[(%a %s@ %a)@]" pp1 e1 s) + in + f pp_ec_ast_expr e1 pp_ec_ast_expr e2 + + and pp_ec_op3 fmt (op, e1, e2, e3) = + let f = match op with + | Ternary -> Format.fprintf fmt "@[(%a ? %a : %a)@]" + | If -> Format.fprintf fmt "@[(if %a then %a else %a)@]" + | InORange -> Format.fprintf fmt "@[(%a <= %a < %a)@]" + in + f pp_ec_ast_expr e1 pp_ec_ast_expr e2 pp_ec_ast_expr e3 + + let pp_ec_lvalue fmt (lval: ec_lvalue) = + match lval with + | LvIdent ident -> pp_ec_ident fmt ident + | LvArrItem (ident, e) -> pp_ec_op2 fmt (ArrayGet, Eident ident, e) + + let pp_ec_lvalues fmt (lvalues: ec_lvalues) = + match lvalues with + | [] -> assert false + | [lv] -> pp_ec_lvalue fmt lv + | _ -> Format.fprintf fmt "@[(%a)@]" (pp_list ",@ " pp_ec_lvalue) lvalues + + let rec pp_ec_ast_stmt fmt stmt = + Format.fprintf fmt "@[%a@]" (pp_list "@ " pp_ec_ast_instr) stmt + + and pp_ec_ast_instr fmt instr = + match instr with + | ESasgn (lv, e) -> + Format.fprintf fmt "@[%a <-@ %a;@]" pp_ec_lvalues lv pp_ec_ast_expr e + | EScall (lvs, f, args) -> + let pp_res fmt lvs = + if lvs = [] then + Format.fprintf fmt "" + else + Format.fprintf fmt "%a <%@ " pp_ec_lvalues lvs + in + Format.fprintf fmt "@[%a%a (%a);@]" + pp_res lvs + pp_ec_ast_expr (Eident f) + (pp_list ",@ " pp_ec_ast_expr) args + | ESsample (lv, e) -> + Format.fprintf fmt "@[%a <$@ %a;@]" pp_ec_lvalues lv pp_ec_ast_expr e + | ESif (e, c1, c2) -> + Format.fprintf fmt "@[if (%a) {@ %a@ } else {@ %a@ }@]" + pp_ec_ast_expr e pp_ec_ast_stmt c1 pp_ec_ast_stmt c2 + | ESwhile (e, c) -> + Format.fprintf fmt "@[while (%a) {@ %a@ }@]" + pp_ec_ast_expr e pp_ec_ast_stmt c + | ESreturn e -> Format.fprintf fmt "@[return %a;@]" pp_ec_ast_expr e + | EScomment s -> Format.fprintf fmt "@[(* %s *)@]" s + + let pp_ec_vdecl fmt (x, ty) = Format.fprintf fmt "%s:%a" x pp_ec_ty ty + + let pp_ec_fun_decl fmt fdecl = + Format.fprintf fmt + "@[proc %s (@[%a@]) : @[%a@]@]" + fdecl.fname + (pp_list ",@ " pp_ec_vdecl) fdecl.args + pp_ec_ty fdecl.rtys + + let pp_ec_fun fmt f = + let pp_decl_s fmt v = Format.fprintf fmt "var %a;" pp_ec_vdecl v in + Format.fprintf fmt + "@[@[%a = {@]@ @[%a@ %a@]@ }@]" + pp_ec_fun_decl f.decl + (pp_list "@ " pp_decl_s) f.locals + pp_ec_ast_stmt f.stmt + + let pp_ec_propostion fmt (n, b, e) = + Format.fprintf fmt "@[%s @[%a@] :@ @[%a@]@]" + n + (pp_list " " pp_string) b + pp_ec_ast_expr e + + let rec pp_ec_tatic_args fmt args = + match args with + | Conti t -> Format.fprintf fmt "@[%a@]" pp_ec_rtactic t + | Seq t -> Format.fprintf fmt "@[; %a@]" pp_ec_rtactic t + | Param a -> Format.fprintf fmt "(@[%a@])" (pp_list " " pp_string) a + | Form f -> Format.fprintf fmt "@[%a@]" pp_ec_propostion f + | Ident i -> Format.fprintf fmt "@[%a@]" pp_ec_ident i + | Pattern s -> Format.fprintf fmt "@[%s@]" s + | Prop s -> Format.fprintf fmt "@[%s@]" s + | Comment s -> Format.fprintf fmt "@[(* %s *)@]" s + + and pp_ec_rtactic fmt t = + Format.fprintf fmt "@[%s @[%a@]@]" t.tname (pp_list " " pp_ec_tatic_args) t.targs + + let pp_ec_tactic fmt t = + Format.fprintf fmt "@[%a@]." pp_ec_rtactic t + + let pp_ec_item fmt it = match it with + | IrequireImport is -> + Format.fprintf fmt "@[require import@ @[%a@].@]" (pp_list "@ " pp_string) is + | Iimport is -> + Format.fprintf fmt "@[import@ @[%a@].@]" (pp_list "@ " pp_string) is + | IfromImport (m, is) -> + Format.fprintf fmt "@[from %s import@ @[%a@].@]" m (pp_list "@ " pp_string) is + | IfromRequireImport (m, is) -> + Format.fprintf fmt "@[from %s require import@ @[%a@].@]" m (pp_list "@ " pp_string) is + | Iabbrev (a, e) -> + Format.fprintf fmt "@[abbrev %s =@ @[%a@].@]" a pp_ec_ast_expr e + | ImoduleType mt -> + Format.fprintf fmt "@[@[module type %s = {@]@ @[%a@]@ }.@]" + mt.name (pp_list "@ " pp_ec_fun_decl) mt.funs + | Imodule m -> + let pp_mp fmt (m, mt) = Format.fprintf fmt "%s:%s" m mt in + Format.fprintf fmt "@[@[module %s@[%a@]%a = {@]@ @[%a%a%a@]@ }.@]" + m.name + (pp_list_paren ",@ " pp_mp) m.params + (pp_option (fun fmt s -> Format.fprintf fmt " : %s" s)) m.ty + (pp_list "@ " (fun fmt (v, t) -> Format.fprintf fmt "@[var %s : %a@]" v pp_ec_ty t)) m.vars + (fun fmt _ -> if m.vars = [] then (Format.fprintf fmt "") else (Format.fprintf fmt "@ ")) () + (pp_list "@ " pp_ec_fun) m.funs + | Icomment s -> Format.fprintf fmt "@[(* %s *)@]" s + | Axiom p -> + Format.fprintf fmt "@[axiom @[%a@].@]" pp_ec_propostion p + | Lemma (p, t) -> + Format.fprintf fmt "@[lemma @[%a@].@]@ @[proof.@]@ @[%a@]" + pp_ec_propostion p + (pp_list "@ "pp_ec_tactic) t + + let pp_ec_prog fmt prog = + Format.fprintf fmt "@[%a@]" (pp_list "@ @ " pp_ec_item) prog; + Format.fprintf fmt "@." + +end + +module Scmp = struct + type t = string + let compare = compare +end + +module Ss = Set.Make(Scmp) +module Ms = Map.Make(Scmp) + +module Tcmp = struct + type t = ty + let compare = compare +end + +module Mty = Map.Make (Tcmp) + +type proofvar = { + assume_ : Ss.elt; + assert_ : Ss.elt; + assert_proof : Ss.elt; + assume_proof : Ss.elt; +} +type ('len) env = { + pd : Wsize.wsize; + model : model; + alls : Ss.t; + vars : string Mv.t; + glob : (string * ty) Ms.t; + funs : (string * (ty list * ty list)) Mf.t; + tmplvs : ('len CoreIdent.gvar list) Mf.t; + ttmplvs : (Ss.elt * Ec.ec_ty) Mf.t; + contra : ('len Prog.gfcontract * 'len CoreIdent.gvar list) Mf.t; + arrsz : Sint.t ref; + warrsz : Sint.t ref; + auxv : string list Mty.t; + randombytes : Sint.t ref; + proofv : proofvar Mf.t ref; + func : funname option; + freturn : Prog.var list; + sign : bool +} (* ------------------------------------------------------------------- *) let add_ptr pd x e = @@ -125,6 +362,7 @@ let add_ptr pd x e = let int_of_word ws e = Papp1 (E.Oint_of_word ws, e) + let rec leaks_e_rec pd leaks e = match e with | Pconst _ | Pbool _ | Parr_init _ |Pvar _ -> leaks @@ -154,196 +392,196 @@ let leaks_lval pd = function (* FIXME: generate this list automatically *) (* Adapted from EasyCrypt source file src/ecLexer.mll *) let ec_keyword = - [ "admit" - ; "admitted" - - ; "forall" - ; "exists" - ; "fun" - ; "glob" - ; "let" - ; "in" - ; "for" - ; "var" - ; "proc" - ; "if" - ; "is" - ; "match" - ; "then" - ; "else" - ; "elif" - ; "match" - ; "for" - ; "while" - ; "assert" - ; "return" - ; "res" - ; "equiv" - ; "hoare" - ; "ehoare" - ; "choare" - ; "cost" - ; "phoare" - ; "islossless" - ; "async" - - ; "try" - ; "first" - ; "last" - ; "do" - ; "strict" - ; "expect" - - (* Lambda tactics *) - ; "beta" - ; "iota" - ; "zeta" - ; "eta" - ; "logic" - ; "delta" - ; "simplify" - ; "cbv" - ; "congr" - - (* Logic tactics *) - ; "change" - ; "split" - ; "left" - ; "right" - ; "case" - - ; "pose" - ; "gen" - ; "have" - ; "suff" - ; "elim" - ; "exlim" - ; "ecall" - ; "clear" - ; "wlog" - - (* Auto tactics *) - ; "apply" - ; "rewrite" - ; "rwnormal" - ; "subst" - ; "progress" - ; "trivial" - ; "auto" - - (* Other tactics *) - ; "idtac" - ; "move" - ; "modpath" - ; "field" - ; "fieldeq" - ; "ring" - ; "ringeq" - ; "algebra" - - ; "exact" - ; "assumption" - ; "smt" - ; "by" - ; "reflexivity" - ; "done" - ; "solve" - - (* PHL: tactics *) - ; "replace" - ; "transitivity" - ; "symmetry" - ; "seq" - ; "wp" - ; "sp" - ; "sim" - ; "skip" - ; "call" - ; "rcondt" - ; "rcondf" - ; "swap" - ; "cfold" - ; "rnd" - ; "rndsem" - ; "pr_bounded" - ; "bypr" - ; "byphoare" - ; "byehoare" - ; "byequiv" - ; "byupto" - ; "fel" - - ; "conseq" - ; "exfalso" - ; "inline" - ; "outline" - ; "interleave" - ; "alias" - ; "weakmem" - ; "fission" - ; "fusion" - ; "unroll" - ; "splitwhile" - ; "kill" - ; "eager" - - ; "axiom" - ; "schema" - ; "axiomatized" - ; "lemma" - ; "realize" - ; "proof" - ; "qed" - ; "abort" - ; "goal" - ; "end" - ; "from" - ; "import" - ; "export" - ; "include" - ; "local" - ; "declare" - ; "hint" - ; "nosmt" - ; "module" - ; "of" - ; "const" - ; "op" - ; "pred" - ; "inductive" - ; "notation" - ; "abbrev" - ; "require" - ; "theory" - ; "abstract" - ; "section" - ; "type" - ; "class" - ; "instance" - ; "instantiate" - ; "print" - ; "search" - ; "locate" - ; "as" - ; "Pr" - ; "clone" - ; "with" - ; "rename" - ; "prover" - ; "timeout" - ; "why3" - ; "dump" - ; "remove" - ; "exit" - - ; "fail" - ; "time" - ; "undo" - ; "debug" - ; "pragma" - - ; "Top" - ; "Self" ] + [ "admit" + ; "admitted" + + ; "forall" + ; "exists" + ; "fun" + ; "glob" + ; "let" + ; "in" + ; "for" + ; "var" + ; "proc" + ; "if" + ; "is" + ; "match" + ; "then" + ; "else" + ; "elif" + ; "match" + ; "for" + ; "while" + ; "assert" + ; "return" + ; "res" + ; "equiv" + ; "hoare" + ; "ehoare" + ; "choare" + ; "cost" + ; "phoare" + ; "islossless" + ; "async" + + ; "try" + ; "first" + ; "last" + ; "do" + ; "strict" + ; "expect" + + (* Lambda tactics *) + ; "beta" + ; "iota" + ; "zeta" + ; "eta" + ; "logic" + ; "delta" + ; "simplify" + ; "cbv" + ; "congr" + + (* Logic tactics *) + ; "change" + ; "split" + ; "left" + ; "right" + ; "case" + + ; "pose" + ; "gen" + ; "have" + ; "suff" + ; "elim" + ; "exlim" + ; "ecall" + ; "clear" + ; "wlog" + + (* Auto tactics *) + ; "apply" + ; "rewrite" + ; "rwnormal" + ; "subst" + ; "progress" + ; "trivial" + ; "auto" + + (* Other tactics *) + ; "idtac" + ; "move" + ; "modpath" + ; "field" + ; "fieldeq" + ; "ring" + ; "ringeq" + ; "algebra" + + ; "exact" + ; "assumption" + ; "smt" + ; "by" + ; "reflexivity" + ; "done" + ; "solve" + + (* PHL: tactics *) + ; "replace" + ; "transitivity" + ; "symmetry" + ; "seq" + ; "wp" + ; "sp" + ; "sim" + ; "skip" + ; "call" + ; "rcondt" + ; "rcondf" + ; "swap" + ; "cfold" + ; "rnd" + ; "rndsem" + ; "pr_bounded" + ; "bypr" + ; "byphoare" + ; "byehoare" + ; "byequiv" + ; "byupto" + ; "fel" + + ; "conseq" + ; "exfalso" + ; "inline" + ; "outline" + ; "interleave" + ; "alias" + ; "weakmem" + ; "fission" + ; "fusion" + ; "unroll" + ; "splitwhile" + ; "kill" + ; "eager" + + ; "axiom" + ; "schema" + ; "axiomatized" + ; "lemma" + ; "realize" + ; "proof" + ; "qed" + ; "abort" + ; "goal" + ; "end" + ; "from" + ; "import" + ; "export" + ; "include" + ; "local" + ; "declare" + ; "hint" + ; "nosmt" + ; "module" + ; "of" + ; "const" + ; "op" + ; "pred" + ; "inductive" + ; "notation" + ; "abbrev" + ; "require" + ; "theory" + ; "abstract" + ; "section" + ; "type" + ; "class" + ; "instance" + ; "instantiate" + ; "print" + ; "search" + ; "locate" + ; "as" + ; "Pr" + ; "clone" + ; "with" + ; "rename" + ; "prover" + ; "timeout" + ; "why3" + ; "dump" + ; "remove" + ; "exit" + + ; "fail" + ; "time" + ; "undo" + ; "debug" + ; "pragma" + + ; "Top" + ; "Self" ] let syscall_mod_arg = "SC" let syscall_mod_sig = "Syscall_t" @@ -369,15 +607,17 @@ let normalize_name n = let mkfunname env fn = fn.fn_name |> normalize_name |> create_name env -let empty_env model fds arrsz warrsz randombytes = +let empty_env pd model fds arrsz warrsz randombytes sign = - let env = { + let env = { + pd; model; alls = keywords; vars = Mv.empty; glob = Ms.empty; funs = Mf.empty; tmplvs = Mf.empty; + ttmplvs = Mf.empty; contra = Mf.empty; arrsz; warrsz; @@ -386,10 +626,10 @@ let empty_env model fds arrsz warrsz randombytes = proofv = ref Mf.empty; func = None; freturn = []; + sign } in - -(* let mk_tys tys = List.map Conv.cty_of_ty tys in *) + (* let mk_tys tys = List.map Conv.cty_of_ty tys in *) let add_fun env fd = let s = mkfunname env fd.f_name in let funs = @@ -401,24 +641,21 @@ let empty_env model fds arrsz warrsz randombytes = let add_fun_contra env fd = let contra = let args = fd.f_args in - let ret = List.map L.unloc fd.f_ret in - Mf.add fd.f_name (fd.f_contra,args, ret) env.contra + Mf.add fd.f_name (fd.f_contra,args) env.contra in { env with contra } in List.fold_left add_fun_contra env fds let get_funtype env f = snd (Mf.find f env.funs) -let get_funcontr env f = Mf.find f env.contra let get_funname env f = fst (Mf.find f env.funs) -let pp_fname env fmt f = Format.fprintf fmt "%s" (get_funname env f) -let pp_syscall env fmt o = +let ec_syscall env o = match o with | Syscall_t.RandomBytes p -> let n = (Conv.int_of_pos p) in env.randombytes := Sint.add n !(env.randombytes); - Format.fprintf fmt "%s.randombytes_%i" syscall_mod_arg n + Format.sprintf "%s.randombytes_%i" syscall_mod_arg n let ty_lval = function | Lnone (_, ty) -> ty @@ -427,35 +664,13 @@ let ty_lval = function | Laset(_, _, ws, _, _) -> Bty (U ws) | Lasub (_,ws, len, _, _) -> Arr(ws, len) -let add_tmp_lv env f lvs = - let tmplvs = Mf.add f lvs env.tmplvs in - {env with tmplvs} - -let add_proofv env f p = - env.proofv := Mf.add f p !(env.proofv) let add_Array env n = env.arrsz := Sint.add n !(env.arrsz) -let pp_Array env fmt n = - add_Array env n; - Format.fprintf fmt "Array%i" n - let add_WArray env n = env.warrsz := Sint.add n !(env.warrsz) -let pp_WArray env fmt n = - add_WArray env n; - Format.fprintf fmt "WArray%i" n - -let pp_ty env fmt ty = - match ty with - | Bty Bool -> Format.fprintf fmt "bool" - | Bty Int -> Format.fprintf fmt "int" - | Bty (U ws) -> pp_sz_t fmt ws - | Arr(ws,n) -> Format.fprintf fmt "%a %a.t" pp_sz_t ws (pp_Array env) n - | Bty Abstract _ -> assert false - let add_aux env tys = let tbl = Hashtbl.create 10 in let do1 env ty = @@ -479,60 +694,19 @@ let get_aux env tys = List.nth l n in List.map do1 tys -let set_var env x option s = +let set_var env x s = { env with alls = Ss.add s env.alls; - vars = Mv.add x (s,option) env.vars } + vars = Mv.add x s env.vars } -let add_var option env x = +let add_var env x = let s = normalize_name x.v_name in let s = create_name env s in - set_var env x option s + set_var env x s let add_glob env x = let s = create_name env (normalize_name x.v_name) in - set_var env x false s - -let pp_oget option pp = - pp_maybe option (pp_enclose ~pre:"(oget " ~post:")") pp - -let pp_var env fmt (x:var) = - pp_string fmt (fst (Mv.find x env.vars)) - -let pp_ovar env fmt (x:var) = - let (s,option) = Mv.find x env.vars in - if option then - let ty = x.v_ty in - if is_ty_arr ty then - let (_ws,n) = array_kind ty in - Format.fprintf fmt "(%a.map oget %s)" (pp_Array env) n s - else pp_oget true pp_string fmt s - else pp_string fmt s - -let pp_zeroext fmt (szi, szo) = - let io, ii = int_of_ws szo, int_of_ws szi in - if ii < io then Format.fprintf fmt "zeroextu%a" pp_size szo - else if ii = io then () - else (* io < ii *) Format.fprintf fmt "truncateu%a" pp_size szo - -let pp_op1 ~sign fmt = function - | E.Oword_of_int sz -> - if sign then - Format.fprintf fmt "%a.of_int" pp_Tsz sz - else - Format.fprintf fmt "%a.of_int" pp_Tsz sz - | E.Oint_of_word sz -> - if sign then - Format.fprintf fmt "%a.to_sint" pp_Tsz sz - else - Format.fprintf fmt "%a.to_uint" pp_Tsz sz - | E.Osignext(szo,_szi) -> - Format.fprintf fmt "sigextu%a" pp_size szo - | E.Ozeroext(szo,szi) -> - pp_zeroext fmt (szi, szo) - | E.Onot -> Format.fprintf fmt "!" - | E.Olnot _ -> Format.fprintf fmt "invw" - | E.Oneg _ -> Format.fprintf fmt "-" + set_var env x s let swap_op2 op e1 e2 = match op with @@ -580,8 +754,6 @@ let pp_op2 fmt = function | Ovlsl(ve,ws) -> pp_vop2 fmt ("shl", ve, ws) | Ovasr(ve,ws) -> pp_vop2 fmt ("sar", ve, ws) -let pp_opa fmt opa = Format.fprintf fmt "%s" opa.name - let in_ty_op1 op = Conv.ty_of_cty (fst (E.type_of_op1 op)) @@ -621,311 +793,731 @@ let check_array env x = | Arr(ws, n) -> Sint.mem n !(env.arrsz) && Sint.mem (arr_size ws n) !(env.warrsz) | _ -> true -let pp_initi env pp fmt (x, n, ws) = - let i = create_name env "i" in - Format.fprintf fmt - "@[(%a.init%i (fun %s => (%a).[%s]))@]" - (pp_WArray env) (arr_size ws n) (int_of_ws ws) i pp x i - -let pp_print_i fmt z = - if Z.leq Z.zero z then Z.pp_print fmt z - else Format.fprintf fmt "(%a)" Z.pp_print z +let ec_vars env (x:var) = Mv.find x env.vars -let pp_access aa = if aa = Warray_.AAdirect then "_direct" else "" +module Exp = struct -let pp_cast env pp fmt (ty,ety,e) = - if ety = ty then pp fmt e - else - match ty with - | Bty _ -> - Format.fprintf fmt "(%a %a)" pp_zeroext (ws_of_ty ety, ws_of_ty ty) pp e - | Arr(ws, n) -> - let wse, ne = array_kind ety in - let i = create_name env "i" in - Format.fprintf fmt - "@[(%a.init@ (fun %s => get%i@ %a@ %s))@]" - (pp_Array env) n - i - (int_of_ws ws) - (pp_initi env pp) (e, ne, wse) - i + open Ec + let ec_ident s = Eident [s] -let rec pp_expr ~sign pd env fmt (e:expr) = - let pp_expr = pp_expr ~sign in - match e with - | Pconst z -> Format.fprintf fmt "%a" pp_print_i z + let ec_vari env (x:var) = Eident [ec_vars env x] + + let ec_aget a i = Eop2(ArrayGet, a, i) + + let ec_int x = Econst (Z.of_int x) + + let glob_mem = ["Glob"; "mem"] + let glob_memi = Eident glob_mem + + let pd_uint env = + if env.sign then + Eident [Format.sprintf "W%d" (int_of_ws env.pd); "to_int"] + else + Eident [Format.sprintf "W%d" (int_of_ws env.pd); "to_uint"] + + let ec_apps1 s e = Eapp (ec_ident s, [e]) + + let iIdent i = ec_ident (Format.sprintf "%i" i) - | Pbool b -> Format.fprintf fmt "%a" pp_bool b + let fmt_Array n = Format.sprintf "Array%i" n - | Parr_init _n -> Format.fprintf fmt "witness" + let fmt_WArray n = Format.sprintf "WArray%i" n - | Pvar x -> - pp_ovar env fmt (L.unloc x.gv) + let ec_Array env n = add_Array env n; fmt_Array n - | Pget(_, aa, ws, x, e) -> - assert (check_array env x.gv); - let pp fmt (x,e) = - let x = x.gv in - let x = L.unloc x in + let ec_WArray env n = add_WArray env n; fmt_WArray n + + let ec_Array_init env len = Eident [ec_Array env len; "init"] + + let ec_WArray_init env ws n = + Eident [ec_WArray env (arr_size ws n); Format.sprintf "init%i" (int_of_ws ws)] + + let ec_WArray_initf env ws n f = + let i = create_name env "i" in + Eapp (ec_WArray_init env ws n, [Equant (Llambda ,[i], f i)]) + + let ec_initi env (x, n, ws) = + let f i = ec_aget x (ec_ident i) in + ec_WArray_initf env ws n f + + let ec_initi_var env (x, n, ws) = ec_initi env (ec_vari env x, n, ws) + + let ec_zeroext (szo, szi) e = + let io, ii = int_of_ws szo, int_of_ws szi in + if ii < io then ec_apps1 (Format.sprintf "zeroextu%i" io) e + else if ii = io then e + else (* io < ii *) ec_apps1 (Format.sprintf "truncateu%i" io) e + + let ec_wzeroext (tyo, tyi) e = + if tyi = tyo then e else ec_zeroext (ws_of_ty tyo, ws_of_ty tyi) e + + let ec_cast env (ty, ety) e = + if ety = ty then e + else + match ty with + | Bty _ -> ec_zeroext (ws_of_ty ty, ws_of_ty ety) e + | Arr(ws, n) -> + let wse, ne = array_kind ety in + let i = create_name env "i" in + let geti = ec_ident (Format.sprintf "get%i" (int_of_ws ws)) in + let init_fun = + Equant (Llambda, [i], Eapp (geti, [ec_initi env (e, ne, wse); ec_ident i])) + in + Eapp (ec_Array_init env n, [init_fun]) + + let ec_op1 op e = match op with + | E.Oword_of_int sz -> + ec_apps1 (Format.sprintf "%s.of_int" (pp_Tsz sz)) e + | E.Oint_of_word sz -> + ec_apps1 (Format.sprintf "%s.to_uint" (pp_Tsz sz)) e + | E.Osignext(szo,_szi) -> + ec_apps1 (Format.sprintf "sigextu%i" (int_of_ws szo)) e + | E.Ozeroext(szo,szi) -> ec_zeroext (szo, szi) e + | E.Onot -> ec_apps1 "!" e + | E.Olnot _ -> ec_apps1 "invw" e + | E.Oneg _ -> ec_apps1 "-" e + + let pp_access aa = if aa = Warray_.AAdirect then "_direct" else "" + + let rec toec_cast env ty e = ec_cast env (ty, ty_expr e) (toec_expr env e) + + and ec_wcast env (ty, e) = toec_cast env ty e + + and toec_expr env (e: expr) = + match e with + | Pconst z -> Econst z + | Pbool b -> Ebool b + | Parr_init _n -> ec_ident "witness" + | Pvar x -> ec_vari env (L.unloc x.gv) + | Pget (a, aa, ws, y, e) -> + assert (check_array env y.gv); + let x = L.unloc y.gv in + let (xws, n) = array_kind x.v_ty in + if ws = xws && aa = Warray_.AAscale then + ec_aget (ec_vari env x) (toec_expr env e) + else + Eapp ( + (ec_ident (Format.sprintf "get%i%s" (int_of_ws ws) (pp_access aa))), + [ec_initi_var env (x, n, xws); toec_expr env e] + ) + | Psub (aa, ws, len, x, e) -> + assert (check_array env x.gv); + let i = create_name env "i" in + let x = L.unloc x.gv in let (xws,n) = array_kind x.v_ty in if ws = xws && aa = Warray_.AAscale then - Format.fprintf fmt "@[%a.[%a]@]" (pp_var env) x (pp_expr pd env) e + Eapp ( + ec_Array_init env len, + [ + Equant (Llambda, [i], + ec_aget (ec_vari env x) (Eop2 (Plus, toec_expr env e, ec_ident i))) + ]) else - Format.fprintf fmt "@[(get%i%s@ %a@ %a)@]" - (int_of_ws ws) - (pp_access aa) - (pp_initi env (pp_var env)) (x, n, xws) (pp_expr pd env) e in - let option = - for_safety env && snd (Mv.find (L.unloc x.gv) env.vars) in - pp_oget option pp fmt (x,e) - - | Psub (aa, ws, len, x, e) -> - assert (check_array env x.gv); - let i = create_name env "i" in - let x = x.gv in - let x = L.unloc x in - let (xws,n) = array_kind x.v_ty in - if ws = xws && aa = Warray_.AAscale then - Format.fprintf fmt "@[(%a.init (fun %s => %a.[%a + %s]))@]" - (pp_Array env) len - i - (pp_var env) x - (pp_expr pd env) e - i - else - Format.fprintf fmt - "@[(%a.init (fun %s => (get%i%s@ %a@ (%a + %s))))@]" - (pp_Array env) len - i - (int_of_ws ws) - (pp_access aa) - (pp_initi env (pp_var env)) (x, n, xws) - (pp_expr pd env) e - i + Eapp ( + ec_Array_init env len, + [ + Equant (Llambda, [i], + Eapp (ec_ident (Format.sprintf "get%i%s" (int_of_ws ws) (pp_access aa)), [ + ec_initi_var env (x, n, xws); Eop2 (Plus, toec_expr env e, ec_ident i) + ]) + ) + ]) + | Pload (_, sz, x, e) -> + let load = ec_ident (Format.sprintf "loadW%i" (int_of_ws sz)) in + Eapp (load, [ + glob_memi; + Eapp (pd_uint env, [ec_wcast env (add_ptr env.pd (gkvar x) e)]) + ]) + | Papp1 (op1, e) -> + ec_op1 op1 (ec_wcast env (in_ty_op1 op1, e)) + | Papp2 (op2, e1, e2) -> + let ty1,ty2 = in_ty_op2 op2 in + let te1, te2 = swap_op2 op2 (ty1, e1) (ty2, e2) in + let op = Infix (Format.asprintf "%a" pp_op2 op2) in + Eop2 (op, (ec_wcast env te1), (ec_wcast env te2)) + | PappN (op, es) -> + begin match op with + | Opack (ws, we) -> + let i = int_of_pe we in + let rec aux es = + match es with + | [] -> assert false + | [e] -> toec_expr env e + | e::es -> + let exp2i = Eop2 (Infix "^", iIdent 2, iIdent i) in + Eop2 ( + Infix "+", + Eop2 (Infix "%%", toec_expr env e, exp2i), + Eop2 (Infix "*", exp2i, aux es) + ) + in + ec_apps1 (Format.sprintf "W%i.of_int" (int_of_ws ws)) (aux (List.rev es)) + | Ocombine_flags c -> + Eapp ( + ec_ident (Printer.string_of_combine_flags c), + List.map (toec_expr env) es + ) + end - - | Pload (_, sz, x, e) -> - Format.fprintf fmt "(loadW%a Glob.mem (W%d.to_uint %a))" - pp_size sz - (int_of_ws pd) - (pp_wcast ~sign pd env) (add_ptr pd (gkvar x) e) - - | Papp1 (op1, e) -> - Format.fprintf fmt "(%a %a)" (pp_op1 ~sign) op1 (pp_wcast ~sign pd env) (in_ty_op1 op1, e) - - | Papp2 (op2, e1, e2) -> - let ty1,ty2 = in_ty_op2 op2 in - let te1, te2 = swap_op2 op2 (ty1, e1) (ty2, e2) in - Format.fprintf fmt "(%a %a %a)" - (pp_wcast ~sign pd env) te1 pp_op2 op2 (pp_wcast ~sign pd env) te2 - - | PappN (op, es) -> - (* FIXME *) - begin match op with - | Opack (ws, we) -> - let i = int_of_pe we in - let rec aux fmt es = - match es with - | [] -> assert false - | [e] -> Format.fprintf fmt "%a" (pp_expr pd env) e - | e::es -> - Format.fprintf fmt "@[(%a %%%% 2^%i +@ 2^%i * %a)@]" - (pp_expr pd env) e i i aux es in - Format.fprintf fmt "(W%a.of_int %a)" pp_size ws aux (List.rev es) - | Ocombine_flags c -> - Format.fprintf fmt "@[(%s@ %a)@]" - (Printer.string_of_combine_flags c) - (pp_list "@ " (pp_expr pd env)) es - end - - | Pabstract (opa, es) -> - Format.fprintf fmt "(@[%a @[%a@]@])" - pp_opa opa - (pp_list "@ " (pp_expr pd env)) es - - | Pif(_,e1,et,ef) -> - let ty = ty_expr e in - Format.fprintf fmt "(%a ? %a : %a)" - (pp_expr pd env) e1 (pp_wcast ~sign pd env) (ty,et) (pp_wcast ~sign pd env) (ty,ef) - - | Pfvar x -> pp_ovar env fmt (L.unloc x) - - | Pbig (a, b, op, v, i, e) -> - let env = add_var false env (L.unloc v) in - Format.fprintf fmt "@[(foldr (fun x acc => x %a acc) %a ((map (fun %a => %a) (iota_ %a %a))))@]" - pp_op2 op - (pp_expr pd env) i - (pp_ovar env) (L.unloc v) - (pp_expr pd env) e - (pp_expr pd env) a - (pp_expr pd env) b - - | Presult (i, x) -> - let ret = env.freturn in - if List.length ret = 1 then - Format.fprintf fmt "res" - else - Format.fprintf fmt "res.`%i" (i+1) + | Pif(_,e1,et,ef) -> + let ty = ty_expr e in + Eop3 ( + Ternary, + toec_expr env e1, + ec_wcast env (ty, et), + ec_wcast env (ty, ef) + ) + + | Pabstract (opa, es) -> + Eapp (ec_ident opa.name, List.map (toec_expr env) es) + + | Pfvar x -> ec_vari env (L.unloc x) + + | Pbig (a, b, op, v, i, e) -> + let v = L.unloc v in + let env = add_var env v in + let op = Infix (Format.asprintf "%a" pp_op2 op) in + let acc = "acc" and x = "x" in + let expr = Eop2 (op, Eident [x], Eident [acc]) in + let lambda1 = Equant (Llambda, [acc], expr) in + let lambda1 = Equant (Llambda, [x], lambda1) in + let i = toec_expr env i in + let a = toec_expr env a in + let b = toec_expr env b in + let e = toec_expr env e in + let lambda2 = Equant(Llambda, [ec_vars env v],e) in + let iota = Eapp (ec_ident "iota_", [a; b]) in + let map = Eapp (ec_ident "map", [lambda2;iota]) in + Eapp (ec_ident "foldr", [lambda1;i; map]) + + | Presult (i, x) -> + let rt = Eident ["res"] in + let rt = + match env.model with + | Annotations -> Eproj (rt,1) + | _ -> rt + in + let ret = env.freturn in + if List.length ret = 1 then + rt + else + Eproj (rt,i+1) - | Presultget (_, aa, ws, i, x, e) -> - assert (check_array env x.gv); - let x = L.unloc x.gv in - let ret = env.freturn in - let (xws,n) = array_kind x.v_ty in - if ws = xws && aa = Warray_.AAscale then - begin - if List.length ret = 1 then - Format.fprintf fmt "@[res.[%a]@]" (pp_expr pd env) e - else - Format.fprintf fmt "@[res.`%i.[%a]@]" (i+1) (pp_expr pd env) e - end - else - assert false + | Presultget (_, aa, ws, i, x, e) -> + assert (check_array env x.gv); + let x = L.unloc x.gv in + let (xws,n) = array_kind x.v_ty in + if ws = xws && aa = Warray_.AAscale then + begin + let rt = Eident ["res"] in + let rt = + match env.model with + | Annotations -> Eproj (rt,1) + | _ -> rt + in + let ret = env.freturn in + let e = toec_expr env e in + if List.length ret = 1 then + ec_aget rt e + else + ec_aget (Eproj(rt, i+1)) e + end + else + assert false + +end -and pp_wcast ~sign pd env fmt (ty, e) = - pp_cast env (pp_expr ~sign pd env) fmt (ty, ty_expr e, e) +open Ec +open Exp -let pp_vdecl env fmt x = - Format.fprintf fmt "%a:%a" - (pp_var env) x - (pp_ty env) x.v_ty - -let pp_params env fmt params = - Format.fprintf fmt "@[%a@]" - (pp_list ",@ " (pp_vdecl env)) params - -let pp_locals env fmt locals = - let locarr = - List.filter (fun x -> match x.v_ty with Arr _ -> true | _ -> false) - locals in - let locarr = - List.sort (fun x1 x2 -> compare x1.v_name x2.v_name) locarr in - - let pp_vdecl = pp_vdecl env in - let pp_loc fmt x = Format.fprintf fmt "var %a;" pp_vdecl x in - - let pp_init fmt x = - Format.fprintf fmt "%a <- witness;" (pp_var env) x in - Format.fprintf fmt "%a@ %a" - (pp_list "@ " pp_loc) locals - (pp_list "@ " pp_init) locarr - -let pp_rty env fmt tys = - if tys = [] then - Format.fprintf fmt "unit" - else - Format.fprintf fmt "@[%a@]" - (pp_list " *@ " (pp_ty env)) tys +let base_op = function + | Sopn.Oasm (Arch_extra.BaseOp (_, o)) -> Sopn.Oasm (Arch_extra.BaseOp(None,o)) + | o -> o + +let all_vars lvs = + let is_lvar = function Lvar _ -> true | _ -> false in + List.for_all is_lvar lvs -let pp_ret env fmt xs = - Format.fprintf fmt "@[return (%a);@]" - (pp_list ",@ " (fun fmt x -> pp_ovar env fmt (L.unloc x))) xs +let check_lvals lvs = all_vars lvs -let pp_lval1 ~sign pd env pp_e fmt (lv, (ety, e)) = - let pp_expr = pp_expr ~sign in - let lty = ty_lval lv in - let pp_e fmt e = pp_e fmt (lty, ety, e) in +let ec_lval env = function + | Lnone _ -> assert false + | Lmem _ -> assert false + | Lvar x -> LvIdent [ec_vars env (L.unloc x)] + | Laset _ -> assert false + | Lasub _ -> assert false + +let ec_lvals env xs = List.map (ec_lval env) xs + +let toec_lval1 env lv e = match lv with | Lnone _ -> assert false | Lmem(_, ws, x, e1) -> - if sign then - assert false - else - Format.fprintf fmt "@[Glob.mem <-@ storeW%a Glob.mem (W%d.to_uint %a) (%a);@]" pp_size ws - (int_of_ws pd) - (pp_wcast ~sign pd env) (add_ptr pd (gkvar x) e1) pp_e e - | Lvar x -> - Format.fprintf fmt "@[%a <-@ %a;@]" (pp_var env) (L.unloc x) pp_e e + let storewi = ec_ident (Format.sprintf "storeW%i" (int_of_ws ws)) in + let addr = + Eapp (pd_uint env, [ec_wcast env (add_ptr env.pd (gkvar x) e1)]) + in + ESasgn ([LvIdent glob_mem], Eapp (storewi, [glob_memi; addr; e])) + | Lvar x -> + let lvid = [ec_vars env (L.unloc x)] in + ESasgn ([LvIdent lvid], e) | Laset (_, aa, ws, x, e1) -> assert (check_array env x); let x = L.unloc x in let (xws,n) = array_kind x.v_ty in if ws = xws && aa = Warray_.AAscale then - Format.fprintf fmt "@[%a.[%a] <-@ %a;@]" - (pp_var env) x (pp_expr pd env) e1 pp_e e + ESasgn ([LvArrItem ([ec_vars env x], toec_expr env e1)], e) else let nws = n * int_of_ws xws in - let nws8 = nws / 8 in - Format.fprintf fmt - "@[%a <-@ @[%a.init@ (%a.get%i (%a.set%i%s %a %a (%a)));@]@]" - (pp_var env) x - (pp_Array env) n - (pp_WArray env) nws8 - (int_of_ws xws) - (pp_WArray env) nws8 (int_of_ws ws) - (pp_access aa) - (pp_initi env (pp_var env)) (x, n, xws) (pp_expr pd env) e1 pp_e e + let warray = ec_WArray env (nws / 8) in + let waget = Eident [warray; Format.sprintf "get%i" (int_of_ws xws)] in + let wsi = int_of_ws ws in + let waset = Eident [warray; Format.sprintf "set%i%s" wsi (pp_access aa)] in + let updwa = + Eapp (waset, [ec_initi_var env (x, n, xws); toec_expr env e1; e]) + in + ESasgn ( + [LvIdent [ec_vars env x]], + Eapp (ec_Array_init env n, [Eapp (waget, [updwa])]) + ) | Lasub (aa, ws, len, x, e1) -> assert (check_array env x); let x = L.unloc x in let (xws, n) = array_kind x.v_ty in if ws = xws && aa = Warray_.AAscale then let i = create_name env "i" in - Format.fprintf fmt - "@[%a <- @[%a.init@ @[(fun %s => if %a <= %s < %a + %i@ then %a.[%s-%a]@ else %a.[%s]);@]@]@]" - (pp_var env) x - (pp_Array env) n - i - (pp_expr pd env) e1 - i - (pp_expr pd env) e1 len - pp_e e - i - (pp_expr pd env) e1 - (pp_var env) x - i + let range_ub = Eop2 (Plus, toec_expr env e1, ec_int len) in + ESasgn ( + [LvIdent [ec_vars env x]], + Eapp (ec_Array_init env n, [ + Equant (Llambda, [i], Eop3 ( + If, + Eop3 (InORange, toec_expr env e1, ec_ident i, range_ub), + ec_aget e (Eop2 (Infix "-", ec_ident i, toec_expr env e1)), + ec_aget (ec_vari env x) (ec_ident i) + )) + ]) + ) else let nws = n * int_of_ws xws in let nws8 = nws / 8 in - let pp_start fmt () = + let start = if aa = Warray_.AAscale then - Format.fprintf fmt "(%i * %a)" (int_of_ws ws / 8) (pp_expr pd env) e1 + Eop2 (Infix "*", ec_int (int_of_ws ws / 8), toec_expr env e1) else - Format.fprintf fmt "%a" (pp_expr pd env) e1 in + toec_expr env e1 + in let len8 = len * int_of_ws ws / 8 in - let pp_a fmt () = - let i = create_name env "i" in - Format.fprintf fmt - "@[(%a.init8@ (fun %s =>@ if %a <= %s < %a + %i@ then %a.get8 %a (%s - %a)@ else %a.get8 %a %s))@]" - (pp_WArray env) nws8 - i - pp_start () i pp_start () len8 - (pp_WArray env) len8 (pp_initi env pp_e) (e, len, ws) i pp_start () - (pp_WArray env) nws8 (pp_initi env (pp_var env)) (x,n,xws) i - - in - - Format.fprintf fmt "@[%a <- @[%a.init@ @[(%a.get%i %a);@]" - (pp_var env) x - (pp_Array env) n - (pp_WArray env) nws8 (int_of_ws xws) - pp_a () - -let pp_lval env fmt = function - | Lnone _ -> assert false - | Lmem _ -> assert false - | Lvar x -> pp_var env fmt (L.unloc x) - | Laset _ -> assert false - | Lasub _ -> assert false + let i = create_name env "i" in + let in_range = + Eop3 (InORange, start, ec_ident i, Eop2 (Plus, start, ec_int len8)) + in + let ainit = Eident [ec_WArray env nws8; "init8"] in + let aw_get8 len = Eident [ec_WArray env len; "get8"] in + let at = + Eapp (aw_get8 len8, + [ec_initi env (e, len, ws); Eop2 (Infix "-", + ec_ident i, + start)]) + in + let ae = + Eapp (aw_get8 nws8, [ec_initi_var env (x, n, xws); ec_ident i]) + in + let a = Eapp (ainit, [Equant (Llambda, [i], Eop3 (If, in_range, at, ae))]) in + let wag = Eident [ec_WArray env nws8; Format.sprintf "get%i" (int_of_ws xws)] in + ESasgn ( + [LvIdent [ec_vars env x]], + Eapp (ec_Array_init env n, [Eapp (wag, [a])]) + ) + +let toec_ty ty = match ty with + | Bty Bool -> "bool" + | Bty Int -> "int" + | Bty (U ws) -> (pp_sz_t ws) + | Bty (Abstract s) -> s + | Arr(ws,n) -> Format.sprintf "%s %s.t" (pp_sz_t ws) (fmt_Array n) + +module Annotations = struct + + let fand a b = Eop2 (Infix "/\\", a, b) + + let ec_assert env e = + let f = Option.get env.func in + let p = Mf.find f !(env.proofv) in + let e = toec_expr env e in + let e1 = Eop2 (Infix "/\\", Eident [p.assert_], Eident [p.assume_]) in + let e2 = Eop2 (Infix "=>", e1, e) in + let e3 = Eop2 (Infix "/\\" , Eident [p.assert_proof], e2) in + let i1 = ESasgn ([LvIdent ([p.assert_proof])], e3) in + let e1 = Eop2 (Infix "/\\", Eident [p.assert_], e) in + let i2 = ESasgn ([LvIdent ([p.assert_])],e1) in + [i1;i2] + + let ec_assume env e = + let f = Option.get env.func in + let p = Mf.find f !(env.proofv) in + let e = toec_expr env e in + let e1 = Eop2 (Infix "/\\", Eident [p.assert_], Eident [p.assume_]) in + let e2 = Eop2 (Infix "=>", e1, e) in + let e3 = Eop2 (Infix "/\\" , Eident [p.assume_proof], e2) in + let i1 = ESasgn ([LvIdent ([p.assume_proof])], e3) in + let e1 = Eop2 (Infix "/\\", Eident [p.assume_], e) in + let i2 = ESasgn ([LvIdent ([p.assume_])],e1) in + [i1;i2] -let pp_lvals env fmt xs = - match xs with - | [] -> assert false - | [x] -> pp_lval env fmt x - | _ -> Format.fprintf fmt "(%a)" (pp_list ",@ " (pp_lval env)) xs + let sub_fun_param args params = + let aux f = + List.map (fun (prover,clause) -> prover, f clause) + in + let check v vi= + (L.unloc v.gv).v_name = vi.v_name && (L.unloc v.gv).v_id = vi.v_id + in + let aux1 v = + match List.findi (fun _ vi -> check v vi) args with + | i,_ -> let _,e = List.findi (fun ii _ -> ii = i) params in + e + | exception _ -> Pvar v + in + aux (Subst.gsubst_e (fun ?loc:_ x -> x) aux1) -let pp_aux_lvs fmt aux = - match aux with - | [] -> assert false - | [x] -> Format.fprintf fmt "%s" x - | xs -> Format.fprintf fmt "(%a)" (pp_list ",@ " pp_string) xs + let sub_fun_return r = + let aux f = List.map (fun (prover,clause) -> prover, f clause) in + let aux1 i v = + let _,v = List.findi (fun ii _ -> ii = i) r in + {gv = L.mk_loc L._dummy v; gs = Expr.Slocal} + in + aux (Subst.subst_result aux1) -let pp_wzeroext pp_e fmt tyo tyi e = - if tyi = tyo then pp_e fmt e - else - let szi, szo = ws_of_ty tyi, ws_of_ty tyo in - Format.fprintf fmt "%a(%a)" pp_zeroext (szi, szo) pp_e e + + let toec_fun env lvs f es = + let otys, itys = get_funtype env f in + let args = List.map (ec_wcast env) (List.combine itys es) in + + let tmps = Mf.find f env.tmplvs in + let ttmpt,_ = Mf.find f env.ttmplvs in + let (contr,formals) = Mf.find f env.contra in + + let lvs2 = List.map (fun v -> Lvar (L.mk_loc L._dummy v)) tmps in + + let elvs2 = + List.map (fun v -> + Pvar({gv = L.mk_loc L._dummy v; gs = Expr.Slocal}) + ) tmps + in + + (* let pre = Annotations.sub_fun_param formals es contr.f_pre in *) + (* let pre = List.map (fun (_,e) -> e) pre in *) + let post = sub_fun_return tmps contr.f_post in + let post = sub_fun_param formals es post in + let post = List.map (fun (_,e) -> e) post in + + (* let i = List.fold (fun acc pre -> Annotations.ec_assert env pre @ acc ) [] pre in *) + + let i = (* i @ *) + [EScall ([LvIdent [ttmpt] ; LvIdent ["tmp__check"]], [get_funname env f], args)] + in + let i = i @ [ESasgn( ec_lvals env lvs2, Eident [ttmpt])] in + let current_f = Option.get env.func in + let p = Mf.find current_f !(env.proofv) in + let ilvs = + [LvIdent [p.assume_]; + LvIdent [p.assert_]; + LvIdent [p.assume_proof]; + LvIdent [p.assert_proof]] + in + let params = + [Etuple ([Eident [p.assume_]; + Eident [p.assert_]; + Eident [p.assume_proof]; + Eident [p.assert_proof]]); + Eident["tmp__check"]] + in + let i = i @ [ESasgn (ilvs, Eapp (Eident ["upd_call"],params))] in + let i = List.fold_left (fun acc post -> acc @ ec_assert env post ) i post in + List.fold_left2 + (fun acc lv e -> + let e = toec_cast env (ty_lval lv) e in + acc @ [toec_lval1 env lv e]) + i lvs elvs2 + + let contract env c = + let c = List.map (fun (_,x) -> x) c in + if List.is_empty c then + Ebool true + else + let c = List.map (toec_expr env) c in + List.fold_left (fun acc a -> Eop2 (Infix "/\\", a, acc) ) (List.hd c) (List.tl c) + + let var_eq env vars1 vars2 = + let vars = List.map2 (fun a b -> (a,b)) vars1 vars2 in + if List.is_empty vars then + Ebool true + else + let eq (var1,var2) = + Eop2 (Infix "=", ec_ident var1, ec_ident var2.v_name) + in + List.fold_left + (fun acc a -> Eop2 (Infix "/\\", eq a, acc)) + (eq (List.hd vars)) + (List.tl vars) + + let mk_old_param env params = + List.fold_left (fun (env,acc) v -> + let s = String.uncapitalize_ascii v.v_name in + let s = "_" ^ s in + let s = create_name env s in + let env = set_var env v s in + env, s :: acc + ) (env,[]) (List.rev params) + + let res = Eident ["res"] + + let pp_assert env f = + let fname = get_funname env f.f_name in + let freturn = List.map (fun x -> L.unloc x) f.f_ret in + let env = {env with freturn} in + let env1, vars = mk_old_param env f.f_args in + let env = List.fold_left add_var env f.f_args in + + let f1 = var_eq env vars f.f_args in + let f2 = contract env f.f_contra.f_pre in + let pre = fand f1 f2 in + + let post = Eapp(Eident ["_assert_spec"], [res;contract env1 f.f_contra.f_post]) in + + let name = Format.asprintf "%s_assert" fname in + + Axiom (name, vars, EHoare (["M"; fname], pre, post)) + + let pp_assume env f = + let fname = get_funname env f.f_name in + + let pre = Ebool true in + + let post = Eapp(Eident ["assume_proof_"], [res]) in + + let name = Format.asprintf "%s_assume" fname in + + let tactic = { + tname = "admitted"; + targs = [Comment "TODO"]; + } + in + + Lemma ((name, [], EHoare (["M";fname], pre, post)),[tactic]) + + let pp_assert_assume env f = + let fname = get_funname env f.f_name in + + let pre = Ebool true in + + let post = Eapp(Eident ["soundness_"], [res]) in + + let name = Format.asprintf "%s_assert_assume_sound" fname in + + let tactic = { + tname = "admitted"; + targs = [Comment "TODO"]; + } + in + + Lemma ((name, [], EHoare (["M"; fname], pre, post)),[tactic]) + + + let pp_spec env f = + let fname = get_funname env f.f_name in + let freturn = List.map (fun x -> L.unloc x) f.f_ret in + let env = {env with freturn} in + let env1,vars = mk_old_param env f.f_args in + + let env = List.fold_left add_var env f.f_args in + + let f1 = var_eq env vars f.f_args in + let f2 = contract env f.f_contra.f_pre in + let pre = fand f1 f2 in + + let post = contract env1 f.f_contra.f_post in + + let name = Format.asprintf "%s_spec" fname in + + let form = Equant (Lforall, vars, EHoare (["M";fname], pre, post)) in + let prop = (name, [], form) in + + + let intros = List.map (fun x -> Ident [x]) vars in + + let tactic1 = { + tname = "move"; + targs = Pattern "=>":: intros; + } + in + + let f1 = var_eq env vars f.f_args in + let f2 = contract env f.f_contra.f_pre in + let pre = fand f1 f2 in + + let post = Eapp(Eident ["_spec_soundness"], [res;contract env1 f.f_contra.f_post]) in + + let have = "h", [], EHoare (["M";fname], pre, post) in + let tactic2 = { + tname = "have"; + targs = [Form have] + } + in + + let name1 = Format.asprintf "%s_assume" fname in + let name2 = Format.asprintf "%s_assert" fname in + + let tactic3 = { + tname ="conseq"; + targs = [Prop name1; Param (name2 :: vars)] + } + in + + let tactic4 = { + tname = "by"; + targs = [Conti tactic3] + } + in + + let tactic5 ={ + tname = "smt"; + targs = [Param []] + } + in + + let name = Format.asprintf "%s_assert_assume_sound" fname in + + let tactic6 = { + tname ="conseq"; + targs = [Prop "h"; Prop name; Pattern "=>"; Pattern "//"; Seq tactic5] + } + in + + let tactic7 = { + tname ="qed"; + targs = [] + } + in + + Lemma (prop, [tactic1;tactic2;tactic4;tactic6;tactic7]) + + let proof env funcs = + let p1 = List.map (pp_assume env) funcs in + let p2 = List.map (pp_assert_assume env) funcs in + let p3 = List.map (pp_assert env) funcs in + let p4 = List.map (pp_spec env) funcs in + let c1 = Icomment "All assume are valid." in + let c2 = Icomment "Soundness of assert/assume." in + let c3 = Icomment "Lemmas proved by cryptoline." in + let c4 = Icomment "Final specification for the functions." in + (c1 :: p1) @ (c2 :: p2) @ (c3 :: p3) @ (c4 :: p4) + + let add_proofv env f p = + env.proofv := Mf.add f p !(env.proofv) + + let get_funcontr env f = Mf.find f env.contra + + let ec_tmp_lvs env f = + let fn = f.f_name in + let otys, itys = get_funtype env fn in + let env,tmps = + List.fold_left_map (fun env ty -> + let name = "tmp__" ^ fn.fn_name in + let s = normalize_name name in + let s = create_name env s in + let v = CoreIdent.GV.mk s (Wsize.Stack Direct) ty L._dummy [] in + let env = + { env with + alls = Ss.add s env.alls; + vars = Mv.add v s env.vars + } + in + env, v + ) env otys + in + let env = {env with tmplvs = Mf.add fn tmps env.tmplvs} in + let tmps = List.map (fun x -> x.v_name, Base (toec_ty x.v_ty)) tmps in + + let name = "tmp__data_" ^ fn.fn_name in + let s = normalize_name name in + let s = create_name env s in + let env = + { env with + alls = Ss.add s env.alls; + } + in + let tmp = + (s, Tuple(List.map (fun x -> Base (toec_ty x)) f.f_tyout)) + in + let env = {env with ttmplvs = Mf.add fn tmp env.ttmplvs} in + + let tmps = + (s, Tuple(List.map (fun x -> Base (toec_ty x)) f.f_tyout)) :: tmps + in + + env,tmps + + let ec_vars env f = + let fname = get_funname env f.f_name in + let assume_ = create_name env ("assume_" ^ fname) in + let assert_ = create_name env ("assert_" ^ fname) in + let assume_proof = create_name env ("assume_proof_" ^ fname) in + let assert_proof = create_name env ("assert_proof_" ^ fname) in + + let proofv = {assume_; assert_; assume_proof; assert_proof} in + + add_proofv env f.f_name proofv; + + let freturn = List.map (fun x -> L.unloc x) f.f_ret in + let env = { env with func = Some f.f_name ; freturn} in + let vars = + [assume_,Base "bool"; + assert_,Base "bool"; + assume_proof, Base "bool"; + assert_proof, Base "bool"] + in + env, vars + + let proof_var_init env f = + let proofv = Mf.find f.f_name !(env.proofv) in + let pre = contract env f.f_contra.f_pre in + + [ESasgn ([LvIdent [proofv.assume_]], Ebool true); + ESasgn ([LvIdent [proofv.assert_]], pre); + ESasgn ([LvIdent [proofv.assume_proof]], Ebool true); + ESasgn ([LvIdent [proofv.assert_proof]], Eident [proofv.assert_])] + + let check_vars env f = + let proofv = Mf.find f.f_name !(env.proofv) in + let l = + [Eident [proofv.assume_]; + Eident [proofv.assert_]; + Eident [proofv.assume_proof]; + Eident [proofv.assert_proof]] + in + Etuple l + + let import = [IrequireImport ["Jcheck"]] + + let trans annot = + let l = + ["t", true ; "f", false] + in + let mk_trans = Annot.filter_string_list None l in + let atran annot = + match Annot.ensure_uniq1 "signed" mk_trans annot with + | None -> false + | Some s -> s + in + atran annot + + let sign env f = + let sign = trans f.f_annot.f_user_annot in + {env with sign} + +end let base_op = function | Sopn.Oasm (Arch_extra.BaseOp (_, o)) -> Sopn.Oasm (Arch_extra.BaseOp(None,o)) @@ -988,884 +1580,407 @@ let rec remove_for_i i = { i with i_desc } and remove_for c = List.map remove_for_i c -let pp_opn pd asmOp fmt o = +let ec_opn pd asmOp o = let s = Format.asprintf "%a" (pp_opn pd asmOp) o in - let s = if Ss.mem s keywords then s^"_" else s in - Format.fprintf fmt "%s" s + if Ss.mem s keywords then s^"_" else s -module Normal = struct +let ec_lval env = function + | Lnone _ -> assert false + | Lmem _ -> assert false + | Lvar x -> LvIdent [ec_vars env (L.unloc x)] + | Laset _ -> assert false + | Lasub _ -> assert false - let all_vars lvs = +let ec_lvals env xs = List.map (ec_lval env) xs + +let toec_lval1 env lv e = + match lv with + | Lnone _ -> assert false + | Lmem(_, ws, x, e1) -> + let storewi = ec_ident (Format.sprintf "storeW%i" (int_of_ws ws)) in + let addr = Eapp (pd_uint env, [ec_wcast env (add_ptr env.pd (gkvar x) e1)]) in + ESasgn ([LvIdent glob_mem], Eapp (storewi, [glob_memi; addr; e])) + | Lvar x -> + let lvid = [ec_vars env (L.unloc x)] in + ESasgn ([LvIdent lvid], e) + | Laset (_, aa, ws, x, e1) -> + assert (check_array env x); + let x = L.unloc x in + let (xws,n) = array_kind x.v_ty in + if ws = xws && aa = Warray_.AAscale then + ESasgn ([LvArrItem ([ec_vars env x], toec_expr env e1)], e) + else + let nws = n * int_of_ws xws in + let warray = ec_WArray env (nws / 8) in + let waget = Eident [warray; Format.sprintf "get%i" (int_of_ws xws)] in + let wsi = int_of_ws ws in + let waset = Eident [warray; Format.sprintf "set%i%s" wsi (pp_access aa)] in + let updwa = Eapp (waset, [ec_initi_var env (x, n, xws); toec_expr env e1; e]) in + ESasgn ( + [LvIdent [ec_vars env x]], + Eapp (ec_Array_init env n, [Eapp (waget, [updwa])]) + ) + | Lasub (aa, ws, len, x, e1) -> + assert (check_array env x); + let x = L.unloc x in + let (xws, n) = array_kind x.v_ty in + if ws = xws && aa = Warray_.AAscale then + let i = create_name env "i" in + let range_ub = Eop2 (Plus, toec_expr env e1, ec_int len) in + ESasgn ( + [LvIdent [ec_vars env x]], + Eapp (ec_Array_init env n, [ + Equant (Llambda, [i], Eop3 ( + If, + Eop3 (InORange, toec_expr env e1, ec_ident i, range_ub), + ec_aget e (Eop2 (Infix "-", ec_ident i, toec_expr env e1)), + ec_aget (ec_vari env x) (ec_ident i) + )) + ]) + ) + else + let nws = n * int_of_ws xws in + let nws8 = nws / 8 in + let start = + if aa = Warray_.AAscale then + Eop2 (Infix "*", ec_int (int_of_ws ws / 8), toec_expr env e1) + else + toec_expr env e1 + in + let len8 = len * int_of_ws ws / 8 in + let i = create_name env "i" in + let in_range = Eop3 (InORange, start, ec_ident i, Eop2 (Plus, start, ec_int len8)) in + let ainit = Eident [ec_WArray env nws8; "init8"] in + let aw_get8 len = Eident [ec_WArray env len; "get8"] in + let at = Eapp (aw_get8 len8, [ec_initi env (e, len, ws); Eop2 (Infix "-", ec_ident i, start)]) in + let ae = Eapp (aw_get8 nws8, [ec_initi_var env (x, n, xws); ec_ident i]) in + let a = Eapp (ainit, [Equant (Llambda, [i], Eop3 (If, in_range, at, ae))]) in + let wag = Eident [ec_WArray env nws8; Format.sprintf "get%i" (int_of_ws xws)] in + ESasgn ( + [LvIdent [ec_vars env x]], + Eapp (ec_Array_init env n, [Eapp (wag, [a])]) + ) + +(* =================----------=============== *) +let all_vars lvs = let is_lvar = function Lvar _ -> true | _ -> false in List.for_all is_lvar lvs - let check_lvals lvs = - all_vars lvs - - let rec init_aux_i ~sign pd asmOp env i = - let init_aux = init_aux ~sign in - match i.i_desc with - | Cassgn _ | Cassert _ -> env - | Cif(_, c1, c2) - | Cwhile(_, c1, _, c2) -> - init_aux pd asmOp (init_aux pd asmOp env c1) c2 - | Cfor(_,_,c) -> init_aux pd asmOp (add_aux env [tint]) c - | Copn (lvs, _, op, _) -> - if List.length lvs = 1 then env - else - let tys = List.map Conv.ty_of_cty (Sopn.sopn_tout Build_Tabstract pd asmOp op) in - let ltys = List.map ty_lval lvs in - if all_vars lvs && ltys = tys then env - else add_aux env tys - | Ccall(lvs, f, _) -> - if lvs = [] then env - else - let tys = (*List.map Conv.ty_of_cty *)(fst (get_funtype env f)) in - let ltys = List.map ty_lval lvs in - if (check_lvals lvs && ltys = tys) then env - else add_aux env tys - | Csyscall(lvs, o, _) -> - if lvs = [] then env - else - let tys = List.map Conv.ty_of_cty (Syscall.syscall_sig_u o).scs_tout in - let ltys = List.map ty_lval lvs in - if (check_lvals lvs && ltys = tys) then env - else add_aux env tys - - and init_aux ~sign pd asmOp env c = List.fold_left (init_aux_i ~sign pd asmOp) env c - - let pp_assgn_i ~sign pd env fmt lv ((etyo, etyi), aux) = - let pp_e fmt aux = - pp_wzeroext pp_string fmt etyo etyi aux in - Format.fprintf fmt "@ %a" (pp_lval1 ~sign pd env (pp_cast env pp_e)) (lv, (etyo,aux)) - - - let pp_call ~sign pd env fmt lvs etyso etysi pp a = - let ltys = List.map (fun lv -> ty_lval lv) lvs in - if check_lvals lvs && ltys = etyso && etyso = etysi then - Format.fprintf fmt "@[%a %a;@]" (pp_lvals env) lvs pp a - else - let auxs = get_aux env etysi in - Format.fprintf fmt "@[%a %a;@]" pp_aux_lvs auxs pp a; - let tyauxs = List.combine (List.combine etyso etysi) auxs in - List.iter2 (pp_assgn_i ~sign pd env fmt) lvs tyauxs - - let pp_assume ~sign pd env p fmt e = - Format.fprintf fmt "@[%s <- @[%s /\\@ ((%s /\\ %s)@ => %a)@];@]@ " - p.assume_proof p.assume_proof p.assert_ p.assume_ - (pp_expr ~sign pd env) e; - Format.fprintf fmt "@[%s <- %s /\\ %a;@]" - p.assume_ p.assume_ - (pp_expr ~sign pd env) e - - let pp_assert ~sign pd env p fmt e = - Format.fprintf fmt "@[%s <- @[%s /\\@ ((%s /\\ %s)@ => %a)@];@]@ " - p.assert_proof p.assert_proof p.assert_ p.assume_ - (pp_expr ~sign pd env) e; - Format.fprintf fmt "@[%s <- %s /\\ %a;@]" - p.assert_ p.assert_ - (pp_expr ~sign pd env) e - - let mk_old_param env params = - List.fold_left (fun (env,acc) v -> - let s = String.uncapitalize_ascii v.v_name in - let s = "_" ^ s in - let s = create_name env s in - let env = set_var env v false s in - env, s :: acc - ) (env,[]) (List.rev params) - - let sub_fun_param args params = - let aux f = - List.map (fun (prover,clause) -> prover, f clause) - in - let check v vi= - (L.unloc v.gv).v_name = vi.v_name && (L.unloc v.gv).v_id = vi.v_id - in - let aux1 v = - match List.findi (fun _ vi -> check v vi) args with - | i,_ -> let _,e = List.findi (fun ii _ -> ii = i) params in - e - | exception _ -> Pvar v - in - aux (Subst.gsubst_e (fun ?loc:_ x -> x) aux1) - - let sub_fun_return r = - let aux f = List.map (fun (prover,clause) -> prover, f clause) in - let aux1 i v = - let _,v = List.findi (fun ii _ -> ii = i) r in - {gv = L.mk_loc L._dummy v; gs = Expr.Slocal} - in - aux (Subst.subst_result aux1) - - - let rec pp_cmd ~sign pd asmOp env fmt c = - Format.fprintf fmt "@[%a@]" (pp_list "@ " (pp_instr ~sign pd asmOp env)) c - - and pp_instr ~sign pd asmOp env fmt i = - let pp_expr = pp_expr ~sign in - match i.i_desc with - | Cassgn(v, _, _, Parr_init _) -> - let pp_e fmt _ = Format.fprintf fmt "witness" in - pp_lval1 ~sign pd env pp_e fmt (v, ((), ())) - - | Cassgn (lv, _, _ty, e) -> - let pp_e = pp_cast env (pp_expr pd env) in - pp_lval1 ~sign pd env pp_e fmt (lv , (ty_expr e, e)) - - | Copn([], _, op, _es) -> - (* Erase opn without any return values *) - Format.fprintf fmt "(* Erased call to %a *)" (pp_opn pd asmOp) op - - | Copn(lvs, _, op, es) -> - let op' = base_op op in - (* Since we do not have merge for the moment only the output type can change *) - let otys,itys = ty_sopn pd asmOp op es in - let otys', _ = ty_sopn pd asmOp op' es in - let pp_e fmt (op,es) = - Format.fprintf fmt "%a %a" (pp_opn pd asmOp) op - (pp_list "@ " (pp_wcast ~sign pd env)) (List.combine itys es) in - if List.length lvs = 1 then - let pp_e fmt (op, es) = - pp_wzeroext pp_e fmt (List.hd otys) (List.hd otys') (op, es) in - let pp_e = pp_cast env pp_e in - pp_lval1 ~sign pd env pp_e fmt (List.hd lvs , (List.hd otys, (op',es))) - else - let pp fmt (op, es) = - Format.fprintf fmt "<- %a" pp_e (op,es) in - pp_call ~sign pd env fmt lvs otys otys' pp (op,es) - - | Ccall(lvs, f, es) -> - let otys, itys = get_funtype env f in - let (contr,args,ret) = get_funcontr env f in - - let cf = Option.get env.func in - let p = Mf.find cf !(env.proofv) in - let tmps = Mf.find f env.tmplvs in - - let lvs2 = List.map (fun v -> Lvar (L.mk_loc L._dummy v)) tmps in - - let elvs2 = - List.map (fun v -> - Pvar({gv = L.mk_loc L._dummy v; gs = Expr.Slocal}) - ) tmps - in - - let pre = sub_fun_param args es contr.f_pre in - let pre = List.map (fun (_,e) -> e) pre in - let post = sub_fun_return tmps contr.f_post in - let post = sub_fun_param args es post in - let post = List.map (fun (_,e) -> e) post in - - Format.fprintf fmt "%a@ " (pp_list "@ " (pp_assert ~sign pd env p)) pre; +let check_lvals lvs = all_vars lvs + +let rec init_aux_i pd asmOp env i = +match i.i_desc with + | Cassgn (lv, _, _, e) -> ( + match env.model with + | Normal | Annotations -> env + | ConstantTime -> add_aux (add_aux env [ty_lval lv]) [ty_expr e] + ) + | Cassert _ -> env + | Copn (lvs, _, op, _) -> ( + match env.model with + | Normal | Annotations -> + if List.length lvs = 1 then env + else + let tys = List.map Conv.ty_of_cty (Sopn.sopn_tout Build_Tabstract pd asmOp op) in + let ltys = List.map ty_lval lvs in + if all_vars lvs && ltys = tys then env + else add_aux env tys + | ConstantTime -> + let op = base_op op in + let tys = List.map Conv.ty_of_cty (Sopn.sopn_tout Build_Tabstract pd asmOp op) in + let env = add_aux env tys in + add_aux env (List.map ty_lval lvs) + ) + | Ccall(lvs, f, _) -> ( + match env.model with + | Normal | Annotations -> + if lvs = [] then env + else + let tys = (*List.map Conv.ty_of_cty *)(fst (get_funtype env f)) in + let ltys = List.map ty_lval lvs in + if (check_lvals lvs && ltys = tys) then env + else add_aux env tys + | ConstantTime -> + if lvs = [] then env + else add_aux env (List.map ty_lval lvs) + ) + | Csyscall(lvs, o, _) -> ( + match env.model with + | Normal | Annotations -> + if lvs = [] then env + else + let tys = List.map Conv.ty_of_cty (Syscall.syscall_sig_u o).scs_tout in + let ltys = List.map ty_lval lvs in + if (check_lvals lvs && ltys = tys) then env + else add_aux env tys + | ConstantTime -> + let s = Syscall.syscall_sig_u o in + let otys = List.map Conv.ty_of_cty s.scs_tout in + let env = add_aux env otys in + add_aux env (List.map ty_lval lvs) + ) + | Cif(_, c1, c2) | Cwhile(_, c1, _, c2) -> init_aux pd asmOp (init_aux pd asmOp env c1) c2 + | Cfor(_,_,c) -> init_aux pd asmOp (add_aux env [tint]) c - let env = List.fold_left (add_var false) env tmps in - begin - let pp_args fmt es = - pp_list ",@ " (pp_wcast ~sign pd env) fmt (List.combine itys es) - in - if lvs = [] then - Format.fprintf fmt "@[%a (%a);@]" (pp_fname env) f pp_args es - else - let pp fmt es = - Format.fprintf fmt "<%@ %a (%a)" (pp_fname env) f pp_args es in - pp_call ~sign pd env fmt lvs2 otys otys pp es - end; - - Format.fprintf fmt "@ %a@ " (pp_list "@ " (pp_assume ~sign pd env p)) post; - List.iter2 (fun lv e -> - Format.fprintf fmt "%a <- %a;@ " (pp_lval env) lv (pp_expr pd env) e - ) lvs elvs2 - - | Csyscall(lvs, o, es) -> - let s = Syscall.syscall_sig_u o in - let otys = List.map Conv.ty_of_cty s.scs_tout in - let itys = List.map Conv.ty_of_cty s.scs_tin in - let pp_args fmt es = - pp_list ",@ " (pp_wcast ~sign pd env) fmt (List.combine itys es) in - if lvs = [] then - Format.fprintf fmt "@[%a (%a);@]" (pp_syscall env) o pp_args es - else - let pp fmt es = - Format.fprintf fmt "<%@ %a (%a)" (pp_syscall env) o pp_args es in - pp_call ~sign pd env fmt lvs otys otys pp es +and init_aux pd asmOp env c = List.fold_left (init_aux_i pd asmOp) env c - | Cassert (Assume,_,e) -> - let f = Option.get env.func in - let p = Mf.find f !(env.proofv) in - pp_assume ~sign pd env p fmt e - | Cassert (Assert,_,e) -> - let f = Option.get env.func in - let p = Mf.find f !(env.proofv) in - pp_assert ~sign pd env p fmt e +let ece_leaks_e env e = List.map (toec_expr env) (leaks_e env.pd e) - | Cassert (_,_,e) -> assert false +let ec_newleaks leaks = + let add_leak lacc l = Eop2 (Infix "::", l, lacc) in + List.fold_left add_leak (ec_ident "leakages") leaks - | Cif(e,c1,c2) -> - Format.fprintf fmt "@[if (%a) {@ %a@ } else {@ %a@ }@]" - (pp_expr pd env) e (pp_cmd ~sign pd asmOp env) c1 (pp_cmd ~sign pd asmOp env) c2 - - | Cwhile(_, c1, e,c2) -> - Format.fprintf fmt "@[%a@ while (%a) {@ %a@ }@]" - (pp_cmd ~sign pd asmOp env) c1 (pp_expr pd env) e (pp_cmd ~sign pd asmOp env) (c2@c1) - - | Cfor(i, (d,e1,e2), c) -> - (* decreasing for loops have bounds swaped *) - let e1, e2 = if d = UpTo then e1, e2 else e2, e1 in - let pp_init, pp_e2 = - match e2 with - (* Can be generalized to the case where e2 is not modified by c and i *) - | Pconst _ -> (fun _fmt () -> ()), (fun fmt () -> pp_expr pd env fmt e2) - | _ -> - let aux = List.hd (get_aux env [tint]) in - let pp_init fmt () = - Format.fprintf fmt "@[%s <-@ %a@];@ " aux (pp_expr pd env) e2 in - let pp_e2 fmt () = pp_string fmt aux in - pp_init, pp_e2 in - let pp_i fmt () = pp_var env fmt (L.unloc i) in - let pp_i1, pp_i2 = - if d = UpTo then pp_i , pp_e2 - else pp_e2, pp_i in - Format.fprintf fmt - "@[%a%a <- %a;@ while (%a < %a) {@ @[%a@ %a <- %a %s 1;@]@ }@]" - pp_init () - pp_i () (pp_expr pd env) e1 - pp_i1 () pp_i2 () - (pp_cmd ~sign pd asmOp env) c - pp_i () pp_i () (if d = UpTo then "+" else "-") +let ec_addleaks leaks = [ESasgn ([LvIdent ["leakages"]], ec_newleaks leaks)] -end +let ec_leaks es = ec_addleaks [Eapp (ec_ident "LeakAddr", [Elist es])] -module Leak = struct - - type safe_cond = - | Initv of var - | Initai of wsize * var * expr - | Inita of var * int - | InBound of Memory_model.aligned * wsize * int * expr - | Valid of wsize * expr - | NotZero of wsize * expr - - let in_bound al ws x e = - match (L.unloc x).v_ty with - | Arr(ws1,n) -> InBound(al, ws, (arr_size ws1 n), e) - | _ -> assert false - - let safe_op2 safe _e1 e2 = function - | E.Obeq | E.Oand | E.Oor - | E.Oadd _ | E.Omul _ | E.Osub _ - | E.Oland _ | E.Olor _ | E.Olxor _ - | E.Olsr _ | E.Olsl _ | E.Oasr _ - | E.Orol _ | E.Oror _ - | E.Oeq _ | E.Oneq _ | E.Olt _ | E.Ole _ | E.Ogt _ | E.Oge _ - | E.Ovadd _ | E.Ovsub _ | E.Ovmul _ - | E.Ovlsr _ | E.Ovlsl _ | E.Ovasr _ -> safe - - | E.Odiv E.Cmp_int -> safe - | E.Omod Cmp_int -> safe - | E.Odiv (E.Cmp_w(_, s)) -> NotZero (s, e2) :: safe - | E.Omod (E.Cmp_w(_, s)) -> NotZero (s, e2) :: safe - - let is_init env x safe = - let (_s,option) = Mv.find (L.unloc x) env.vars in - if option then Initv (L.unloc x) :: safe - else safe - - let rec safe_e_rec pd env safe = function - | Pconst _ | Pbool _ | Parr_init _ -> safe - | Pvar x -> - let x = x.gv in - let (_s,option) = Mv.find (L.unloc x) env.vars in - if option then - match (L.unloc x).v_ty with - | Arr(ws,n) -> Inita (L.unloc x, arr_size ws n) :: safe - | _ -> Initv(L.unloc x) :: safe - else safe - | Pload (al, ws,x,e) -> (* TODO: alignment *) - is_init env x (Valid (ws, snd (add_ptr pd (gkvar x) e)) :: safe_e_rec pd env safe e) - | Papp1 (_, e) -> safe_e_rec pd env safe e - | Pget (al, aa, ws, x, e) -> - assert (aa = Warray_.AAscale); (* NOT IMPLEMENTED *) - let x = x.gv in - let safe = - let (_s,option) = Mv.find (L.unloc x) env.vars in - if option then Initai(ws, L.unloc x, e) :: safe - else safe in - in_bound al ws x e :: safe - | Psub _ -> assert false (* NOT IMPLEMENTED *) - | Papp2 (op, e1, e2) -> - safe_op2 (safe_e_rec pd env (safe_e_rec pd env safe e1) e2) e1 e2 op - | PappN (_op, _es) -> assert false (* TODO: nary *) - | Pabstract _ -> assert false - | Pif (_,e1, e2, e3) -> - safe_e_rec pd env (safe_e_rec pd env (safe_e_rec pd env safe e1) e2) e3 - | Pfvar _ -> assert false - | Pbig _ -> assert false - | Presult _ -> assert false - | Presultget _ -> assert false - - let safe_e pd env = safe_e_rec pd env [] - - let safe_es pd env = List.fold_left (safe_e_rec pd env) [] - - let safe_opn pd asmOp env safe opn es = - let id = Sopn.get_instr_desc Build_Tabstract pd asmOp opn in - List.pmap (fun c -> - match c with - | Wsize.X86Division(sz, _sg) -> - Some (NotZero(sz, List.nth es 2)) - (* FIXME: there are more properties to check *) - | Wsize.InRange _ -> None - (* FIXME: there are properties to check *) - | Wsize.AllInit (ws, p, i) -> - let e = List.nth es (Conv.int_of_nat i) in - let y = match e with Pvar y -> y | _ -> assert false in - let (_s,option) = Mv.find (L.unloc y.gv) env.vars in - if option then Some (Inita (L.unloc y.gv, arr_size ws (Conv.int_of_pos p))) - else None) id.i_safe @ safe - - let safe_lval pd env = function - | Lnone _ | Lvar _ -> [] - | Lmem(al, ws, x, e) -> (* TODO: alignment *) - is_init env x (Valid (ws, snd (add_ptr pd (gkvar x) e)) :: safe_e_rec pd env [] e) - | Laset(al, aa, ws, x,e) -> - assert (aa = Warray_.AAscale); (* NOT IMPLEMENTED *) - in_bound al ws x e :: safe_e_rec pd env [] e - | Lasub _ -> assert false (* NOT IMPLEMENTED *) - - let pp_safe_e ~sign pd env fmt = function - | Initv x -> Format.fprintf fmt "is_init %a" (pp_var env) x - | Initai(ws, x,e) -> Format.fprintf fmt "is_init%i %a %a" - (int_of_ws ws) (pp_var env) x (pp_expr ~sign pd env) e - | Inita(x,n) -> Format.fprintf fmt "%a.is_init %a" (pp_Array env) n (pp_var env) x - | Valid (sz, e) -> Format.fprintf fmt "is_valid Glob.mem %a W%a" (pp_expr ~sign pd env) e pp_size sz - | NotZero(sz,e) -> Format.fprintf fmt "%a <> W%a.zeros" (pp_expr ~sign pd env) e pp_size sz - | InBound(al, ws, n,e) -> Format.fprintf fmt "in_bound %a %a %i %i" - pp_bool (al = Aligned) - (pp_expr ~sign pd env) e (size_of_ws ws) n - - let pp_safe_es ~sign pd env fmt es = pp_list "/\\@ " (pp_safe_e ~sign pd env) fmt es - - let pp_leaks ~sign pd env fmt es = - Format.fprintf fmt "leakages <- LeakAddr(@[[%a]@]) :: leakages;@ " - (pp_list ";@ " (pp_expr ~sign pd env)) es - - let pp_safe_cond ~sign pd env fmt conds = - if conds <> [] then - Format.fprintf fmt "safe <- @[safe /\\ %a@];@ " (pp_safe_es ~sign pd env) conds - - let pp_leaks_e ~sign pd env fmt e = +let ec_leaks_e env e = match env.model with - | ConstantTime -> pp_leaks ~sign pd env fmt (leaks_e pd e) - | Safety -> pp_safe_cond ~sign pd env fmt (safe_e pd env e) - | _ -> () + | ConstantTime -> ec_leaks (ece_leaks_e env e) + | Normal | Annotations -> [] - let pp_leaks_es ~sign pd env fmt es = - match env.model with - | ConstantTime -> pp_leaks ~sign pd env fmt (leaks_es pd es) - | Safety -> pp_safe_cond ~sign pd env fmt (safe_es pd env es) - | _ -> () - - let pp_leaks_opn ~sign pd asmOp env fmt op es = +let ec_leaks_es env es = match env.model with - | ConstantTime -> pp_leaks ~sign pd env fmt (leaks_es pd es) - | Safety -> - let conds = safe_opn pd asmOp env (safe_es pd env es) op es in - pp_safe_cond ~sign pd env fmt conds - | Normal -> () + | ConstantTime -> ec_leaks (List.map (toec_expr env) (leaks_es env.pd es)) + | Normal | Annotations -> [] - let pp_leaks_if ~sign pd env fmt e = +let ec_leaks_opn env es = ec_leaks_es env es + +let ec_leaks_if env e = match env.model with | ConstantTime -> - let leaks = leaks_e pd e in - Format.fprintf fmt - "leakages <- LeakCond(%a) :: LeakAddr(@[[%a]@]) :: leakages;@ " - (pp_expr ~sign pd env) e (pp_list ";@ " (pp_expr ~sign pd env)) leaks - | Safety -> pp_safe_cond ~sign pd env fmt (safe_e pd env e) - | Normal -> () - - let pp_leaks_for ~sign pd env fmt e1 e2 = + ec_addleaks [ + Eapp (ec_ident "LeakAddr", [Elist (ece_leaks_e env e)]); + Eapp (ec_ident "LeakCond", [toec_expr env e]) + ] + | Normal | Annotations -> [] + +let ec_leaks_for env e1 e2 = match env.model with | ConstantTime -> - let leaks = leaks_es pd [e1;e2] in - Format.fprintf fmt - "leakages <- LeakFor(%a,%a) :: LeakAddr(@[[%a]@]) :: leakages;@ " - (pp_expr ~sign pd env) e1 (pp_expr ~sign pd env) e2 - (pp_list ";@ " (pp_expr ~sign pd env)) leaks - | Safety -> pp_safe_cond ~sign pd env fmt (safe_es pd env [e1;e2]) - | Normal -> () - - let pp_leaks_lv ~sign pd env fmt lv = + let leaks = List.map (toec_expr env) (leaks_es env.pd [e1;e2]) in + ec_addleaks [ + Eapp (ec_ident "LeakAddr", [Elist leaks]); + Eapp (ec_ident "LeakFor", [Etuple [toec_expr env e1; toec_expr env e2]]) + ] + | Normal | Annotations -> [] + +let ec_leaks_lv env lv = match env.model with | ConstantTime -> - let leaks = leaks_lval pd lv in - if leaks <> [] then pp_leaks ~sign pd env fmt leaks - | Safety -> pp_safe_cond ~sign pd env fmt (safe_lval pd env lv) - | _ -> () + let leaks = leaks_lval env.pd lv in + if leaks = [] then [] + else ec_leaks (List.map (toec_expr env) leaks) + | Normal | Annotations -> [] - let rec init_aux_i pd asmOp env i = - match i.i_desc with - | Cassgn (lv, _, _, e) -> add_aux (add_aux env [ty_lval lv]) [ty_expr e] - | Copn (lvs, _, op, _) -> - let op = base_op op in - let tys = List.map Conv.ty_of_cty (Sopn.sopn_tout Build_Tabstract pd asmOp op) in - let env = add_aux env tys in - add_aux env (List.map ty_lval lvs) - | Csyscall(lvs, o, _)-> - let s = Syscall.syscall_sig_u o in - let otys = List.map Conv.ty_of_cty s.scs_tout in - let env = add_aux env otys in - add_aux env (List.map ty_lval lvs) - | Ccall(lvs, _, _) -> - if lvs = [] then env - else add_aux env (List.map ty_lval lvs) - | Cassert _ -> assert false - | Cif(_, c1, c2) | Cwhile(_, c1, _, c2) -> init_aux pd asmOp (init_aux pd asmOp env c1) c2 - | Cfor(_,_,c) -> - if for_safety env then - init_aux pd asmOp (add_aux env [tint; tint]) c - else - init_aux pd asmOp (add_aux env [tint]) c +let ec_assgn env lv (etyo, etyi) e = + let e = e |> ec_wzeroext (etyo, etyi) |> ec_cast env (ty_lval lv, etyo) in + (ec_leaks_lv env lv) @ [toec_lval1 env lv e] - and init_aux pd asmOp env c = List.fold_left (init_aux_i pd asmOp) env c +let ec_assgn_i env lv ((etyo, etyi), aux) = ec_assgn env lv (etyo, etyi) (ec_ident aux) - let pp_some env pp lv fmt e = - if for_safety env then - match lv with - | Lnone _ -> () - | Lvar x -> - let x = L.unloc x in - let _s, option = Mv.find x env.vars in - if option then - let ty = x.v_ty in - if is_ty_arr ty then - let (_ws,n) = array_kind ty in - Format.fprintf fmt "(%a.map Some %a)" (pp_Array env) n pp e - else Format.fprintf fmt "(Some %a)" pp e - else pp fmt e - | Lmem _ -> pp fmt e - | Laset _ -> pp fmt e - | Lasub _ -> assert false (* NOT IMPLEMENTED *) - else pp fmt e - - let pp_assgn_i ~sign pd env fmt lv ((etyo, etyi), aux) = - Format.fprintf fmt "@ "; pp_leaks_lv ~sign pd env fmt lv; - let pp_e fmt aux = - pp_wzeroext pp_string fmt etyo etyi aux in - let pp_e = pp_some env (pp_cast env pp_e) lv in - pp_lval1 ~sign pd env pp_e fmt (lv, (etyo,aux)) - - let pp_call ~sign pd env fmt lvs etyso etysi pp a = +let ec_instr_aux env lvs etyso etysi instr = let auxs = get_aux env etysi in - Format.fprintf fmt "@[%a %a;@]" pp_aux_lvs auxs pp a; + let s2lv s = LvIdent [s] in + let call = instr (List.map s2lv auxs) in let tyauxs = List.combine (List.combine etyso etysi) auxs in - List.iter2 (pp_assgn_i ~sign pd env fmt) lvs tyauxs - - let rec pp_cmd ~sign pd asmOp env fmt c: unit = - Format.fprintf fmt "@[%a@]" (pp_list "@ " (pp_instr ~sign pd asmOp env)) c - - and pp_instr ~sign pd asmOp env fmt i: unit - = - match i.i_desc with - | Cassgn(v, _, _, (Parr_init _ as e)) -> - pp_leaks_e ~sign pd env fmt e; - let pp_e fmt _ = Format.fprintf fmt "witness" in - pp_lval1 ~sign pd env pp_e fmt (v, ((), ())) - - | Cassgn (lv, _, _, e) -> - pp_leaks_e ~sign pd env fmt e; - let pp fmt e = Format.fprintf fmt "<- %a" (pp_expr ~sign pd env) e in - let tys = [ty_expr e] in - pp_call ~sign pd env fmt [lv] tys tys pp e - - | Copn([], _, op, es) -> - (* Erase opn without return values but keep their leakage *) - let op' = base_op op in - pp_leaks_opn ~sign pd asmOp env fmt op' es; - Format.fprintf fmt "(* Erased call to %a *)" (pp_opn pd asmOp) op - - | Copn(lvs, _, op, es) -> - let op' = base_op op in - (* Since we do not have merge for the moment only the output type can change *) - let otys,itys = ty_sopn pd asmOp op es in - let otys', _ = ty_sopn pd asmOp op' es in - let pp fmt (op, es) = - Format.fprintf fmt "<- %a %a" (pp_opn pd asmOp) op - (pp_list "@ " (pp_wcast ~sign pd env)) (List.combine itys es) in - pp_leaks_opn ~sign pd asmOp env fmt op' es; - pp_call ~sign pd env fmt lvs otys otys' pp (op, es) - - | Ccall(lvs, f, es) -> - let otys, itys = get_funtype env f in - let pp_args fmt es = - pp_list ",@ " (pp_wcast ~sign pd env) fmt (List.combine itys es) in - pp_leaks_es ~sign pd env fmt es; - if lvs = [] then - Format.fprintf fmt "@[%a (%a);@]" (pp_fname env) f pp_args es - else - let pp fmt es = - Format.fprintf fmt "<%@ %a (%a)" (pp_fname env) f pp_args es in - pp_call ~sign pd env fmt lvs otys otys pp es - - | Csyscall(lvs, o, es) -> - let s = Syscall.syscall_sig_u o in - let otys = List.map Conv.ty_of_cty s.scs_tout in - let itys = List.map Conv.ty_of_cty s.scs_tin in - - let pp_args fmt es = - pp_list ",@ " (pp_wcast ~sign pd env) fmt (List.combine itys es) in - pp_leaks_es ~sign pd env fmt es; - if lvs = [] then - Format.fprintf fmt "@[%a (%a);@]" (pp_syscall env) o pp_args es - else - let pp fmt es = - Format.fprintf fmt "<%@ %a (%a)" (pp_syscall env) o pp_args es in - pp_call ~sign pd env fmt lvs otys otys pp es - - | Cassert _ -> assert false - - | Cif(e,c1,c2) -> - pp_leaks_if ~sign pd env fmt e; - Format.fprintf fmt "@[if (%a) {@ %a@ } else {@ %a@ }@]" - (pp_expr ~sign pd env) e (pp_cmd ~sign pd asmOp env) c1 (pp_cmd ~sign pd asmOp env) c2 - - | Cwhile(_, c1, e,c2) -> - let pp_leak fmt e = - Format.fprintf fmt "@ %a" (pp_leaks_if ~sign pd env) e in - Format.fprintf fmt "@[%a%a@ while (%a) {@ %a%a@ }@]" - (pp_cmd ~sign pd asmOp env) c1 pp_leak e (pp_expr ~sign pd env) e - (pp_cmd ~sign pd asmOp env) (c2@c1) pp_leak e - - | Cfor(i, (d,e1,e2), c) -> - pp_leaks_for ~sign pd env fmt e1 e2; - let aux, env1 = - if for_safety env then - let auxs = get_aux env [tint;tint] in - List.hd auxs, set_var env (L.unloc i) false (List.nth auxs 1) - else List.hd (get_aux env [tint]), env in - let pp_init, pp_e2 = - match e2 with - (* Can be generalized to the case where e2 is not modified by c and i *) - | Pconst _ -> (fun _fmt () -> ()), (fun fmt () -> pp_expr ~sign pd env fmt e2) - | _ -> - let pp_init fmt () = - Format.fprintf fmt "@[%s <-@ %a@];@ " aux (pp_expr ~sign pd env) e2 in - let pp_e2 fmt () = pp_string fmt aux in - pp_init, pp_e2 in - let pp_i fmt () = pp_var env1 fmt (L.unloc i) in - let pp_i1, pp_i2 = - if d = UpTo then pp_i , pp_e2 - else pp_e2, pp_i in - let pp_restore fmt () = - if for_safety env then - Format.fprintf fmt "@ @[%a <- %a;@]" - (pp_var env) (L.unloc i) (pp_some env pp_i (Lvar i)) () in - Format.fprintf fmt - "@[%a%a <- %a;@ while (%a < %a) {@ @[%a@ %a <- %a %s 1;@]@ }%a@]" - pp_init () - pp_i () (pp_expr ~sign pd env) e1 - pp_i1 () pp_i2 () - (pp_cmd ~sign pd asmOp env1) c - pp_i () pp_i () (if d = UpTo then "+" else "-") - pp_restore () - -end - -let pp_aux fmt env = - let pp ty aux = - Format.fprintf fmt "@[var %s:@ %a@];@ " aux (pp_ty env) ty in - Mty.iter (fun ty -> List.iter (pp ty)) env.auxv - -let pp_tmp fmt env = - let pp tmp ty = - Format.fprintf fmt "@[var %s:@ %a@];@ " tmp.v_name (pp_ty env) ty - in - Mf.iter (fun f tmps -> - let otys, _ = get_funtype env f in - List.iter2 pp tmps otys - ) env.tmplvs - -let pp_safe_ret ~sign pd env fmt xs = - if for_safety env then - let es = List.map (fun x -> Pvar (gkvar x)) xs in - Leak.pp_safe_cond ~sign pd env fmt (Leak.safe_es pd env es) - -let pp_bool_var env fmt var = - Format.fprintf fmt "@[var %s:@ %a@]" var (pp_ty env) tbool - -let pp_init_bool_var env fmt var = - Format.fprintf fmt "@[%s <- true;@]" var - -let pp_proof_var_init env fmt proofv = - Format.fprintf fmt "%a@ %a@ %a@ %a@ " - (pp_init_bool_var env) proofv.assume_ - (pp_init_bool_var env) proofv.assert_ - (pp_init_bool_var env) proofv.assume_proof - (pp_init_bool_var env) proofv.assert_proof - -let pp_proof_var env fmt proofv = - Format.fprintf fmt "%a@ %a@ %a@ %a@ " - (pp_bool_var env) proofv.assume_ - (pp_bool_var env) proofv.assert_ - (pp_bool_var env) proofv.assume_proof - (pp_bool_var env) proofv.assert_proof - -let rec init_tmp_lvs env i = - match i.i_desc with - | Cassgn _ - | Copn _ - | Csyscall _ - | Cassert _ -> env - | Ccall(lvs, f, _) -> - let otys, itys = get_funtype env f in - let (contr,args,ret) = get_funcontr env f in - let tmp = - List.map2 (fun ty arg -> - let name = "tmp___" ^ arg.v_name in - CoreIdent.GV.mk name (Wsize.Stack Direct) ty L._dummy [] - ) otys ret - in - add_tmp_lv env f tmp - | Cif(_, c1, c2) | Cwhile(_, c1, _, c2) -> - List.fold init_tmp_lvs (List.fold init_tmp_lvs env c1) c2 - | Cfor(_,_,c) -> List.fold init_tmp_lvs env c + let assgn_auxs = List.flatten (List.map2 (ec_assgn_i env) lvs tyauxs) in + call :: assgn_auxs -let pp_fun pd asmOp env fmt f = - let trans annot = - let l = - ["t", true ; "f", false] - in - let mk_trans = Annot.filter_string_list None l in - let atran annot = - match Annot.ensure_uniq1 "signed" mk_trans annot with - | None -> false - | Some s -> s - in - atran annot - in - - let sign = trans f.f_annot.f_user_annot in - - let f = { f with f_body = remove_for f.f_body } in - let locals = Sv.elements (locals f) in - (* initialize the env *) - let env = List.fold_left (add_var false) env f.f_args in - let env = List.fold_left (add_var (for_safety env)) env locals in - (* init auxiliary variables *) - let env = - if env.model = Normal then Normal.init_aux ~sign pd asmOp env f.f_body - else Leak.init_aux pd asmOp env f.f_body in - - let fname = get_funname env f.f_name in - let assume_ = create_name env ("assume_" ^ fname) in - let assert_ = create_name env ("assert_" ^ fname) in - let assume_proof = create_name env ("assume_proof_" ^ fname) in - let assert_proof = create_name env ("assert_proof_" ^ fname) in - - let proofv = {assume_; assert_; assume_proof; assert_proof} in - - add_proofv env f.f_name proofv; - - let freturn = List.map (fun x -> L.unloc x) f.f_ret in - let env = { env with func = Some f.f_name ; freturn} in - let env = List.fold init_tmp_lvs env f.f_body in - - (* Print the function *) - (* FIXME ajouter les conditions d'initialisation - sur les variables de retour *) - let pp_cmd = - if env.model = Normal then Normal.pp_cmd - else Leak.pp_cmd - in - Format.fprintf fmt - "@[@[%a@]@ proc %a (%a) : %a = {@ @[%a@ %a@ %a@ %a@ %a@ %a%a@]@ }@]" - (pp_proof_var env) proofv - (pp_fname env) f.f_name - (pp_params env) f.f_args - (pp_rty env) f.f_tyout - pp_aux env - pp_tmp env - (pp_locals env) locals - (pp_proof_var_init env) proofv - (pp_cmd ~sign pd asmOp env) f.f_body - (pp_safe_ret ~sign pd env) f.f_ret - (pp_ret env) f.f_ret - -let pp_contract ~sign pd env fmt c = - let c = List.map (fun (_,x) -> x) c in - if List.is_empty c then - Format.fprintf fmt "true" - else - Format.fprintf fmt "%a" (pp_list "@ /\\@ " (pp_expr ~sign pd env)) c - -let pp_var_eq env fmt (vars1, vars2) = - let vars = List.map2 (fun a b -> a,b) vars1 vars2 in - let pp fmt (var1,var2) = - Format.fprintf fmt "%s = %a " var1 (pp_var env) var2 - in - Format.fprintf fmt "%a" (pp_list "/\\ " pp) vars - -let pp_hoare fmt (f, pre, post) = - Format.fprintf fmt "@[hoare [M.%s :@ @[%a@ ==>@ %a@]@ ]@]" - f pre () post () - -let pp_proof1 ~sign pd env fmt f = - let p = Mf.find f.f_name !(env.proofv) in - let fname = get_funname env f.f_name in - let freturn = List.map (fun x -> L.unloc x) f.f_ret in - let env = {env with freturn} in - let env1, vars = Normal.mk_old_param env f.f_args in - let env = List.fold_left (add_var false) env f.f_args in - - let pp_pre fmt () = - Format.fprintf fmt "@[(%a /\\ %a)@]" - (pp_var_eq env) (vars, f.f_args) - (pp_contract ~sign pd env) f.f_contra.f_pre - in - let pp_post fmt () = - Format.fprintf fmt "@[M.%s@ /\\@ ((M.%s /\\ M.%s)@ =>@ (%a))@]" - p.assert_proof - p.assert_ - p.assume_ - (pp_contract ~sign pd env1) f.f_contra.f_post - in - - Format.fprintf fmt - "@[axiom %s_assert %a :@ @[%a@].@]" - fname - (pp_list " " pp_string) vars - pp_hoare (fname, pp_pre, pp_post) - -let pp_proof2 ~sign pd env fmt f = - let p = Mf.find f.f_name !(env.proofv) in - let fname = get_funname env f.f_name in - let freturn = List.map (fun x -> L.unloc x) f.f_ret in - let env = {env with freturn} in - let env = List.fold_left (add_var false) env f.f_args in - - let pp_pre fmt () = - Format.fprintf fmt "%a" - (pp_contract ~sign pd env) f.f_contra.f_pre - in - let pp_post fmt () = - Format.fprintf fmt "M.%s" - p.assume_proof - in +let ec_pcall env lvs otys f args = + let ltys = List.map ty_lval lvs in + if lvs = [] || ((env.model = Normal || env.model = Annotations) && check_lvals lvs && ltys = otys) then + [EScall (ec_lvals env lvs, f, args)] + else + ec_instr_aux env lvs otys otys (fun lvals -> EScall (lvals, f, args)) - Format.fprintf fmt - "@[lemma %s_assume :@ %a.@]@ " - fname - pp_hoare (fname, pp_pre, pp_post); - Format.fprintf fmt "proof.@ admitted. (*TODO*)" +let ec_call env lvs etyso etysi e = + let ltys = List.map ty_lval lvs in + if lvs = [] || ((env.model = Normal || env.model = Annotations) && check_lvals lvs && ltys = etyso && etyso = etysi) then + [ESasgn ((ec_lvals env lvs), e)] + else + ec_instr_aux env lvs etyso etysi (fun lvals -> ESasgn (lvals, e)) -let pp_proof3 pd env fmt f = - let p = Mf.find f.f_name !(env.proofv) in - let fname = get_funname env f.f_name in +let rec toec_cmd asmOp env c = List.flatten (List.map (toec_instr asmOp env) c) - let pp_pre fmt () = - Format.fprintf fmt "true" - in - let pp_post fmt () = - Format.fprintf fmt "@[(M.%s /\\ M.%s)@ =>@ (M.%s /\\ M.%s)@]" - p.assert_proof - p.assume_proof - p.assert_ - p.assume_ - in +and toec_instr asmOp env i = + match i.i_desc with + | Cassgn (lv, _, _, (Parr_init _ as e)) -> + (ec_leaks_e env e) @ + [toec_lval1 env lv (ec_ident "witness")] + | Cassgn (lv, _, _, e) -> ( + match env.model with + | Normal | Annotations -> + let e = toec_cast env (ty_lval lv) e in + [toec_lval1 env lv e] + | ConstantTime -> + let tys = [ty_expr e] in + (ec_leaks_e env e) @ + ec_call env [lv] tys tys (toec_expr env e) + ) + | Copn ([], _, op, es) -> + (ec_leaks_opn env es) @ + [EScomment (Format.sprintf "Erased call to %s" (ec_opn env.pd asmOp op))] + | Copn (lvs, _, op, es) -> + let op' = base_op op in + (* Since we do not have merge for the moment only the output type can change *) + let otys,itys = ty_sopn env.pd asmOp op es in + let otys', _ = ty_sopn env.pd asmOp op' es in + let ec_op op = ec_ident (ec_opn env.pd asmOp op) in + let ec_e op = Eapp (ec_op op, List.map (ec_wcast env) (List.combine itys es)) in + if (env.model = Normal || env.model = Annotations) && List.length lvs = 1 then + ec_assgn env (List.hd lvs) (List.hd otys, List.hd otys') (ec_e op') + else + (ec_leaks_opn env es) @ + (ec_call env lvs otys otys' (ec_e op)) + | Ccall (lvs, f, es) -> + begin + match env.model with + | Annotations -> Annotations.toec_fun env lvs f es + | _ -> + let otys, itys = get_funtype env f in + let args = List.map (ec_wcast env) (List.combine itys es) in + + (ec_leaks_es env es) @ + (ec_pcall env lvs otys [get_funname env f] args) + end - Format.fprintf fmt - "@[lemma %s_assert_assume_sound :@ %a.@]@ " - fname - pp_hoare (fname, pp_pre, pp_post); - Format.fprintf fmt "proof.@ admitted. (*TODO*)" - -let pp_proof4 ~sign pd env fmt f = - let p = Mf.find f.f_name !(env.proofv) in - let fname = get_funname env f.f_name in - let freturn = List.map (fun x -> L.unloc x) f.f_ret in - let env = {env with freturn} in - let env1,vars = Normal.mk_old_param env f.f_args in - let env = List.fold_left (add_var false) env f.f_args in - - let pp_pre fmt () = - Format.fprintf fmt "@[(%a /\\ %a)@]" - (pp_var_eq env) (vars, f.f_args) - (pp_contract ~sign pd env) f.f_contra.f_pre - in - let pp_post fmt () = - Format.fprintf fmt "@[%a@]" - (pp_contract ~sign pd env1) f.f_contra.f_post - in + | Cassert (Assume,_,e) -> + begin + match env.model with + | Annotations -> Annotations.ec_assume env e + | _ -> [] + end - Format.fprintf fmt - "@[lemma %s_spec :@ @[forall %a,@ %a@].@]@ " - fname - (pp_list " " pp_string) vars - pp_hoare (fname, pp_pre, pp_post); + | Cassert (Assert,_,e) -> + begin + match env.model with + | Annotations -> Annotations.ec_assert env e + | _ -> [] + end - Format.fprintf fmt "proof.@ "; + | Cassert (_,_,e) -> assert false - Format.fprintf fmt "move =>%a.@ " - (pp_list " " pp_string) vars; + | Csyscall (lvs, o, es) -> + let s = Syscall.syscall_sig_u o in + let otys = List.map Conv.ty_of_cty s.scs_tout in + let itys = List.map Conv.ty_of_cty s.scs_tin in + let args = List.map (ec_wcast env) (List.combine itys es) in + (ec_leaks_es env es) @ + (ec_pcall env lvs otys [ec_syscall env o] args) + | Cif (e, c1, c2) -> + (ec_leaks_if env e) @ + [ESif (toec_expr env e, toec_cmd asmOp env c1, toec_cmd asmOp env c2)] + | Cwhile (_, c1, e, c2) -> + let leak_e = ec_leaks_if env e in + (toec_cmd asmOp env c1) @ leak_e @ + [ESwhile (toec_expr env e, (toec_cmd asmOp env (c2@c1)) @ leak_e)] + | Cfor (i, (d,e1,e2), c) -> + (* decreasing for loops have bounds swaped *) + let e1, e2 = if d = UpTo then e1, e2 else e2, e1 in + let init, ec_e2 = + match e2 with + (* Can be generalized to the case where e2 is not modified by c and i *) + | Pconst _ -> ([], toec_expr env e2) + | _ -> + let aux = List.hd (get_aux env [tint]) in + let init = ESasgn ([LvIdent [aux]], toec_expr env e2) in + let ec_e2 = ec_ident aux in + [init], ec_e2 in + let ec_i = [ec_vars env (L.unloc i)] in + let lv_i = [LvIdent ec_i] in + let ec_i1, ec_i2 = + if d = UpTo then Eident ec_i , ec_e2 + else ec_e2, Eident ec_i in + let i_upd_op = Infix (if d = UpTo then "+" else "-") in + let i_upd = ESasgn (lv_i, Eop2 (i_upd_op, Eident ec_i, Econst (Z.of_int 1))) in + (ec_leaks_for env e1 e2) @ init @ [ + ESasgn (lv_i, toec_expr env e1); + ESwhile (Eop2 (Infix "<", ec_i1, ec_i2), (toec_cmd asmOp env c) @ [i_upd]) + ] + +let var2ec_var env x = (List.hd [ec_vars env x], Base (toec_ty x.v_ty)) + +let add_ty env = function + | Bty _ -> () + | Arr (_ws, n) -> add_Array env n + +let toec_fun asmOp env f = + let f = { f with f_body = remove_for f.f_body } in + + let env = + match env.model with + | Annotations -> Annotations.sign env f + | _ -> env + in - let pp_pre fmt () = - Format.fprintf fmt "@[(%a /\\ %a)@]" - (pp_var_eq env) (vars, f.f_args) - (pp_contract ~sign pd env) f.f_contra.f_pre - in - let pp_post fmt () = - Format.fprintf fmt "@[M.%s /\\ M.%s@ /\\@ ((M.%s /\\ M.%s)@ =>@ (%a))@]" - p.assert_proof - p.assume_proof - p.assert_ - p.assume_ - (pp_contract ~sign pd env1) f.f_contra.f_post; - in - Format.fprintf fmt - "have h: %a.@ " - pp_hoare (fname, pp_pre, pp_post); - - Format.fprintf fmt "+ by conseq %s_assume (%s_assert %a).@ " - fname fname - (pp_list " " pp_string) vars; - Format.fprintf fmt "conseq h %s_assert_assume_sound => //; smt().@ " fname; - Format.fprintf fmt "qed." - -let pp_proof pd env fmt f = - let trans annot = - let l = - ["t", true ; "f", false] + let locals = Sv.elements (locals f) in + let env = List.fold_left add_var env (f.f_args @ locals) in + (* init auxiliary variables *) + let env = init_aux env.pd asmOp env f.f_body in + List.iter (add_ty env) f.f_tyout; + List.iter (fun x -> add_ty env x.v_ty) (f.f_args @ locals); + Mty.iter (fun ty _ -> add_ty env ty) env.auxv; + let ec_locals = + let locs_ty (ty, vars) = List.map (fun v -> (v, Base (toec_ty ty))) vars in + (List.flatten (List.map locs_ty (Mty.bindings env.auxv))) @ + (List.map (var2ec_var env) locals) in - let mk_trans = Annot.filter_string_list None l in - let atran annot = - match Annot.ensure_uniq1 "signed" mk_trans annot with - | None -> false - | Some s -> s + let aux_locals_init = locals + |> List.filter (fun x -> match x.v_ty with Arr _ -> true | _ -> false) + |> List.sort (fun x1 x2 -> compare x1.v_name x2.v_name) + |> List.map (fun x -> ESasgn ([LvIdent [ec_vars env x]], ec_ident "witness")) + in + let env, ec_locals = + match env.model with + | Annotations -> + let env, vars = Annotations.ec_vars env f in + env, ec_locals @ vars + | _ -> env, ec_locals in - atran annot - in - let sign = trans f.f_annot.f_user_annot in + let cl_vars_init = + match env.model with + | Annotations -> (Annotations.proof_var_init env f) + | _ -> [] + in - Format.fprintf fmt "@[%a@ @ %a@ @ %a@ @ %a@]" - (pp_proof1 ~sign pd env) f - (pp_proof2 ~sign pd env) f - (pp_proof3 pd env) f - (pp_proof4 ~sign pd env) f + let ret = + let ec_var x = ec_vari env (L.unloc x) in + match f.f_ret with + | [x] -> + begin + match env.model with + | Annotations -> ESreturn (Etuple (ec_var x :: [Annotations.check_vars env f])) + | _ -> ESreturn (ec_var x) + end + | xs -> + begin + match env.model with + | Annotations -> + ESreturn (Etuple (Etuple (List.map ec_var xs) :: [Annotations.check_vars env f ])) + | _ -> ESreturn (Etuple (List.map ec_var xs)) + end + in -let pp_glob_decl env fmt (x,d) = - match d with - | Global.Gword(ws, w) -> - Format.fprintf fmt "@[abbrev %a = %a.of_int %a.@]@ " - (pp_var env) x pp_Tsz ws pp_print_i (Conv.z_of_word ws w) - | Global.Garr(p,t) -> - let wz, t = Conv.to_array x.v_ty p t in - let pp_elem fmt z = - Format.fprintf fmt "%a.of_int %a" pp_Tsz wz pp_print_i z in - Format.fprintf fmt "@[abbrev %a = %a.of_list witness [%a].@]@ " - (pp_var env) x (pp_Array env) (Array.length t) - (pp_list ";@ " pp_elem) (Array.to_list t) + let ret_typ = + match env.model with + | Annotations -> + let ret_typ = [Tuple(List.map (fun x -> Base (toec_ty x)) f.f_tyout)] in + Tuple (ret_typ @ [Base "to_check"]) + | _ -> Tuple(List.map (fun x -> Base (toec_ty x)) f.f_tyout) + in + + { + decl = { + fname = (get_funname env f.f_name); + args = List.map (var2ec_var env) f.f_args; + rtys = ret_typ; + }; + locals = ec_locals; + stmt = cl_vars_init @ aux_locals_init @ (toec_cmd asmOp env f.f_body) @ [ret]; + } let add_arrsz env f = let add_sz x sz = @@ -1910,85 +2025,153 @@ let add_glob_arrsz env (x,d) = env.warrsz := Sint.add (arr_size ws n) !(env.warrsz); env -let jmodel () = - let open Glob_options in - match !target_arch with +let jmodel () = match !Glob_options.target_arch with | X86_64 -> "JModel_x86" | ARM_M4 -> "JModel_m4" -let require_lib_slh () = - let s = - match !Glob_options.target_arch with +let lib_slh () = match !Glob_options.target_arch with | X86_64 -> "SLH64" | ARM_M4 -> "SLH32" - in - Format.sprintf "import %s." s -let pp_prog pd asmOp fmt model globs funcs arrsz warrsz randombytes = +let ec_glob_decl env (x,d) = + let w_of_z ws z = Eapp (Eident [pp_Tsz ws; "of_int"], [ec_ident (ec_print_i z)]) in + let mk_abbrev e = Iabbrev (ec_vars env x, e) in + match d with + | Global.Gword(ws, w) -> mk_abbrev (w_of_z ws (Conv.z_of_word ws w)) + | Global.Garr(p,t) -> + let ws, t = Conv.to_array x.v_ty p t in + mk_abbrev (Eapp ( + Eident [ec_Array env (Array.length t); "of_list"], + [ec_ident "witness"; Elist (List.map (w_of_z ws) (Array.to_list t))] + )) + +let ec_randombytes env = + let randombytes_decl a n = + let arr_ty = Format.sprintf "W8.t %s.t" (fmt_Array n) in + { + fname = Format.sprintf "randombytes_%i" n; + args = [(a, Base arr_ty)]; + rtys = Base arr_ty; + } + in + let randombytes_f n = + let dmap = + let wa = fmt_WArray n in + let initf = Equant (Llambda, ["a"], Eapp (Eident [fmt_Array n; "init"], [ + Equant (Llambda, ["i"], Eapp (Eident [wa; "get8"], [ec_ident "a"; ec_ident "i"])) + ])) in + Eapp (ec_ident "dmap", [Eident [wa; "darray"]; initf]) + in + { + decl = randombytes_decl "a" n; + locals = []; + stmt = [ESsample ([LvIdent ["a"]], dmap); ESreturn (ec_ident "a")]; + } + in + if Sint.is_empty !(env.randombytes) then [] + else [ + ImoduleType { + name = syscall_mod_sig; + funs = List.map (randombytes_decl "_") (Sint.elements !(env.randombytes)); + }; + Imodule { + name = syscall_mod; + params = []; + ty = Some syscall_mod_sig; + vars = []; + funs = List.map randombytes_f (Sint.elements !(env.randombytes)); + } + ] + +let toec_prog pd asmOp model globs funcs arrsz warrsz randombytes = + let add_glob_env env (x, d) = add_glob (add_glob_arrsz env (x, d)) x in + let env = empty_env pd model funcs arrsz warrsz randombytes false + |> fun env -> List.fold_left add_glob_env env globs + |> fun env -> List.fold_left add_arrsz env funcs + in - let env = empty_env model funcs arrsz warrsz randombytes in + let env, pp_leakages = match model with + | ConstantTime -> env, [("leakages", Base"leakages_t")] + | Normal -> env, [] + | Annotations -> + let env, tmp = + List.fold_left + (fun (env,acc) a -> + let env, vars = Annotations.ec_tmp_lvs env a in + env, acc @ vars + ) + (env,[]) + funcs + in + let name = "tmp__check" in + let s = normalize_name name in + let s = create_name env s in + let env = + { env with + alls = Ss.add s env.alls; + } + in + env, (s, Base "to_check") :: tmp + in - let env = - List.fold_left (fun env (x, d) -> let env = add_glob_arrsz env (x,d) in add_glob env x) - env globs in - let env = List.fold_left add_arrsz env funcs in + let funs = List.map (toec_fun asmOp env) funcs in - let prefix = !Glob_options.ec_array_path in - Sint.iter (pp_array_decl ~prefix) !(env.arrsz); - Sint.iter (pp_warray_decl ~prefix) !(env.warrsz); + let prefix = !Glob_options.ec_array_path in + Sint.iter (pp_array_decl ~prefix) !(env.arrsz); + Sint.iter (pp_warray_decl ~prefix) !(env.warrsz); - let pp_arrays arr fmt s = - let l = Sint.elements s in - let pp_i fmt i = Format.fprintf fmt "%s%i" arr i in - if l <> [] then - Format.fprintf fmt "require import @[%a@].@ " (pp_list "@ " pp_i) l in + let pp_arrays arr s = match Sint.elements s with + | [] -> [] + | l -> [IrequireImport (List.map (Format.sprintf "%s%i" arr) l)] + in - let pp_leakages fmt env = - match env.model with - | ConstantTime -> - Format.fprintf fmt "var leakages : leakages_t@ @ " - | Safety -> - Format.fprintf fmt "var safe : bool@ @ " - | Normal -> () in - - let pp_mod_arg fmt env = - if not (Sint.is_empty !(env.randombytes)) then - Format.fprintf fmt "(%s:%s)" syscall_mod_arg syscall_mod_sig in - - let pp_mod_arg_sig fmt env = - if not (Sint.is_empty !(env.randombytes)) then - let pp_randombytes_decl fmt n = - Format.fprintf fmt "proc randombytes_%i(_:W8.t %a.t) : W8.t %a.t" n (pp_Array env) n (pp_Array env) n in - Format.fprintf fmt "module type %s = {@ @[%a@]@ }.@ @ " - syscall_mod_sig - (pp_list "@ " pp_randombytes_decl) (Sint.elements !(env.randombytes)); - let pp_randombytes_proc fmt n = - Format.fprintf fmt "proc randombytes_%i(a:W8.t %a.t) : W8.t %a.t = {@ a <$ @[dmap %a.darray@ (fun a => %a.init (fun i => %a.get8 a i))@];@ return a;@ }" - n (pp_Array env) n (pp_Array env) n (pp_WArray env) n - (pp_Array env) n (pp_WArray env) n - in - Format.fprintf fmt - "module %s : %s = {@ @[%a@]@ }.@ @ " - syscall_mod syscall_mod_sig - (pp_list "@ @ " pp_randombytes_proc) (Sint.elements !(env.randombytes)) - in + let mod_arg = + if Sint.is_empty !(env.randombytes) then [] + else [(syscall_mod_arg, syscall_mod_sig)] + in + + let import_jleakage = match model with + | Normal -> [] + | Annotations -> Annotations.import + | ConstantTime -> [IfromRequireImport ("Jasmin", ["JLeakage"])] + in + + let glob_imports = [ + IrequireImport ["AllCore"; "IntDiv"; "CoreMap"; "List"; "Distr"]; + IfromRequireImport ("Jasmin", [jmodel ()]); + Iimport [lib_slh ()]; + ] + in + + let top_mod = Imodule { + name = "M"; + params = mod_arg; + ty = None; + vars = pp_leakages; + funs; + } + in + + let proof = + match env.model with + | Annotations -> Annotations.proof env funcs + | _ -> [] + in + + glob_imports @ + import_jleakage @ + (pp_arrays "Array" !(env.arrsz)) @ + (pp_arrays "WArray" !(env.warrsz)) @ + (List.map (fun glob -> ec_glob_decl env glob) globs) @ + (ec_randombytes env) @ + [top_mod] @ + proof + + +let pp_prog pd asmOp fmt model globs funcs arrsz warrsz randombytes = + pp_ec_prog fmt (toec_prog pd asmOp model globs funcs arrsz warrsz randombytes); + Format.fprintf fmt "@." - Format.fprintf fmt - "@[%s.@ %s %s.@ %s@ @ %s@ %a%a@ %a@ @ %amodule M%a = {@ @[%a%a@]@ }.@ @ %a@]@ " - "require import AllCore IntDiv CoreMap List Distr" - "from Jasmin require import" - (jmodel ()) - (require_lib_slh ()) - (if env.model = ConstantTime then "from Jasmin require import JLeakage." else "") - (pp_arrays "Array") !(env.arrsz) - (pp_arrays "WArray") !(env.warrsz) - (pp_list "@ @ " (pp_glob_decl env)) globs - pp_mod_arg_sig env - pp_mod_arg env - pp_leakages env - (pp_list "@ @ " (pp_fun pd asmOp env)) funcs - (pp_list "@ @ " (pp_proof pd env)) funcs - let rec used_func f = used_func_c Ss.empty f.f_body @@ -2014,8 +2197,4 @@ let extract pd asmOp fmt model ((globs,funcs):('info, 'asm) prog) tokeep = let arrsz = ref Sint.empty in let warrsz = ref Sint.empty in let randombytes = ref Sint.empty in - (* Do first a dummy printing to collect the Arrayi WArrayi RandomBytes ... *) - let dummy_fmt = Format.make_formatter (fun _ _ _ -> ()) (fun _ -> ()) in - pp_prog pd asmOp dummy_fmt model globs funcs arrsz warrsz randombytes; - pp_prog pd asmOp fmt model globs funcs arrsz warrsz randombytes - + pp_prog pd asmOp fmt model globs funcs arrsz warrsz randombytes diff --git a/compiler/src/toEC.mli b/compiler/src/toEC.mli index 49f82bff2..6f9438448 100644 --- a/compiler/src/toEC.mli +++ b/compiler/src/toEC.mli @@ -6,5 +6,3 @@ val extract : Format.formatter -> Utils.model -> ('info, ('reg, 'regx, 'xreg, 'rflag, 'cond, 'asm_op, 'extra_op) Arch_extra.extended_op) Prog.prog -> string list -> unit - -val init_use : ('info, 'asm) Prog.func list -> Prog.Sf.t * Prog.Sf.t diff --git a/compiler/src/typing.ml b/compiler/src/typing.ml index 74c9a59be..8f637e12b 100644 --- a/compiler/src/typing.ml +++ b/compiler/src/typing.ml @@ -141,7 +141,7 @@ and check_expr pd loc e ty = and check_exprs pd loc es tys = let len = List.length tys in if List.length es <> len then - error loc "invalid number of expressions %i excepted" len; + error loc "invalid number of expressions %i expected" len; List.iter2 (check_expr pd loc) es tys and ty_load_store pd loc ws x e = @@ -184,7 +184,7 @@ let check_lval pd loc x ty = let check_lvals pd loc xs tys = let len = List.length tys in if List.length xs <> len then - error loc "invalid number of left values %i excepted" len; + error loc "invalid number of left values %i expected" len; List.iter2 (check_lval pd loc) xs tys (* -------------------------------------------------------------------- *) diff --git a/compiler/src/utils.ml b/compiler/src/utils.ml index cfd079384..d83f5d412 100644 --- a/compiler/src/utils.ml +++ b/compiler/src/utils.ml @@ -233,8 +233,8 @@ let pp_string fmt s = (* -------------------------------------------------------------------- *) type model = | ConstantTime - | Safety | Normal + | Annotations (* -------------------------------------------------------------------- *) (* Functions used to add colors to errors and warnings. *) @@ -297,9 +297,21 @@ let add_iloc e i_loc = in { e with err_loc } +let remove_dummy_locations = + let open Location in + function + | Lnone -> Lnone + | Lone l when isdummy l -> Lnone + | Lone _ as x -> x + | Lmore { base_loc ; stack_loc ; _ } -> + match List.filter (fun x -> not (isdummy x)) (base_loc :: stack_loc) with + | [] -> Lnone + | [ x ] -> Lone x + | x :: xs -> Lmore (i_loc x xs) + let pp_hierror fmt e = let pp_loc fmt = - match e.err_loc with + match remove_dummy_locations e.err_loc with | Lnone -> () | Lone l -> Format.fprintf fmt "%a:@ " (pp_print_bold Location.pp_loc) l | Lmore i_loc -> Format.fprintf fmt "%a:@ " (pp_print_bold Location.pp_iloc) i_loc diff --git a/compiler/src/utils.mli b/compiler/src/utils.mli index 74f7f3e1c..4b29fd802 100644 --- a/compiler/src/utils.mli +++ b/compiler/src/utils.mli @@ -135,8 +135,8 @@ val pp_string : string pp (* -------------------------------------------------------------------- *) type model = | ConstantTime - | Safety | Normal + | Annotations (* -------------------------------------------------------------------- *) (* Enables colors in errors and warnings. *) diff --git a/compiler/src/varalloc.ml b/compiler/src/varalloc.ml index 7d17ae23c..1570a0318 100644 --- a/compiler/src/varalloc.ml +++ b/compiler/src/varalloc.ml @@ -431,8 +431,8 @@ let alloc_stack_fd callstyle pd get_info gtbl fd = let sao_alloc = List.iter (Hv.remove lalloc) fd.f_args; lalloc in - let sao_modify_rsp = - sao_size <> 0 || ra_on_stack || + let sao_modify_rsp = + sao_size <> 0 || has_syscall fd.f_body || Sf.exists (fun fn -> (get_info fn).sao_modify_rsp) sao_calls in let sao = { sao_calls; diff --git a/compiler/src/x86_arch_full.ml b/compiler/src/x86_arch_full.ml index c32243e88..5a6211bc9 100644 --- a/compiler/src/x86_arch_full.ml +++ b/compiler/src/x86_arch_full.ml @@ -1,5 +1,6 @@ open Arch_decl open X86_decl +open Wsize module type X86_input = sig @@ -47,8 +48,160 @@ module X86_core = struct | DIV _ | IDIV _ -> false | _ -> true - let is_ct_asm_extra (_ : extra_op) = true - + let is_doit_asm_op (o : asm_op) = + match o with + | ADC _ -> true + | ADCX _ -> true + | ADD _ -> true + | ADOX _ -> true + | AESDEC -> true + | AESDECLAST -> true + | AESENC -> true + | AESENCLAST -> true + | AESIMC -> true + | AESKEYGENASSIST -> true + | AND _ -> true + | ANDN _ -> true + | BSWAP _ -> false (* Not DOIT *) + | BT _ -> true + | CLC -> false (* Not DOIT *) + | CLFLUSH -> false (* Not DOIT *) + | CMOVcc _ -> true + | CMP _ -> true + | CQO _ -> false (* Not DOIT *) + | DEC _ -> true + | DIV _ -> false (* Not DOIT *) + | IDIV _ -> false (* Not DOIT *) + | IMUL _ -> true + | IMULr _ -> false (* Not DOIT *) + | IMULri _ -> false (* Not DOIT *) + | INC _ -> true + | LEA _ -> true + | LFENCE -> false (* Not DOIT *) + | LZCNT _ -> false (* Not DOIT *) + | MFENCE -> false (* Not DOIT *) + | MOV _ -> true + | MOVD _ -> true + | MOVSX _ -> true + | MOVV _ -> true + | MOVX _ -> true + | MOVZX _ -> true + | MUL _ -> true + | MULX_lo_hi _ -> true + | NEG _ -> true + | NOT _ -> true + | OR _ -> true + | PCLMULQDQ -> true + | PDEP _ -> false (* Not DOIT *) + | PEXT _ -> false (* Not DOIT *) + | POPCNT _ -> false (* Not DOIT *) + | RCL _ -> false (* Not DOIT *) + | RCR _ -> false (* Not DOIT *) + | RDTSC _ -> false (* Not DOIT *) + | RDTSCP _ -> false (* Not DOIT *) + | ROL _ -> false (* Not DOIT *) + | RORX _ -> false (* Not DOIT *) + | ROR _ -> false (* Not DOIT *) + | SAL _ -> false (* Not DOIT *) + | SAR _ -> true + | SARX _ -> false (* Not DOIT *) + | SBB _ -> true + | SETcc -> true + | SFENCE -> false (* Not DOIT *) + | SHL _ -> true + | SHLD _ -> false (* Not DOIT *) + | SHLX _ -> true + | SHR _ -> true + | SHRD _ -> false (* Not DOIT *) + | SHRX _ -> true + | STC -> false (* Not DOIT *) + | SUB _ -> true + | TEST _ -> true + | VAESDEC _ -> true + | VAESDECLAST _ -> true + | VAESENC _ -> true + | VAESENCLAST _ -> true + | VAESIMC -> true + | VAESKEYGENASSIST -> true + | VBROADCASTI128 -> true + | VEXTRACTI128 -> true + | VINSERTI128 -> true + | VMOV _ -> true + | VMOVDQA _ -> true + | VMOVDQU _ -> true + | VMOVHPD -> false (* Not DOIT *) + | VMOVLPD -> false (* Not DOIT *) + | VMOVSHDUP _ -> true + | VMOVSLDUP _ -> true + | VPACKSS _ -> true + | VPACKUS _ -> true + | VPADD _ -> true + | VPALIGNR _ -> true + | VPAND _ -> true + | VPANDN _ -> true + | VPAVG _ -> true + | VPBLEND _ -> true + | VPBLENDVB _ -> true + | VPBROADCAST _ -> true + | VPCLMULQDQ _ -> true + | VPCMPEQ _ -> true + | VPCMPGT _ -> true + | VPERM2I128 -> true + | VPERMD -> true + | VPERMQ -> true + | VPEXTR _ -> true + | VPINSR _ -> true + | VPMADDUBSW _ -> true + | VPMADDWD _ -> true + | VPMAXS (ve, _) -> ve = VE8 || ve = VE16 + | VPMAXU _ -> true + | VPMINS (ve, _) -> ve = VE8 || ve = VE16 + | VPMINU _ -> true + | VPMOVMSKB _ -> true + | VPMOVSX _ -> true + | VPMOVZX _ -> true + | VPMUL _ -> true + | VPMULH _ -> true + | VPMULHRS _ -> true + | VPMULHU _ -> true + | VPMULL _ -> true + | VPMULU _ -> true + | VPOR _ -> true + | VPSHUFB _ -> true + | VPSHUFD _ -> true + | VPSHUFHW _ -> true + | VPSHUFLW _ -> true + | VPSLL _ -> true + | VPSLLDQ _ -> true + | VPSLLV _ -> true + | VPSRA _ -> true + | VPSRL _ -> true + | VPSRLDQ _ -> true + | VPSRLV _ -> true + | VPSUB _ -> true + | VPTEST _ -> true + | VPUNPCKH _ -> true + | VPUNPCKL _ -> true + | VPXOR _ -> true + | VSHUFPS _ -> false (* Not DOIT *) + | XCHG _ -> false (* Not DOIT *) + | XOR _ -> true + + (* All of the extra ops compile into CT instructions (no DIV). *) + let is_ct_asm_extra (o : extra_op) = true + + (* All of the extra ops compile into DOIT instructions only, but this needs to be checked manually. *) + let is_doit_asm_extra (o : extra_op) = + match o with + | Oset0 _ -> true + | Oconcat128 -> true + | Ox86MOVZX32 -> true + | Ox86MULX ws -> true + | Ox86MULX_hi _ -> true + | Ox86SLHinit -> true + | Ox86SLHupdate -> true + | Ox86SLHmove -> true + | Ox86SLHprotect _ -> true end diff --git a/compiler/tests/fail/x86-64/unaligned_slice_copy.jazz b/compiler/tests/fail/x86-64/unaligned_slice_copy.jazz new file mode 100644 index 000000000..baa72c62f --- /dev/null +++ b/compiler/tests/fail/x86-64/unaligned_slice_copy.jazz @@ -0,0 +1,10 @@ +// Cannot copy by chunks of 4 bytes starting at offset 3 bytes +export fn main() -> reg u32 { + stack u8[8] s; + s[u64 0] = 0; + stack u32[1] d; + d = #copy_32(s[3:4]); + reg u32 r; + r = d[0]; + return r; +} diff --git a/compiler/tests/sct-checker/accept.expected b/compiler/tests/sct-checker/accept.expected index 995db845e..2316b7cd8 100644 --- a/compiler/tests/sct-checker/accept.expected +++ b/compiler/tests/sct-checker/accept.expected @@ -55,14 +55,20 @@ output corruption: #public constraints: -modmsf safe_access : #public * #poly = { n = d, s = d} -> +modmsf safe_access_no_array : #public * #poly = { n = d, s = d} -> #poly = { n = d, s = d} output corruption: #public constraints: -modmsf safe_direct_access : #public * #poly = { n = d, s = d} -> -#poly = { n = d, s = d} +modmsf safe_access : #public * #poly = { n = d, s = secret} -> +#poly = { n = d, s = secret} +output corruption: #public + constraints: + + +modmsf safe_direct_access : #public * #poly = { n = d, s = secret} -> +#poly = { n = d, s = secret} output corruption: #public constraints: @@ -129,6 +135,32 @@ output corruption: #transient constraints: +File bug_852.jazz: +nomodmsf reset : #public -> + +output corruption: #public + constraints: + + +modmsf main : #transient -> + +output corruption: #public + constraints: + + +File bug_887.jazz: +modmsf test_msf : #secret * #transient -> + +output corruption: #public + constraints: + + +modmsf test_venv : #secret -> +#public +output corruption: #public + constraints: + + File corruption.jazz: nomodmsf corrupts_memory : #public * #secret * #[ptr = public, val = secret] * @@ -179,6 +211,19 @@ output corruption: #public constraints: +File movmsf.jazz: +modmsf reset_msf : -> +#msf +output corruption: #public + constraints: + + +modmsf main : #transient -> + +output corruption: #public + constraints: + + File paper.jazz: modmsf fig3a : #[ptr = transient, val = transient] * #[ptr = transient, val = secret] * #transient -> diff --git a/compiler/tests/sct-checker/fail/basic.jazz b/compiler/tests/sct-checker/fail/basic.jazz index 67f16eae1..09b031aae 100644 --- a/compiler/tests/sct-checker/fail/basic.jazz +++ b/compiler/tests/sct-checker/fail/basic.jazz @@ -5,8 +5,8 @@ u64[2] not = { 1, 0 }; fn after_branch(#transient reg u64 a){ reg u64 m; m = #init_msf(); - if a >= 2 { a = m; } - a = not[(int) a]; + if a >= 2 { a = 0; } + a = not[a]; a = #protect(a, m); } diff --git a/compiler/tests/sct-checker/fail/bug_887.jazz b/compiler/tests/sct-checker/fail/bug_887.jazz new file mode 100644 index 000000000..e14a3deb3 --- /dev/null +++ b/compiler/tests/sct-checker/fail/bug_887.jazz @@ -0,0 +1,14 @@ +/* In this example, r is public most of the time, except when the loop exits. */ +#[sct="secret → ()"] +fn test_venv(reg u64 s) { + reg u64 i r; + r = 0; + i = 0; + while { + r = s; + } (i < 10) { + r = 0; + i += 1; + } + [r] = 0; +} diff --git a/compiler/tests/sct-checker/fail/movmsf.jazz b/compiler/tests/sct-checker/fail/movmsf.jazz new file mode 100644 index 000000000..e5defc226 --- /dev/null +++ b/compiler/tests/sct-checker/fail/movmsf.jazz @@ -0,0 +1,31 @@ +inline +fn reset_msf() -> #msf reg u64 { + reg u64 msf; + msf = #init_msf(); + return msf; +} + +fn fail(reg u64 x) { + reg u64 msf; + msf = #init_msf(); + if x < 1 { + msf = reset_msf(); + msf = #update_msf(x < 1, msf); + } +} + +fn overwrite(reg u64 x) { + reg u64 msf; + msf = #init_msf(); + if x > 0 { + x = msf; + } +} + +fn overwrite2(reg u64 x) { + reg u64 msf; + msf = #init_msf(); + if x > 0 { + x = #mov_msf(msf); + } +} diff --git a/compiler/tests/sct-checker/fail/speculative-stack-leak.jazz b/compiler/tests/sct-checker/fail/speculative-stack-leak.jazz new file mode 100644 index 000000000..0f1a8facd --- /dev/null +++ b/compiler/tests/sct-checker/fail/speculative-stack-leak.jazz @@ -0,0 +1,38 @@ +// After running this function, the secret is left below the top of the stack +inline +fn leak(reg u32 x) -> reg u32 { + stack u32 s; + s = x; + x = s; + return x; +} + +// Under mis-speculation, the second if may access the uninitialized stack variable +// and expose the resulting value as public +inline +fn get(reg u32 p) -> reg u32 { + stack u32 t; + if true { + t = p; + } + if true { + p = t; + } + return p; +} + +#[sct="secret × transient → public"] +export +fn main(reg u32 sec pub) -> reg u32 { + _ = #init_msf(); + sec = leak(sec); + pub = get(pub); + reg u32 r; + // leak pub + if pub >s 0 { + r = 0; + } else { + r = 1; + } + return r; +} diff --git a/compiler/tests/sct-checker/reject.expected b/compiler/tests/sct-checker/reject.expected index fb7cb650a..7551ff36e 100644 --- a/compiler/tests/sct-checker/reject.expected +++ b/compiler/tests/sct-checker/reject.expected @@ -27,6 +27,9 @@ Failed as expected after_branch: "fail/basic.jazz", line 10 (18-19): } are Failed as expected leak_transient: "fail/basic.jazz", line 1 (42-50): speculative constant type checker: x has type #transient but should be at most #public +File bug_887.jazz: +Failed as expected test_venv: "fail/bug_887.jazz", line 13 (3-4): + speculative constant type checker: r has type #secret but should be at most #public File corruption.jazz: Failed as expected does_corrupt_memory: "fail/corruption.jazz", line 26 (12-13): speculative constant type checker: return type for y is #[ptr = public, val = transient] it should be less than #[ptr = public, val = public] @@ -51,6 +54,18 @@ Failed as expected modmsf_trace: "fail/modmsf-trace.jazz", line 17 (2-8): the function f2 destroys MSFs at "fail/modmsf-trace.jazz", line 12 (19-25) the function f1 destroys MSFs at "fail/modmsf-trace.jazz", line 9 (19-31) the function kill_msf destroys MSFs at "fail/modmsf-trace.jazz", line 3 (4) to line 5 (5) +File movmsf.jazz: +Failed as expected overwrite2: "fail/movmsf.jazz", line 29 (4-5): + speculative constant type checker: x cannot become an MSF as the current status depends on it ( + (x >u ((64u) 0))) +Failed as expected overwrite: "fail/movmsf.jazz", line 21 (4-5): + speculative constant type checker: x cannot become an MSF as the current status depends on it ( + (x >u ((64u) 0))) +Failed as expected fail: "fail/movmsf.jazz", line 13 (29-32): + speculative constant type checker: MSF is not Trans +File speculative-stack-leak.jazz: +Failed as expected main: "fail/speculative-stack-leak.jazz", line 32 (2) to line 36 (3): + speculative constant type checker: (pub > ((32u) 0)) has type #transient but should be at most #public File spill.jazz: Failed as expected spill2: "fail/spill.jazz", line 12 (5-8): speculative constant type checker: pub has type #transient but should be at most #public diff --git a/compiler/tests/sct-checker/success/arrays.jazz b/compiler/tests/sct-checker/success/arrays.jazz index f373322b8..4ddbc8f48 100644 --- a/compiler/tests/sct-checker/success/arrays.jazz +++ b/compiler/tests/sct-checker/success/arrays.jazz @@ -8,11 +8,24 @@ fn transient_read( reg u64 x; x = #init_msf(); x = i if i < N; - x = p[(int) x]; + x = p[x]; return x; } #[sct="public * d -> d"] +fn safe_access_no_array(reg u64 c x) -> reg u64 { + stack u64 s; + if c != 0 { + s = x; + x = s; + } + return x; +} + +// Contrary to the example above (safe_access_no_array), +// the checker is not able to detect that the array is fully overwritten +// and only a “weak update” is done on “s[0] = x;” +#[sct="public * { n: d, s: secret } -> { n: d, s: secret }"] fn safe_access(reg u64 c x) -> reg u64 { stack u64[1] s; if c != 0 { @@ -22,7 +35,7 @@ fn safe_access(reg u64 c x) -> reg u64 { return x; } -#[sct="public × d → d"] +#[sct="public × { n: d, s: secret } → { n: d, s: secret }"] fn safe_direct_access( reg u64 c, reg u8 x diff --git a/compiler/tests/sct-checker/success/bug_852.jazz b/compiler/tests/sct-checker/success/bug_852.jazz new file mode 100644 index 000000000..5b9aca1d8 --- /dev/null +++ b/compiler/tests/sct-checker/success/bug_852.jazz @@ -0,0 +1,12 @@ +inline +fn reset(stack u64 t) { + [t] = 0; +} + +export +fn main(reg u64 x) { + _ = #init_msf(); + stack u64 s; + s = x; + reset(s); +} diff --git a/compiler/tests/sct-checker/success/bug_887.jazz b/compiler/tests/sct-checker/success/bug_887.jazz new file mode 100644 index 000000000..503e2aae2 --- /dev/null +++ b/compiler/tests/sct-checker/success/bug_887.jazz @@ -0,0 +1,23 @@ +fn test_msf(reg u64 msf x) { + while { + msf = #init_msf(); + } (x != 0) { + msf = #update_msf(x != 0, msf); + x = 0; + } + msf = #update_msf(! (x != 0), msf); +} + +#[sct="secret → public"] +fn test_venv(reg u64 s) -> reg u64 { + reg u64 i r; + r = 0; + i = 0; + while { + r = 0; + } (i < 10) { + r = s; + i += 1; + } + return r; +} diff --git a/compiler/tests/sct-checker/success/movmsf.jazz b/compiler/tests/sct-checker/success/movmsf.jazz new file mode 100644 index 000000000..200b7a51a --- /dev/null +++ b/compiler/tests/sct-checker/success/movmsf.jazz @@ -0,0 +1,18 @@ +fn reset_msf() -> #msf reg u64 { + reg u64 msf; + msf = #init_msf(); + return msf; +} + +fn main(reg u64 x) { + stack u64[1] tab; + reg u64 msf; + msf = #init_msf(); + tab[0] = 0; + if x < 1 { + x = tab[x]; + msf = reset_msf(); + x = #protect(x, msf); + [x] = 0; + } +} diff --git a/compiler/tests/success/common/arraycopy.jazz b/compiler/tests/success/common/arraycopy.jazz index e762ac9b1..5c7c4b9ab 100644 --- a/compiler/tests/success/common/arraycopy.jazz +++ b/compiler/tests/success/common/arraycopy.jazz @@ -45,4 +45,37 @@ fn all_kinds() -> reg u32 { return x; } +export +fn slices(reg u32 x) -> reg u32 { + inline int i; + stack u32[4] p q; + for i = 0 to 4 { p[i] = x; } + for i = 0 to 2 { + q[2 * i:2] = #copy_32(p[2 - 2 * i:2]); + } + x = q[1]; + return x; +} +export +fn self_copy(reg u32 x) -> reg u32 { + inline int i; + stack u32[3] s; + s[0] = x; + for i = 1 to 3 { + s[i:1] = #copy_32(s[i - 1:1]); + } + x = s[2]; + return x; +} + +export +fn ptr_slices() -> reg u32 { + reg u32 x; + reg ptr u32[2] p; + stack u32[1] s; + p = g[1:2]; + s = #copy_32(p[1:1]); + x = s[0]; + return x; +} diff --git a/compiler/tests/success/common/bug_842.jazz b/compiler/tests/success/common/bug_842.jazz new file mode 100644 index 000000000..da12d7e16 --- /dev/null +++ b/compiler/tests/success/common/bug_842.jazz @@ -0,0 +1,23 @@ +export fn fail() -> reg u32 +{ + stack u32[1] a b; + reg u32 one; + one = 1; + a[0] = one; + b[0:1] = #copy_32(a); + reg u32 r; + r = b[0]; + return r; +} + +export fn fail2() -> reg u32 +{ + stack u32[1] a b; + reg u32 one; + one = 1; + a[0] = one; + b = #copy_32(a[0:1]); + reg u32 r; + r = b[0]; + return r; +} diff --git a/compiler/tests/success/common/bug_870.jazz b/compiler/tests/success/common/bug_870.jazz new file mode 100644 index 000000000..001dc4c88 --- /dev/null +++ b/compiler/tests/success/common/bug_870.jazz @@ -0,0 +1,5 @@ +export +fn rand(reg ptr u8[32] io) -> reg ptr u8[32] { + io = #randombytes(io); + return io; +} diff --git a/compiler/tests/success/common/integer_notation.jazz b/compiler/tests/success/common/integer_notation.jazz new file mode 100644 index 000000000..6ac12464a --- /dev/null +++ b/compiler/tests/success/common/integer_notation.jazz @@ -0,0 +1,22 @@ +/* +Test for all valid integer syntaxes +*/ +export fn test () -> reg u32 { + reg u32 y; + y = 0b11110000; + y = 0b111_111_11; + y = 0B111_00_11; + + y = 0o01234567; + y = 0o765_4_321; + y = 0O76543210; + + y = 1000000000; + y = 1000_0000_000; + + y = 0x01234567; + y = 0x765_b_32aac; + y = 0X76aab3210; + + return y; +} diff --git a/compiler/tests/success/x86-64/bug_681.jazz b/compiler/tests/success/x86-64/bug_681.jazz new file mode 100644 index 000000000..125e7b271 --- /dev/null +++ b/compiler/tests/success/x86-64/bug_681.jazz @@ -0,0 +1,8 @@ +export +fn load_small(reg u32 x) -> reg u16 { + stack u32 s; + reg u16 r; + s = x; + r = s; + return r; +} diff --git a/default.nix b/default.nix index 2ce3defdf..d396efa76 100644 --- a/default.nix +++ b/default.nix @@ -19,7 +19,10 @@ let coqPackages = if coqMaster then pkgs.coqPackages.overrideScope (self: super: { coq = super.coq.override { version = "master"; }; - coq-elpi = super.coq-elpi.override { version = "coq-master"; }; + coq-elpi = callPackage scripts/coq-elpi.nix { + version = "master"; + inherit (self) lib mkCoqDerivation coq; + }; hierarchy-builder = super.hierarchy-builder.override { version = "1.7.0"; }; }) else coqPackages_8_19 diff --git a/eclib/JArray.ec b/eclib/JArray.ec index f8045b5bc..d1f90b9a7 100644 --- a/eclib/JArray.ec +++ b/eclib/JArray.ec @@ -58,11 +58,11 @@ abstract theory MonoArray. 0 <= x < size => t.[x<-a].[y] = if y = x then a else t.[y]. proof. by move=> hx;rewrite get_set_if hx. qed. - lemma nosmt set_eqiE (t : t) x y a : + lemma set_eqiE (t : t) x y a : 0 <= x < size => y = x => t.[x <- a].[y] = a. proof. by move=> h1 ->;rewrite get_setE. qed. - lemma nosmt set_neqiE (t : t) x y a : + lemma set_neqiE (t : t) x y a : y <> x => t.[x <- a].[y] = t.[y]. proof. by rewrite get_set_if => /neqF ->. qed. @@ -316,11 +316,11 @@ abstract theory PolyArray. 0 <= x < size => t.[x<-a].[y] = if y = x then a else t.[y]. proof. by move=> hx; rewrite get_set_if hx. qed. - lemma nosmt set_eqiE (t : 'a t) x y a : + lemma set_eqiE (t : 'a t) x y a : 0 <= x < size => y = x => t.[x <- a].[y] = a. proof. by move=> h1 ->;rewrite get_setE. qed. - lemma nosmt set_neqiE (t : 'a t) x y a : + lemma set_neqiE (t : 'a t) x y a : 0 <= x < size => y <> x => t.[x <- a].[y] = t.[y]. proof. by move=> h1; rewrite get_setE // => ->. qed. @@ -521,12 +521,5 @@ abstract theory PolyArray. by rewrite mem_iota /= => h1; apply h;case h1. qed. - (* -------------------------------------------------------------------- *) - op is_init (t: 'a option t) = all is_init t. - - lemma is_init_Some (t:'a t) : is_init (map Some t). - proof. by rewrite /is_init allP => i hi; rewrite mapiE. qed. - - hint simplify [eqtrue] is_init_Some. end PolyArray. diff --git a/eclib/JMemory.ec b/eclib/JMemory.ec index 13b54a58c..8329909c1 100644 --- a/eclib/JMemory.ec +++ b/eclib/JMemory.ec @@ -255,200 +255,3 @@ proof. rewrite storeW32E /= get_storesE /= /#. qed. module Glob = { var mem : global_mem_t }. - -(* ------------------------------------------------------------------- *) -(* Safety *) - -op is_align (ws:wsize) (a:address) = - wsize_i ws %| a. - -op allocated (m:global_mem_t) (p:address) (N:int) : bool = - forall i, 0 <= i < N => allocated8 m (p + i). - -op is_valid (m:global_mem_t) (a:address) (ws:wsize) = - allocated m a (wsize_i ws) /\ is_align ws a -axiomatized by is_validE. - -op valid_range (w:wsize) (mem:global_mem_t) (ptr:address) (len:int) = - forall i, 0 <= i < len => is_valid mem (ptr + wsize_i w * i) w. - -(* ------------------------------------------------------------------- *) - -lemma is_align_le w2 w1 ptr: - wsize_i w1 <= wsize_i w2 => is_align w2 ptr => is_align w1 ptr. -proof. - by rewrite /is_align => hw; apply dvdz_trans; apply div_le_wsize. -qed. - -lemma is_align_add w ptr ofs: - wsize_i w %| ofs => is_align w ptr => is_align w (ptr + ofs). -proof. - by rewrite /is_align => h1 h2; apply dvdzD. -qed. - -(* ------------------------------------------------------------------- *) - -lemma allocated_stores a1 s mem a2 N: allocated (stores mem a1 s) a2 N = allocated mem a2 N. -proof. - rewrite /allocated /= eq_iff;split => h i hi. - + by rewrite -(allocated8_stores s a1) h. - by rewrite allocated8_stores h. -qed. - -lemma allocate_le m p (N1 N2:int) : - N1 <= N2 => - allocated m p N2 => allocated m p N1. -proof. rewrite /allocated => hle h i hi;apply h => /#. qed. - -(* ------------------------------------------------------------------- *) - -lemma valid_range_le (len1 len2:int) w mem ptr : - len1 <= len2 => - valid_range w mem ptr len2 => - valid_range w mem ptr len1. -proof. by move=> hle hv i hlt; apply hv => /#. qed. - -lemma is_valid_valid_range w1 w2 mem ptr : - wsize_i w1 <= wsize_i w2 => - is_valid mem ptr w2 => - valid_range w1 mem ptr (wsize_i w2 %/ wsize_i w1). -proof. - rewrite /valid_range is_validE => hw [ha hia] i hi. - rewrite is_validE is_align_add /=. - + by apply modzMr. - + by apply: is_align_le hia. - move=> k hk /=;rewrite -addzA;apply ha;split;[smt (gt0_wsize_i)|move=> ?]. - apply: (ltr_le_trans ((i + 1) * wsize_i w1)); 1: smt (). - rewrite (divz_eq (wsize_i w2) (wsize_i w1)). - smt (modz_cmp gt0_wsize_i). -qed. - -lemma valid_range_size_le w1 w2 mem ptr len : - wsize_i w1 <= wsize_i w2 => - valid_range w2 mem ptr len => - valid_range w1 mem ptr (len * (wsize_i w2 %/ wsize_i w1)). -proof. - rewrite /valid_range => hw hv i hi. - pose dw := wsize_i w2 %/ wsize_i w1. - have gt0_dw : 0 < dw. - + by apply ltz_divRL => //; apply div_le_wsize. - have := hv (i %/ dw) _. - + apply divz_cmp => //. - move=> /(is_valid_valid_range _ _ _ _ hw) /(_ (i %% dw) _) /=. - + by apply modz_cmp. - have <- := divzK _ _ (div_le_wsize _ _ hw); rewrite -/dw. - have -> : ptr + dw * wsize_i w1 * (i %/ dw) + wsize_i w1 * (i %% dw) = - ptr + wsize_i w1 * ((i %/ dw) * dw + i %% dw) by ring. - by rewrite -divz_eq. -qed. - -lemma valid_range_is_valid w1 w2 mem ptr : - wsize_i w1 <= wsize_i w2 => - is_align w2 ptr => - valid_range w1 mem ptr (wsize_i w2 %/ wsize_i w1) => - is_valid mem ptr w2. -proof. - move=> hw hia hr; rewrite is_validE. - pose dw := wsize_i w2 %/ wsize_i w1. - have gt0_dw : 0 < dw. - + by apply ltz_divRL => //; apply div_le_wsize. - split;last by (have := hr 0 _). - move=> i hi. - have := hr (i %/ wsize_i w1) _. - + split; 1: by apply divz_ge0;[ apply gt0_wsize_i | case hi]. - move=> ?;apply ltz_divRL => //; 1: by apply div_le_wsize. - by have := divz_eq i (wsize_i w1); have := modz_cmp i (wsize_i w1) _ => // /#. - rewrite is_validE; move => [] /(_ (i%%wsize_i w1) _); 1: by apply modz_cmp. - by rewrite mulzC -addzA -divz_eq. -qed. - -lemma valid_range_size_ge w1 w2 mem ptr len1 len2 : - is_align w2 ptr => - wsize_i w1 <= wsize_i w2 => - (wsize_i w2 %/ wsize_i w1) * len2 <= len1 => - valid_range w1 mem ptr len1 => - valid_range w2 mem ptr len2. -proof. - move=> hia hw hl hv. - have {hv} hv:= valid_range_le _ _ _ _ _ hl hv. - move=> i hi; apply (valid_range_is_valid w1) => //. - + by apply is_align_add => //; apply modzMr. - move=> k hk /=. - have gt0_dw : 0 < wsize_i w2 %/ wsize_i w1. - + by apply ltz_divRL => //; apply div_le_wsize. - have := hv ((wsize_i w2 %/ wsize_i w1) * i + k) _. - + split. smt(). - move=> ?;apply (ltr_le_trans (wsize_i w2 %/ wsize_i w1 * (i + 1))). - + smt(). - by apply ler_wpmul2l;[apply ltzW | smt()]. - rewrite Ring.IntID.mulrDr -mulzA (mulzC(wsize_i w1)) divzK ?addzA //. - by apply div_le_wsize. -qed. - -lemma valid_range_add (k:int) w mem ptr len : - 0 <= k <= len => - valid_range w mem ptr len => - valid_range w mem (ptr + k * wsize_i w) (len - k). -proof. - move=> hk hv i hi /=. - have -> : ptr + k * wsize_i w + wsize_i w * i = ptr + wsize_i w * (k + i) by ring. - apply hv => /#. -qed. - -lemma valid_range_add_split p n w mem ptr : - 0 <= p <= n => - valid_range w mem ptr n => - valid_range w mem ptr p /\ - valid_range w mem (ptr + p * wsize_i w) (n - p). -proof. - move=> hp hv; split. - + by apply: valid_range_le hv;case hp. - by apply valid_range_add. -qed. - -(* ------------------------------------------------------------------- *) - -lemma is_valid_store8 mem sz ptr1 ptr2 w : - is_valid (storeW8 mem ptr2 w) ptr1 sz = is_valid mem ptr1 sz. -proof. - rewrite !is_validE storeW8E /allocated;congr. - rewrite eq_iff;split => h i hi. - + by rewrite -(allocated8_setE ptr2 w) h. - by rewrite allocated8_setE h. -qed. -hint simplify is_valid_store8. - -lemma is_valid_store16 mem sz ptr1 ptr2 w : - is_valid (storeW16 mem ptr2 w) ptr1 sz = is_valid mem ptr1 sz. -proof. - by rewrite !is_validE storeW16E allocated_stores. -qed. -hint simplify is_valid_store16. - -lemma is_valid_store32 mem sz ptr1 ptr2 w : - is_valid (storeW32 mem ptr2 w) ptr1 sz = is_valid mem ptr1 sz. -proof. - by rewrite !is_validE storeW32E allocated_stores. -qed. -hint simplify is_valid_store32. - -lemma is_valid_store64 mem sz ptr1 ptr2 w : - is_valid (storeW64 mem ptr2 w) ptr1 sz = is_valid mem ptr1 sz. -proof. - by rewrite !is_validE storeW64E allocated_stores. -qed. -hint simplify is_valid_store64. - -lemma is_valid_store128 mem sz ptr1 ptr2 w : - is_valid (storeW128 mem ptr2 w) ptr1 sz = is_valid mem ptr1 sz. -proof. - by rewrite !is_validE storeW128E allocated_stores. -qed. -hint simplify is_valid_store128. - -lemma is_valid_store256 mem sz ptr1 ptr2 w : - is_valid (storeW256 mem ptr2 w) ptr1 sz = is_valid mem ptr1 sz. -proof. - by rewrite !is_validE storeW256E allocated_stores. -qed. -hint simplify is_valid_store256. diff --git a/eclib/JModel_x86.ec b/eclib/JModel_x86.ec index 1db189676..932525322 100644 --- a/eclib/JModel_x86.ec +++ b/eclib/JModel_x86.ec @@ -1,6 +1,5 @@ (* -------------------------------------------------------------------- *) -require import AllCore BitEncoding IntDiv SmtMap Ring List StdOrder Bool. -(*---*) import CoreMap Map Ring.IntID IntOrder . +require import AllCore IntDiv List. require export JModel_common JArray JWord_array Jslh JMemory AES. diff --git a/eclib/JUtils.ec b/eclib/JUtils.ec index 081cf77be..8c2f74021 100644 --- a/eclib/JUtils.ec +++ b/eclib/JUtils.ec @@ -51,7 +51,7 @@ lemma modz_sub_carry k i d : 0 <= k < d => 0 <= i < d => k - i < 0 => by rewrite -divz_eq; ring. qed. -lemma nosmt divz_mod_mul n p i: 0 <= p => 0 <= n => +lemma divz_mod_mul n p i: 0 <= p => 0 <= n => (i %% (n*p)) %/ p = (i %/ p) %% n. proof. move=> [hp | <- //]; move=> [hn | <- //]. @@ -66,7 +66,7 @@ proof. by apply modz_cmp => /#. qed. -lemma nosmt divz_mod_div n p i: p %| n => 0 <= p => 0 <= n => +lemma divz_mod_div n p i: p %| n => 0 <= p => 0 <= n => (i %% n) %/ p = (i %/ p) %% (n%/p). proof. rewrite dvdz_eq => {2}<- hp hn;apply divz_mod_mul => //. @@ -86,7 +86,7 @@ proof. qed. (* FIXME: this is defined in IntDiv but with 0 <= i *) -lemma nosmt modz_pow2_div n p i: 0 <= p <= n => +lemma modz_pow2_div n p i: 0 <= p <= n => (i %% 2^n) %/ 2^p = (i %/ 2^p) %% 2^(n-p). proof. move=> [h1 h2];rewrite divz_mod_div. @@ -153,7 +153,7 @@ proof. by rewrite xorC xor_true. qed. lemma xor0b (b : bool) : false ^^ b = b. proof. by rewrite xorC xor_false. qed. -lemma nosmt xorK_simplify (b1 b2: bool) : b1 = b2 => b1 ^^ b2 = false. +lemma xorK_simplify (b1 b2: bool) : b1 = b2 => b1 ^^ b2 = false. proof. by move=> ->; apply xorK. qed. hint simplify (xor1b, xor_true, xor0b, xor_false)@0. @@ -266,22 +266,6 @@ op _interleave (l1 l2: 'a list) = with l1 = _::_, l2 = "[]" => l1 with l1 = a1::l1', l2 = a2::l2' => a1::a2::_interleave l1' l2'. -(* ------------------------------------------------------------------- *) -(* Safety *) - -op in_bound (x n:int) = 0 <= x /\ x < n. -op is_init (x : 'a option) = x <> None. - -lemma is_init_Some (a:'a) : is_init (Some a). -proof. done. qed. - -lemma in_bound_simplify x n : - 0 <= x < n => in_bound x n. -proof. done. qed. - -hint simplify [eqtrue] is_init_Some. -hint simplify [eqtrue] in_bound_simplify. - (* -------------------------------------------------------------------- *) lemma powm1_mod k n: diff --git a/eclib/JWord.ec b/eclib/JWord.ec index 76b8e42ed..6dd5ec3fd 100644 --- a/eclib/JWord.ec +++ b/eclib/JWord.ec @@ -479,29 +479,29 @@ proof. move=> ->;apply orwK. qed. lemma andw_invw w: andw w (invw w) = zerow. proof. by rewrite -xorw1; ring. qed. -lemma nosmt orw_xorw w1 w2: orw w1 w2 = w1 +^ w2 +^ (andw w1 w2). +lemma orw_xorw w1 w2: orw w1 w2 = w1 +^ w2 +^ (andw w1 w2). proof. apply wordP => i Hi. rewrite orE !xorE andE !map2iE //. by case: w1.[i]; case: w2.[i]. qed. -lemma nosmt andw_orwDl: left_distributive andw orw. +lemma andw_orwDl: left_distributive andw orw. proof. by move=> x y z; rewrite !orw_xorw; ring. qed. -lemma nosmt andw_orwDr: right_distributive andw orw. +lemma andw_orwDr: right_distributive andw orw. proof. by move=> x y z; rewrite !orw_xorw; ring. qed. -lemma nosmt orw_andwDl: left_distributive orw andw. +lemma orw_andwDl: left_distributive orw andw. proof. by move=> x y z; rewrite !orw_xorw; ring. qed. -lemma nosmt orw_andwDr: right_distributive orw andw. +lemma orw_andwDr: right_distributive orw andw. proof. by move=> x y z; rewrite !orw_xorw; ring. qed. @@ -1120,14 +1120,14 @@ proof. apply bound_abs; smt (le_modz to_uint_cmp gt0_pow2 modz_cmp). qed. -lemma nosmt to_uintNE w: +lemma to_uintNE w: to_uint (-w) = (modulus - to_uint w) %% modulus. proof. rewrite to_uintN. by have /= ->:= (modzMDl 1). qed. -lemma nosmt of_intNE (n:int): +lemma of_intNE (n:int): of_int (-n) = of_int (modulus - n). proof. rewrite of_intN. @@ -1154,7 +1154,7 @@ proof. by rewrite map2_w2bits bits2wK // size_map2 minrE !size_w2bits. qed. lemma map_w2bits_w2bits f w : map f (w2bits w) = w2bits (map f w). proof. by rewrite map_w2bits bits2wK 2:// size_map size_w2bits. qed. -lemma nosmt to_uintD_disjoint w1 w2: +lemma to_uintD_disjoint w1 w2: w1 `&` w2 = BitWord.zero => to_uint (w1 + w2) = to_uint w1 + to_uint w2. proof. @@ -1166,7 +1166,7 @@ apply bs2int_add_disjoint; rewrite ?size_w2bits //. by rewrite -H0 map2_w2bits_w2bits. qed. -lemma nosmt orw_disjoint w1 w2: +lemma orw_disjoint w1 w2: w1 `&` w2 = BitWord.zero => w1 `|` w2 = w1 + w2. proof. move=> H; have H0: to_uint (w1 `&` w2) = 0 by smt(to_uint0). @@ -1176,12 +1176,12 @@ move: H0; rewrite !to_uintE andE => H0. by rewrite orE -bs2int_or_add ?size_mkseq // 1:-H0 map2_w2bits_w2bits. qed. -lemma nosmt to_uint_orw_disjoint w1 w2: +lemma to_uint_orw_disjoint w1 w2: w1 `&` w2 = zero => to_uint (w1 `|` w2) = to_uint w1 + to_uint w2. proof. by move=> *; rewrite orw_disjoint // to_uintD_disjoint. qed. -lemma nosmt ule_andN0 (x y: t): +lemma ule_andN0 (x y: t): x `&` invw y = BitWord.zero => x \ule y. proof. @@ -1193,18 +1193,18 @@ rewrite !to_uintE; apply bs2int_sub_common. by rewrite map_w2bits_w2bits map2_w2bits_w2bits. qed. -lemma nosmt ule_andw x y: +lemma ule_andw x y: x `&` y \ule x. proof. rewrite andwC; apply ule_andN0. by rewrite -andwA andw_invw andw0. qed. -lemma nosmt to_uint_ule_andw (x y: t): +lemma to_uint_ule_andw (x y: t): to_uint (x `&` y) <= to_uint x. proof. have := ule_andw x y; by rewrite uleE. qed. -lemma nosmt ule_orw x y: +lemma ule_orw x y: x \ule x `|` y. proof. have {1}->: x = (x`|`y) `&` (x`|`invw y). @@ -1214,7 +1214,7 @@ have {1}->: x = (x`|`y) `&` (x`|`invw y). by apply ule_andw. qed. -lemma nosmt subw_xorw w1 w2: +lemma subw_xorw w1 w2: invw w1 `&` w2 = BitWord.zero => w1 - w2 = w1 `^` w2. proof. move=> H; have H0: to_uint (invw w1 `&` w2) = 0 by smt(to_uint0). @@ -1228,7 +1228,7 @@ rewrite -bs2int_xor_sub ?size_mkseq //. by rewrite map2_w2bits_w2bits. qed. -lemma nosmt orw_xpnd w1 w2: w1 `|` w2 = w1 - w1 `&` w2 + w2. +lemma orw_xpnd w1 w2: w1 `|` w2 = w1 - w1 `&` w2 + w2. proof. rewrite subw_xorw. by rewrite andwA (andwC (invw w1)) andw_invw and0w. @@ -1247,7 +1247,7 @@ rewrite orw_xpnd andw_invw => <-. by ring. qed. -lemma nosmt twos_compl (x: t): -x = invw x + BitWord.one. +lemma twos_compl (x: t): -x = invw x + BitWord.one. proof. apply (addrI x); rewrite addrA ones_compl onewS. by ring. @@ -1260,7 +1260,7 @@ rewrite twos_compl -orw_disjoint. by rewrite orwC orw_invw. qed. -lemma nosmt to_uint_invw w: to_uint (invw w) = max_uint - to_uint w. +lemma to_uint_invw w: to_uint (invw w) = max_uint - to_uint w. proof. rewrite -to_uint_onew -to_uintB. rewrite uleE to_uint_onew. @@ -1300,12 +1300,12 @@ qed. hint simplify masklsbE. -lemma nosmt shrl_andmaskN k w: +lemma shrl_andmaskN k w: 0 <= k => w `>>>` k `<<<` k = w `&` invw (masklsb k). proof. by move=> Hk; apply wordP => i Hi /= /#. qed. -lemma nosmt shlw_andmask k1 k2 w: +lemma shlw_andmask k1 k2 w: 0 <= k1 <= k2 < size => (w `<<<` k1) `&` masklsb k2 = (w `&` masklsb (k2-k1)) `<<<` k1. proof. @@ -1313,7 +1313,7 @@ move=> *; apply/wordP => i Hi /=; rewrite !Hi /= /min. smt(get_out). qed. -lemma nosmt andmask_shrw k1 k2 w: +lemma andmask_shrw k1 k2 w: 0 <= k2 < k1 < size => (w `&` masklsb k1) `>>>` k2 = (w `>>>` k2) `&` masklsb (k1-k2). @@ -1322,7 +1322,7 @@ move=> *; apply/wordP => i Hi /=; rewrite !Hi /min /=. smt(get_out). qed. -lemma nosmt andmask_shlw k1 k2 w: +lemma andmask_shlw k1 k2 w: 0 <= k1 < size => (w `&` masklsb k1) `<<<` k2 = (w `<<<` k2) `&` masklsb (k1+k2). @@ -1331,7 +1331,7 @@ move=> *; apply/wordP => i Hi /=; rewrite Hi /= /min. smt(get_out). qed. -lemma nosmt shrw_shlw_disjoint k1 k2 w1 w2: +lemma shrw_shlw_disjoint k1 k2 w1 w2: 0 <= k1 < size <= k1+k2 => (w1 `>>>` k1) `&` (w2 `<<<` k2) = zero. proof. @@ -1339,11 +1339,11 @@ move=> *; apply/wordP => i Hi /=; rewrite Hi /= /min. smt(get_out). qed. -lemma nosmt andmaskK k w: +lemma andmaskK k w: size <= k => w `&` masklsb k = w. proof. by move=> *; apply/wordP => i Hi /= /#. qed. -lemma nosmt shrw_andmaskK k1 k2 w: +lemma shrw_andmaskK k1 k2 w: 0 <= k1 < size <= (k1+k2)%Int => (w `>>>` k1) `&` masklsb k2 = (w `>>>` k1). proof. @@ -1356,12 +1356,12 @@ lemma mask_and_mask k1 k2: (masklsb k1 `&` masklsb k2) = masklsb (min k1 k2). proof. by move=> *; apply/wordP => i Hi /= /#. qed. -lemma nosmt shrw_shlw_shlw k1 k2 x: +lemma shrw_shlw_shlw k1 k2 x: 0 <= k1 < k2 => x `>>>` k1 `<<<` k2 = (x `&` invw (masklsb k1)) `<<<` (k2-k1). proof. by move=> *; apply/wordP => i Hi /= /#. qed. -lemma nosmt shrw_shlw_shrw k1 k2 x: +lemma shrw_shlw_shrw k1 k2 x: 0 <= k2 <= k1 < size => x `>>>` k1 `<<<` k2 = (x `&` invw (masklsb k1)) `>>>` (k1-k2). proof. @@ -1369,7 +1369,7 @@ move=> *; apply/wordP => i Hi /=; rewrite !Hi /= /min. smt(get_out). qed. -lemma nosmt shlw_shrw_shlw k1 k2 x: +lemma shlw_shrw_shlw k1 k2 x: 0 <= k2 <= k1 < size => x `<<<` k1 `>>>` k2 = (x `&` masklsb (size-k1)) `<<<` (k1-k2). proof. @@ -1377,12 +1377,12 @@ move=> *; apply/wordP => i Hi /=; rewrite !Hi /= /min. smt(get_out). qed. -lemma nosmt shlw_shrw_shrw k1 k2 x: +lemma shlw_shrw_shrw k1 k2 x: 0 <= k1 < k2 < size => x `<<<` k1 `>>>` k2 = (x `&` masklsb (size-k1)) `>>>` (k2-k1). proof. by move=> *; apply/wordP => i Hi /=; rewrite !Hi /= /#. qed. -lemma nosmt splitwE k w: +lemma splitwE k w: 0 <= k => to_uint w = to_uint (w `&` masklsb k) + 2^k * to_uint (w `>>>` k). proof. @@ -1392,7 +1392,7 @@ qed. op splitBits k w = (w `&` masklsb k, w `>>>` k). -lemma nosmt splitBits_disjoint k w: +lemma splitBits_disjoint k w: 0 <= k => (splitBits k w).`1 `&` ((splitBits k w).`2 `<<<` k) = BitWord.zero. proof. @@ -1400,7 +1400,7 @@ move => *; rewrite /splitBits /= shrl_andmaskN //. by rewrite andwA -(andwA w) (andwC _ w) andwA andwK -andwA andw_invw andw0. qed. -lemma nosmt to_uint_splitBits k w: +lemma to_uint_splitBits k w: 0 <= k => to_uint (splitBits k w).`1 + 2^k * to_uint (splitBits k w).`2 = to_uint w. proof. by move=> ?; rewrite eq_sym (splitwE k w). qed. @@ -1416,14 +1416,14 @@ rewrite /splitMask /=. by rewrite (andwC w) -andwA (andwA w) andwK (andwC w) andwA andw_invw and0w. qed. -lemma nosmt splitMask_add mask w: +lemma splitMask_add mask w: (splitMask mask w).`1 + (splitMask mask w).`2 = w. proof. rewrite -orw_disjoint; first by apply (splitMask_and0 mask w). by rewrite /splitMask /= !(andwC w) -andw_orwDl orw_invw and1w. qed. -lemma nosmt splitAtP k w: +lemma splitAtP k w: 0 <= k <= size => to_uint (splitAt k w).`1 = to_uint w %% 2^k /\ to_uint (splitAt k w).`2 = 2^k * (to_uint w %/ 2^k). @@ -2196,7 +2196,7 @@ abstract theory W_WS. smt (ler_weexpn2l le_size WS.gt0_size). qed. - lemma nosmt zeroextu'BE (x: WS.t) : + lemma zeroextu'BE (x: WS.t) : zeroextu'B x = pack'R_t (Pack.init (fun i => if i = 0 then x else WS.of_int 0)). proof. apply/wordP => i h. diff --git a/opam b/opam index 1621cd019..0ed0ecaf9 100644 --- a/opam +++ b/opam @@ -25,7 +25,7 @@ depends: [ "apron" {>= "v0.9.12"} "conf-ppl" "yojson" {>= "1.6.0"} - "angstrom" + "angstrom" {>= "0.14.0"} "ocamlfind" { build } "coq" {>= "8.18.0" & < "8.20~"} "coq-mathcomp-ssreflect" {>= "2.0" & < "2.3~"} diff --git a/proofs/arch/asm_gen_proof.v b/proofs/arch/asm_gen_proof.v index b0c6fdbec..1aa7e523c 100644 --- a/proofs/arch/asm_gen_proof.v +++ b/proofs/arch/asm_gen_proof.v @@ -429,7 +429,7 @@ Lemma word_uincl_word_extend sz sz' szo (w: word sz) (w': word sz') fl (old:word word_uincl w w' → word_uincl w (word_extend fl old w'). Proof. - move=> hsz' /dup [] /andP[hsz_sz' /eqP ->] h. + move=> hsz' /[dup] /andP[hsz_sz' /eqP ->] h. case: fl. + (* MSB_CLEAR *) rewrite word_extend_CLEAR; apply: (word_uincl_trans h). @@ -1002,7 +1002,7 @@ Lemma exec_desc_desc_op op asm_args s : exec_instr_op (instr_desc op) asm_args s = exec_instr_op (instr_desc_op op.2) asm_args s. Proof. case: op => -[ws |] //= op. - case: eqP => //= hclear /dup[] hcheck /exclude_mem_correct [hc hnaddr]. + case: eqP => //= hclear /[dup] hcheck /exclude_mem_correct [hc hnaddr]. rewrite /exec_instr_op /= /eval_instr_op /= hcheck hc hclear /=. case heq : eval_args_in => [vargs | ] //=. rewrite app_sopn_apply_lprod. @@ -1229,7 +1229,7 @@ Lemma assemble_c_find_label (lc : lcmd) (ac : asm_code) lbl p : -> linear.find_label lbl lc = ok p -> arch_sem.find_label lbl ac = ok (asm_pos p lc). Proof. - move=> /dup [] /assemble_c_find_is_label -/(_ lbl). + move=> /[dup] /assemble_c_find_is_label -/(_ lbl). rewrite /label_pos /linear.find_label /arch_sem.find_label => <- hac. case: ltnP => //;rewrite -has_find /asm_pos => hlt [<-]. move: hac; rewrite /assemble_c; t_xrbindP => li hli <-. diff --git a/proofs/arch/label.v b/proofs/arch/label.v index f09fa3408..013cfad27 100644 --- a/proofs/arch/label.v +++ b/proofs/arch/label.v @@ -54,8 +54,8 @@ Section CONSISTENCY. else None). exists (λ dom p, oseq.onth dom (Z.to_nat (wunsigned p))). move => dom lbl /ZleP small_dom. - rewrite -has_pred1 => /dup[] => lbl_in_dom. - rewrite has_find => /= /dup[] /ltP found -> /=. + rewrite -has_pred1 => /[dup] => lbl_in_dom. + rewrite has_find => /= /[dup] /ltP found -> /=. rewrite wunsigned_repr_small; last first. - move: (find _ _) (size _) small_dom found => n m; Lia.lia. rewrite Nat2Z.id oseq.onth_nth. diff --git a/proofs/compiler/allocation_proof.v b/proofs/compiler/allocation_proof.v index bb2f2f239..ffeb90568 100644 --- a/proofs/compiler/allocation_proof.v +++ b/proofs/compiler/allocation_proof.v @@ -167,7 +167,8 @@ Section CHECK_EP. rewrite -/(sem_pexprs_aux _ _ _ _). rewrite -/(sem_pexprs _ _ _ _). move: h => /(_ _ _ _ ok_vs1) [] vs2 [] -> hs /=. - by have [] := vuincl_sem_opN ok_v1 hs; eauto. + rewrite (vuincl_sem_opN hs ok_v1). + by eexists; split; first by reflexivity. move => t e He e11 He11 e12 He12 [] // t' e2 e21 e22 r re vm1. t_xrbindP => r1 r' /eqP <- /He Hr' /He11 Hr1 /He12 Hr2 {He He11 He12}. move=> /Hr'{Hr'}[] /Hr1{Hr1}[] /Hr2{Hr2}[] Hre Hs2 Hs1 Hs;split=>// scs m v1. diff --git a/proofs/compiler/arm_params_proof.v b/proofs/compiler/arm_params_proof.v index e5942a432..bd720edb2 100644 --- a/proofs/compiler/arm_params_proof.v +++ b/proofs/compiler/arm_params_proof.v @@ -48,20 +48,21 @@ Unset Printing Implicit Defensive. Section Section. +#[local] Existing Instance withsubword. +#[local] Existing Instance direct_c. + Context {atoI : arch_toIdent} {syscall_state : Type} {sc_sem : syscall_sem syscall_state} {call_conv : calling_convention}. -#[local] Existing Instance withsubword. - (* ------------------------------------------------------------------------ *) (* Stack alloc hypotheses. *) Section STACK_ALLOC. -Context {dc : DirectCall} (P': sprog). +Context (P': sprog). Lemma arm_mov_ofsP s1 e i x tag ofs w vpk s2 ins : p_globs P' = [::] @@ -132,7 +133,7 @@ Qed. End STACK_ALLOC. -Definition arm_hsaparams {dc : DirectCall} : +Definition arm_hsaparams : h_stack_alloc_params (ap_sap arm_params) := {| mov_ofsP := arm_mov_ofsP; @@ -311,7 +312,6 @@ Proof. exists LR; exact: to_identK. Qed. (* Lowering hypotheses. *) Lemma arm_lower_callP - { dc : DirectCall } (pT : progT) (sCP : semCallParams) (p : prog) @@ -337,7 +337,7 @@ Proof. exact: lower_callP. Qed. -Definition arm_hloparams { dc : DirectCall } : h_lowering_params (ap_lop arm_params) := +Definition arm_hloparams : h_lowering_params (ap_lop arm_params) := {| hlop_lower_callP := arm_lower_callP; |}. @@ -927,7 +927,7 @@ Qed. (* ------------------------------------------------------------------------ *) -Definition arm_h_params {dc : DirectCall} : h_architecture_params arm_params := +Definition arm_h_params : h_architecture_params arm_params := {| hap_hsap := arm_hsaparams; hap_hlip := arm_hliparams; diff --git a/proofs/compiler/array_copy.v b/proofs/compiler/array_copy.v index cce188c0f..8040875a0 100644 --- a/proofs/compiler/array_copy.v +++ b/proofs/compiler/array_copy.v @@ -27,10 +27,10 @@ End E. Section Section. Context `{asmop:asmOp}. -Context - (fresh_counter: Ident.ident) - (fresh_temporary: wsize → Ident.ident) -. +Context (fresh_var_ident: v_kind → string → stype → Ident.ident). + +Let fresh_counter : Ident.ident := fresh_var_ident Inline "i__copy" sint. +Let fresh_temporary (ws: wsize) : Ident.ident := fresh_var_ident (Reg (Normal, Direct)) "tmp" (sword ws). (** Replaces each x = #copy(y) with the following: @@ -74,8 +74,8 @@ Definition array_copy ii (x: var_i) (ws: wsize) (n: positive) (y: gvar) := [seq MkI ii i | i <- (if needs_temporary x y.(gv) then indirect_copy else direct_copy) ws x y ei ]) ]. -Definition array_copy_c (array_copy_i : instr -> cexec cmd) (c:cmd) : cexec cmd := - Let cs := mapM array_copy_i c in +Definition array_copy_c V (array_copy_i : Sv.t -> instr -> cexec cmd) (c:cmd) : cexec cmd := + Let cs := mapM (array_copy_i V) c in ok (flatten cs). Definition is_copy o := @@ -84,72 +84,81 @@ Definition is_copy o := | _ => None end. -Definition is_Pvar es := - match es with - | [:: Pvar x] => Some x - | _ => None - end. - -Definition is_Lvar xs := - match xs with - | [:: Lvar x] => Some x - | _ => None - end. +Definition get_source V ii (es: pexprs) : cexec (gvar * cmd) := + if es is [:: e ] then + match e with + | Pvar x => ok (x, [::]) + | Psub aa ws len x ofs => + let ty := sarr (Z.to_pos (arr_size ws len)) in + let y_name := fresh_var_ident (Ident.id_kind x.(gv).(v_var).(vname)) "src" ty in + let y_var := {| v_var := Var ty y_name ; v_info := var_info_of_ii ii |} in + Let _ := assert (~~ Sv.mem y_var V) + (pp_internal_error_s_at E.pass ii "fresh source not fresh") in + let y := {| gs := Slocal ; gv := y_var |} in + ok (y, [:: MkI ii (Cassgn (Lvar y_var) AT_rename ty e) ]) + | _ => Error (pp_internal_error_s_at E.pass ii "unexpected source for copy ") + end + else Error (pp_internal_error_s_at E.pass ii "copy should have a single source"). + +Definition get_target V ii (xs: lvals) : cexec (var_i * cmd) := + if xs is [:: d ] then + match d with + | Lvar x => ok (x, [::]) + | Lasub aa ws len x ofs => + let ty := sarr (Z.to_pos (arr_size ws len)) in + let x_name := fresh_var_ident (Ident.id_kind x.(v_var).(vname)) "dst" ty in + let x_var := {| v_var := Var ty x_name ; v_info := var_info_of_ii ii |} in + Let _ := assert (~~ Sv.mem x_var V) + (pp_internal_error_s_at E.pass ii "fresh destination not fresh") in + let x := {| gs := Slocal ; gv := x_var |} in + ok (x_var, [:: MkI ii (Cassgn d AT_rename ty (Pvar x)) ]) + | _ => Error (pp_internal_error_s_at E.pass ii "unexpected destination for copy ") + end + else Error (pp_internal_error_s_at E.pass ii "copy should have a single destination"). -Fixpoint array_copy_i (i:instr) : cexec cmd := +Fixpoint array_copy_i V (i:instr) : cexec cmd := let:(MkI ii id) := i in match id with | Cassgn _ _ _ _ => ok [:: i] | Copn xs _ o es => match is_copy o with | Some (ws, n) => - match is_Pvar es with - | Some y => - match is_Lvar xs with - | Some x => - (* FIXME error msg *) + Let: (y, pre) := get_source V ii es in + Let: (x, post) := get_target V ii xs in Let _ := assert (vtype x == sarr (Z.to_pos (arr_size ws n))) (pp_internal_error_s_at E.pass ii "bad type for copy") in - ok (array_copy ii x ws n y) - | None => - (* FIXME error msg *) - Error (pp_internal_error_s_at E.pass ii "copy destination is not a var") - end - | None => - (* FIXME error msg *) - Error (pp_internal_error_s_at E.pass ii "copy source is not a var") - end + ok (pre ++ array_copy ii x ws n y ++ post) | _ => ok [:: i] end | Csyscall _ _ _ => ok [:: i] | Cassert _ _ _ => ok [:: i] | Cif e c1 c2 => - Let c1 := array_copy_c array_copy_i c1 in - Let c2 := array_copy_c array_copy_i c2 in + Let c1 := array_copy_c V array_copy_i c1 in + Let c2 := array_copy_c V array_copy_i c2 in ok [:: MkI ii (Cif e c1 c2)] | Cfor i r c => - Let c := array_copy_c array_copy_i c in + Let c := array_copy_c V array_copy_i c in ok [:: MkI ii (Cfor i r c)] | Cwhile a c1 e c2 => - Let c1 := array_copy_c array_copy_i c1 in - Let c2 := array_copy_c array_copy_i c2 in + Let c1 := array_copy_c V array_copy_i c1 in + Let c2 := array_copy_c V array_copy_i c2 in ok [:: MkI ii (Cwhile a c1 e c2)] | Ccall _ _ _ => ok [:: i] end. Context {pT: progT}. -Definition array_copy_fd (f:fundef) := +Definition array_copy_fd V (f:fundef) := let 'MkFun fi ci tyin params c tyout res ev := f in - Let c := array_copy_c array_copy_i c in + Let c := array_copy_c V array_copy_i c in ok (MkFun fi ci tyin params c tyout res ev). Definition array_copy_prog (p:prog) := let V := vars_p (p_funcs p) in let fresh := Sv.add {| vtype := sint ; vname := fresh_counter |} (sv_of_list tmp_var wsizes) in Let _ := assert (disjoint fresh V) E.error in - Let fds := map_cfprog array_copy_fd (p_funcs p) in + Let fds := map_cfprog (array_copy_fd V) (p_funcs p) in ok {| p_funcs := fds; p_globs := p_globs p; p_extra := p_extra p|}. diff --git a/proofs/compiler/array_copy_proof.v b/proofs/compiler/array_copy_proof.v index 69c0d8d17..79a6e0998 100644 --- a/proofs/compiler/array_copy_proof.v +++ b/proofs/compiler/array_copy_proof.v @@ -25,16 +25,16 @@ Context {pT : progT} {sCP : semCallParams}. -Context - (fresh_counter: Ident.ident) - (fresh_temporary: wsize → Ident.ident) -. +Context (fresh_var_ident: v_kind → string → stype → Ident.ident). + +Let fresh_counter : Ident.ident := fresh_var_ident Inline "i__copy" sint. +Let fresh_temporary (ws: wsize) : Ident.ident := fresh_var_ident (Reg (Normal, Direct)) "tmp" (sword ws). Context (p1 p2: prog) (ev: extra_val_t). Notation gd := (p_globs p1). -Hypothesis Hp : array_copy_prog fresh_counter fresh_temporary p1 = ok p2. +Hypothesis Hp : array_copy_prog fresh_var_ident p1 = ok p2. Local Definition vi := {| vtype := sint ; vname := fresh_counter |}. @@ -42,19 +42,22 @@ Local Definition vi := Lemma eq_globs : gd = p_globs p2. Proof. by move: Hp; rewrite /array_copy_prog; t_xrbindP => ??? <-. Qed. +Let X := vars_p (p_funcs p1). + Lemma all_checked fn fd1 : get_fundef (p_funcs p1) fn = Some fd1 -> - exists2 fd2, - array_copy_fd fresh_counter fresh_temporary fd1 = ok fd2 & + exists2 fd2, + array_copy_fd fresh_var_ident X fd1 = ok fd2 & get_fundef (p_funcs p2) fn = Some fd2. Proof. move: Hp; rewrite /array_copy_prog; t_xrbindP => h fds h1 <- hf. apply: (get_map_cfprog_gen h1 hf). Qed. -Let X := vars_p (p_funcs p1). +Definition not_tmp (D: Sv.t) : Prop := + [/\ ¬ Sv.In vi D & ∀ ws, ¬ Sv.In (tmp_var fresh_var_ident ws) D ]. -Lemma freshX : ~ Sv.In vi X ∧ ∀ ws, ~ Sv.In (tmp_var fresh_temporary ws) X. +Lemma freshX : not_tmp X. Proof. move: Hp; rewrite /array_copy_prog; t_xrbindP => /disjointP H _ _ _; split => [ | ws ]; apply: H. - exact: SvD.F.add_1. @@ -69,7 +72,7 @@ Proof. by have [] := freshX. Qed. Let Pi s1 (i1:instr) s2 := Sv.Subset (vars_I i1) X -> - forall i2, array_copy_i fresh_counter fresh_temporary i1 = ok i2 -> + forall i2, array_copy_i fresh_var_ident X i1 = ok i2 -> forall vm1, evm s1 <=[X] vm1 -> exists2 vm2, evm s2 <=[X] vm2 & sem p2 ev (with_vm s1 vm1) i2 (with_vm s2 vm2). @@ -78,14 +81,14 @@ Let Pi_r s1 (i:instr_r) s2 := forall ii, Pi s1 (MkI ii i) s2. Let Pc s1 (c1:cmd) s2 := Sv.Subset (vars_c c1) X -> - forall c2, array_copy_c (array_copy_i fresh_counter fresh_temporary) c1 = ok c2 -> + forall c2, array_copy_c X (array_copy_i fresh_var_ident) c1 = ok c2 -> forall vm1, evm s1 <=[X] vm1 -> exists2 vm2, evm s2 <=[X] vm2 & sem p2 ev (with_vm s1 vm1) c2 (with_vm s2 vm2). Let Pfor (i:var_i) vs s1 c1 s2 := Sv.Subset (Sv.add i (vars_c c1)) X -> - forall c2, array_copy_c (array_copy_i fresh_counter fresh_temporary) c1 = ok c2 -> + forall c2, array_copy_c X (array_copy_i fresh_var_ident) c1 = ok c2 -> forall vm1, evm s1 <=[X] vm1 -> exists2 vm2, evm s2 <=[X] vm2 & sem_for p2 ev i vs (with_vm s1 vm1) c2 (with_vm s2 vm2). @@ -123,48 +126,98 @@ Qed. Lemma is_copyP o ws n : is_copy o = Some(ws,n) -> o = sopn_copy ws n. Proof. by case: o => // -[] // ?? [-> ->]. Qed. -Lemma is_PvarP es y : is_Pvar es = Some y -> es = [::Pvar y]. -Proof. by case: es => // -[] // ? [] // [->]. Qed. - -Lemma is_LvarP xs x : is_Lvar xs = Some x -> xs = [::Lvar x]. -Proof. by case: xs => //= -[] // ? [] // [->]. Qed. +Opaque arr_size. + +Lemma get_sourceP ii es src pfx s vm ves : + get_source fresh_var_ident X ii es = ok (src, pfx) → + sem_pexprs true gd s es = ok ves → + Sv.Subset (read_es es) X → + evm s <=[X] vm → + not_tmp (read_gvar src) ∧ + exists2 v, + ves = [:: v ] & + ∃ vm1, + [/\ + sem p2 ev (with_vm s vm) pfx (with_vm s vm1), + evm s <=[X] vm1 & + exists2 v', get_gvar true gd vm1 src = ok v' & value_uincl v v' ]. +Proof. + clear -Hp. + case: es => // e [] //. + case: e => //. + - move => x /ok_inj[] ? <- /=; subst x. + t_xrbindP => v ok_v <-{ves} hX hvm; split. + + move: freshX hX; rewrite /not_tmp read_es_cons read_e_var; clear. + case => ? htmp ?; split; first SvD.fsetdec. + by move => ws; have := htmp ws; SvD.fsetdec. + exists v; first by []. + exists vm; split. + + exact: Eskip. + + exact: hvm. + move: ok_v; rewrite /get_gvar. + case: src hX => src []; last by exists v. + rewrite read_es_cons read_e_var /read_gvar /get_var /= => hX. + have {}hX : Sv.In src X by SvD.fsetdec. + t_xrbindP => ok_src <-{v}. + have {hvm hX} hle := hvm _ hX. + exists vm.[src]; last exact: hle. + by have /= -> := value_uincl_defined (wdb := false) hle ok_src. + move => aa ws len [] x xs ofs /=. + set y := {| vtype := _ |}. + t_xrbindP => /Sv_memP hyX ? ? z; subst src pfx. + rewrite/on_arr_var; t_xrbindP => - [] // len' t ok_t. + t_xrbindP => iofs vofs ok_vofs /to_intI ? sub ok_sub ? ?; subst vofs ves z. + rewrite read_es_cons read_e_Psub => hX hvm. + split. + - by split => [ | ?] /Sv.singleton_spec. + exists (Varr sub); first by []. + have : exists2 t' : WArray.array len', get_gvar true gd vm {| gv := x; gs := xs |} = ok (Varr t') & WArray.uincl t t'. + - case: xs ok_t hX; last by exists t. + rewrite /get_gvar /get_var /read_gvar /=. + t_xrbindP => ok_x ok_t hX. + have {} hX : Sv.In x X by SvD.fsetdec. + have := hvm _ hX. + rewrite ok_t => /value_uinclE[] t' -> htt'. + by exists t'. + case => t' ok_t' htt'. + have [ sub' ok_sub' sub_sub' ] := WArray.uincl_get_sub htt' ok_sub. + have : evm s <=[read_e ofs] vm by (apply: uincl_onI hvm; SvD.fsetdec). + move => /sem_pexpr_uincl_on /(_ ok_vofs) [] vofs' ok_vofs' /value_uinclE ?; subst vofs'. + eexists; split. + - apply: sem_seq1; constructor; apply: Eassgn. + + rewrite /= -eq_globs ok_t' /= ok_vofs' /= ok_sub' /=; reflexivity. + + rewrite /truncate_val /= WArray.castK /=; reflexivity. + rewrite /= /write_var /= /set_var /= eqxx /= with_vm_idem; reflexivity. + - apply: uincl_on_set_r; first by []. + apply: uincl_onI hvm; clear -hyX; SvD.fsetdec. + exists (Varr sub'); last by []. + by rewrite /get_gvar /= /get_var /= Vm.setP_eq /= eqxx. +Qed. -Local Lemma Hopn : sem_Ind_opn p1 Pi_r. +Lemma array_copyP ii (dst: var_i) ws n src s vm1 (t t': WArray.array (Z.to_pos (arr_size ws n))) : + vtype dst = sarr (Z.to_pos (arr_size ws n)) → + not_tmp (read_gvar src) → + evm s <=[X] vm1 → + get_gvar true gd vm1 src = ok (Varr t) → + WArray.copy t = ok t' → + ∃ vm2, [/\ + evm s <=[Sv.remove dst X] vm2, + (exists2 a : WArray.array (Z.to_pos (arr_size ws n)), vm2.[dst] = Varr a & WArray.uincl t' a) & + sem p2 ev (with_vm s vm1) (array_copy fresh_var_ident ii dst ws n src) (with_vm s vm2) + ]. Proof. - Opaque arr_size. - move => s1 s2 t o xs es; rewrite /sem_sopn; t_xrbindP => vs ves hves ho hw ii. - rewrite /Pi vars_I_opn /vars_lvals => hsub /=. - case: is_copy (@is_copyP o); last first. - + move=> _ _ [<-] vm1 hvm1. - have [|ves' hves' uves]:= sem_pexprs_uincl_on (uincl_onI _ hvm1) hves; first by SvD.fsetdec. - have [ vs' ho' vs_vs' ] := vuincl_exec_opn uves ho. - have [| vm2 hvm2 hw']:= write_lvals_uincl_on _ vs_vs' hw hvm1; first by SvD.fsetdec. - exists vm2; first by apply: uincl_onI hvm2; SvD.fsetdec. - apply sem_seq1; constructor; econstructor; eauto. - by rewrite /sem_sopn -eq_globs hves' /= ho' /=. - move=> [ws n] /(_ _ _ refl_equal) ?; subst o. - case: is_Pvar (@is_PvarP es) => // y /(_ _ refl_equal) ?; subst es. - case: is_Lvar (@is_LvarP xs) => // x /(_ _ refl_equal) ?; subst xs. - t_xrbindP => _ /eqP htx <- vm1 hvm1. - move: htx hsub hves hw. - rewrite read_rvs_cons vrvs_cons /vrvs read_rvs_nil read_es_cons /read_es /=. - rewrite !(SvP.MP.empty_union_2 _ Sv.empty_spec) !(SvP.MP.empty_union_1 _ Sv.empty_spec). - case: x => -[] /= _ xn xi ->. - rewrite /array_copy; set len := Z.to_pos _. - set vx := {| vname := xn |}; set x := {|v_var := vx|}; set i := {| v_var := _ |} => hsub. - t_xrbindP => vy hy ?; subst ves. - move: ho; rewrite /exec_sopn /=; t_xrbindP => tx ty hty. - rewrite /sopn_sem /= => hcopy ?; subst vs; t_xrbindP => s hw ?; subst s. - have [|v1 hv1 /value_uinclE uv1] := sem_pexpr_uincl_on (vm2:= vm1) (e:= Pvar y) _ hy. - + by apply: uincl_onI hvm1;SvD.fsetdec. - have ? := to_arrI hty; subst vy. - case: uv1 => [ty1 ? ut]; subst v1. + move: t t'. + set len := Z.to_pos _. + case: dst => -[] _ dst dsti ty t' /= -> hsub hvm ok_t hcopy. + set x := {| vtype := _ |}. + rewrite /array_copy. + set i := {| v_var := {| vtype := sint |} |}. set ipre := if _ then _ else _. set cond := needs_temporary _ _. set c := map (MkI ii) _. - have [vm1' [hvm1' [tx0 htx0]] hipre] : exists2 vm1', - vm1 <=[Sv.union (read_e y) (Sv.remove x X)] vm1' /\ exists tx, vm1'.[x] = @Varr len tx & - sem_I p2 ev (with_vm s1 vm1) (MkI ii ipre) (with_vm s1 vm1'). + have [vm1' [hvm1' [tx0 htx0]] hipre] : exists2 vm1', + vm1 <=[Sv.union (read_gvar src) (Sv.remove x X)] vm1' /\ exists tx, vm1'.[x] = @Varr len tx & + sem_I p2 ev (with_vm s vm1) (MkI ii ipre) (with_vm s vm1'). + rewrite /ipre; case: ifPn => hxy. + exists vm1; last by constructor; econstructor. split; first by []. @@ -172,8 +225,8 @@ Proof. exists (vm1.[x <- Varr (WArray.empty len)]). + split; last by rewrite Vm.setP_eq /= eqxx; eauto. move=> z hz; rewrite Vm.setP_neq //; apply /eqP => heq; subst z. - have : Sv.In x (read_e y) by SvD.fsetdec. - by case/norP: hxy; rewrite read_e_var /eq_gvar /= /read_gvar; case: (y) => /= vy [/= /eqP | /=]; SvD.fsetdec. + have : Sv.In x (read_gvar src) by SvD.fsetdec. + by case/norP: hxy; rewrite /eq_gvar /= /read_gvar; case: (src) => /= vy [/= /eqP | /=]; SvD.fsetdec. constructor; apply: Eassgn => //=; first by rewrite /truncate_val /= WArray.castK. by rewrite write_var_eq_type. move: hcopy; rewrite /WArray.copy -/len => /(WArray.fcopy_uincl (WArray.uincl_empty tx0 erefl)) @@ -181,13 +234,13 @@ Proof. have : forall (j:Z), 0 <= j -> j <= n -> forall vm1' (tx0:WArray.array len), - vm1 <=[Sv.union (read_e y) (Sv.remove x X)] vm1' -> + vm1 <=[Sv.union (read_gvar src) (Sv.remove x X)] vm1' -> vm1'.[x] = Varr tx0 -> WArray.fcopy ws ty tx0 (Zpos n - j) j = ok tx' -> exists2 vm2, - (vm1 <=[Sv.union (read_e y) (Sv.remove x X)] vm2 /\ vm2.[x] = Varr tx') & - sem_for p2 ev i (ziota (Zpos n - j) j) (with_vm s1 vm1') c (with_vm s1 vm2). - + move=> {hy vm1' hvm1' htx0 hipre hcopy hutx tx0 tx hw}. + (vm1 <=[Sv.union (read_gvar src) (Sv.remove x X)] vm2 /\ vm2.[x] = Varr tx') & + sem_for p2 ev i (ziota (Zpos n - j) j) (with_vm s vm1') c (with_vm s vm2). + + clear -fresh_counter fresh_temporary ok_t Hp hsub ok_t. apply: natlike_ind => [ | j hj hrec] hjn vm1' tx hvm1' hx. + by rewrite /WArray.fcopy ziota0 /= => -[?]; subst tx; exists vm1' => //; apply: EForDone. Opaque Z.sub. @@ -197,40 +250,41 @@ Proof. set tmp := {| vtype := sword ws; vname := fresh_temporary ws |}. have [] := hrec _ ((if cond then vm2'.[tmp <- Vword w] else vm2').[x <- Varr tx1]) tx1 => //. + by lia. - + rewrite read_e_var; move=> z hz. - case: (v_var x =P z) => hxz. + + move=> z hz. + case: (x =P z) => hxz. + subst z; rewrite Vm.setP_eq. - have [hxy hyl]: v_var (gv y) = v_var x /\ is_lvar y. + have [hxy hyl]: v_var (gv src) = x /\ is_lvar src. + by move: hz; rewrite /read_gvar; case: ifP => ?; first split => //; SvD.fsetdec. - move: hv1; rewrite /= /get_gvar hyl /get_gvar hxy /get_var; t_xrbindP => _ heq. + move: ok_t; rewrite /= /get_gvar hyl /get_gvar hxy /get_var; t_xrbindP => _ heq. rewrite heq /len eqxx; split => //. - move: hvm1'; rewrite read_e_var => /(_ _ hz) /=; rewrite hx heq /= => hu k w8. + move: hvm1' => /(_ _ hz) /=; rewrite hx heq /= => hu k w8. case: (hu) => _ h /h hw8; rewrite (write_read8 hset) /=. rewrite WArray.subE; case: andP => //; rewrite !zify => hb. - have [_ htxy] := WArray.uincl_trans ut hu. - have [ _ /(_ _ hb) -/htxy <-] := read_read8 hget. - by rewrite -hw8 WArray.addE /mk_scale; f_equal; ring. + have [ _ /(_ _ hb) ] := read_read8 hget. + case: hu => _ hu /hu <-. + by rewrite -hw8 WArray.addE /mk_scale; f_equal; ring. rewrite Vm.setP_neq; last by apply /eqP. have i_neq_z : v_var i != z. - + by apply /eqP; move: viX hsub hz; rewrite /vi read_e_var /=; SvD.fsetdec. - have ? : value_uincl vm1.[z] vm1'.[z] by apply: hvm1'; rewrite read_e_var. + + by apply /eqP; move: viX (proj1 hsub) hz; rewrite /vi /fresh_counter /=; SvD.fsetdec. + have ? : value_uincl vm1.[z] vm1'.[z] by apply: hvm1'. case: {c hrec} cond; rewrite !Vm.setP_neq //. - apply/eqP => ?; move: (proj2 freshX ws) hsub hz; subst z. - clear; rewrite read_e_var /tmp_var /=; SvD.fsetdec. + apply/eqP => ?; move: (proj2 freshX ws) (proj2 hsub ws) hz; subst z. + clear; rewrite /tmp_var /tmp /fresh_temporary /=; SvD.fsetdec. + by rewrite Vm.setP_eq /= eqxx. move=> vm2 h1 h2; exists vm2 => //. - apply: (EForOne (s1' := with_vm s1 vm1'.[i <- Vint (n - Z.succ j)])) h2. + apply: (EForOne (s1' := with_vm s vm1'.[i <- Vint (n - Z.succ j)])) h2. + by rewrite write_var_eq_type. - have fresh_not_y : {| vtype := sint; vname := fresh_counter |} ≠ gv y. - + by move=> heqy; move: hv1 => /= /type_of_get_gvar /= /compat_typeEl; rewrite -heqy. - case: (sem_pexpr_uincl_on (vm2 := vm1') _ hv1). - + by apply: uincl_onI hvm1'; SvD.fsetdec. + have fresh_not_y : {| vtype := sint; vname := fresh_counter |} ≠ gv src. + + by move=> heqy; move: ok_t => /= /type_of_get_gvar /= /compat_typeEl; rewrite -heqy. + have! := (ok_t : sem_pexpr true gd (with_vm s vm1) (Pvar src) = ok (Varr ty)). + case/(sem_pexpr_uincl_on (vm2 := vm1')). + + apply: uincl_onI hvm1'; rewrite read_e_var; clear; SvD.fsetdec. move=> _v hv /value_uinclE [yv ? hty']; subst _v. subst c; case: {hrec} cond. { apply: Eseq; last apply: sem_seq1; constructor; apply: Eassgn. + rewrite /= get_gvar_neq //. rewrite -eq_globs; move: hv => /= => -> /=. - by rewrite (@get_gvar_eq _ _ _ (mk_lvar i)) //= (WArray.uincl_get (WArray.uincl_trans ut hty') hget). + by rewrite (@get_gvar_eq _ _ _ (mk_lvar i)) //= (WArray.uincl_get hty' hget). + by rewrite /truncate_val /= truncate_word_u. + by rewrite /= write_var_eq_type. + by rewrite /mk_lvar /= /get_gvar get_var_eq /= cmp_le_refl orbT. @@ -242,23 +296,104 @@ Proof. apply: Eassgn. + rewrite /= get_gvar_neq //. rewrite -eq_globs; move: hv => /= => -> /=. - by rewrite (@get_gvar_eq _ _ _ (mk_lvar i)) //= (WArray.uincl_get (WArray.uincl_trans ut hty') hget). + by rewrite (@get_gvar_eq _ _ _ (mk_lvar i)) //= (WArray.uincl_get hty' hget). + by rewrite /truncate_val /= truncate_word_u. rewrite /= get_var_neq //= /get_var hx /= (@get_gvar_eq _ _ _ (mk_lvar i)) //= truncate_word_u /=. by rewrite hset /= write_var_eq_type. move=> /(_ n _ _ vm1' tx0 hvm1' htx0) [] => //;first by lia. + by rewrite Z.sub_diag. - rewrite Z.sub_diag => vm2 [] hvm2 htx' hfor; exists vm2. - + move=> z hz; case: (v_var x =P z) => [<- | hne]. - + move: hw; rewrite htx' => /write_varP_arr [h ? ? ->]. - by rewrite Vm.setP_eq (vm_truncate_val_eq h). - rewrite -(vrvP_var hw); last by SvD.fsetdec. - apply: value_uincl_trans; first by apply hvm1. - by apply hvm2; SvD.fsetdec. + rewrite Z.sub_diag => vm2 [] hvm2 htx' hfor; exists vm2; split. + + apply: uincl_onT. + * apply: uincl_onI hvm; clear; SvD.fsetdec. + apply: uincl_onI hvm2; clear; SvD.fsetdec. + + by exists tx'. apply: (Eseq hipre); apply sem_seq1; constructor. apply: Efor => //. have -> : wrange UpTo 0 n = ziota 0 n by rewrite /wrange ziotaE Z.sub_0_r. - by case: (s1) hw hfor; rewrite /write_var /= => ???; t_xrbindP => ?? <-. + done. +Qed. + +Opaque array_copy. + +Lemma get_targetP ii xs dst sfx s1 len (t' t'': WArray.array len) s2 vm1 : + get_target fresh_var_ident X ii xs = ok (dst, sfx) → + write_lvals true gd s1 xs [:: Varr t'] = ok s2 → + Sv.Subset (read_rvs xs) X → + evm s1 <=[Sv.remove dst X] vm1 → + vm1.[dst] = Varr t'' → + WArray.uincl t' t'' → + exists2 vm2, + evm s2 <=[X] vm2 & + sem p2 ev (with_vm s1 vm1) sfx (with_vm s2 vm2). +Proof. + clear -Hp. + case: xs => // x [] //. + case: x => //. + { move => x /ok_inj[] ??; subst x sfx => /=. + t_xrbindP => s ok_s2 ? hsub hvm ok_t2 ht; subst s. + move: ok_s2; rewrite /write_var; t_xrbindP => vm ok_vm <-{s2}. + eexists; last by rewrite with_vm_idem; constructor. + case/set_varP: ok_vm => ? ht' ->{vm} /= => x hx. + rewrite Vm.setP; case: eqP => hdst. + - subst; rewrite ok_t2. + apply: value_uincl_trans; first apply: vm_truncate_value_uincl ht'. + exact: ht. + apply: hvm; clear -hx hdst; SvD.fsetdec. } + move => aa ws nitem x ofs /=; t_xrbindP. + set dst_var := {| vtype := sarr _ |}. + move/Sv_memP => dstX ?? s; subst => /=. + rewrite /on_arr_var; t_xrbindP => - [] // alen a ok_a; t_xrbindP => iofs vofs ok_ofs /to_intI ?; subst vofs. + move=> z1 hcast z2 hset hw ?; subst s. + rewrite read_rvs_cons read_rvs_nil /= read_eE => hsub hvm ok_dst t't''. + have [ z1' hcast' z1z1' ] := WArray.uincl_cast t't'' hcast. + have : get_gvar true gd (evm s1) (mk_lvar x) = ok (Varr a) := ok_a. + case/(get_gvar_uincl_at (vm2 := vm1)). + - apply: hvm => /=; SvD.fsetdec. + case => // blen b; rewrite /get_gvar /= => ok_b hab. + have hvm' : evm s1 <=[ read_e ofs ] vm1. + - by apply: uincl_onI hvm; clear -hsub dstX; SvD.fsetdec. + case: (sem_pexpr_uincl_on hvm' ok_ofs) => ? ok_ofs' /value_uinclE ?; subst. + have [ z2' hset' z2z2' ] := WArray.uincl_set_sub hab z1z1' hset. + have {}z2z2' : value_uincl (Varr z2) (Varr z2') by []. + have! := (write_var_uincl_on z2z2' hw hvm). + case => vm2 hw' hvm2. + exists vm2; last first. + { apply: sem_seq1; constructor. + apply: Eassgn. + - rewrite /= /get_gvar /= /get_var /= ok_dst /=; reflexivity. + - rewrite /truncate_val /= hcast' /=; reflexivity. + rewrite /= /on_arr_var ok_b /= -eq_globs ok_ofs' /= WArray.castK /= hset' /= hw'. + done. } + apply: uincl_onI hvm2. + SvD.fsetdec. +Qed. + +Local Lemma Hopn : sem_Ind_opn p1 Pi_r. +Proof. + move => s1 s2 tg o xs es; rewrite /sem_sopn; t_xrbindP => vs ves hves ho hw ii. + rewrite /Pi vars_I_opn /vars_lvals => hsub /=. + case: is_copy (@is_copyP o); last first. + + move=> _ _ [<-] vm1 hvm1. + have [|ves' hves' uves]:= sem_pexprs_uincl_on (uincl_onI _ hvm1) hves; first by SvD.fsetdec. + have [ vs' ho' vs_vs' ] := vuincl_exec_opn uves ho. + have [| vm2 hvm2 hw']:= write_lvals_uincl_on _ vs_vs' hw hvm1; first by SvD.fsetdec. + exists vm2; first by apply: uincl_onI hvm2; SvD.fsetdec. + apply sem_seq1; constructor; econstructor; eauto. + by rewrite /sem_sopn -eq_globs hves' /= ho' /=. + move=> [ws n] /(_ _ _ refl_equal) ?; subst o. + t_xrbindP => cc [] src pfx ok_src; t_xrbindP => - [] dst sfx ok_sfx; t_xrbindP => /eqP htx ? vm0 hvm0; subst cc. + have hesX : Sv.Subset (read_es es) X by (clear -hsub; SvD.fsetdec). + have [ hdis [] v ? [] vm1 [] exec_pfx hvm1 [] vy hy ] := get_sourceP ok_src hves hesX hvm0; subst ves. + move: ho. + rewrite /exec_sopn /sopn_sem /=; t_xrbindP => t' t /to_arrI ? ok_t' ?; subst v vs. + case/value_uinclE => t2 ? htt2; subst vy. + have ok_t2' := WArray.uincl_copy htt2 ok_t'. + have [ vm2 [] hvm2 [] t'' ok_dst t't'' exec_array_copy ] := array_copyP ii htx hdis hvm1 hy ok_t2'. + have hxsX : Sv.Subset (read_rvs xs) X by (clear -hsub; SvD.fsetdec). + have [ vm3 hvm3 exec_sfx ] := get_targetP ok_sfx hw hxsX hvm2 ok_dst t't''. + exists vm3; first exact: hvm3. + apply: (sem_app exec_pfx). + exact: sem_app exec_array_copy exec_sfx. Qed. Local Lemma Hsyscall : sem_Ind_syscall p1 Pi_r. diff --git a/proofs/compiler/array_expansion_proof.v b/proofs/compiler/array_expansion_proof.v index 09aa6499d..2653f66c2 100644 --- a/proofs/compiler/array_expansion_proof.v +++ b/proofs/compiler/array_expansion_proof.v @@ -257,7 +257,7 @@ Lemma expand_lvP (s1 s2 : estate) : exists s2', write_lval wdb gd x2 v s2 = ok s2' /\ eq_alloc m s1' s2'. Proof. move=> h; case: (h) => -[heq ha] hscs hmem [] /=. - + move=> ii ty _ [<-] /= ?? /dup [] /write_noneP [-> _ _] hn. + + move=> ii ty _ [<-] /= ?? /[dup] /write_noneP [-> _ _] hn. by exists s2; split => //; apply: uincl_write_none hn. + by move=> x; t_xrbindP => _ ? <- /= v1 s1'; apply eq_alloc_write_var. + move=> al ws x e x2; t_xrbindP => hin e' he <- v s1' vx p /=. @@ -274,7 +274,7 @@ Proof. case hai: Mvar.get => [ai | //]. case: is_constP => // i ; t_xrbindP => /eqP <- /eqP -> /eqP -> hbound <- v s1'. apply on_arr_varP => n t hty hget /=. - t_xrbindP => w hvw t' ht' /dup[] hw1 /write_varP [? _ htrv]; subst s1'. + t_xrbindP => w hvw t' ht' /[dup] hw1 /write_varP [? _ htrv]; subst s1'. have vai := valid hai; have hin := wf_mem (v_var x) vai hbound. move: (vai.(xi_ty) hin) (vai.(xi_nin) hin) => htyi ?. have [htri htrvi hdb hdv]:= to_word_vm_truncate_val wdb htyi hvw. @@ -352,7 +352,7 @@ Proof. move=> + hrec _ _ [<-] z0 /hrec{hrec}+ <- => + [? ->] /= => <-. have vai := (valid hga); case: h => -[_ /(_ _ _ _ hga){hga}hgai _ _]. have := Vm.getP (evm s1) (gv g); rewrite vai.(x_ty) /compat_val /=. - move => /compat_typeE /type_of_valI [x2 /dup[] hg ->]. + move => /compat_typeE /type_of_valI [x2 /[dup] hg ->]. rewrite /sem_pexprs mapM_cat -/(sem_pexprs _ _ _ (flatten _)) => -> /=. rewrite expand_vP /=; eexists; eauto. rewrite mapM_map /comp /= /get_gvar /get_var /= mapM_ok /=; do 2!f_equal. @@ -785,7 +785,7 @@ Proof. + by move=> xi /mapP [id ? ->]. move=> x' ai' xi /eqP ?. rewrite Mvar.setP_neq // => /hget -/(_ xi) h []. by rewrite -(map_id elems) => /sv_of_listP -/hdis h1 /h. - move=> hne /dup[] /hget h1 /hwf [/= ??????? xi_disj]; constructor => //=. + move=> hne /[dup] /hget h1 /hwf [/= ??????? xi_disj]; constructor => //=. move=> x' ai' xi hxx'; rewrite Mvar.setP; case: eqP => [? | hne']; last by apply xi_disj. by move=> [<-] [] /= /h1 /hdis h2; rewrite -(map_id elems) => /sv_of_listP. + by SvD.fsetdec. diff --git a/proofs/compiler/array_init_proof.v b/proofs/compiler/array_init_proof.v index a0502e516..b57d2b949 100644 --- a/proofs/compiler/array_init_proof.v +++ b/proofs/compiler/array_init_proof.v @@ -421,14 +421,14 @@ Section ADD_INIT. Local Lemma RAif_true : sem_Ind_if_true p ev Pc Pi_r. Proof. move=> s1 s2 e c1 c2 H _ [] hs Hc ii /=; split. - + move=> vm1 /dup[] heq1 /hs [vm2] ? hc; exists vm2 => //; constructor. + + move=> vm1 /[dup] heq1 /hs [vm2] ? hc; exists vm2 => //; constructor. by apply: Eif_true => //; rewrite -(sem_pexpr_ext_eq _ _ e heq1). - move=> I /dup [] hu1 /Hc [] /=. + move=> I /[dup] hu1 /Hc [] /=. case: (add_init_c _ _ c1)=> /= c1' O1; case: (add_init_c _ _ c2)=> /= c2' O2. move=> hu2 hsc'; split. + by move=> ??;rewrite hu2 //;SvD.fsetdec. apply add_initP => //. - move=> vm1 /dup[] heq1 /hsc' [vm2 he hs']; exists vm2 => //. + move=> vm1 /[dup] heq1 /hsc' [vm2 he hs']; exists vm2 => //. by constructor; apply: Eif_true => //; rewrite -(sem_pexpr_ext_eq _ _ e heq1). Qed. @@ -458,14 +458,14 @@ Section ADD_INIT. Local Lemma RAif_false : sem_Ind_if_false p ev Pc Pi_r. Proof. move=> s1 s2 e c1 c2 H _ [] hs Hc ii /=; split. - + move=> vm1 /dup[] heq1 /hs [vm2] ? hc; exists vm2 => //; constructor. + + move=> vm1 /[dup] heq1 /hs [vm2] ? hc; exists vm2 => //; constructor. by apply: Eif_false => //; rewrite -(sem_pexpr_ext_eq _ _ e heq1). - move=> I /dup [] hu1 /Hc [] /=. + move=> I /[dup] hu1 /Hc [] /=. case: (add_init_c _ _ c1)=> /= c1' O1; case: (add_init_c _ _ c2)=> /= c2' O2. move=> hu2 hsc'; split. + by move=> ??;rewrite hu2 //;SvD.fsetdec. apply add_initP => //. - move=> vm1 /dup[] heq1 /hsc' [vm2 he hs']; exists vm2 => //. + move=> vm1 /[dup] heq1 /hsc' [vm2 he hs']; exists vm2 => //. by constructor; apply: Eif_false => //; rewrite -(sem_pexpr_ext_eq _ _ e heq1). Qed. @@ -475,7 +475,7 @@ Section ADD_INIT. have [{Hi}Hi _]:= Hi ii. apply aux. + by constructor;apply: Ewhile_true;eauto. - move=> vm1 /Hc [vm2] /dup[] heq /Hc' [vm3] /Hi [vm4] ? /sem_IE h *; exists vm4 => //. + move=> vm1 /Hc [vm2] /[dup] heq /Hc' [vm3] /Hi [vm4] ? /sem_IE h *; exists vm4 => //. constructor;apply: Ewhile_true;eauto. by rewrite -(sem_pexpr_ext_eq _ _ e heq). Qed. @@ -495,7 +495,7 @@ Section ADD_INIT. move=> s1 s2 i d lo hi c vlo vhi H H' hsf hf ii. apply aux. + by constructor; econstructor; eauto. - move=> vm1 /dup [] heq /hf [vm2] ? hs'; exists vm2 => //. + move=> vm1 /[dup] heq /hf [vm2] ? hs'; exists vm2 => //. by constructor; econstructor; eauto; rewrite -(sem_pexpr_ext_eq _ _ _ heq). Qed. diff --git a/proofs/compiler/byteset.v b/proofs/compiler/byteset.v index 7de764a11..363788ef1 100644 --- a/proofs/compiler/byteset.v +++ b/proofs/compiler/byteset.v @@ -111,7 +111,7 @@ Module Type ByteSetType. End ByteSetType. -Module ByteSet : ByteSetType. +Module ByteSet <: ByteSetType. (* sorted in increasing order, no overlap *) Definition bytes := seq interval. @@ -250,13 +250,13 @@ Proof. elim: (tobytes t) (_wf t) => [ _ | n' t' ih] /=. + constructor => /(_ (imin n)); rewrite !zify => h1. by have : false by apply h1; lia. - rewrite wf_auxE => /and3P [] /ZleP ? /ZltP ? /dup[] /ih h1 /(@_memi_least (imax n' + 1)) hi. + rewrite wf_auxE => /and3P [] /ZleP ? /ZltP ? /[dup] /ih h1 /(@_memi_least (imax n' + 1)) hi. case: I.subsetP => [[??] | hs] /=. + by constructor => i; rewrite /I.memi !zify; lia. case: ZltP => /= => ?. + case: h1 => h2; constructor. - + by move=> i /dup []/h2 ->; rewrite andbT; rewrite !zify; lia. - by move=> h3; apply h2 => i /dup[] /h3; rewrite !zify => -[]; [ lia| case]. + + by move=> i /[dup]/h2 ->; rewrite andbT; rewrite !zify; lia. + by move=> h3; apply h2 => i /[dup] /h3; rewrite !zify => -[]; [ lia| case]. constructor => h3. move /I.subsetP : hs; rewrite /I.subset; case: ZleP => /= ?. + move=> /ZleP ?; have {hi}hi:= hi (imax n'). @@ -282,10 +282,10 @@ Lemma wf_add_aux n t : Proof. move => ok_n ok_t. elim: t ok_t n ok_n; first by move => _ n /= ->; rewrite Z.min_id. - move => n' t ih ok_t n /dup[] ok_n /ZleP hle_n /=; case: ZltP => hlt. + move => n' t ih ok_t n /[dup] ok_n /ZleP hle_n /=; case: ZltP => hlt. - split; first by move => _ /=; lia. by apply: wf_cons => //=; rewrite zify; lia. - case/andP: ok_t => /dup[] ok_n' /ZleP hle_n'; rewrite wf_auxE => /andP[] /ZltP h ok_t. + case/andP: ok_t => /[dup] ok_n' /ZleP hle_n'; rewrite wf_auxE => /andP[] /ZltP h ok_t. case: ZltP => hlt'. - split; first by move => _ /=; lia. have {ih}[ih1 ih2] := ih ok_t _ ok_n. @@ -354,7 +354,7 @@ Lemma wf_push n t : (imin n <= imax n → imax n < least (imax n + 1) t) → wf (_push n t). Proof. - rewrite /_push; case: ifPn => // /dup [] /ZleP hle. + rewrite /_push; case: ifPn => // /[dup] /ZleP hle. rewrite -/(I.wf n) /= wf_auxE => -> -> ?; rewrite /= andbT. apply/ZltP; lia. Qed. @@ -502,8 +502,8 @@ elim : (_subset_eq h) (_wf t1) (_wf t2) => {t1 t2 h}. move: (wf1); rewrite /= wf_auxE => /and3P [] /ZleP h1 /ZltP h2 wf1'. move: wf2; rewrite /= wf_auxE => /and3P [] /ZleP h1' /ZltP h2' wf2. apply: (equivP (ih wf1 wf2)) => /=; split => hh i; have := hh i; rewrite !zify. - + by move=> h /dup [] /h -> hh1; right; split => //; lia. - by move=> h /dup [] /h [ | [] //]; lia. + + by move=> h /[dup] /h -> hh1; right; split => //; lia. + by move=> h /[dup] /h [ | [] //]; lia. move=> n1 t1' n2 t2' /I.subsetP hh hh' wf1 wf2;constructor. move: wf1; rewrite /= wf_auxE => /and3P [] h1 /ZltP h2 wf1. move: wf2; rewrite /= wf_auxE => /and3P [] h1' /ZltP h2' wf2 hh1. @@ -584,9 +584,9 @@ elim : (_disjoint_eq h) (_wf t1) (_wf t2) => {t1 t2 h}. move: (wf1); rewrite /= wf_auxE => /and3P [] /ZleP h1 /ZltP h2 wf1'. move: wf2; rewrite /= wf_auxE => /and3P [] /ZleP h1' /ZltP h2' wf2. apply: (equivP (ih wf1 wf2)) => /=; split => hh i; have := hh i; rewrite !zify. - + move=> h /dup[] /h{h}h. + + move=> h /[dup] /h{h}h. by move=> ? [|[_ ?] //]; lia. - move=> h /dup[] /h{h}h _ hmem2; apply h; right; split=> //. + move=> h /[dup] /h{h}h _ hmem2; apply h; right; split=> //. by have /(_ (imax n2 + 1) i hmem2) := _memi_least wf2; lia. move=> n1 t1' n2 t2' hlt1 hlt2 wf1 wf2;constructor. move: wf1; rewrite /= wf_auxE => /and3P [] h1 /ZltP h2 wf1. @@ -836,12 +836,12 @@ Proof. + by move=> t2 _ wf2;split => //= d; apply: (@le_least (least d t2)); rewrite least_least; lia. + by move=> t1 wf1 _;split => //= d; apply: (@le_least (least d t1)); rewrite least_least; lia. + move=> n1 t1 n2 t2 t h1 _ ih wf1 wf2 /=. - move: wf1; rewrite /= !wf_auxE => /and3P[] /dup [] /ZleP ? -> /ZltP ? wf1. + move: wf1; rewrite /= !wf_auxE => /and3P[] /[dup] /ZleP ? -> /ZltP ? wf1. have [-> /= h]:= ih wf1 wf2; rewrite andbT; split. + by apply/ZltP; apply: lt_least; apply: Z.lt_le_trans; last apply (h (imax n1 + 1)); lia. by move=> _; move: wf2; rewrite /= wf_auxE => /and3P [] /ZleP ???; lia. + move=> n1 t1 n2 t2 t h1 _ ih wf1 wf2 /=. - move: wf2; rewrite /= !wf_auxE => /and3P[] /dup [] /ZleP ? -> /ZltP ? wf2. + move: wf2; rewrite /= !wf_auxE => /and3P[] /[dup] /ZleP ? -> /ZltP ? wf2. have [-> /= h]:= ih wf1 wf2; rewrite andbT; split. + by apply/ZltP; apply: lt_least; apply: Z.lt_le_trans; last apply: (h (imax n2 + 1)); lia. by move=> _; move: wf1; rewrite /= wf_auxE => /and3P [] /ZleP ???; lia. diff --git a/proofs/compiler/compiler.v b/proofs/compiler/compiler.v index 4cbcf6df5..0fab1f4a8 100644 --- a/proofs/compiler/compiler.v +++ b/proofs/compiler/compiler.v @@ -250,12 +250,7 @@ Definition compiler_first_part (to_keep: seq funname) (p: prog) : cexec uprog := let p := remove_assert_prog p in let p := cparams.(print_uprog) RemoveAssert p in - Let p := - array_copy.array_copy_prog - (fresh_var_ident cparams Inline dummy_instr_info 0 "i__copy" sint) - (λ ws, fresh_var_ident cparams (Reg (Normal, Direct)) dummy_instr_info 0 "tmp" (sword ws)) - p in - + Let p := array_copy.array_copy_prog (λ k, cparams.(fresh_var_ident) k dummy_instr_info 0) p in let p := cparams.(print_uprog) ArrayCopy p in let p := add_init_prog p in @@ -462,7 +457,6 @@ Definition compiler_back_end_to_asm (entries: seq funname) (p: sprog) := Definition compile_prog_to_asm entries (p: prog): cexec asm_prog := compiler_front_end entries p >>= compiler_back_end_to_asm entries. - Definition compiler_CL_first_part (to_keep: seq funname) (p: prog) : cexec uprog := let p := add_init_prog p in let p := cparams.(print_uprog) AddArrInit p in diff --git a/proofs/compiler/compiler_proof.v b/proofs/compiler/compiler_proof.v index cd7201f27..1f3c4acf9 100644 --- a/proofs/compiler/compiler_proof.v +++ b/proofs/compiler/compiler_proof.v @@ -485,7 +485,7 @@ Proof. rewrite -gd2 in ok_p2. case/sem_call_length: (exec_p1) => fd1 [] get_fd1 size_params size_tyin size_tyout size_res. have! [mglob ok_mglob] := (alloc_prog_get_fundef ok_p2). - move=> /(_ _ _ get_fd1)[] fd2 /dup[] ok_fd2 /alloc_fd_checked_sao[] ok_sao_p ok_sao_r get_fd2. + move=> /(_ _ _ get_fd1)[] fd2 /[dup] ok_fd2 /alloc_fd_checked_sao[] ok_sao_p ok_sao_r get_fd2. have [fd [get_fd _]] := sem_callE exec_p. rewrite /get_nb_wptr /get_wptrs get_fd /= seq.find_map /preim. set n := find _ _. @@ -1233,7 +1233,7 @@ Proof. have -> := compiler_back_end_to_asm_meta ok_xp. case=> /= mi1 mi2 mi3 mi4. rewrite (ss_top_stack mi3). - move=> /dup[] henough /(enough_stack_space_alloc_ok ok_xp ok_fn mi4) ok_mi. + move=> /[dup] henough /(enough_stack_space_alloc_ok ok_xp ok_fn mi4) ok_mi. have [sfd [xd [get_sfd get_xd xd_export align_args_eq]]] := compiler_back_end_to_asm_get_fundef ok_xp ok_fn. exists xd; split=> //. diff --git a/proofs/compiler/constant_prop_proof.v b/proofs/compiler/constant_prop_proof.v index 7acae2f39..4da462aba 100644 --- a/proofs/compiler/constant_prop_proof.v +++ b/proofs/compiler/constant_prop_proof.v @@ -171,9 +171,8 @@ Lemma ssem_sop1P o e : Papp1 o e =E ssem_sop1 o e. Proof. rewrite /ssem_sop1. case heq : of_expr => [ v | ] //=. - apply: eeq_weaken => rho v' /dup[]h1 /=. - rewrite /sem_pexpr. - rewrite /sem_sop1. -Let_Let. (of_exprP rho heq) /= => -[?]; subst v'. + apply: eeq_weaken => rho v' /[dup]h1 /=. + rewrite /sem_sop1 -Let_Let (of_exprP rho heq) /= => -[?]; subst v'. by case heq' : to_expr => [e' | //]; apply to_exprP. Qed. @@ -504,7 +503,7 @@ Proof. rewrite /ssem_sop2. case heq1 : (of_expr _ e1) => [ v1 | ] //=. case heq2 : (of_expr _ e2) => [ v2 | ] //=. - apply: eeq_weaken => rho v' /dup[]h1 /=. + apply: eeq_weaken => rho v' /[dup]h1 /=. rewrite /sem_sop2. move: (of_exprP rho heq1) (of_exprP rho heq2). t_xrbindP => ? -> he1 ? -> he2 ? [<-] ? [<-]; rewrite he1 he2 => ?[<-] ?[<-] ? -> ? /=; subst v'. @@ -651,16 +650,16 @@ Section CONST_PROP_EP. t_xrbindP => v1 /He1 [w1] [hw1 hvw1] v2 /He2 [w2] [hw2 hvw2] h; apply/s_op2P_aux. rewrite /= hw1 hw2 /=. by apply: vuincl_sem_sop2 h. - - move => op es ih v ? ; rewrite s_opNP_aux //=. - t_xrbindP => vs /ih{ih} [] vs' ih /vuincl_sem_opN h/h{h} [] v' ok_v' h. - rewrite /= -/(sem_pexprs_aux _ _ _ _) ; move : ih => -> /=; eauto. - - move => t e He e1 He1 e2 He2 v ? //=. - t_xrbindP => b ve /He/= [] ve' [] hse /[swap] /to_boolI -> /value_uinclE ?; subst. - move=> ve1 vte1 /He1 []ve1' [] hse1 hue1 /(value_uincl_truncate hue1) [] ? /dup[] ht1 /truncate_value_uincl ht1' hu1. - move=> ve2 vte2 /He2 []ve2' [] hse2 hue2 /(value_uincl_truncate hue2) [] ? /dup[] ht2 /truncate_value_uincl ht2' hu2 <-. - rewrite /s_if; case: is_boolP hse; first by move=> [][<-] /=;eexists;split;eauto using value_uincl_trans. - move=> /= p -> /=;rewrite hse1 hse2 /=ht1 ht2 /=;eexists;split;eauto. - by case:(b). + - move => op es ih v. + t_xrbindP => vs /ih{ih} [] vs' ih /vuincl_sem_opN h/h{h} ok_v. + by rewrite s_opNP /= -/(sem_pexprs _ _ _) ih /= ok_v; eauto. + move => t e He e1 He1 e2 He2 v. + t_xrbindP => b ve /He/= [] ve' [] hse /[swap] /to_boolI -> /value_uinclE ?; subst. + move=> ve1 vte1 /He1 []ve1' [] hse1 hue1 /(value_uincl_truncate hue1) [] ? /[dup] ht1 /truncate_value_uincl ht1' hu1. + move=> ve2 vte2 /He2 []ve2' [] hse2 hue2 /(value_uincl_truncate hue2) [] ? /[dup] ht2 /truncate_value_uincl ht2' hu2 <-. + rewrite /s_if; case: is_boolP hse; first by move=> [][<-] /=;eexists;split;eauto using value_uincl_trans. + move=> /= p -> /=;rewrite hse1 hse2 /= ht1 ht2 /=;eexists;split;eauto. + by case:(b). - move => sop v e1 He1 e2 He2 e3 He3 e4 He4 v0 ? /=. t_xrbindP => z1 ve1 /He1 [ ] ve1' /[swap] /to_intI -> [ ] -> /value_uinclE -> //=. move => z2 ve2 /He2 [ ] ve2' /[swap] /to_intI -> [ ] -> /value_uinclE -> //=. @@ -739,7 +738,7 @@ Proof. have [_ /vm_truncate_valE [ws' [-> _ -> /=]] /get_varP [<-]] := write_get_varP_eq hw. move => _ _. elim/cmp_minP: (cmp_min szw ws'); first by move => ->. - case/dup => /(@cmp_lt_le _ _ _ _ _) hle'. + move=> /[dup] /(@cmp_lt_le _ _ _ _ _) hle'. rewrite -cmp_nle_lt => /negbTE ->. by rewrite zero_extend_wrepr. Qed. @@ -1236,7 +1235,7 @@ Section PROOF. case: (Hc1 _ Hm). case Heq1 : const_prop => [m1 c0]; case Heq2 : const_prop => [m2 c3] /= Hval Hs;split. + by apply merge_cpmP;left. - move=> vm1 /dup[] h /Hs [vm2 [ hc u]];exists vm2;split => //. + move=> vm1 /[dup] h /Hs [vm2 [ hc u]];exists vm2;split => //. apply sem_seq1; do 2 constructor=> //. by have [v2 -> /value_uinclE ->]:= sem_pexpr_uincl h He. Qed. @@ -1251,7 +1250,7 @@ Section PROOF. case: (Hc1 _ Hm). case Heq1 : const_prop => [m1 c0]; case Heq2 : const_prop => [m2 c3] /= Hval Hs;split. + by apply merge_cpmP;right. - move=> vm1 /dup[] h /Hs [vm2 [ hc u]];exists vm2;split => //. + move=> vm1 /[dup] h /Hs [vm2 [ hc u]];exists vm2;split => //. apply sem_seq1; constructor;apply Eif_false => //. by have [v2 -> /value_uinclE ->]:= sem_pexpr_uincl h He. Qed. @@ -1333,7 +1332,7 @@ Section PROOF. have := Hfor _ Heqm Hm'1. case Heq1: const_prop => [m'' c'] /= Hsem;split. + by apply: valid_cpm_rm Hm;apply (write_iP (P:=p) (ev:=ev));econstructor;eauto. - move=> vm1 /dup[] hvm1 /Hsem [vm2 [ hfor hvm2]];exists vm2;split => //. + move=> vm1 /[dup] hvm1 /Hsem [vm2 [ hfor hvm2]];exists vm2;split => //. apply sem_seq1;constructor;econstructor;eauto. + have [v' [h /=]] := const_prop_eP Hm valid_without_globals Hlo; case: v' h => //= ? h ->. by have [v2 -> /value_uinclE ->]:= sem_pexpr_uincl hvm1 h. diff --git a/proofs/compiler/linearization_proof.v b/proofs/compiler/linearization_proof.v index 36111a107..2e6c63a2d 100644 --- a/proofs/compiler/linearization_proof.v +++ b/proofs/compiler/linearization_proof.v @@ -333,7 +333,7 @@ have : exists (b1 b2:bool), st = sbool /\ sem_pexpr true gd s e1 = ok (Vbool b1) by move: htr2; rewrite /truncate_val; t_xrbindP => /= b2 /to_boolI -> ?;eauto. have [??]:= truncate_valI htr2;subst st v2. by move: htr1; rewrite /truncate_val; t_xrbindP => /= b1 /to_boolI -> ?;eauto. -move=> [b1 [b2 [-> []/dup[]hb1 /he1 -> /dup[]hb2 /he2 ->]]] /=. +move=> [b1 [b2 [-> []/[dup]hb1 /he1 -> /[dup]hb2 /he2 ->]]] /=. by rewrite hb1 hb2 /=; case bp. Qed. @@ -1477,7 +1477,7 @@ Section PROOF. have := [elaborate top_stack_below_root _ m1]; rewrite -/(top_stack _). by lia. (* read stk *) - + move=> p1 w1 hb /dup[] Hr1. + + move=> p1 w1 hb /[dup] Hr1. move: (Hve p1) (Hvr p1). have -> := readV Hr1. case: validw. @@ -2697,7 +2697,7 @@ Section PROOF. } (* arbitrary expression *) move => {} e ok_e Ew Hw. - t_xrbindP => /dup[] checked_e /check_fexprP[] f ok_f ok_c ok_c'. + t_xrbindP => /[dup] checked_e /check_fexprP[] f ok_f ok_c ok_c'. move: Hw; rewrite checked_e /to_fexpr ok_f => Hw. case: c' Ec' Hc' ok_c' Ew Hw => [ | i c' ]. { (* second body is empty *) @@ -3747,7 +3747,7 @@ Section PROOF. move=> [x1 ofs1] to_save ih lo /all_disjoint_aligned_betweenP. move=> [] ofs1' [] ws1' [] [] /=. case heq: is_word_type => [ws1 | ] // [??]; subst ofs1' ws1'. - move=> _ hlo _ _ /dup[] {}/ih ih /all_disjoint_aligned_between_range ?. + move=> _ hlo _ _ /[dup] {}/ih ih /all_disjoint_aligned_between_range ?. move=> x ofs ws; rewrite in_cons => /orP [/eqP [-> ->] | hin] ht. + by move: heq; rewrite ht => -[->]. have := ih _ _ _ hin ht; have := (@le0_wsize_size ws1); lia. @@ -4292,7 +4292,7 @@ Section PROOF. rewrite SvP.diff_mem negb_and => /orP[]; last first. * move/negbNE; rewrite sv_of_list_map. have -> : (id \o fst) = fst by done. - move=> /dup [hin]; rewrite sv_of_listE => hin'. + move=> /[dup] hin; rewrite sv_of_listE => hin'. have -> : (x == var_tmp2) = false. + by apply/negbTE/eqP => ?; subst x; rewrite hin in tmp2_not_saved. rewrite hin' hvm2 // => /Sv.add_spec [?| /Sv.add_spec [?| /Sv.add_spec [?| ]]]. diff --git a/proofs/compiler/propagate_inline_proof.v b/proofs/compiler/propagate_inline_proof.v index 5f724ad06..45b3a3362 100644 --- a/proofs/compiler/propagate_inline_proof.v +++ b/proofs/compiler/propagate_inline_proof.v @@ -253,8 +253,9 @@ Proof. + move=> o es hrec ?; t_xrbindP => ? /hrec [vs' hs' hu]. case: o => [wz pe | c] /=. + move=> ho; rewrite -/(sem_pexprs wdb gd _ (pi_es pi es)) hs' /=. - by apply: vuincl_sem_opN ho hu. - move=> ho; have [v' ho' hu']:= vuincl_sem_opN ho hu. + rewrite (vuincl_sem_opN hu ho). + by eexists; first by reflexivity. + move=> ho; have ho' := vuincl_sem_opN hu ho. by rewrite -/(pi_es pi es) (scfcP hs' ho'); eauto. move=> ?? hrec ? hrec1 ? hrec2 v; t_xrbindP. move=> ?? /hrec [? -> /of_value_uincl_te h] /(h sbool) /= ->. diff --git a/proofs/compiler/slh_lowering.v b/proofs/compiler/slh_lowering.v index bb8d9fd4a..e97f298a8 100644 --- a/proofs/compiler/slh_lowering.v +++ b/proofs/compiler/slh_lowering.v @@ -117,8 +117,7 @@ End E. Module Env. Section WITH_PARAMS. - - Context {A: Tabstract}. + Context {AB : Tabstract}. Context {fcparams : flag_combination.FlagCombinationParams}. (* We keep track of the condition of the last conditional we entered, and of diff --git a/proofs/compiler/stack_alloc.v b/proofs/compiler/stack_alloc.v index 29823b592..c83e6d189 100644 --- a/proofs/compiler/stack_alloc.v +++ b/proofs/compiler/stack_alloc.v @@ -589,7 +589,9 @@ Definition check_vpk_word rmap al x vpk ofs ws := Let _ := check_valid x sr' bytes in check_align al x sr ws. -Fixpoint alloc_e (e:pexpr) := +Definition bad_arg_number := stk_ierror_no_var "invalid number of args". + +Fixpoint alloc_e (e:pexpr) ty := match e with | Pconst _ | Pbool _ | Parr_init _ => ok e | Pvar x => @@ -598,16 +600,18 @@ Fixpoint alloc_e (e:pexpr) := match vk with | None => Let _ := check_diff xv in ok e | Some vpk => - if is_word_type (vtype xv) is Some ws then - Let _ := check_vpk_word rmap Aligned xv vpk (Some 0%Z) ws in - Let pofs := mk_addr xv AAdirect ws vpk (Pconst 0) in - ok (Pload Aligned ws pofs.1 pofs.2) + if is_word_type ty is Some ws then + if subtype (sword ws) (vtype xv) then + Let _ := check_vpk_word rmap Aligned xv vpk (Some 0%Z) ws in + Let pofs := mk_addr xv AAdirect ws vpk (Pconst 0) in + ok (Pload Aligned ws pofs.1 pofs.2) + else Error (stk_ierror_basic xv "invalid type for expression") else Error (stk_ierror_basic xv "not a word variable in expression") end | Pget al aa ws x e1 => let xv := x.(gv) in - Let e1 := alloc_e e1 in + Let e1 := alloc_e e1 sint in Let vk := get_var_kind x in match vk with | None => Let _ := check_diff xv in ok (Pget al aa ws x e1) @@ -624,31 +628,31 @@ Fixpoint alloc_e (e:pexpr) := | Pload al ws x e1 => Let _ := check_var x in Let _ := check_diff x in - Let e1 := alloc_e e1 in + Let e1 := alloc_e e1 (sword Uptr) in ok (Pload al ws x e1) | Papp1 o e1 => - Let e1 := alloc_e e1 in + Let e1 := alloc_e e1 (type_of_op1 o).1 in ok (Papp1 o e1) | Papp2 o e1 e2 => - Let e1 := alloc_e e1 in - Let e2 := alloc_e e2 in + let tys := type_of_op2 o in + Let e1 := alloc_e e1 tys.1.1 in + Let e2 := alloc_e e2 tys.1.2 in ok (Papp2 o e1 e2) | PappN o es => - Let es := mapM alloc_e es in + Let es := mapM2 bad_arg_number alloc_e es (type_of_opN o).1 in ok (PappN o es) | Pabstract s es => - Let es := mapM alloc_e es in - ok (Pabstract s es) + Error (stk_ierror_no_var "Pabstract") | Pif t e e1 e2 => - Let e := alloc_e e in - Let e1 := alloc_e e1 in - Let e2 := alloc_e e2 in - ok (Pif t e e1 e2) + Let e := alloc_e e sbool in + Let e1 := alloc_e e1 ty in + Let e2 := alloc_e e2 ty in + ok (Pif ty e e1 e2) | Pfvar v => Error (stk_ierror_no_var "Pfvar is not supported in stack_alloc") | Pbig _ _ _ _ _ _ => Error (stk_ierror_no_var "Pbig is not supported in stack_alloc") @@ -656,7 +660,7 @@ Fixpoint alloc_e (e:pexpr) := | Presultget _ _ _ _ _ _ => Error (stk_ierror_no_var "Presultget is not supported in stack_alloc") end. - Definition alloc_es := mapM alloc_e. + Definition alloc_es es ty := mapM2 bad_arg_number alloc_e es ty. End ALLOC_E. @@ -695,7 +699,7 @@ Definition alloc_lval (rmap: region_map) (r:lval) (ty:stype) := | Laset al aa ws x e1 => (* TODO: could we remove this [check_diff] and use an invariant in the proof instead? *) - Let e1 := alloc_e rmap e1 in + Let e1 := alloc_e rmap e1 sint in match get_local x with | None => Let _ := check_diff x in ok (rmap, Laset al aa ws x e1) | Some pk => @@ -712,7 +716,7 @@ Definition alloc_lval (rmap: region_map) (r:lval) (ty:stype) := | Lmem al ws x e1 => Let _ := check_var x in Let _ := check_diff x in - Let e1 := alloc_e rmap e1 in + Let e1 := alloc_e rmap e1 (sword Uptr) in ok (rmap, Lmem al ws x e1) end. @@ -905,7 +909,7 @@ Definition alloc_protect_ptr rmap ii r t e msf := match pk with | Pregptr px => let dx := Lvar (with_var x px) in - Let msf := add_iinfo ii (alloc_e rmap msf) in + Let msf := add_iinfo ii (alloc_e rmap msf (sword msf_size)) in Let ir := lower_protect_ptr_fail ii [::dx] t [:: ey; msf] in let rmap := Region.set_move rmap x sry bytesy in ok (rmap, ir) @@ -1225,7 +1229,7 @@ Fixpoint alloc_i sao (rmap:region_map) (i: instr) : cexec (region_map * cmd) := Let ri := add_iinfo ii (alloc_array_move_init rmap r t e) in ok (ri.1, [:: MkI ii ri.2]) else - Let e := add_iinfo ii (alloc_e rmap e) in + Let e := add_iinfo ii (alloc_e rmap e ty) in Let r := add_iinfo ii (alloc_lval rmap r ty) in ok (r.1, [:: MkI ii (Cassgn r.2 t ty e)]) @@ -1238,7 +1242,7 @@ Fixpoint alloc_i sao (rmap:region_map) (i: instr) : cexec (region_map * cmd) := Let rs := add_iinfo ii (alloc_array_swap rmap rs t e) in ok (rs.1, [:: MkI ii rs.2]) else - Let e := add_iinfo ii (alloc_es rmap e) in + Let e := add_iinfo ii (alloc_es rmap e (sopn_tin o)) in Let rs := add_iinfo ii (alloc_lvals rmap rs (sopn_tout o)) in ok (rs.1, [:: MkI ii (Copn rs.2 t o e)]) @@ -1246,11 +1250,11 @@ Fixpoint alloc_i sao (rmap:region_map) (i: instr) : cexec (region_map * cmd) := alloc_syscall ii rmap rs o es | Cassert t p e => - Let e := add_iinfo ii (alloc_e rmap e) in + Let e := add_iinfo ii (alloc_e rmap e sbool) in ok (rmap, [:: MkI ii (Cassert t p e)]) | Cif e c1 c2 => - Let e := add_iinfo ii (alloc_e rmap e) in + Let e := add_iinfo ii (alloc_e rmap e sbool) in Let c1 := fmapM (alloc_i sao) rmap c1 in Let c2 := fmapM (alloc_i sao) rmap c2 in let rmap:= merge c1.1 c2.1 in @@ -1260,7 +1264,7 @@ Fixpoint alloc_i sao (rmap:region_map) (i: instr) : cexec (region_map * cmd) := let check_c rmap := Let c1 := fmapM (alloc_i sao) rmap c1 in let rmap1 := c1.1 in - Let e := add_iinfo ii (alloc_e rmap1 e) in + Let e := add_iinfo ii (alloc_e rmap1 e sbool) in Let c2 := fmapM (alloc_i sao) rmap1 c2 in ok ((rmap1, c2.1), (e, (c1.2, c2.2))) in Let r := loop2 ii check_c Loop.nb rmap in diff --git a/proofs/compiler/stack_alloc_proof.v b/proofs/compiler/stack_alloc_proof.v index b3899fc56..5a30f6147 100644 --- a/proofs/compiler/stack_alloc_proof.v +++ b/proofs/compiler/stack_alloc_proof.v @@ -1,5 +1,6 @@ (* ** Imports and settings *) -From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq eqtype ssralg. +From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq eqtype fintype. +From mathcomp Require Import div ssralg. From mathcomp Require Import word_ssrZ. Require Import psem psem_facts compiler_util low_memory. Require Export stack_alloc. @@ -915,7 +916,7 @@ Section EXPR. Proof. move=> hofs; rewrite /get_var_kind /check_gvalid. case : (@idP (is_glob x)) => hg. - + t_xrbindP=> -[_ ws'] /get_globalP /dup [] /wf_globals /sub_region_glob_wf hwf -> <- /= [<- <- <-]. + + t_xrbindP=> -[_ ws'] /get_globalP /[dup] /wf_globals /sub_region_glob_wf hwf -> <- /= [<- <- <-]. set bytesx := ByteSet.full _. by exists bytesx. by case hlocal: get_local => [pk|//] [<-] /get_sub_region_bytesP. @@ -1045,16 +1046,18 @@ Section EXPR. Qed. Let X e : Prop := - ∀ e' v, - alloc_e pmap rmap e = ok e' → + ∀ ty e' v v2, + alloc_e pmap rmap e ty = ok e' → sem_pexpr true gd s e = ok v → - sem_pexpr true [::] s' e' = ok v. + truncate_val ty v = ok v2 -> + exists v', sem_pexpr true [::] s' e' = ok v' /\ truncate_val ty v' = ok v2. Let Y es : Prop := - ∀ es' vs, - alloc_es pmap rmap es = ok es' → + ∀ err tys es' vs vs2, + alloc_es pmap rmap es tys = ok es' → sem_pexprs true gd s es = ok vs → - sem_pexprs true [::] s' es' = ok vs. + mapM2 err truncate_val tys vs = ok vs2 -> + exists vs', sem_pexprs true [::] s' es' = ok vs' /\ mapM2 err truncate_val tys vs' = ok vs2. Lemma check_varP (x:var_i) t: check_var pmap x = ok t -> @@ -1087,22 +1090,83 @@ Section EXPR. by move=> _ /(_ ltac:(discriminate)) [->] _ [<-]. Qed. + (* Not sure at all if this is the right way to do the proof. *) + Lemma wbit_subword (ws ws' : wsize) i (w : word ws) k : + wbit_n (word.subword i ws' w) k = (k < ws')%nat && wbit_n w (k + i). + Proof. + clear. + rewrite /wbit_n. + case: ltP. + + move=> /ltP hlt. + by rewrite word.subwordE word.wbit_t2wE (nth_map ord0) ?size_enum_ord // nth_enum_ord. + rewrite /nat_of_wsize => hle. + rewrite word.wbit_word_ovf //. + by apply /ltP; lia. + Qed. + + (* TODO: is this result generic enough to be elsewhere ? *) + Lemma zero_extend_wread8 (ws ws' : wsize) (w : word ws) : + (ws' <= ws)%CMP -> + forall off, + 0 <= off < wsize_size ws' -> + LE.wread8 (zero_extend ws' w) off = LE.wread8 w off. + Proof. + clear. + move=> /wsize_size_le /(Z.divide_pos_le _ _ (wsize_size_pos _)) hle off hoff. + rewrite /LE.wread8 /LE.encode /split_vec. + have hmod: forall (ws:wsize), ws %% U8 = 0%nat. + + by move=> []. + have hdiv: forall (ws:wsize), ws %/ U8 = Z.to_nat (wsize_size ws). + + by move=> []. + have hlt: (Z.to_nat off < Z.to_nat (wsize_size ws))%nat. + + by apply /ltP /Z2Nat.inj_lt; lia. + have hlt': (Z.to_nat off < Z.to_nat (wsize_size ws'))%nat. + + by apply /ltP /Z2Nat.inj_lt; lia. + rewrite !hmod !addn0. + rewrite !(nth_map 0%nat) ?size_iota ?hdiv // !nth_iota // !add0n. + apply /eqP/eq_from_wbit_n => i. + rewrite !wbit_subword; f_equal. + rewrite wbit_zero_extend. + have -> //: (i + Z.to_nat off * U8 <= wsize_size_minus_1 ws')%nat. + rewrite -ltnS -/(nat_of_wsize ws'). + apply /ltP. + have := ltn_ord i; rewrite -/(nat_of_wsize _) => /ltP hi. + have /ltP ? := hlt'. + have <-: (Z.to_nat (wsize_size ws') * U8 = ws')%nat. + + by case: (ws'). + by rewrite -!multE -!plusE; nia. + Qed. + Lemma check_e_esP : (∀ e, X e) * (∀ es, Y es). Proof. apply: pexprs_ind_pair; subst X Y; split => //=. - + by move=> ?? [<-] [<-]. - + move=> e he es hes ??; t_xrbindP => e' /he{he}he es' /hes{hes}hes <- /=. - by move=> v /he -> vs /hes -> <-. - + by move=> z ?? [<-] [<-]. - + by move=> b ?? [<-] [<-]. - + by move=> n ?? [<-] [<-]. - + move=> x e' v; t_xrbindP => -[ vpk | ] hgvk; last first. - + by t_xrbindP=> /check_diffP hnnew <-; apply: get_var_kindP. - case hty: is_word_type => [ws | //]; move /is_word_typeP in hty. - t_xrbindP => hcheck [xi ei] haddr <- hget /=. + + move=> err [|//] _ _ _ /= [<-] [<-] [<-]. + by exists [::]. + + move=> e he es hes err [//|ty tys]. + t_xrbindP=> _ _ vs2 e' ok_e' es' ok_es' <- v ok_v vs ok_vs <- /=. + t_xrbindP=> v2 ok_v2 {}vs2 ok_vs2 <-. + have [v' [ok_v' htr]] := he _ _ _ _ ok_e' ok_v ok_v2. + have [vs' [ok_vs' htrs]] := hes _ _ _ _ _ ok_es' ok_vs ok_vs2. + rewrite ok_v' ok_vs' /=. + eexists; split; first by reflexivity. + by rewrite /= htr htrs. + + move=> z ???? [<-] [<-] /= /truncate_valE [-> ->]. + by eexists; split; first by reflexivity. + + move=> b ???? [<-] [<-] /= /truncate_valE [-> ->]. + by eexists; split; first by reflexivity. + + move=> n ???? [<-] [<-] /= /truncate_valE [-> ->]. + eexists; split; first by reflexivity. + by rewrite /truncate_val /= WArray.castK /=. + + move=> x ty e' v v2; t_xrbindP => -[ vpk | ] hgvk; last first. + + t_xrbindP=> /check_diffP hnnew <- /= ok_v htr. + exists v; split=> //. + by apply: get_var_kindP. + case hty: is_word_type => [ws | //]; move /is_word_typeP in hty; subst. + case: ifP => //; rewrite -/(subtype (sword _) _) => hsub. + t_xrbindP => hcheck [xi ei] haddr <- hget /= htr. have h0: Let x := sem_pexpr true [::] s' 0 in to_int x = ok 0 by done. have h1: 0 <= 0 /\ wsize_size ws <= size_slot x.(gv). - + by rewrite hty /=; lia. + + by have /= := size_of_le hsub; lia. have h1' := ofs_bound_option h1 (fun _ => refl_equal). have [sr [bytes [hgvalid hmem halign]]] := check_vpk_wordP h1' hgvk hcheck. have h2: valid_vpk rmap s' x.(gv) sr vpk. @@ -1110,25 +1174,39 @@ Section EXPR. by rewrite hgvk => -[_ [[]] <-]. have [wx [wi [-> -> /= haddr2]]] := check_mk_addr h0 (get_var_kind_wf hgvk) h2 haddr. rewrite -haddr2. - assert (heq := wfr_val hgvalid hget); rewrite hty in heq. + have [ws' [htyx hcmp]] := subtypeEl hsub. + assert (heq := wfr_val hgvalid hget); rewrite htyx in heq. case: heq => hread hty'. + have [ws'' [w [_ ?]]] := get_gvar_word htyx hget; subst v. + case: hty' => ?; subst ws''. assert (hwf := check_gvalid_wf wfr_wf hgvalid). - have [ws' [w [_ ?]]] := get_gvar_word hty hget; subst v. - case: hty' => ?; subst ws'. - rewrite (eq_sub_region_val_read_word _ hwf hread hmem _ h1 (get_val_byte_word w) (w:=w)) //. - by rewrite wrepr0 GRing.addr0 halign. - + move=> al aa sz x e1 he1 e' v he'; apply: on_arr_gvarP => n t hty /= hget. - t_xrbindP => i vi /he1{he1}he1 hvi w hw <-. - move: he'; t_xrbindP => e1' /he1{he1}he1'. + have hwf' := wf_sub_region_subtype hsub hwf. + rewrite (eq_sub_region_val_read_word _ hwf' hread hmem (w:=zero_extend ws w)) //. + + rewrite wrepr0 GRing.addr0 halign /=. + eexists; split; first by reflexivity. + move: htr; rewrite /truncate_val /=. + t_xrbindP=> ? /truncate_wordP [_ ->] <-. + by rewrite truncate_word_u. + + by move=> /=; lia. + move=> k hk. + rewrite zero_extend_wread8 //. + apply (get_val_byte_word w). + by have /= := size_of_le hsub; rewrite htyx /=; lia. + + move=> al aa sz x e1 he1 ty e' v v2 he'; apply: on_arr_gvarP => n t htyx /= hget. + t_xrbindP => i vi /he1{he1}he1 hvi w hw <- htr. + exists (Vword w); split=> //. + move: he'; t_xrbindP => e1' /he1{he1}. + rewrite /truncate_val /= hvi /= => /(_ _ erefl) [] v' [] he1'. + t_xrbindP=> i' hv' ?; subst i'. have h0 : sem_pexpr true [::] s' e1' >>= to_int = ok i. - + by rewrite he1'. + + by rewrite he1' /= hv'. move=> [vpk | ]; last first. + t_xrbindP => h /check_diffP h1 <- /=. by rewrite (get_var_kindP h h1 hget) /= h0 /= hw. t_xrbindP => hgvk hcheck [xi ei] haddr <- /=. have [h1 h2 h3] := WArray.get_bound hw. have h4: 0 <= i * mk_scale aa sz /\ i * mk_scale aa sz + wsize_size sz <= size_slot x.(gv). - + by rewrite hty. + + by rewrite htyx. have h4' := ofs_bound_option h4 (mk_ofsiP h0). have [sr [bytes [hgvalid hmem halign]]] := check_vpk_wordP h4' hgvk hcheck. have h5: valid_vpk rmap s' x.(gv) sr vpk. @@ -1143,22 +1221,59 @@ Section EXPR. rewrite (eq_sub_region_val_read_word _ hwf hread hmem (mk_ofsiP h0) (w:=w)) // /=. + case: al hw h3 h6 {hcheck} halign => //= hw h3 h6 halign. by rewrite (is_align_addE halign) WArray.arr_is_align h3. - by move => k hk; rewrite (read8_alignment al) -h6. - + move=> al1 sz1 v1 e1 IH e2 v. + by move => k hk; rewrite (read8_alignment al) -h6. + + move=> al1 sz1 v1 e1 IH ty e2 v v2. t_xrbindP => /check_varP hc /check_diffP hnnew e1' /IH hrec <- wv1 vv1 /= hget hto' we1 ve1. - move=> /hrec -> hto wr hr ?; subst v. + move=> he1 hto wr hr ? htr; subst v. + exists (Vword wr); split=> //. + have := hrec _ _ he1. + rewrite /truncate_val /= hto /= => /(_ _ erefl) [] v' [] he1'. + t_xrbindP=> w hv' ?; subst w. have := get_var_kindP hc hnnew hget; rewrite /get_gvar /= => -> /=. - by rewrite hto' hto /= -(eq_mem_source_word hvalid (readV hr)) hr. - + move=> o1 e1 IH e2 v. - by t_xrbindP => e1' /IH hrec <- ve1 /hrec /= ->. - + move=> o1 e1 H1 e1' H1' e2 v. - by t_xrbindP => e1_ /H1 hrec e1'_ /H1' hrec' <- ve1 /hrec /= -> /= ve2 /hrec' ->. - + move => e1 es1 H1 e2 v. - t_xrbindP => es1' /H1{H1}H1 <- vs /H1{H1} /=. - by rewrite /sem_pexprs => ->. - move=> t e He e1 H1 e1' H1' e2 v. - t_xrbindP => e_ /He he e1_ /H1 hrec e1'_ /H1' hrec' <-. - by move=> b vb /he /= -> /= -> ?? /hrec -> /= -> ?? /hrec' -> /= -> /= ->. + rewrite hto' /= he1' /= hv' /=. + by rewrite -(eq_mem_source_word hvalid (readV hr)) hr. + + move=> o1 e1 IH ty e2 v v2. + t_xrbindP => e1' /IH hrec <- ve1 /hrec{}hrec hve1 htr. + exists v; split=> //=. + have [ve1' [htr' hve1']] := sem_sop1_truncate_val hve1. + have [v' [he1' /truncate_value_uincl huincl]] := hrec _ htr'. + rewrite he1' /=. + by apply (vuincl_sem_sop1 huincl). + + move=> o2 e1 H1 e2 H2 ty e' v v2. + t_xrbindP => e1' /H1 hrec1 e2' /H2 hrec2 <- ve1 /hrec1{}hrec1 ve2 /hrec2{}hrec2 ho2 htr. + exists v; split=> //=. + have [ve1' [ve2' [htr1 htr2 ho2']]] := sem_sop2_truncate_val ho2. + have [v1' [-> /truncate_value_uincl huincl1]] := hrec1 _ htr1. + have [v2' [-> /truncate_value_uincl huincl2]] := hrec2 _ htr2. + by rewrite /= (vuincl_sem_sop2 huincl1 huincl2 ho2'). + + move => o es1 H1 ty e2 v v2. + t_xrbindP => es1' /H1{H1}H1 <- ves /H1{H1}H1 /= hves htr. + exists v; split=> //. + rewrite -/(sem_pexprs _ _ _ _). + have [ves' [htr' hves']] := sem_opN_truncate_val hves. + have [vs' [-> /mapM2_truncate_value_uincl huincl]] := H1 _ _ htr'. + by rewrite /= (vuincl_sem_opN huincl hves'). + move=> t e He e1 H1 e2 H2 ty e' v v2. + t_xrbindP=> e_ /He he e1_ /H1 hrec1 e2_ /H2 hrec2 <-. + move=> b vb /he{}he hvb ve1 ve1' /hrec1{}hrec1 htr1 ve2 ve2' /hrec2{}hrec2 htr2 <- htr. + move: he; rewrite {1 2}/truncate_val /= hvb /= => /(_ _ erefl) [] vb' [] -> /=. + t_xrbindP=> b' -> ? /=; subst b'. + have hsub: subtype ty t. + + have := truncate_val_subtype htr. + rewrite fun_if. + rewrite (truncate_val_has_type htr1) (truncate_val_has_type htr2). + by rewrite if_same. + have [ve1'' htr1''] := subtype_truncate_val hsub htr1. + have := subtype_truncate_val_idem hsub htr1 htr1''. + move=> /hrec1 [ve1_ [-> /= ->]] /=. + have [ve2'' htr2''] := subtype_truncate_val hsub htr2. + have := subtype_truncate_val_idem hsub htr2 htr2''. + move=> /hrec2 [ve2_ [-> /= ->]] /=. + eexists; split; first by reflexivity. + move: htr. + rewrite !(fun_if (truncate_val ty)). + rewrite htr1'' htr2''. + by rewrite (truncate_val_idem htr1'') (truncate_val_idem htr2''). Qed. Definition alloc_eP := check_e_esP.1. @@ -1323,7 +1438,7 @@ Lemma eq_sub_region_val_same_region s2 sr ty sry ty' mem2 bytes v : eq_sub_region_val ty' mem2 sry (ByteSet.remove bytes (interval_of_zone sr.(sr_zone))) v. Proof. move=> hwf hwfy hr hreadeq [hread hty']. - split=> // off hmem v1 /dup[] /get_val_byte_bound; rewrite hty' => hoff hget. + split=> // off hmem v1 /[dup] /get_val_byte_bound; rewrite hty' => hoff hget. have hwfy' := sub_region_at_ofs_wf_byte hwfy hoff. move: hmem; rewrite memi_mem_U8. move=> /(mem_remove_interval_of_zone (wf_zone_len_gt0 hwf) (wf_zone_len_gt0 hwfy')) [hmem hdisj]. @@ -1742,7 +1857,11 @@ Proof. + move=> al ws x e1 /=; t_xrbindP => /check_varP hx /check_diffP hnnew e1' /(alloc_eP hvs) he1 <-. move=> s1' xp ? hgx hxp w1 v1 /he1 he1' hv1 w hvw mem1 hmem1 <- /=. have := get_var_kindP hvs hx hnnew; rewrite /get_gvar /= => /(_ _ _ hgx) -> /=. - rewrite he1' hxp /= hv1 /= hvw /=. + have {}he1': sem_pexpr true [::] s2 e1' >>= to_pointer = ok w1. + + have [ws1 [wv1 [? hwv1]]] := to_wordI hv1; subst. + move: he1'; rewrite /truncate_val /= hwv1 /= => /(_ _ erefl) [] ve1' [] -> /=. + by t_xrbindP=> w1' -> ? /=; subst w1'. + rewrite he1' hxp /= hvw /=. have hvp1 := write_validw hmem1. have /valid_incl_word hvp2 := hvp1. have /writeV -/(_ w) [mem2 hmem2] := hvp2. @@ -1783,15 +1902,18 @@ Proof. move=> al aa ws x e1 /=; t_xrbindP => e1' /(alloc_eP hvs) he1. move=> hr2 s1'; apply on_arr_varP => n t hty hxt. t_xrbindP => i1 v1 /he1 he1' hi1 w hvw t' htt' /write_varP [? hdb htr]; subst s1'. + have {he1} he1 : sem_pexpr true [::] s2 e1' >>= to_int = ok i1. + + have ? := to_intI hi1; subst. + move: he1'; rewrite /truncate_val /= => /(_ _ erefl) [] ve1' [] -> /=. + by t_xrbindP=> i1' -> ? /=; subst i1'. case hlx: get_local hr2 => [pk | ]; last first. + t_xrbindP=> /check_diffP hnnew <-. have /get_var_kindP -/(_ _ _ hnnew hxt) : get_var_kind pmap (mk_lvar x) = ok None. + by rewrite /get_var_kind /= hlx. rewrite /get_gvar /= => hxt2. - rewrite he1' /= hi1 hxt2 /= hvw /= htt' /= (write_var_truncate hdb htr) //. + rewrite he1 hxt2 /= hvw /= htt' /= (write_var_truncate hdb htr) //. by eexists; split; first reflexivity; apply valid_state_set_var. t_xrbindP => rmap2 /set_arr_wordP [sr [hget hal hset]] [xi ei] ha <- /=. - have {he1} he1 : sem_pexpr true [::] s2 e1' >>= to_int = ok i1 by rewrite he1'. have /wfr_ptr [pk' [hlx' hpk]] := hget. have hgvalid := check_gvalid_lvar hget. move: hlx'; rewrite hlx => -[?]; subst pk'. @@ -2001,7 +2123,7 @@ Proof. rewrite hty. exists a1; split=> //. move=> k w. - move=> /dup[]; rewrite -{1}get_read8 => /WArray.get_valid8 /WArray.in_boundP => hbound. + move=> /[dup]; rewrite -{1}get_read8 => /WArray.get_valid8 /WArray.in_boundP => hbound. rewrite (WArray.get_sub_get8 hgsub) /=. by move: hbound; rewrite -!zify => ->. Qed. @@ -2052,7 +2174,7 @@ Lemma cast_get8 len1 len2 (m : WArray.array len2) (m' : WArray.array len1) : read m Aligned k U8 = ok w. Proof. move=> hcast k w. - move=> /dup[]; rewrite -{1}get_read8 => /WArray.get_valid8 /WArray.in_boundP => hbound. + move=> /[dup]; rewrite -{1}get_read8 => /WArray.get_valid8 /WArray.in_boundP => hbound. rewrite (WArray.cast_get8 hcast). by case: hbound => _ /ZltP ->. Qed. @@ -2368,7 +2490,7 @@ Proof. have {hofs} -> := get_ofs_subP he hofs. move=> hlx hget hsub hread. apply (valid_state_set_move_sub hvs hlx h). - move=> srx /dup[] /hget{hget} ? hget; subst srx; rewrite heq. + move=> srx /[dup] /hget{hget} ? hget; subst srx; rewrite heq. split=> // off hmem w /=. rewrite (WArray.set_sub_get8 ha3) /=. case: ifPn => [_|]. @@ -2488,7 +2610,7 @@ Proof. (sub_region_at_ofs sry (Some ofs) len).(sr_region) x) (Varr a'). + rewrite /= get_var_bytes_set_move_bytes /= !eqxx /=. - move=> off hmem w' /dup[] /get_val_byte_bound /= hoff /hay. + move=> off hmem w' /[dup] /get_val_byte_bound /= hoff /hay. rewrite -sub_region_addr_offset -GRing.addrA -wrepr_add. assert (hval := wfr_val hgvalidy hgety). case: hval => hread _. @@ -2645,7 +2767,7 @@ Proof. have hpky: valid_vpk rmap1 s2 y.(gv) sry vpky. + have /wfr_gptr := hgvalidy. by rewrite hkindy => -[_ [[]] <-]. - t_xrbindP=> -[e1 ofs2] /dup [] hmk_addr /(mk_addr_pexprP true _ hwfpky hpky) [w [he1 haddr]] [] <- _ <-. + t_xrbindP=> -[e1 ofs2] /[dup] hmk_addr /(mk_addr_pexprP true _ hwfpky hpky) [w [he1 haddr]] [] <- _ <-. have [? [ay [hgety hay]]] := get_Pvar_subP he hgete erefl; subst n. have hread: @@ -2661,7 +2783,7 @@ Proof. (sub_region_at_ofs sry (Some ofs) len).(sr_region) x) (Varr a'). + rewrite /= get_var_bytes_set_move_bytes /= !eqxx /=. - move=> off hmem w' /dup[] /get_val_byte_bound /= hoff /hay. + move=> off hmem w' /[dup] /get_val_byte_bound /= hoff /hay. rewrite -sub_region_addr_offset -GRing.addrA -wrepr_add. assert (hval := wfr_val hgvalidy hgety). case: hval => hread _. @@ -2706,13 +2828,16 @@ Proof. have := slh_lowering_proof.hshp_spec_lower hshparams heq. pose s2' := (with_vm s2 (evm s2).[ p <- vp]). move: he1; t_xrbindP => ve1 h1 hve1 /=. - move=> /(_ s2 s2' [::] [::ve1; Vword wmsf] [::Vword (w + wrepr Uptr ofs2)]) /= h. + have := alloc_eP hvs hmsf' hmsf. + rewrite /truncate_val /= htr /= => /(_ _ erefl) [] vmsf' [] ok_vmsf'. + t_xrbindP=> z hto ?; subst z. + move=> /(_ s2 s2' [::] [::ve1; vmsf'] [::Vword (w + wrepr Uptr ofs2)]) /= h. have ? : ofs2 = 0%Z; last subst ofs2. + by case: (vpky) hvpky hmk_addr => // -[] //= ? _ [] _ <-. constructor; rewrite P'_globs; apply h. - + by eexists; [reflexivity | apply htr]. - + by rewrite h1 (alloc_eP hvs hmsf' hmsf). - + by rewrite /exec_sopn /= hve1 htr /= wrepr0 GRing.addr0. + + by eexists; [reflexivity| apply hto]. + + by rewrite h1 /= ok_vmsf' /=. + + by rewrite /exec_sopn /= hve1 hto /= wrepr0 GRing.addr0. rewrite /write_var /set_var /s2' /vp -sub_region_addr_offset haddr wrepr0 !GRing.addr0 /=. by rewrite (wfr_rtype hlocal) cmp_le_refl orbT. Qed. @@ -2766,7 +2891,7 @@ Proof. apply (valid_state_set_move_regptr (ptr_prop _ hpx) hvs (sub_region_at_ofs_0_wf hwfw) hpx htrx). rewrite /set_move /= get_var_bytes_set_move_bytes eqxx /= eqxx /=. rewrite hxty eqxx; split => //. - move=> off hmem ww /dup[] /get_val_byte_bound /= hoff hget. + move=> off hmem ww /[dup] /get_val_byte_bound /= hoff hget. have /(_ _ _ _ _ hvs _ _ _ _ gvalidw) := vs_wf_region.(wfr_val). rewrite get_gvar_nglob in hw => //; last by rewrite -is_lvar_is_glob. rewrite get_gvar_nglob // => /(_ _ hw) [+ _]. @@ -2789,7 +2914,7 @@ Proof. apply (valid_state_set_move_regptr (ptr_prop _ hpy) hvs' (sub_region_at_ofs_0_wf hwfz) hpy htry). rewrite /set_move /= get_var_bytes_set_move_bytes eqxx /= eqxx /=. rewrite hyty eqxx; split => //. - move=> off hmem ww /dup[] /get_val_byte_bound /= hoff hget. + move=> off hmem ww /[dup] /get_val_byte_bound /= hoff hget. have /(_ _ _ _ _ hvs _ _ _ _ gvalidz) := vs_wf_region.(wfr_val). rewrite get_gvar_nglob in hz => //; last by rewrite -is_lvar_is_glob. rewrite get_gvar_nglob // => /(_ _ hz) [+ _]. @@ -3180,7 +3305,7 @@ Lemma wf_rmap_Incl rmap1 rmap2 s1 s2 : wf_rmap rmap2 s1 s2 -> wf_rmap rmap1 s1 s2. Proof. - move=> /dup[] hincl [hinclr hsub] hwfr. + move=> /[dup] hincl [hinclr hsub] hwfr. case: (hwfr) => hwfsr hval hptr; split. + move=> x sr /hinclr. by apply hwfsr. @@ -3452,7 +3577,7 @@ Proof. move: hget; rewrite /get_gvar /= => /get_varP []. by rewrite /get_var hty => <- ? /compat_valEl [a] ->. have /(wfr_val hgvalid) [hread /= hty] := hget'. - move=> off w /dup[] /get_val_byte_bound; rewrite hty => hoff. + move=> off w /[dup] /get_val_byte_bound; rewrite hty => hoff. apply hread. have := subset_inter_l bytes @@ -3933,7 +4058,7 @@ Proof. move=> hvs hlwf hlunch hldisj. move=> x sr bytes v /= hgvalid /(wfr_val hgvalid) [hread hty]. have /(check_gvalid_wf wfr_wf) /= hwf := hgvalid. - split=> // off hmem w /dup[] /get_val_byte_bound; rewrite hty => hoff hget. + split=> // off hmem w /[dup] /get_val_byte_bound; rewrite hty => hoff hget. rewrite -(hread _ hmem _ hget). apply (eq_read_holed_rmap hvs hlwf hlunch hldisj hwf hoff). move=> hw. @@ -4212,7 +4337,7 @@ Proof. by rewrite /get_var hty => <- ? /compat_valEl [a] ->. assert (hval := wfr_val hgvalid hget'). case: hval => hread hty. - move=> off w /dup[] /get_val_byte_bound; rewrite hty => hoff. + move=> off w /[dup] /get_val_byte_bound; rewrite hty => hoff. apply hread. have := subset_inter_l bytes @@ -4485,7 +4610,7 @@ Proof. + rewrite /s1''' /s2'''. apply: (valid_state_set_sub_region_regptr _ hvs1'' hwfg hsub hofs hlx hrmap2' h). + by rewrite hlocal.(wfr_rtype). - rewrite htreq; split=> // off hmem w /dup[] /get_val_byte_bound /= hoff. + rewrite htreq; split=> // off hmem w /[dup] /get_val_byte_bound /= hoff. rewrite (WArray.fill_get8 hfill) (fill_mem_read8_no_overflow _ hfillm) -?(WArray.fill_size hfill) ?positive_nat_Z /=; try lia. diff --git a/proofs/compiler/stack_alloc_proof_2.v b/proofs/compiler/stack_alloc_proof_2.v index af9f796bc..0698c489c 100644 --- a/proofs/compiler/stack_alloc_proof_2.v +++ b/proofs/compiler/stack_alloc_proof_2.v @@ -3,8 +3,8 @@ *) (* ** Imports and settings *) -From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq eqtype fintype. -From mathcomp Require Import div ssralg. +From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq eqtype. +From mathcomp Require Import ssralg. From mathcomp Require Import word_ssrZ. Require Import psem psem_facts compiler_util. Require Export stack_alloc stack_alloc_proof. @@ -1134,7 +1134,7 @@ Proof. have ?: x <> p. + by move /is_sarrP: harr => [n]; congruence. by move=> /SvD.F.add_3; auto. - move=> ? /dup[] ? /hnew ?. + move=> ? /[dup] ? /hnew ?. have ?: p <> y by congruence. by move=> /SvD.F.add_3; auto. move=> s z f. @@ -1191,7 +1191,7 @@ Proof. case: eqP. + move=> <- _. by move=> /SvD.F.add_3; auto. - move=> ? /dup[] ? /hnew ?. + move=> ? /[dup] ? /hnew ?. have ?: f <> y by congruence. by move=> /SvD.F.add_3; auto. Qed. @@ -1402,7 +1402,7 @@ Proof. have ?: param.(v_var) <> pi.(pp_ptr). + by move /is_sarrP : harrty => [n]; congruence. by move=> /SvD.F.add_3; auto. - move=> ? /dup[] ? /hnew ?. + move=> ? /[dup] ? /hnew ?. have ?: pi.(pp_ptr) <> y by congruence. by move=> /SvD.F.add_3; auto. Qed. @@ -1977,7 +1977,7 @@ Proof. have [s2' [hs2' hvs']] := alloc_array_move_initP hwf.(wfsl_no_overflow) hwf.(wfsl_disjoint) hwf.(wfsl_align) hpmap P'_globs hsaparams hvs hv htr hw halloc. by exists s2'; split => //; apply sem_seq1; constructor. move=> e' he1 [rmap2' x'] hax /= ?? m0 s2 hvs hext hsao; subst rmap2' c2. - have he := alloc_eP hwf.(wfsl_no_overflow) hwf.(wfsl_align) hpmap hvs he1. + have [ve' [hve' htr']] := alloc_eP hwf.(wfsl_no_overflow) hwf.(wfsl_align) hpmap hvs he1 hv htr. have htyv':= truncate_val_has_type htr. have [s2' [/= hw' hvs']]:= alloc_lvalP hwf.(wfsl_no_overflow) hwf.(wfsl_disjoint) hwf.(wfsl_align) hpmap hax hvs htyv' hw. exists s2'; split=> //. @@ -2016,7 +2016,10 @@ Proof. have [s2' [hw' hvalid']] := alloc_lvalsP hwf.(wfsl_no_overflow) hwf.(wfsl_disjoint) hwf.(wfsl_align) hpmap ha hvs (sopn_toutP hop) hw. exists s2'; split=> //. apply sem_seq_ir; constructor. - by rewrite /sem_sopn P'_globs (alloc_esP hwf.(wfsl_no_overflow) hwf.(wfsl_align) hpmap hvs he hes) /= hop. + rewrite /sem_sopn P'_globs. + have [va' [ok_va' hop']] := exec_sopn_truncate_val hop. + have [vs3 [ok_vs3 htr']] := alloc_esP hwf.(wfsl_no_overflow) hwf.(wfsl_align) hpmap hvs he hes ok_va'. + by rewrite ok_vs3 /= (truncate_val_exec_sopn htr' hop'). Qed. Local Lemma Hsyscall : sem_Ind_syscall P Pi_r. @@ -2053,7 +2056,8 @@ Local Lemma Hif_true : sem_Ind_if_true P ev Pc Pi_r. Proof. move=> s1 s2 e c1 c2 Hse _ Hc pmap rsp Slots Addr Writable Align rmap1 rmap2 ii1 c hpmap hwf sao /=. t_xrbindP => e' he [rmap4 c1'] hc1 [rmap5 c2'] hc2 /= ?? m0 s1' hv hext hsao; subst rmap2 c. - have := alloc_eP hwf.(wfsl_no_overflow) hwf.(wfsl_align) hpmap hv he Hse; rewrite -P'_globs => he'. + have := alloc_eP hwf.(wfsl_no_overflow) hwf.(wfsl_align) hpmap hv he Hse; rewrite -P'_globs. + move=> /(_ _ erefl) [] b [] he' /= /truncate_valI [_ ?]; subst b. have [s2' [Hsem Hvalid']] := Hc _ _ _ _ _ _ _ _ _ hpmap hwf _ hc1 _ _ hv hext hsao. exists s2'; split; first by apply sem_seq1;constructor;apply: Eif_true. by apply: valid_state_Incl Hvalid'; apply incl_Incl; apply incl_merge_l. @@ -2063,7 +2067,8 @@ Local Lemma Hif_false : sem_Ind_if_false P ev Pc Pi_r. Proof. move=> s1 s2 e c1 c2 Hse _ Hc pmap rsp Slots Addr Writable Align rmap1 rmap2 ii1 c hpmap hwf sao /=. t_xrbindP => e' he [rmap4 c1'] hc1 [rmap5 c2'] hc2 /= ?? m0 s1' hv hext hsao; subst rmap2 c. - have := alloc_eP hwf.(wfsl_no_overflow) hwf.(wfsl_align) hpmap hv he Hse; rewrite -P'_globs => he'. + have := alloc_eP hwf.(wfsl_no_overflow) hwf.(wfsl_align) hpmap hv he Hse; rewrite -P'_globs. + move=> /(_ _ erefl) [] b [] he' /= /truncate_valI [_ ?]; subst b. have [s2' [Hsem Hvalid']] := Hc _ _ _ _ _ _ _ _ _ hpmap hwf _ hc2 _ _ hv hext hsao. exists s2'; split; first by apply sem_seq1; constructor; apply: Eif_false. by apply: valid_state_Incl Hvalid'; apply incl_Incl; apply incl_merge_r. @@ -2088,7 +2093,8 @@ Proof. t_xrbindP => -[rmap7 c11] hc1 /= e1 he [rmap8 c22] /= hc2 ????? hincl2 ??. subst c rmap4 rmap7 rmap8 e1 c11 c22 => m0 s1' /(valid_state_Incl hincl1) hv hext hsao. have [s2' [hs1 hv2]]:= Hc1 _ _ _ _ _ _ _ _ _ hpmap hwf _ hc1 _ _ hv hext hsao. - have := alloc_eP hwf.(wfsl_no_overflow) hwf.(wfsl_align) hpmap hv2 he Hv; rewrite -P'_globs => he'. + have := alloc_eP hwf.(wfsl_no_overflow) hwf.(wfsl_align) hpmap hv2 he Hv; rewrite -P'_globs. + move=> /(_ _ erefl) [] b [] he' /= /truncate_valI [_ ?]; subst b. have hsao2 := stack_stable_wf_sao (sem_stack_stable_sprog hs1) hsao. have hext2 := valid_state_extend_mem hwf hv hext hv2 (sem_validw_stable_uprog hhi) (sem_validw_stable_sprog hs1). have [s3' [hs2 /(valid_state_Incl (incl_Incl hincl2)) hv3]]:= Hc2 _ _ _ _ _ _ _ _ _ hpmap hwf _ hc2 _ _ hv2 hext2 hsao2. @@ -2107,7 +2113,8 @@ Proof. t_xrbindP => -[rmap7 c11] hc1 /= e1 he [rmap8 c22] /= hc2 ????? hincl2 ??. subst c rmap4 rmap7 rmap8 e1 c11 c22 => m0 s1' /(valid_state_Incl hincl1) hv hext hsao. have [s2' [hs1 hv2]]:= Hc1 _ _ _ _ _ _ _ _ _ hpmap hwf _ hc1 _ _ hv hext hsao. - have := alloc_eP hwf.(wfsl_no_overflow) hwf.(wfsl_align) hpmap hv2 he Hv; rewrite -P'_globs => he'. + have := alloc_eP hwf.(wfsl_no_overflow) hwf.(wfsl_align) hpmap hv2 he Hv; rewrite -P'_globs. + move=> /(_ _ erefl) [] b [] he' /= /truncate_valI [_ ?]; subst b. by exists s2';split => //; apply sem_seq1; constructor; apply: Ewhile_false; eassumption. Qed. @@ -2294,53 +2301,6 @@ Proof. by case: hvs => <- *. Qed. -(* Not sure at all if this is the right way to do the proof. *) -Lemma wbit_subword (ws ws' : wsize) i (w : word ws) k : - wbit_n (word.subword i ws' w) k = (k < ws')%nat && wbit_n w (k + i). -Proof. - clear. - rewrite /wbit_n. - case: ltP. - + move=> /ltP hlt. - by rewrite word.subwordE word.wbit_t2wE (nth_map ord0) ?size_enum_ord // nth_enum_ord. - rewrite /nat_of_wsize => hle. - rewrite word.wbit_word_ovf //. - by apply /ltP; lia. -Qed. - -(* TODO: is this result generic enough to be elsewhere ? *) -Lemma zero_extend_wread8 (ws ws' : wsize) (w : word ws) : - (ws' <= ws)%CMP -> - forall off, - 0 <= off < wsize_size ws' -> - LE.wread8 (zero_extend ws' w) off = LE.wread8 w off. -Proof. - clear. - move=> /wsize_size_le /(Z.divide_pos_le _ _ (wsize_size_pos _)) hle off hoff. - rewrite /LE.wread8 /LE.encode /split_vec. - have hmod: forall (ws:wsize), ws %% U8 = 0%nat. - + by move=> []. - have hdiv: forall (ws:wsize), ws %/ U8 = Z.to_nat (wsize_size ws). - + by move=> []. - have hlt: (Z.to_nat off < Z.to_nat (wsize_size ws))%nat. - + by apply /ltP /Z2Nat.inj_lt; lia. - have hlt': (Z.to_nat off < Z.to_nat (wsize_size ws'))%nat. - + by apply /ltP /Z2Nat.inj_lt; lia. - rewrite !hmod !addn0. - rewrite !(nth_map 0%nat) ?size_iota ?hdiv // !nth_iota // !add0n. - apply /eqP/eq_from_wbit_n => i. - rewrite !wbit_subword; f_equal. - rewrite wbit_zero_extend. - have -> //: (i + Z.to_nat off * U8 <= wsize_size_minus_1 ws')%nat. - rewrite -ltnS -/(nat_of_wsize ws'). - apply /ltP. - have := ltn_ord i; rewrite -/(nat_of_wsize _) => /ltP hi. - have /ltP ? := hlt'. - have <-: (Z.to_nat (wsize_size ws') * U8 = ws')%nat. - + by case: (ws'). - by rewrite -!multE -!plusE; nia. -Qed. - (* Actually, I think we could have proved something only for arrays, since we use this result when the target value is a pointer, in which case the source value is an array. But it is not clear whether we know that the source value @@ -2695,7 +2655,7 @@ Proof. have hj := nth_not_default hpi ltac:(discriminate). move=> /= [p [-> hread]] hresultp. exists p; split; first by reflexivity. - move=> off w /dup[] /get_val_byte_bound hoff. + move=> off w /[dup] /get_val_byte_bound hoff. rewrite -hfss.(fss_read_old8); first by apply hread. move: (hargs j); rewrite /wf_arg (nth_map None) //. rewrite hpi /= -hresultp.(wrp_args). diff --git a/proofs/compiler/stack_zeroization.v b/proofs/compiler/stack_zeroization.v index f94b58e33..10ea23985 100644 --- a/proofs/compiler/stack_zeroization.v +++ b/proofs/compiler/stack_zeroization.v @@ -51,19 +51,23 @@ End E. (* -------------------------------------------------------------------- *) (* Architecture-specific parameters. *) -Record stack_zeroization_params {AB : Tabstract} {asm_op : Type} {asmop : asmOp asm_op} := - { - szp_cmd : - stack_zero_strategy -> (* zeroization strategy *) - Ident.ident -> (* RSP *) - label -> (* fresh label *) - wsize -> (* stack alignment *) - wsize -> (* clearing step *) - Z -> (* stack size to be zeroized *) - cexec (lcmd * Sv.t); - (* the command and the set of written variables in the command (except RSP) *) - }. +Section STACK_ZEROIZATION_PARAM. + Context {AB : Tabstract}. + + Record stack_zeroization_params {asm_op : Type} {asmop : asmOp asm_op} := + { + szp_cmd : + stack_zero_strategy -> (* zeroization strategy *) + Ident.ident -> (* RSP *) + label -> (* fresh label *) + wsize -> (* stack alignment *) + wsize -> (* clearing step *) + Z -> (* stack size to be zeroized *) + cexec (lcmd * Sv.t); + (* the command and the set of written variables in the command (except RSP) *) + }. +End STACK_ZEROIZATION_PARAM. Section STACK_ZEROIZATION. diff --git a/proofs/compiler/x86_lowering.v b/proofs/compiler/x86_lowering.v index 2c8eed536..8e44986d1 100644 --- a/proofs/compiler/x86_lowering.v +++ b/proofs/compiler/x86_lowering.v @@ -601,7 +601,7 @@ Fixpoint lower_i (i:instr) : cmd := [:: MkI ii (Cfor v (d, lo, hi) (conc_map lower_i c))] | Cwhile a c e c' => let '(pre, e) := lower_condition (var_info_of_ii ii) e in - map (MkI ii) [:: Cwhile a ((conc_map lower_i c) ++ map (MkI dummy_instr_info) pre) e (conc_map lower_i c')] + map (MkI ii) [:: Cwhile a ((conc_map lower_i c) ++ map (MkI ii) pre) e (conc_map lower_i c')] | _ => map (MkI ii) [:: ir] end. diff --git a/proofs/compiler/x86_lowering_proof.v b/proofs/compiler/x86_lowering_proof.v index 09889e823..0b9e36108 100644 --- a/proofs/compiler/x86_lowering_proof.v +++ b/proofs/compiler/x86_lowering_proof.v @@ -557,7 +557,7 @@ Section PROOF. Proof. rewrite /lower_cassgn_classify. move: e Hs=> [z|b|n|x|al aa ws x e | aa ws len x e |al sz x e| o e|o e1 e2| op es |e e1 e2] //. - + case: x => - [] [] [] // sz vn vi vs //= /dup[] ok_v. + + case: x => - [] [] [] // sz vn vi vs //= /[dup] ok_v. case/type_of_get_gvar => sz' [Hs Hs']. have := truncate_val_subtype Hv'. rewrite Hs -(truncate_val_has_type Hv'). case hty: (type_of_val v') => [ | | | sz'' ] //= hle. @@ -1813,7 +1813,7 @@ Section PROOF. have [s2' [Hs2'1 Hs2'2]] := Hc Hc1 _ Hs1'. have [s3' [Hs3'1 Hs3'2 Hs3'3]] := lower_condition_corr - dummy_instr_info + ii Hcond Hs2'2 (eeq_exc_sem_pexpr Hdisje Hs2'2 Hz). @@ -1840,7 +1840,7 @@ Section PROOF. have [s2' [Hs2'1 Hs2'2]] := Hc Hc1 _ Hs1'. have [s3' [Hs3'1 Hs3'2 Hs3'3]] := lower_condition_corr - dummy_instr_info + ii Hcond Hs2'2 (eeq_exc_sem_pexpr Hdisje Hs2'2 Hz). diff --git a/proofs/compiler/x86_params_proof.v b/proofs/compiler/x86_params_proof.v index aa986053b..f39ed6c1f 100644 --- a/proofs/compiler/x86_params_proof.v +++ b/proofs/compiler/x86_params_proof.v @@ -44,6 +44,7 @@ Unset Strict Implicit. Unset Printing Implicit Defensive. #[local] Existing Instance withsubword. +#[local] Existing Instance direct_c. Section Section. Context {atoI : arch_toIdent} {syscall_state : Type} {sc_sem : syscall_sem syscall_state}. @@ -53,7 +54,7 @@ Context {atoI : arch_toIdent} {syscall_state : Type} {sc_sem : syscall_sem sysca (* Stack alloc hypotheses. *) Section STACK_ALLOC. -Context {dc : DirectCall} (P' : sprog). +Context (P' : sprog). Lemma lea_ptrP s1 e i x tag ofs w s2 : P'.(p_globs) = [::] @@ -124,7 +125,7 @@ Qed. End STACK_ALLOC. -Definition x86_hsaparams {dc : DirectCall} : h_stack_alloc_params (ap_sap x86_params) := +Definition x86_hsaparams : h_stack_alloc_params (ap_sap x86_params) := {| mov_ofsP := x86_mov_ofsP; sap_immediateP := x86_immediateP; @@ -290,7 +291,7 @@ Qed. (* Lowering hypotheses. *) (* Due to the order of the parameters we can't defined this as a record. *) -Definition x86_hloparams {dc : DirectCall} : h_lowering_params (ap_lop x86_params). +Definition x86_hloparams : h_lowering_params (ap_lop x86_params). Proof. split. exact: @lower_callP. Defined. @@ -722,7 +723,7 @@ Opaque cat. rewrite /se_protect_large_sem Hws /= => -[?]?; subst tr ys. case: lvs => // -[] // [aux iaux] [] // y [] // hws. case: args hes => // ew [] // emsf [] // hes1. - t_xrbindP; rewrite negb_or => /andP [] haux1 haux2 hops /dup[] + hmap hlo. + t_xrbindP; rewrite negb_or => /andP [] haux1 haux2 hops /[dup] + hmap hlo. Transparent cat. rewrite -hops /=; t_xrbindP => -[op1 oargs1] hass1 z0 z1 _ z2. rewrite mapM_cat /=; t_xrbindP => _ _ _ -[op2 oargs2] hass2 _ _ _ _ {z0 z1 z2}. @@ -909,7 +910,7 @@ Qed. (* ------------------------------------------------------------------------ *) -Definition x86_h_params {dc : DirectCall} {call_conv : calling_convention} : h_architecture_params x86_params := +Definition x86_h_params {call_conv : calling_convention} : h_architecture_params x86_params := {| hap_hsap := x86_hsaparams; hap_hlip := x86_hliparams; diff --git a/proofs/lang/memory_example.v b/proofs/lang/memory_example.v index 2b6d8dd4a..f292b0ab0 100644 --- a/proofs/lang/memory_example.v +++ b/proofs/lang/memory_example.v @@ -325,7 +325,7 @@ Module MemoryI : MemoryT. (wunsigned (stk_root m) - (footprint_of_frame f + footprint_of_stack (frames m)) + frame_off f) (frame_size f - frame_off f)) x = false. Proof. - case/andP => /dup [] /footprint_of_valid_frame ok_f /and3P [] /ZleP h0fo /ZleP hfo _ ok_ws /= range. + case/andP => /[dup] /footprint_of_valid_frame ok_f /and3P [] /ZleP h0fo /ZleP hfo _ ok_ws /= range. rewrite set_allocP. case: ifPn; rewrite !zify; first lia. move => nrange; apply: m.(stk_freeP); lia. @@ -598,7 +598,7 @@ Module MemoryI : MemoryT. move: h; rewrite /alloc_stack; case: Sumbool.sumbool_of_bool => // h [<-] /=. rewrite -!valid8_validw /valid8 /= /is_alloc /top_stack /=. case/and3P: h. - set fr := {| frame_size := sz |} => /dup [] ok_f /and3P[] /ZleP h0fo hfo _ /lezP no_ovf _. + set fr := {| frame_size := sz |} => /[dup] ok_f /and3P[] /ZleP h0fo hfo _ /lezP no_ovf _. rewrite set_allocP /between /zbetween Zleb_succ. have b_pos := wunsigned_range m.(stk_root). have l_pos := wunsigned_range m.(stk_limit). @@ -815,7 +815,7 @@ Module MemoryI : MemoryT. validw (free_stack m) Aligned p U8 → read m Aligned p U8 = read (free_stack m) Aligned p U8. Proof. - move => /dup [] hv'; rewrite (fss_valid m) => /andP[] hv hp. + move => /[dup] hv'; rewrite (fss_valid m) => /andP[] hv hp. by move: hv' hv; rewrite -!valid8_validw -!get_read8 /memory_model.get /= /get => -> ->. Qed. diff --git a/proofs/lang/memory_model.v b/proofs/lang/memory_model.v index 420aeb981..59dc70c03 100644 --- a/proofs/lang/memory_model.v +++ b/proofs/lang/memory_model.v @@ -537,7 +537,7 @@ Lemma disjoint_zrange_U8 p sz p' sz' : (forall k, 0 <= k /\ k < sz' -> disjoint_zrange p sz (p' + wrepr _ k) (wsize_size U8)) -> disjoint_zrange p sz p' sz'. Proof. - move=> hsz /dup[] /Z.lt_le_incl. + move=> hsz /[dup] /Z.lt_le_incl. move: sz'; apply: natlike_ind; first by lia. move=> sz' hsz' ih _ hover hdisj. have /Z_le_lt_eq_dec [?|?] := hsz'. @@ -580,7 +580,7 @@ Qed. (** Pointer arithmetic *) #[ global ] -Instance Pointer : pointer_op pointer. +Instance PointerW : pointer_op pointer. Proof. refine {| add p k := (p + wrepr Uptr k)%R @@ -609,7 +609,7 @@ Proof. rewrite /= wrepr_add; ssring. Qed. Lemma p_to_zE p : p_to_z p = wunsigned p. Proof. done. Qed. -Global Opaque Pointer. +Global Opaque PointerW. Lemma disjoint_zrange_alt a m b n : disjoint_zrange a m b n → @@ -859,7 +859,7 @@ Section SPEC. validw m Aligned p s -> disjoint_zrange p (wsize_size s) pstk sz. Proof. - move=> /dup[] /ass.(ass_fresh) hfresh hvalid. + move=> /[dup] /ass.(ass_fresh) hfresh hvalid. split=> //. + apply is_align_no_overflow. by move: hvalid => /validwP [? _]. diff --git a/proofs/lang/psem.v b/proofs/lang/psem.v index 0e1f5c72b..62e49733c 100644 --- a/proofs/lang/psem.v +++ b/proofs/lang/psem.v @@ -473,7 +473,7 @@ Lemma get_var_to_word wdb vm x ws w : get_var wdb vm x >>= to_word ws = ok w -> get_var wdb vm x = ok (Vword w). Proof. - t_xrbindP => htx v /dup[] /get_varP [] -> hdef + ->. + t_xrbindP => htx v /[dup] /get_varP [] -> hdef + ->. rewrite htx => hcomp /to_wordI' [ws1 [w1 [hws hx ->]]]. move: hcomp; rewrite hx => /compat_valE [ws2 [?] hws']; subst ws2. have <- : ws1 = ws; last by rewrite zero_extend_u. @@ -1279,7 +1279,7 @@ Lemma write_var_eq_on wdb X x v s1 s2 vm1: write_var wdb x v (with_vm s1 vm1) = ok (with_vm s2 vm2) & evm s2 =[Sv.add x X] vm2. Proof. - move=> /dup [] /(write_var_eq_on1 vm1) [vm2' hw2 h] hw1 hs. + move=> /[dup] /(write_var_eq_on1 vm1) [vm2' hw2 h] hw1 hs. exists vm2' => //; rewrite SvP.MP.add_union_singleton. apply: (eq_on_union hs h); [apply: vrvP_var hw1 | apply: vrvP_var hw2]. Qed. @@ -1360,6 +1360,26 @@ Corollary get_gvar_uincl wdb x gd vm1 vm2 v1: exists2 v2, get_gvar wdb gd vm2 x = ok v2 & value_uincl v1 v2. Proof. by move => /(_ x.(gv)) h; apply: get_gvar_uincl_at; case: ifP. Qed. +Lemma vuincl_sem_sop1 o ve1 ve1' v1 : + value_uincl ve1 ve1' -> sem_sop1 o ve1 = ok v1 -> + sem_sop1 o ve1' = ok v1. +Proof. + rewrite /sem_sop1; t_xrbindP=> /of_value_uincl_te h + /h{h}. + by case: o; last case; move=> > -> /= ->. +Qed. + +Lemma sem_sop1_truncate_val o ve1 v1 : + sem_sop1 o ve1 = ok v1 -> + exists ve1', + truncate_val (type_of_op1 o).1 ve1 = ok ve1' /\ + sem_sop1 o ve1' = ok v1. +Proof. + rewrite /sem_sop1 /truncate_val. + t_xrbindP=> w -> <- /=. + eexists; split; first by reflexivity. + by rewrite of_val_to_val. +Qed. + Lemma vuincl_sem_sop2 o ve1 ve1' ve2 ve2' v1 : value_uincl ve1 ve1' -> value_uincl ve2 ve2' -> sem_sop2 o ve1 ve2 = ok v1 -> @@ -1374,27 +1394,75 @@ Proof. | _ => idtac end => > -> > -> ? /=; (move=> -> || case=> ->) => /= ->. Qed. -Lemma vuincl_sem_sop1 o ve1 ve1' v1 : - value_uincl ve1 ve1' -> sem_sop1 o ve1 = ok v1 -> - sem_sop1 o ve1' = ok v1. +Lemma sem_sop2_truncate_val o ve1 ve2 v1 : + sem_sop2 o ve1 ve2 = ok v1 -> + exists ve1' ve2', [/\ + truncate_val (type_of_op2 o).1.1 ve1 = ok ve1', + truncate_val (type_of_op2 o).1.2 ve2 = ok ve2' & + sem_sop2 o ve1' ve2' = ok v1]. Proof. - rewrite /sem_sop1; t_xrbindP=> /of_value_uincl_te h + /h{h}. - by case: o; last case; move=> > -> /= ->. + rewrite /sem_sop2 /truncate_val. + t_xrbindP=> w1 -> w2 -> w ho <- /=. + eexists _, _; split; [by reflexivity..|]. + by rewrite !of_val_to_val /= ho. Qed. Lemma vuincl_sem_opN op vs v vs' : - sem_opN op vs = ok v → List.Forall2 value_uincl vs vs' → - exists2 v' : value, sem_opN op vs' = ok v' & value_uincl v v'. + sem_opN op vs = ok v → + sem_opN op vs' = ok v. Proof. rewrite /sem_opN. - t_xrbindP => q ok_q <-{v} hvs. + t_xrbindP => hvs q ok_q <-{v}. have -> /= := vuincl_sopn _ hvs ok_q. + by eauto. case: {q ok_q} op => //. by move => sz n; rewrite /= all_nseq orbT. Qed. +Lemma sem_opN_truncate_val o vs v : + sem_opN o vs = ok v -> + exists vs', + mapM2 ErrType truncate_val (type_of_opN o).1 vs = ok vs' /\ + sem_opN o vs' = ok v. +Proof. + rewrite /sem_opN. + t_xrbindP=> w hvs <-. + have [vs' [-> hvs']] := app_sopn_truncate_val hvs. + eexists; split; first by reflexivity. + by rewrite hvs'. +Qed. + +Lemma vuincl_exec_opn {sip : SemInstrParams asm_op syscall_state} o vs vs' v : + List.Forall2 value_uincl vs vs' -> exec_sopn o vs = ok v -> + exists2 v', exec_sopn o vs' = ok v' & List.Forall2 value_uincl v v'. +Proof. + rewrite /exec_sopn /sopn_sem => vs_vs' ho. + exact: (get_instr_desc o).(semu) vs_vs' ho. +Qed. + +Lemma truncate_val_exec_sopn {sip : SemInstrParams asm_op syscall_state} o vs vs' v : + mapM2 ErrType truncate_val (sopn_tin o) vs = ok vs' -> + exec_sopn o vs' = ok v -> + exec_sopn o vs = ok v. +Proof. + move=> htr; rewrite /exec_sopn. + t_xrbindP=> w ok_w <-. + by rewrite (truncate_val_app_sopn htr ok_w). +Qed. + +Lemma exec_sopn_truncate_val {sip : SemInstrParams asm_op syscall_state} o vs v : + exec_sopn o vs = ok v -> + exists vs', + mapM2 ErrType truncate_val (sopn_tin o) vs = ok vs' /\ + exec_sopn o vs' = ok v. +Proof. + rewrite /exec_sopn; t_xrbindP=> w ok_w <-. + have [? [-> {}ok_w]] := app_sopn_truncate_val ok_w. + eexists; split; first by reflexivity. + by rewrite ok_w. +Qed. + (* --------------------------------------------------------- *) Lemma sem_pexpr_uincl_on_pair wdb gd s1 vm2 : (∀ e v1, @@ -1443,7 +1511,7 @@ Proof. /uincl_on_union_and[] /He2{He2} He2 _; t_xrbindP => ? /He1 [? -> /vuincl_sem_sop2 h1] ? /He2 [? -> /h1 h2/h2]; exists v1. + by move => op es Hes v /Hes{}Hes; t_xrbindP => vs1 /Hes[] vs2; - rewrite /sem_pexprs => -> /vuincl_sem_opN h{}/h. + rewrite /sem_pexprs => -> /vuincl_sem_opN h{}/h; exists v. move => t e He e1 He1 e2 He2 v1. rewrite !read_eE => /uincl_on_union_and[] /He{He}He /uincl_on_union_and[] /He1{He1}He1 /uincl_on_union_and[] /He2{He2}He2 _; t_xrbindP => b @@ -1499,14 +1567,6 @@ Proof. by have /(_ _ h1) := sem_pexprs_uincl_on _ h2. Qed. -Lemma vuincl_exec_opn {sip : SemInstrParams asm_op syscall_state} o vs vs' v : - List.Forall2 value_uincl vs vs' -> exec_sopn o vs = ok v -> - exists2 v', exec_sopn o vs' = ok v' & List.Forall2 value_uincl v v'. -Proof. - rewrite /exec_sopn /sopn_sem => vs_vs' ho. - exact: (get_instr_desc o).(semu) vs_vs' ho. -Qed. - Lemma write_var_uincl_on wdb X (x : var_i) v1 v2 s1 s2 vm1 : value_uincl v1 v2 -> write_var wdb x v1 s1 = ok s2 -> @@ -1537,7 +1597,7 @@ Corollary write_var_uincl wdb s1 s2 vm1 v1 v2 (x : var_i) : write_var wdb x v2 (with_vm s1 vm1) = ok (with_vm s2 vm2) & s2.(evm) <=1 vm2. Proof. - move => Hvm hv /dup[] hw1 /(write_var_uincl_on1 vm1 hv) {hv} [] vm2 hw2 le. + move => Hvm hv /[dup] hw1 /(write_var_uincl_on1 vm1 hv) {hv} [] vm2 hw2 le. exists vm2 => //; apply: (uincl_on_vm_uincl Hvm le); [apply: vrvP_var hw1 | apply: vrvP_var hw2]. Qed. diff --git a/proofs/lang/psem_facts.v b/proofs/lang/psem_facts.v index 4daf8aa2c..ec2c02fec 100644 --- a/proofs/lang/psem_facts.v +++ b/proofs/lang/psem_facts.v @@ -193,16 +193,16 @@ Lemma mem_equiv_mkI : sem_Ind_mkI P ev Pi_r Pi. Proof. by []. Qed. Lemma mem_equiv_assgn : sem_Ind_assgn P Pi_r. -Proof. by move => s1 s2 x tg ty e v v' ok_v ok_v' /dup[] /write_lval_validw ? /write_lval_stack_stable. Qed. +Proof. by move => s1 s2 x tg ty e v v' ok_v ok_v' /[dup] /write_lval_validw ? /write_lval_stack_stable. Qed. Lemma mem_equiv_opn : sem_Ind_opn P Pi_r. -Proof. by move => s1 s2 tg op xs es; rewrite /sem_sopn; t_xrbindP => ???? /dup[] /write_lvals_validw ? /write_lvals_stack_stable. Qed. +Proof. by move => s1 s2 tg op xs es; rewrite /sem_sopn; t_xrbindP => ???? /[dup] /write_lvals_validw ? /write_lvals_stack_stable. Qed. Lemma mem_equiv_syscall : sem_Ind_syscall P Pi_r. Proof. move => s1 scs m s2 o xs es ves vs hes h. have [ho1 ho2]:= exec_syscallS h. - move=> /dup[] /write_lvals_validw ho3 /write_lvals_stack_stable ?. + move=> /[dup] /write_lvals_validw ho3 /write_lvals_stack_stable ?. split; [rewrite ho1 | move=> ???; rewrite ho2] => //; exact: ho3. Qed. @@ -244,7 +244,7 @@ Qed. Lemma mem_equiv_call : sem_Ind_call P ev Pi_r Pfun. Proof. move=> s1 scs2 m2 s2 xs fn args vargs vres _ _ - ? /dup[] /write_lvals_validw ? /write_lvals_stack_stable ?. + ? /[dup] /write_lvals_validw ? /write_lvals_stack_stable ?. red. etransitivity; by eauto. Qed. diff --git a/proofs/lang/psem_of_sem_proof.v b/proofs/lang/psem_of_sem_proof.v index b4c8ce68e..bc8d8c3d8 100644 --- a/proofs/lang/psem_of_sem_proof.v +++ b/proofs/lang/psem_of_sem_proof.v @@ -92,7 +92,7 @@ Lemma set_var_sim (vm1 : vmap_n) (vm1' : vmap_s) x v vm2 : (vm2 =1 vm2')%vm ∧ set_var true vm1' x v = ok vm2'. Proof. - move=> hsim /set_varP [hdb /dup []htr /truncatable_sim htr' ->]. + move=> hsim /set_varP [hdb /[dup]htr /truncatable_sim htr' ->]. rewrite (set_var_truncate hdb htr') //; eexists; split; last by eauto. by apply vmap_set_sim. Qed. diff --git a/proofs/lang/utils.v b/proofs/lang/utils.v index 175e9ec86..b8a64b8de 100644 --- a/proofs/lang/utils.v +++ b/proofs/lang/utils.v @@ -1538,13 +1538,6 @@ Qed. (* ** Some Extra tactics * -------------------------------------------------------------------- *) -(* -------------------------------------------------------------------- *) -Variant dup_spec (P : Prop) := -| Dup of P & P. - -Lemma dup (P : Prop) : P -> dup_spec P. -Proof. by move=> ?; split. Qed. - (* -------------------------------------------------------------------- *) Definition ZleP : ∀ x y, reflect (x <= y) (x <=? y) := Z.leb_spec0. Definition ZltP : ∀ x y, reflect (x < y) (x i /=. + apply: eq_map => i /=; rewrite ?add0n. Lia.lia. Qed. @@ -1668,7 +1661,7 @@ Proof. rewrite !ziotaE. move=> hz;rewrite /ziota Z2Nat.inj_succ //= Z.add_0_r; f_equal. rewrite -addn1 addnC iotaDl -map_comp. - by apply eq_map => i /=; rewrite Zpos_P_of_succ_nat; Lia.lia. + by apply eq_map => i /=; rewrite Zpos_P_of_succ_nat ?add0n; Lia.lia. Qed. Lemma ziotaS_cat p z: 0 <= z -> ziota p (Z.succ z) = ziota p z ++ [:: p + z]. @@ -1795,16 +1788,6 @@ Proof. by rewrite Nat2Z.id nth_index. Qed. -(* ------------------------------------------------------------------------- *) -Lemma sumbool_of_boolET (b: bool) (h: b) : - Sumbool.sumbool_of_bool b = left h. -Proof. by move: h; rewrite /is_true => ?; subst. Qed. - -Lemma sumbool_of_boolEF (b: bool) (h: b = false) : - Sumbool.sumbool_of_bool b = right h. -Proof. by move: h; rewrite /is_true => ?; subst. Qed. - - (* ------------------------------------------------------------------------- *) Definition lprod ts tr := diff --git a/proofs/lang/values.v b/proofs/lang/values.v index 03700debb..7f4f37300 100644 --- a/proofs/lang/values.v +++ b/proofs/lang/values.v @@ -350,8 +350,8 @@ Section VALUE. Lemma to_arrI n v t : to_arr n v = ok t -> v = Varr t. Proof. - case: v => //= n' t' /dup [] /WArray.cast_len ?; subst n'. - by rewrite WArray.castK => -[<-]. + case: v => //= n' t' /[dup] /WArray.cast_len ?; subst n'. + by rewrite WArray.castK => -[<-]. Qed. Lemma to_arr_undef p v : to_arr p v <> undef_error. @@ -627,7 +627,7 @@ Section VALUE. Proof. case: t1 v1 => /=; case: t2 v2 => //=; try (exists erefl; done); rewrite /val_uincl /=. - + by move=> > /dup [] /WArray.uincl_len ? ?; subst; exists erefl. + + by move=> > /[dup] /WArray.uincl_len ? ?; subst; exists erefl. + by eexists; exists erefl. by eexists; exists erefl. Qed. @@ -646,7 +646,7 @@ Section VALUE. Proof. case: t1 v1 => /=; case: t2 v2 => //=; try (exists erefl; done); rewrite /val_uincl /=. - + by move=> > /dup [] /WArray.uincl_len ? ?; subst; exists erefl. + + by move=> > /[dup] /WArray.uincl_len ? ?; subst; exists erefl. + by eexists; exists erefl. by eexists; exists erefl. Qed. diff --git a/proofs/lang/varmap.v b/proofs/lang/varmap.v index d241a758b..a97ac4f99 100644 --- a/proofs/lang/varmap.v +++ b/proofs/lang/varmap.v @@ -1095,7 +1095,7 @@ Section REL_EQUIV. vm1 =[s] vm1' -> set_var wdb vm1' x v = ok vm1'.[x <- v] /\ vm2 =[Sv.add x s] vm1'.[x <- v]. Proof. - move=> /dup [] /(set_var_eq_on1 vm1') [hw2 h] hw1 hs. + move=> /[dup] /(set_var_eq_on1 vm1') [hw2 h] hw1 hs. split => //; rewrite SvP.MP.add_union_singleton. apply: (eq_on_union hs h); apply: set_var_eq_ex; eauto. Qed. diff --git a/proofs/lang/warray_.v b/proofs/lang/warray_.v index 9b1b32b87..0d5f8d2a3 100644 --- a/proofs/lang/warray_.v +++ b/proofs/lang/warray_.v @@ -129,7 +129,7 @@ Module WArray. set8 m p w = ok m' -> get8 m' p' = if p == p' then ok w else get8 m p'. Proof. - rewrite /get8 /set8 => /dup[] /valid8_set ->; t_xrbindP => hb <-. + rewrite /get8 /set8 => /[dup] /valid8_set ->; t_xrbindP => hb <-. case heq: in_bound => //=; last by case: eqP => // h;move: heq; rewrite -h hb. by rewrite /is_init /= Mz.setP; case: eqP. Qed. @@ -260,7 +260,7 @@ Module WArray. Lemma cast_empty_ok len1 len2 t: WArray.cast len1 (empty len2) = ok t -> t = empty len1. - Proof. by move=> /dup[]/cast_len/eqP; rewrite cast_empty => -> [<-]. Qed. + Proof. by move=> /[dup]/cast_len/eqP; rewrite cast_empty => -> [<-]. Qed. Lemma cast_get8 len1 len2 (m : array len2) m' : cast len1 m = ok m' -> @@ -285,7 +285,7 @@ Module WArray. cast len a1 = ok a1' -> exists2 a2', cast len a2 = ok a2' & uincl a1' a2'. Proof. - move=> /dup [] /uincl_len ? hu /dup [] /cast_len ?; subst len1 len2. + move=> /[dup] /uincl_len ? hu /[dup] /cast_len ?; subst len1 len2. rewrite castK => -[<-]; exists a2 => //; apply castK. Qed. diff --git a/scripts/coq-elpi.nix b/scripts/coq-elpi.nix new file mode 100644 index 000000000..4e5b03334 --- /dev/null +++ b/scripts/coq-elpi.nix @@ -0,0 +1,20 @@ +{ lib, mkCoqDerivation, coq, version }: + +let elpi = + coq.ocamlPackages.elpi.override { + version = "v1.18.2"; + } +; in + +mkCoqDerivation { + pname = "elpi"; + repo = "coq-elpi"; + owner = "LPCIC"; + inherit version; + + mlPlugin = true; + useDune = true; + propagatedBuildInputs = [ elpi ] + ++ (with coq.ocamlPackages; [ findlib ppx_optcomp ]); + +} diff --git a/scripts/nixpkgs.nix b/scripts/nixpkgs.nix index c11f4810d..cef36ab29 100644 --- a/scripts/nixpkgs.nix +++ b/scripts/nixpkgs.nix @@ -1,4 +1,4 @@ import (fetchTarball { - url = "https://github.com/NixOS/nixpkgs/archive/805a384895c696f802a9bf5bf4720f37385df547.tar.gz"; - sha256 = "sha256:1q7y5ygr805l5axcjhn0rn3wj8zrwbrr0c6a8xd981zh8iccmx0p"; + url = "https://github.com/NixOS/nixpkgs/archive/110fd8d57734d192f5ea43eb5bc0b41d2004a143.tar.gz"; + sha256 = "sha256:1m3xsj0k6bw4a6008zf22i07jb2i1f6cfxydsphkifh2ki79h97x"; }) diff --git a/scripts/test-libjade.sh b/scripts/test-libjade.sh index b0cfe340d..18297b4b0 100755 --- a/scripts/test-libjade.sh +++ b/scripts/test-libjade.sh @@ -5,11 +5,11 @@ NAME=libjade BRANCH=main FILE="$NAME.tar.gz" -ROOT="$NAME-$BRANCH" +ROOT=$(echo -n $NAME-$BRANCH | tr / -) [ 1 -le $# ] || exit 127 -DIR="$ROOT/$1" +DIR="libjade/$1" MAKELINE="-C $DIR CI=1 JASMIN=$PWD/compiler/jasminc" @@ -18,7 +18,11 @@ export EXCLUDE="" echo "Info: $MAKELINE (EXCLUDE=$EXCLUDE)" -curl -v -o $FILE https://codeload.github.com/$REPO/$NAME/tar.gz/refs/heads/$BRANCH +curl -v -o $FILE https://codeload.github.com/$REPO/$NAME/tar.gz/$BRANCH tar xvf $FILE +rm -rf libjade/ +mv $ROOT libjade + +mv libjade/oldsrc-should-delete/ libjade/src make $MAKELINE