From 278beeaa57f816928e081882f71e5623f9254c1d Mon Sep 17 00:00:00 2001 From: J08nY Date: Wed, 8 May 2024 12:31:06 +0200 Subject: [PATCH 01/51] Add DOIT data to the architecture descriptions --- AUTHORS | 1 + CHANGELOG.md | 6 ++ compiler/src/arch_full.ml | 10 ++- compiler/src/arch_full.mli | 4 +- compiler/src/arm_arch_full.ml | 67 ++++++++++++++- compiler/src/x86_arch_full.ml | 157 +++++++++++++++++++++++++++++++++- 6 files changed, 236 insertions(+), 9 deletions(-) diff --git a/AUTHORS b/AUTHORS index e36ba1ed1..fdd06bd0b 100644 --- a/AUTHORS +++ b/AUTHORS @@ -14,6 +14,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..e64134311 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -28,6 +28,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 diff --git a/compiler/src/arch_full.ml b/compiler/src/arch_full.ml index 464643bde..3d8785aad 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 9dcbce8a8..83d973a9b 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/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 From a63434e0b56019c96e79689e3497e3faf5210730 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 28 May 2024 11:19:02 +0200 Subject: [PATCH 02/51] jazzct: add --doit argument MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Ján Jančár --- compiler/CCT/fail/doit/x86_64/rol.jazz | 6 ++++++ compiler/CCT/fail/doit/x86_64/xchg.jazz | 7 +++++++ compiler/CCT/success/doit/by_stack.jazz | 6 ++++++ compiler/Makefile | 2 +- compiler/config/tests.config | 7 +++++++ compiler/entry/jasmin_ct.ml | 25 ++++++++++++++++++------- 6 files changed, 45 insertions(+), 8 deletions(-) create mode 100644 compiler/CCT/fail/doit/x86_64/rol.jazz create mode 100644 compiler/CCT/fail/doit/x86_64/xchg.jazz create mode 100644 compiler/CCT/success/doit/by_stack.jazz 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 60c29da99..0640ff62e 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 \ 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 From c6e405e76273b4fe35e1b5089f22868ddebdcb6b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jean-Christophe=20L=C3=A9chenet?= Date: Tue, 25 Jun 2024 21:37:54 +0200 Subject: [PATCH 03/51] stack alloc: truncation of stack variables (#848) --- CHANGELOG.md | 4 + compiler/tests/success/x86-64/bug_681.jazz | 8 + proofs/compiler/allocation_proof.v | 3 +- proofs/compiler/constant_prop_proof.v | 4 +- proofs/compiler/propagate_inline_proof.v | 5 +- proofs/compiler/stack_alloc.v | 51 ++--- proofs/compiler/stack_alloc_proof.v | 223 ++++++++++++++++----- proofs/compiler/stack_alloc_proof_2.v | 70 ++----- proofs/lang/psem.v | 94 +++++++-- proofs/lang/values.v | 70 +++++++ 10 files changed, 383 insertions(+), 149 deletions(-) create mode 100644 compiler/tests/success/x86-64/bug_681.jazz diff --git a/CHANGELOG.md b/CHANGELOG.md index e64134311..db1d7c3c6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -116,6 +116,10 @@ ## Bug fixes +- 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 intrincics with the `S` suffix if the instruction does not set flags ([PR #809](https://github.com/jasmin-lang/jasmin/pull/809); 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/proofs/compiler/allocation_proof.v b/proofs/compiler/allocation_proof.v index 9c21e529a..3d5029a0e 100644 --- a/proofs/compiler/allocation_proof.v +++ b/proofs/compiler/allocation_proof.v @@ -166,7 +166,8 @@ Section CHECK_EP. split => //= scs m v1; t_xrbindP => vs1 ok_vs1 ok_v1. 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/constant_prop_proof.v b/proofs/compiler/constant_prop_proof.v index 3d91f3b80..0235d69f9 100644 --- a/proofs/compiler/constant_prop_proof.v +++ b/proofs/compiler/constant_prop_proof.v @@ -590,8 +590,8 @@ Section CONST_PROP_EP. rewrite /= hw1 hw2 /=. by apply: vuincl_sem_sop2 h. - move => op es ih v. - t_xrbindP => vs /ih{ih} [] vs' ih /vuincl_sem_opN h/h{h} [] v' ok_v' h. - by rewrite s_opNP /= -/(sem_pexprs _ _ _) ih /= ok_v'; eauto. + 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. diff --git a/proofs/compiler/propagate_inline_proof.v b/proofs/compiler/propagate_inline_proof.v index cd79de5df..170a5e7a5 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/stack_alloc.v b/proofs/compiler/stack_alloc.v index 6f89f73d6..29696d6a6 100644 --- a/proofs/compiler/stack_alloc.v +++ b/proofs/compiler/stack_alloc.v @@ -586,7 +586,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 => @@ -595,16 +597,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) @@ -621,30 +625,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) | 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) end. - Definition alloc_es := mapM alloc_e. + Definition alloc_es es ty := mapM2 bad_arg_number alloc_e es ty. End ALLOC_E. @@ -683,7 +688,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 => @@ -700,7 +705,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. @@ -893,7 +898,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) @@ -1213,7 +1218,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)]) @@ -1226,7 +1231,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)]) @@ -1234,7 +1239,7 @@ Fixpoint alloc_i sao (rmap:region_map) (i: instr) : cexec (region_map * cmd) := alloc_syscall ii rmap rs o es | 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 @@ -1244,7 +1249,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..649da0de0 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. @@ -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. @@ -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'. @@ -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. diff --git a/proofs/compiler/stack_alloc_proof_2.v b/proofs/compiler/stack_alloc_proof_2.v index 27cabcf3a..8eb23bfd6 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. @@ -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. @@ -2031,7 +2034,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. @@ -2041,7 +2045,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. @@ -2066,7 +2071,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. @@ -2085,7 +2091,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. @@ -2272,53 +2279,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 diff --git a/proofs/lang/psem.v b/proofs/lang/psem.v index bee6acb53..b44dff5db 100644 --- a/proofs/lang/psem.v +++ b/proofs/lang/psem.v @@ -1314,6 +1314,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 -> @@ -1328,27 +1348,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, @@ -1397,7 +1465,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 @@ -1453,14 +1521,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 -> diff --git a/proofs/lang/values.v b/proofs/lang/values.v index 821e44280..2feba6a91 100644 --- a/proofs/lang/values.v +++ b/proofs/lang/values.v @@ -399,6 +399,13 @@ Definition to_val t : sem_t t -> value := Lemma to_val_inj t (v1 v2: sem_t t) : to_val v1 = to_val v2 -> v1 = v2. Proof. by case: t v1 v2 => /= > => [[]|[]| /Varr_inj1 |[]]. Qed. +Lemma of_val_to_val t (v : sem_t t) : of_val t (to_val v) = ok v. +Proof. + case: t v => //=. + + by move=> len a; rewrite WArray.castK. + by move=> ws w; rewrite truncate_word_u. +Qed. + Lemma to_valI t (x: sem_t t) v : to_val x = v -> match v with | Vbool b => exists h: t = sbool, eq_rect _ _ x _ h = b @@ -592,6 +599,39 @@ Proof. by move=> _ _; rewrite /truncate_val /= truncate_word_u. Qed. +Lemma subtype_truncate_val_idem ty1 ty2 v v1 v2 : + subtype ty2 ty1 -> + truncate_val ty1 v = ok v1 -> + truncate_val ty2 v1 = ok v2 -> + truncate_val ty2 v = ok v2. +Proof. + move=> /subtypeE hsub /truncate_valE htr. + case: v htr hsub => //. + + by move=> b [-> ->] _. + + by move=> z [-> ->] _. + + by move=> len a [-> ->] _. + move=> ws w [ws1 [w1 [-> /truncate_wordP [hcmp1 ->] ->]]] [ws2 [-> hcmp2]]. + rewrite /truncate_val /= truncate_word_le //= => -[<-]. + rewrite truncate_word_le /=; last by apply (cmp_le_trans hcmp2 hcmp1). + by rewrite zero_extend_idem. +Qed. + +Lemma subtype_truncate_val ty1 ty2 v v1 : + subtype ty2 ty1 -> + truncate_val ty1 v = ok v1 -> + exists v2, truncate_val ty2 v1 = ok v2. +Proof. + move=> /subtypeE hsub /truncate_valI htr. + case: v1 htr hsub => //. + + by move=> b [-> _] ->; eexists; reflexivity. + + by move=> z [-> _] ->; eexists; reflexivity. + + move=> len a [-> _] ->. + by rewrite /truncate_val /= WArray.castK; eexists; reflexivity. + move=> ws1 w1 [_ [_ [-> _ _]]] [ws2 [-> hcmp2]]. + rewrite /truncate_val /= truncate_word_le //. + by eexists; reflexivity. +Qed. + Lemma truncate_val_defined ty v v' : truncate_val ty v = ok v' -> is_defined v'. Proof. by move=> /truncate_valI; case: v'. Qed. @@ -680,6 +720,36 @@ Definition app_sopn_v tin tout (semi: sem_prod tin (exec (sem_tuple tout))) vs : Let t := app_sopn _ semi vs in ok (list_ltuple t). +Lemma app_sopn_truncate_val T l f vargs (t:T) : + app_sopn l f vargs = ok t -> + exists vargs', + mapM2 ErrType truncate_val l vargs = ok vargs' /\ + app_sopn l f vargs' = ok t. +Proof. + elim: l f vargs => /= [|ty l ih] f [|v vargs] //. + + move=> ->. + by eexists; split; first by reflexivity. + t_xrbindP=> w hv /ih [vargs' [htr hvargs']]. + rewrite /truncate_val hv /= htr /=. + eexists; split; first by reflexivity. + by rewrite /= of_val_to_val /=. +Qed. + +Lemma truncate_val_app_sopn T l f vargs vargs' (t : T) : + mapM2 ErrType truncate_val l vargs = ok vargs' -> + app_sopn l f vargs' = ok t -> + app_sopn l f vargs = ok t. +Proof. + move=> htr. + elim: {l vargs vargs' htr} (mapM2_Forall3 htr) f => //=. + move=> ty v v' tys vargs vargs' htr _ ih f. + t_xrbindP=> w' ok_w' ok_t. + move: htr => /[dup] /truncate_val_idem. + rewrite /truncate_val ok_w' /=. + t_xrbindP=> <- _ -> /to_val_inj -> /=. + by apply ih. +Qed. + Lemma vuincl_sopn T ts o vs vs' (v: T) : all is_not_sarr ts -> List.Forall2 value_uincl vs vs' -> app_sopn ts o vs = ok v -> app_sopn ts o vs' = ok v. From cde6bfef4a21df72fcd359f061d7aa24c037a07d Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 25 Jun 2024 22:17:55 +0200 Subject: [PATCH 04/51] Deprecate EasyCrypt extraction for safety --- CHANGELOG.md | 4 ++++ compiler/src/CLI_errors.ml | 4 ++++ compiler/src/glob_options.ml | 2 +- 3 files changed, 9 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index db1d7c3c6..62d417fd4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -172,6 +172,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/src/CLI_errors.ml b/compiler/src/CLI_errors.ml index 66bc3a061..21afcb3c9 100644 --- a/compiler/src/CLI_errors.ml +++ b/compiler/src/CLI_errors.ml @@ -50,6 +50,10 @@ let check_options () = then warning Experimental Location.i_dummy "support for windows calling-convention is experimental"; + if !model = Safety + then warning Deprecated Location.i_dummy + "the [-safety] option has been deprecated since June 2024"; + if !target_arch = ARM_M4 then warning Experimental Location.i_dummy "support of the ARMv7 architecture is experimental"; diff --git a/compiler/src/glob_options.ml b/compiler/src/glob_options.ml index 0236c2aea..deb0a1f11 100644 --- a/compiler/src/glob_options.ml +++ b/compiler/src/glob_options.ml @@ -185,7 +185,7 @@ let options = [ "-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"; "-slice" , Arg.String set_slice , "[f] Keep function [f] and everything it needs"; - "-safety", Arg.Unit set_safety , " Generate model for safety verification"; + "-safety", Arg.Unit set_safety , " Generate model for safety verification (deprecated)"; "-checksafety", Arg.Unit set_checksafety, " Automatically check for safety"; "-safetyparam", Arg.String set_safetyparam, " Parameter for automatic safety verification:\n \ From 06cbecb99219d8b29b70c9364467bc1b655af9cf Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Mon, 24 Jun 2024 16:03:35 +0200 Subject: [PATCH 05/51] SCT-checker: improve handling of stack variables Stack-variables are now considered transient before initialization. Indeed and in particular after a few compilation passes, stack variables may contain secrets before their initialization. When (mis)speculative execution can bypass initialization, said secret can be exposed. See new test file for a precise example illustrating the issue. --- compiler/src/sct_checker_forward.ml | 4 +- compiler/tests/sct-checker/accept.expected | 12 ++++-- .../fail/speculative-stack-leak.jazz | 38 +++++++++++++++++++ compiler/tests/sct-checker/reject.expected | 3 ++ .../tests/sct-checker/success/arrays.jazz | 17 ++++++++- 5 files changed, 67 insertions(+), 7 deletions(-) create mode 100644 compiler/tests/sct-checker/fail/speculative-stack-leak.jazz diff --git a/compiler/src/sct_checker_forward.ml b/compiler/src/sct_checker_forward.ml index f4fbd87a8..ecf45a297 100644 --- a/compiler/src/sct_checker_forward.ml +++ b/compiler/src/sct_checker_forward.ml @@ -1333,8 +1333,8 @@ let init_constraint fenv f = | None -> begin match x.v_kind with | Const -> Env.dpublic env - | Stack Direct -> Direct (Env.fresh2 env) - | Stack (Pointer _) -> Indirect(Env.fresh2 env, Env.fresh2 env) + | Stack Direct -> Direct (Env.fresh env, Env.secret env) + | Stack (Pointer _) -> Indirect((Env.fresh env, Env.secret env), Env.fresh2 env) | Reg (_, Direct) -> Direct (Env.fresh2 env) | Reg (_, Pointer _) -> Indirect(Env.fresh2 env, Env.fresh2 env) | Inline -> Env.dpublic env diff --git a/compiler/tests/sct-checker/accept.expected b/compiler/tests/sct-checker/accept.expected index 995db845e..afe4cde41 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: 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..a81dee86a 100644 --- a/compiler/tests/sct-checker/reject.expected +++ b/compiler/tests/sct-checker/reject.expected @@ -51,6 +51,9 @@ 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 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 From 135dc81c5a56ac923182999e31bc0fe0258a558a Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Fri, 21 Jun 2024 13:36:50 +0200 Subject: [PATCH 06/51] Regalloc: improve liveness analysis MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit During register-allocation (i.e., when performing “weak” liveness analysis), values that are used in the left-hand side of an assignment (assgn, opn, call, syscall, etc.) are considered live after the instruction. Fixes #634 --- compiler/src/liveness.ml | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/compiler/src/liveness.ml b/compiler/src/liveness.ml index b3dc6f3f1..0a7877a52 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); } @@ -30,7 +33,7 @@ and live_d weak d (s_o: Sv.t) = 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) @@ -38,7 +41,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) @@ -63,11 +66,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 From bfaf5b9fdb2ccf5177c979394b9cd5a6783d9831 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Cassiers?= Date: Thu, 6 Jun 2024 17:22:45 +0200 Subject: [PATCH 07/51] Test runner: fix of-by-one error for the counter --- compiler/scripts/runtest | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/scripts/runtest b/compiler/scripts/runtest index 1df1a15b8..372012c12 100755 --- a/compiler/scripts/runtest +++ b/compiler/scripts/runtest @@ -359,7 +359,7 @@ 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}" ) errors = [x for x in result if not x.success] From f901628245d15a2ff50711d91c638e30394a755a Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Cassiers?= Date: Thu, 6 Jun 2024 21:10:07 +0200 Subject: [PATCH 08/51] Test runner: remove usage of deprecated function --- compiler/scripts/runtest | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/scripts/runtest b/compiler/scripts/runtest index 372012c12..477b9e18f 100755 --- a/compiler/scripts/runtest +++ b/compiler/scripts/runtest @@ -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.UTC).isoformat() for gname, group in grouped.items(): ko = [x for x in group if not x.success] node = cl.OrderedDict() From c5a956655cc577dddc80eb180b546530c6d9ea1a Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Thu, 27 Jun 2024 23:27:26 +0200 Subject: [PATCH 09/51] SCT-checker: more precise handling of stack variables --- compiler/src/sct_checker_forward.ml | 16 ++++++++++------ compiler/tests/sct-checker/accept.expected | 13 +++++++++++++ compiler/tests/sct-checker/success/bug_852.jazz | 12 ++++++++++++ 3 files changed, 35 insertions(+), 6 deletions(-) create mode 100644 compiler/tests/sct-checker/success/bug_852.jazz diff --git a/compiler/src/sct_checker_forward.ml b/compiler/src/sct_checker_forward.ml index ecf45a297..73caa3244 100644 --- a/compiler/src/sct_checker_forward.ml +++ b/compiler/src/sct_checker_forward.ml @@ -1309,7 +1309,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 @@ -1333,8 +1335,10 @@ let init_constraint fenv f = | None -> begin match x.v_kind with | Const -> Env.dpublic env - | Stack Direct -> Direct (Env.fresh env, Env.secret env) - | Stack (Pointer _) -> Indirect((Env.fresh env, Env.secret env), Env.fresh2 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) | Inline -> Env.dpublic env @@ -1359,7 +1363,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 @@ -1389,7 +1393,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 @@ -1434,7 +1438,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/tests/sct-checker/accept.expected b/compiler/tests/sct-checker/accept.expected index afe4cde41..4630223fa 100644 --- a/compiler/tests/sct-checker/accept.expected +++ b/compiler/tests/sct-checker/accept.expected @@ -135,6 +135,19 @@ output corruption: #transient constraints: +File bug_852.jazz: +nomodmsf reset : #public -> + +output corruption: #public + constraints: + + +modmsf main : #transient -> + +output corruption: #public + constraints: + + File corruption.jazz: nomodmsf corrupts_memory : #public * #secret * #[ptr = public, val = secret] * 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); +} From 1121ae6b17baab54ce07213d6b6e4a78368c8654 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Cassiers?= Date: Tue, 9 Jul 2024 11:45:16 +0200 Subject: [PATCH 10/51] runtest: restore compatibility with python < 3.11 --- compiler/scripts/runtest | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/scripts/runtest b/compiler/scripts/runtest index 477b9e18f..58352c8f4 100755 --- a/compiler/scripts/runtest +++ b/compiler/scripts/runtest @@ -264,7 +264,7 @@ def _dump_report(results, out): grouped.setdefault(result.config.group, []).append(result) hostname = socket.gethostname() - timestamp = datetime.datetime.now(datetime.UTC).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() From 500c71c71dc4a12ffc165b85ad162a33d5a788c8 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 9 Jul 2024 07:31:48 +0200 Subject: [PATCH 11/51] CI: update nixpkgs --- scripts/nixpkgs.nix | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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"; }) From a2f2f329a08929d51a0a4d354ce60ce3d52c3ff7 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 9 Jul 2024 06:24:32 +0200 Subject: [PATCH 12/51] CI: fix coq-elpi for job coq-master --- default.nix | 5 ++++- scripts/coq-elpi.nix | 20 ++++++++++++++++++++ 2 files changed, 24 insertions(+), 1 deletion(-) create mode 100644 scripts/coq-elpi.nix 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/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 ]); + +} From 1dce721c9538b9b6a0d261b6863611bd4f9f5e0f Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 9 Jul 2024 06:21:08 +0200 Subject: [PATCH 13/51] CI: disable coq-master job on release branches and allow it to fail --- .gitlab-ci.yml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 0d7e415ad..5bd6f41db 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -69,6 +69,9 @@ coq-proof: 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 From 5a95a5fb9dda843ce42d5c6ef201716b4c7048c9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jean-Christophe=20L=C3=A9chenet?= Date: Wed, 10 Jul 2024 09:27:35 +0100 Subject: [PATCH 14/51] Update CHANGELOG after release 2024.07.0 --- CHANGELOG.md | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 62d417fd4..8f53163e4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,8 @@ # [unreleased] +# Jasmin 2024.07.0 — Sophia-Antipolis, 2024-07-09 + ## New features - The stack allocation checker accepts more programs. This checker is run @@ -19,6 +21,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 @@ -57,13 +60,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; @@ -75,6 +78,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`. @@ -120,7 +124,7 @@ ([PR #848](https://github.com/jasmin-lang/jasmin/pull/848); fixes [#681](https://github.com/jasmin-lang/jasmin/issues/681)). -- The compiler rejects ARM intrincics with the `S` suffix if the instruction +- 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)). @@ -153,7 +157,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)). From 513a134a5e78d25f6735fdfe1d91721b8e487f1f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Cassiers?= Date: Thu, 6 Jun 2024 22:18:37 +0200 Subject: [PATCH 15/51] toEC (leakage extraction): fix for loop bound swap Fixes #858 --- CHANGELOG.md | 5 +++++ compiler/src/toEC.ml | 2 ++ 2 files changed, 7 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8f53163e4..103c2f9b8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,11 @@ # [unreleased] +## 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)). # Jasmin 2024.07.0 — Sophia-Antipolis, 2024-07-09 ## New features diff --git a/compiler/src/toEC.ml b/compiler/src/toEC.ml index d6a15ff32..5b0e6ff18 100644 --- a/compiler/src/toEC.ml +++ b/compiler/src/toEC.ml @@ -1327,6 +1327,8 @@ module Leak = struct (pp_cmd pd asmOp env) (c2@c1) pp_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 pp_leaks_for pd env fmt e1 e2; let aux, env1 = if for_safety env then From 54b6100f0a17fdea18e836c411d3a8c852c144f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jean-Christophe=20L=C3=A9chenet?= Date: Wed, 10 Jul 2024 16:42:42 +0100 Subject: [PATCH 16/51] opam: lower bound on angstrom --- compiler/jasmin.opam | 2 +- opam | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/compiler/jasmin.opam b/compiler/jasmin.opam index f546792b8..a9bc36ff7 100644 --- a/compiler/jasmin.opam +++ b/compiler/jasmin.opam @@ -31,7 +31,7 @@ depends: [ "apron" {>= "v0.9.12"} "conf-ppl" "yojson" {>= "1.6.0"} - "angstrom" + "angstrom" {>= "0.14.0"} "ocamlfind" { build } ] conflicts: [ 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~"} From 88a932b2bf478345597f75be31ae25e5acefafae Mon Sep 17 00:00:00 2001 From: Pierre-Yves Strub Date: Tue, 16 Jul 2024 11:05:32 +0200 Subject: [PATCH 17/51] ECLIB: remove deprecated "nosmt" tag --- eclib/JArray.ec | 8 +++--- eclib/JUtils.ec | 8 +++--- eclib/JWord.ec | 70 ++++++++++++++++++++++++------------------------- 3 files changed, 43 insertions(+), 43 deletions(-) diff --git a/eclib/JArray.ec b/eclib/JArray.ec index f8045b5bc..317f16ae3 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. diff --git a/eclib/JUtils.ec b/eclib/JUtils.ec index 081cf77be..dd89ed097 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. 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. From 6575b720b9c555f657c212e0bac19e8a3febe02f Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 23 Jul 2024 10:25:29 +0200 Subject: [PATCH 18/51] jasminc: remove deprecated -latex option --- CHANGELOG.md | 6 ++++++ compiler/src/CLI_errors.ml | 6 +----- compiler/src/glob_options.ml | 2 -- compiler/src/main_compiler.ml | 12 ++---------- 4 files changed, 9 insertions(+), 17 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 103c2f9b8..aa848d247 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,12 @@ - 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)). + +## Other changes + +- The deprecated legacy interface to the LATEX pretty-printer has been removed + ([PR #869](https://github.com/jasmin-lang/jasmin/pull/869)). + # Jasmin 2024.07.0 — Sophia-Antipolis, 2024-07-09 ## New features diff --git a/compiler/src/CLI_errors.ml b/compiler/src/CLI_errors.ml index 21afcb3c9..c712e81c9 100644 --- a/compiler/src/CLI_errors.ml +++ b/compiler/src/CLI_errors.ml @@ -58,8 +58,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/glob_options.ml b/compiler/src/glob_options.ml index deb0a1f11..e14e22168 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 @@ -175,7 +174,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)"; diff --git a/compiler/src/main_compiler.ml b/compiler/src/main_compiler.ml index 049992a50..3f23cb601 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 = From 31e8ebf5207e685a0e494f2c32acb290198f2bd8 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Wed, 31 Jul 2024 09:29:00 +0200 Subject: [PATCH 19/51] Compile with Coq master --- proofs/lang/utils.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/proofs/lang/utils.v b/proofs/lang/utils.v index 99ac993d6..359ba1dc5 100644 --- a/proofs/lang/utils.v +++ b/proofs/lang/utils.v @@ -1641,7 +1641,7 @@ Proof. rewrite map_cons -/(iota _ _) Z.add_0_r; congr (_ :: _). rewrite (iotaDl 1) -map_comp. rewrite ziota_recP. - apply: eq_map => i /=. + apply: eq_map => i /=; rewrite ?add0n. Lia.lia. Qed. @@ -1660,7 +1660,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]. From 38a61cb2f29ae325715c34bc13d6c086642fde1c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jean-Christophe=20L=C3=A9chenet?= Date: Thu, 1 Aug 2024 10:49:53 +0200 Subject: [PATCH 20/51] Remove custom tactic dup Use the one from ssreflect instead --- proofs/arch/asm_gen_proof.v | 6 ++--- proofs/arch/label.v | 4 ++-- proofs/compiler/array_expansion_proof.v | 8 +++---- proofs/compiler/array_init_proof.v | 16 ++++++------- proofs/compiler/byteset.v | 24 ++++++++++---------- proofs/compiler/compiler_proof.v | 4 ++-- proofs/compiler/constant_prop_proof.v | 16 ++++++------- proofs/compiler/linearization_proof.v | 10 ++++----- proofs/compiler/stack_alloc_proof.v | 30 ++++++++++++------------- proofs/compiler/stack_alloc_proof_2.v | 8 +++---- proofs/compiler/x86_lowering_proof.v | 2 +- proofs/compiler/x86_params_proof.v | 2 +- proofs/lang/memory_example.v | 6 ++--- proofs/lang/memory_model.v | 4 ++-- proofs/lang/psem.v | 6 ++--- proofs/lang/psem_facts.v | 8 +++---- proofs/lang/psem_of_sem_proof.v | 2 +- proofs/lang/utils.v | 7 ------ proofs/lang/values.v | 6 ++--- proofs/lang/varmap.v | 2 +- proofs/lang/warray_.v | 6 ++--- 21 files changed, 85 insertions(+), 92 deletions(-) diff --git a/proofs/arch/asm_gen_proof.v b/proofs/arch/asm_gen_proof.v index f06bc10b6..68cae4fc9 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/array_expansion_proof.v b/proofs/compiler/array_expansion_proof.v index e8bc37fd9..3e49d9830 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. @@ -771,7 +771,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 1018d5236..8399d626d 100644 --- a/proofs/compiler/array_init_proof.v +++ b/proofs/compiler/array_init_proof.v @@ -403,28 +403,28 @@ 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. 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. @@ -434,7 +434,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. @@ -454,7 +454,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..3e233607f 100644 --- a/proofs/compiler/byteset.v +++ b/proofs/compiler/byteset.v @@ -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_proof.v b/proofs/compiler/compiler_proof.v index 9b893e92c..2b8183ac0 100644 --- a/proofs/compiler/compiler_proof.v +++ b/proofs/compiler/compiler_proof.v @@ -483,7 +483,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 _ _. @@ -1231,7 +1231,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 0235d69f9..519faf1f8 100644 --- a/proofs/compiler/constant_prop_proof.v +++ b/proofs/compiler/constant_prop_proof.v @@ -130,7 +130,7 @@ 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 /=. + 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. @@ -458,7 +458,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'. @@ -594,8 +594,8 @@ Section CONST_PROP_EP. 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 <-. + 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). @@ -652,7 +652,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. @@ -1121,7 +1121,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. @@ -1136,7 +1136,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. @@ -1218,7 +1218,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 a8b5e2fac..fd03d3a47 100644 --- a/proofs/compiler/linearization_proof.v +++ b/proofs/compiler/linearization_proof.v @@ -326,7 +326,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. @@ -1459,7 +1459,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. @@ -2657,7 +2657,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 *) @@ -3707,7 +3707,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. @@ -4252,7 +4252,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/stack_alloc_proof.v b/proofs/compiler/stack_alloc_proof.v index 649da0de0..5a30f6147 100644 --- a/proofs/compiler/stack_alloc_proof.v +++ b/proofs/compiler/stack_alloc_proof.v @@ -916,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. @@ -1438,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]. @@ -2123,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. @@ -2174,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. @@ -2490,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 => [_|]. @@ -2610,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 _. @@ -2767,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: @@ -2783,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 _. @@ -2891,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) [+ _]. @@ -2914,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) [+ _]. @@ -3305,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. @@ -3577,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 @@ -4058,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. @@ -4337,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 @@ -4610,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 8eb23bfd6..9a6afbe0d 100644 --- a/proofs/compiler/stack_alloc_proof_2.v +++ b/proofs/compiler/stack_alloc_proof_2.v @@ -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. @@ -2633,7 +2633,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/x86_lowering_proof.v b/proofs/compiler/x86_lowering_proof.v index 4d843cd63..588a6cb1a 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. diff --git a/proofs/compiler/x86_params_proof.v b/proofs/compiler/x86_params_proof.v index aa986053b..acaf9a6e5 100644 --- a/proofs/compiler/x86_params_proof.v +++ b/proofs/compiler/x86_params_proof.v @@ -722,7 +722,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}. 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..4915c2f1b 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'. @@ -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 b44dff5db..c542d9b00 100644 --- a/proofs/lang/psem.v +++ b/proofs/lang/psem.v @@ -452,7 +452,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. @@ -1233,7 +1233,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. @@ -1551,7 +1551,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 265d28526..f0a60e088 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. @@ -238,7 +238,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 623f8df12..0a296e53b 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 359ba1dc5..4ec824b31 100644 --- a/proofs/lang/utils.v +++ b/proofs/lang/utils.v @@ -1530,13 +1530,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 v = Varr t. Proof. - case: v => //= n' t' /dup [] /WArray.cast_len ?; subst n'. + case: v => //= n' t' /[dup] /WArray.cast_len ?; subst n'. by rewrite WArray.castK => -[<-]. Qed. @@ -457,7 +457,7 @@ Lemma val_uinclEl t1 t2 v1 v2 : 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. Qed. @@ -473,7 +473,7 @@ Lemma val_uinclE t1 t2 v1 v2 : 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. Qed. diff --git a/proofs/lang/varmap.v b/proofs/lang/varmap.v index a17741b9a..2c3d4eb3a 100644 --- a/proofs/lang/varmap.v +++ b/proofs/lang/varmap.v @@ -1061,7 +1061,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. From 2ccee70da8e1306906b781bfcaea890a83fa4ef9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Jean-Christophe=20L=C3=A9chenet?= Date: Thu, 1 Aug 2024 11:00:38 +0200 Subject: [PATCH 21/51] params: use a specific instance of DirectCall The interface in arch_params_proof already uses direct_c everywhere, so it is useless to be more generic when instantiating this interface for each architecture. --- proofs/compiler/arm_params_proof.v | 14 +++++++------- proofs/compiler/x86_params_proof.v | 9 +++++---- 2 files changed, 12 insertions(+), 11 deletions(-) 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/x86_params_proof.v b/proofs/compiler/x86_params_proof.v index acaf9a6e5..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. @@ -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; From 9f85d3d2f96366e00028074914862d66bed32c7f Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Thu, 1 Aug 2024 11:16:15 +0200 Subject: [PATCH 22/51] Remove dead lemmas about sumbool_of_bool --- proofs/lang/utils.v | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/proofs/lang/utils.v b/proofs/lang/utils.v index 4ec824b31..a1895467d 100644 --- a/proofs/lang/utils.v +++ b/proofs/lang/utils.v @@ -1780,16 +1780,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 := From 35760608462b78578ce7c7a6264ada1ac5d2ba87 Mon Sep 17 00:00:00 2001 From: Lionel Blatter Date: Mon, 5 Aug 2024 22:14:34 +0200 Subject: [PATCH 23/51] disable CI --- .gitlab-ci.yml | 281 ------------------------------------------------- 1 file changed, 281 deletions(-) delete mode 100644 .gitlab-ci.yml diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml deleted file mode 100644 index 5bd6f41db..000000000 --- a/.gitlab-ci.yml +++ /dev/null @@ -1,281 +0,0 @@ -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-main/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-main/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 From 11312b1dc1300c7eec73ceb5301c35b6f1117ebf Mon Sep 17 00:00:00 2001 From: Lionel Blatter Date: Mon, 5 Aug 2024 23:55:15 +0200 Subject: [PATCH 24/51] remove Cl related components --- compiler/.gitignore | 1 - compiler/Makefile | 4 +- compiler/default.nix | 2 +- compiler/dune | 8 - compiler/entry/jazz2cl.ml | 212 --- compiler/jasmin.opam | 1 - compiler/src/array_expand.ml | 8 +- compiler/src/array_expand.mli | 2 +- compiler/src/compile.ml | 170 +-- compiler/src/compile.mli | 29 - compiler/src/toCL.ml | 2123 ------------------------------- compiler/src/toCL.mli | 54 - proofs/_CoqProject | 1 - proofs/compiler/array_copy_cl.v | 154 --- proofs/compiler/compiler.v | 61 - 15 files changed, 56 insertions(+), 2774 deletions(-) delete mode 100644 compiler/entry/jazz2cl.ml delete mode 100644 compiler/src/toCL.ml delete mode 100644 compiler/src/toCL.mli delete mode 100644 proofs/compiler/array_copy_cl.v 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/Makefile b/compiler/Makefile index d9a3dedad..974279491 100644 --- a/compiler/Makefile +++ b/compiler/Makefile @@ -41,7 +41,7 @@ all: build build: native define do-build - $(RM) jasminc jasmin2tex jazz2cl jasmin-ct + $(RM) jasminc jasmin2tex jasmin-ct dune build @check @install for p in _build/install/default/bin/*; do ln -sf $$p $$(basename $$p); done endef @@ -72,13 +72,11 @@ install: $(INSTALL) -m 0755 -d $(DESTDIR)$(BINDIR) $(INSTALL) -m 0755 -T jasminc $(DESTDIR)$(BINDIR)/jasminc $(INSTALL) -m 0755 -T jasmin2tex $(DESTDIR)$(BINDIR)/jasmin2tex - $(INSTALL) -m 0755 -T jazz2cl $(DESTDIR)$(BINDIR)/jazz2cl $(INSTALL) -m 0755 -T jasmin-ct $(DESTDIR)$(BINDIR)/jasmin-ct uninstall: $(RM) $(DESTDIR)$(BINDIR)/jasminc $(RM) $(DESTDIR)$(BINDIR)/jasmin2tex - $(RM) $(DESTDIR)$(BINDIR)/jazz2cl $(RM) $(DESTDIR)$(BINDIR)/jasmin-ct # -------------------------------------------------------------------- diff --git a/compiler/default.nix b/compiler/default.nix index 260ca7081..c5bd44854 100644 --- a/compiler/default.nix +++ b/compiler/default.nix @@ -9,7 +9,7 @@ stdenv.mkDerivation { installPhase = '' mkdir -p $out/bin - for p in jasminc jasmin2tex jazz2cl jasmin-ct + for p in jasminc jasmin2tex jasmin-ct do cp -L _build/install/default/bin/$p $out/bin/$p done diff --git a/compiler/dune b/compiler/dune index 1d507f3db..7370ee050 100644 --- a/compiler/dune +++ b/compiler/dune @@ -23,14 +23,6 @@ (modes byte exe) (libraries commonCLI)) -(executable - (public_name jazz2cl) - (name jazz2cl) - (modules jazz2cl) - (flags -rectypes) - (modes byte exe) - (libraries commonCLI)) - (executable (public_name jasmin-ct) (name jasmin_ct) diff --git a/compiler/entry/jazz2cl.ml b/compiler/entry/jazz2cl.ml deleted file mode 100644 index 74c1b64a5..000000000 --- a/compiler/entry/jazz2cl.ml +++ /dev/null @@ -1,212 +0,0 @@ -module J = Jasmin -open Jasmin -open Utils -open Prog - -type arch = Amd64 | CortexM - - -let add_inline f = - { f with f_cc = Internal} - -module type Arch_ToCL = sig - module C : Arch_full.Core_arch - val test : bool -> (module ToCL.BaseOp - with type op = C.asm_op - and type extra_op = C.extra_op) -end - -let parse_and_print print arch call_conv ecoutput joutput output file funname = - let _ = if print then Glob_options.set_all_print () in - - let (module ACL : Arch_ToCL) = - match arch with - | Amd64 -> - (module struct - module C = (val CoreArchFactory.core_arch_x86 ~use_lea:false ~use_set0:false call_conv) - let test = ToCL.x86BaseOpsign - end) - | CortexM -> - (module struct - module C = CoreArchFactory.Core_arch_ARM - let test = ToCL.armeBaseOpsign - end) - in - let module A = Arch_full.Arch_from_Core_arch (ACL.C) in - - try - let _, pprog, _ = - (* FIXME: This code is a cut and paste of main_compiler *) - try Compile.parse_file A.arch_info file with - | Annot.AnnotationError (loc, code) -> hierror ~loc:(Lone loc) ~kind:"annotation error" "%t" code - | Pretyping.TyError (loc, code) -> hierror ~loc:(Lone loc) ~kind:"typing error" "%a" Pretyping.pp_tyerror code - | Syntax.ParseError (loc, msg) -> - let msg = - match msg with - | None -> "unexpected token" (* default message *) - | Some msg -> msg - in - hierror ~loc:(Lone loc) ~kind:"parse error" "%s" msg - in - - let prog = - (* FIXME: same here, maybe the solution will be to add the version that catch the error *) - try Compile.preprocess A.reg_size A.asmOp pprog - with Typing.TyError(loc, code) -> - hierror ~loc:(Lmore loc) ~kind:"typing error" "%s" code - in - - let funname,annot = - try - let fd = List.find (fun fd -> fd.Prog.f_name.fn_name = funname) (snd prog) in - fd.Prog.f_name,fd.Prog.f_annot - with Not_found -> - hierror ~loc:Lnone ~kind:"typing error" "unknow function %s" funname in - - 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 signed = trans annot.f_user_annot in - let module CL = ToCL.Mk(val ACL.test signed) in - - (* First step: annot all call site with inline *) - let prog = (fst prog, List.map add_inline (snd prog)) in - let cprog = Conv.cuprog_of_prog prog in - - let prog = Compile.compile_CL (module A) cprog funname in - let prog = Conv.prog_of_cuprog ((* FIXME *) Obj.magic prog) in - - begin match joutput with - | None -> () - | Some file -> - let out, close = open_out file, close_out in - let fmt = Format.formatter_of_out_channel out in - Format.fprintf fmt "%a@." (Printer.pp_prog ~debug:true A.reg_size A.asmOp) prog; - close out - end; - - begin match ecoutput with - | None -> () - | Some file -> - let out, close = open_out file, close_out in - let fmt = Format.formatter_of_out_channel out in - let fnames = [funname.fn_name] in - BatPervasives.finally - (fun () -> close out) - (fun () -> ToEC.extract A.reg_size A.asmOp fmt Normal prog fnames) - () - end; - - let out, close = - match output with - | None -> (stdout, ignore) - | Some file -> (open_out file, close_out) - in - - let proc = CL.fun_to_proc (snd prog) (List.nth (snd prog) 0) in - let fmt = Format.formatter_of_out_channel out in - ToCL.CL.Proc.pp_proc fmt proc; - close out - with - | Utils.HiError e -> - Format.eprintf "%a@." pp_hierror e; - exit 1 - -open Cmdliner - -(* This should be shared with jazz2tex and jasminc *) - -let file = - let doc = "The Jasmin source file" in - Arg.(required & pos 0 (some non_dir_file) None & info [] ~docv:"JAZZ" ~doc) - -let output = - let doc = - "The file in which the result is written (instead of the standard output)" - in - Arg.(value & opt (some string) None & info [ "o"; "output" ] ~docv:"CL" ~doc) - -let joutput = - let doc = - "Print the program before extraction to cryptoline to the file JAZZFILE" - in - Arg.(value & opt (some string) None & info [ "j"; "joutput" ] ~docv:"JAZZFILE" ~doc) - -let ecoutput = - let doc = - "Extract (to EC) the program before extraction to cryptoline to the file ECFILE" - in - Arg.(value & opt (some string) None & info [ "e"; "ecoutput" ] ~docv:"ECFILE" ~doc) - -(* -let print = - let alts = - List.map - (fun p -> - let (s, _msg) = glob_options.print_string p in - (s, p)) - Compiler.compiler_step_list in - let doc = - Format.asprintf "The step to print (%s)" (Arg.doc_alts_enum alts) - in - let print = Arg.enum alts in - Arg.(value & opt_all arch [] & info [ "p"; "print" ] ~doc) - -*) - -let print = - let doc = "print result after each step" in - Arg.(value & flag & info ["pall"] ~docv:"JAZZ" ~doc) - -let funname = - let doc = - "The function to extract to CryptoLine" - in - Arg.(required & opt (some string) None & info [ "f"; "funname" ] ~docv:"CL" ~doc) - - -let arch = - let alts = [ ("x86-64", Amd64); ("arm-m4", CortexM) ] in - let doc = - Format.asprintf "The target architecture (%s)" (Arg.doc_alts_enum alts) - in - let arch = Arg.enum alts in - Arg.(value & opt arch Amd64 & info [ "arch" ] ~doc) - -let call_conv = - let alts = - [ ("linux", J.Glob_options.Linux); ("windows", J.Glob_options.Windows) ] - in - let doc = Format.asprintf "Undocumented (%s)" (Arg.doc_alts_enum alts) in - let call_conv = Arg.enum alts in - Arg.( - value - & opt call_conv J.Glob_options.Linux - & info [ "call-conv"; "cc" ] ~docv:"OS" ~doc) - - -let () = - let doc = "Pretty-print Jasmin source programs into Cryptoline" in - let man = - [ - `S Manpage.s_environment; - Manpage.s_environment_intro; - `I ("OCAMLRUNPARAM", "This is an OCaml program"); - `I ("JASMINPATH", "To resolve $(i,require) directives"); - ] - in - let info = - Cmd.info "jazz2cl" ~version:J.Glob_options.version_string ~doc ~man - in - Cmd.v info Term.(const parse_and_print $ print $ arch $ call_conv $ ecoutput $ joutput $ output $ file $ funname) - |> Cmd.eval |> exit diff --git a/compiler/jasmin.opam b/compiler/jasmin.opam index 385144222..a9bc36ff7 100644 --- a/compiler/jasmin.opam +++ b/compiler/jasmin.opam @@ -15,7 +15,6 @@ install: [ mkdir -p "%{prefix}%/bin" cp -L "_build/install/default/bin/jasminc" "%{prefix}%/bin/jasminc" cp -L "_build/install/default/bin/jasmin2tex" "%{prefix}%/bin/jasmin2tex" - cp -L "_build/install/default/bin/jazz2cl" "%{prefix}%/bin/jazz2cl" cp -L "_build/install/default/bin/jasmin-ct" "%{prefix}%/bin/jasmin-ct" mkdir -p "%{prefix}%/lib/jasmin/easycrypt" sh -c "cp ../eclib/*.ec \"%{prefix}%/lib/jasmin/easycrypt/\"" diff --git a/compiler/src/array_expand.ml b/compiler/src/array_expand.ml index f30232cf8..2997daf14 100644 --- a/compiler/src/array_expand.ml +++ b/compiler/src/array_expand.ml @@ -1,11 +1,8 @@ (* Replace register array by register *) open Prog -let init_tbl ?(onlyreg=true) fc = +let init_tbl fc = let tbl = Hv.create 107 in - let is_arr = if onlyreg then is_reg_arr else is_arr in - let reg_kind = - if onlyreg then reg_kind else fun _ -> Normal in let init_var (v:var) = let ws, sz = array_kind v.v_ty in let ty = Bty (U ws) in @@ -14,8 +11,7 @@ let init_tbl ?(onlyreg=true) fc = let t = Array.init sz vi in Hv.add tbl v (ws, t) in let fv = vars_fc fc in - - let arrs = Sv.filter is_arr (vars_fc fc) in + let arrs = Sv.filter is_reg_arr (vars_fc fc) in let vars = Sv.diff fv arrs in Sv.iter init_var arrs; vars, tbl diff --git a/compiler/src/array_expand.mli b/compiler/src/array_expand.mli index 741ac6415..52202661c 100644 --- a/compiler/src/array_expand.mli +++ b/compiler/src/array_expand.mli @@ -1,3 +1,3 @@ open Prog -val init_tbl : ?onlyreg:bool -> ('info, 'asm) func -> Sv.t * (Wsize.wsize * var array) Hv.t +val init_tbl : ('info, 'asm) func -> Sv.t * (Wsize.wsize * var array) Hv.t diff --git a/compiler/src/compile.ml b/compiler/src/compile.ml index b0cfd7c52..12f6a0f2c 100644 --- a/compiler/src/compile.ml +++ b/compiler/src/compile.ml @@ -40,20 +40,25 @@ let rec warn_extra_i pd asmOp i = | Cfor _ -> hierror ~loc:(Lmore i.i_loc) ~kind:"compilation error" ~internal:true "for loop remains" - | Ccall _ | Csyscall _ | Cassert _ -> () + | Cassert _ | Ccall _ | Csyscall _ -> () let warn_extra_fd pd asmOp (_, fd) = List.iter (warn_extra_i pd asmOp) fd.f_body (*--------------------------------------------------------------------- *) -module CompilerParams (Arch : Arch_full.Arch) = -struct - - module Regalloc = Regalloc.Regalloc (Arch) - module StackAlloc = StackAlloc.StackAlloc (Arch) - - let fdef_of_cufdef fn cfd = Conv.fdef_of_cufdef (fn, cfd) - let cufdef_of_fdef fd = snd (Conv.cufdef_of_fdef fd) +let compile (type reg regx xreg rflag cond asm_op extra_op) + (module Arch : Arch_full.Arch + with type reg = reg + and type regx = regx + and type xreg = xreg + and type rflag = rflag + and type cond = cond + and type asm_op = asm_op + and type extra_op = extra_op) visit_prog_after_pass prog cprog = + let module Regalloc = Regalloc.Regalloc (Arch) in + let module StackAlloc = StackAlloc.StackAlloc (Arch) in + let fdef_of_cufdef fn cfd = Conv.fdef_of_cufdef (fn, cfd) in + let cufdef_of_fdef fd = snd (Conv.cufdef_of_fdef fd) in let apply msg trans fn cfd = if !debug then Format.eprintf "START %s@." msg; @@ -61,14 +66,16 @@ struct if !debug then Format.eprintf "back to ocaml@."; let fd = trans fd in cufdef_of_fdef fd + in - let translate_var = Conv.var_of_cvar + let translate_var = Conv.var_of_cvar in let memory_analysis up : Compiler.stack_alloc_oracles = StackAlloc.memory_analysis (Printer.pp_err ~debug:!debug) ~debug:!debug up - + in + let global_regalloc fds = if !debug then Format.eprintf "START regalloc@."; let fds = List.map Conv.fdef_of_csfdef fds in @@ -94,15 +101,18 @@ struct let fds = List.map (fun (y, _, x) -> (y, x)) fds in let fds = List.map Conv.csfdef_of_fdef fds in fds + in - let pp_cuprog visit_prog_after_pass s cp = + let pp_cuprog s cp = Conv.prog_of_cuprog cp |> visit_prog_after_pass ~debug:true s + in let pp_csprog fmt cp = let p = Conv.prog_of_csprog cp in Printer.pp_sprog ~debug:true Arch.pointer_data Arch.asmOp fmt p + in - let pp_linear fmt lp = PrintLinear.pp_prog Arch.pointer_data Arch.asmOp fmt lp + let pp_linear fmt lp = PrintLinear.pp_prog Arch.pointer_data Arch.asmOp fmt lp in let rename_fd ii fn cfd = let ii, _ = ii in @@ -111,10 +121,11 @@ struct Subst.extend_iinfo ii fd in apply "rename_fd" doit fn cfd + in - let expand_fd ~onlyreg fn cfd = + let expand_fd fn cfd = let fd = Conv.fdef_of_cufdef (fn, cfd) in - let vars, harrs = Array_expand.init_tbl ~onlyreg fd in + let vars, harrs = Array_expand.init_tbl fd in let cvar = Conv.cvar_of_var in let vars = List.map cvar (Sv.elements vars) in let arrs = ref [] in @@ -166,43 +177,48 @@ struct let f_outannot = List.flatten (List.map2 do_outannot fd.f_ret fd.f_outannot) in let finfo = fd.f_loc, fd.f_annot, f_cc, f_outannot in { Array_expansion.vars; arrs = !arrs; finfo } + in let refresh_instr_info fn f = (fn, f) |> Conv.fdef_of_cufdef |> refresh_i_loc_f |> Conv.cufdef_of_fdef |> snd + in let warning ii msg = (if not !Glob_options.lea then let loc, _ = ii in warning UseLea loc "%a" Printer.pp_warning_msg msg); ii + in let fresh_id _gd x = let x = Conv.var_of_cvar x in Prog.V.clone x + in - let split_live_ranges_fd fd = Regalloc.split_live_ranges fd - - let renaming_fd fd = Regalloc.renaming fd - - let remove_phi_nodes_fd fd = Regalloc.remove_phi_nodes fd + let split_live_ranges_fd fd = Regalloc.split_live_ranges fd in + let renaming_fd fd = Regalloc.renaming fd in + let remove_phi_nodes_fd fd = Regalloc.remove_phi_nodes fd in let removereturn sp = let fds, _data = Conv.prog_of_csprog sp in let tokeep = RemoveUnusedResults.analyse fds in tokeep + in let warn_extra s p = if s = Compiler.DeadCode_RegAllocation then let fds, _ = Conv.prog_of_csprog p in List.iter (warn_extra_fd Arch.pointer_data Arch.asmOp) fds + in let slh_info up = let p = Conv.prog_of_cuprog up in let ttbl = Sct_checker_forward.compile_infer_msf p in fun fn -> try Hf.find ttbl fn with Not_found -> assert false + in - let tbl_annot cprog = + let tbl_annot = let tbl = Hf.create 17 in let add (fn, cfd) = let fd = fdef_of_cufdef fn cfd in @@ -210,9 +226,10 @@ struct in List.iter add cprog.Expr.p_funcs; tbl + in - let get_annot cprog fn = - try Hf.find (tbl_annot cprog) fn + let get_annot fn = + try Hf.find tbl_annot fn with Not_found -> hierror ~loc:Lnone @@ -220,16 +237,18 @@ struct ~kind:"compiler error" ~internal:true "invalid annotation table." + in - let szs_of_fn cprog fn = - match (get_annot cprog fn).stack_zero_strategy with + let szs_of_fn fn = + match (get_annot fn).stack_zero_strategy with | Some (s, ows) -> Some (s, Option.map Pretyping.tt_ws ows) | None -> None + in - let cparams ~onlyreg visit_prog_after_pass cprog = - { + let cparams = + { Compiler.rename_fd; - Compiler.expand_fd = expand_fd ~onlyreg; + Compiler.expand_fd; Compiler.split_live_ranges_fd = apply "split live ranges" split_live_ranges_fd; Compiler.renaming_fd = apply "alloc inline assgn" renaming_fd; @@ -244,7 +263,7 @@ struct Compiler.regalloc = global_regalloc; Compiler.print_uprog = (fun s p -> - pp_cuprog visit_prog_after_pass s p; + pp_cuprog s p; p); Compiler.print_sprog = (fun s p -> @@ -261,26 +280,10 @@ struct Compiler.fresh_id; Compiler.fresh_var_ident = Conv.fresh_var_ident; Compiler.slh_info; - Compiler.stack_zero_info = szs_of_fn cprog; + Compiler.stack_zero_info = szs_of_fn; } + in -end - -(*--------------------------------------------------------------------- *) - -let compile (type reg regx xreg rflag cond asm_op extra_op) - (module Arch : Arch_full.Arch - with type reg = reg - and type regx = regx - and type xreg = xreg - and type rflag = rflag - and type cond = cond - and type asm_op = asm_op - and type extra_op = extra_op) visit_prog_after_pass prog cprog = - - let module CP = CompilerParams(Arch) in - let open CP in - let export_functions = let conv fd = fd.f_name in List.fold_right @@ -291,77 +294,6 @@ let compile (type reg regx xreg rflag cond asm_op extra_op) (snd prog) [] in - Compiler.compile_prog_to_asm Arch.asm_e Arch.call_conv Arch.aparams - (cparams ~onlyreg:true visit_prog_after_pass cprog) + Compiler.compile_prog_to_asm Arch.asm_e Arch.call_conv Arch.aparams cparams export_functions (Expr.to_uprog Build_Tabstract Arch.asmOp cprog) -(*--------------------------------------------------------------------- *) - - -let compile_CL (type reg regx xreg rflag cond asm_op extra_op) - (module Arch : Arch_full.Arch - with type reg = reg - and type regx = regx - and type xreg = xreg - and type rflag = rflag - and type cond = cond - and type asm_op = asm_op - and type extra_op = extra_op) cprog toextract = - let module CP = CompilerParams(Arch) in - let open CP in - - let visit_prog_after_pass ~debug s p = - eprint s (Printer.pp_prog ~debug Arch.reg_size Arch.asmOp) p in - - let cparams = CP.cparams ~onlyreg:false visit_prog_after_pass cprog in - - (* Add array copy after inlining every where *) - let is_array_init e = - match e with - | Parr_init _ -> true - | _ -> false in - - let rec add_array_copy_i i = - { i with i_desc = add_array_copy_id i.i_desc } - - and add_array_copy_id i = - match i with - | Cif(e,c1,c2) -> Cif(e, add_array_copy_c c1, add_array_copy_c c2) - | Cfor(x,r,c) -> Cfor(x,r, add_array_copy_c c) - | Cwhile(a,c1,e,c2) -> Cwhile(a, add_array_copy_c c1, e, add_array_copy_c c2) - | Cassgn(Lvar x, t, _ty, e) when is_arr x.pl_desc && not (is_array_init e) -> - let (ws,n) = array_kind x.pl_desc.v_ty in - Copn([Lvar x],t, Opseudo_op (Ocopy(ws, Conv.pos_of_int n)), [e]) - | Cassgn(Lasub (_, ws, n,_, _) as x, t, _ty, e) when not (is_array_init e) -> - Copn([x],t, Opseudo_op (Ocopy(ws, Conv.pos_of_int n)), [e]) - | Cassert _ | Ccall _ | Copn _ | Csyscall _ | Cassgn _ -> i - - and add_array_copy_c c = - List.map add_array_copy_i c in - - let add_array_copy_f f = - { f with f_body = add_array_copy_c f.f_body } in - let add_array_copy (g,fds) = (g, List.map add_array_copy_f fds) in - - let doit f p = - match f p with - | Utils0.Error e -> - let e = Conv.error_of_cerror (Printer.pp_err ~debug:!debug) e in - raise (HiError e) - | Utils0.Ok p -> p in - - let cprog = - doit - (Compiler.compiler_CL_first_part Arch.asm_e Arch.aparams cparams - [toextract]) - (Expr.to_uprog Build_Tabstract Arch.asmOp cprog) in - - let cprog = - let p = Conv.prog_of_cuprog (Obj.magic cprog) in -(* Format.eprintf "Before add copy@.%a@." (Printer.pp_prog ~debug:true Arch.reg_size Arch.asmOp) p; *) - let p = add_array_copy p in -(* Format.eprintf "After add copy@.%a@." (Printer.pp_prog ~debug:true Arch.reg_size Arch.asmOp) p; *) - let cp = Conv.cuprog_of_prog p in - cp in - doit (Compiler.compiler_CL_second_part Arch.asm_e Arch.aparams cparams [toextract]) - (Expr.to_uprog Build_Tabstract Arch.asmOp cprog) diff --git a/compiler/src/compile.mli b/compiler/src/compile.mli index 7149ff65a..8927bfe4f 100644 --- a/compiler/src/compile.mli +++ b/compiler/src/compile.mli @@ -62,32 +62,3 @@ val compile : Expr._uprog -> ('reg, 'regx, 'xreg, 'rflag, 'cond, 'asm_op) Arch_decl.asm_prog Compiler_util.cexec - -val compile_CL : - (module Arch_full.Arch - with type reg = 'reg - and type regx = 'regx - and type xreg = 'xreg - and type rflag = 'rflag - and type cond = 'cond - and type asm_op = 'asm_op - and type extra_op = 'extra_op) -> -(* (debug:bool -> - Compiler.compiler_step -> - ( unit, - ( 'reg, - 'regx, - 'xreg, - 'rflag, - 'cond, - 'asm_op, - 'extra_op ) - Arch_extra.extended_op - Sopn.asm_op_t ) - prog -> - unit) -> *) - ('reg, 'regx, 'xreg, 'rflag, 'cond, 'asm_op, 'extra_op) Arch_extra.extended_op - Expr._uprog -> Prog.funname -> - ('reg, 'regx, 'xreg, 'rflag, 'cond, 'asm_op, 'extra_op) Arch_extra.extended_op - Expr.uprog - diff --git a/compiler/src/toCL.ml b/compiler/src/toCL.ml deleted file mode 100644 index 5824ff2ef..000000000 --- a/compiler/src/toCL.ml +++ /dev/null @@ -1,2123 +0,0 @@ -open Allocation -open Arch_extra -open Arch_params -open Array_copy -open Array_expansion -open Array_init -open Compiler_util -open Dead_calls -open Dead_code -open Eqtype -open Expr -open Inline -open Lowering -open MakeReferenceArguments -open Propagate_inline -open Remove_globals -open Utils0 -open Compiler -open Utils -open Prog -open Glob_options -open Utils - -let unsharp = String.map (fun c -> if c = '#' then '_' else c) - -module CL = struct - - type const = Z.t - - let pp_const fmt c = Format.fprintf fmt "(%s)" (Z.to_string c) - - type var = Prog.var - - let pp_var fmt x = - Format.fprintf fmt "%s_%s" (unsharp x.v_name) (string_of_uid x.v_id) - - type ty = - | Uint of int - | Sint of int (* Should be bigger than 1 *) - | Bit - | Vector of int * ty - - let rec pp_ty fmt ty = - match ty with - | Uint i -> Format.fprintf fmt "uint%i" i - | Sint i -> Format.fprintf fmt "sint%i" i - | Bit -> Format.fprintf fmt "bit" - | Vector (i,t) -> Format.fprintf fmt "%a[%i]" pp_ty t i - - let pp_cast fmt ty = Format.fprintf fmt "%@%a" pp_ty ty - - type tyvar = var * ty - - let pp_vector fmt typ = - match typ with - | Vector _ -> Format.fprintf fmt "%%" - | _ -> () - - let pp_vvar fmt (x, ty) = - Format.fprintf fmt "%a%a" pp_vector ty pp_var x - - let pp_tyvar fmt ((x, ty) as v) = - Format.fprintf fmt "%a%a" pp_vvar v pp_cast ty - - let pp_tyvars fmt xs = - Format.fprintf fmt "%a" (pp_list ",@ " pp_tyvar) xs - - let pp_tyvar2 fmt (x, ty) = - Format.fprintf fmt "%a%a" pp_vector ty pp_var x - - let pp_tyvars2 fmt xs = - Format.fprintf fmt "%a" (pp_list ",@ " pp_tyvar2) xs - - (* Expression over z *) - - module I = struct - - type eexp = - | Iconst of const - | Ivar of tyvar - | Iunop of string * eexp - | Ibinop of eexp * string * eexp - | Ilimbs of const * eexp list - - let (!-) e1 = Iunop ("-", e1) - let (-) e1 e2 = Ibinop (e1, "-", e2) - let (+) e1 e2 = Ibinop (e1, "+", e2) - let mull e1 e2 = Ibinop (e1, "*", e2) - let power e1 e2 = Ibinop (e1, "**", e2) - - let rec pp_eexp fmt e = - match e with - | Iconst c -> pp_const fmt c - | Ivar x -> pp_tyvar2 fmt x - | Iunop(s, e) -> Format.fprintf fmt "(%s %a)" s pp_eexp e - | Ibinop (e1, s, e2) -> Format.fprintf fmt "(%a %s %a)" pp_eexp e1 s pp_eexp e2 - | Ilimbs (c, es) -> - Format.fprintf fmt "(limbs %a [%a])" - pp_const c - (pp_list ",@ " pp_eexp) es - - type epred = - | Eeq of eexp * eexp - | Eeqmod of eexp * eexp * eexp list - - let pp_epred fmt ep = - match ep with - | Eeq(e1, e2) -> Format.fprintf fmt "(%a = %a)" pp_eexp e1 pp_eexp e2 - | Eeqmod(e1,e2, es) -> - Format.fprintf fmt "(%a = %a (mod [%a]))" - pp_eexp e1 - pp_eexp e2 - (pp_list ",@ " pp_eexp) es - - let pp_epreds fmt eps = - if eps = [] then Format.fprintf fmt "true" - else Format.fprintf fmt "/\\[@[%a@]]" (pp_list ",@ " pp_epred) eps - - end - - (* Range expression *) - module R = struct - - type rexp = - | Rvar of tyvar - | Rconst of int * const - | Ruext of rexp * int - | Rsext of rexp * int - | Runop of string * rexp - | Rbinop of rexp * string * rexp - | Rpreop of string * rexp * rexp - | Rlimbs of const * rexp list - | RVget of rexp * int * int * const - - let const z1 z2 = Rconst(z1, z2) - let (!-) e1 = Runop ("-", e1) - let minu e1 e2 = Rbinop (e1, "-", e2) - let add e1 e2 = Rbinop (e1, "+", e2) - let mull e1 e2 = Rbinop (e1, "*", e2) - let neg e1 = Runop ("neg", e1) - let not e1 = Runop ("not", e1) - let rand e1 e2 = Rbinop (e1, "&", e2) - let ror e1 e2 = Rbinop (e1, "|", e2) - let xor e1 e2 = Rbinop (e1, "^", e2) - let umod e1 e2 = Rpreop ("umod", e1, e2) - let smod e1 e2 = Rpreop ("smod", e1, e2) - let srem e1 e2 = Rpreop ("srem", e1, e2) - let shl e1 e2 = Rpreop ("shl", e1, e2) - let shr e1 e2 = Rpreop ("shr", e1, e2) - let udiv e1 e2 = Rpreop ("udiv", e1, e2) - - let rec pp_rexp fmt r = - match r with - | Rvar x -> pp_tyvar fmt x - | Rconst (c1, c2) -> Format.fprintf fmt "(const %i %a)" c1 pp_const c2 - | Ruext (e, c) -> Format.fprintf fmt "(uext %a %i)" pp_rexp e c - | Rsext (e, c) -> Format.fprintf fmt "(sext %a %i)" pp_rexp e c - | Runop(s, e) -> Format.fprintf fmt "(%s %a)" s pp_rexp e - | Rbinop(e1, s, e2) -> Format.fprintf fmt "(%a %s %a)" pp_rexp e1 s pp_rexp e2 - | Rpreop(s, e1, e2) -> Format.fprintf fmt "(%s %a %a)" s pp_rexp e1 pp_rexp e2 - | Rlimbs(c, es) -> - Format.fprintf fmt "(limbs %a [%a])" - pp_const c - (pp_list ",@ " pp_rexp) es - | RVget(e,i1,i2,c) -> - Format.fprintf fmt "(%a[%a])" - pp_rexp e - pp_const c - - type rpred = - | RPcmp of rexp * string * rexp - | RPeqmod of rexp * rexp * string * rexp - | RPnot of rpred - | RPand of rpred list - | RPor of rpred list - - let eq e1 e2 = RPcmp (e1, "=", e2) - let equmod e1 e2 e3 = RPeqmod (e1, e2, "umod", e3) - let eqsmod e1 e2 e3 = RPeqmod (e1, e2, "smod", e3) - let ult e1 e2 = RPcmp (e1, "<", e2) - let ule e1 e2 = RPcmp (e1, "<=", e2) - let ugt e1 e2 = RPcmp (e1, ">", e2) - let uge e1 e2 = RPcmp (e1, ">=", e2) - let slt e1 e2 = RPcmp (e1, "s", e2) - let sge e1 e2 = RPcmp (e1, ">=s", e2) - - let rec pp_rpred fmt rp = - match rp with - | RPcmp(e1, s, e2) -> Format.fprintf fmt "(%a %s %a)" pp_rexp e1 s pp_rexp e2 - | RPeqmod(e1, e2, s, e3) -> - Format.fprintf fmt "(%a = %a (%s %a))" pp_rexp e1 pp_rexp e2 s pp_rexp e3 - | RPnot e -> Format.fprintf fmt "(~ %a)" pp_rpred e - | RPand rps -> - begin - match rps with - | [] -> Format.fprintf fmt "true" - | [h] -> pp_rpred fmt h - | h :: q -> Format.fprintf fmt "/\\[%a]" (pp_list ",@ " pp_rpred) rps - end - | RPor rps -> Format.fprintf fmt "\\/[%a]" (pp_list ",@ " pp_rpred) rps - - let pp_rpreds fmt rps = pp_rpred fmt (RPand rps) - - end - - type clause = I.epred list * R.rpred list - - let pp_clause fmt (ep,rp) = - Format.fprintf fmt "@[@[%a@] &&@ @[%a@]@]" - I.pp_epreds ep - R.pp_rpreds rp - - type gvar = var - - let pp_gvar fmt x = - Format.fprintf fmt "%a@@bit :" pp_var x - - let pp_gvars fmt xs = - Format.fprintf fmt "%a" (pp_list ",@ " pp_gvar) xs - - module Instr = struct - - type atom = - | Aconst of const * ty - | Avar of tyvar - | Avecta of tyvar * int - | Avatome of atom list - - let rec pp_atom fmt a = - match a with - | Aconst (c, ty) -> Format.fprintf fmt "%a%a" pp_const c pp_cast ty - | Avar tv -> pp_tyvar fmt tv - | Avecta (v, i) -> Format.fprintf fmt "%a[%i]" pp_vvar v i - | Avatome al -> Format.fprintf fmt "[%a]" (pp_list ", " pp_atom) al - - type lval = tyvar - - type arg = - | Atom of atom - | Lval of lval - | Const of const - | Ty of ty - | Pred of clause - | Gval of gvar - - type args = arg list - - let pp_arg fmt a = - match a with - | Atom a -> pp_atom fmt a - | Lval lv -> pp_tyvar fmt lv - | Const c -> pp_const fmt c - | Ty ty -> pp_ty fmt ty - | Pred cl -> pp_clause fmt cl - | Gval x -> pp_gvar fmt x - - type instr = - { iname : string; - iargs : args; } - - let pp_instr fmt (i : instr) = - Format.fprintf fmt "%s %a;" - i.iname (pp_list " " pp_arg) i.iargs - - let pp_instrs fmt (is : instr list) = - Format.fprintf fmt "%a" (pp_list "@ " pp_instr) is - - module Op1 = struct - - let op1 iname (d : lval) (s : atom) = - { iname; iargs = [Lval d; Atom s] } - - let mov = op1 "mov" - let not = op1 "not" - - end - - module Op2 = struct - - let op2 iname (d : lval) (s1 : atom) (s2 : atom) = - { iname; iargs = [Lval d; Atom s1; Atom s2] } - - let add = op2 "add" - let sub = op2 "sub" - let mul = op2 "mul" - let seteq = op2 "seteq" - let and_ = op2 "and" - let xor = op2 "xor" - let mulj = op2 "mulj" - let setne = op2 "setne" - let or_ = op2 "or" - let join = op2 "join" - - end - - module Op2c = struct - - let op2c iname (d : lval) (s1 : atom) (s2 : atom) (c : tyvar) = - { iname; iargs = [Lval d; Atom s1; Atom s2; Atom (Avar c)] } - - let adc = op2c "adc" - let sbc = op2c "sbc" - let sbb = op2c "sbb" - - end - - module Op2_2 = struct - - let op2_2 iname (d1 : lval) (d2: lval) (s1 : atom) (s2 : atom) = - { iname; iargs = [Lval d1; Lval d2; Atom s1; Atom s2] } - - let subc = op2_2 "subc" - let mull = op2_2 "mull" - let cmov = op2_2 "cmov" - let adds = op2_2 "adds" - let subb = op2_2 "subb" - let muls = op2_2 "muls" - - end - - module Op2_2c = struct - - let op2_2c iname (d1 : lval) (d2: lval) (s1 : atom) (s2 : atom) (c : tyvar) = - { iname; iargs = [Lval d1; Lval d2; Atom s1; Atom s2; Atom (Avar c)] } - - let adcs = op2_2c "adcs" - let sbcs = op2_2c "sbcs" - let sbbs = op2_2c "sbbs" - - end - - module Shift = struct - - let shift iname (d : lval) (s : atom) (c : const) = - { iname; iargs = [Lval d; Atom s; Const c] } - - let shl = shift "shl" - let shr = shift "shr" - let sar = shift "sar" - - end - - module Cshift = struct - - let cshift iname (d1 : lval) (d2 : lval) (s1 : atom) (s2 : atom) (c : const) = - { iname; iargs = [Lval d1; Lval d2; Atom s1; Atom s2; Const c] } - - let cshl = cshift "cshl" - let cshr = cshift "cshr" - - end - - module Shifts = struct - - let shifts iname (d1 : lval) (d2 : lval) (s : atom) (c : const) = - { iname; iargs = [Lval d1; Lval d2; Atom s; Const c] } - - let shls = shifts "shls" - let shrs = shifts "shrs" - let sars = shifts "sars" - let spl = shifts "spl" - let split = shifts "split" - let ssplit = shifts "ssplit" - - end - - module Shift2s = struct - - let shift2s iname (d1 : lval) (d2 : lval) (d3 : lval) (s1 : atom) (s2 : atom) (c : const) = - { iname; iargs = [Lval d1; Lval d2; Lval d3; Atom s1; Atom s2; Const c] } - - let cshls = shift2s "cshls" - let cshrs = shift2s "cshrs" - - end - - let cast _ty (d : lval) (s : atom) = - { iname = "cast"; iargs = [Lval d; Atom s] } - - let assert_ cl = - { iname = "assert"; iargs = [Pred cl] } - - let cut ep rp = - { iname = "cut"; iargs = [Pred(ep, rp)] } - - let vpc _ty (d : lval) (s : atom) = - { iname = "vpc"; iargs = [Lval d; Atom s] } - - let assume cl = - { iname = "assume"; iargs = [Pred cl] } - - let ghost (v: gvar) cl = - { iname = "ghost"; iargs = [Gval v; Pred cl] } - - (* nondet set rcut clear ecut *) - - end - - module Proc = struct - - type proc = - { id : string; - formals : tyvar list; - pre : clause; - prog : Instr.instr list; - post : clause; - } - - let pp_proc fmt (proc : proc) = - Format.fprintf fmt - "@[proc %s(@[%a@]) = @ {@[@ %a@]@ }@ %a@ {@[@ %a@]@ }@ @] " - proc.id - pp_tyvars proc.formals - pp_clause proc.pre - Instr.pp_instrs proc.prog - pp_clause proc.post - end -end - -module Counter = struct - let cpt = ref 0 - let next () = incr cpt ; !cpt - let get () = !cpt -end - -module Cfg = struct - - type node = - { mutable nkind : CL.Instr.instr; - mutable succs : node list; - mutable preds: node list; - id: int - } - - and program = node list - - let mk_node nkind = - let preds = [] in - let succs = [] in - let id = Counter.next() in - { nkind ; succs; preds; id } - - (** Compute CFG: - Requires to first compute all nodes, by maintaining the order of the stmt - in the list. - *) - - let rec update_succ node succ = - let addSucc n = - node.succs <- n :: node.succs; - n.preds <- node :: n.preds - in - let addOptionSucc (n: node option) = - match n with - | None -> () - | Some n' -> addSucc n' - in - addOptionSucc succ - - let rec cfg_node nodes next = - match nodes with - | [] -> assert false - | [h] -> update_succ h next - | h :: q -> - update_succ h (Some (List.hd q)); - cfg_node q next - - let compute_cfg program = cfg_node program None - - let cfg_of_prog prog = - let cfg = List.map mk_node prog in - compute_cfg cfg; - List.hd cfg - - let cfg_of_prog_rev prog = - let prog_rev = List.rev prog in - let cfg = List.map mk_node prog_rev in - compute_cfg cfg; - List.hd cfg - - let prog_of_cfg cfg = - let rec aux node acc = - match node.succs with - | [] -> node.nkind::acc - | [h] -> aux h (node.nkind::acc) - | _ -> assert false - in - aux cfg [] - - let prog_of_cfg_rev cfg = - let rec aux node acc = - match node.succs with - | [] -> node.nkind::acc - | [h] -> aux h (node.nkind::acc) - | _ -> assert false - in - let prog_rev = aux cfg [] in - List.rev prog_rev - - -end - -module SimplVector = struct - open Cfg - open CL.Instr - - let rec int_of_ty = function - | CL.Uint n -> n - | Sint n -> n - | Bit -> assert false - | Vector (i,t) -> i * int_of_ty t - - let int_of_tyvar (tyv: CL.tyvar) = - let (_,ty) = tyv in - int_of_ty ty - - let getNextI n' = - match n'.preds with - | h :: _ -> Some h - | _ -> None - - let getPrevI n' = - match n'.succs with - | h :: _ -> Some h - | _ -> None - - let rec is_unsigned (ty: CL.ty) = - match ty with - | Uint _ -> true - | Sint _ -> false - | Bit -> true - | Vector (_, ty') -> is_unsigned ty' - - let rec is_equiv_type (ty: CL.ty) (ty': CL.ty) = - match (ty, ty') with - | (Uint i, Uint i') -> i == i' - | (Uint i, Sint i') -> false - | (Uint i, Bit) -> assert false - | (Uint i, Vector (i', ty'')) -> - i == (i' * int_of_ty ty'') && (is_unsigned ty'') - | (Sint i, Bit) -> assert false - | (Sint i, Vector (i', ty'')) -> - i == (i' * int_of_ty ty'') && not(is_unsigned ty'') - | (Bit, Vector (_, _)) -> assert false - | Vector (i, ty''), Vector (i', ty''') -> - (i * int_of_ty ty'' == i' * int_of_ty ty''') && ((is_unsigned ty'') == (is_unsigned ty''')) - | _ -> is_equiv_type ty' ty (* use recursivity to check the commutative pair *) - - let rec find_vect_lval v n = - let (v, ty) = v in - let aux v' n' = - let nI = getPrevI n' in - match nI with - | Some i -> find_vect_lval v' i - | None -> None - in - match n.nkind with - | {iname = "cast"; iargs = [Lval (v', ty'); Atom (Avar (v'', ty''))]} -> - if v == v' && is_equiv_type ty' ty'' then - aux (v'',ty'') n - else - aux (v, ty) n - | {iname = "mov"; iargs = [Lval (v', ty') ; Atom (Avecta ((v'', ty''), j))]} -> - if v == v' && j == 0 && is_equiv_type ty' ty'' then (* do we care if j != 0 ? *) - aux (v'',ty'') n - else - aux (v, ty) n - | {iname = "mov"; iargs = [Lval (v', ty'); Atom (Avatome [Avar (v'', ty'')])]} -> - if v == v' && is_equiv_type ty' ty'' then - aux (v'', ty'') n - else - aux (v, ty) n - | {iname = "adds"; iargs = [_; Lval (v', ty'); Atom (Avar (_, ty'')); Atom (Avar (_, ty'''))]} -> - if v == v' && (is_equiv_type ty' ty'' || is_equiv_type ty' ty''') then - Some (v', ty') - else - aux (v, ty) n - | {iname = "add"; iargs = [Lval (v', ty'); Atom (Avar (_, ty'')); Atom (Avar (_, ty'''))]} -> - if v == v' && (is_equiv_type ty' ty'' || is_equiv_type ty' ty''') then - Some (v', ty') - else - aux (v, ty) n - | {iname = "mull"; iargs = [Lval (vh', tyh'); Lval (vl', tyl'); Atom (Avar (_, ty'')); Atom (Avar (_, ty'''))]} -> - if v == vl' && (is_equiv_type tyl' ty'' || is_equiv_type tyl' ty''') then - Some (vl', tyl') - else if v == vh' && (is_equiv_type tyh' ty'' || is_equiv_type tyh' ty''') then - Some (vh', tyh') - else - aux (v, ty) n - | {iname = "subb"; iargs = [_; Lval (v', ty'); Atom (Avar (_, ty'')); Atom (Avar (_, ty'''))]} -> - if v == v' && (is_equiv_type ty' ty'' || is_equiv_type ty' ty''') then - Some (v', ty') - else - aux (v, ty) n - | _ -> aux (v, ty) n (* Keep searching *) - - let sr_lval node pred = (* Search for the source of the argument in lval of another instruction *) - let rec update_arg args v i = - begin - match args with - | [] -> assert false - | h::q -> - if i == 0 then v::q - else h::(update_arg q v (i-1)) - end - in - let replace_arg v' i = - let arg' = (Atom (Avar v')) in - let iargs' = update_arg node.nkind.iargs arg' i in - node.nkind <- { iname = node.nkind.iname; iargs = iargs' } - in - let aux v idx = - let l = find_vect_lval v pred in - begin - match l with - | Some v' -> replace_arg v' idx - | None -> () - end - in - match node.nkind with - | {iname = "adds"; iargs = [_; _; Atom (Avar (v, Vector (i, ty))); Atom (Avar (v', Vector (i', ty')))]} -> - aux (v, Vector (i, ty)) 2; - aux (v', Vector (i', ty')) 3; - | {iname = "mull"; iargs = [_; _; Atom (Avar (v, Vector (i, ty))); Atom (Avar (v', Vector (i', ty')))]} -> - aux (v, Vector (i, ty)) 2; - aux (v', Vector (i', ty')) 3; - | {iname = "subb"; iargs = [_; _; Atom (Avar (v, Vector (i, ty))); Atom (Avar (v', Vector (i', ty')))]} -> - aux (v, Vector (i, ty)) 2; - aux (v', Vector (i', ty')) 3; - | _ -> () - - let rec sr_lvals node = - match node.succs with - | [] -> () - | h::_ -> - sr_lval node h; - sr_lvals h - - let rec unused_lval v nI = (* Checks if lval is used in any subsequent instruction *) - let rec var_in_vatome v' l = - match l with - | h :: t -> - begin - match h with - | Avar v' -> (v' == v) || (var_in_vatome v t) - | Avecta (v', _) -> (v' == v) || (var_in_vatome v t) - | Avatome l' -> (var_in_vatome v t) || (var_in_vatome v l') (* is this valid CL? should we assert false ?? *) - | _ -> (var_in_vatome v t) - end - | [] -> false - in - let aux v' n' = - let i = getNextI n' in - unused_lval v' i - in - match nI with - | None -> true - | Some n -> - begin - match n.nkind with - | {iname = "mov"; iargs = [_; Atom (Avar v')]} -> (v' != v) && (aux v n) - | {iname = "mov"; iargs = [_; Atom (Avecta (v', _))]} -> (v' != v) && (aux v n) - | {iname = "mov"; iargs = [_; Atom (Aconst _)]} -> aux v n - | {iname = "mov"; iargs = [_; Atom (Avatome l)]} -> not(var_in_vatome v l) && (aux v n) - | {iname = "cast"; iargs = [_; Atom (Avar v')]} -> (v' != v) && (aux v n) - | {iname = "cast"; iargs = [_; Atom (Avecta (v', _))]} -> (v' != v) && (aux v n) - | {iname = "cast"; iargs = [_; Atom (Aconst _)]} -> aux v n - | {iname = "cast"; iargs = [_; Atom (Avatome l)]} -> not(var_in_vatome v l) && (aux v n) - | {iname = "adds"; iargs = [_; _; Atom (Avar v'); Atom (Avar v'')]} -> (v' != v) && (v'' != v) && (aux v n) - | {iname = "adds"; iargs = [_; _; Atom (Avecta (v', _)); Atom (Avecta (v'', _))]} -> (v' != v) && (v'' != v) && (aux v n) - | {iname = "add"; iargs = [_; Atom (Avar v'); Atom (Avar v'')]} -> (v' != v) && (v'' != v) && (aux v n) - | {iname = "add"; iargs = [_; Atom (Avecta (v', _)); Atom (Avecta (v'', _))]} -> (v' != v) && (v'' != v) && (aux v n) - | {iname = "subb"; iargs = [_; _; Atom (Avar v'); Atom (Avar v'')]} -> (v' != v) && (v'' != v) && (aux v n) - | {iname = "subb"; iargs = [_; _; Atom (Avecta (v', _)); Atom (Avecta (v'', _))]} -> (v' != v) && (v'' != v) && (aux v n) - | {iname = "sub"; iargs = [_; Atom (Avar v'); Atom (Avar v'')]} -> (v' != v) && (v'' != v) && (aux v n) - | {iname = "sub"; iargs = [_; Atom (Avecta (v', _)); Atom (Avecta (v'', _))]} -> (v' != v) && (v'' != v) && (aux v n) - | {iname = "mull"; iargs = [_; _; Atom (Avar v'); Atom (Avar v'')]} -> (v' != v) && (v'' != v) && (aux v n) - | {iname = "mull"; iargs = [_; _; Atom (Avecta (v', _)); Atom (Avecta (v'', _))]} -> (v' != v) && (v'' != v) && (aux v n) - | _ -> aux v n - end - - let rec nop_uinst cfg node = - let nI = getNextI node in - match node.nkind with - | {iname = "cast"; iargs = [Lval v; _]} -> - if unused_lval v nI then - node.nkind <- { iname = "nop"; iargs = [] } - else () - | {iname = "mov"; iargs = [Lval v; _]} -> - if unused_lval v nI then - node.nkind <- { iname = "nop"; iargs = [] } - else () - | _ -> () - - let rec nop_uinsts cfg node = - nop_uinst cfg node; - let nI = getPrevI node in - match nI with - | None -> () - | Some i -> nop_uinsts cfg i - - let rec remove_nops l = - match l with - | [] -> [] - | h::t -> - begin - match h with - | { iname = "nop" } -> remove_nops t - | _ -> h :: remove_nops t - end - - let rec simpl_cfg cfg = - sr_lvals cfg; - let nI = getPrevI cfg in - match nI with - | None -> cfg - | Some i -> - begin - nop_uinsts cfg i; - let cfg' = cfg_of_prog (remove_nops (prog_of_cfg_rev cfg)) in - cfg' - end -end - -module type I = sig - val power: Z.t -> Z.t -> Z.t - val int_of_typ : 'a Prog.gty -> int option - val to_var : - ?sign:bool -> 'a Prog.ggvar -> 'a Prog.gvar * CL.ty - val gexp_to_rexp : ?sign:bool -> int Prog.gexpr -> CL.R.rexp - val gexp_to_rpred : ?sign:bool -> int Prog.gexpr -> CL.R.rpred - val extract_list : - 'a Prog.gexpr -> - 'a Prog.gexpr list -> 'a Prog.gexpr list - val get_const : 'a Prog.gexpr -> int - val var_to_tyvar : - ?sign:bool -> ?vector:int * int -> int Prog.gvar -> CL.tyvar - val mk_tmp_lval : - ?name:Jasmin__CoreIdent.Name.t -> - ?l:Prog.L.t -> - ?kind:Wsize.v_kind -> - ?sign:bool -> - ?vector:int * int -> int Jasmin__CoreIdent.gty -> CL.Instr.lval - val wsize_of_int: - int -> Wsize.wsize - val mk_spe_tmp_lval : - ?name:Jasmin__CoreIdent.Name.t -> - ?l:Prog.L.t -> - ?kind:Wsize.v_kind -> ?sign:bool -> int -> CL.Instr.lval - val gexp_to_eexp : - (int, CL.Instr.lval) Utils.Hash.t -> - ?sign:bool -> int Prog.gexpr -> CL.I.eexp - val gexp_to_epred : - (int, CL.Instr.lval) Utils.Hash.t -> - ?sign:bool -> int Prog.gexpr -> CL.I.epred list - val glval_to_lval : ?sign:bool -> int Prog.glval -> CL.Instr.lval - val gexp_to_var : ?sign:bool -> int Prog.gexpr -> CL.tyvar - val gexp_to_const : ?sign:bool -> 'a Prog.gexpr -> CL.const * CL.ty - val mk_const : int -> CL.const - val mk_const_atome : int -> ?sign:bool -> CL.const -> CL.Instr.atom - val gexp_to_atome : ?sign:bool -> int Prog.gexpr -> CL.Instr.atom - val mk_lval_atome : CL.Instr.lval -> CL.Instr.atom -end - -module type S = sig - val s : bool -end - -module I (S:S): I = struct - - let int_of_typ = function - | Bty (U ws) -> Some (int_of_ws ws) - | Bty (Bool) -> Some 1 - | Bty (Abstract s) -> - begin - match String.to_list s with - | '/'::'*':: q -> Some (String.to_int (String.of_list q)) - | _ -> assert false - end - | Bty (Int) -> None - | _ -> assert false - - let to_var ?(sign=S.s) x = - let var = L.unloc x.gv in - if sign then var, CL.Sint (Option.get (int_of_typ var.v_ty)) - else var, CL.Uint (Option.get (int_of_typ var.v_ty)) - - let rec gexp_to_rexp ?(sign=S.s) e : CL.R.rexp = - let open CL.R in - let (!>) e = gexp_to_rexp ~sign e in - match e with - | Papp1 (Oword_of_int ws, Pconst z) -> Rconst(int_of_ws ws, z) - | Papp1 (Oword_of_int ws, Pvar x) -> Rvar (L.unloc x.gv, Uint (int_of_ws ws)) - | Pvar x -> Rvar (to_var ~sign x) - | Papp1(Oneg _, e) -> neg !> e - | Papp1(Olnot _, e) -> not !> e - | Papp2(Oadd _, e1, e2) -> add !> e1 !> e2 - | Papp2(Osub _, e1, e2) -> minu !> e1 !> e2 - | Papp2(Omul _, e1, e2) -> mull !> e1 !> e2 - | Papp2(Odiv (Cmp_w (Unsigned,_)), e1, e2) -> udiv !> e1 !> e2 - | Papp2(Olxor _, e1, e2) -> xor !> e1 !> e2 - | Papp2(Oland _, e1, e2) -> rand !> e1 !> e2 - | Papp2(Olor _, e1, e2) -> ror !> e1 !> e2 - | Papp2(Omod (Cmp_w (Unsigned,_)), e1, e2) -> umod !> e1 !> e2 - | Papp2(Omod (Cmp_w (Signed,_)), e1, e2) -> smod !> e1 !> e2 - | Papp2(Olsl _, e1, e2) -> shl !> e1 !> e2 - | Papp2(Olsr _, e1, e2) -> shr !> e1 !> e2 - | Papp1(Ozeroext (osz,isz), e1) -> Ruext (!> e1, (int_of_ws osz) - (int_of_ws isz)) - | Pabstract ({name="se_16_64"}, [v]) -> Rsext (!> v, 48) - | Pabstract ({name="se_32_64"}, [v]) -> Rsext (!> v, 32) - | Pabstract ({name="ze_16_64"}, [v]) -> Ruext (!> v, 48) - | Presult (_, x) -> Rvar (to_var x) - | _ -> assert false - - let rec gexp_to_rpred ?(sign=S.s) e : CL.R.rpred = - let open CL.R in - let (!>) e = gexp_to_rexp ~sign e in - let (!>>) e = gexp_to_rpred ~sign e in - match e with - | Pbool (true) -> RPand [] - | Pbool (false) -> assert false - | Papp1(Onot, e) -> RPnot (!>> e) - | Papp2(Oeq _, e1, e2) -> eq !> e1 !> e2 - | Papp2(Obeq, e1, e2) -> eq !> e1 !> e2 - | Papp2(Oand, e1, e2) -> RPand [!>> e1; !>> e2] - | Papp2(Oor, e1, e2) -> RPor [!>> e1; !>> e2] - | Papp2(Ole (Cmp_w (Signed,_)), e1, e2) -> sle !> e1 !>e2 - | Papp2(Ole (Cmp_w (Unsigned,_)), e1, e2) -> ule !> e1 !> e2 - | Papp2(Olt (Cmp_w (Signed,_)), e1, e2) -> slt !> e1 !> e2 - | Papp2(Olt (Cmp_w (Unsigned,_)), e1, e2) -> ult !> e1 !> e2 - | Papp2(Oge (Cmp_w (Signed,_)), e1, e2) -> sge !> e1 !> e2 - | Papp2(Oge (Cmp_w (Unsigned,_)), e1, e2) -> uge !> e1 !> e2 - | Papp2(Ogt (Cmp_w (Signed,_)), e1, e2) -> sgt !> e1 !> e2 - | Papp2(Ogt (Cmp_w (Unsigned,_)), e1, e2) -> ugt !> e1 !> e2 - | Pif(_, e1, e2, e3) -> RPand [RPor [RPnot !>> e1; !>> e2];RPor[ !>> e1; !>> e3]] - | Pabstract ({name="eqsmod64"}, [e1;e2;e3]) -> eqsmod !> e1 !> e2 !> e3 - | Pabstract ({name="equmod64"}, [e1;e2;e3]) -> equmod !> e1 !> e2 !> e3 - | Pabstract ({name="eq"}, [e1;e2]) -> eq !> e1 !> e2 - | Pabstract ({name="u256_as_16u16"}, [e0;e1;e2;e3;e4;e5;e6;e7;e8;e9;e10;e11;e12;e13;e14;e15;e16]) -> - RPand [] (* FIX ME: INTRODUCE AN INITIAL ASSIGNMENT! *) - | _ -> assert false - - let rec extract_list e aux = - match e with - | Pabstract ({name="single"}, [h]) -> [h] - | Pabstract ({name="pair"}, [h1;h2]) -> [h1;h2] - | Pabstract ({name="triple"}, [h1;h2;h3]) -> [h1;h2;h3] - | Pabstract ({name="word_nil"}, []) -> List.rev aux - | Pabstract ({name="word_cons"}, [h;q]) -> extract_list q (h :: aux) - | _ -> assert false - - let rec get_const x = - match x with - | Pconst z -> Z.to_int z - | Papp1 (Oword_of_int _ws, x) -> get_const x - | _ -> assert false - - let var_to_tyvar ?(sign=S.s) ?vector v : CL.tyvar = - match vector with - | None -> - begin - match int_of_typ v.v_ty with - | None -> v, CL.Bit - | Some w -> - if sign then v, CL.Sint w - else v, CL.Uint w - end - | Some (n,w) -> - begin - match int_of_typ v.v_ty with - | None -> assert false - | Some w' -> - assert (n * w = w' && not sign); - v, CL.Vector (n, CL.Uint w) - end - - let mk_tmp_lval ?(name = "TMP____") ?(l = L._dummy) - ?(kind = (Wsize.Stack Direct)) ?(sign=S.s) - ?vector ty : CL.Instr.lval = - let v = CoreIdent.GV.mk name kind ty l [] in - var_to_tyvar ~sign ?vector v - - let wsize_of_int = function - | 8 -> Wsize.U8 - | 16 -> Wsize.U16 - | 32 -> Wsize.U32 - | 64 -> Wsize.U64 - | 128 -> Wsize.U128 - | 256 -> Wsize.U256 - | _ -> assert false - - let mk_spe_tmp_lval ?(name = "TMP____") ?(l = L._dummy) - ?(kind = (Wsize.Stack Direct)) ?(sign=S.s) - size = - let size = String.to_list (String.of_int size) in - let s = String.of_list ('/'::'*':: size) in - mk_tmp_lval ~name ~l ~kind ~sign (Bty(Abstract s)) - - let rec gexp_to_eexp env ?(sign=S.s) e : CL.I.eexp = - let open CL.I in - let (!>) e = gexp_to_eexp env ~sign e in - match e with - | Pconst z -> Iconst z - | Pvar x -> Ivar (to_var ~sign x) - | Papp1 (Oword_of_int _ws, x) -> !> x - | Papp1 (Oint_of_word _ws, x) -> !> x - | Papp1(Oneg _, e) -> !- !> e - | Papp2(Oadd _, e1, e2) -> !> e1 + !> e2 - | Papp2(Osub _, e1, e2) -> !> e1 - !> e2 - | Papp2(Omul _, e1, e2) -> mull !> e1 !> e2 - | Pabstract ({name="limbs"}, [h;q]) -> - begin - match !> h with - | Iconst c -> Ilimbs (c, (List.map (!>) (extract_list q []))) - | _ -> assert false - end - | Pabstract ({name="pow"}, [b;e]) -> power !> b !> e - | Pabstract ({name="mon"}, [c;a;b]) -> - let c = get_const c in - let v = - match Hash.find env c with - | exception Not_found -> - let name = "X" ^ "_" ^ string_of_int c in - let x = - mk_tmp_lval ~name (Bty Int) - in - Hash.add env c x; - x - | x -> x - in - mull !> b (power (Ivar v) !> a) - | Presult (_,x) -> Ivar (to_var ~sign x) - | _ -> assert false - - let rec gexp_to_epred env ?(sign=S.s) e :CL.I.epred list = - let open CL.I in - let (!>) e = gexp_to_eexp env ~sign e in - let (!>>) e = gexp_to_epred env ~sign e in - match e with - | Papp2(Oeq _, e1, e2) -> [Eeq (!> e1, !> e2)] - | Papp2(Oand, e1, e2) -> !>> e1 @ !>> e2 - | Pabstract ({name="eqmod"} as _opa, [h1;h2;h3]) -> - [Eeqmod (!> h1, !> h2, List.map (!>) (extract_list h3 []))] - | _ -> assert false - - let glval_to_lval ?(sign=S.s) x : CL.Instr.lval = - match x with - | Lvar v -> var_to_tyvar ~sign (L.unloc v) - | Lnone (l,ty) -> - let name = "NONE____" in - mk_tmp_lval ~sign ~name ~l ty - | Lmem _ | Laset _ | Lasub _ -> assert false - - let gexp_to_var ?(sign=S.s) x : CL.tyvar = - match x with - | Pvar x -> var_to_tyvar ~sign (L.unloc x.gv) - | _ -> assert false - - let rec power (acc: Z.t) (n: Z.t) = match n with - | n when n = Z.zero -> acc - | n when Z.(n < Z.zero) -> assert false - | n -> power Z.(acc * (Z.of_int 2)) Z.(n - Z.one) - - let gexp_to_const ?(sign=S.s) x : CL.const * CL.ty = - match x with - | Papp1 (Oword_of_int ws, Pconst c) -> - Format.eprintf "%s@." (Z.to_string c); - Format.eprintf "%s@." (Z.to_string ( Z.((power Z.one (z_of_ws ws))) )); - Format.eprintf "%s@." (Z.to_string ( Z.(c - (power Z.one (z_of_ws ws))) )); - if sign then - let c = if Z.(c >= power Z.one Z.((z_of_ws ws) - one)) then - Z.(c - (power Z.one (z_of_ws ws))) else c in - (c , CL.Sint (int_of_ws ws)) - else (c, CL.Uint (int_of_ws ws)) - | _ -> assert false - - let mk_const c : CL.const = Z.of_int c - - let mk_const_atome ws ?(sign=S.s) c = - if sign then CL.Instr.Aconst (c, CL.Sint ws) - else CL.Instr.Aconst (c, CL.Uint ws) - - let gexp_to_atome ?(sign=S.s) x : CL.Instr.atom = - match x with - | Pvar _ -> Avar (gexp_to_var ~sign x) - | Papp1 (Oword_of_int _, Pconst _) -> - let c,ty = gexp_to_const x in - Aconst (c,ty) - | _ -> assert false - - let mk_lval_atome (lval: CL.Instr.lval) = CL.Instr.Avar (lval) -end - - -module type BaseOp = sig - type op - type extra_op - - module I: I - - val op_to_instr : - Annotations.annotations -> - int Prog.glval list -> - op -> int Prog.gexpr list -> CL.Instr.instr list - - val assgn_to_instr : - Annotations.annotations -> - int Prog.glval -> int Prog.gexpr -> CL.Instr.instr list - -end - -module X86BaseOpU : BaseOp - with type op = X86_instr_decl.x86_op - with type extra_op = X86_extra.x86_extra_op -= struct - - type op = X86_instr_decl.x86_op - type extra_op = X86_extra.x86_extra_op - - module S = struct - let s = false - end - - module I = I (S) - - type trans = - | Cas1 - | Cas2 - | Cas3 - | Smt - - let trans annot = - let l = - ["smt", Smt ; "cas", Cas1; "cas_two", Cas2; "cas_three", Cas3 ] - in - let mk_trans = Annot.filter_string_list None l in - let atran annot = - match Annot.ensure_uniq1 "tran" mk_trans annot with - | None -> Cas1 - | Some aty -> aty - in - atran annot - - let cast_atome ws x = - match x with - | Pvar va -> - let ws_x = ws_of_ty (L.unloc va.gv).v_ty in - if ws = ws_x then I.gexp_to_atome x,[] - else - let e = I.gexp_to_atome x in - let v = L.unloc va.gv in - let kind = v.v_kind in - let (_,ty) as x = I.mk_tmp_lval ~kind (CoreIdent.tu ws) in - CL.Instr.Avar x, [CL.Instr.cast ty x e] - | Papp1 (Oword_of_int ws_x, Pconst z) -> - if ws = ws_x then I.gexp_to_atome x,[] - else - let e = I.gexp_to_atome x in - let (_,ty) as x = I.mk_tmp_lval (CoreIdent.tu ws) in - CL.Instr.Avar x, [CL.Instr.cast ty x e] - | _ -> assert false - - let (!) e = I.mk_lval_atome e - - let cast_vector_atome ws v x = - let a,i = cast_atome ws x in - let a1 = CL.Instr.Avatome [a] in - let v = int_of_velem v in - let s = int_of_ws ws in - let l_tmp = I.mk_tmp_lval ~vector:(1,s) (CoreIdent.tu ws) in - let l_tmp2 = I.mk_tmp_lval ~vector:(v,s/v) (CoreIdent.tu ws) in - let ty = CL.(Vector (v, Uint (s/v))) in - CL.Instr.Avar l_tmp2, - i @ [CL.Instr.Op1.mov l_tmp a1; - CL.Instr.cast ty l_tmp2 !l_tmp; - ] - - let cast_atome_vector ws v x l = - let s = int_of_ws ws in - let l_tmp = I.mk_tmp_lval ~vector:(1,s) (CoreIdent.tu ws) in - let ty = CL.(Vector (v, Uint s)) in - let a = CL.Instr.Avecta (l_tmp, 0) in - [CL.Instr.cast ty l_tmp x; - CL.Instr.Op1.mov l a - ] - - let assgn_to_instr _annot x e = - let a = I.gexp_to_atome e in - let l = I.glval_to_lval x in - [CL.Instr.Op1.mov l a] - - let op_to_instr annot xs o es = - let trans = trans annot in - match o with - | X86_instr_decl.MOV ws -> - let a,i = cast_atome ws (List.nth es 0) in - let l = I.glval_to_lval (List.nth xs 0) in - i @ [CL.Instr.Op1.mov l a] - - | ADD ws -> - begin - let a1,i1 = cast_atome ws (List.nth es 0) in - let a2,i2 = cast_atome ws (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - match trans with - | Smt -> - i1 @ i2 @ [CL.Instr.Op2.add l a1 a2] - | Cas1 -> - let l_tmp = I.mk_spe_tmp_lval 1 in - i1 @ i2 @ [CL.Instr.Op2_2.adds l_tmp l a1 a2] - | _ -> assert false - end - - | SUB ws -> - begin - let a1, i1 = cast_atome ws (List.nth es 0) in - let a2, i2 = cast_atome ws (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - match trans with - | Smt -> - i1 @ i2 @ [CL.Instr.Op2.sub l a1 a2] - | Cas1 -> - let l_tmp = I.mk_spe_tmp_lval 1 in - i1 @ i2 @ [CL.Instr.Op2_2.subb l_tmp l a1 a2] - | _ -> assert false - end - - | IMULr ws -> - let a1, i1 = cast_atome ws (List.nth es 0) in - let a2, i2 = cast_atome ws (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - let l_tmp = I.mk_tmp_lval (CoreIdent.tu ws) in - i1 @ i2 @ [CL.Instr.Op2_2.mull l_tmp l a1 a2] - - | IMULri ws -> - let a1, i1 = cast_atome ws (List.nth es 0) in - let a2, i2 = cast_atome ws (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - let l_tmp = I.mk_tmp_lval (CoreIdent.tu ws) in - i1 @ i2 @ [CL.Instr.Op2_2.mull l_tmp l a1 a2] - - | ADC ws -> - let a1, i1 = cast_atome ws (List.nth es 0) in - let a2, i2 = cast_atome ws (List.nth es 1) in - let l1 = I.glval_to_lval (List.nth xs 1) in - let l2 = I.glval_to_lval (List.nth xs 5) in - let v = I.gexp_to_var (List.nth es 2) in - i1 @ i2 @ [CL.Instr.Op2_2c.adcs l1 l2 a1 a2 v] - - | SBB ws -> - let a1, i1 = cast_atome ws (List.nth es 0) in - let a2, i2 = cast_atome ws (List.nth es 1) in - let l1 = I.glval_to_lval (List.nth xs 1) in - let l2 = I.glval_to_lval (List.nth xs 5) in - let v = I.gexp_to_var (List.nth es 2) in - i1 @ i2 @ [CL.Instr.Op2_2c.sbbs l1 l2 a1 a2 v] - - | NEG ws -> - let a = I.mk_const_atome ~sign:true (int_of_ws ws) Z.zero in - let a1,i1 = cast_atome ws (List.nth es 0) in - let l_tmp1 = I.mk_tmp_lval ~sign:true (CoreIdent.tu ws) in - let ty1 = CL.Sint (int_of_ws ws) in - let l_tmp2 = I.mk_tmp_lval ~sign:true (CoreIdent.tu ws) in - let ty2 = CL.Sint (int_of_ws ws) in - let l = I.glval_to_lval (List.nth xs 5) in - i1 @ [CL.Instr.cast ty1 l_tmp1 a1; - CL.Instr.Op2.sub l_tmp2 a !l_tmp1; - CL.Instr.cast ty2 l !l_tmp2 - ] - - | INC ws -> - let a1 = I.mk_const_atome (int_of_ws ws) Z.one in - let a2,i2 = cast_atome ws (List.nth es 0) in - let l = I.glval_to_lval (List.nth xs 4) in - let l_tmp = I.mk_spe_tmp_lval 1 in - i2 @ [CL.Instr.Op2_2.adds l_tmp l a1 a2] (* should we account for overflow in increment? *) - - | DEC ws -> - let a1,i1 = cast_atome ws (List.nth es 0) in - let a2 = I.mk_const_atome (int_of_ws ws) Z.one in - let l = I.glval_to_lval (List.nth xs 4) in - let l_tmp = I.mk_spe_tmp_lval 1 in - i1 @ [CL.Instr.Op2_2.subb l_tmp l a1 a2] (* should we account for underflow in decrement? *) - - | AND ws -> - let a1,i1 = cast_atome ws (List.nth es 0) in - let a2,i2 = cast_atome ws (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - i1 @ i2 @ [CL.Instr.Op2.and_ l a1 a2] - - | ANDN ws -> - let a1,i1 = cast_atome ws (List.nth es 0) in - let a2,i2 = cast_atome ws (List.nth es 1) in - let l_tmp = I.mk_tmp_lval (CoreIdent.tu ws) in - let at = I.mk_lval_atome l_tmp in - let l = I.glval_to_lval (List.nth xs 5) in - i1 @ i2 @ [CL.Instr.Op1.not l_tmp a1; CL.Instr.Op2.and_ l a2 at] - - | OR ws -> - let a1,i1 = cast_atome ws (List.nth es 0) in - let a2,i2 = cast_atome ws (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - i1 @ i2 @ [CL.Instr.Op2.or_ l a1 a2] - - | XOR ws -> - let a1,i1 = cast_atome ws (List.nth es 0) in - let a2,i2 = cast_atome ws (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - i1 @ i2 @ [CL.Instr.Op2.xor l a1 a2] - - | NOT ws -> - let a,i = cast_atome ws (List.nth es 0) in - let l = I.glval_to_lval (List.nth xs 5) in - i @ [CL.Instr.Op1.not l a] - - | SHL ws -> - begin - match trans with - | Smt -> - let a, i = cast_atome ws (List.nth es 0) in - let (c,_) = I.gexp_to_const(List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - i @ [CL.Instr.Shift.shl l a c] - | Cas1 -> - let a, i = cast_atome ws (List.nth es 0) in - let (c,_) = I.gexp_to_const (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - let l_tmp = I.mk_spe_tmp_lval (Z.to_int c) in - i @ [CL.Instr.Shifts.shls l_tmp l a c] - | _ -> assert false - end - - | SHR ws -> - begin - match trans with - | Smt -> - let a, i = cast_atome ws (List.nth es 0) in - let (c,_) = I.gexp_to_const(List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - i @ [CL.Instr.Shift.shr l a c] - | Cas1 -> - let a, i = cast_atome ws (List.nth es 0) in - let (c,_) = I.gexp_to_const (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - let l_tmp = I.mk_spe_tmp_lval (Z.to_int c) in - i @ [CL.Instr.Shifts.shrs l l_tmp a c] - | _ -> assert false - end - - | SAR ws -> - begin - match trans with - | Smt -> - let a,i = cast_atome ws (List.nth es 0) in - let l_tmp1 = I.mk_tmp_lval ~sign:true (CoreIdent.tu ws) in - let ty1 = CL.Sint (int_of_ws ws) in - let (c,_) = I.gexp_to_const(List.nth es 1) in - let l_tmp2 = I.mk_tmp_lval ~sign:true (CoreIdent.tu ws) in - let l_tmp3 = I.mk_tmp_lval (CoreIdent.tu ws) in - let ty2 = CL.Uint (int_of_ws ws) in - let l = I.glval_to_lval (List.nth xs 5) in - i @ [CL.Instr.cast ty1 l_tmp1 a; - CL.Instr.Shifts.ssplit l_tmp2 l_tmp3 !l_tmp1 c; - CL.Instr.cast ty2 l !l_tmp2] - | Cas1 -> - let a1,i1 = cast_atome ws (List.nth es 0) in - let c1 = I.mk_const (int_of_ws ws - 1) in - let l_tmp1 = I.mk_spe_tmp_lval 1 in - let l_tmp2 = I.mk_spe_tmp_lval (int_of_ws ws - 1) in - let c = I.get_const (List.nth es 1) in - let a2 = I.mk_const_atome c Z.zero in - let l_tmp3 = I.mk_spe_tmp_lval (c + 1) in - let a3 = I.mk_const_atome (c + 1) Z.(I.power Z.one (Z.of_int (c) + Z.one) - Z.one) in - let l_tmp4 = I.mk_spe_tmp_lval (c + 1) in - let l_tmp5 = I.mk_spe_tmp_lval (c + int_of_ws ws) in - let c2 = Z.of_int c in - let l_tmp6 = I.mk_spe_tmp_lval c in - let l = I.glval_to_lval (List.nth xs 5) in - i1 @ [CL.Instr.Shifts.spl l_tmp1 l_tmp2 a1 c1; - CL.Instr.Op2.join l_tmp3 a2 !l_tmp1; - CL.Instr.Op2.mul l_tmp4 !l_tmp3 a3; - CL.Instr.Op2.join l_tmp5 !l_tmp4 !l_tmp2; - CL.Instr.Shifts.spl l l_tmp6 !l_tmp5 c2 - ] - | Cas2 -> - let a1,i1 = cast_atome ws (List.nth es 0) in - let c1 = I.mk_const (int_of_ws ws - 1) in - let l_tmp1 = I.mk_spe_tmp_lval 1 in - let l_tmp2 = I.mk_spe_tmp_lval (int_of_ws ws - 1) in - let c = I.get_const (List.nth es 1) in - let a2 = I.mk_const_atome (c -1) Z.zero in - let l_tmp3 = I.mk_spe_tmp_lval c in - let a3 = I.mk_const_atome c (I.power Z.one Z.((of_int c) - one)) in - let l_tmp4 = I.mk_spe_tmp_lval c in - let l_tmp5 = I.mk_spe_tmp_lval c in - let c2 = Z.of_int c in - let l_tmp6 = I.mk_spe_tmp_lval (int_of_ws ws - c) in - let l = I.glval_to_lval (List.nth xs 5) in - i1 @ [CL.Instr.Shifts.spl l_tmp1 l_tmp2 a1 c1; - CL.Instr.Op2.join l_tmp3 a2 !l_tmp1; - CL.Instr.Op2.mul l_tmp4 !l_tmp3 a3; - CL.Instr.Shifts.spl l_tmp6 l_tmp5 a1 c2; - CL.Instr.Op2.join l !l_tmp4 !l_tmp6; - ] - | Cas3 -> - let a1,i1 = cast_atome ws (List.nth es 0) in - let c1 = I.mk_const (int_of_ws ws - 1) in - let l_tmp = I.mk_spe_tmp_lval (int_of_ws ws) in - let l_tmp1 = I.mk_spe_tmp_lval 1 in - let l_tmp2 = I.mk_spe_tmp_lval (int_of_ws ws - 1) in - let c = I.get_const (List.nth es 1) in - let a2 = I.mk_const_atome (c -1) Z.zero in - let l_tmp3 = I.mk_spe_tmp_lval c in - let a3 = I.mk_const_atome c (I.power Z.one Z.((of_int c) - one)) in - let l_tmp4 = I.mk_spe_tmp_lval c in - let l_tmp5 = I.mk_spe_tmp_lval c in - let c2 = Z.of_int c in - let c3 = (I.power Z.one Z.(of_int c)) in - let l_tmp6 = I.mk_spe_tmp_lval (int_of_ws ws - c) in - let l = I.glval_to_lval (List.nth xs 5) in - i1 @ [CL.Instr.Op1.mov l_tmp a1; - CL.Instr.assert_ ([Eeqmod(Ivar l_tmp, Iconst Z.zero,[Iconst c3])] ,[]); - CL.Instr.Shifts.spl l_tmp1 l_tmp2 a1 c1; - CL.Instr.Op2.join l_tmp3 a2 !l_tmp1; - CL.Instr.Op2.mul l_tmp4 !l_tmp3 a3; - CL.Instr.Shifts.spl l_tmp6 l_tmp5 a1 c2; - CL.Instr.assume ([Eeq(Ivar l_tmp5, Iconst Z.zero)] ,[]); - CL.Instr.Op2.join l !l_tmp4 !l_tmp6; - ] - end - - | MOVSX (ws1, ws2) -> - begin - match trans with - | Smt -> - let a,i = cast_atome ws2 (List.nth es 0) in - let sign = true in - let l_tmp1 = I.mk_tmp_lval ~sign (CoreIdent.tu ws2) in - let ty1 = CL.Sint (int_of_ws ws2) in - let l_tmp2 = I.mk_tmp_lval ~sign (CoreIdent.tu ws1) in - let ty2 = CL.Sint (int_of_ws ws1) in - let l = I.glval_to_lval (List.nth xs 0) in - let ty3 = CL.Uint (int_of_ws ws1) in - i @ [CL.Instr.cast ty1 l_tmp1 a; - CL.Instr.cast ty2 l_tmp2 !l_tmp1; - CL.Instr.cast ty3 l !l_tmp2] - | Cas1 -> - let a,i = cast_atome ws2 (List.nth es 0) in - let c = Z.of_int (int_of_ws ws2 - 1) in - let l_tmp1 = I.mk_spe_tmp_lval 1 in - let l_tmp2 = I.mk_spe_tmp_lval (int_of_ws ws2 - 1) in - let diff = int_of_ws ws1 - (int_of_ws ws2) in - let a2 = I.mk_const_atome (diff - 1) Z.zero in - let l_tmp3 = I.mk_spe_tmp_lval diff in - let a3 = - I.mk_const_atome diff (Z.(I.power Z.one (Z.of_int diff) - one)) - in - let l_tmp4 = I.mk_spe_tmp_lval diff in - let l = I.glval_to_lval (List.nth xs 0) in - i @ [CL.Instr.Shifts.spl l_tmp1 l_tmp2 a c; - CL.Instr.Op2.join l_tmp3 a2 !l_tmp1; - CL.Instr.Op2.mul l_tmp4 !l_tmp3 a3; - CL.Instr.Op2.join l !l_tmp4 a; - ] - | _ -> assert false - end - | MOVZX (ws1, ws2) -> - let a,i = cast_atome ws2 (List.nth es 0) in - let l = I.glval_to_lval (List.nth xs 0) in - let ty = CL.Uint (int_of_ws ws1) in - i @ [CL.Instr.cast ty l a] - - | VPADD (ve,ws) -> - begin - let a1,i1 = cast_vector_atome ws ve (List.nth es 0) in - let a2,i2 = cast_vector_atome ws ve (List.nth es 1) in - let v = int_of_velem ve in - let s = int_of_ws ws in - let l_tmp = I.mk_tmp_lval ~vector:(v,s/v) (CoreIdent.tu ws) in - let l = I.glval_to_lval (List.nth xs 0) in - let i3 = cast_atome_vector ws v !l_tmp l in - match trans with - | Smt -> - i1 @ i2 @ [CL.Instr.Op2.add l_tmp a1 a2] @ i3 - | Cas1 -> - let l_tmp1 = I.mk_tmp_lval ~vector:(v,1) (CoreIdent.tu (I.wsize_of_int v)) in - i1 @ i2 @ [CL.Instr.Op2_2.adds l_tmp1 l_tmp a1 a2] @ i3 - | _ -> assert false - end - |SETcc -> assert false - |CLC -> assert false - |STC -> assert false - |VBROADCASTI128 -> assert false - |VEXTRACTI128 -> assert false - |VINSERTI128 -> assert false - |VPERM2I128 -> assert false - |VPERMD -> assert false - |VPERMQ -> assert false - |VMOVLPD -> assert false - |VMOVHPD -> assert false - |CLFLUSH -> assert false - |LFENCE -> assert false - |MFENCE -> assert false - |SFENCE -> assert false - |AESDEC -> assert false - |VAESDEC _ -> assert false - |AESDECLAST -> assert false - |VAESDECLAST _ -> assert false - |AESENC -> assert false - |VAESENC _ -> assert false - |AESENCLAST -> assert false - |VAESENCLAST _ -> assert false - |AESIMC -> assert false - |VAESIMC -> assert false - |AESKEYGENASSIST -> assert false - |VAESKEYGENASSIST -> assert false - |PCLMULQDQ -> assert false - |CMOVcc _ -> assert false - |MUL _ -> assert false - |IMUL _ -> assert false - |DIV _ -> assert false - |IDIV _ -> assert false - |CQO _ -> assert false - |LZCNT _ -> assert false - |BT _ -> assert false - |LEA _ -> assert false - |TEST _ -> assert false - |CMP _ -> assert false - |ROR _ -> assert false - |ROL _ -> assert false - |RCR _ -> assert false - |RCL _ -> assert false - |SAL _ -> assert false - |SHLD _ -> assert false - |SHRD _ -> assert false - |MULX_lo_hi _ -> assert false - |ADCX _ -> assert false - |ADOX _ -> assert false - |BSWAP _ -> assert false - |POPCNT _ -> assert false - |PEXT _ -> assert false - |PDEP _ -> assert false - |MOVX _ -> assert false - |MOVD _ -> assert false - |VMOV _ -> assert false - |VMOVDQA _ -> assert false - |VMOVDQU ws -> - let a,i = cast_atome ws (List.nth es 0) in - let l = I.glval_to_lval (List.nth xs 0) in - i @ [CL.Instr.Op1.mov l a] - |VPMOVSX _ -> assert false - |VPMOVZX _ -> assert false - |VPAND ws -> - let a1,i1 = cast_vector_atome ws VE16 (List.nth es 0) in - let a2,i2 = cast_vector_atome ws VE16 (List.nth es 1) in - let s = int_of_ws ws in - let v = s / 16 in - let l_tmp = I.mk_tmp_lval ~vector:(v,s/v) (CoreIdent.tu ws) in - let l = I.glval_to_lval (List.nth xs 0) in - let i3 = cast_atome_vector ws v !l_tmp l in - i1 @ i2 @ [CL.Instr.Op2.and_ l_tmp a1 a2] @ i3 - |VPANDN _ -> assert false - |VPOR _ -> assert false - |VPXOR _ -> assert false - |VPSUB (ve,ws) -> - begin - let a1,i1 = cast_vector_atome ws ve (List.nth es 0) in - let a2,i2 = cast_vector_atome ws ve (List.nth es 1) in - let v = int_of_velem ve in - let s = int_of_ws ws in - let l_tmp = I.mk_tmp_lval ~vector:(v,s/v) (CoreIdent.tu ws) in - let l = I.glval_to_lval (List.nth xs 0) in - let i3 = cast_atome_vector ws v !l_tmp l in - match trans with - | Smt -> - i1 @ i2 @ [CL.Instr.Op2.sub l_tmp a1 a2] @ i3 - | Cas1 -> - let l_tmp1 = I.mk_tmp_lval ~vector:(v,1) (CoreIdent.tu (I.wsize_of_int v)) in - i1 @ i2 @ [CL.Instr.Op2_2.subb l_tmp1 l_tmp a1 a2] @ i3 - | _ -> assert false - end - |VPAVG _ -> assert false - |VPMULL (v,ws) -> - let a1,i1 = cast_vector_atome ws v (List.nth es 0) in - let a2,i2 = cast_vector_atome ws v (List.nth es 1) in - let v = int_of_velem v in - let s = int_of_ws ws in - let l_tmp = I.mk_tmp_lval ~vector:(v,s/v) (CoreIdent.tu ws) in - let l = I.glval_to_lval (List.nth xs 0) in - let i3 = cast_atome_vector ws v !l_tmp l in - let l_tmp1 = I.mk_tmp_lval ~vector:(v,s/v) (CoreIdent.tu ws) in - i1 @ i2 @ [CL.Instr.Op2_2.mull l_tmp1 l_tmp a1 a2] @ i3 - |VPMULH ws -> - let a1,i1 = cast_vector_atome ws VE16 (List.nth es 0) in - let a2,i2 = cast_vector_atome ws VE16 (List.nth es 1) in - let s = int_of_ws ws in - let v = s / 16 in - let l_tmp = I.mk_tmp_lval ~vector:(v,s/v) (CoreIdent.tu ws) in - let l = I.glval_to_lval (List.nth xs 0) in - let i3 = cast_atome_vector ws v !l_tmp l in - let l_tmp1 = I.mk_tmp_lval ~vector:(v,s/v) (CoreIdent.tu ws) in - i1 @ i2 @ [CL.Instr.Op2_2.mull l_tmp l_tmp1 a1 a2] @ i3 - |VPMULHU _ -> assert false - |VPMULHRS _ -> assert false - |VPMUL _ -> assert false - |VPMULU _ -> assert false - |VPEXTR _ -> assert false - |VPINSR _ -> assert false - (* |VPSLL (v,ws) -> *) - (* begin *) - (* match trans with *) - (* | Smt -> *) - (* let a1,i1 = cast_vector_atome ws v (List.nth es 0) in *) - (* let (c,_) = I.gexp_to_const(List.nth es 1) in *) - (* let v = int_of_velem v in *) - (* let s = int_of_ws ws in *) - (* let l_tmp = I.mk_tmp_lval ~vector:(v,s/v) (CoreIdent.tu ws) in *) - (* let l = I.glval_to_lval (List.nth xs 0) in *) - (* let i3 = cast_atome_vector ws v !l_tmp l in *) - (* i1 @ [CL.Instr.ShiftV.shl l_tmp a1 c v] @ i3 *) - (* | _ -> assert false *) - (* end *) - (* |VPSRL (v,ws) -> *) - (* begin *) - (* match trans with *) - (* | Smt -> *) - (* let a1,i1 = cast_vector_atome ws v (List.nth es 0) in *) - (* let (c,_) = I.gexp_to_const(List.nth es 1) in *) - (* let v = int_of_velem v in *) - (* let s = int_of_ws ws in *) - (* let l_tmp = I.mk_tmp_lval ~vector:(v,s/v) (CoreIdent.tu ws) in *) - (* let l = I.glval_to_lval (List.nth xs 0) in *) - (* let i3 = cast_atome_vector ws v !l_tmp l in *) - (* i1 @ [CL.Instr.ShiftV.shr l_tmp a1 c v] @ i3 *) - (* | _ -> assert false *) - (* end *) - (* |VPSRA (v,ws) -> *) - (* begin *) - (* match trans with *) - (* | Smt -> *) - (* let a1,i1 = cast_vector_atome ws v (List.nth es 0) in *) - (* let (c,_) = I.gexp_to_const(List.nth es 1) in *) - (* let v = int_of_velem v in *) - (* let s = int_of_ws ws in *) - (* let l_tmp = I.mk_tmp_lval ~vector:(v,s/v) (CoreIdent.tu ws) in *) - (* let l = I.glval_to_lval (List.nth xs 0) in *) - (* let i3 = cast_atome_vector ws v !l_tmp l in *) - (* i1 @ [CL.Instr.ShiftV.sar l_tmp a1 c v] @ i3 *) - (* | _ -> assert false *) - (* end *) - |VPSLLV _ -> assert false - |VPSRLV _ -> assert false - |VPSLLDQ _ -> assert false - |VPSRLDQ _ -> assert false - |VPSHUFB _ -> assert false - |VPSHUFD _ -> assert false - |VPSHUFHW _ -> assert false - |VPSHUFLW _ -> assert false - |VPBLEND _ -> assert false - |VPBLENDVB _ -> assert false - |VPACKUS _ -> assert false - |VPACKSS _ -> assert false - |VSHUFPS _ -> assert false - |VPBROADCAST _ -> assert false - |VMOVSHDUP _ -> assert false - |VMOVSLDUP _ -> assert false - |VPALIGNR _ -> assert false - |VPUNPCKH _ -> assert false - |VPUNPCKL _ -> assert false - |VPMOVMSKB _ -> assert false - |VPCMPEQ _ -> assert false - |VPCMPGT _ -> assert false - |VPMADDUBSW _ -> assert false - |VPMADDWD _ -> assert false - |VPMINU _ -> assert false - |VPMINS _ -> assert false - |VPMAXU _ -> assert false - |VPMAXS _ -> assert false - |VPTEST _ -> assert false - |RDTSC _ -> assert false - |RDTSCP _ -> assert false - |VPCLMULQDQ _ -> assert false - | _ -> assert false -end - -module X86BaseOpS : BaseOp - with type op = X86_instr_decl.x86_op - with type extra_op = X86_extra.x86_extra_op -= struct - - type op = X86_instr_decl.x86_op - type extra_op = X86_extra.x86_extra_op - - - module S = struct - let s = true - end - - module I = I (S) - - type trans = - | Cas1 - | Cas2 - | Cas3 - | Smt - - let trans annot = - let l = - ["smt", Smt ; "cas", Cas1; "cas_two", Cas2; "cas_three", Cas3; ] - in - let mk_trans = Annot.filter_string_list None l in - let atran annot = - match Annot.ensure_uniq1 "tran" mk_trans annot with - | None -> Cas1 - | Some aty -> aty - in - atran annot - - let cast_atome ws x = - match x with - | Pvar va -> - let ws_x = ws_of_ty (L.unloc va.gv).v_ty in - if ws = ws_x then I.gexp_to_atome x,[] - else - let e = I.gexp_to_atome x in - let v = L.unloc va.gv in - let kind = v.v_kind in - let (_,ty) as x = I.mk_tmp_lval ~kind (CoreIdent.tu ws) in - CL.Instr.Avar x, [CL.Instr.cast ty x e] - | Papp1 (Oword_of_int ws_x, Pconst z) -> - if ws = ws_x then I.gexp_to_atome x,[] - else - let e = I.gexp_to_atome x in - let (_,ty) as x = I.mk_tmp_lval (CoreIdent.tu ws) in - CL.Instr.Avar x, [CL.Instr.cast ty x e] - | _ -> assert false - - let vpc_atome ws x = - match x with - | Pvar va -> - let ws_x = ws_of_ty (L.unloc va.gv).v_ty in - if ws = ws_x then I.gexp_to_atome x,[] - else - let e = I.gexp_to_atome x in - let v = L.unloc va.gv in - let kind = v.v_kind in - let (_,ty) as x = I.mk_tmp_lval ~kind (CoreIdent.tu ws) in - CL.Instr.Avar x, [CL.Instr.vpc ty x e] - | Papp1 (Oword_of_int ws_x, Pconst z) -> - if ws = ws_x then I.gexp_to_atome x,[] - else - let e = I.gexp_to_atome x in - let (_,ty) as x = I.mk_tmp_lval (CoreIdent.tu ws) in - CL.Instr.Avar x, [CL.Instr.vpc ty x e] - | _ -> assert false - - let (!) e = I.mk_lval_atome e - - let assgn_to_instr _annot x e = - let a = I.gexp_to_atome e in - let l = I.glval_to_lval x in - [CL.Instr.Op1.mov l a] - - let op_to_instr annot xs o es = - let trans = trans annot in - match o with - | X86_instr_decl.MOV ws -> - begin match trans with - | Smt -> let a, i = vpc_atome ws (List.nth es 0) in - let l = I.glval_to_lval (List.nth xs 0) in - i @ [CL.Instr.Op1.mov l a] - | _ -> - let a,i = cast_atome ws (List.nth es 0) in - let l = I.glval_to_lval (List.nth xs 0) in - i @ [CL.Instr.Op1.mov l a] - end - | ADD ws -> - begin - let a1,i1 = cast_atome ws (List.nth es 0) in - let a2,i2 = cast_atome ws (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - match trans with - | Smt -> - i1 @ i2 @ [CL.Instr.Op2.add l a1 a2] - | Cas1 -> - let l_tmp = I.mk_spe_tmp_lval 1 in - i1 @ i2 @ [CL.Instr.Op2_2.adds l_tmp l a1 a2] - | _ -> assert false - end - - | SUB ws -> - begin - let a1, i1 = cast_atome ws (List.nth es 0) in - let a2, i2 = cast_atome ws (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - match trans with - | Smt -> - i1 @ i2 @ [CL.Instr.Op2.sub l a1 a2] - | Cas1 -> - let l_tmp = I.mk_spe_tmp_lval 1 in - i1 @ i2 @ [CL.Instr.Op2_2.subb l_tmp l a1 a2] - | _ -> assert false - end - - | IMULr ws -> - let a1, i1 = cast_atome ws (List.nth es 0) in - let a2, i2 = cast_atome ws (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - let l_tmp = I.mk_tmp_lval (CoreIdent.tu ws) in - i1 @ i2 @ [CL.Instr.Op2_2.mull l_tmp l a1 a2] - - | IMULri ws -> - begin match trans with - (* FIXME: lower part should be unsigned*) - (* | Cas1 -> *) - (* let a1, i1 = cast_atome ws (List.nth es 0) in *) - (* let a2, i2 = cast_atome ws (List.nth es 1) in *) - (* let l = I.glval_to_lval ~sign:false (List.nth xs 5) in *) - (* let l_tmp = I.mk_tmp_lval (CoreIdent.tu ws) in *) - (* i1 @ i2 @ [CL.Instr.Op2_2.mull l_tmp l a1 a2] *) - | Smt -> - let a1, i1 = cast_atome ws (List.nth es 0) in - let a2, i2 = cast_atome ws (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - i1 @ i2 @ [CL.Instr.Op2.mul l a1 a2] - | _ -> assert false - end - - | ADC _ -> assert false - | SBB _ -> assert false - - | NEG ws -> - let a = I.mk_const_atome (int_of_ws ws) Z.zero in - let a1,i1 = cast_atome ws (List.nth es 0) in - let l = I.glval_to_lval (List.nth xs 5) in - i1 @ [CL.Instr.Op2.sub l a a1] - - | INC ws -> - let a1 = I.mk_const_atome (int_of_ws ws) Z.one in - let a2,i2 = cast_atome ws (List.nth es 0) in - let l = I.glval_to_lval (List.nth xs 4) in - let l_tmp = I.mk_spe_tmp_lval 1 in - i2 @ [CL.Instr.Op2_2.adds l_tmp l a1 a2] - - | DEC ws -> - let a1,i1 = cast_atome ws (List.nth es 0) in - let a2 = I.mk_const_atome (int_of_ws ws) Z.one in - let l = I.glval_to_lval (List.nth xs 4) in - let l_tmp = I.mk_spe_tmp_lval 1 in - i1 @ [CL.Instr.Op2_2.subb l_tmp l a1 a2] - - | AND _ -> assert false - | ANDN _ -> assert false - | OR _ -> assert false - | XOR _ -> assert false - | NOT _ -> assert false - - - | SHL ws -> - begin - match trans with - | Smt -> - let a, i = cast_atome ws (List.nth es 0) in - let (c,_) = I.gexp_to_const (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - i @ [CL.Instr.Shift.shl l a c] - | Cas1 -> - let a, i = cast_atome ws (List.nth es 0) in - let (c,_) = I.gexp_to_const (List.nth es 1) in - let l = I.glval_to_lval (List.nth xs 5) in - let l_tmp = I.mk_spe_tmp_lval (Z.to_int c) in - i @ [CL.Instr.Shifts.shls l_tmp l a c] - (* maybe do a multiplication *) - - | _ -> assert false - end - - | SHR _ -> assert false - (* TODO: check semantics in CL paper and actually implement this *) - (* | SHR ws -> *) - (* begin *) - (* match trans with *) - (* | Smt -> *) - (* let a, i = cast_atome ws (List.nth es 0) in *) - (* let (c,_) = I.gexp_to_const(List.nth es 1) in *) - (* let l = I.glval_to_lval (List.nth xs 5) in *) - (* i @ [CL.Instr.Shift.shr l a c] *) - (* | Cas1 -> *) - (* let a, i = cast_atome ws (List.nth es 0) in *) - (* let (c,_) = I.gexp_to_const (List.nth es 1) in *) - (* let l = I.glval_to_lval (List.nth xs 5) in *) - (* let l_tmp = I.mk_spe_tmp_lval (Z.to_int c) in *) - (* i @ [CL.Instr.Shifts.shrs l l_tmp a c] *) - (* | _ -> assert false *) - (* end *) - - | SAR ws -> - begin - match trans with - | Cas1 -> - let a1,i1 = cast_atome ws (List.nth es 0) in - let c = I.get_const (List.nth es 1) in - let l_tmp = I.mk_spe_tmp_lval (int_of_ws ws) in - let c = Z.of_int c in - let l = I.glval_to_lval (List.nth xs 5) in - i1 @ [CL.Instr.Shifts.split l l_tmp a1 c] - | Cas2 -> - let a1,i1 = cast_atome ws (List.nth es 0) in - let c = I.get_const (List.nth es 1) in - let c1 = Z.(I.power one (of_int c)) in - let l_tmp = I.mk_spe_tmp_lval (int_of_ws ws) in - let l_tmp1 = I.mk_spe_tmp_lval ~sign:false (int_of_ws ws) in - let c = Z.of_int c in - let l = I.glval_to_lval (List.nth xs 5) in - i1 @ [CL.Instr.Op1.mov l_tmp a1; - CL.Instr.assert_ ([Eeqmod(Ivar l_tmp, Iconst Z.zero,[Iconst c1])] ,[]); - CL.Instr.Shifts.split l l_tmp1 !l_tmp c; - CL.Instr.assume ([Eeq(Ivar l_tmp1, Iconst Z.zero)] ,[]); - ] - | _ -> assert false - end - - | MOVSX (ws1, ws2) -> - begin - match trans with - | Cas1 -> - let a,i = cast_atome ws2 (List.nth es 0) in - let l = I.glval_to_lval (List.nth xs 0) in - i @ [CL.Instr.cast (CL.Sint (int_of_ws ws1)) l a] - | Smt -> - let a, i = vpc_atome ws2 (List.nth es 0) in - let l = I.glval_to_lval (List.nth xs 0) in - i @ [CL.Instr.vpc (CL.Sint (int_of_ws ws1)) l a] - | _ -> assert false - end - | MOVZX _ -> assert false - | CMOVcc _ -> assert false - | XCHG _ -> assert false - | MUL _ -> assert false - | IMUL _ -> assert false - | DIV _ -> assert false - | IDIV _ -> assert false - | CQO _ -> assert false - | MOVX _ -> assert false - | MOVD _ -> assert false - | MOVV _ -> assert false - | ROR _ -> assert false - | ROL _ -> assert false - | RCR _ -> assert false - | RCL _ -> assert false - | SAL _ -> assert false - | SHLD _ -> assert false - | SHRD _ -> assert false - | RORX _ -> assert false - | SARX _ -> assert false - | SHRX _ -> assert false - | SHLX _ -> assert false - | MULX_lo_hi _ -> assert false - | ADCX _ -> assert false - | ADOX _ -> assert false - | BSWAP _ -> assert false - | POPCNT _ -> assert false - | PEXT _ -> assert false - | PDEP _ -> assert false - - | _ -> assert false -end - -let x86BaseOpsign s : - (module BaseOp with type op = X86_instr_decl.x86_op - and type extra_op = X86_extra.x86_extra_op - ) - = - if s then (module X86BaseOpS) - else (module X86BaseOpU) - -module ARMBaseOp : BaseOp - with type op = Arm_instr_decl.arm_op - and type extra_op = Arm_extra.arm_extra_op -= struct - - open Arm_instr_decl - - type op = Arm_instr_decl.arm_op - type extra_op = Arm_extra.arm_extra_op - - module S = struct - let s = false - end - - module I = I (S) - - let ws = Wsize.U32 - - let assgn_to_instr trans x e = assert false - - let op_to_instr trans xs o es = - let mn, opt = match o with Arm_instr_decl.ARM_op (mn, opt) -> mn, opt in - match mn with - | ADD -> assert false -(* - let v1 = pp_cast fmt (List.nth es 0, ws) in - let v2 = pp_cast fmt (List.nth es 1, ws) in - let v2' = pp_shifted fmt opt v2 es in - Format.fprintf fmt "add %a %a %a" - pp_lval (List.nth xs 5, int_of_ws ws) - pp_atome (v1, int_of_ws ws) - pp_atome (v2', int_of_ws ws) -*) - - | ADC - | MUL - | MLA - | MLS - | SDIV - | SUB - | RSB - | UDIV - | UMULL - | UMAAL - | UMLAL - | SMULL - | SMLAL - | SMMUL - | SMMULR - | SMUL_hw _ - | SMLA_hw _ - | SMULW_hw _ - | AND - | BFC - | BFI - | BIC - | EOR - | MVN - | ORR - | ASR - | LSL - | LSR - | ROR - | REV - | REV16 - | REVSH - | ADR - | MOV - | MOVT - | UBFX - | UXTB - | UXTH - | SBFX - | CLZ - | CMP - | TST - | CMN - | LDR - | LDRB - | LDRH - | LDRSB - | LDRSH - | STR - | STRB - | STRH -> assert false - -end - -let armeBaseOpsign _s : - (module BaseOp with type op = Arm_instr_decl.arm_op - and type extra_op = Arm_extra.arm_extra_op - ) - = - (module ARMBaseOp) - -let sub_fun_return r = - let aux f = List.map (fun (prover,clause) -> prover, f clause) in - let aux1 i v = - match snd (List.findi (fun ii _ -> ii = i) r) with - | Lvar v -> {gv = v; gs = Expr.Slocal} - | _ -> assert false - in - aux (Subst.subst_result aux1) - -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 fst (List.findi (fun _ vi -> check v vi) args) with - | i -> snd (List.findi (fun ii _ -> ii = i) params) - | exception _ -> Pvar v - in - aux (Subst.gsubst_e (fun ?loc:_ x -> x) aux1) - -module Mk(O:BaseOp) = struct - - let pp_ext_op xs o es trans = - match o with - | Arch_extra.BaseOp (_, o) -> O.op_to_instr trans xs o es - | Arch_extra.ExtOp o -> assert false - - let pp_sopn xs o es tcas = - match o with - | Sopn.Opseudo_op _ -> assert false - | Sopn.Oslh _ -> assert false - | Sopn.Oasm o -> pp_ext_op xs o es tcas - - let rec filter_clause cs (cas,smt) = - match cs with - | [] -> cas,smt - | (Expr.Cas,c)::q -> filter_clause q (c::cas,smt) - | (Expr.Smt,c)::q -> filter_clause q (cas,c::smt) - - let to_smt smt = - List.fold_left (fun acc a -> O.I.gexp_to_rpred a :: acc) [] smt - - let to_cas env cas = - List.fold_left (fun acc a -> O.I.gexp_to_epred env a @ acc) [] cas - - let to_clause env clause : CL.clause = - let cas,smt = filter_clause clause ([],[]) in - let smt = to_smt smt in - let cas = to_cas env cas in - (cas,smt) - - let pp_i env fds i = - let trans = i.i_annot in - match i.i_desc with - | Cassert (t, p, e) -> - let cl = to_clause env [(p,e)] in - begin - match t with - | Expr.Assert -> [], [CL.Instr.assert_ cl] - | Expr.Assume -> [], [CL.Instr.assume cl] - | Expr.Cut -> assert false - end - | Csyscall _ | Cif _ | Cfor _ | Cwhile _ -> assert false - | Ccall (r,f,params) -> - let fd = List.find (fun fd -> fd.f_name.fn_id = f.fn_id) fds in - let pre = sub_fun_param fd.f_args params fd.f_contra.f_pre in - let post = sub_fun_param fd.f_args params fd.f_contra.f_post in - let post = sub_fun_return r post in - let pre_cl = to_clause env pre in - let post_cl = to_clause env post in - r , [CL.Instr.assert_ pre_cl] @ [CL.Instr.assume post_cl] - - | Cassgn (a, _, _, e) -> - begin - match a with - | Lvar x -> [], O.assgn_to_instr trans a e - | Lnone _ | Lmem _ | Laset _ |Lasub _ -> assert false - end - | Copn(xs, _, o, es) -> [], pp_sopn xs o es trans - - let pp_c env fds c = - List.fold_left (fun (acc1,acc2) a -> - let l1,l2 = pp_i env fds a in - acc1 @ l1, acc2 @ l2 - ) ([],[]) c - - let filter_add cond l1 l2 = - List.fold_left ( - fun l a -> - if List.exists (cond a) l - then l else a :: l - ) l1 l2 - - type vector = - | U16x16 - - let unfold_vector formals = - let aux ((formal,ty) as v) = - let mk_vector = Annot.filter_string_list None ["u16x16", U16x16] in - match Annot.ensure_uniq1 "vect" mk_vector (formal.v_annot) with - | None -> [v],[] - | Some U16x16 -> - let rec aux i acc = - match i with - | 0 -> acc - | n -> - let name = String.concat "_" [formal.v_name; "v" ; string_of_int i] in - let v = O.I.mk_tmp_lval ~name u16 in - aux ( n - 1) (v :: acc) - in - let v = aux 16 [] in - let va = List.map (fun v -> CL.Instr.Avar v) v in - let a = CL.Instr.Avatome va in - let l = O.I.var_to_tyvar ~vector:(16,16) formal in - v,[CL.Instr.Op1.mov l a] - in - List.fold_left (fun (acc1,acc2) v -> - let fs,is = aux v in - fs @ acc1,is @ acc2) - ([],[]) formals - - let fun_to_proc fds fd = - let env = Hash.create 10 in - let ret = List.map L.unloc fd.f_ret in - let cond a x = (x.v_name = a.v_name) && (x.v_id = a.v_id) in - let args = filter_add cond fd.f_args ret in - let formals = List.map O.I.var_to_tyvar args in - let pre = to_clause env fd.f_contra.f_pre in - let post = to_clause env fd.f_contra.f_post in - let lval,prog = pp_c env fds fd.f_body in - let formals_lval = List.map O.I.glval_to_lval lval in - let cond (a,_) (x,_) = (x.v_name = a.v_name) && (x.v_id = a.v_id) in - let formals = filter_add cond formals formals_lval in - let ghost = ref [] in - Hash.iter (fun _ x -> ghost := x :: ! ghost) env; - let formals = filter_add cond formals !ghost in - - (* let cfg = Cfg.cfg_of_prog_rev prog in - let clean_cfg = SimplVector.simpl_cfg cfg in - let prog = Cfg.prog_of_cfg clean_cfg in *) - - CL.Proc.{id = fd.f_name.fn_name; - formals; - pre; - prog; - post} -end diff --git a/compiler/src/toCL.mli b/compiler/src/toCL.mli deleted file mode 100644 index d96c04c3a..000000000 --- a/compiler/src/toCL.mli +++ /dev/null @@ -1,54 +0,0 @@ -open Prog -open Wsize -open Sopn - -module CL : sig - module Instr : - sig - type instr - val pp_instr : Format.formatter -> instr -> unit - val pp_instrs : Format.formatter -> instr list -> unit - end - module Proc : - sig - type proc - val pp_proc : Format.formatter -> proc -> unit - end -end - -module type I - -module type BaseOp = sig - type op - type extra_op - - module I: I - - val op_to_instr : - Annotations.annotations -> - int Prog.glval list -> - op -> int Prog.gexpr list -> CL.Instr.instr list - - val assgn_to_instr : - Annotations.annotations -> - int Prog.glval -> int Prog.gexpr -> CL.Instr.instr list -end - -val x86BaseOpsign : - bool -> - (module BaseOp with type op = X86_instr_decl.x86_op - and type extra_op = X86_extra.x86_extra_op - ) - -val armeBaseOpsign : - bool -> - (module BaseOp with type op = Arm_instr_decl.arm_op - and type extra_op = Arm_extra.arm_extra_op - ) - -module Mk(O:BaseOp) : sig - val fun_to_proc : - (int, 'f, ('a, 'b, 'c, 'd, 'e, O.op, O.extra_op) Arch_extra.extended_op) gfunc list -> - (int, 'f, ('a, 'b, 'c, 'd, 'e, O.op, O.extra_op) Arch_extra.extended_op) gfunc -> - CL.Proc.proc -end diff --git a/proofs/_CoqProject b/proofs/_CoqProject index 14aa8a027..c423e1aff 100644 --- a/proofs/_CoqProject +++ b/proofs/_CoqProject @@ -54,7 +54,6 @@ compiler/array_expansion.v compiler/array_expansion_proof.v compiler/array_copy.v compiler/array_copy_proof.v -compiler/array_copy_cl.v compiler/array_init.v compiler/array_init_proof.v compiler/byteset.v diff --git a/proofs/compiler/array_copy_cl.v b/proofs/compiler/array_copy_cl.v deleted file mode 100644 index 51b3fb5fd..000000000 --- a/proofs/compiler/array_copy_cl.v +++ /dev/null @@ -1,154 +0,0 @@ -From mathcomp Require Import all_ssreflect. -Require Import expr compiler_util. -Import Utf8. - -Set Implicit Arguments. -Unset Strict Implicit. -Unset Printing Implicit Defensive. - -(* -semantics: Ccopy x ws n y - -x & y have type array(ws * n) -all y[i] is init (ok u) - -*) - -Module Import E. - Definition pass : string := "array copy cl". - - Definition error := pp_internal_error_s pass "fresh variables are not fresh ...". - -End E. - -Section Section. - -Context `{asmop:asmOp}. -Context (fresh_counter: Ident.ident). - -(* - x = ArrayInit(); - for i = 0 to n { - x[i] = y[i]; - } -*) - -Definition add e ei := - match e with - | Some e => Papp2 (Oadd Op_int) e ei - | None => ei - end. - -Definition array_copy ii (x: var_i * option pexpr) (ws: wsize) (n: positive) (y: gvar * option pexpr) := - let '(x,ex) := x in - let '(y,ey) := y in - let i_name := fresh_counter in - let i := {| v_var := {| vtype := sint ; vname := i_name |}; v_info := v_info x |} in - let ei := Pvar (mk_lvar i) in - let xei := add ex ei in - let yei := add ey ei in - let sz := Z.to_pos (wsize_size ws * n) in - let pre := - if eq_gvar (mk_lvar x) y then Copn [::] AT_none sopn_nop [::] - else Cassgn (Lvar x) AT_none (sarr sz) (Parr_init sz) in - [:: MkI ii pre; - MkI ii - (Cfor i (UpTo, Pconst 0, Pconst n) - [:: MkI ii (Cassgn (Laset Aligned AAscale ws x xei) AT_none (sword ws) (Pget Aligned AAscale ws y yei))]) - ]. - -Definition array_copy_c (array_copy_i : instr -> cexec cmd) (c:cmd) : cexec cmd := - Let cs := mapM array_copy_i c in - ok (flatten cs). - -Definition is_copy o := - match o with - | Opseudo_op (pseudo_operator.Ocopy ws p) => Some (ws, p) - | _ => None - end. - -Definition is_Pvar es := - match es with - | [:: Pvar x] => Some (x, None) - | [:: Psub AAscale ws n x e] => Some(x, Some(ws, n, e)) - | _ => None - end. - -Definition is_Lvar xs := - match xs with - | [:: Lvar x] => Some (x, None) - | [:: Lasub AAscale ws n x e] => Some (x, Some (ws, n, e)) - | _ => None - end. - -Definition check_x (A:Type) ii ws (xe: A * option (wsize * positive * pexpr)) := - match xe with - | (x, None) => - ok (x, None) - | (x, Some (ws', n', e)) => - Let _ := assert (ws' == ws) - (pp_internal_error_s_at E.pass ii "bad type for copy") in - ok (x, Some e) - end. - -Fixpoint array_copy_i (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 => - Let x := check_x ii ws x in - Let y := check_x ii ws y 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 [:: 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 - ok [:: MkI ii (Cif e c1 c2)] - | Cfor i r c => - Let c := array_copy_c 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 - ok [:: MkI ii (Cwhile a c1 e c2)] - | Ccall _ _ _ => ok [:: i] - end. - -Context {pT:progT}. - -Definition array_copy_fd (f:fundef) := - let 'MkFun fi ci tyin params c tyout res ev := f in - Let c := array_copy_c 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 _ := - assert (~~ Sv.mem {| vtype := sint ; vname := fresh_counter |} V) E.error - in - Let fds := map_cfprog array_copy_fd (p_funcs p) in - ok {| p_funcs := fds; - p_globs := p_globs p; - p_extra := p_extra p|}. - -End Section. - - - diff --git a/proofs/compiler/compiler.v b/proofs/compiler/compiler.v index 4cbcf6df5..8b7345455 100644 --- a/proofs/compiler/compiler.v +++ b/proofs/compiler/compiler.v @@ -462,65 +462,4 @@ 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 - - Let p := inlining to_keep p in - - Let p := unroll_loop (ap_is_move_op aparams) true p in - let p := cparams.(print_uprog) Unrolling p in - - live_range_splitting p. - -Definition compiler_CL_second_part (to_keep: seq funname) (p: prog) : cexec uprog := - - Let p := array_copy_cl.array_copy_prog - (fresh_var_ident cparams Inline dummy_instr_info 0 "i__copy" sint) - p in - - let p := cparams.(print_uprog) ArrayCopy p in - - Let p := unroll_loop (ap_is_move_op aparams) true p in - let p := cparams.(print_uprog) Unrolling p in - - Let pv := live_range_splitting p in - - let pr := remove_init_prog is_reg_array pv in - let pr := cparams.(print_uprog) RemoveArrInit pr in - - Let pe := expand_prog cparams.(expand_fd) [::] pr in - let pe := cparams.(print_uprog) RegArrayExpansion pe in - - Let pe := live_range_splitting pe in - - Let pg := remove_glob_prog cparams.(fresh_id) pe in - let pg := cparams.(print_uprog) RemoveGlobal pg in - - Let pa := makereference_prog (fresh_var_ident cparams (Reg (Normal, Pointer Writable))) pg in - let pa := cparams.(print_uprog) MakeRefArguments pa in - - Let _ := - assert - (lop_fvars_correct loparams (fresh_var_ident cparams (Reg (Normal, Direct)) dummy_instr_info 0) (p_funcs pa)) - (pp_internal_error_s "lowering" "lowering check fails") - in - - let pl := - lower_prog - (lop_lower_i loparams) - (lowering_opt cparams) - (warning cparams) - (fresh_var_ident cparams (Reg (Normal, Direct)) dummy_instr_info 0) - pa - in - let pl := cparams.(print_uprog) LowerInstruction pl in - - Let pp := propagate_inline.pi_prog pl in - let pp := cparams.(print_uprog) PropagateInline pp in - - ok pp. - - End COMPILER. From 89a5174080454e054cb6595ab2c779153b44a193 Mon Sep 17 00:00:00 2001 From: Pierre Roux Date: Mon, 12 Aug 2024 23:30:18 +0200 Subject: [PATCH 25/51] Adapt to https://github.com/coq/coq/pull/18449 This compiles with Coq master and should be backward compatible. --- proofs/compiler/byteset.v | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/proofs/compiler/byteset.v b/proofs/compiler/byteset.v index 3e233607f..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. From 5f68a9a08e2d5dd5cba66e2f3d37affec80a2a72 Mon Sep 17 00:00:00 2001 From: Santiago Arranz Olmos Date: Wed, 14 Aug 2024 15:59:40 +0200 Subject: [PATCH 26/51] Add SCT to CHECKCATS, fix error message typo --- compiler/Makefile | 2 +- compiler/src/typing.ml | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/Makefile b/compiler/Makefile index 0640ff62e..57f18d5c2 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-DOIT \ + CCT CCT-DOIT SCT \ x86-64-ATT \ x86-64-Intel \ x86-64-print \ diff --git a/compiler/src/typing.ml b/compiler/src/typing.ml index d5e432087..72ece3024 100644 --- a/compiler/src/typing.ml +++ b/compiler/src/typing.ml @@ -118,7 +118,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 = @@ -161,7 +161,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 (* -------------------------------------------------------------------- *) From b44e6519cf231661758b20ffb4a881a9f5f51158 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Cassiers?= Date: Wed, 10 Jul 2024 17:51:13 +0200 Subject: [PATCH 27/51] Add .editorconfig file for OCaml files formatting --- .editorconfig | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 .editorconfig diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 000000000..c3365d214 --- /dev/null +++ b/.editorconfig @@ -0,0 +1,10 @@ +root=true + +[*] +end_of_line = lf +insert_final_newline = true +charset = utf8 + +[*.{ml,mli}] +indent_style = space +indent_size = 2 From e18d9f14050eb986afc7ad55e135a75382f50165 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Wed, 21 Aug 2024 07:20:31 +0200 Subject: [PATCH 28/51] Add support for slices in array #copy --- CHANGELOG.md | 4 + compiler/src/insert_copy_and_fix_length.ml | 17 +- .../fail/x86-64/unaligned_slice_copy.jazz | 10 + compiler/tests/success/common/arraycopy.jazz | 33 ++ compiler/tests/success/common/bug_842.jazz | 23 ++ proofs/compiler/array_copy.v | 89 +++--- proofs/compiler/array_copy_proof.v | 299 +++++++++++++----- proofs/compiler/compiler.v | 6 +- 8 files changed, 348 insertions(+), 133 deletions(-) create mode 100644 compiler/tests/fail/x86-64/unaligned_slice_copy.jazz create mode 100644 compiler/tests/success/common/bug_842.jazz diff --git a/CHANGELOG.md b/CHANGELOG.md index aa848d247..b6a6bc29e 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,10 @@ ([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)). + ## Other changes - The deprecated legacy interface to the LATEX pretty-printer has been removed diff --git a/compiler/src/insert_copy_and_fix_length.ml b/compiler/src/insert_copy_and_fix_length.ml index 682b80a65..4b09eaafc 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/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/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/proofs/compiler/array_copy.v b/proofs/compiler/array_copy.v index 9b1b97f93..eab62fc32 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,71 +84,80 @@ 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] | 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 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 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 2396a4e96..1f8869628 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/compiler.v b/proofs/compiler/compiler.v index 481ea619e..d8fe5d5c5 100644 --- a/proofs/compiler/compiler.v +++ b/proofs/compiler/compiler.v @@ -243,11 +243,7 @@ Definition inlining (to_keep: seq funname) (p: uprog) : cexec uprog := Definition compiler_first_part (to_keep: seq funname) (p: prog) : cexec uprog := - Let p := - 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_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 From a029e7f593343e8219cf358083e6134f7055d625 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Wed, 28 Aug 2024 14:36:09 +0200 Subject: [PATCH 29/51] CI: fix libjade jobs --- .gitlab-ci.yml | 4 ++-- scripts/test-libjade.sh | 10 +++++++--- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/.gitlab-ci.yml b/.gitlab-ci.yml index 5bd6f41db..088ff639d 100644 --- a/.gitlab-ci.yml +++ b/.gitlab-ci.yml @@ -205,7 +205,7 @@ libjade-compile-to-asm: artifacts: when: always paths: - - libjade-main/src/check.tar.gz + - libjade/src/check.tar.gz libjade-extract-to-ec: stage: test @@ -224,7 +224,7 @@ libjade-extract-to-ec: artifacts: when: always paths: - - libjade-main/proof/check.tar.gz + - libjade/proof/check.tar.gz test-extract-to-ec: stage: test 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 From 1bdb63aa5f6aac322a79b2f1365988a4f5174dd4 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Thu, 29 Aug 2024 10:20:48 +0200 Subject: [PATCH 30/51] eclib: remove redundant dependencies in JModel_x86 --- eclib/JModel_x86.ec | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) 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. From 57940c4d512631d3c0df4a136d0ddfc40ece70be Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 3 Sep 2024 16:03:43 +0200 Subject: [PATCH 31/51] S-CT checker: accept copies of outdated MSF --- CHANGELOG.md | 3 ++ compiler/src/sct_checker_forward.ml | 51 +++++++++++-------- compiler/tests/sct-checker/accept.expected | 13 +++++ compiler/tests/sct-checker/fail/basic.jazz | 4 +- compiler/tests/sct-checker/fail/movmsf.jazz | 31 +++++++++++ compiler/tests/sct-checker/reject.expected | 9 ++++ .../tests/sct-checker/success/movmsf.jazz | 18 +++++++ 7 files changed, 107 insertions(+), 22 deletions(-) create mode 100644 compiler/tests/sct-checker/fail/movmsf.jazz create mode 100644 compiler/tests/sct-checker/success/movmsf.jazz diff --git a/CHANGELOG.md b/CHANGELOG.md index b6a6bc29e..65f4d00ab 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -16,6 +16,9 @@ - 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)). + # Jasmin 2024.07.0 — Sophia-Antipolis, 2024-07-09 ## New features diff --git a/compiler/src/sct_checker_forward.ml b/compiler/src/sct_checker_forward.ml index 73caa3244..b007b21a7 100644 --- a/compiler/src/sct_checker_forward.ml +++ b/compiler/src/sct_checker_forward.ml @@ -793,7 +793,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 @@ -814,9 +816,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 @@ -834,7 +841,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' -> @@ -842,25 +855,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 @@ -1000,6 +1008,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' *) @@ -1013,10 +1028,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 @@ -1042,9 +1055,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 diff --git a/compiler/tests/sct-checker/accept.expected b/compiler/tests/sct-checker/accept.expected index 4630223fa..8efb36d8e 100644 --- a/compiler/tests/sct-checker/accept.expected +++ b/compiler/tests/sct-checker/accept.expected @@ -198,6 +198,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/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/reject.expected b/compiler/tests/sct-checker/reject.expected index a81dee86a..a807f211f 100644 --- a/compiler/tests/sct-checker/reject.expected +++ b/compiler/tests/sct-checker/reject.expected @@ -51,6 +51,15 @@ 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 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; + } +} From 69c49c2aac49cbb6d1719f0a8335853052c7b84f Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Wed, 4 Sep 2024 10:12:14 +0200 Subject: [PATCH 32/51] SCT: fix checking of while loops --- CHANGELOG.md | 4 ++++ compiler/src/sct_checker_forward.ml | 4 ++-- compiler/tests/sct-checker/accept.expected | 13 +++++++++++ compiler/tests/sct-checker/fail/bug_887.jazz | 14 +++++++++++ compiler/tests/sct-checker/reject.expected | 3 +++ .../tests/sct-checker/success/bug_887.jazz | 23 +++++++++++++++++++ 6 files changed, 59 insertions(+), 2 deletions(-) create mode 100644 compiler/tests/sct-checker/fail/bug_887.jazz create mode 100644 compiler/tests/sct-checker/success/bug_887.jazz diff --git a/CHANGELOG.md b/CHANGELOG.md index 65f4d00ab..1fcd532b1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -11,6 +11,10 @@ ([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)). + ## Other changes - The deprecated legacy interface to the LATEX pretty-printer has been removed diff --git a/compiler/src/sct_checker_forward.ml b/compiler/src/sct_checker_forward.ml index b007b21a7..6347ee4e3 100644 --- a/compiler/src/sct_checker_forward.ml +++ b/compiler/src/sct_checker_forward.ml @@ -1127,9 +1127,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 diff --git a/compiler/tests/sct-checker/accept.expected b/compiler/tests/sct-checker/accept.expected index 8efb36d8e..2316b7cd8 100644 --- a/compiler/tests/sct-checker/accept.expected +++ b/compiler/tests/sct-checker/accept.expected @@ -148,6 +148,19 @@ 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] * 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/reject.expected b/compiler/tests/sct-checker/reject.expected index a807f211f..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] 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; +} From e473b8426aeed08addf30d02d9ba8151cb6f1741 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Wed, 4 Sep 2024 15:55:44 +0200 Subject: [PATCH 33/51] Rename Uptr pointer_op instance as PointerW For consistency with the name of the PointerZ instance. To avoid unfortunate name clash with the constructor of the `reference` data type. --- proofs/lang/memory_model.v | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/proofs/lang/memory_model.v b/proofs/lang/memory_model.v index 4915c2f1b..59dc70c03 100644 --- a/proofs/lang/memory_model.v +++ b/proofs/lang/memory_model.v @@ -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 → From 8d6d11c81feef5e81546579cc8cec36e6f7ba9fd Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Wed, 4 Sep 2024 16:25:00 +0200 Subject: [PATCH 34/51] Parser: factor two rules into one --- compiler/src/parser.mly | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/compiler/src/parser.mly b/compiler/src/parser.mly index 20f2c24f1..ac77714cf 100644 --- a/compiler/src/parser.mly +++ b/compiler/src/parser.mly @@ -364,11 +364,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 } From d880640940b828f2a8f51d006b02f2bb204a8b90 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Wed, 4 Sep 2024 16:28:04 +0200 Subject: [PATCH 35/51] Add examples for constructors of the pinstr_r type --- compiler/src/syntax.ml | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/compiler/src/syntax.ml b/compiler/src/syntax.ml index 9f5f9dbb0..5fd78d211 100644 --- a/compiler/src/syntax.ml +++ b/compiler/src/syntax.ml @@ -212,11 +212,17 @@ type vardecls = pstotype * pident list type pinstr_r = | PIArrayInit of pident + (** ArrayInit(x); *) | PIAssign of plvals * peqop * pexpr * pexpr option + (** x, y += z >> 4 if c; *) | 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 ] From b08ca13618f0e4a69a53deb5304e93e525c9b3c7 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Thu, 5 Sep 2024 10:48:07 +0200 Subject: [PATCH 36/51] editorconfig: fix spelling of utf-8 charset --- .editorconfig | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.editorconfig b/.editorconfig index c3365d214..ec2b9457c 100644 --- a/.editorconfig +++ b/.editorconfig @@ -3,7 +3,7 @@ root=true [*] end_of_line = lf insert_final_newline = true -charset = utf8 +charset = utf-8 [*.{ml,mli}] indent_style = space From faf9b1d772d1b3006cd2ff3e919b08d1d91c4eb8 Mon Sep 17 00:00:00 2001 From: MrDaiki <38009151+MrDaiki@users.noreply.github.com> Date: Fri, 6 Sep 2024 11:21:24 +0200 Subject: [PATCH 37/51] lexer: preserve formatting of integer literal (#886) --- AUTHORS | 1 + CHANGELOG.md | 4 ++++ compiler/src/latex_printer.ml | 2 +- compiler/src/lexer.mll | 4 ++-- compiler/src/parser.mly | 6 +++--- compiler/src/pretyping.ml | 5 +++-- compiler/src/syntax.ml | 8 ++++++-- 7 files changed, 20 insertions(+), 10 deletions(-) diff --git a/AUTHORS b/AUTHORS index fdd06bd0b..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 diff --git a/CHANGELOG.md b/CHANGELOG.md index 1fcd532b1..7e09378f5 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -22,6 +22,10 @@ - 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)). + # Jasmin 2024.07.0 — Sophia-Antipolis, 2024-07-09 diff --git a/compiler/src/latex_printer.ml b/compiler/src/latex_printer.ml index b3ef2d5c2..42f0577b8 100644 --- a/compiler/src/latex_printer.ml +++ b/compiler/src/latex_printer.ml @@ -157,7 +157,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 fc68114f9..3ce849dfa 100644 --- a/compiler/src/lexer.mll +++ b/compiler/src/lexer.mll @@ -135,10 +135,10 @@ rule main = parse (* Why this is needed *) | ((*'-'?*) digit+) as s - { INT (Z.of_string s) } + {INT s} | ('0' ['x' 'X'] hexdigit+) as s - { INT (Z.of_string s) } + {INT s} | ident as s { Option.default (NID s) (Hash.find_option keywords s) } diff --git a/compiler/src/parser.mly b/compiler/src/parser.mly index ac77714cf..8906c629d 100644 --- a/compiler/src/parser.mly +++ b/compiler/src/parser.mly @@ -82,7 +82,7 @@ %token EXPORT %token ARRAYINIT %token NID -%token INT +%token INT %token STRING %nonassoc COLON QUESTIONMARK %left PIPEPIPE @@ -127,8 +127,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 } diff --git a/compiler/src/pretyping.ml b/compiler/src/pretyping.ml index 18a247efa..b4ac7894c 100644 --- a/compiler/src/pretyping.ml +++ b/compiler/src/pretyping.ml @@ -1045,7 +1045,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 -> let x, ty = tt_var_global mode env x in @@ -2144,6 +2144,7 @@ let tt_global pd (env : 'asm Env.env) _loc (gd: S.pglobal) : 'asm Env.env = Env.Vars.push_global env (x,d) + (* -------------------------------------------------------------------- *) let rec tt_item arch_info (env : 'asm Env.env) pt : 'asm Env.env = match L.unloc pt with @@ -2151,7 +2152,7 @@ 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.PNamespace (ns, items) -> diff --git a/compiler/src/syntax.ml b/compiler/src/syntax.ml index 5fd78d211..ee509f085 100644 --- a/compiler/src/syntax.ml +++ b/compiler/src/syntax.ml @@ -23,6 +23,9 @@ 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 = Z.of_string + let bits_of_wsize : wsize -> int = Annotations.int_of_ws let suffix_of_sign : sign -> string = @@ -153,7 +156,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 @@ -269,7 +272,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; } (* -------------------------------------------------------------------- *) @@ -286,3 +289,4 @@ type pitem = (* -------------------------------------------------------------------- *) type pprogram = pitem L.located list + From 5efc8aa99e412996e73cf285be3ee8a751dd207f Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Fri, 6 Sep 2024 14:37:48 +0200 Subject: [PATCH 38/51] pretyping: minor cleaning --- compiler/src/pretyping.ml | 11 ++++------- 1 file changed, 4 insertions(+), 7 deletions(-) diff --git a/compiler/src/pretyping.ml b/compiler/src/pretyping.ml index b4ac7894c..dab1fb219 100644 --- a/compiler/src/pretyping.ml +++ b/compiler/src/pretyping.ml @@ -1201,10 +1201,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 @@ -1891,8 +1887,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 @@ -2152,7 +2146,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 (List.map (fun (x,y) -> S.parse_int x,S.parse_int y) 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.PNamespace (ns, items) -> From 1d4692bbc18ac3e038e146d0c23199a6fea859ad Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Fri, 6 Sep 2024 14:49:38 +0200 Subject: [PATCH 39/51] pretyping: remove tt_ws (an identity function) --- compiler/src/checkAnnot.ml | 1 - compiler/src/compile.ml | 4 +--- compiler/src/pretyping.ml | 16 +++++----------- compiler/src/pretyping.mli | 1 - compiler/src/stackAlloc.ml | 3 +-- 5 files changed, 7 insertions(+), 18 deletions(-) diff --git a/compiler/src/checkAnnot.ml b/compiler/src/checkAnnot.ml index 998b0fabe..f9f05af94 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 5207b9f59..5ed0c7e14 100644 --- a/compiler/src/compile.ml +++ b/compiler/src/compile.ml @@ -240,9 +240,7 @@ let compile (type reg regx xreg rflag cond asm_op extra_op) in let szs_of_fn fn = - match (get_annot fn).stack_zero_strategy with - | Some (s, ows) -> Some (s, Option.map Pretyping.tt_ws ows) - | None -> None + (get_annot fn).stack_zero_strategy in let cparams = diff --git a/compiler/src/pretyping.ml b/compiler/src/pretyping.ml index dab1fb219..04df80e39 100644 --- a/compiler/src/pretyping.ml +++ b/compiler/src/pretyping.ml @@ -510,9 +510,6 @@ end = struct end -(* -------------------------------------------------------------------- *) -let tt_ws (ws : A.wsize) = ws - (* -------------------------------------------------------------------- *) let tt_pointer dfl_writable (p:S.ptr) : W.reference = match p with @@ -714,7 +711,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)) @@ -1058,7 +1054,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 @@ -1083,7 +1079,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 @@ -1165,7 +1160,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) @@ -1174,9 +1169,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)) (* -------------------------------------------------------------------- *) let tt_exprs pd (env : 'asm Env.env) es = List.map (tt_expr ~mode:`AllVar pd env) es @@ -1235,7 +1230,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 @@ -1793,7 +1788,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 arch_info.asmOp p in 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/stackAlloc.ml b/compiler/src/stackAlloc.ml index 7e290b87e..781d9219c 100644 --- a/compiler/src/stackAlloc.ml +++ b/compiler/src/stackAlloc.ml @@ -376,7 +376,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 @@ -415,7 +414,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)) From c41ad8008b19dce3a7359add2606bd326cecd4e0 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Thu, 5 Sep 2024 10:36:08 +0200 Subject: [PATCH 40/51] varalloc: system calls do modify the stack pointer --- CHANGELOG.md | 5 +++++ compiler/src/varalloc.ml | 4 ++-- compiler/tests/success/common/bug_870.jazz | 5 +++++ 3 files changed, 12 insertions(+), 2 deletions(-) create mode 100644 compiler/tests/success/common/bug_870.jazz diff --git a/CHANGELOG.md b/CHANGELOG.md index 7e09378f5..f8b8cd759 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -15,6 +15,11 @@ ([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)). + ## Other changes - The deprecated legacy interface to the LATEX pretty-printer has been removed diff --git a/compiler/src/varalloc.ml b/compiler/src/varalloc.ml index 5f3652d71..a3b8b1a76 100644 --- a/compiler/src/varalloc.ml +++ b/compiler/src/varalloc.ml @@ -425,8 +425,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/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; +} From 4948ecf5db7fc115df6d2bf5713112a2cd119da2 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Wed, 11 Sep 2024 15:41:34 +0200 Subject: [PATCH 41/51] Tests: fix output as tests progress Do not move the cursor up: this eats previous output Compute the terminal width when needed (it may change during the course of the test-suite). Also print something in CI log. --- compiler/scripts/runtest | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/compiler/scripts/runtest b/compiler/scripts/runtest index 58352c8f4..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): @@ -362,6 +362,8 @@ def _main(): 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 ---") From d201a899e49b02f685ff02306b28b19c029ebc6f Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Thu, 5 Sep 2024 09:37:44 +0200 Subject: [PATCH 42/51] checksafety: support dynamically scoped global variables --- CHANGELOG.md | 4 ++++ compiler/safety/success/dynglob.jazz | 9 +++++++++ compiler/safetylib/safetyAbsExpr.ml | 8 +++----- 3 files changed, 16 insertions(+), 5 deletions(-) create mode 100644 compiler/safety/success/dynglob.jazz diff --git a/CHANGELOG.md b/CHANGELOG.md index f8b8cd759..feed45328 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -20,6 +20,10 @@ ([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 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/safetylib/safetyAbsExpr.ml b/compiler/safetylib/safetyAbsExpr.ml index 1ea393cc4..c9a6f9c78 100644 --- a/compiler/safetylib/safetyAbsExpr.ml +++ b/compiler/safetylib/safetyAbsExpr.ml @@ -1002,11 +1002,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 From 18a8f5d621e53539435da6fd68b39147d99f1bf4 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Fri, 13 Sep 2024 16:40:17 +0200 Subject: [PATCH 43/51] checksafety: improve handling of LEA instruction --- CHANGELOG.md | 3 +++ compiler/safety/success/lea.jazz | 29 +++++++++++++++++++++++++ compiler/safetylib/safetyInterpreter.ml | 8 +++++++ 3 files changed, 40 insertions(+) create mode 100644 compiler/safety/success/lea.jazz diff --git a/CHANGELOG.md b/CHANGELOG.md index feed45328..7491ed8a9 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -35,6 +35,9 @@ - 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)). + # Jasmin 2024.07.0 — Sophia-Antipolis, 2024-07-09 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/safetyInterpreter.ml b/compiler/safetylib/safetyInterpreter.ml index 6b5da6c05..4093646e4 100644 --- a/compiler/safetylib/safetyInterpreter.ml +++ b/compiler/safetylib/safetyInterpreter.ml @@ -1356,6 +1356,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))) ] From 5603a3252b70cfd8fe592511fd69030711553651 Mon Sep 17 00:00:00 2001 From: Alexandre BOURBEILLON Date: Wed, 11 Sep 2024 11:32:27 +0200 Subject: [PATCH 44/51] Add support for binary, octal, and underscores in integer notation At the source level, integer literal can now be written in - binary with a 0b or 0B prefix: 0b10001111 - octal with a 0o or 0O prefix: 0o7722 - decimal without any explicit prefix: 42 - hexadecimal with a 0x or 0X prefix: 0xabcd All these notations may contain underscores (except at the beginning), e.g., 0b1111_0000 or 10_854_736. Caveat _1234 is an indentifier, not a number. Co-authored-by: Vincent Laporte --- CHANGELOG.md | 8 +++++++ compiler/src/lexer.mll | 12 ++++++---- compiler/src/syntax.ml | 5 ++++- .../success/common/integer_notation.jazz | 22 +++++++++++++++++++ 4 files changed, 42 insertions(+), 5 deletions(-) create mode 100644 compiler/tests/success/common/integer_notation.jazz diff --git a/CHANGELOG.md b/CHANGELOG.md index 7491ed8a9..4751092e1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,14 @@ # [unreleased] +## 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 diff --git a/compiler/src/lexer.mll b/compiler/src/lexer.mll index 3ce849dfa..3354b0e59 100644 --- a/compiler/src/lexer.mll +++ b/compiler/src/lexer.mll @@ -108,6 +108,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'] @@ -133,11 +135,13 @@ rule main = parse | '"' (([^'"' '\\']|'\\' _)* as s) '"' { STRING (unescape (L.of_lexbuf lexbuf) s) } - (* Why this is needed *) - | ((*'-'?*) digit+) as s - {INT s} + | (digit+(('_')+ digit+)*) as s - | ('0' ['x' 'X'] hexdigit+) as 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 diff --git a/compiler/src/syntax.ml b/compiler/src/syntax.ml index ee509f085..4911d7eaf 100644 --- a/compiler/src/syntax.ml +++ b/compiler/src/syntax.ml @@ -1,4 +1,5 @@ open Annotations +open Utils (* -------------------------------------------------------------------- *) module L = Location @@ -24,7 +25,9 @@ type castop1 = CSS of sowsize | CVS of svsize type castop = castop1 L.located option type int_representation = string -let parse_int = Z.of_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 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; +} From 7b326561db40d073793767da562e135bc6714a2c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Cassiers?= Date: Tue, 4 Jun 2024 18:50:38 +0200 Subject: [PATCH 45/51] toEc: Remove safety extraction --- CHANGELOG.md | 3 + compiler/src/CLI_errors.ml | 4 - compiler/src/glob_options.ml | 2 - compiler/src/toEC.ml | 234 +++++------------------------------ compiler/src/utils.ml | 1 - compiler/src/utils.mli | 1 - eclib/JArray.ec | 7 -- eclib/JMemory.ec | 197 ----------------------------- eclib/JUtils.ec | 16 --- 9 files changed, 32 insertions(+), 433 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 4751092e1..0dec003ca 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -46,6 +46,9 @@ - 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 diff --git a/compiler/src/CLI_errors.ml b/compiler/src/CLI_errors.ml index c712e81c9..d22cf5dbb 100644 --- a/compiler/src/CLI_errors.ml +++ b/compiler/src/CLI_errors.ml @@ -50,10 +50,6 @@ let check_options () = then warning Experimental Location.i_dummy "support for windows calling-convention is experimental"; - if !model = Safety - then warning Deprecated Location.i_dummy - "the [-safety] option has been deprecated since June 2024"; - if !target_arch = ARM_M4 then warning Experimental Location.i_dummy "support of the ARMv7 architecture is experimental"; diff --git a/compiler/src/glob_options.ml b/compiler/src/glob_options.ml index e14e22168..6f1fca503 100644 --- a/compiler/src/glob_options.ml +++ b/compiler/src/glob_options.ml @@ -83,7 +83,6 @@ let set_slice f = slice := f :: !slice let set_constTime () = model := ConstantTime -let set_safety () = model := Safety let set_checksafety () = check_safety := true let set_safetyparam s = safety_param := Some s @@ -183,7 +182,6 @@ let options = [ "-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"; "-slice" , Arg.String set_slice , "[f] Keep function [f] and everything it needs"; - "-safety", Arg.Unit set_safety , " Generate model for safety verification (deprecated)"; "-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/toEC.ml b/compiler/src/toEC.ml index 5b0e6ff18..5d15b3685 100644 --- a/compiler/src/toEC.ml +++ b/compiler/src/toEC.ml @@ -31,7 +31,7 @@ module Mty = Map.Make (Tcmp) type env = { model : model; alls : Ss.t; - vars : (string * bool) Mv.t; (* true means option type *) + vars : string Mv.t; glob : (string * ty) Ms.t; funs : (string * (ty list * ty list)) Mf.t; arrsz : Sint.t ref; @@ -40,8 +40,6 @@ type env = { randombytes : Sint.t ref; } -let for_safety env = env.model = Utils.Safety - (* --------------------------------------------------------------- *) let rec read_mem_e = function @@ -429,35 +427,21 @@ 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)) + set_var env x s -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_var env fmt (x:var) = pp_string fmt (Mv.find x env.vars) let pp_zeroext fmt (szi, szo) = let io, ii = int_of_ws szo, int_of_ws szi in @@ -597,25 +581,20 @@ let rec pp_expr pd env fmt (e:expr) = | Parr_init _n -> Format.fprintf fmt "witness" - | Pvar x -> - pp_ovar env fmt (L.unloc x.gv) + | Pvar x -> pp_var env fmt (L.unloc x.gv) | 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 (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 - 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) + 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.[%a]@]" (pp_var env) x (pp_expr pd env) e + 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 | Psub (aa, ws, len, x, e) -> assert (check_array env x.gv); @@ -718,7 +697,7 @@ let pp_rty env fmt tys = let pp_ret env fmt xs = Format.fprintf fmt "@[return (%a);@]" - (pp_list ",@ " (fun fmt x -> pp_ovar env fmt (L.unloc x))) xs + (pp_list ",@ " (fun fmt x -> pp_var env fmt (L.unloc x))) xs let pp_lval1 pd env pp_e fmt (lv, (ety, e)) = let lty = ty_lval lv in @@ -1037,135 +1016,23 @@ end 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 *) - | Pif (_,e1, e2, e3) -> - safe_e_rec pd env (safe_e_rec pd env (safe_e_rec pd env safe e1) e2) e3 - - 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 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 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 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 pd env) e pp_size sz - | NotZero(sz,e) -> Format.fprintf fmt "%a <> W%a.zeros" (pp_expr 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 pd env) e (size_of_ws ws) n - - let pp_safe_es pd env fmt es = pp_list "/\\@ " (pp_safe_e pd env) fmt es - let pp_leaks pd env fmt es = Format.fprintf fmt "leakages <- LeakAddr(@[[%a]@]) :: leakages;@ " (pp_list ";@ " (pp_expr pd env)) es - let pp_safe_cond pd env fmt conds = - if conds <> [] then - Format.fprintf fmt "safe <- @[safe /\\ %a@];@ " (pp_safe_es pd env) conds - let pp_leaks_e pd env fmt e = match env.model with | ConstantTime -> pp_leaks pd env fmt (leaks_e pd e) - | Safety -> pp_safe_cond pd env fmt (safe_e pd env e) - | _ -> () + | Normal -> () let pp_leaks_es pd env fmt es = match env.model with | ConstantTime -> pp_leaks pd env fmt (leaks_es pd es) - | Safety -> pp_safe_cond pd env fmt (safe_es pd env es) - | _ -> () + | Normal -> () let pp_leaks_opn pd asmOp env fmt op es = match env.model with | ConstantTime -> pp_leaks 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 pd env fmt conds | Normal -> () let pp_leaks_if pd env fmt e = @@ -1175,7 +1042,6 @@ module Leak = struct Format.fprintf fmt "leakages <- LeakCond(%a) :: LeakAddr(@[[%a]@]) :: leakages;@ " (pp_expr pd env) e (pp_list ";@ " (pp_expr pd env)) leaks - | Safety -> pp_safe_cond pd env fmt (safe_e pd env e) | Normal -> () let pp_leaks_for pd env fmt e1 e2 = @@ -1186,7 +1052,6 @@ module Leak = struct "leakages <- LeakFor(%a,%a) :: LeakAddr(@[[%a]@]) :: leakages;@ " (pp_expr pd env) e1 (pp_expr pd env) e2 (pp_list ";@ " (pp_expr pd env)) leaks - | Safety -> pp_safe_cond pd env fmt (safe_es pd env [e1;e2]) | Normal -> () let pp_leaks_lv pd env fmt lv = @@ -1194,8 +1059,7 @@ module Leak = struct | ConstantTime -> let leaks = leaks_lval pd lv in if leaks <> [] then pp_leaks pd env fmt leaks - | Safety -> pp_safe_cond pd env fmt (safe_lval pd env lv) - | _ -> () + | Normal -> () let rec init_aux_i pd asmOp env i = match i.i_desc with @@ -1214,38 +1078,15 @@ module Leak = struct if lvs = [] then env else 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) -> - 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 + | Cfor(_,_,c) -> init_aux pd asmOp (add_aux env [tint]) c and init_aux pd asmOp env c = List.fold_left (init_aux_i pd asmOp) env c - 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 pd env fmt lv ((etyo, etyi), aux) = Format.fprintf fmt "@ "; pp_leaks_lv 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 + let pp_e = pp_cast env pp_e in pp_lval1 pd env pp_e fmt (lv, (etyo,aux)) let pp_call pd env fmt lvs etyso etysi pp a = @@ -1330,11 +1171,7 @@ module Leak = struct (* decreasing for loops have bounds swaped *) let e1, e2 = if d = UpTo then e1, e2 else e2, e1 in pp_leaks_for 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 aux, env1 = 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 *) @@ -1348,18 +1185,13 @@ module Leak = struct 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@]" + "@[%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 pd asmOp env1) c pp_i () pp_i () (if d = UpTo then "+" else "-") - pp_restore () end @@ -1368,17 +1200,12 @@ let pp_aux fmt env = Format.fprintf fmt "@[var %s:@ %a@];@ " aux (pp_ty env) ty in Mty.iter (fun ty -> List.iter (pp ty)) env.auxv -let pp_safe_ret pd env fmt xs = - if for_safety env then - let es = List.map (fun x -> Pvar (gkvar x)) xs in - Leak.pp_safe_cond pd env fmt (Leak.safe_es pd env es) - let pp_fun pd asmOp env fmt f = 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 + let env = List.fold_left add_var env f.f_args in + let env = List.fold_left add_var env locals in (* init auxiliary variables *) let env = if env.model = Normal then Normal.init_aux pd asmOp env f.f_body @@ -1391,14 +1218,13 @@ let pp_fun pd asmOp env fmt f = if env.model = Normal then Normal.pp_cmd else Leak.pp_cmd in Format.fprintf fmt - "@[proc %a (%a) : %a = {@ @[%a@ %a@ %a@ %a%a@]@ }@]" + "@[proc %a (%a) : %a = {@ @[%a@ %a@ %a@ %a@]@ }@]" (pp_fname env) f.f_name (pp_params env) f.f_args (pp_rty env) f.f_tyout pp_aux env (pp_locals env) locals (pp_cmd pd asmOp env) f.f_body - (pp_safe_ret pd env) f.f_ret (pp_ret env) f.f_ret let pp_glob_decl env fmt (x,d) = @@ -1494,8 +1320,6 @@ let pp_prog pd asmOp fmt model globs funcs arrsz warrsz randombytes = 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 = diff --git a/compiler/src/utils.ml b/compiler/src/utils.ml index cfd079384..5a11052f4 100644 --- a/compiler/src/utils.ml +++ b/compiler/src/utils.ml @@ -233,7 +233,6 @@ let pp_string fmt s = (* -------------------------------------------------------------------- *) type model = | ConstantTime - | Safety | Normal (* -------------------------------------------------------------------- *) diff --git a/compiler/src/utils.mli b/compiler/src/utils.mli index 74f7f3e1c..f446949f3 100644 --- a/compiler/src/utils.mli +++ b/compiler/src/utils.mli @@ -135,7 +135,6 @@ val pp_string : string pp (* -------------------------------------------------------------------- *) type model = | ConstantTime - | Safety | Normal (* -------------------------------------------------------------------- *) diff --git a/eclib/JArray.ec b/eclib/JArray.ec index 317f16ae3..d1f90b9a7 100644 --- a/eclib/JArray.ec +++ b/eclib/JArray.ec @@ -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/JUtils.ec b/eclib/JUtils.ec index dd89ed097..8c2f74021 100644 --- a/eclib/JUtils.ec +++ b/eclib/JUtils.ec @@ -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: From 4d406f103d52e5097520b237db1db611a34264b3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Cassiers?= Date: Tue, 4 Jun 2024 20:25:59 +0200 Subject: [PATCH 46/51] toEC: make parentheses and whitespace more uniform This prepares for pretty-printing easycrypt code based on an AST. (We will ensure that the AST-based pretty-printing produces exactly the same output as the current pretty-printing.) --- compiler/src/toEC.ml | 77 +++++++++++++++++++++++++++----------------- 1 file changed, 47 insertions(+), 30 deletions(-) diff --git a/compiler/src/toEC.ml b/compiler/src/toEC.ml index 5d15b3685..f5610ec19 100644 --- a/compiler/src/toEC.ml +++ b/compiler/src/toEC.ml @@ -4,6 +4,13 @@ open Prog open PrintCommon module E = Expr +let rec pp_list_pre sep pp fmt xs = + let pp_list_pre = pp_list_pre sep pp in + match xs with + | [] -> () + | [x] -> Format.fprintf fmt "%(%)%a" sep pp x + | x :: xs -> Format.fprintf fmt "%(%)%a%a" sep pp x pp_list_pre xs + let pp_size fmt sz = Format.fprintf fmt "%i" (int_of_ws sz) @@ -546,7 +553,7 @@ let check_array env x = 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]))@]" + "@[(%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 = @@ -565,7 +572,7 @@ let pp_cast env pp fmt (ty,ety,e) = 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))@]" + "@[(%a.init@ (fun %s => (get%i@ %a@ %s)))@]" (pp_Array env) n i (int_of_ws ws) @@ -603,7 +610,7 @@ let rec pp_expr pd env fmt (e:expr) = 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]))@]" + Format.fprintf fmt "@[(%a.init (fun %s => %a.[(%a + %s)]))@]" (pp_Array env) len i (pp_var env) x @@ -646,7 +653,7 @@ let rec pp_expr pd env fmt (e:expr) = | [] -> assert false | [e] -> Format.fprintf fmt "%a" (pp_expr pd env) e | e::es -> - Format.fprintf fmt "@[(%a %%%% 2^%i +@ 2^%i * %a)@]" + 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 -> @@ -696,8 +703,10 @@ let pp_rty env fmt tys = (pp_list " *@ " (pp_ty env)) tys let pp_ret env fmt xs = - Format.fprintf fmt "@[return (%a);@]" - (pp_list ",@ " (fun fmt x -> pp_var env fmt (L.unloc x))) xs + match xs with + | [x] -> Format.fprintf fmt "@[return %a;@]" (pp_var env) (L.unloc x) + | _ -> Format.fprintf fmt "@[return (%a);@]" + (pp_list ",@ " (fun fmt x -> pp_var env fmt (L.unloc x))) xs let pp_lval1 pd env pp_e fmt (lv, (ety, e)) = let lty = ty_lval lv in @@ -705,7 +714,7 @@ let pp_lval1 pd env pp_e fmt (lv, (ety, e)) = match lv with | Lnone _ -> assert false | Lmem(_, ws, x, e1) -> - Format.fprintf fmt "@[Glob.mem <-@ storeW%a Glob.mem (W%d.to_uint %a) (%a);@]" pp_size ws + Format.fprintf fmt "@[Glob.mem <-@ (storeW%a Glob.mem (W%d.to_uint %a) %a);@]" pp_size ws (int_of_ws pd) (pp_wcast pd env) (add_ptr pd (gkvar x) e1) pp_e e | Lvar x -> @@ -721,7 +730,7 @@ let pp_lval1 pd env pp_e fmt (lv, (ety, e)) = 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)));@]@]" + "@[%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 @@ -736,7 +745,7 @@ let pp_lval1 pd env pp_e fmt (lv, (ety, e)) = 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]);@]@]@]" + "@[%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 @@ -760,7 +769,7 @@ let pp_lval1 pd env pp_e fmt (lv, (ety, e)) = 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))@]" + "@[(%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 @@ -769,7 +778,7 @@ let pp_lval1 pd env pp_e fmt (lv, (ety, e)) = in - Format.fprintf fmt "@[%a <- @[%a.init@ @[(%a.get%i %a);@]" + 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) @@ -798,7 +807,7 @@ 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 + Format.fprintf fmt "(%a %a)" pp_zeroext (szi, szo) pp_e e let base_op = function | Sopn.Oasm (Arch_extra.BaseOp (_, o)) -> Sopn.Oasm (Arch_extra.BaseOp(None,o)) @@ -943,8 +952,12 @@ module Normal = struct 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 pd env)) (List.combine itys es) in + if es = [] then + Format.fprintf fmt "(%a)" (pp_opn pd asmOp) op + else + Format.fprintf fmt "(%a %a)" (pp_opn pd asmOp) op + (pp_list "@ " (pp_wcast 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 @@ -984,8 +997,12 @@ module Normal = struct (pp_expr pd env) e (pp_cmd pd asmOp env) c1 (pp_cmd pd asmOp env) c2 | Cwhile(_, c1, e,c2) -> - Format.fprintf fmt "@[%a@ while (%a) {@ %a@ }@]" - (pp_cmd pd asmOp env) c1 (pp_expr pd env) e (pp_cmd pd asmOp env) (c2@c1) + if c1 = [] then + Format.fprintf fmt "@[while (%a) {@ %a@ }@]" + (pp_expr pd env) e (pp_cmd pd asmOp env) c2 + else + Format.fprintf fmt "@[%a@ while (%a) {@ %a@ }@]" + (pp_cmd pd asmOp env) c1 (pp_expr pd env) e (pp_cmd pd asmOp env) (c2@c1) | Cfor(i, (d,e1,e2), c) -> (* decreasing for loops have bounds swaped *) @@ -1005,7 +1022,7 @@ module Normal = struct 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;@]@ }@]" + "@[%a%a <- %a;@ while ((%a < %a)) {@ @[%a@ %a <- (%a %s 1);@]@ }@]" pp_init () pp_i () (pp_expr pd env) e1 pp_i1 () pp_i2 () @@ -1017,7 +1034,7 @@ end module Leak = struct let pp_leaks pd env fmt es = - Format.fprintf fmt "leakages <- LeakAddr(@[[%a]@]) :: leakages;@ " + Format.fprintf fmt "@[leakages <- ((LeakAddr @[[%a]@]) :: leakages);@]@ " (pp_list ";@ " (pp_expr pd env)) es let pp_leaks_e pd env fmt e = @@ -1040,7 +1057,7 @@ module Leak = struct | ConstantTime -> let leaks = leaks_e pd e in Format.fprintf fmt - "leakages <- LeakCond(%a) :: LeakAddr(@[[%a]@]) :: leakages;@ " + "@[leakages <- ((LeakCond %a) :: ((LeakAddr @[[%a]@]) :: leakages));@]@ " (pp_expr pd env) e (pp_list ";@ " (pp_expr pd env)) leaks | Normal -> () @@ -1049,7 +1066,7 @@ module Leak = struct | ConstantTime -> let leaks = leaks_es pd [e1;e2] in Format.fprintf fmt - "leakages <- LeakFor(%a,%a) :: LeakAddr(@[[%a]@]) :: leakages;@ " + "@[leakages <- ((LeakFor (%a, %a)) :: ((LeakAddr @[[%a]@]) :: leakages));@]@ " (pp_expr pd env) e1 (pp_expr pd env) e2 (pp_list ";@ " (pp_expr pd env)) leaks | Normal -> () @@ -1123,8 +1140,8 @@ module Leak = struct 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 pd env)) (List.combine itys es) in + Format.fprintf fmt "<- (%a%a)" (pp_opn pd asmOp) op + (pp_list_pre "@ " (pp_wcast pd env)) (List.combine itys es) in pp_leaks_opn pd asmOp env fmt op' es; pp_call pd env fmt lvs otys otys' pp (op, es) @@ -1186,7 +1203,7 @@ module Leak = struct 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;@]@ }@]" + "@[%a%a <- %a;@ while ((%a < %a)) {@ @[%a@ %a <- (%a %s 1);@]@ }@]" pp_init () pp_i () (pp_expr pd env) e1 pp_i1 () pp_i2 () @@ -1197,7 +1214,7 @@ end let pp_aux fmt env = let pp ty aux = - Format.fprintf fmt "@[var %s:@ %a@];@ " aux (pp_ty env) ty in + Format.fprintf fmt "@[var %s:%a@];@ " aux (pp_ty env) ty in Mty.iter (fun ty -> List.iter (pp ty)) env.auxv let pp_fun pd asmOp env fmt f = @@ -1218,7 +1235,7 @@ let pp_fun pd asmOp env fmt f = if env.model = Normal then Normal.pp_cmd else Leak.pp_cmd in Format.fprintf fmt - "@[proc %a (%a) : %a = {@ @[%a@ %a@ %a@ %a@]@ }@]" + "@[@[proc %a (%a) : %a = {@]@ @[%a@ %a@ %a@ %a@]@ }@]" (pp_fname env) f.f_name (pp_params env) f.f_args (pp_rty env) f.f_tyout @@ -1230,13 +1247,13 @@ let pp_fun pd asmOp env fmt f = let pp_glob_decl env fmt (x,d) = match d with | Global.Gword(ws, w) -> - Format.fprintf fmt "@[abbrev %a = %a.of_int %a.@]@ " + 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].@]@ " + 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) @@ -1329,12 +1346,12 @@ let pp_prog pd asmOp fmt model globs funcs arrsz warrsz randombytes = 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 "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;@ }" + 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 From 14799a9a13922d3768107f63bfb0ba43008373e8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ga=C3=ABtan=20Cassiers?= Date: Tue, 4 Jun 2024 22:02:30 +0200 Subject: [PATCH 47/51] toEC: generate easycrypt AST then pretty-print it --- compiler/src/toEC.ml | 1570 ++++++++++++++++++++--------------------- compiler/src/toEC.mli | 2 - 2 files changed, 783 insertions(+), 789 deletions(-) diff --git a/compiler/src/toEC.ml b/compiler/src/toEC.ml index f5610ec19..0f2597e59 100644 --- a/compiler/src/toEC.ml +++ b/compiler/src/toEC.ml @@ -4,21 +4,17 @@ open Prog open PrintCommon module E = Expr -let rec pp_list_pre sep pp fmt xs = - let pp_list_pre = pp_list_pre sep pp in - match xs with - | [] -> () - | [x] -> Format.fprintf fmt "%(%)%a" sep pp x - | x :: xs -> Format.fprintf fmt "%(%)%a%a" sep pp x pp_list_pre xs +let pp_option pp fmt = function + | Some x -> pp fmt x + | None -> () -let pp_size fmt sz = - Format.fprintf fmt "%i" (int_of_ws sz) +let pp_list_paren sep pp fmt xs = + if xs = [] then () + else pp_paren (pp_list sep pp) fmt xs -let pp_Tsz fmt sz = - Format.fprintf fmt "W%a" pp_size sz +let pp_Tsz sz = Format.asprintf "W%i" (int_of_ws sz) -let pp_sz_t fmt sz = - Format.fprintf fmt "%a.t" pp_Tsz sz +let pp_sz_t sz = Format.sprintf "W%i.t" (int_of_ws sz) module Scmp = struct type t = string @@ -36,6 +32,7 @@ end module Mty = Map.Make (Tcmp) type env = { + pd : Wsize.wsize; model : model; alls : Ss.t; vars : string Mv.t; @@ -47,63 +44,6 @@ type env = { randombytes : Sint.t ref; } -(* --------------------------------------------------------------- *) - -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 - | Pif (_, e1, e2, e3) -> read_mem_e e1 || read_mem_e e2 || read_mem_e e3 - -and read_mem_es es = List.exists read_mem_e es - -let read_mem_lval = function - | Lnone _ | Lvar _ -> false - | Lmem (_,_,_,_) -> true - | Laset (_,_,_,_,e) | Lasub (_,_,_,_,e)-> read_mem_e e - - -let write_mem_lval = function - | Lnone _ | Lvar _ | Laset _ | Lasub _ -> false - | Lmem _ -> true - -let read_mem_lvals = List.exists read_mem_lval -let write_mem_lvals = List.exists write_mem_lval - -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 - | 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 - -and read_mem_c s = List.exists (read_mem_i s) - -let read_mem_f s f = read_mem_c s f.f_body - -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 - | 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 - -and write_mem_c s = List.exists (write_mem_i s) - -let write_mem_f s f = write_mem_c s f.f_body - -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 add_ptr pd x e = (Prog.tu pd, Papp2 (E.Oadd ( E.Op_w pd), Pvar x, e)) @@ -348,9 +288,10 @@ 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 = let env = { + pd; model; alls = keywords; vars = Mv.empty; @@ -373,14 +314,13 @@ let empty_env model fds arrsz warrsz randombytes = let get_funtype env f = snd (Mf.find f env.funs) 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 @@ -393,24 +333,9 @@ let ty_lval = function 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 - let add_aux env tys = let tbl = Hashtbl.create 10 in let do1 env ty = @@ -448,27 +373,6 @@ let add_glob env x = let s = create_name env (normalize_name x.v_name) in set_var env x s -let pp_var env fmt (x:var) = pp_string fmt (Mv.find x env.vars) - -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 fmt = function - | E.Oword_of_int sz -> - Format.fprintf fmt "%a.of_int" pp_Tsz sz - | E.Oint_of_word sz -> - 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 "-" - let swap_op2 op e1 e2 = match op with | E.Ogt _ -> e2, e1 @@ -550,264 +454,226 @@ 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_print_i z = + if Z.leq Z.zero z then Z.to_string z + else Format.asprintf "(%a)" Z.pp_print z let pp_access aa = if aa = Warray_.AAdirect then "_direct" else "" -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 - - -let rec pp_expr pd env fmt (e:expr) = - match e with - | Pconst z -> Format.fprintf fmt "%a" pp_print_i z +type ec_op2 = + | ArrayGet + | Plus + | Infix of string - | Pbool b -> Format.fprintf fmt "%a" pp_bool b +type ec_op3 = + | Ternary + | If + | InORange - | Parr_init _n -> Format.fprintf fmt "witness" +type ec_ident = string list - | Pvar x -> pp_var env fmt (L.unloc x.gv) +type ec_expr = + | 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 *) + | Efun1 of string * ec_expr (* fun s => expr *) + | 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 *) - | Pget(_, aa, ws, x, e) -> - assert (check_array env x.gv); - 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.[%a]@]" (pp_var env) x (pp_expr pd env) e - 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 +let ec_ident s = Eident [s] +let ec_aget a i = Eop2 (ArrayGet, a, i) +let ec_int x = Econst (Z.of_int x) + +let ec_vars env (x:var) = Mv.find x env.vars +let ec_vari env (x:var) = Eident [ec_vars env x] - | Psub (aa, ws, len, x, e) -> - assert (check_array env x.gv); +let glob_mem = ["Glob"; "mem"] +let glob_memi = Eident glob_mem + +let pd_uint env = 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) + +let fmt_Array n = Format.sprintf "Array%i" n + +let fmt_WArray n = Format.sprintf "WArray%i" n + +let ec_Array env n = add_Array env n; fmt_Array n + +let ec_WArray env n = add_WArray env n; fmt_WArray n + +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 - 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_WArray_init env ws n, [Efun1 (i, f i)]) - - | 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 pd env) (add_ptr pd (gkvar x) e) - - | Papp1 (op1, e) -> - Format.fprintf fmt "(%a %a)" pp_op1 op1 (pp_wcast 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 pd env) te1 pp_op2 op2 (pp_wcast 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 - - | Pif(_,e1,et,ef) -> - let ty = ty_expr e in - Format.fprintf fmt "(%a ? %a : %a)" - (pp_expr pd env) e1 (pp_wcast pd env) (ty,et) (pp_wcast pd env) (ty,ef) - -and pp_wcast pd env fmt (ty, e) = - pp_cast env (pp_expr pd env) fmt (ty, ty_expr e, e) - -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 pp_ret env fmt xs = - match xs with - | [x] -> Format.fprintf fmt "@[return %a;@]" (pp_var env) (L.unloc x) - | _ -> Format.fprintf fmt "@[return (%a);@]" - (pp_list ",@ " (fun fmt x -> pp_var env fmt (L.unloc x))) xs - -let pp_lval1 pd env pp_e fmt (lv, (ety, e)) = - let lty = ty_lval lv in - let pp_e fmt e = pp_e fmt (lty, ety, e) in - match lv with - | Lnone _ -> assert false - | Lmem(_, ws, x, e1) -> - Format.fprintf fmt "@[Glob.mem <-@ (storeW%a Glob.mem (W%d.to_uint %a) %a);@]" pp_size ws - (int_of_ws pd) - (pp_wcast 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 - | 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 - 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 - | 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 - else - let nws = n * int_of_ws xws in - let nws8 = nws / 8 in - let pp_start fmt () = - if aa = Warray_.AAscale then - Format.fprintf fmt "(%i * %a)" (int_of_ws ws / 8) (pp_expr pd env) e1 - else - Format.fprintf fmt "%a" (pp_expr pd 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 ec_Array_init env len = Eident [ec_Array env len; "init"] -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 ec_initi env (x, n, ws) = + let f i = ec_aget x (ec_ident i) in + ec_WArray_initf env ws n f -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 ec_initi_var env (x, n, ws) = ec_initi env (ec_vari env x, n, ws) -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 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 = Efun1 (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 rec 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 + Eapp ( + ec_Array_init env len, + [ + Efun1 (i, ec_aget (ec_vari env x) (Eop2 (Plus, toec_expr env e, ec_ident i))) + ]) + else + Eapp ( + ec_Array_init env len, + [ + Efun1 (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 + | 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) + ) + +and 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 + +let pp_ec_ident fmt ident = Format.fprintf fmt "@[%a@]" (pp_list "." pp_string) ident + +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) + | Efun1 (var, e) -> + Format.fprintf fmt "@[(fun %s => %a)@]" var pp_ec_ast_expr e + | 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 + +and pp_ec_op2 fmt (op2, e1, e2) = + let f fmt = 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 fmt) pp_ec_ast_expr e1 pp_ec_ast_expr e2 + +and pp_ec_op3 fmt (op, e1, e2, e3) = + let f fmt = 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 fmt) pp_ec_ast_expr e1 pp_ec_ast_expr e2 pp_ec_ast_expr e3 let base_op = function | Sopn.Oasm (Arch_extra.BaseOp (_, o)) -> Sopn.Oasm (Arch_extra.BaseOp(None,o)) @@ -868,394 +734,440 @@ 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 = +type ec_lvalue = + | LvIdent of ec_ident + | LvArrItem of ec_ident * ec_expr + +type ec_lvalues = ec_lvalue list + +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 *) + +and ec_stmt = ec_instr list + +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 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, [ + Efun1 (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, [Efun1 (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 pd asmOp env i = - match i.i_desc with - | Cassgn _ -> env - | Cif(_, c1, c2) - | Cwhile(_, c1, _, c2) -> - init_aux pd asmOp (init_aux pd asmOp env c1) c2 +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 -> env + | ConstantTime -> add_aux (add_aux env [ty_lval lv]) [ty_expr e] + ) + | Copn (lvs, _, op, _) -> ( + match env.model with + | Normal -> + if List.length lvs = 1 then env + else + let tys = List.map Conv.ty_of_cty (Sopn.sopn_tout 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 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 -> + 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 -> + 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 - | Copn (lvs, _, op, _) -> - if List.length lvs = 1 then env - else - let tys = List.map Conv.ty_of_cty (Sopn.sopn_tout 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 pd asmOp env c = List.fold_left (init_aux_i pd asmOp) env c - - let pp_assgn_i 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 pd env (pp_cast env pp_e)) (lv, (etyo,aux)) - - - let pp_call 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 pd env fmt) lvs tyauxs - - let rec pp_cmd pd asmOp env fmt c = - Format.fprintf fmt "@[%a@]" (pp_list "@ " (pp_instr pd asmOp env)) c - - and pp_instr pd asmOp env fmt i = - match i.i_desc with - | Cassgn(v, _, _, Parr_init _) -> - let pp_e fmt _ = Format.fprintf fmt "witness" in - pp_lval1 pd env pp_e fmt (v, ((), ())) - - | Cassgn (lv, _, _ty, e) -> - let pp_e = pp_cast env (pp_expr pd env) in - pp_lval1 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) = - if es = [] then - Format.fprintf fmt "(%a)" (pp_opn pd asmOp) op - else - Format.fprintf fmt "(%a %a)" (pp_opn pd asmOp) op - (pp_list "@ " (pp_wcast 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 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 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 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 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 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 pd env fmt lvs otys otys pp es - - | Cif(e,c1,c2) -> - Format.fprintf fmt "@[if (%a) {@ %a@ } else {@ %a@ }@]" - (pp_expr pd env) e (pp_cmd pd asmOp env) c1 (pp_cmd pd asmOp env) c2 - - | Cwhile(_, c1, e,c2) -> - if c1 = [] then - Format.fprintf fmt "@[while (%a) {@ %a@ }@]" - (pp_expr pd env) e (pp_cmd pd asmOp env) c2 - else - Format.fprintf fmt "@[%a@ while (%a) {@ %a@ }@]" - (pp_cmd pd asmOp env) c1 (pp_expr pd env) e (pp_cmd 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 pd asmOp env) c - pp_i () pp_i () (if d = UpTo then "+" else "-") -end +and init_aux pd asmOp env c = List.fold_left (init_aux_i pd asmOp) env c -module Leak = struct - let pp_leaks pd env fmt es = - Format.fprintf fmt "@[leakages <- ((LeakAddr @[[%a]@]) :: leakages);@]@ " - (pp_list ";@ " (pp_expr pd env)) es +let ece_leaks_e env e = List.map (toec_expr env) (leaks_e env.pd e) - let pp_leaks_e pd env fmt e = - match env.model with - | ConstantTime -> pp_leaks pd env fmt (leaks_e pd e) - | Normal -> () +let ec_newleaks leaks = + let add_leak lacc l = Eop2 (Infix "::", l, lacc) in + List.fold_left add_leak (ec_ident "leakages") leaks + +let ec_addleaks leaks = [ESasgn ([LvIdent ["leakages"]], ec_newleaks leaks)] + +let ec_leaks es = ec_addleaks [Eapp (ec_ident "LeakAddr", [Elist es])] - let pp_leaks_es pd env fmt es = +let ec_leaks_e env e = match env.model with - | ConstantTime -> pp_leaks pd env fmt (leaks_es pd es) - | Normal -> () - - let pp_leaks_opn pd asmOp env fmt op es = + | ConstantTime -> ec_leaks (ece_leaks_e env e) + | Normal -> [] + +let ec_leaks_es env es = match env.model with - | ConstantTime -> pp_leaks pd env fmt (leaks_es pd es) - | Normal -> () + | ConstantTime -> ec_leaks (List.map (toec_expr env) (leaks_es env.pd es)) + | Normal -> [] - let pp_leaks_if 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 pd env) e (pp_list ";@ " (pp_expr pd env)) leaks - | Normal -> () + ec_addleaks [ + Eapp (ec_ident "LeakAddr", [Elist (ece_leaks_e env e)]); + Eapp (ec_ident "LeakCond", [toec_expr env e]) + ] + | Normal -> [] - let pp_leaks_for pd env fmt e1 e2 = +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 pd env) e1 (pp_expr pd env) e2 - (pp_list ";@ " (pp_expr pd env)) leaks - | Normal -> () - - let pp_leaks_lv 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 -> [] + +let ec_leaks_lv env lv = match env.model with | ConstantTime -> - let leaks = leaks_lval pd lv in - if leaks <> [] then pp_leaks pd env fmt leaks - | Normal -> () - - 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 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) - | 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 leaks = leaks_lval env.pd lv in + if leaks = [] then [] + else ec_leaks (List.map (toec_expr env) leaks) + | Normal -> [] - and init_aux pd asmOp env c = List.fold_left (init_aux_i pd asmOp) env 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] - let pp_assgn_i pd env fmt lv ((etyo, etyi), aux) = - Format.fprintf fmt "@ "; pp_leaks_lv pd env fmt lv; - let pp_e fmt aux = - pp_wzeroext pp_string fmt etyo etyi aux in - let pp_e = pp_cast env pp_e in - pp_lval1 pd env pp_e fmt (lv, (etyo,aux)) +let ec_assgn_i env lv ((etyo, etyi), aux) = ec_assgn env lv (etyo, etyi) (ec_ident aux) - let pp_call 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 pd env fmt) lvs tyauxs - - let rec pp_cmd pd asmOp env fmt c = - Format.fprintf fmt "@[%a@]" (pp_list "@ " (pp_instr pd asmOp env)) c - - and pp_instr pd asmOp env fmt i = - match i.i_desc with - | Cassgn(v, _, _, (Parr_init _ as e)) -> - pp_leaks_e pd env fmt e; - let pp_e fmt _ = Format.fprintf fmt "witness" in - pp_lval1 pd env pp_e fmt (v, ((), ())) - - | Cassgn (lv, _, _, e) -> - pp_leaks_e pd env fmt e; - let pp fmt e = Format.fprintf fmt "<- %a" (pp_expr pd env) e in - let tys = [ty_expr e] in - pp_call 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 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_pre "@ " (pp_wcast pd env)) (List.combine itys es) in - pp_leaks_opn pd asmOp env fmt op' es; - pp_call 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 pd env) fmt (List.combine itys es) in - pp_leaks_es 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 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 pd env) fmt (List.combine itys es) in - pp_leaks_es 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 pd env fmt lvs otys otys pp es - - | Cif(e,c1,c2) -> - pp_leaks_if pd env fmt e; - Format.fprintf fmt "@[if (%a) {@ %a@ } else {@ %a@ }@]" - (pp_expr pd env) e (pp_cmd pd asmOp env) c1 (pp_cmd pd asmOp env) c2 - - | Cwhile(_, c1, e,c2) -> - let pp_leak fmt e = - Format.fprintf fmt "@ %a" (pp_leaks_if pd env) e in - Format.fprintf fmt "@[%a%a@ while (%a) {@ %a%a@ }@]" - (pp_cmd pd asmOp env) c1 pp_leak e (pp_expr pd env) e - (pp_cmd pd asmOp env) (c2@c1) pp_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 - pp_leaks_for pd env fmt e1 e2; - let aux, env1 = 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 pd env fmt e2) - | _ -> - 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 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 - 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 pd asmOp env1) c - pp_i () pp_i () (if d = UpTo then "+" else "-") - -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_fun pd asmOp env fmt f = - 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 env f.f_args in - let env = List.fold_left add_var env locals in - (* init auxiliary variables *) - let env = - if env.model = Normal then Normal.init_aux pd asmOp env f.f_body - else Leak.init_aux pd asmOp 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 - "@[@[proc %a (%a) : %a = {@]@ @[%a@ %a@ %a@ %a@]@ }@]" - (pp_fname env) f.f_name - (pp_params env) f.f_args - (pp_rty env) f.f_tyout - pp_aux env - (pp_locals env) locals - (pp_cmd pd asmOp env) f.f_body - (pp_ret env) f.f_ret - -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 assgn_auxs = List.flatten (List.map2 (ec_assgn_i env) lvs tyauxs) in + call :: assgn_auxs + +let ec_pcall env lvs otys f args = + let ltys = List.map ty_lval lvs in + if lvs = [] || (env.model = Normal && 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)) + +let ec_call env lvs etyso etysi e = + let ltys = List.map ty_lval lvs in + if lvs = [] || (env.model = Normal && 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 rec toec_cmd asmOp env c = List.flatten (List.map (toec_instr asmOp env) c) + +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 -> + 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 && 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) -> + 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) + | 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]) + ] + +type ec_ty = string + +type ec_var = string * ec_ty + +type ec_fun_decl = { + fname: string; + args: (string * ec_ty) list; + rtys: ec_ty list; +} +type ec_fun = { + decl: ec_fun_decl; + locals: (string * ec_ty) list; + stmt: ec_stmt; +} + +let toec_ty ty = match ty with + | Bty Bool -> "bool" + | Bty Int -> "int" + | Bty (U ws) -> (pp_sz_t ws) + | Arr(ws,n) -> Format.sprintf "%s %s.t" (pp_sz_t ws) (fmt_Array n) + +let var2ec_var env x = (List.hd [ec_vars env x], toec_ty x.v_ty) + +let pp_ec_vdecl fmt (x, ty) = Format.fprintf fmt "%s:%a" x pp_string ty + +let pp_ec_fun_decl fmt fdecl = + let pp_ec_rty fmt rtys = + if rtys = [] then Format.fprintf fmt "unit" + else Format.fprintf fmt "@[%a@]" (pp_list " *@ " pp_string) rtys + in + Format.fprintf fmt + "@[proc %s (@[%a@]) : @[%a@]@]" + fdecl.fname + (pp_list ",@ " pp_ec_vdecl) fdecl.args + pp_ec_rty 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 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 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, toec_ty ty)) vars in + (List.flatten (List.map locs_ty (Mty.bindings env.auxv))) @ + (List.map (var2ec_var env) locals) + in + 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 ret = + let ec_var x = ec_vari env (L.unloc x) in + match f.f_ret with + | [x] -> ESreturn (ec_var x) + | xs -> ESreturn (Etuple (List.map ec_var xs)) + in + { + decl = { + fname = (get_funname env f.f_name); + args = List.map (var2ec_var env) f.f_args; + rtys = List.map toec_ty f.f_tyout; + }; + locals = ec_locals; + stmt = aux_locals_init @ (toec_cmd asmOp env f.f_body) @ [ret]; + } let add_arrsz env f = let add_sz x sz = @@ -1300,82 +1212,169 @@ 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 = +type ec_modty = string + +type ec_module_type = { + name: ec_modty; + funs: ec_fun_decl list; +} + +type ec_module = { + name: string; + params: (string * ec_modty) list; + ty: ec_modty option; + vars: (string * string) list; + funs: ec_fun list; +} + +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 + +type ec_prog = ec_item list + +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 : %s@]" v t)) m.vars + (fun fmt _ -> if m.vars = [] then (Format.fprintf fmt "") else (Format.fprintf fmt "@ ")) () + (pp_list "@ " pp_ec_fun) m.funs + +let pp_ec_prog fmt prog = Format.fprintf fmt "@[%a@]" (pp_list "@ @ " pp_ec_item) prog + +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, arr_ty)]; + rtys = [arr_ty]; + } + in + let randombytes_f n = + let dmap = + let wa = fmt_WArray n in + let initf = Efun1 ("a", Eapp (Eident [fmt_Array n; "init"], [ + Efun1 ("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 + |> fun env -> List.fold_left add_glob_env env globs + |> fun 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 pp_arrays arr s = match Sint.elements s with + | [] -> [] + | l -> [IrequireImport (List.map (Format.sprintf "%s%i" arr) l)] + in + let pp_leakages = match model with + | ConstantTime -> [("leakages", "leakages_t")] + | Normal -> [] + 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 -> [] + | 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 + 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] - let env = empty_env model funcs arrsz warrsz randombytes 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 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_leakages fmt env = - match env.model with - | ConstantTime -> - Format.fprintf fmt "var leakages : leakages_t@ @ " - | 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 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@]@ }.@ @]@." - "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 - let rec used_func f = used_func_c Ss.empty f.f_body @@ -1401,8 +1400,5 @@ 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 From 8e8afa5de382576509b97a7febf57eb3256e90e7 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Wed, 18 Sep 2024 14:05:46 +0200 Subject: [PATCH 48/51] Mark gvar OCaml type as covariant This allows polymorphic constant values of type 'a gvar. --- compiler/src/coreIdent.mli | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/src/coreIdent.mli b/compiler/src/coreIdent.mli index d8dccb66b..bd6f01274 100644 --- a/compiler/src/coreIdent.mli +++ b/compiler/src/coreIdent.mli @@ -37,7 +37,7 @@ val tint : 'len gty (* ------------------------------------------------------------------------ *) -type 'len gvar = private { +type +'len gvar = private { v_name : Name.t; v_id : uid; v_kind : v_kind; From 67f87aaaf1ae9c6390b16faa61ba13cab7ec9378 Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 17 Sep 2024 16:26:52 +0200 Subject: [PATCH 49/51] x86-lowering: do not introduce dummy instr info Similarly to what is done with if statements, the instructions corresponding to the lowering of the condition inherit the instr-info from the complete statement. --- proofs/compiler/x86_lowering.v | 2 +- proofs/compiler/x86_lowering_proof.v | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/proofs/compiler/x86_lowering.v b/proofs/compiler/x86_lowering.v index 860e0dc6b..6eaa743df 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 588a6cb1a..cef07e606 100644 --- a/proofs/compiler/x86_lowering_proof.v +++ b/proofs/compiler/x86_lowering_proof.v @@ -1789,7 +1789,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). @@ -1816,7 +1816,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). From ac57159133058234583177bcc439fd728daed6fd Mon Sep 17 00:00:00 2001 From: Vincent Laporte Date: Tue, 17 Sep 2024 16:13:19 +0200 Subject: [PATCH 50/51] Remove dummy locations from errors before printing them Best would be to avoid these dummy locations in the first place. Meanwhile, this is an attempt at saving the user from seeing scary locations. --- compiler/src/utils.ml | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/compiler/src/utils.ml b/compiler/src/utils.ml index 5a11052f4..de67219eb 100644 --- a/compiler/src/utils.ml +++ b/compiler/src/utils.ml @@ -296,9 +296,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 From 412519412cb1ea7ad8c486c1e43684429b791faf Mon Sep 17 00:00:00 2001 From: Lionel Blatter Date: Thu, 8 Aug 2024 16:35:41 +0200 Subject: [PATCH 51/51] Translation to EC for CL using new extraction --- compiler/src/glob_options.ml | 2 + compiler/src/toEC.ml | 1955 ++++++++++++++++++++++++---------- compiler/src/utils.ml | 1 + compiler/src/utils.mli | 1 + 4 files changed, 1380 insertions(+), 579 deletions(-) diff --git a/compiler/src/glob_options.ml b/compiler/src/glob_options.ml index 20d79e0c8..81cf19112 100644 --- a/compiler/src/glob_options.ml +++ b/compiler/src/glob_options.ml @@ -83,6 +83,7 @@ let set_slice f = slice := f :: !slice let set_constTime () = model := ConstantTime +let set_annotations () = model := Annotations let set_checksafety () = check_safety := true let set_safetyparam s = safety_param := Some s @@ -182,6 +183,7 @@ 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"; "-checksafety", Arg.Unit set_checksafety, " Automatically check for safety"; "-safetyparam", Arg.String set_safetyparam, diff --git a/compiler/src/toEC.ml b/compiler/src/toEC.ml index 7a2e810b1..e5021ee68 100644 --- a/compiler/src/toEC.ml +++ b/compiler/src/toEC.ml @@ -4,17 +4,315 @@ open Prog open PrintCommon module E = Expr -let pp_option pp fmt = function +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; + } + + type ec_lvalue = + | LvIdent of ec_ident + | LvArrItem of ec_ident * ec_expr + + type ec_lvalues = ec_lvalue list + + 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 *) + + and ec_stmt = ec_instr list + + type ec_fun = { + decl: ec_fun_decl; + locals: ec_var list; + stmt: ec_stmt; + } + + type ec_modty = string + + type ec_module_type = { + name: ec_modty; + funs: ec_fun_decl list; + } + + type ec_module = { + name: string; + params: (string * ec_modty) list; + ty: ec_modty option; + vars: ec_var list; + funs: ec_fun list; + } + + 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 + + and ec_tactic = + { tname : string; + targs : ec_tactic_args list; + (* subgoals : ec_tactic list *) + } + + type ec_proof = ec_tactic list + + 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 + + (* Printer*) + + 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 pp_option pp fmt = function | Some x -> pp fmt x | None -> () -let pp_list_paren sep pp fmt xs = + let pp_list_paren sep pp fmt xs = if xs = [] then () else pp_paren (pp_list sep pp) fmt xs -let pp_Tsz sz = Format.asprintf "W%i" (int_of_ws sz) + let pp_Tsz sz = Format.asprintf "W%i" (int_of_ws sz) + + let pp_sz_t sz = Format.sprintf "W%i.t" (int_of_ws sz) + + let pp_ec_ident fmt ident = Format.fprintf fmt "@[%a@]" (pp_list "." pp_string) ident + + let string_of_quant = function + | Lforall -> "forall" + | Lexists -> "exists" + | Llambda -> "fun" + + 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 "@." -let pp_sz_t sz = Format.sprintf "W%i.t" (int_of_ws sz) +end module Scmp = struct type t = string @@ -31,18 +329,31 @@ end module Mty = Map.Make (Tcmp) -type 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; - arrsz : Sint.t ref; - warrsz : Sint.t ref; - auxv : string list Mty.t; - randombytes : Sint.t ref; - } +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 = @@ -51,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 @@ -59,7 +371,14 @@ let rec leaks_e_rec pd leaks e = | Papp1 (_, e) -> leaks_e_rec pd leaks e | Papp2 (_, e1, e2) -> leaks_e_rec pd (leaks_e_rec pd leaks e1) e2 | PappN (_, es) -> leaks_es_rec pd leaks es + | Pabstract (_, es) -> leaks_es_rec pd leaks es | Pif (_, e1, e2, e3) -> leaks_e_rec pd (leaks_e_rec pd (leaks_e_rec pd leaks e1) e2) e3 + | Pfvar _ -> assert false + | Pbig (e1, e2, _, _, ei, e) -> + leaks_e_rec pd (leaks_e_rec pd (leaks_e_rec pd (leaks_e_rec pd leaks e1) e2) ei) e + | Presult _ -> leaks + | Presultget (_, _, _, _, _, e) -> leaks_e_rec pd (e::leaks) e + and leaks_es_rec pd leaks es = List.fold_left (leaks_e_rec pd) leaks es let leaks_e pd e = leaks_e_rec pd [] e @@ -73,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" @@ -288,29 +607,45 @@ let normalize_name n = let mkfunname env fn = fn.fn_name |> normalize_name |> create_name env -let empty_env pd 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; auxv = Mty.empty; 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 = Mf.add fd.f_name (s, ((*mk_tys*) fd.f_tyout, (*mk_tys*)fd.f_tyin)) env.funs in { env with funs; alls = Ss.add s env.alls } in - List.fold_left add_fun env fds + let env = List.fold_left add_fun env fds in + + let add_fun_contra env fd = + let contra = + let args = fd.f_args in + 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_funname env f = fst (Mf.find f env.funs) @@ -418,7 +753,6 @@ let pp_op2 fmt = function | Ovlsr(ve,ws) -> pp_vop2 fmt ("shr", ve, ws) | Ovlsl(ve,ws) -> pp_vop2 fmt ("shl", ve, ws) | Ovasr(ve,ws) -> pp_vop2 fmt ("sar", ve, ws) - let in_ty_op1 op = Conv.ty_of_cty (fst (E.type_of_op1 op)) @@ -447,233 +781,743 @@ let ty_expr = function | Papp1 (op,_) -> out_ty_op1 op | Papp2 (op,_,_) -> out_ty_op2 op | PappN (op, _) -> out_ty_opN op + | Pabstract (op, _) -> op.tyout | Pif (ty,_,_,_) -> ty + | Pfvar x -> x.L.pl_desc.v_ty + | Pbig (_, _, op, _, _, _) -> out_ty_op2 op + | Presult (_, x) -> x.gv.L.pl_desc.v_ty + | Presultget (_, _, sz, _, _, _) -> tu sz let check_array env x = match (L.unloc x).v_ty with | Arr(ws, n) -> Sint.mem n !(env.arrsz) && Sint.mem (arr_size ws n) !(env.warrsz) | _ -> true -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 ec_vars env (x:var) = Mv.find x env.vars -let pp_access aa = if aa = Warray_.AAdirect then "_direct" else "" +module Exp = struct -type ec_op2 = - | ArrayGet - | Plus - | Infix of string + open Ec -type ec_op3 = - | Ternary - | If - | InORange + let ec_ident s = Eident [s] -type ec_ident = string list + let ec_vari env (x:var) = Eident [ec_vars env x] -type ec_expr = - | 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 *) - | Efun1 of string * ec_expr (* fun s => expr *) - | 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 *) + let ec_aget a i = Eop2(ArrayGet, a, i) -let ec_ident s = Eident [s] -let ec_aget a i = Eop2 (ArrayGet, a, i) -let ec_int x = Econst (Z.of_int x) + let ec_int x = Econst (Z.of_int x) -let ec_vars env (x:var) = Mv.find x env.vars -let ec_vari env (x:var) = Eident [ec_vars env x] + let glob_mem = ["Glob"; "mem"] + let glob_memi = Eident glob_mem -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 pd_uint env = Eident [Format.sprintf "W%d" (int_of_ws env.pd); "to_uint"] + let ec_apps1 s e = Eapp (ec_ident s, [e]) -let ec_apps1 s e = Eapp (ec_ident s, [e]) + let iIdent i = ec_ident (Format.sprintf "%i" i) -let iIdent i = ec_ident (Format.sprintf "%i" i) + let fmt_Array n = Format.sprintf "Array%i" n -let fmt_Array n = Format.sprintf "Array%i" n + let fmt_WArray n = Format.sprintf "WArray%i" n -let fmt_WArray n = Format.sprintf "WArray%i" n + let ec_Array env n = add_Array env n; fmt_Array n -let ec_Array env n = add_Array env n; fmt_Array n + let ec_WArray env n = add_WArray env n; fmt_WArray n -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_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 ec_WArray_initf env ws n f = let i = create_name env "i" in - Eapp (ec_WArray_init env ws n, [Efun1 (i, f i)]) - -let ec_Array_init env len = Eident [ec_Array env len; "init"] + Eapp (ec_WArray_init env ws n, [Equant (Llambda ,[i], f i)]) -let ec_initi env (x, n, ws) = + 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_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_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 = + 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 = + 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 = Efun1 (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 rec toec_expr env (e: expr) = + 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 - Eapp ( - ec_Array_init env len, - [ - Efun1 (i, ec_aget (ec_vari env x) (Eop2 (Plus, toec_expr env e, ec_ident i))) - ]) - else - Eapp ( - ec_Array_init env len, - [ - Efun1 (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) - ]) - ) - ]) + 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 + 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 + 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)]) + 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)) + | 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 + 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 - ) + 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 + + | 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 (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 - | 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) - ) + else + assert false -and 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 +end -let pp_ec_ident fmt ident = Format.fprintf fmt "@[%a@]" (pp_list "." pp_string) ident +open Ec +open Exp -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) - | Efun1 (var, e) -> - Format.fprintf fmt "@[(fun %s => %a)@]" var pp_ec_ast_expr e - | 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 +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 check_lvals lvs = all_vars lvs + +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 -and pp_ec_op2 fmt (op2, e1, e2) = - let f fmt = 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) +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 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 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 - (f fmt) pp_ec_ast_expr e1 pp_ec_ast_expr e2 + aux (Subst.gsubst_e (fun ?loc:_ x -> x) aux1) -and pp_ec_op3 fmt (op, e1, e2, e3) = - let f fmt = 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)@]" + 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 - (f fmt) pp_ec_ast_expr e1 pp_ec_ast_expr e2 pp_ec_ast_expr e3 + aux (Subst.subst_result aux1) + + + 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)) @@ -712,6 +1556,7 @@ let rec is_write_i x i = is_write_c x c1 || is_write_c x c2 | Cfor(x',_,c) -> V.equal x x'.L.pl_desc || is_write_c x c + | Cassert _ -> false and is_write_c x c = List.exists (is_write_i x) c @@ -730,65 +1575,11 @@ let rec remove_for_i i = let ii' = Cassgn (Lvar j, E.AT_inline, jd.v_ty, Pvar (gkvar j')) in let ii' = { i with i_desc = ii' } in Cfor (j', r, ii' :: remove_for c) + | Cassert _ -> i.i_desc in { i with i_desc } and remove_for c = List.map remove_for_i c -type ec_lvalue = - | LvIdent of ec_ident - | LvArrItem of ec_ident * ec_expr - -type ec_lvalues = ec_lvalue list - -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 *) - -and ec_stmt = ec_instr list - -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 ec_opn pd asmOp o = let s = Format.asprintf "%a" (pp_opn pd asmOp) o in if Ss.mem s keywords then s^"_" else s @@ -839,7 +1630,7 @@ let toec_lval1 env lv e = ESasgn ( [LvIdent [ec_vars env x]], Eapp (ec_Array_init env n, [ - Efun1 (i, Eop3 ( + 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)), @@ -863,7 +1654,7 @@ let toec_lval1 env lv e = 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, [Efun1 (i, Eop3 (If, in_range, at, ae))]) 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]], @@ -881,12 +1672,13 @@ let rec init_aux_i pd asmOp env i = match i.i_desc with | Cassgn (lv, _, _, e) -> ( match env.model with - | Normal -> env + | 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 -> + | 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 @@ -901,7 +1693,7 @@ match i.i_desc with ) | Ccall(lvs, f, _) -> ( match env.model with - | Normal -> + | Normal | Annotations -> if lvs = [] then env else let tys = (*List.map Conv.ty_of_cty *)(fst (get_funtype env f)) in @@ -914,7 +1706,7 @@ match i.i_desc with ) | Csyscall(lvs, o, _) -> ( match env.model with - | Normal -> + | Normal | Annotations -> if lvs = [] then env else let tys = List.map Conv.ty_of_cty (Syscall.syscall_sig_u o).scs_tout in @@ -946,12 +1738,12 @@ let ec_leaks es = ec_addleaks [Eapp (ec_ident "LeakAddr", [Elist es])] let ec_leaks_e env e = match env.model with | ConstantTime -> ec_leaks (ece_leaks_e env e) - | Normal -> [] + | Normal | Annotations -> [] let ec_leaks_es env es = match env.model with | ConstantTime -> ec_leaks (List.map (toec_expr env) (leaks_es env.pd es)) - | Normal -> [] + | Normal | Annotations -> [] let ec_leaks_opn env es = ec_leaks_es env es @@ -962,7 +1754,7 @@ let ec_leaks_if env e = Eapp (ec_ident "LeakAddr", [Elist (ece_leaks_e env e)]); Eapp (ec_ident "LeakCond", [toec_expr env e]) ] - | Normal -> [] + | Normal | Annotations -> [] let ec_leaks_for env e1 e2 = match env.model with @@ -972,7 +1764,7 @@ let ec_leaks_for env e1 e2 = Eapp (ec_ident "LeakAddr", [Elist leaks]); Eapp (ec_ident "LeakFor", [Etuple [toec_expr env e1; toec_expr env e2]]) ] - | Normal -> [] + | Normal | Annotations -> [] let ec_leaks_lv env lv = match env.model with @@ -980,7 +1772,7 @@ let ec_leaks_lv env lv = let leaks = leaks_lval env.pd lv in if leaks = [] then [] else ec_leaks (List.map (toec_expr env) leaks) - | Normal -> [] + | Normal | Annotations -> [] let ec_assgn env lv (etyo, etyi) e = let e = e |> ec_wzeroext (etyo, etyi) |> ec_cast env (ty_lval lv, etyo) in @@ -998,14 +1790,14 @@ let ec_instr_aux env lvs etyso etysi instr = let ec_pcall env lvs otys f args = let ltys = List.map ty_lval lvs in - if lvs = [] || (env.model = Normal && check_lvals lvs && ltys = otys) then + 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)) let ec_call env lvs etyso etysi e = let ltys = List.map ty_lval lvs in - if lvs = [] || (env.model = Normal && check_lvals lvs && ltys = etyso && etyso = etysi) then + 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)) @@ -1019,7 +1811,7 @@ and toec_instr asmOp env i = [toec_lval1 env lv (ec_ident "witness")] | Cassgn (lv, _, _, e) -> ( match env.model with - | Normal -> + | Normal | Annotations -> let e = toec_cast env (ty_lval lv) e in [toec_lval1 env lv e] | ConstantTime -> @@ -1037,16 +1829,39 @@ and toec_instr asmOp env i = 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 && List.length lvs = 1 then + 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) -> - 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) + 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 + + | Cassert (Assume,_,e) -> + begin + match env.model with + | Annotations -> Annotations.ec_assume env e + | _ -> [] + end + + | Cassert (Assert,_,e) -> + begin + match env.model with + | Annotations -> Annotations.ec_assert env e + | _ -> [] + end + + | Cassert (_,_,e) -> assert false + | Csyscall (lvs, o, es) -> let s = Syscall.syscall_sig_u o in let otys = List.map Conv.ty_of_cty s.scs_tout in @@ -1085,49 +1900,7 @@ and toec_instr asmOp env i = ESwhile (Eop2 (Infix "<", ec_i1, ec_i2), (toec_cmd asmOp env c) @ [i_upd]) ] -type ec_ty = string - -type ec_var = string * ec_ty - -type ec_fun_decl = { - fname: string; - args: (string * ec_ty) list; - rtys: ec_ty list; -} -type ec_fun = { - decl: ec_fun_decl; - locals: (string * ec_ty) list; - stmt: ec_stmt; -} - -let toec_ty ty = match ty with - | Bty Bool -> "bool" - | Bty Int -> "int" - | Bty (U ws) -> (pp_sz_t ws) - | Arr(ws,n) -> Format.sprintf "%s %s.t" (pp_sz_t ws) (fmt_Array n) - -let var2ec_var env x = (List.hd [ec_vars env x], toec_ty x.v_ty) - -let pp_ec_vdecl fmt (x, ty) = Format.fprintf fmt "%s:%a" x pp_string ty - -let pp_ec_fun_decl fmt fdecl = - let pp_ec_rty fmt rtys = - if rtys = [] then Format.fprintf fmt "unit" - else Format.fprintf fmt "@[%a@]" (pp_list " *@ " pp_string) rtys - in - Format.fprintf fmt - "@[proc %s (@[%a@]) : @[%a@]@]" - fdecl.fname - (pp_list ",@ " pp_ec_vdecl) fdecl.args - pp_ec_rty 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 var2ec_var env x = (List.hd [ec_vars env x], Base (toec_ty x.v_ty)) let add_ty env = function | Bty _ -> () @@ -1135,16 +1908,22 @@ let add_ty env = function 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 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 + 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, toec_ty ty)) vars in + 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 @@ -1153,20 +1932,54 @@ let toec_fun asmOp env f = |> 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 + + let cl_vars_init = + match env.model with + | Annotations -> (Annotations.proof_var_init env f) + | _ -> [] + in + let ret = - let ec_var x = ec_vari env (L.unloc x) in - match f.f_ret with - | [x] -> ESreturn (ec_var x) - | xs -> ESreturn (Etuple (List.map ec_var xs)) + 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 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 = List.map toec_ty f.f_tyout; + rtys = ret_typ; }; locals = ec_locals; - stmt = aux_locals_init @ (toec_cmd asmOp env f.f_body) @ [ret]; + stmt = cl_vars_init @ aux_locals_init @ (toec_cmd asmOp env f.f_body) @ [ret]; } let add_arrsz env f = @@ -1220,58 +2033,6 @@ let lib_slh () = match !Glob_options.target_arch with | X86_64 -> "SLH64" | ARM_M4 -> "SLH32" -type ec_modty = string - -type ec_module_type = { - name: ec_modty; - funs: ec_fun_decl list; -} - -type ec_module = { - name: string; - params: (string * ec_modty) list; - ty: ec_modty option; - vars: (string * string) list; - funs: ec_fun list; -} - -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 - -type ec_prog = ec_item list - -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 : %s@]" v t)) m.vars - (fun fmt _ -> if m.vars = [] then (Format.fprintf fmt "") else (Format.fprintf fmt "@ ")) () - (pp_list "@ " pp_ec_fun) m.funs - -let pp_ec_prog fmt prog = Format.fprintf fmt "@[%a@]" (pp_list "@ @ " pp_ec_item) prog - 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 @@ -1289,15 +2050,15 @@ let ec_randombytes env = let arr_ty = Format.sprintf "W8.t %s.t" (fmt_Array n) in { fname = Format.sprintf "randombytes_%i" n; - args = [(a, arr_ty)]; - rtys = [arr_ty]; + args = [(a, Base arr_ty)]; + rtys = Base arr_ty; } in let randombytes_f n = let dmap = let wa = fmt_WArray n in - let initf = Efun1 ("a", Eapp (Eident [fmt_Array n; "init"], [ - Efun1 ("i", Eapp (Eident [wa; "get8"], [ec_ident "a"; ec_ident "i"])) + 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 @@ -1324,11 +2085,35 @@ let ec_randombytes env = 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 + 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, 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 funs = List.map (toec_fun asmOp env) funcs in let prefix = !Glob_options.ec_array_path in @@ -1339,37 +2124,49 @@ let toec_prog pd asmOp model globs funcs arrsz warrsz randombytes = | [] -> [] | l -> [IrequireImport (List.map (Format.sprintf "%s%i" arr) l)] in - let pp_leakages = match model with - | ConstantTime -> [("leakages", "leakages_t")] - | Normal -> [] - 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 -> [] - | ConstantTime -> [IfromRequireImport ("Jasmin", ["JLeakage"])] + | 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 + ] + in + let top_mod = Imodule { name = "M"; params = mod_arg; ty = None; vars = pp_leakages; funs; - } in + } + 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] + [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); @@ -1383,7 +2180,7 @@ and used_func_c used c = and used_func_i used i = match i.i_desc with - | Cassgn _ | Copn _ | Csyscall _ -> used + | Cassgn _ | Copn _ | Csyscall _ | Cassert _ -> used | Cif (_,c1,c2) -> used_func_c (used_func_c used c1) c2 | Cfor(_,_,c) -> used_func_c used c | Cwhile(_,c1,_,c2) -> used_func_c (used_func_c used c1) c2 diff --git a/compiler/src/utils.ml b/compiler/src/utils.ml index de67219eb..d83f5d412 100644 --- a/compiler/src/utils.ml +++ b/compiler/src/utils.ml @@ -234,6 +234,7 @@ let pp_string fmt s = type model = | ConstantTime | Normal + | Annotations (* -------------------------------------------------------------------- *) (* Functions used to add colors to errors and warnings. *) diff --git a/compiler/src/utils.mli b/compiler/src/utils.mli index f446949f3..4b29fd802 100644 --- a/compiler/src/utils.mli +++ b/compiler/src/utils.mli @@ -136,6 +136,7 @@ val pp_string : string pp type model = | ConstantTime | Normal + | Annotations (* -------------------------------------------------------------------- *) (* Enables colors in errors and warnings. *)