diff --git a/compiler/CCT/fail/randombytes.jazz b/compiler/CCT/fail/randombytes.jazz index 882f4cd705..8fd32ade6b 100644 --- a/compiler/CCT/fail/randombytes.jazz +++ b/compiler/CCT/fail/randombytes.jazz @@ -3,7 +3,8 @@ export fn main() -> reg u64 { stack u64[1] s; reg u64 r; - s = #randombytes(s); + reg u64 len = 8; + s = #randombytes{8}(s,len); r = s[0]; while (r < 64) { r += 64; diff --git a/compiler/CCT/fail/secret_ptr.jazz b/compiler/CCT/fail/secret_ptr.jazz index 20846448ad..c64221cb98 100644 --- a/compiler/CCT/fail/secret_ptr.jazz +++ b/compiler/CCT/fail/secret_ptr.jazz @@ -8,7 +8,8 @@ fn pointers(reg u64 a) -> reg u8 { q = s[1:1]; r = p; r = q if a reg u64 { reg u64[2] input; input[0] = a; input[1] = b; - s = #randombytes(s); + reg u64 len = 1; + s = #randombytes{1}(s, len); t = s[0]; r = input[0]; r = input[1] if t domain -> domain annotation - val funcall : Location.i_loc -> lvals -> funname -> exprs -> domain -> domain annotation + val funcall : Location.i_loc -> lvals -> funname -> length list -> exprs -> domain -> domain annotation val syscall : Location.i_loc -> lvals - -> (Wsize.wsize * BinNums.positive) Syscall_t.syscall_t + -> Syscall.syscall_t -> exprs -> domain -> domain annotation @@ -208,12 +208,12 @@ struct | Cassert (msg, e) -> let annotation = Annotation.bind annotation (L.assertion loc msg e) in (Cassert (msg, e), annotation) - | Ccall (lvs, fn, es) -> - let annotation = Annotation.bind annotation (L.funcall loc lvs fn es) in - (Ccall (lvs, fn, es), annotation) - | Csyscall (lvs, sc, es) -> + | Ccall (lvs, fn, al, es) -> + let annotation = Annotation.bind annotation (L.funcall loc lvs fn al es) in + (Ccall (lvs, fn, al, es), annotation) + | Csyscall (lvs, sc, al, es) -> let annotation = Annotation.bind annotation (L.syscall loc lvs sc es) in - (Csyscall (lvs, sc, es), annotation) + (Csyscall (lvs, sc, al, es), annotation) | Cif (cond, th, el) -> let th, annotation_th = analyse_stmt th annotation in let el, annotation_el = analyse_stmt el annotation in diff --git a/compiler/linter/Analyser/BackwardAnalyser.mli b/compiler/linter/Analyser/BackwardAnalyser.mli index 02d294a682..09de7a79ea 100644 --- a/compiler/linter/Analyser/BackwardAnalyser.mli +++ b/compiler/linter/Analyser/BackwardAnalyser.mli @@ -86,6 +86,7 @@ module type Logic = Jasmin.Location.i_loc -> Jasmin.Prog.lvals -> Jasmin.CoreIdent.funname -> + Jasmin.Prog.length list -> Jasmin.Prog.exprs -> domain -> domain Annotation.annotation (** @@ -94,7 +95,7 @@ module type Logic = val syscall : Jasmin.Location.i_loc -> Jasmin.Prog.lvals -> - (Jasmin.Wsize.wsize * Jasmin.BinNums.positive) Jasmin.Syscall_t.syscall_t -> + Jasmin.Syscall.syscall_t -> Jasmin.Prog.exprs -> domain -> domain Annotation.annotation (** diff --git a/compiler/linter/Analyser/ForwardAnalyser.ml b/compiler/linter/Analyser/ForwardAnalyser.ml index e53249aa14..096cc8b753 100644 --- a/compiler/linter/Analyser/ForwardAnalyser.ml +++ b/compiler/linter/Analyser/ForwardAnalyser.ml @@ -17,12 +17,12 @@ module type Logic = sig val forget : var_i -> domain -> domain annotation - val funcall : Location.i_loc -> lvals -> funname -> exprs -> domain -> domain annotation + val funcall : Location.i_loc -> lvals -> funname -> length list -> exprs -> domain -> domain annotation val syscall : Location.i_loc -> lvals - -> (Wsize.wsize * BinNums.positive) Syscall_t.syscall_t + -> Syscall.syscall_t -> exprs -> domain -> domain annotation @@ -185,12 +185,12 @@ module Make (Logic : Logic) : S with type domain = Logic.domain = struct | Cassert (msg, e) -> let annotation = Annotation.bind annotation (Logic.assertion loc msg e) in (Cassert (msg, e), annotation) - | Ccall (lvs, fn, es) -> - let annotation = Annotation.bind annotation (Logic.funcall loc lvs fn es) in - (Ccall (lvs, fn, es), annotation) - | Csyscall (lvs, sc, es) -> + | Ccall (lvs, fn, al, es) -> + let annotation = Annotation.bind annotation (Logic.funcall loc lvs fn al es) in + (Ccall (lvs, fn, al, es), annotation) + | Csyscall (lvs, sc, al, es) -> let annotation = Annotation.bind annotation (Logic.syscall loc lvs sc es) in - (Csyscall (lvs, sc, es), annotation) + (Csyscall (lvs, sc, al, es), annotation) | Cif (expr, th, el) -> let annotation_th, annotation_el = Logic.assume expr annotation in let th, annotation_th = analyse_stmt th annotation_th in diff --git a/compiler/linter/Analyser/ForwardAnalyser.mli b/compiler/linter/Analyser/ForwardAnalyser.mli index 2825a3b61d..44bb019bfa 100644 --- a/compiler/linter/Analyser/ForwardAnalyser.mli +++ b/compiler/linter/Analyser/ForwardAnalyser.mli @@ -108,6 +108,7 @@ module type Logic = Jasmin.Location.i_loc -> Jasmin.Prog.lvals -> Jasmin.CoreIdent.funname -> + Jasmin.Prog.length list -> Jasmin.Prog.exprs -> domain -> domain Annotation.annotation (** @@ -116,7 +117,7 @@ module type Logic = val syscall : Jasmin.Location.i_loc -> Jasmin.Prog.lvals -> - (Jasmin.Wsize.wsize * Jasmin.BinNums.positive) Jasmin.Syscall_t.syscall_t -> + Jasmin.Syscall.syscall_t -> Jasmin.Prog.exprs -> domain -> domain Annotation.annotation (** diff --git a/compiler/linter/Analysis/Liveness/LivenessAnalyser.ml b/compiler/linter/Analysis/Liveness/LivenessAnalyser.ml index ac5bf1b641..77a8605e2e 100644 --- a/compiler/linter/Analysis/Liveness/LivenessAnalyser.ml +++ b/compiler/linter/Analysis/Liveness/LivenessAnalyser.ml @@ -43,13 +43,13 @@ module LivenessDomain : BackwardAnalyser.Logic with type domain = Sv.t = struct assert (not (Sv.mem (L.unloc var) domain)); Annotation domain - let funcall (_ : Location.i_loc) (lvs : lvals) (_ : funname) (exprs : exprs) (domain : domain) = + let funcall (_ : Location.i_loc) (lvs : lvals) (_ : funname) (_ : length list) (exprs : exprs) (domain : domain) = Annotation (live_assigns domain lvs exprs) let syscall (_ : Location.i_loc) (lvs : lvals) - (_ : (Wsize.wsize * BinNums.positive) Syscall_t.syscall_t) + (_ : Syscall.syscall_t) (exprs : exprs) (domain : domain) = Annotation (live_assigns domain lvs exprs) diff --git a/compiler/linter/Analysis/ReachingDefinitions/RDAnalyser.ml b/compiler/linter/Analysis/ReachingDefinitions/RDAnalyser.ml index 8010c73300..c374caf4c4 100644 --- a/compiler/linter/Analysis/ReachingDefinitions/RDAnalyser.ml +++ b/compiler/linter/Analysis/ReachingDefinitions/RDAnalyser.ml @@ -34,7 +34,7 @@ module ReachingDefinitionLogic : Annotation (RDDomain.add (List.fold_left written_lv Sv.empty lvs) loc domain) - let funcall loc lvs _ _ domain = logic loc lvs domain + let funcall loc lvs _ _ _ domain = logic loc lvs domain let syscall loc lvs _ _ domain = logic loc lvs domain let assign loc lv _ _ _ domain = logic loc [ lv ] domain let opn loc lvs _ _ _ domain = logic loc lvs domain diff --git a/compiler/linter/Checker/VariableInitialisation.ml b/compiler/linter/Checker/VariableInitialisation.ml index 74fd7e28d3..0013d5163f 100644 --- a/compiler/linter/Checker/VariableInitialisation.ml +++ b/compiler/linter/Checker/VariableInitialisation.ml @@ -59,7 +59,7 @@ let check_func fd = | Cassgn (x, _, _, e) -> check_lv i_info x; check_e i_info e - | Copn (xs, _, _, es) | Csyscall (xs, _, es) | Ccall (xs, _, es) -> + | Copn (xs, _, _, es) | Csyscall (xs, _, _, es) | Ccall (xs, _, _, es) -> check_lvs i_info xs; check_es i_info es | Cassert (_, e) -> check_a i_info e diff --git a/compiler/safetylib/safetyAbsExpr.ml b/compiler/safetylib/safetyAbsExpr.ml index 65662fa842..797d527c68 100644 --- a/compiler/safetylib/safetyAbsExpr.ml +++ b/compiler/safetylib/safetyAbsExpr.ml @@ -28,7 +28,13 @@ type msub = int gmsub let check_msub ms = let gv = ms.ms_v in (* array size, in bytes *) - let arr_size = arr_range gv * (size_of_ws (arr_size gv)) in + let len = arr_range gv in + let len = + match len with + | Const len -> len + | _ -> assert false + in + let arr_size = len * (size_of_ws (arr_size gv)) in (* sub-array size, in bytes * *) let sub_size = ms.ms_len * (size_of_ws ms.ms_ws) in let offset = ms.ms_offset in @@ -40,10 +46,16 @@ let check_msubo ms = match ms.ms_offset with | Some off -> check_msub { ms with ms_offset = off } let msub_of_arr gv sc = + let len = arr_range gv in + let len = + match len with + | Const len -> len + | _ -> assert false + in let msub = { ms_v = gv; ms_sc = sc; ms_ws = arr_size gv; - ms_len = arr_range gv; + ms_len = len; ms_offset = Some 0; } in check_msubo msub; msub @@ -216,7 +228,7 @@ let print_not_word_expr e = Format.eprintf "@[Should be a word expression:@;\ @[%a@]@;Type:@;@[%a@]@]@." (Printer.pp_expr ~debug:(!Glob_options.debug)) e - (PrintCommon.pp_ty) (Conv.ty_of_cty (Conv.cty_of_ty (ty_expr e))) + (Printer.pp_ty ~debug:false) (Conv.ty_of_cty (Conv.cty_of_ty (ty_expr e))) let check_is_int v = let gv = L.unloc v.gv in @@ -224,7 +236,7 @@ let check_is_int v = | Bty Int -> () | _ -> Format.eprintf "%s should be an int but is a %a@." - gv.v_name PrintCommon.pp_ty gv.v_ty; + gv.v_name (Printer.pp_ty ~debug:false) gv.v_ty; raise (Aint_error "Bad type") let check_is_word v = @@ -233,7 +245,7 @@ let check_is_word v = | Bty (U _) -> () | _ -> Format.eprintf "%s should be a word but is a %a@." - gv.v_name PrintCommon.pp_ty gv.v_ty; + gv.v_name (Printer.pp_ty ~debug:false) gv.v_ty; raise (Aint_error "Bad type") @@ -416,8 +428,14 @@ module AbsExpr (Arch : SafetyArch.SafetyArch) (AbsDom : AbsNumBoolType) = struct (*-------------------------------------------------------------------------*) let arr_full_range x = + let len = arr_range x in + let len = + match len with + | Const len -> len + | _ -> assert false + in List.init - (arr_range x * size_of_ws (arr_size x)) + (len * size_of_ws (arr_size x)) (fun i -> AarraySlice (x, U8, i)) (* let abs_arr_range_at abs x acc ws ei = match aeval_cst_int abs ei with @@ -452,7 +470,7 @@ module AbsExpr (Arch : SafetyArch.SafetyArch) (AbsDom : AbsNumBoolType) = struct (*-------------------------------------------------------------------------*) (* Collect all variables appearing in e. *) - let ptr_expr_of_expr abs e = + let ptr_expr_of_expr abs (e:length gexpr) = let exception Expr_contain_load in let rec aux acc e = match e with | Pbool _ | Parr_init _ | Pconst _ -> acc @@ -462,6 +480,11 @@ module AbsExpr (Arch : SafetyArch.SafetyArch) (AbsDom : AbsNumBoolType) = struct | Pget(_, access,ws,x,ei) -> abs_sub_arr_range abs (L.unloc x.gv,x.gs) access ws 1 ei @ acc | Psub (access, ws, len, x, ei) -> + let len = + match len with + | Const len -> len + | _ -> assert false + in abs_sub_arr_range abs (L.unloc x.gv,x.gs) access ws len ei @ acc | Papp1 (_, e1) -> aux acc e1 @@ -1076,6 +1099,11 @@ module AbsExpr (Arch : SafetyArch.SafetyArch) (AbsDom : AbsNumBoolType) = struct end | Lasub (acc, ws, len, x, ei) -> + let len = + match len with + | Const len -> len + | _ -> assert false + in let offset = match aeval_cst_int abs ei with | Some i -> Some (access_offset acc ws i) | None -> None in @@ -1087,7 +1115,7 @@ module AbsExpr (Arch : SafetyArch.SafetyArch) (AbsDom : AbsNumBoolType) = struct MLasub (loc, msub) - let apply_offset_expr abs outv info (inv : int ggvar) offset_expr = + let apply_offset_expr abs outv info (inv : length ggvar) offset_expr = (* Global variable cannot alias to a input pointer. *) assert (inv.gs = Expr.Slocal); let inv = L.unloc inv.gv in @@ -1154,6 +1182,11 @@ module AbsExpr (Arch : SafetyArch.SafetyArch) (AbsDom : AbsNumBoolType) = struct let msub_of_sub_expr abs = function | Psub (acc, ws, len, ggv, ei) -> + let len = + match len with + | CoreIdent.Const len -> len + | _ -> assert false + in let offset = match aeval_cst_int abs ei with | Some i -> Some (access_offset acc ws i) | None -> None in diff --git a/compiler/safetylib/safetyAbsExpr.mli b/compiler/safetylib/safetyAbsExpr.mli index 8238ba11e4..810bdbea21 100644 --- a/compiler/safetylib/safetyAbsExpr.mli +++ b/compiler/safetylib/safetyAbsExpr.mli @@ -14,7 +14,7 @@ val pcast : wsize -> expr -> expr val wsize_of_ty : 'a gty -> int -val check_is_word : int ggvar -> unit +val check_is_word : length ggvar -> unit (*---------------------------------------------------------------*) type 'a gmsub = { ms_v : var; diff --git a/compiler/safetylib/safetyArch.ml b/compiler/safetylib/safetyArch.ml index 40707a15f8..909f87a4ee 100644 --- a/compiler/safetylib/safetyArch.ml +++ b/compiler/safetylib/safetyArch.ml @@ -37,21 +37,21 @@ module type SafetyArch = sig val split_asm_opn : int -> extended_op -> - expr list -> + exprs -> expr option list (** Architecture-specific assembly operation splitting *) val post_opn : extended_op -> - (int glval) list -> - expr list -> + lvals -> + exprs -> btcons list (** Post-conditions of operators, that cannot be precisely expressed as an expression of the arguments *) val opn_heur : extended_op -> mvar -> - expr list -> + exprs -> flags_heur option (** Heuristic for flags *) end diff --git a/compiler/safetylib/safetyInterpreter.ml b/compiler/safetylib/safetyInterpreter.ml index 37afc9df6c..e1caab5256 100644 --- a/compiler/safetylib/safetyInterpreter.ml +++ b/compiler/safetylib/safetyInterpreter.ml @@ -40,7 +40,7 @@ let pp_s_env fmt env = Format.printf fmt "@[global variables:@;%a@]" (pp_list (fun fmt (_,(x,sw)) -> Format.fprintf fmt "@[%s: %a@]@," - x PrintCommon.pp_ty (Conv.ty_of_cty sw))) + x (Printer.pp_ty ~debug:false) (Conv.ty_of_cty sw))) (Sv.to_list env.s_glob) (pp_list (fun fmt i -> Format.fprintf fmt "%d" i)) @@ -136,6 +136,7 @@ let pp_ows fmt ws = let pp_arr_slice fmt slice = let open PrintCommon in + let pp_len = Printer.pp_len ~debug:false in let pp_var = Printer.pp_var ~debug:false in let pp_expr = Printer.pp_expr ~debug:false in let ws = non_default_wsize slice.as_arr slice.as_wsize in @@ -144,7 +145,7 @@ let pp_arr_slice fmt slice = slice.as_arr slice.as_offset else pp_arr_slice pp_var pp_expr pp_len fmt slice.as_access ws slice.as_arr - slice.as_offset slice.as_len + slice.as_offset (Const slice.as_len) let pp_safety_cond fmt = function | Initv x -> Format.fprintf fmt "is_init %a" pp_var x @@ -240,7 +241,7 @@ module AbsMake (Arch : SafetyArch.SafetyArch) = struct let in_bound x access ws e len = let ux = L.unloc x in match ux.v_ty with - | Arr(ws',n) -> [InBound ( n * size_of_ws ws', + | Arr(ws',Prog.Const n) -> [InBound ( n * size_of_ws ws', { as_arr = ux; as_len = len; as_wsize = ws; @@ -358,6 +359,11 @@ let rec safe_e_rec safe = function safe | Psub (access, ws, len, x, e) -> + let len = + match len with + | Const len -> len + | _ -> assert false + in in_bound x.gv access ws e len @ (* Remark that we do not have to check initialization for sub-arrays. *) (* Note that the length is scaled with the word-size, so we only @@ -392,6 +398,11 @@ let safe_lval = function safe_e_rec [] e | Lasub(access,ws,len,x,e) -> + let len = + match len with + | Const len -> len + | _ -> assert false + in in_bound x access ws e len @ arr_aligned (* x *) access ws e @ safe_e_rec [] e @@ -423,10 +434,15 @@ let safe_opn pd asmOp safe opn es = let n = Papp2 (Omod (Unsigned, Op_int), n, Pconst (Z.of_int 32)) in [ InRange(Pconst (Conv.z_of_cz lo), Pconst (Conv.z_of_cz hi), n) ] | Wsize.AllInit(ws, p, i) -> + let p = + match p with + | Type.ALConst p -> p + | _ -> assert false + in let e = List.nth es (Conv.int_of_nat i) in let y = match e with Pvar y -> y | _ -> assert false in List.flatten - (List.init (Conv.int_of_pos p) (fun i -> init_get y Warray_.AAscale ws (Pconst (Z.of_int i)) 1)) + (List.init (CoreConv.int_of_cz p) (fun i -> init_get y Warray_.AAscale ws (Pconst (Z.of_int i)) 1)) | NotZero (sz, n) -> [ notZero(sz, List.nth es (Conv.int_of_nat n)) ] @@ -471,7 +487,7 @@ let safe_instr pd asmOp ginstr = match ginstr.i_desc with | Cassert (_, e) -> safe_eassert [] e | Cif(e, _, _) -> safe_e e | Cwhile(_, _, _, _, _) -> [] (* We check the while condition later. *) - | Ccall(lvs, _, es) | Csyscall(lvs, _, es) -> safe_lvals lvs @ safe_es es + | Ccall(lvs, _, _, es) | Csyscall(lvs, _, _, es) -> safe_lvals lvs @ safe_es es | Cfor (_, (_, e1, e2), _) -> safe_es [e1;e2] let safe_return main_decl = @@ -1275,14 +1291,14 @@ end = struct let rec nm_i vs_for i = match i.i_desc with | Cassgn (lv, _, _, e) -> nm_lv vs_for lv && nm_e vs_for e | Copn (lvs, _, _, es) -> nm_lvs vs_for lvs && nm_es vs_for es - | Csyscall(lvs, _ ,es) -> nm_lvs vs_for lvs && nm_es vs_for es + | Csyscall(lvs, _, _, es) -> nm_lvs vs_for lvs && nm_es vs_for es | Cassert(_, e) -> nm_a vs_for e | Cif (e, st, st') -> nm_e vs_for e && nm_stmt vs_for st && nm_stmt vs_for st' | Cfor (i, _, st) -> nm_stmt (i :: vs_for) st | Cwhile (_, st1, e, _, st2) -> nm_e vs_for e && nm_stmt vs_for st1 && nm_stmt vs_for st2 - | Ccall (lvs, fn, es) -> + | Ccall (lvs, fn, _al, es) -> let f' = get_fun_def prog fn |> oget in nm_lvs vs_for lvs && nm_es vs_for es && nm_fdecl f' @@ -1420,10 +1436,15 @@ end = struct let x = L.unloc x in List.init (Conv.int_of_pos n) (fun i -> SafetyVar.AarraySlice (x, U8, ofs + i)) - let aeval_syscall state sc lvs _es = + let aeval_syscall state sc lvs al _es = match sc with - | Syscall_t.RandomBytes (ws, len) -> - let n = BinInt.Z.to_pos (Type.arr_size ws len) in + | Syscall.RandomBytes -> + let len = + match al with + | [ Prog.Const len ] -> len + | _ -> assert false (* FIXME: deal with non-constant cases *) + in + let n = Conv.pos_of_int (Prog.arr_size U8 len) in let cells = match lvs with | [ Lnone _ ] -> [] | [ Lvar x ] -> cells_of_array x 0 n @@ -1496,8 +1517,8 @@ end = struct { state with abs = abs; } end - | Csyscall(lvs, sc, es) -> - aeval_syscall state sc lvs es + | Csyscall(lvs, sc, al, es) -> + aeval_syscall state sc lvs al es | Cassert _ -> state @@ -1724,7 +1745,7 @@ end = struct { state with abs = abs; } - | Ccall(lvs, f, es) -> + | Ccall(lvs, f, _al, es) -> let f_decl = get_fun_def state.prog f |> oget in let fn = f_decl.f_name in diff --git a/compiler/safetylib/safetyPreanalysis.ml b/compiler/safetylib/safetyPreanalysis.ml index 7b16cb49e1..4f2b9f6b7d 100644 --- a/compiler/safetylib/safetyPreanalysis.ml +++ b/compiler/safetylib/safetyPreanalysis.ml @@ -88,14 +88,14 @@ end = struct Copn (mk_lvals fn lvls, tag, opn, mk_exprs fn exprs) | Cassert (msg, e) -> Cassert (msg, mk_eassert fn e) - | Csyscall (lvls, o, exprs) -> - Csyscall(mk_lvals fn lvls, o, mk_exprs fn exprs) + | Csyscall (lvls, o, als, exprs) -> + Csyscall(mk_lvals fn lvls, o, als, mk_exprs fn exprs) | Cif (e, st, st') -> Cif (mk_expr fn e, mk_stmt fn st, mk_stmt fn st') | Cfor (v, r, st) -> Cfor (mk_v_loc fn v, mk_range fn r, mk_stmt fn st) - | Ccall (lvs, c_fn, es) -> - Ccall (mk_lvals fn lvs, c_fn, mk_exprs fn es) + | Ccall (lvs, c_fn, al, es) -> + Ccall (mk_lvals fn lvs, c_fn, al, mk_exprs fn es) | Cwhile (a, st1, e, (info, _), st2) -> Cwhile (a, mk_stmt fn st1, mk_expr fn e, (info, mk_info ()), mk_stmt fn st2) @@ -382,14 +382,14 @@ end = struct | Cwhile (_, c1, _, _, c2) -> pa_flag_setfrom v (List.rev_append c1 (List.rev c2)) - | Ccall (lvs, _, _) | Csyscall(lvs, _, _) -> + | Ccall (lvs, _, _, _) | Csyscall(lvs, _, _, _) -> if flag_mem_lvs v lvs then raise Flag_set_from_failure else None let rec pa_instr fn (prog : ('info, 'asm) prog option) st instr = match instr.i_desc with | Cassgn (lv, _, _, e) -> pa_lv st lv e - | Copn (lvs, _, _, es) | Csyscall(lvs, _, es) -> List.fold_left (fun st lv -> + | Copn (lvs, _, _, es) | Csyscall(lvs, _, _, es) -> List.fold_left (fun st lv -> List.fold_left (fun st e -> pa_lv st lv e) st es) st lvs | Cassert _ -> st @@ -447,7 +447,7 @@ end = struct pa_stmt fn prog st' (List.append c1 c2) |> set_ct st.ct - | Ccall (lvs, fn', es) -> + | Ccall (lvs, fn', _al, es) -> let st = { st with cfg = add_call st.cfg fn fn' } in let f_decl = get_fun_def (oget prog) fn' |> oget in @@ -559,7 +559,7 @@ end = struct | Cfor (v,(_,e1,e2),st) -> let sv = collect_vars_is (Sv.add (L.unloc v) sv) st in collect_vars_es sv [e1;e2] - | Copn (lvs, _, _, es) | Csyscall(lvs, _, es) -> + | Copn (lvs, _, _, es) | Csyscall(lvs, _, _, es) -> let sv = collect_vars_lvs sv lvs in collect_vars_es sv es | Cassgn (lv, _, _, e) -> diff --git a/compiler/safetylib/safetyVar.ml b/compiler/safetylib/safetyVar.ml index 9f18cabe06..44a3a64d91 100644 --- a/compiler/safetylib/safetyVar.ml +++ b/compiler/safetylib/safetyVar.ml @@ -34,7 +34,7 @@ type mvar = (* Must the variable [v] be handled as a weak variable. *) let weak_update v = let weak_update_kind = function - | Const -> assert false (* should not happen *) + | Const | Length -> assert false (* should not happen *) | Stack _ | Reg _ | Inline @@ -103,7 +103,7 @@ let mvar_ignore = function | _ -> false (*---------------------------------------------------------------*) -let arr_range (v : var) : int = match v.v_ty with +let arr_range (v : var) : length = match v.v_ty with | Arr (_,i) -> i | _ -> assert false @@ -169,7 +169,7 @@ let mvar_of_scoped_var (s : Expr.v_scope) (uv : var) = of_scope s at -let mvar_of_var (v : int Prog.ggvar) = +let mvar_of_var (v : length Prog.ggvar) = mvar_of_scoped_var v.gs (L.unloc v.gv) (*---------------------------------------------------------------*) @@ -180,6 +180,11 @@ let u8_blast_at ~blast_arrays scope at = if blast_arrays then let iws = size_of_ws (arr_size v) in let r = arr_range v in + let r = + match r with + | Const r -> r + | _ -> assert false + in let vi i = AarraySlice (v,U8,i) in List.init (r * iws) vi else [at] @@ -211,6 +216,11 @@ let rec expand_arr_vars = function match v.v_ty with | Bty _ -> assert false | Arr (ws, n) -> + let n = + match n with + | Const n -> n + | _ -> assert false + in let wsz = size_of_ws ws in List.init n (fun i -> of_scope scope (AarraySlice (v,ws,wsz * i))) @ expand_arr_vars t diff --git a/compiler/safetylib/safetyVar.mli b/compiler/safetylib/safetyVar.mli index 034f71401b..2128dfa3df 100644 --- a/compiler/safetylib/safetyVar.mli +++ b/compiler/safetylib/safetyVar.mli @@ -41,7 +41,7 @@ val variables_ignore : Apron.Var.t -> bool val mvar_ignore : mvar -> bool (*---------------------------------------------------------------*) -val arr_range : var -> int +val arr_range : var -> length val arr_size : var -> wsize val ty_mvar : mvar -> ty @@ -62,7 +62,7 @@ val mvar_of_svar : string -> mvar val mvar_of_avar : Apron.Var.t -> mvar val mvar_of_scoped_var : Expr.v_scope -> Prog.var -> mvar -val mvar_of_var : int Prog.ggvar -> mvar +val mvar_of_var : length Prog.ggvar -> mvar (*---------------------------------------------------------------*) diff --git a/compiler/src/alias.ml b/compiler/src/alias.ml index fe7c7e6836..76ad32b614 100644 --- a/compiler/src/alias.ml +++ b/compiler/src/alias.ml @@ -1,7 +1,7 @@ open Utils open Printer -open Prog open Wsize +open Prog let hierror = hierror ~kind:"compilation error" ~sub_kind:"stack allocation" (* Most of the errors have no location initially, but they are added later @@ -15,7 +15,15 @@ type sub_slice_kind = (* the precise offset is not known, we remember that it is a subpart and its alignment *) -type slice = { in_var : var ; scope : E.v_scope ; range : int * int; kind : sub_slice_kind } +type slice = { in_var : var ; scope : E.v_scope ; range : int * length; kind : sub_slice_kind } +(* range: the high part of a slice can be a [length] expression. + This high part is used only when it is [Const], to perform some checks. *) + +let eq_slice s1 s2 = + let eq_range (n1, len1) (n2, len2) = + n1 = n2 && compare_array_length (U8, len1) (U8, len2) + in + s1.in_var = s2.in_var && s1.scope = s2.scope && eq_range s1.range s2.range && s1.kind = s2.kind type alias = slice Mv.t @@ -26,7 +34,7 @@ let pp_scope fmt s = Format.fprintf fmt "%s" (if s = E.Slocal then "" else "#g:") let pp_range fmt (lo, hi) = - Format.fprintf fmt "%d; %d" lo hi + Format.fprintf fmt "%d; %a" lo (Printer.pp_len ~debug:false) hi let pp_slice fmt s = match s.kind with @@ -56,15 +64,25 @@ let align_of_offset lo = let wsize_min = Utils0.cmp_min wsize_cmp +let add_int_length n len = + match len with + | Const len -> Const (n + len) + | _ -> Add (Const n, len) + let range_in_slice (lo, hi) kind s = match kind, s.kind with | Exact, Exact -> let (u, v) = s.range in - if u + hi <= v - then { s with range = u + lo, u + hi } - else - hierror_no_loc "cannot access the subarray [%a[ of %a, the access overflows, your program is probably unsafe" - pp_range (lo, hi) pp_slice s + let () = + begin match hi, v with + | Const hi', Const v' -> + if not (u + hi' <= v') then + hierror_no_loc "cannot access the subarray [%a[ of %a, the access overflows, your program is probably unsafe" + pp_range (lo, hi) pp_slice s + | _ -> () + end + in + { s with range = u + lo, add_int_length u hi } | Sub ws, Exact -> { s with kind = Sub (wsize_min ws (align_of_offset (fst s.range))) } | Exact, Sub ws -> @@ -119,9 +137,12 @@ let incl a1 a2 = (* Partial order on variables, by scope and size *) let compare_gvar params x gx y gy = let check_size kind x1 s1 x2 s2 = - if not (s1 <= s2) then - hierror_no_loc "cannot merge a %s and a local that is larger (%a of size %i, and %a of size %i)" - kind pp_var x2 s2 pp_var x1 s1 + match s1, s2 with + | Const s1, Const s2 -> + if not (s1 <= s2) then + hierror_no_loc "cannot merge a %s and a local that is larger (%a of size %i, and %a of size %i)" + kind pp_var x2 s2 pp_var x1 s1 + | _ -> () in if V.equal x y @@ -147,13 +168,21 @@ let compare_gvar params x gx y gy = | true, false -> check_size "param" y sy x sx; 1 | false, true -> check_size "param" x sx y sy; -1 | false, false -> - let c = Stdlib.Int.compare sx sy in - if c = 0 then - match is_ptr x.v_kind, is_ptr y.v_kind with - | true, false -> -1 - | false, true -> 1 - | _, _ -> V.compare x y - else c + begin match sx, sy with + | Const sx, Const sy -> + let c = Stdlib.Int.compare sx sy in + if c = 0 then + match is_ptr x.v_kind, is_ptr y.v_kind with + | true, false -> -1 + | false, true -> 1 + | _, _ -> V.compare x y + else c + | _ -> + Format.eprintf "%a vs %a@." + (Printer.pp_var ~debug:true) x + (Printer.pp_var ~debug:true) y; + assert false + end (* Precondition: s1 and s2 are normal forms (aka roots) in a *) (* x1[e1:n1] = x2[e2:n2] *) @@ -171,8 +200,8 @@ let merge_slices params a s1 s2 = let x = s1.in_var in let y = s2.in_var in let lo = fst s2.range - fst s1.range in - let hi = lo + size_of x.v_ty in - if lo < 0 || size_of y.v_ty < hi + let hi = add_int_length lo (size_of x.v_ty) in + if lo < 0 || begin match size_of y.v_ty, hi with | Const n, Const hi -> n < hi | _ -> false end then hierror_no_loc "merging slices %a and %a may introduce invalid accesses; consider declaring variable %a smaller" pp_slice s1 pp_slice s2 pp_var x; Mv.add x { s2 with range = lo, hi; kind = s1.kind } a @@ -184,6 +213,11 @@ let merge params a1 a2 = merge_slices params a s1 s2 ) a1 a2 +let arr_size ws len = + match len with + | Const len -> Const (arr_size ws len) + | _ -> Mul (Const (size_of_ws ws), len) + let range_of_asub aa ws len _gv i = match get_ofs aa ws i with | None -> @@ -195,7 +229,7 @@ let range_of_asub aa ws len _gv i = end in range, kind - | Some start -> (start, start + arr_size ws len), Exact + | Some start -> (start, add_int_length start (arr_size ws len)), Exact let normalize_asub a aa ws len x i = let s = normalize_gvar a x in @@ -222,9 +256,9 @@ let assign_arr params a x e = | None, _ | _, None -> a | Some d, Some s -> merge_slices params a d s -let syscall_cc (o : 'a Syscall_t.syscall_t) = +let syscall_cc (o : Syscall.syscall_t) = match o with - | Syscall_t.RandomBytes _ -> [Some 0] + | Syscall.RandomBytes -> [Some 0] let link_array_return params a xs es cc = List.fold_left2 (fun a x -> @@ -243,8 +277,8 @@ let opn_cc o = let rec analyze_instr_r params cc a = function | Cfor _ -> assert false - | Ccall (xs, fn, es) -> link_array_return params a xs es (cc fn) - | Csyscall (xs, o, es) -> link_array_return params a xs es (syscall_cc o) + | Ccall (xs, fn, _al, es) -> link_array_return params a xs es (cc fn) + | Csyscall (xs, o, _al, es) -> link_array_return params a xs es (syscall_cc o) | Cassgn (x, _, ty, e) -> if is_ty_arr ty then assign_arr params a x e else a | Copn (xs, _, o, es) -> (* A special case for operators that can return array *) diff --git a/compiler/src/alias.mli b/compiler/src/alias.mli index 25f32ee807..51022159b1 100644 --- a/compiler/src/alias.mli +++ b/compiler/src/alias.mli @@ -7,7 +7,7 @@ type sub_slice_kind = (* the precise offset is not known, we remember that it is a subpart and its alignment *) -type slice = { in_var : var ; scope : E.v_scope ; range : int * int; kind : sub_slice_kind } +type slice = { in_var : var ; scope : E.v_scope ; range : int * length; kind : sub_slice_kind } type alias = slice Mv.t @@ -20,3 +20,5 @@ val classes : alias -> Sv.t Mv.t val pp_slice : Format.formatter -> slice -> unit val pp_alias : Format.formatter -> alias -> unit + +val eq_slice : slice -> slice -> bool diff --git a/compiler/src/array_expand.ml b/compiler/src/array_expand.ml index 2997daf147..3d01bcbad0 100644 --- a/compiler/src/array_expand.ml +++ b/compiler/src/array_expand.ml @@ -4,12 +4,16 @@ open Prog let init_tbl fc = let tbl = Hv.create 107 in let init_var (v:var) = - let ws, sz = array_kind v.v_ty in - let ty = Bty (U ws) in - let vi i = - V.mk (v.v_name ^ "#" ^ string_of_int i) (Reg(reg_kind v.v_kind, Direct)) ty v.v_dloc v.v_annot in - let t = Array.init sz vi in - Hv.add tbl v (ws, t) in + let ws, len = array_kind v.v_ty in + match len with + | Const len -> + let ty = Bty (U ws) in + let vi i = + V.mk (v.v_name ^ "#" ^ string_of_int i) (Reg(reg_kind v.v_kind, Direct)) ty v.v_dloc v.v_annot in + let t = Array.init len vi in + Hv.add tbl v (ws, t) + | _ -> () + in let fv = vars_fc fc in let arrs = Sv.filter is_reg_arr (vars_fc fc) in let vars = Sv.diff fv arrs in diff --git a/compiler/src/asm_utils.ml b/compiler/src/asm_utils.ml index c2c26a9c68..5c35944e26 100644 --- a/compiler/src/asm_utils.ml +++ b/compiler/src/asm_utils.ml @@ -6,9 +6,9 @@ open PrintASM let global_datas_label = "glob_data" -let pp_syscall (o : _ Syscall_t.syscall_t) = +let pp_syscall (o : Syscall.syscall_t) = match o with - | Syscall_t.RandomBytes _ -> "__jasmin_syscall_randombytes__" + | Syscall.RandomBytes -> "__jasmin_syscall_randombytes__" let string_of_label name p = Format.asprintf "L%s$%a" (escape name) Z.pp_print (Conv.z_of_pos p) diff --git a/compiler/src/asm_utils.mli b/compiler/src/asm_utils.mli index 31cfabeff0..77ed66895e 100644 --- a/compiler/src/asm_utils.mli +++ b/compiler/src/asm_utils.mli @@ -1,5 +1,5 @@ val global_datas_label : string -val pp_syscall : 'a Syscall_t.syscall_t -> string +val pp_syscall : Syscall.syscall_t -> string val string_of_label : string -> Label.label -> string val pp_remote_label : Label.remote_label -> string val mangle : string -> string diff --git a/compiler/src/autoSpill.ml b/compiler/src/autoSpill.ml index d4cc305da7..c30f78b5aa 100644 --- a/compiler/src/autoSpill.ml +++ b/compiler/src/autoSpill.ml @@ -40,7 +40,7 @@ let vars_lv = function let vars_i = function | Cassgn (x, _, _, e) -> Sv.union (vars_lv x) (vars_e e) - | Copn (xs, _, _, es) | Csyscall (xs, _, es) | Ccall (xs, _, es) -> + | Copn (xs, _, _, es) | Csyscall (xs, _, _, es) | Ccall (xs, _, _, es) -> List.fold Sv.union (vars_es es) (List.map vars_lv xs) | Cassert (_, e) -> vars_a e | Cfor _ | Cif _ | Cwhile _ -> assert false diff --git a/compiler/src/compile.ml b/compiler/src/compile.ml index 8a231f21ea..c209418be4 100644 --- a/compiler/src/compile.ml +++ b/compiler/src/compile.ml @@ -2,11 +2,13 @@ open Utils open Prog open Glob_options +let syscall_length_ident = Conv.fresh_var_ident Length IInfo.dummy (Uint63.of_int 0) "N" Coq_aint + let preprocess pd msfsize asmOp p = let p = p |> Subst.remove_params |> Insert_copy_and_fix_length.doit pd in - Typing.check_prog pd msfsize asmOp p; + Typing.check_prog pd msfsize asmOp syscall_length_ident p; p (* -------------------------------------------------------------------- *) @@ -26,7 +28,7 @@ let get_jasminpath () = let parse_file arch_info ?(idirs=[]) fname = let idirs = idirs @ get_jasminpath () in let env = List.fold_left Pretyping.Env.add_from Pretyping.Env.empty idirs in - Pretyping.tt_program arch_info env fname + Pretyping.tt_program arch_info syscall_length_ident env fname (* -------------------------------------------------------------------- *) let rec warn_extra_i pd msfsize asmOp i = @@ -102,13 +104,14 @@ let do_wint_int Conv.csv_of_sv fv ,info in let cp = Conv.cuprog_of_prog prog in - let cp = Wint_int.wi2i_prog Arch.asmOp Arch.pointer_data Arch.msf_size get_info cp in + let cp = Wint_int.wi2i_prog Arch.asmOp Arch.pointer_data Arch.msf_size syscall_length_ident get_info cp in let cp = catch_error cp in let (gd, fdso) = Conv.prog_of_cuprog cp in (* Restore type of array in the functions signature *) + (* FIXME: is this needed now that we preserve ws on Rocq's side? *) let restore_ty tyi tyo = match tyi, tyo with - | Arr(ws1, l1), Arr(ws2, l2) -> assert (arr_size ws1 l1 = arr_size ws2 l2); tyi + | Arr(ws1, Const l1), Arr(ws2, Const l2) -> assert (arr_size ws1 l1 = arr_size ws2 l2); tyi | Bty (U _), Bty Int -> tyo | _, _ -> assert (tyi = tyo); tyo in @@ -429,6 +432,7 @@ let compile (type reg regx xreg rflag cond asm_op extra_op) Compiler.dead_vars_ufd; Compiler.dead_vars_sfd; Compiler.pp_sr; + Compiler.syscall_length_ident; } in diff --git a/compiler/src/compile.mli b/compiler/src/compile.mli index 7f2bd7c512..5cc60b8b44 100644 --- a/compiler/src/compile.mli +++ b/compiler/src/compile.mli @@ -2,8 +2,10 @@ open Prog open Wsize open Sopn +val syscall_length_ident : Type.length_var + val preprocess : - wsize -> wsize -> 'asm asmOp -> (unit, 'asm) pprog -> (unit, 'asm) prog + wsize -> wsize -> 'asm asmOp -> (unit, 'asm) mod_item list -> (unit, 'asm) prog (** Preprocessing before translation to Coq representation: - substitution of parameters; - inserts `#copy` operators where needed; @@ -27,7 +29,7 @@ val parse_file : 'asm_op, 'extra_op ) Arch_extra.extended_op ) - pmod_item + mod_item list * Syntax.pprogram (** Parsing and pre-typing of a complete file. Require directives are resolved diff --git a/compiler/src/conv.ml b/compiler/src/conv.ml index 7cafe205ac..9f239dcbc7 100644 --- a/compiler/src/conv.ml +++ b/compiler/src/conv.ml @@ -33,17 +33,45 @@ let z_unsigned_of_word sz z = z_of_cz (Word0.wunsigned sz z) (* ------------------------------------------------------------------------ *) +let rec al_of_cal cal = + let open Type in + match cal with + | ALConst n -> Const (int_of_cz n) + | ALVar x -> Var x + | ALNeg al -> Neg (al_of_cal al) + | ALAdd (al1, al2) -> Add (al_of_cal al1, al_of_cal al2) + | ALSub (al1, al2) -> Sub (al_of_cal al1, al_of_cal al2) + | ALMul (al1, al2) -> Mul (al_of_cal al1, al_of_cal al2) + | ALDiv (sg, al1, al2) -> Div (sg, al_of_cal al1, al_of_cal al2) + | ALMod (sg, al1, al2) -> Mod (sg, al_of_cal al1, al_of_cal al2) + | ALShl (al1, al2) -> Shl (al_of_cal al1, al_of_cal al2) + | ALShr (al1, al2) -> Shr (al_of_cal al1, al_of_cal al2) + +let rec cal_of_al al = + let open Type in + match al with + | Const n -> ALConst (cz_of_int n) + | Var x -> ALVar x + | Neg al -> ALNeg (cal_of_al al) + | Add (al1, al2) -> ALAdd (cal_of_al al1, cal_of_al al2) + | Sub (al1, al2) -> ALSub (cal_of_al al1, cal_of_al al2) + | Mul (al1, al2) -> ALMul (cal_of_al al1, cal_of_al al2) + | Div (sg, al1, al2) -> ALDiv (sg, cal_of_al al1, cal_of_al al2) + | Mod (sg, al1, al2) -> ALMod (sg, cal_of_al al1, cal_of_al al2) + | Shl (al1, al2) -> ALShl (cal_of_al al1, cal_of_al al2) + | Shr (al1, al2) -> ALShr (cal_of_al al1, cal_of_al al2) + let cty_of_ty = function | Bty Bool -> T.Coq_abool | Bty Int -> T.Coq_aint | Bty (U sz) -> T.Coq_aword(sz) - | Arr (sz, len) -> T.Coq_aarr (sz, pos_of_int len) + | Arr (sz, len) -> T.Coq_aarr (sz, cal_of_al len) let ty_of_cty = function | T.Coq_abool -> Bty Bool | T.Coq_aint -> Bty Int | T.Coq_aword sz -> Bty (U sz) - | T.Coq_aarr (sz, len) -> Arr (sz, int_of_pos len) + | T.Coq_aarr (sz, len) -> Arr (sz, al_of_cal len) (* ------------------------------------------------------------------------ *) @@ -85,11 +113,11 @@ let gvari_of_cgvari v = let rec cexpr_of_expr = function | Pconst z -> C.Pconst (cz_of_z z) | Pbool b -> C.Pbool b - | Parr_init (ws, n) -> C.Parr_init (ws, pos_of_int n) + | Parr_init (ws, n) -> C.Parr_init (ws, cal_of_al n) | Pvar x -> C.Pvar (cgvari_of_gvari x) | Pget (al, aa,ws, x,e) -> C.Pget (al, aa, ws, cgvari_of_gvari x, cexpr_of_expr e) | Psub (aa,ws,len, x,e) -> - C.Psub (aa, ws, pos_of_int len, cgvari_of_gvari x, cexpr_of_expr e) + C.Psub (aa, ws, cal_of_al len, cgvari_of_gvari x, cexpr_of_expr e) | Pload (al, ws, e) -> C.Pload(al, ws, cexpr_of_expr e) | Papp1 (o, e) -> C.Papp1(o, cexpr_of_expr e) | Papp2 (o, e1, e2) -> C.Papp2(o, cexpr_of_expr e1, cexpr_of_expr e2) @@ -102,10 +130,10 @@ let rec cexpr_of_expr = function let rec expr_of_cexpr = function | C.Pconst z -> Pconst (z_of_cz z) | C.Pbool b -> Pbool b - | C.Parr_init (ws, n) -> Parr_init (ws, int_of_pos n) + | C.Parr_init (ws, n) -> Parr_init (ws, al_of_cal n) | C.Pvar x -> Pvar (gvari_of_cgvari x) | C.Pget (al, aa,ws, x,e) -> Pget (al, aa, ws, gvari_of_cgvari x, expr_of_cexpr e) - | C.Psub (aa,ws,len,x,e) -> Psub (aa, ws, int_of_pos len, gvari_of_cgvari x, expr_of_cexpr e) + | C.Psub (aa,ws,len,x,e) -> Psub (aa, ws, al_of_cal len, gvari_of_cgvari x, expr_of_cexpr e) | C.Pload (al, ws, e) -> Pload(al, ws, expr_of_cexpr e) | C.Papp1 (o, e) -> Papp1(o, expr_of_cexpr e) | C.Papp2 (o, e1, e2) -> Papp2(o, expr_of_cexpr e1, expr_of_cexpr e2) @@ -123,7 +151,7 @@ let clval_of_lval = function | Lmem (al, ws, loc, e) -> C.Lmem (al, ws, loc, cexpr_of_expr e) | Laset(al, aa,ws,x,e)-> C.Laset (al, aa, ws, cvari_of_vari x, cexpr_of_expr e) | Lasub(aa,ws,len,x,e)-> - C.Lasub (aa, ws, pos_of_int len, cvari_of_vari x, cexpr_of_expr e) + C.Lasub (aa, ws, cal_of_al len, cvari_of_vari x, cexpr_of_expr e) let lval_of_clval = function | C.Lnone(loc, ty) -> Lnone (loc, ty_of_cty ty) @@ -131,7 +159,7 @@ let lval_of_clval = function | C.Lmem(al,ws,loc,e) -> Lmem (al, ws, loc, expr_of_cexpr e) | C.Laset(al, aa,ws,x,e) -> Laset (al, aa,ws, vari_of_cvari x, expr_of_cexpr e) | C.Lasub(aa,ws,len,x,e) -> - Lasub (aa,ws, int_of_pos len, vari_of_cvari x, expr_of_cexpr e) + Lasub (aa,ws, al_of_cal len, vari_of_cvari x, expr_of_cexpr e) (* ------------------------------------------------------------------------ *) @@ -165,7 +193,6 @@ let cassertion_of_assertions = List.map cassertion_of_assertion let assertion_of_cassertions = List.map assertion_of_cassertion (* ------------------------------------------------------------------------ *) - let rec cinstr_of_instr i = let n = i.i_loc, i.i_annot in cinstr_r_of_instr_r n i.i_desc @@ -182,9 +209,9 @@ and cinstr_r_of_instr_r p i = C.Copn(clval_of_lvals x, t, o, cexpr_of_exprs e) in C.MkI(p, ir) - | Csyscall(x,o,e) -> + | Csyscall(x,o,al,e) -> let ir = - C.Csyscall(clval_of_lvals x, o, cexpr_of_exprs e) in + C.Csyscall(clval_of_lvals x, o, List.map cal_of_al al, cexpr_of_exprs e) in C.MkI(p, ir) | Cassert (msg, e) -> @@ -207,8 +234,8 @@ and cinstr_r_of_instr_r p i = let ir = C.Cwhile(a, cstmt_of_stmt c, cexpr_of_expr e, info, cstmt_of_stmt c') in C.MkI(p,ir) - | Ccall(x, f, e) -> - let ir = C.Ccall(clval_of_lvals x, f, cexpr_of_exprs e) in + | Ccall(x, f, al, e) -> + let ir = C.Ccall(clval_of_lvals x, f, List.map cal_of_al al, cexpr_of_exprs e) in C.MkI(p,ir) and cstmt_of_stmt c = @@ -228,8 +255,8 @@ and instr_r_of_cinstr_r = function | C.Copn(x,t,o,e) -> Copn(lval_of_clvals x, t, o, expr_of_cexprs e) - | C.Csyscall(x,o,e) -> - Csyscall(lval_of_clvals x, o, expr_of_cexprs e) + | C.Csyscall(x,o,al,e) -> + Csyscall(lval_of_clvals x, o, List.map al_of_cal al, expr_of_cexprs e) | C.Cassert (msg, e) -> Cassert (msg, eassert_of_ceassert e) @@ -248,8 +275,8 @@ and instr_r_of_cinstr_r = function | Cwhile(a, c, e, info, c') -> Cwhile(a, stmt_of_cstmt c, expr_of_cexpr e, (info, ()), stmt_of_cstmt c') - | Ccall(x, f, e) -> - Ccall(lval_of_clvals x, f, expr_of_cexprs e) + | Ccall(x, f, al, e) -> + Ccall(lval_of_clvals x, f, List.map al_of_cal al, expr_of_cexprs e) and stmt_of_cstmt c = List.map instr_of_cinstr c @@ -273,6 +300,7 @@ let cufdef_of_fdef fd = let f_res = List.map cvari_of_vari fd.f_ret in fn, { C.f_info = f_info; C.f_contract = Option.map ccontract_of_contract fd.f_contract; + C.f_al = fd.f_al; C.f_tyin = List.map cty_of_ty fd.f_tyin; C.f_params = f_params; C.f_body = f_body; @@ -297,6 +325,7 @@ let fdef_of_cufdef (fn, fd) = f_cc; f_info = (); f_name = fn; + f_al = fd.C.f_al; f_tyin = List.map ty_of_cty fd.C.f_tyin; f_args = List.map (fun v -> L.unloc (vari_of_cvari v)) fd.C.f_params; f_body = stmt_of_cstmt fd.C.f_body; @@ -336,7 +365,7 @@ let prog_of_csprog p = (* ---------------------------------------------------------------------------- *) let to_array ty p t = - let ws, n = array_kind ty in + let ws, n = array_kind_const ty in let get i = match Warray_.WArray.get p Aligned Warray_.AAscale ws t (cz_of_int i) with | Utils0.Ok w -> z_of_word ws w diff --git a/compiler/src/conv.mli b/compiler/src/conv.mli index ab0df82248..45d847a2ce 100644 --- a/compiler/src/conv.mli +++ b/compiler/src/conv.mli @@ -29,6 +29,8 @@ val z_of_word : wsize -> Word0.word -> Z.t val z_unsigned_of_word : wsize -> Word0.word -> Z.t (* -------------------------------------------------------------------- *) +val cal_of_al : length -> Type.array_length +val al_of_cal : Type.array_length -> length val cty_of_ty : Prog.ty -> Type.atype val ty_of_cty : Type.atype -> Prog.ty @@ -57,7 +59,7 @@ val fdef_of_csfdef : Var0.funname * 'asm Expr._sfundef -> (unit, 'asm) sfundef val prog_of_csprog : 'asm Expr._sprog -> (unit, 'asm) sprog val to_array : - Prog.ty -> BinNums.positive -> Warray_.WArray.array -> wsize * Z.t array + Prog.ty -> BinNums.coq_Z -> Warray_.WArray.array -> wsize * Z.t array val error_of_cerror : (Format.formatter -> Compiler_util.pp_error -> unit) -> diff --git a/compiler/src/coreIdent.ml b/compiler/src/coreIdent.ml index 487d18ccc5..0b58b67765 100644 --- a/compiler/src/coreIdent.ml +++ b/compiler/src/coreIdent.ml @@ -83,16 +83,62 @@ module GV = struct let hash v = Uint63.hash v.v_id - let is_glob v = v.v_kind = Const - - let is_local v = not (is_glob v) + let is_length_var v = v.v_kind = Length + + (* if the type of the var is a base type, the var can be cast to any type *) + let cast v = + let ty = + match v.v_ty with + | Bty _ as ty -> ty + | _ -> assert false + in + { v with v_ty = ty } end (* ------------------------------------------------------------------------ *) (* Non parametrized variable *) -type ty = int gty -type var = int gvar +type length = + | Const of int (* FIXME: Z.t ? *) + | Var of length gvar + | Neg of length + | Add of length * length + | Sub of length * length + | Mul of length * length + | Div of signedness * length * length + | Mod of signedness * length * length + | Shl of length * length + | Shr of length * length + +type ty = length gty +type var = length gvar + +let rec subst_al (f : var -> length option) al = + match al with + | Const _ -> al + | Var x -> + begin match f x with + | None -> al + | Some al' -> al' + end + | Neg al -> Neg (subst_al f al) + | Add (al1, al2) -> Add (subst_al f al1, subst_al f al2) + | Sub (al1, al2) -> Sub (subst_al f al1, subst_al f al2) + | Mul (al1, al2) -> Mul (subst_al f al1, subst_al f al2) + | Div (sg, al1, al2) -> Div (sg, subst_al f al1, subst_al f al2) + | Mod (sg, al1, al2) -> Mod (sg, subst_al f al1, subst_al f al2) + | Shl (al1, al2) -> Shl (subst_al f al1, subst_al f al2) + | Shr (al1, al2) -> Shr (subst_al f al1, subst_al f al2) + +let subst_ety f ty = + match ty with + | ETarr (ws, len) -> ETarr (ws, subst_al f len) + | _ -> ty + +let subst_ty f ty = + match ty with + | Arr (ws, len) -> Arr (ws, subst_al f len) + | _ -> ty module V = struct type t = var diff --git a/compiler/src/coreIdent.mli b/compiler/src/coreIdent.mli index 028e6bc96e..b679bde72d 100644 --- a/compiler/src/coreIdent.mli +++ b/compiler/src/coreIdent.mli @@ -73,18 +73,32 @@ module GV : sig val hash : 'len gvar -> int - val is_glob : 'len gvar -> bool - - (* Fixme : still used *) - val is_local : 'len gvar -> bool + val is_length_var : 'len gvar -> bool + val cast : 'len1 gvar -> 'len2 gvar end (* ------------------------------------------------------------------------ *) (* Non parametrized variable *) -type ty = int gty -type var = int gvar +type length = + | Const of int (* FIXME: Z.t ? *) + | Var of length gvar + | Neg of length + | Add of length * length + | Sub of length * length + | Mul of length * length + | Div of signedness * length * length + | Mod of signedness * length * length + | Shl of length * length + | Shr of length * length + +type ty = length gty +type var = length gvar + +val subst_al : (var -> length option) -> length -> length +val subst_ety : (var -> length option) -> length gety -> length gety +val subst_ty : (var -> length option) -> ty -> ty module V : sig type t = var @@ -99,10 +113,7 @@ module V : sig val hash : var -> int - val is_glob : var -> bool - - (* Fixme : still used *) - val is_local : var -> bool + val is_length_var : var -> bool end (* Cident *) diff --git a/compiler/src/ct_checker_forward.ml b/compiler/src/ct_checker_forward.ml index 1a88f832d5..0f5ea5b542 100644 --- a/compiler/src/ct_checker_forward.ml +++ b/compiler/src/ct_checker_forward.ml @@ -171,7 +171,7 @@ module Env : sig val le : env -> env -> bool val get : public:bool -> env -> var_i -> env * Lvl.t - val gget : public:bool -> env -> int ggvar -> env * Lvl.t + val gget : public:bool -> env -> length ggvar -> env * Lvl.t val pp : Format.formatter -> env -> unit end = struct @@ -557,7 +557,7 @@ let rec ty_instr is_ct_asm fenv env i = let env, lvl = ty_exprs_max ~public env es in ty_lvals1 env xs (declassify_lvl ~loc i.i_annot lvl) - | Csyscall(xs, RandomBytes _, es) -> + | Csyscall(xs, RandomBytes, _al, es) -> let env, _ = ty_exprs_max ~public:true env es in ty_lvals1 env xs (declassify_lvl ~loc i.i_annot Secret) @@ -594,7 +594,7 @@ let rec ty_instr is_ct_asm fenv env i = else loop (Env.max env2 env) in loop env - | Ccall (xs, f, es) -> + | Ccall (xs, f, _al, es) -> let fty = get_fun is_ct_asm fenv f in (* Check the arguments *) let do_e env e lvl = ty_expr ~public:(lvl=Public) env e in diff --git a/compiler/src/dune b/compiler/src/dune index fb94b0812d..1a1b71ace6 100644 --- a/compiler/src/dune +++ b/compiler/src/dune @@ -4,7 +4,7 @@ (modules lexer)) (menhir - (flags "--table" "--explain" "--inspection" "--strict") + (flags "--table" "--inspection" "--strict") (modules parser)) (rule diff --git a/compiler/src/evaluator.ml b/compiler/src/evaluator.ml index 55ae18bfef..475654781e 100644 --- a/compiler/src/evaluator.ml +++ b/compiler/src/evaluator.ml @@ -54,42 +54,42 @@ exception Final of Memory.mem * values let withassert = Sem_params.withassert -let exec_pre ep spp ii fc gd escs emem (vargs:value list) = - let s1 = exn_exec ii (write_vars nosubword ep true fc.f_iparams vargs {escs; emem; evm = Vm.init nosubword}) in - List.iter (fun pa -> exn_exec ii (sem_assert nosubword withassert ep spp gd s1 pa)) fc.f_pre +let exec_pre ep spp env ii fc gd escs emem (vargs:value list) = + let s1 = exn_exec ii (write_vars nosubword ep env true fc.f_iparams vargs {escs; emem; evm = Vm.init nosubword env}) in + List.iter (fun pa -> exn_exec ii (sem_assert nosubword withassert ep spp gd env s1 pa)) fc.f_pre -let exec_post ep spp ii fc gd escs emem (vargs:value list) (vres: value list) = - let s1 = exn_exec ii (write_vars nosubword ep true fc.f_iparams vargs {escs; emem; evm = Vm.init nosubword}) in - let s1 = exn_exec ii (write_vars nosubword ep true fc.f_ires vres s1) in - List.iter (fun pa -> exn_exec ii (sem_assert nosubword withassert ep spp gd s1 pa)) fc.f_post +let exec_post ep spp env ii fc gd escs emem (vargs:value list) (vres: value list) = + let s1 = exn_exec ii (write_vars nosubword ep env true fc.f_iparams vargs {escs; emem; evm = Vm.init nosubword env}) in + let s1 = exn_exec ii (write_vars nosubword ep env true fc.f_ires vres s1) in + List.iter (fun pa -> exn_exec ii (sem_assert nosubword withassert ep spp gd env s1 pa)) fc.f_post -let init_estate ep spp p ii fn scs0 m vargs = +let init_estate ep spp env p ii fn scs0 m vargs = let f = BatOption.get (get_fundef p.p_funcs fn) in let gd = p.p_globs in - let vargs = exn_exec ii (mapM2 ErrType truncate_val (List.map eval_atype f.f_tyin) vargs) in - BatOption.may (fun fc -> exec_pre ep spp ii fc gd scs0 m vargs) f.f_contract; - let s_estate = { escs = scs0; emem = m; evm = Vm.init nosubword} in - let s_estate = exn_exec ii (write_vars nosubword ep true f.f_params vargs s_estate) in + let vargs = exn_exec ii (mapM2 ErrType truncate_val (List.map (eval_atype env) f.f_tyin) vargs) in + BatOption.may (fun fc -> exec_pre ep spp env ii fc gd scs0 m vargs) f.f_contract; + let s_estate = { escs = scs0; emem = m; evm = Vm.init nosubword env} in + let s_estate = exn_exec ii (write_vars nosubword ep env true f.f_params vargs s_estate) in f, vargs, s_estate -let finalize_estate ep spp p ii f vargs (s: _ estate) = +let finalize_estate ep spp p ii f vargs env (s: _ estate) = let gd = p.p_globs in - let vres = exn_exec ii (mapM (fun (x:var_i) -> get_var nosubword true s.evm x.v_var) f.f_res) in - let vres = exn_exec ii (mapM2 ErrType truncate_val (List.map Type.eval_atype f.f_tyout) vres) in - BatOption.may (fun fc -> exec_post ep spp ii fc gd s.escs s.emem vargs vres) f.f_contract; + let vres = exn_exec ii (mapM (fun (x:var_i) -> get_var nosubword env true s.evm x.v_var) f.f_res) in + let vres = exn_exec ii (mapM2 ErrType truncate_val (List.map (Type.eval_atype env) f.f_tyout) vres) in + BatOption.may (fun fc -> exec_post ep spp env ii fc gd s.escs s.emem vargs vres) f.f_contract; s.escs, s.emem, vres -let return ep spp s = +let return ep spp env s = assert (s.s_cmd = []); match s.s_stk with | Sempty(ii, f, vargs) -> - let _, m, vres = finalize_estate ep spp s.s_prog ii f vargs s.s_estate in + let _, m, vres = finalize_estate ep spp s.s_prog ii f vargs env s.s_estate in raise (Final(m, vres)) | Scall(ii,f, vargs, xs,vm1,c,stk) -> - let escs, emem, vres = finalize_estate ep spp s.s_prog ii f vargs s.s_estate in + let escs, emem, vres = finalize_estate ep spp s.s_prog ii f vargs env s.s_estate in let gd = s.s_prog.p_globs in - let s1 = exn_exec ii (write_lvals nosubword ep spp true gd {escs; emem; evm = vm1 } xs vres) in + let s1 = exn_exec ii (write_lvals nosubword ep spp env true gd {escs; emem; evm = vm1 } xs vres) in { s with s_cmd = c; s_estate = s1; @@ -99,14 +99,14 @@ let return ep spp s = match ws with | [] -> { s with s_cmd = c; s_stk = stk } | w::ws -> - let s1 = exn_exec ii (write_var nosubword ep true i (Vint w) s.s_estate) in + let s1 = exn_exec ii (write_var nosubword ep env true i (Vint w) s.s_estate) in { s with s_cmd = body; s_estate = s1; s_stk = Sfor(ii, i, ws, body, c, stk) } -let small_step1 ep spp sip s = +let small_step1 ep spp sip env s = match s.s_cmd with - | [] -> return ep spp s + | [] -> return ep spp env s | i :: c -> let MkI(ii,ir) = i in let gd = s.s_prog.p_globs in @@ -114,62 +114,63 @@ let small_step1 ep spp sip s = match ir with | Cassgn(x,_,ty,e) -> - let v = exn_exec ii (sem_pexpr nosubword ep spp true gd s1 e) in - let v' = exn_exec ii (truncate_val (eval_atype ty) v) in - let s2 = exn_exec ii (write_lval nosubword ep spp true gd x v' s1) in + let v = exn_exec ii (sem_pexpr nosubword ep spp env true gd s1 e) in + let v' = exn_exec ii (truncate_val (eval_atype env ty) v) in + let s2 = exn_exec ii (write_lval nosubword ep spp env true gd x v' s1) in { s with s_cmd = c; s_estate = s2 } | Copn(xs,_,op,es) -> - let s2 = exn_exec ii (sem_sopn nosubword ep spp sip._asmop gd op s1 xs es) in + let s2 = exn_exec ii (sem_sopn nosubword ep spp sip._asmop env gd op s1 xs es) in { s with s_cmd = c; s_estate = s2 } - | Csyscall(xs,o, es) -> - let ves = exn_exec ii (sem_pexprs nosubword ep spp true gd s1 es) in + | Csyscall(xs,o,al,es) -> + let ps = List.map (eval env) al in + let ves = exn_exec ii (sem_pexprs nosubword ep spp env true gd s1 es) in + let n = assert false in (* FIXME *) let ((scs, m), vs) = - exn_exec ii (syscall_sem__ sip._sc_sem ep._pd s1.escs s1.emem o ves) in - let s2 = exn_exec ii (write_lvals nosubword ep spp true gd {escs = scs; emem = m; evm = s1.evm} xs vs) in + exn_exec ii (syscall_sem__ ep._pd sip._sc_sem n s1.escs s1.emem o ps ves) in + let s2 = exn_exec ii (write_lvals nosubword ep spp env true gd {escs = scs; emem = m; evm = s1.evm} xs vs) in { s with s_cmd = c; s_estate = s2 } | Cassert (p,a) -> - let _ = exn_exec ii (sem_assert nosubword withassert ep spp gd s1 (p, a)) in + let _ = exn_exec ii (sem_assert nosubword withassert ep spp gd env s1 (p, a)) in { s with s_cmd = c } | Cif(e,c1,c2) -> - let b = of_val_b ii (exn_exec ii (sem_pexpr nosubword ep spp true gd s1 e)) in + let b = of_val_b ii (exn_exec ii (sem_pexpr nosubword ep spp env true gd s1 e)) in let c = (if b then c1 else c2) @ c in { s with s_cmd = c } | Cfor (i,((d,lo),hi), body) -> - let vlo = of_val_z ii (exn_exec ii (sem_pexpr nosubword ep spp true gd s1 lo)) in - let vhi = of_val_z ii (exn_exec ii (sem_pexpr nosubword ep spp true gd s1 hi)) in + let vlo = of_val_z ii (exn_exec ii (sem_pexpr nosubword ep spp env true gd s1 lo)) in + let vhi = of_val_z ii (exn_exec ii (sem_pexpr nosubword ep spp env true gd s1 hi)) in let rng = wrange d vlo vhi in let s = {s with s_cmd = []; s_stk = Sfor(ii, i, rng, body, c, s.s_stk) } in - return ep spp s + return ep spp env s | Cwhile (_, c1, e, _, c2) -> { s with s_cmd = c1 @ MkI(ii, Cif(e, c2@[i],[])) :: c } - | Ccall(xs,fn,es) -> - let vargs = exn_exec ii (sem_pexprs nosubword ep spp true gd s1 es) in - let f, vargs, s_estate = init_estate ep spp s.s_prog ii fn s1.escs s1.emem vargs in + | Ccall(xs,fn,_al,es) -> + let vargs = exn_exec ii (sem_pexprs nosubword ep spp env true gd s1 es) in + let f, vargs, s_estate = init_estate ep spp env s.s_prog ii fn s1.escs s1.emem vargs in let stk = Scall(ii,f, vargs, xs, s1.evm, c, s.s_stk) in {s with s_cmd = f.f_body; s_estate; s_stk = stk } +let rec small_step ep spp sip env s = + small_step ep spp sip env (small_step1 ep spp sip env s) -let rec small_step ep spp sip s = - small_step ep spp sip (small_step1 ep spp sip s) - -let init_state ep spp p ii fn scs0 m vargs = - let f, vargs, s_estate = init_estate ep spp p ii fn scs0 m vargs in +let init_state ep spp env p ii fn scs0 m vargs = + let f, vargs, s_estate = init_estate ep spp env p ii fn scs0 m vargs in { s_prog = p; s_cmd = f.f_body; s_estate; s_stk = Sempty (ii, f, vargs) } -let exec ep spp sip scs0 p ii fn vargs m = - let s = init_state ep spp p ii fn scs0 m vargs in - try small_step ep spp sip s +let exec ep spp sip env scs0 p ii fn vargs m = + let s = init_state ep spp env p ii fn scs0 m vargs in + try small_step ep spp sip env s with Final(m,vs) -> m, vs (* ----------------------------------------------------------- *) @@ -198,7 +199,8 @@ let run (type reg regx xreg rflag cond asm_op extra_op) Sem_params_of_arch_extra.sip_of_asm_e A.asm_e Syscall_ocaml.sc_sem in let scs0 = Syscall_ocaml.initial_state () in - exec ep spp sip scs0 p ii fn args m + let env _ = assert false in + exec ep spp sip env scs0 p ii fn args m (* ----------------------------------------------------------- *) let pp_undef fmt cty = @@ -227,7 +229,7 @@ let pp_val fmt v = | Vbool b -> Format.fprintf fmt "%b" b | Vint z -> Format.fprintf fmt "%a" Z.pp_print (Conv.z_of_cz z) | Varr(p,t) -> - let ip = Conv.int_of_pos p in + let ip = CoreConv.int_of_cz p in let pp_res fmt = function | Ok w -> pp_word fmt U8 w | Error ErrAddrUndef -> pp_undef fmt (Coq_cword U8) diff --git a/compiler/src/evaluator.mli b/compiler/src/evaluator.mli index 20c7017c65..37bcd7642c 100644 --- a/compiler/src/evaluator.mli +++ b/compiler/src/evaluator.mli @@ -4,6 +4,7 @@ val exec : 'syscall_state Sem_params.coq_EstateParams -> Sem_params.coq_SemPexprParams -> ('asm_op, 'syscall_state) Sem_params.coq_SemInstrParams -> + (Type.length_var -> BinNums.coq_Z option) -> 'syscall_state -> 'asm_op Expr.prog -> Expr.instr_info -> diff --git a/compiler/src/insert_copy_and_fix_length.ml b/compiler/src/insert_copy_and_fix_length.ml index c4049be936..027d2fee72 100644 --- a/compiler/src/insert_copy_and_fix_length.ml +++ b/compiler/src/insert_copy_and_fix_length.ml @@ -7,12 +7,12 @@ let is_array_copy (x:lval) (e:expr) = | Lvar x -> let x = L.unloc x in begin match x.v_ty with - | Arr (xws, xn) -> + | Arr (xws, Const xn) -> begin match e with | Pvar y -> let y = L.unloc y.gv in begin match y.v_ty with - | Arr(yws, yn) -> + | Arr(yws, Const yn) -> (* Ignore ill-typed copies: they are later rejected by “typing”. *) if arr_size yws yn < arr_size xws xn then None else if x.v_kind = Reg(Normal, Direct) then Some (xws, xn) @@ -28,9 +28,9 @@ let is_array_copy (x:lval) (e:expr) = 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 + | Lvar x -> size_of_const (L.unloc x).v_ty + | Lasub (_, ws, Const len, _, _) -> arr_size ws len + | Lasub _ | Lnone _ | Lmem _ | Laset _ -> assert false let rec fix_length_eassert e = match e with @@ -38,7 +38,7 @@ let rec fix_length_eassert e = | PappN_safety (o, es) -> let e = List.hd es in let ty = Typing.type_of_expr e in - let len = Conv.pos_of_int (size_of ty) in + let len = Conv.cal_of_al (size_of ty) in let o = match o with Ois_arr_init _ -> Operators.Ois_arr_init len | Ois_barr_init _ -> Ois_barr_init len in PappN_safety(o, es) | Pis_var_init _ | Pis_mem_init _ -> e @@ -53,10 +53,10 @@ and iac_instr_r pd loc ir = match is_array_copy x e with | None -> ir | Some (ws, n) -> - Typing.check_length loc n; + Typing.check_length loc (Const n); warning IntroduceArrayCopy loc "an array copy is introduced"; - let op = Pseudo_operator.Ocopy(ws, Conv.pos_of_int n) in + let op = Pseudo_operator.Ocopy(ws, ALConst (CoreConv.cz_of_int n)) in Copn([x], t, Sopn.Opseudo_op op, [e]) else ir | Cif (b, th, el) -> Cif (b, iac_stmt pd th, iac_stmt pd el) @@ -80,8 +80,8 @@ and iac_instr_r pd loc ir = xn wsn else let len = xn / wsn in - Typing.check_length loc len; - let op = Pseudo_operator.Ocopy (ws, Conv.pos_of_int len) in + Typing.check_length loc (Const len); + let op = Pseudo_operator.Ocopy (ws, ALConst (CoreConv.cz_of_int len)) in Copn(xs,t,Sopn.Opseudo_op op, es) | Sopn.Opseudo_op(Ocopy _), _ -> assert false | Sopn.Opseudo_op(Pseudo_operator.Oswap _), x::_ -> @@ -91,9 +91,9 @@ and iac_instr_r pd loc ir = | Sopn.Opseudo_op(Pseudo_operator.Oswap _), [] -> assert false | Sopn.Oslh (SLHprotect_ptr _), [Lvar x] -> (* Fix the size it is dummy for the moment *) - let ws, len = array_kind (L.unloc x).v_ty in - Typing.check_length loc len; - let op = Slh_ops.SLHprotect_ptr (ws, Conv.pos_of_int len) in + let ws, len = array_kind_const (L.unloc x).v_ty in + Typing.check_length loc (Const len); + let op = Slh_ops.SLHprotect_ptr (ws, ALConst (CoreConv.cz_of_int len)) in Copn(xs,t, Sopn.Oslh op, es) | Sopn.Oslh (SLHprotect_ptr _), _ -> assert false | Sopn.Opseudo_op (Odeclassify _), _ -> @@ -105,17 +105,8 @@ and iac_instr_r pd loc ir = | Sopn.Oasm _, _ -> ir end - | Csyscall(xs, o, es) -> - begin match o with - | Syscall_t.RandomBytes _ -> - (* Fix the size it is dummy for the moment *) - let ty = - match xs with - | [x] -> Typing.ty_lval pd loc x - | _ -> assert false in - let ws, len = array_kind ty in - Csyscall(xs, Syscall_t.RandomBytes (ws, Conv.pos_of_int len), es) - end + | Csyscall _ -> ir + | Cassert (msg, e) -> Cassert (msg, fix_length_eassert e) diff --git a/compiler/src/intervalGraphColoring.ml b/compiler/src/intervalGraphColoring.ml index de8bfe40ae..78cae256a4 100644 --- a/compiler/src/intervalGraphColoring.ml +++ b/compiler/src/intervalGraphColoring.ml @@ -22,7 +22,7 @@ let compare_event (dx, x) (dy, y) = let pick sz n = function - | [] -> V.mk n.v_name (Stack Direct) (Arr(U8,sz)) n.v_dloc n.v_annot, [] + | [] -> V.mk n.v_name (Stack Direct) (Arr(U8,Const sz)) n.v_dloc n.v_annot, [] | c :: free -> c, free let solve_rec sz (free, result) = diff --git a/compiler/src/latex_printer.ml b/compiler/src/latex_printer.ml index b86179d3f3..9b29566d71 100644 --- a/compiler/src/latex_printer.ml +++ b/compiler/src/latex_printer.ml @@ -140,10 +140,11 @@ and pp_expr_rec prio fmt pe = | PEstring s -> pp_string fmt s | PEBool b -> F.fprintf fmt "%s" (if b then "true" else "false") | PEInt i -> F.fprintf fmt "%s" i - | PECall (f, args) -> F.fprintf fmt "%a(%a)" pp_var f (pp_list ", " pp_expr) args + | PECall (f, alargs, args) -> F.fprintf fmt "%a%a(%a)" pp_var f pp_alargs alargs (pp_list ", " pp_expr) args | PECombF (f, args) -> F.fprintf fmt "%a(%a)" pp_var f (pp_list ", " pp_expr) args - | PEPrim (f, args) -> F.fprintf fmt "%a%a(%a)" sharp () pprim (L.unloc f) (pp_list ", " pp_expr) args + | PEPrim (f, alargs, args) -> + F.fprintf fmt "%a%a%a(%a)" sharp () pprim (L.unloc f) pp_alargs alargs (pp_list ", " pp_expr) args | PEOp1 (op, e) -> let p = prio_of_op1 op in optparent fmt prio p "("; @@ -190,6 +191,10 @@ and pp_arr_access fmt al aa ws x e len= pp_aligned (Option.bind len (fun _ -> al)) (pp_opt pp_ws) ws (pp_opt pp_space) ws pp_expr e pp_olen len +and pp_alargs fmt alargs = + if alargs <> [] then + F.fprintf fmt "<%a>" (pp_list ", " pp_expr) alargs + let pp_storage fmt s = latex "storageclass" fmt (pp_storage s) diff --git a/compiler/src/lexer.mll b/compiler/src/lexer.mll index 130abbf2a7..20c32ba32b 100644 --- a/compiler/src/lexer.mll +++ b/compiler/src/lexer.mll @@ -131,6 +131,7 @@ | "si" -> `WInt `Signed | "ui" -> `WInt `Unsigned | _ -> assert false + } (* -------------------------------------------------------------------- *) @@ -207,7 +208,6 @@ rule main = parse | ">>" (signletter as s)? { GTGT (mk_sign s) } | ">=" (signletter as s)? { GE (mk_sign s) } | ">" (signletter as s)? { GT (mk_sign s) } - | "." { DOT } | "!" { BANG } | "+" { PLUS } diff --git a/compiler/src/liveness.ml b/compiler/src/liveness.ml index 514f526be5..686cd63e1f 100644 --- a/compiler/src/liveness.ml +++ b/compiler/src/liveness.ml @@ -75,13 +75,13 @@ and live_d weak d (s_o: Sv.t) = let s_i, se, (c,c') = loop s_o in s_i, s_o, Cwhile(a, c, e, (info, se), c') - | Ccall(xs,f,es) -> + | Ccall(xs,f,al,es) -> let s_i = Sv.union (vars_es es) (dep_lvs s_o xs) in - s_i, (if weak then weak_dep_lvs 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,al,es) - | Csyscall(xs,o,es) -> + | Csyscall(xs,o,al,es) -> let s_i = Sv.union (vars_es es) (dep_lvs s_o xs) in - s_i, (if weak then weak_dep_lvs 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,al,es) and live_c weak c s_o = List.fold_right @@ -101,12 +101,12 @@ let liveness weak prog = fst prog, fds let iter_call_sites (cbf: L.i_loc -> funname -> lvals -> Sv.t * Sv.t -> unit) - (cbs: L.i_loc -> (Wsize.wsize * BinNums.positive) Syscall_t.syscall_t -> lvals -> Sv.t * Sv.t -> unit) + (cbs: L.i_loc -> Syscall.syscall_t -> lvals -> Sv.t * Sv.t -> unit) (f: (Sv.t * Sv.t, 'asm) func) : unit = iter_instr (fun i -> match i.i_desc with - | Ccall (xs, fn, _) -> cbf i.i_loc fn xs i.i_info - | Csyscall (xs, op, _) -> cbs i.i_loc op xs i.i_info + | Ccall (xs, fn, _, _) -> cbf i.i_loc fn xs i.i_info + | Csyscall (xs, op, _, _) -> cbs i.i_loc op xs i.i_info | (Cassgn _ | Copn _ | Cif _ | Cfor _ | Cwhile _ | Cassert _) -> () ) f.f_body diff --git a/compiler/src/liveness.mli b/compiler/src/liveness.mli index 367c25e67f..941e25b8f5 100644 --- a/compiler/src/liveness.mli +++ b/compiler/src/liveness.mli @@ -20,7 +20,7 @@ val liveness : bool -> ('info, 'asm) prog -> (Sv.t * Sv.t, 'asm) prog *) val iter_call_sites : (L.i_loc -> funname -> lvals -> Sv.t * Sv.t -> unit) -> - (L.i_loc -> (Wsize.wsize * BinNums.positive) Syscall_t.syscall_t -> lvals -> Sv.t * Sv.t -> unit) -> + (L.i_loc -> Syscall.syscall_t -> lvals -> Sv.t * Sv.t -> unit) -> (Sv.t * Sv.t, 'asm) func -> unit val pp_info : Format.formatter -> Sv.t * Sv.t -> unit diff --git a/compiler/src/parser.mly b/compiler/src/parser.mly index 911298f385..4893d79108 100644 --- a/compiler/src/parser.mly +++ b/compiler/src/parser.mly @@ -267,7 +267,7 @@ arr_access: let s = if s = None then Warray_.AAscale else Warray_.AAdirect in s, i } -pexpr_noarr_r(parent): +pexpr_noarr_nocall_r(parent): | v=var { PEVar v } @@ -303,20 +303,30 @@ pexpr_noarr_r(parent): | e=parens(parent) { PEParens e } -| f=var args=parens_tuple(parent) - { PECall (f, args) } - -| f=prim args=parens_tuple(parent) - { PEPrim (f, args) } +| f=prim alargs=loption(braces_tuple(parent)) args=parens_tuple(parent) + { PEPrim (f, alargs, args) } | e1=parent QUESTIONMARK e2=parent COLON e3=parent { PEIf(e1, e2, e3) } +pexpr_noarr_r: +| e=pexpr_noarr_nocall_r(pexpr_noarr) { e } +| f=var alargs=loption(braces_tuple(pexpr_noarr)) args=parens_tuple(pexpr_noarr) + { PECall (f, alargs, args) } + pexpr_noarr: -| e=loc(pexpr_noarr_r(pexpr_noarr)) { e } +| e=loc(pexpr_noarr_r) { e } + +pexpr_nocall_r: +| e=pexpr_noarr_nocall_r(pexpr_nocall) { e } + +pexpr_nocall: +| e=loc(pexpr_nocall_r) { e } pexpr_r: -| e = pexpr_noarr_r(pexpr) { e } +| e = pexpr_noarr_nocall_r(pexpr) { e } +| f=var alargs=loption(braces_tuple(pexpr)) args=parens_tuple(pexpr) + { PECall (f, alargs, args) } pexpr: | e=loc(pexpr_r) { e } @@ -370,27 +380,27 @@ pinstr_r: | ARRAYINIT x=parens(var) SEMICOLON { PIArrayInit x } -| f=loc(prim) args=parens_tuple(pexpr) SEMICOLON +| f=loc(prim) alargs=loption(braces_tuple(pexpr)) args=parens_tuple(pexpr) SEMICOLON { let { Location.pl_loc = loc; Location.pl_desc = f } = f in - PIAssign((None, []), `Raw, Location.mk_loc loc (PEPrim (f, args)), None) } + PIAssign((None, []), `Raw, Location.mk_loc loc (PEPrim (f, alargs, args)), None) } | x=plvalues o=peqop e=pexpr c=prefix(IF, pexpr)? SEMICOLON { PIAssign (x, o, e, c) } -| fc=loc(f=var args=parens_tuple(pexpr) { (f, args) }) +| fc=loc(f=var alargs=loption(braces_tuple(pexpr)) args=parens_tuple(pexpr) { (f, alargs, args) }) c=prefix(IF, pexpr)? SEMICOLON - { let { Location.pl_loc = loc; Location.pl_desc = (f, args) } = fc in - PIAssign ((None, []), `Raw, Location.mk_loc loc (PECall (f, args)), c) } + { let { Location.pl_loc = loc; Location.pl_desc = (f, alargs, args) } = fc in + PIAssign ((None, []), `Raw, Location.mk_loc loc (PECall (f, alargs, args)), c) } | ASSERT LPAREN msg=loc(STRING) COMMA e=pexpr RPAREN SEMICOLON { PIAssert(msg, e) } | s=pif { s } -| FOR v=var EQ ce1=pexpr TO ce2=pexpr is=pblock +| FOR v=var EQ ce1=pexpr TO ce2=pexpr_nocall is=pblock { PIFor (v, (`Up, ce1, ce2), is) } -| FOR v=var EQ ce1=pexpr DOWNTO ce2=pexpr is=pblock +| FOR v=var EQ ce1=pexpr DOWNTO ce2=pexpr_nocall is=pblock { PIFor (v, (`Down, ce2, ce1), is) } | WHILE is1=pblock? LPAREN b=pexpr RPAREN is2=pblock? @@ -403,10 +413,10 @@ pinstr_r: { PIdecl (ty, vs) } pif: -| IF c=pexpr i1s=pblock +| IF c=pexpr_nocall i1s=pblock { PIIf (c, i1s, None) } -| IF c=pexpr i1s=pblock ELSE i2s=pelse +| IF c=pexpr_nocall i1s=pblock ELSE i2s=pelse { PIIf (c, i1s, Some i2s) } pelseif: @@ -480,6 +490,7 @@ pfundef: cc=call_conv? FN name = ident + alargs = loption(braces_tuple(var)) (* ident instead of var? *) args = parens_tuple(annot_pparamdecl) rty = prefix(RARROW, tuple(annot_stor_type))? body = pfunbody @@ -487,6 +498,7 @@ pfundef: { { pdf_annot; pdf_cc = cc; pdf_name = name; + pdf_alargs = alargs; pdf_args = args; pdf_rty = rty ; pdf_body = body; } } @@ -580,3 +592,6 @@ module_: %inline brackets_tuple(X): | s=brackets(rtuple(X)) { s } + +%inline braces_tuple(X): +| s=braces(rtuple1(X)) { s } diff --git a/compiler/src/pp_stack_alloc.ml b/compiler/src/pp_stack_alloc.ml index 549c45a218..848711a2f2 100644 --- a/compiler/src/pp_stack_alloc.ml +++ b/compiler/src/pp_stack_alloc.ml @@ -16,6 +16,7 @@ let pp_sexpr ~debug fmt e = match e with | Sconst n -> Pconst n | Svar x -> Pvar (mk_lvar (mk_var_i x)) + | Slvar x -> Pvar (mk_lvar (mk_var_i { vtype = Coq_aint; vname = x})) | Sof_int (ws, e) -> Papp1 (Oword_of_int ws, cexpr_of_sexpr e) | Sto_int (sg, ws, e) -> Papp1 (Oint_of_word (sg, ws), cexpr_of_sexpr e) | Sneg (opk, e) -> Papp1 (Oneg opk, cexpr_of_sexpr e) diff --git a/compiler/src/pretyping.ml b/compiler/src/pretyping.ml index 5dd54b1930..15d3d375e0 100644 --- a/compiler/src/pretyping.ml +++ b/compiler/src/pretyping.ml @@ -22,26 +22,29 @@ type sop = [ `Op2 of S.peop2 | `Op1 of S.peop1] type tyerror = | UnknownVar of A.symbol | UnknownFun of A.symbol - | InvalidArrayType of P.epty - | TypeMismatch of P.epty pair - | NoOperator of sop * P.epty list + | InvalidArrayType of P.ety + | TypeMismatch of P.ety pair + | NoOperator of sop * P.ety list | InvalidOperator of sop | NoReturnStatement of P.funname * int | InvalidReturnStatement of P.funname * int * int | InvalidSignatureStorage of P.funname * S.pstorage * A.symbol * W.v_kind + | FailedLengthInference + | InvalidLengthCount of int * int | InvalidArgCount of int * int | InvalidLvalCount of int * int | DuplicateFun of A.symbol * L.t - | DuplicateAlias of A.symbol * P.epty L.located * P.epty L.located + | DuplicateAlias of A.symbol * P.ety L.located * P.ety L.located | TypeNotFound of A.symbol - | InvalidTypeAlias of A.symbol L.located option * P.epty - | InvalidCast of P.epty pair - | InvalidTypeForGlobal of P.epty + | InvalidTypeAlias of A.symbol L.located option * P.ety + | InvalidCast of P.ety pair + | InvalidTypeForGlobal of P.ety | GlobArrayNotWord | GlobWordNotArray | EqOpWithNoLValue | CallNotAllowed | PrimNotAllowed + | LengthNotAllowed | Unsupported of string | UnknownPrim of A.symbol * string | PrimWrongSuffix of A.symbol * Sopn.prim_x86_suffix list @@ -85,7 +88,7 @@ let pp_suffix fmt = let pp_tyerror fmt (code : tyerror) = (* We do not need the extra verbosity of [debug] in this context *) - let pp_eptype = Printer.pp_eptype ~debug:false in + let pp_etype = Printer.pp_etype ~debug:false in match code with | UnknownVar x -> F.fprintf fmt "unknown variable: `%s'" x @@ -95,20 +98,20 @@ let pp_tyerror fmt (code : tyerror) = | InvalidArrayType ty -> F.fprintf fmt "the expression has type %a instead of array" - pp_eptype ty + pp_etype ty | TypeMismatch (t1,t2) -> F.fprintf fmt "the expression has type %a instead of %a" - pp_eptype t1 pp_eptype t2 + pp_etype t1 pp_etype t2 | InvalidCast (t1,t2) -> F.fprintf fmt "can not implicitly cast %a into %a" - pp_eptype t1 pp_eptype t2 + pp_etype t1 pp_etype t2 | InvalidTypeForGlobal ty -> F.fprintf fmt "globals should have type word; found: ‘%a’" - pp_eptype ty + pp_etype ty | GlobArrayNotWord -> F.fprintf fmt "the definition is an array and not a word" @@ -126,13 +129,13 @@ let pp_tyerror fmt (code : tyerror) = F.fprintf fmt "no operator %s for these types %a" (S.string_of_peop2 o) - (pp_list " * " pp_eptype) ts + (pp_list " * " pp_etype) ts | NoOperator (`Op1 o, ts) -> F.fprintf fmt "no operator %s for these type %a" (S.string_of_peop1 o) - (pp_list " * " pp_eptype) ts + (pp_list " * " pp_etype) ts | NoReturnStatement (name, expected) -> F.fprintf fmt "function “%s” has no return statement (but its signature claims that %d values should be returned)" name.P.fn_name expected @@ -147,6 +150,13 @@ let pp_tyerror fmt (code : tyerror) = PrintCommon.pp_kind var_kind (S.pp_storage sto) + | FailedLengthInference -> + F.fprintf fmt "inference of length arguments failed" + + | InvalidLengthCount (n1, n2) -> + F.fprintf fmt + "invalid number of length arguments, %d provided instead of %d" n1 n2 + | InvalidArgCount (n1, n2) -> F.fprintf fmt "invalid number of arguments, %d provided instead of %d" n1 n2 @@ -164,9 +174,9 @@ let pp_tyerror fmt (code : tyerror) = F.fprintf fmt "Type '%s' (ie: '%a') is already declared at %s (with type : '%a')" id - pp_eptype (L.unloc newtype) + pp_etype (L.unloc newtype) (L.tostring (L.loc oldtype)) - pp_eptype (L.unloc oldtype) + pp_etype (L.unloc oldtype) | TypeNotFound (id) -> F.fprintf fmt @@ -176,9 +186,9 @@ let pp_tyerror fmt (code : tyerror) = | InvalidTypeAlias (id,typ) -> let pp_id fmt (id, typ) = match id with - | None -> F.fprintf fmt "'%a'" pp_eptype typ + | None -> F.fprintf fmt "'%a'" pp_etype typ | Some id -> - F.fprintf fmt "'%s' (ie: '%a'), defined at %s," (L.unloc id) pp_eptype typ + F.fprintf fmt "'%s' (ie: '%a'), defined at %s," (L.unloc id) pp_etype typ (L.tostring (L.loc id)) in F.fprintf fmt "Type %a is not allowed as array element. Only machine words (w8, w16 ...) allowed" @@ -196,6 +206,10 @@ let pp_tyerror fmt (code : tyerror) = F.fprintf fmt "primitive calls not allowed at that point" + | LengthNotAllowed -> + F.fprintf fmt + "length arguments not allowed at that point" + | Unsupported s -> F.fprintf fmt "%s" s | UnknownPrim(s, msg) -> @@ -241,14 +255,14 @@ let fully_qualified (stack: (A.symbol * 'a) list) n = (* -------------------------------------------------------------------- *) -type fun_sig = { fs_tin : P.epty list ; fs_tout : P.epty list } +type fun_sig = { fs_al : P.var list; fs_tin : P.ety list ; fs_tout : P.ety list } module Env : sig type 'asm env val empty : 'asm env - val decls : 'asm env -> (unit, 'asm) P.pmod_item list + val decls : 'asm env -> (unit, 'asm) P.mod_item list val add_from : 'asm env -> string * string -> 'asm env @@ -267,25 +281,26 @@ module Env : sig val exit_namespace : 'asm env -> 'asm env module Vars : sig - val push_global : 'asm env -> (P.pvar * P.epty * P.pexpr_ P.ggexpr ) -> 'asm env - val push_param : 'asm env -> (P.pvar * P.epty * P.pexpr) -> 'asm env - val push_local : ?warn:bool -> 'asm env -> P.pvar * P.epty -> 'asm env - val push_implicit : 'asm env -> P.pvar * P.epty -> 'asm env + val push_global : 'asm env -> (P.var * P.ety * P.length P.ggexpr) -> 'asm env + val push_param : 'asm env -> (P.var * P.ety * P.length P.gexpr) -> 'asm env + val push_length_var : 'asm env -> P.var -> 'asm env + val push_local : ?warn:bool -> 'asm env -> P.var * P.ety -> 'asm env + val push_implicit : 'asm env -> P.var * P.ety -> 'asm env - val find : A.symbol -> 'asm env -> (P.pvar * P.epty * E.v_scope) option + val find : A.symbol -> 'asm env -> (P.var * P.ety * E.v_scope) option - val iter_locals : (P.pvar -> unit) -> 'asm env -> unit + val iter_locals : (P.var -> unit) -> 'asm env -> unit val clear_locals : 'asm env -> 'asm env end module TypeAlias : sig - val push : 'asm env -> A.pident -> P.epty -> 'asm env - val get : 'asm env -> A.pident -> P.epty L.located + val push : 'asm env -> A.pident -> P.ety -> 'asm env + val get : 'asm env -> A.pident -> P.ety L.located end module Funs : sig - val push : 'asm env -> (unit, 'asm) P.pfunc -> fun_sig -> 'asm env - val find : A.symbol -> 'asm env -> ((unit, 'asm) P.pfunc * fun_sig) option + val push : 'asm env -> (unit, 'asm) P.func -> fun_sig -> 'asm env + val find : A.symbol -> 'asm env -> ((unit, 'asm) P.func * fun_sig) option end module Exec : sig @@ -303,17 +318,17 @@ end = struct } type 'asm global_bindings = { - gb_types : (A.symbol, P.epty L.located) Map.t; - gb_vars : (A.symbol, P.pvar * P.epty * E.v_scope) Map.t; - gb_funs : (A.symbol, (unit, 'asm) P.pfunc * fun_sig) Map.t; + gb_types : (A.symbol, P.ety L.located) Map.t; + gb_vars : (A.symbol, P.var * P.ety * E.v_scope) Map.t; + gb_funs : (A.symbol, (unit, 'asm) P.func * fun_sig) Map.t; } type 'asm env = { e_bindings : (A.symbol * 'asm global_bindings) list * 'asm global_bindings; - e_decls : (unit, 'asm) P.pmod_item list; + e_decls : (unit, 'asm) P.mod_item list; e_exec : (P.funname * (Z.t * Z.t) list) L.located list; e_loader : loader; - e_declared : P.Spv.t ref; (* Set of local variables declared somewhere in the function *) + e_declared : P.Sv.t ref; (* Set of local variables declared somewhere in the function *) e_reserved : Ss.t; (* Set of string (variable name) declared by the user, fresh variables introduced by the compiler should be disjoint from this set *) @@ -334,7 +349,7 @@ end = struct ; e_decls = [] ; e_exec = [] ; e_loader = empty_loader - ; e_declared = ref P.Spv.empty + ; e_declared = ref P.Sv.empty ; e_reserved = Ss.empty ; e_known_implicits = []; } @@ -468,7 +483,7 @@ end = struct | exception Not_found -> () | v' -> warn_duplicate_var name (v, (), ()) v' - let push_core ?(warn=true) (env : 'asm env) (name: P.Name.t) (v : P.pvar) (ty: P.epty) (s : E.v_scope) = + let push_core ?(warn=true) (env : 'asm env) (name: P.Name.t) (v : P.var) (ty: P.ety) (s : E.v_scope) = let doit m = if warn then warn_double_decl name v m.gb_vars; { m with gb_vars = Map.add name (v, ty, s) m.gb_vars } @@ -496,26 +511,29 @@ end = struct let env = push_core env name x ty Slocal in { env with e_decls = P.MIparam (x, e) :: env.e_decls } - let push_local ?(warn=true) (env : 'asm env) ((v,ty) : P.pvar * P.epty) = - env.e_declared := P.Spv.add v !(env.e_declared); + let push_local ?(warn=true) (env : 'asm env) ((v,ty) : P.var * P.ety) = + env.e_declared := P.Sv.add v !(env.e_declared); push_core ~warn env v.P.v_name v ty Slocal - let push_implicit (env : 'asm env) ((v,ty) : P.pvar * P.epty) = + let push_length_var env x = + push_local env (x, ETint) + + let push_implicit (env : 'asm env) ((v,ty) : P.var * P.ety) = let vars = match env.e_bindings with (_, b) :: _, _ | [], b -> b.gb_vars in assert (not (Map.mem v.P.v_name vars)); push_core env v.P.v_name v ty Slocal let iter_locals f (env : 'asm env) = - P.Spv.iter f !(env.e_declared) + P.Sv.iter f !(env.e_declared) let clear_locals (env : 'asm env) = - { env with e_declared = ref P.Spv.empty } + { env with e_declared = ref P.Sv.empty } end module TypeAlias = struct - let push (env: 'asm env) (id: A.pident) (ty: P.epty) : 'asm env = + let push (env: 'asm env) (id: A.pident) (ty: P.ety) : 'asm env = match find (fun x -> x.gb_types) (L.unloc id) env with | Some alias -> rs_tyerror ~loc:(L.loc id) (DuplicateAlias (L.unloc id, (L.mk_loc (L.loc id) ty) ,alias) ) @@ -529,7 +547,7 @@ end = struct in {env with e_bindings = binds} - let get (env: 'asm env) (id: A.pident) : P.epty L.located = + let get (env: 'asm env) (id: A.pident) : P.ety L.located = let typea = find (fun b -> b.gb_types) (L.unloc id) env in match typea with | None -> @@ -542,7 +560,7 @@ end = struct let find (x : A.symbol) (env : 'asm env) = find (fun b -> b.gb_funs) x env - let push env (v : (unit, 'asm) P.pfunc) rty = + let push env (v : (unit, 'asm) P.func) rty = let name = v.P.f_name.P.fn_name in let v = { v with P.f_name = P.F.mk (fully_qualified (fst env.e_bindings) name) } in match find name env with @@ -605,12 +623,14 @@ let tt_var_core (mode:tt_mode) (env : 'asm Env.env) { L.pl_desc = x; L.pl_loc = | None -> rs_tyerror ~loc:lc (UnknownVar x) in begin match mode with | `OnlyParam -> - if v.P.v_kind <> W.Const then - rs_tyerror ~loc:lc (StringError "only param variables are allowed here") + if v.P.v_kind <> W.Const && v.P.v_kind <> W.Length then + rs_tyerror ~loc:lc (StringError "only param and length variables are allowed here") | `NoParam -> - if v.P.v_kind = W.Const then - rs_tyerror ~loc:lc (StringError "param variables are not allowed here") - | `AllVar -> () + if v.P.v_kind = W.Const || v.P.v_kind = W.Length then + rs_tyerror ~loc:lc (StringError "param and length variables are not allowed here") + | `AllVar -> + if v.P.v_kind = W.Length then + rs_tyerror ~loc:lc (StringError "length variables are not allowed here") end; vs @@ -630,14 +650,14 @@ let tt_fun (env : 'asm Env.env) { L.pl_desc = x; L.pl_loc = loc; } = Env.Funs.find x env |> oget ~exn:(tyerror ~loc (UnknownFun x)) (* -------------------------------------------------------------------- *) -let check_ty_eq ~loc ~(from : P.epty) ~(to_ : P.epty) = - if not (P.epty_equal from to_) then +let check_ty_eq ~loc ~(from : P.ety) ~(to_ : P.ety) = + if not (P.ety_equal from to_) then match from, to_ with | ETarr _, ETarr _ -> () (* we delay typechecking until we know the lengths *) | _, _ -> rs_tyerror ~loc (TypeMismatch (from, to_)) (* -------------------------------------------------------------------- *) -let check_return_statement ~loc name (declared : P.epty list) (given : (L.t * P.epty) list) : unit = +let check_return_statement ~loc name (declared : P.ety list) (given : (L.t * P.ety) list) : unit = let given_size = List.length given in let declared_size = List.length declared in if Stdlib.Int.equal 0 given_size @@ -674,6 +694,7 @@ let check_return_storage ~loc fname = (* Global should never be returned, it is checked before this function is called in tt_fundef *) | _ , W.Global -> assert false | `Global , _ -> assert false + | _, W.Length -> assert false (* Invalid type rule *) | `Reg _, (W.Stack _ | W.Inline | W.Const) @@ -706,7 +727,7 @@ let tt_sign = function | `Unsigned -> W.Unsigned (* -------------------------------------------------------------------- *) -let tt_as_array ((loc, ty) : L.t * P.epty) : P.epty * P.pexpr_ = +let tt_as_array ((loc, ty) : L.t * P.ety) : P.ety * P.length = match ty with | ETarr (ws, n) -> P.etw ws, n | _ -> rs_tyerror ~loc (InvalidArrayType ty) @@ -718,7 +739,7 @@ let wsize_min = Utils0.cmp_min W.wsize_cmp let wsize_max s1 s2 = if wsize_le s1 s2 then s2 else s1 let max_ty ty1 ty2 = - if P.epty_equal ty1 ty2 then Some ty1 else + if P.ety_equal ty1 ty2 then Some ty1 else match ty1, ty2 with | ETint, ETword _ -> Some ty2 | ETword _, ETint -> Some ty1 @@ -1050,7 +1071,7 @@ let cast loc e ety ty = | P.ETword(None, w1), P.ETword(None, w2) when W.wsize_cmp w1 w2 <> Datatypes.Lt -> e | P.ETword(Some W.Unsigned, w1), P.ETword(Some W.Unsigned, w2) when W.wsize_cmp w1 w2 <> Datatypes.Lt -> e - | _, _ when P.epty_equal ety ty -> e + | _, _ when P.ety_equal ety ty -> e | P.ETarr _, P.ETarr _ -> e (* we delay typechecking until we know the lengths *) | _ -> rs_tyerror ~loc (InvalidCast(ety,ty)) @@ -1087,17 +1108,17 @@ let cast_int loc os e ety = (* -------------------------------------------------------------------- *) -let conv_ty : BinNums.positive T.extended_type -> P.epty = function +let conv_ty : T.extended_type -> P.ety = function | T.ETbool -> P.etbool | T.ETint -> P.etint | T.ETword(s,ws) -> P.ETword(s,ws) - | T.ETarr (ws, p) -> P.ETarr (ws, PE (P.cnst (Conv.z_of_pos p))) + | T.ETarr (ws, al) -> P.ETarr (ws, Conv.al_of_cal al) -let conv_cty : T.atype -> P.epty = function +let conv_cty : T.atype -> P.ety = function | T.Coq_abool -> P.etbool | T.Coq_aint -> P.etint | T.Coq_aword ws -> P.etw ws - | T.Coq_aarr (ws, p) -> P.ETarr (ws, PE (P.cnst (Conv.z_of_pos p))) + | T.Coq_aarr (ws, al) -> P.ETarr (ws, Conv.al_of_cal al) let type_of_op2 op = let (ty1, ty2), tyo = E.etype_of_op2 op in @@ -1293,8 +1314,9 @@ let rec tt_expr pd ?(mode=`AllVar) (env : 'asm Env.env) pe = ignore_align ~loc:(L.loc pe) al; let len,ity = tt_expr ~mode:`OnlyParam pd env plen in check_ty_eq ~loc:(L.loc plen) ~from:ity ~to_:P.etint; - let ty = P.ETarr (ws, P.PE len) in - P.Psub (aa, ws, P.PE len, x, i), ty + let len = P.al_of_expr len in + let ty = P.ETarr (ws, len) in + P.Psub (aa, ws, len, x, i), ty end | S.PEOp1 (op, pe) -> @@ -1371,10 +1393,14 @@ let rec tt_expr pd ?(mode=`AllVar) (env : 'asm Env.env) pe = | exception Not_found -> assert false end - | S.PECall (id, args) when is_combine_flags id -> + | S.PECall (id, alargs, args) when is_combine_flags id -> + if alargs <> [] then + rs_tyerror ~loc:(L.loc pe) LengthNotAllowed; tt_expr ~mode pd env (L.mk_loc (L.loc pe) (S.PECombF(id,args))) - | S.PECall (id, args) when Map.mem (L.unloc id) extra_op_map -> + | S.PECall (id, alargs, args) when Map.mem (L.unloc id) extra_op_map -> + if alargs <> [] then + rs_tyerror ~loc:(L.loc pe) LengthNotAllowed; let pa_name = L.unloc id in let args = List.map (tt_expr ~mode pd env) args in let create_pred = Map.find pa_name extra_op_map in @@ -1398,8 +1424,8 @@ let rec tt_expr pd ?(mode=`AllVar) (env : 'asm Env.env) pe = | S.PEstring s -> let es = array_of_string s in - let len = Conv.pos_of_int (List.length es) in - P.PappN (Oarray len, es), P.(ETarr (U8, PE (Pconst (Conv.z_of_pos len)))) + let len = List.length es in + P.PappN (Oarray (CoreConv.cz_of_int len), es), P.(ETarr (U8, Const len)) | S.PEIf (pe1, pe2, pe3) -> let e1, ty1 = tt_expr ~mode pd env pe1 in @@ -1423,7 +1449,7 @@ and tt_mem_access pd ?(mode=`AllVar) (env : 'asm Env.env) (ct, loc, e, al) (* -------------------------------------------------------------------- *) -and tt_type pd (env : 'asm Env.env) (pty : S.ptype) : P.epty = +and tt_type pd (env : 'asm Env.env) (pty : S.ptype) : P.ety = match L.unloc pty with | S.TBool -> P.etbool | S.TInt -> P.etint @@ -1434,12 +1460,16 @@ and tt_type pd (env : 'asm Env.env) (pty : S.ptype) : P.epty = | TypeWsize ws -> L.loc pty, None, tt_swsize ws | TypeSizeAlias id -> let ty = Env.TypeAlias.get env id in - L.loc id, Some (L.mk_loc (L.loc ty) (L.unloc id)), L.unloc ty in + L.loc id, Some (L.mk_loc (L.loc ty) (L.unloc id)), L.unloc ty + in let ws = match ety with | P.ETword(None, ws) -> ws (* wint array are not allowed this is require by wint_int *) | ty -> rs_tyerror ~loc (InvalidTypeAlias (id,ty)) - in P.ETarr (ws, P.PE (fst (tt_expr ~mode:`OnlyParam pd env e))) + in + let len, _ = tt_expr ~mode:`OnlyParam pd env e in + let len = P.al_of_expr len in + P.ETarr (ws, len) | S.TAlias id -> L.unloc (Env.TypeAlias.get env id) (* -------------------------------------------------------------------- *) @@ -1459,7 +1489,7 @@ let mk_var x sto xety xlc annot = Annotations.add_symbol ~loc:xlc s annot | _ -> annot in - P.PV.mk x sto (P.gty_of_gety xety) xlc annot + P.V.mk x sto (P.gty_of_gety xety) xlc annot let tt_vardecl dfl_writable pd (env : 'asm Env.env) ((annot, (sto, xty)), x) = let { L.pl_desc = x; L.pl_loc = xlc; } = x in @@ -1523,8 +1553,9 @@ let tt_lvalue pd (env : 'asm Env.env) { L.pl_desc = pl; L.pl_loc = loc; } = ignore_align ~loc al; let len,ity = tt_expr ~mode:`OnlyParam pd env plen in check_ty_eq ~loc:(L.loc plen) ~from:ity ~to_:P.etint; - let ty = P.ETarr(ws, P.PE len) in - loc, (fun _ -> P.Lasub (aa, ws, P.PE len, L.mk_loc xlc x, i)), Some ty + let len = P.al_of_expr len in + let ty = P.ETarr(ws, len) in + loc, (fun _ -> P.Lasub (aa, ws, len, L.mk_loc xlc x, i)), Some ty end | S.PLMem me -> @@ -1533,7 +1564,7 @@ let tt_lvalue pd (env : 'asm Env.env) { L.pl_desc = pl; L.pl_loc = loc; } = (* -------------------------------------------------------------------- *) -let prim_sig asmOp p : 'a P.gety list * 'a P.gety list * Sopn.arg_desc list = +let prim_sig asmOp p : P.ety list * P.ety list * Sopn.arg_desc list = let f t = conv_cty t in let o = Sopn.asm_op_instr asmOp p in List.map f o.tout, @@ -1746,10 +1777,10 @@ let prim_of_pe pe = | _, _ -> o, pe1, pe2, L.mk_loc (L.loc pe2) (S.PEBool false) in - S.PEPrim(prim_of_op exn loc o, [pe1; pe2; pe3]) + S.PEPrim(prim_of_op exn loc o, [], [pe1; pe2; pe3]) | _ -> - S.PEPrim(prim_of_op exn loc o, [pe1; pe2]) + S.PEPrim(prim_of_op exn loc o, [], [pe1; pe2]) in L.mk_loc (L.loc pe) desc | _ -> raise exn @@ -1920,11 +1951,11 @@ let arr_init (xi, ty) = | _ -> rs_tyerror ~loc:(L.loc xi) (InvalidArrayType ty) -let cassgn_for (x: P.plval) (tg: E.assgn_tag) (ty: P.epty) (e: P.pexpr) : - (unit, 'asm) P.pinstr_r = +let cassgn_for (x: P.lval) (tg: E.assgn_tag) (ty: P.ety) (e: P.expr) : + (unit, 'asm) P.instr_r = Cassgn (x, tg, P.gty_of_gety ty, e) -let mk_call loc inline lvs f es = +let mk_call loc inline lvs f al es = let open P in begin match f.f_cc with | Internal -> () @@ -1955,19 +1986,25 @@ let mk_call loc inline lvs f es = | Pvar y | Psub(_, _, _, y, _) -> let y = L.unloc y.gv in if not (check_ptr_writable y || y.v_kind = Stack Direct) then - rs_tyerror ~loc (string_error "argument %a needs to be writable" Printer.pp_pvar y) + rs_tyerror ~loc (string_error "argument %a needs to be writable" (Printer.pp_var ~debug:false) y) | Pif (_, _, e1, e2) -> aux e1; aux e2 | _ -> assert false in aux e in List.iter2 check_w f.f_args es; - P.Ccall (lvs, f.P.f_name, es) + P.Ccall (lvs, f.P.f_name, al, es) let assign_from_decl decl = let v, e = L.unloc decl in let d = L.mk_loc (L.loc decl) (S.PLVar v) in (None, [d]), `Raw, e, None +let tt_alarg env x = + let { L.pl_desc = x; L.pl_loc = xlc; } = x in + let x = mk_var x W.Length Prog.ETint xlc [] in + let env = Env.Vars.push_length_var env x in + env, L.mk_loc xlc x + let tt_annot_paramdecls ?(warn=true) dfl_writable pd env (annot, (ty,vs)) = let aty = pannot_to_annotations annot, ty in let vars = List.map (fun v -> aty, v) vs in @@ -1995,7 +2032,7 @@ let create_is_arr_init _pd loc args = let e2 = cast_int loc None e2 t2 in let e3 = cast_int loc None e3 t3 in (* The size will be fixed later *) - P.PappN_safety (Ois_arr_init (Conv.pos_of_int 1) , [ e1; e2; e3]) + P.PappN_safety (Ois_arr_init (ALConst Z0) , [ e1; e2; e3]) else rs_tyerror ~loc (InvalidArgCount(3, List.length args)) @@ -2020,7 +2057,10 @@ let rec tt_assert pd env pe = match L.unloc pe with | S.PEParens pe -> tt_assert pd env pe - | S.PECall (id,args) when Map.mem (L.unloc id) safety_map -> + | S.PECall (id,alargs,args) when Map.mem (L.unloc id) safety_map -> + (* FIXME *) + if alargs <> [] then + rs_tyerror ~loc:(L.loc pe) LengthNotAllowed; let pa_name = L.unloc id in let args = List.map (tt_expr pd env) args in let create_pred = Map.find pa_name safety_map in @@ -2029,31 +2069,92 @@ let rec tt_assert pd env pe = P.Pand (tt_assert pd env pe1, tt_assert pd env pe2) | _ -> P.Pexpr (tt_expr_bool pd env pe) -let rec tt_instr arch_info (env : 'asm Env.env) ((pannot,pi) : S.pinstr) : 'asm Env.env * (unit, 'asm) P.pinstr list = +let subst_one als ty = + let f x = + let al = List.assoc_opt x als in + assert (al <> None || x.P.v_kind = Const); + al + in + P.subst_ety f ty + +let subst loc f_al alargs tys = + let n1 = List.length alargs in + let n2 = List.length f_al in + if n1 <> n2 then + rs_tyerror ~loc (InvalidLengthCount (n1, n2)); + let als = List.combine f_al alargs in + List.map (subst_one als) tys + +(* We try to be resilient, errors will be caught later anyway. *) +let infer_length loc al tys1 tys2 = + let rec aux m tys1 tys2 = + match tys1, tys2 with + | [], _ | _, [] -> m + | ty1 :: tys1, ty2 :: tys2 -> + let acc = + match ty1, ty2 with + | P.ETarr (ws1, P.Var x1), P.ETarr (ws2, len2) when ws1 = ws2 -> + (* if [x1] is already in the map, we preserve the old binding *) + P.Mv.modify_opt x1 (function | None -> Some len2 | Some _ as len -> len) m + | _ ,_ -> m + in + aux acc tys1 tys2 + in + let m = aux P.Mv.empty tys1 tys2 in + try + List.map (fun x -> P.Mv.find x m) al + with Not_found -> rs_tyerror ~loc FailedLengthInference + +let syscalls = ["randombytes", Syscall.RandomBytes] + +let rec tt_instr arch_info n (env : 'asm Env.env) ((pannot,pi) : S.pinstr) : 'asm Env.env * (unit, 'asm) P.instr list = let annot = pannot_to_annotations pannot in let mk_i ?(annot=annot) instr = { P.i_desc = instr; P.i_loc = L.of_loc pi; P.i_info = (); P.i_annot = annot} in let default_tag = if Annotations.has_symbol "keep" annot then E.AT_keep else E.AT_none in let rec tt_assign ?tag env_lhs env_rhs ls eqop pe ocp = match ls, eqop, pe, ocp with - | ls, `Raw, { L.pl_desc = S.PECall (f, args); pl_loc = el }, None when is_combine_flags f -> + | ls, `Raw, { L.pl_desc = S.PECall (f, alargs, args); pl_loc = el }, None when is_combine_flags f -> + if alargs <> [] then + rs_tyerror ~loc:(L.loc pe) LengthNotAllowed; tt_assign ~tag:E.AT_inline env_lhs env_rhs ls `Raw (L.mk_loc el (S.PECombF(f, args))) None - | ls, `Raw, { L.pl_desc = S.PECall (f, args); pl_loc = el }, None -> + | ls, `Raw, { L.pl_desc = S.PECall (f, alargs, args); pl_loc = el }, None -> let (f,fsig) = tt_fun env_rhs f in - let lvs, is = tt_lvalues arch_info env_lhs (L.loc pi) ls None fsig.fs_tout in + let alargs = + List.map (fun alarg -> tt_expr_cast arch_info.pd ~mode:`OnlyParam env_rhs alarg Prog.ETint) alargs + in + let alargs = List.map P.al_of_expr alargs in + let alargs = + if alargs = [] && fsig.fs_al <> [] then + (* we try to infer the constraints *) + let n1 = List.length args in + let n2 = List.length fsig.fs_tin in + if n1 <> n2 then + (* if not the right number of args, we exit early *) + (* TODO: remove duplication with tt_exprs_cast *) + rs_tyerror ~loc:(L.loc pi) (InvalidArgCount (n1, n2)); + let tys = tt_exprs arch_info.pd env_rhs args in + infer_length (L.loc pi) fsig.fs_al fsig.fs_tin (List.map snd tys) + else alargs + in + let tout = subst (L.loc pi) fsig.fs_al alargs fsig.fs_tout in + let lvs, is = tt_lvalues arch_info env_lhs (L.loc pi) ls None tout in assert (is = []); - let es = tt_exprs_cast arch_info.pd env_rhs (L.loc pi) args fsig.fs_tin in + let tin = subst (L.loc pi) fsig.fs_al alargs fsig.fs_tin in + let es = tt_exprs_cast arch_info.pd env_rhs (L.loc pi) args tin in let is_inline = P.is_inline annot f.P.f_cc in let annot = if is_inline || FInfo.is_export f.P.f_cc then Annotations.add_symbol ~loc:el "inline" annot else annot in - [mk_i ~annot (mk_call (L.loc pi) is_inline lvs f es)] - | (ls, xs), `Raw, { pl_desc = PEPrim (f, args) }, None + (* FIXME: List.map (fun e -> P.PE e) is ugly *) + [mk_i ~annot (mk_call (L.loc pi) is_inline lvs f alargs es)] + | (ls, xs), `Raw, { pl_desc = PEPrim (f, alargs, args) }, None when L.unloc f = "spill" || L.unloc f = "unspill" -> let op = L.unloc f in + if alargs <> [] then rs_tyerror ~loc:(L.loc pi) (string_error "%s does not support templating" op); if ls <> None then rs_tyerror ~loc:(L.loc pi) (string_error "%s expects no implicit result" op); if xs <> [] then rs_tyerror ~loc:(L.loc pi) (string_error "%s expects no result" op); let es = tt_exprs arch_info.pd env_rhs args in @@ -2066,28 +2167,35 @@ let rec tt_instr arch_info (env : 'asm Env.env) ((pannot,pi) : S.pinstr) : 'asm let p = Sopn.Opseudo_op (Ospill(op, [] (* dummy info, will be fixed latter *))) in [mk_i ~annot (P.Copn([], AT_keep, p, es))] - | (ls, xs), `Raw, { pl_desc = PEPrim (f, args) }, None when L.unloc f = "randombytes" -> - (* FIXME syscall *) - (* This is dirty but ... *) - if ls <> None then rs_tyerror ~loc:(L.loc pi) (string_error "randombytes expects no implicit arguments"); - let loc, x, ty = - match xs with - | [x] -> - let loc, x, oty = tt_lvalue arch_info.pd env_lhs x in - let ty = - match oty with - | None -> rs_tyerror ~loc (string_error "_ lvalue not accepted here") - | Some ty -> ty in - loc, x ty, ty - | _ -> - rs_tyerror ~loc:(L.loc pi) - (string_error "only a single variable is allowed as destination of randombytes") in - let _ = tt_as_array (loc, ty) in - let es = tt_exprs_cast arch_info.pd env_rhs (L.loc pi) args [ty] in - [mk_i (P.Csyscall([x], Syscall_t.RandomBytes (U8, Conv.pos_of_int 1), es))] - - | (ls, xs), `Raw, { pl_desc = PEPrim (f, args) }, None when L.unloc f = "swap" -> + | ls, `Raw, { pl_desc = PEPrim (f, alargs, args) }, None when List.mem_assoc (L.unloc f) syscalls -> + let o = List.assoc (L.unloc f) syscalls in + let fsig = Syscall.syscall_sig_u arch_info.pd n o in + let alargs = + List.map (fun alarg -> tt_expr_cast arch_info.pd ~mode:`OnlyParam env_rhs alarg Prog.ETint) alargs + in + let alargs = List.map P.al_of_expr alargs in + let alargs = + if alargs = [] && fsig.scs_al <> [] then + (* we try to infer the constraints *) + let n1 = List.length args in + let n2 = List.length fsig.scs_tin in + if n1 <> n2 then + (* if not the right number of args, we exit early *) + rs_tyerror ~loc:(L.loc pi) (InvalidArgCount (n1, n2)); + let tys = tt_exprs arch_info.pd env_rhs args in + infer_length (L.loc pi) fsig.scs_al (List.map conv_cty fsig.scs_tin) (List.map snd tys) + else alargs + in + let tout = subst (L.loc pi) fsig.scs_al alargs (List.map conv_cty fsig.scs_tout) in + let lvs, is = tt_lvalues arch_info env_lhs (L.loc pi) ls None tout in + assert (is = []); + let tin = subst (L.loc pi) fsig.scs_al alargs (List.map conv_cty fsig.scs_tin) in + let es = tt_exprs_cast arch_info.pd env_rhs (L.loc pi) args tin in + [mk_i (P.Csyscall(lvs, o, alargs, es))] + + | (ls, xs), `Raw, { pl_desc = PEPrim (f, alargs, args) }, None when L.unloc f = "swap" -> let loc = L.loc pi in + if alargs <> [] then rs_tyerror ~loc (string_error "swap does not support templating"); if ls <> None then rs_tyerror ~loc (string_error "swap expects no implicit arguments"); let ty, es = match args with @@ -2120,14 +2228,16 @@ let rec tt_instr arch_info (env : 'asm Env.env) ((pannot,pi) : S.pinstr) : 'asm let p = Sopn.Opseudo_op (Oswap Type.Coq_abool) in (* The type is fixed later *) [mk_i (P.Copn(lvs, Option.default default_tag tag, p, es))] - | (ls, xs), `Raw, { pl_desc = PEPrim (f, args) }, None when L.unloc f = "declassify" -> + | (ls, xs), `Raw, { pl_desc = PEPrim (f, alargs, args) }, None when L.unloc f = "declassify" -> let loc = L.loc pi in + if alargs <> [] then rs_tyerror ~loc (string_error "declassify does not support templating"); if ls <> None || xs <> [] then rs_tyerror ~loc (string_error "declassify returns no value"); let es = tt_exprs arch_info.pd env_rhs args |> List.map fst in let op = Sopn.Opseudo_op (Odeclassify Type.Coq_abool) in [mk_i (P.Copn([], AT_keep, op, es))] - | ls, `Raw, { pl_desc = PEPrim (f, args) }, None -> + | ls, `Raw, { pl_desc = PEPrim (f, alargs, args) }, None -> + if alargs <> [] then rs_tyerror ~loc:(L.loc pi) (string_error "assembly instructions do not support templating"); let p = tt_prim arch_info.asmOp f in let tlvs, tes, arguments = prim_sig arch_info.asmOp p in let lvs, einstr = tt_lvalues arch_info env_lhs (L.loc pi) ls (Some arguments) tlvs in @@ -2135,13 +2245,14 @@ let rec tt_instr arch_info (env : 'asm Env.env) ((pannot,pi) : S.pinstr) : 'asm let must_keep = lvs = [] || match p with Oslh _ -> true | _ -> false in mk_i (P.Copn(lvs, Option.default (if must_keep then E.AT_keep else default_tag) tag, p, es)) :: einstr - | ls, `Raw, { pl_desc = PEOp1 (`Cast(`ToWord ct), {pl_desc = PEPrim (f, args) }); pl_loc = loc} , None + | ls, `Raw, { pl_desc = PEOp1 (`Cast(`ToWord ct), {pl_desc = PEPrim (f, alargs, args) }); pl_loc = loc} , None -> let ws = match ct with | (ws, `Word _) -> ws | (_ws, `WInt _) -> rs_tyerror ~loc (string_error "invalid cast for asm operator") in + if alargs <> [] then rs_tyerror ~loc:(L.loc pi) (string_error "assembly instructions do not support templating"); let p = tt_prim arch_info.asmOp f in let id = Sopn.asm_op_instr arch_info.asmOp p in let p = cast_opn ~loc:(L.loc pi) id ws p in @@ -2230,8 +2341,8 @@ let rec tt_instr arch_info (env : 'asm Env.env) ((pannot,pi) : S.pinstr) : 'asm | PIIf (cp, st, sf) -> let c = tt_expr_bool arch_info.pd env cp in - let st = tt_block arch_info env st in - let sf = Option.map_default (tt_block arch_info env) [] sf in + let st = tt_block arch_info n env st in + let sf = Option.map_default (tt_block arch_info n env) [] sf in env, [mk_i (P.Cif (c, st, sf))] | PIFor ({ pl_loc = lx } as x, (d, i1, i2), s) -> @@ -2239,34 +2350,34 @@ let rec tt_instr arch_info (env : 'asm Env.env) ((pannot,pi) : S.pinstr) : 'asm let i2 = tt_expr_int arch_info.pd env i2 in let vx, xty = tt_var `AllVar env x in check_ty_eq ~loc:lx ~from:xty ~to_:P.etint; - let s = tt_block arch_info env s in + let s = tt_block arch_info n env s in let d = match d with `Down -> E.DownTo | `Up -> E.UpTo in env, [mk_i (P.Cfor (L.mk_loc lx vx, (d, i1, i2), s))] | PIWhile (s1, e, s2) -> let c = tt_expr_bool arch_info.pd env e in - let s1 = Option.map_default (tt_block arch_info env) [] s1 in - let s2 = Option.map_default (tt_block arch_info env) [] s2 in + let s1 = Option.map_default (tt_block arch_info n env) [] s1 in + let s2 = Option.map_default (tt_block arch_info n env) [] s2 in let a = Option.map_default (fun () -> E.Align) E.NoAlign (Annot.ensure_uniq1 "align" Annot.none annot) in let annot = Annot.consume "align" annot in env, [mk_i ~annot (P.Cwhile (a, s1, c, ((L.of_loc e, []), ()), s2))] (* -------------------------------------------------------------------- *) -and tt_block arch_info env (pb : S.pblock) = - snd (tt_cmd arch_info env (L.unloc pb)) +and tt_block arch_info n env (pb : S.pblock) = + snd (tt_cmd arch_info n env (L.unloc pb)) -and tt_cmd arch_info env c = +and tt_cmd arch_info n env c = match c with | [] -> env, [] | i::c -> - let env, i = tt_instr arch_info env i in - let env, c = tt_cmd arch_info env c in + let env, i = tt_instr arch_info n env i in + let env, c = tt_cmd arch_info n env c in env, i @ c (* -------------------------------------------------------------------- *) -let tt_funbody arch_info env (pb : S.pfunbody) = - let env, bdy = tt_cmd arch_info env pb.S.pdb_instr in +let tt_funbody arch_info n env (pb : S.pfunbody) = + let env, bdy = tt_cmd arch_info n env pb.S.pdb_instr in let ret_loc = L.loc pb.pdb_ret in let ret = let for1 x = L.mk_loc (L.loc x) (tt_var `AllVar env x) in @@ -2285,7 +2396,7 @@ let tt_call_conv _loc params returns cc = if not (P.is_reg_kind (L.unloc x).P.v_kind) then warning PedanticPretyping (L.i_loc0 (L.loc x)) "%a has kind %a, only reg or reg ptr are allowed in %s of non inlined function" - Printer.pp_pvar (L.unloc x) + (Printer.pp_var ~debug:false) (L.unloc x) PrintCommon.pp_kind (L.unloc x).P.v_kind s in List.iter (check "parameter") params; List.iter (check "result") returns; @@ -2299,7 +2410,7 @@ let tt_call_conv _loc params returns cc = | W.Reg(_, Pointer writable) -> if writable = Constant then warning Always (L.i_loc0 loc) "no need to return a [reg const ptr] %a" - Printer.pp_pvar x; + (Printer.pp_var ~debug:false) x; List.index_of x args | _ -> assert false) returns in let is_writable_ptr k = @@ -2312,7 +2423,7 @@ let tt_call_conv _loc params returns cc = if is_writable_ptr x.P.v_kind then if not (List.exists ((=) (Some i)) returned_params) then rs_tyerror ~loc (string_error "%a is mutable, it should be returned" - Printer.pp_pvar x) in + (Printer.pp_var ~debug:false) x) in List.iteri check_writable_param params; if cc = None then FInfo.Subroutine @@ -2361,13 +2472,18 @@ let add_known_implicits arch_info env c = env, (s1, s2)) env arch_info.known_implicits in Env.set_known_implicits env known_implicits - let warn_unused_variables env f = - let used = List.fold_left (fun s v -> P.Spv.add (L.unloc v) s) P.Spv.empty f.P.f_ret in - let used = P.Spv.union used (P.pvars_c f.P.f_body) in + let used = P.fold_vars_fc P.Sv.add P.Sv.empty f in + (* we add the length vars used *) + let pvars_ty ty = + match ty with + | P.Bty _ -> P.Sv.empty + | Arr (_, len) -> P.vars_al len + in + let used = P.fold_vars_fc (fun x acc -> P.Sv.union (pvars_ty x.v_ty) acc) used f in let pp_var fmt x = F.fprintf fmt "%s.%s" x.P.v_name (CoreIdent.string_of_uid x.P.v_id) in Env.Vars.iter_locals (fun x -> - if not (P.Spv.mem x used) then + if not (P.Sv.mem x used) then warning UnusedVar (L.i_loc0 x.v_dloc) "unused variable %a" pp_var x) env @@ -2513,13 +2629,15 @@ let tt_contract arch_info env0 f_ret dfl_mut pf = (annot, f_contract) (* -------------------------------------------------------------------- *) -let tt_fundef arch_info (env0 : 'asm Env.env) loc (pf : S.pfundef) : 'asm Env.env = +let tt_fundef arch_info n (env0 : 'asm Env.env) loc (pf : S.pfundef) : 'asm Env.env = let env = Env.Vars.clear_locals env0 in if is_combine_flags pf.pdf_name then rs_tyerror ~loc:(L.loc pf.pdf_name) (string_error "invalid function name"); let inret = Option.map_default (List.map L.unloc) [] (L.unloc pf.pdf_body.pdb_ret) in let dfl_mut x = List.mem x inret in + let env, alargs = + List.map_fold tt_alarg env pf.pdf_alargs in let envb, args = let env, args = List.map_fold (tt_annot_paramdecls dfl_mut arch_info.pd) env pf.pdf_args in let env = add_known_implicits arch_info env pf.pdf_body.pdb_instr in @@ -2527,7 +2645,7 @@ let tt_fundef arch_info (env0 : 'asm Env.env) loc (pf : S.pfundef) : 'asm Env.en let fs_tout = Option.map_default (List.map (tt_type arch_info.pd env |- snd |- snd)) [] pf.pdf_rty in let ret_annot = Option.map_default (List.map fst) [] pf.pdf_rty in let ret_annot = List.map pannot_to_annotations ret_annot in - let body, ret_loc, xret = tt_funbody arch_info envb pf.pdf_body in + let body, ret_loc, xret = tt_funbody arch_info n envb pf.pdf_body in let f_args = List.map (fun x -> L.mk_loc (L.loc x) (fst (L.unloc x))) args in let fs_tin = List.map (fun x -> snd (L.unloc x)) args in let f_ret = List.map (fun x -> L.mk_loc (L.loc x) (fst (L.unloc x))) xret in @@ -2541,6 +2659,7 @@ let tt_fundef arch_info (env0 : 'asm Env.env) loc (pf : S.pfundef) : 'asm Env.en P.f_cc = f_cc; P.f_info = (); P.f_name = P.F.mk name; + P.f_al = List.map L.unloc alargs; P.f_tyin = List.map P.gty_of_gety fs_tin; P.f_args = List.map L.unloc f_args; P.f_body = body; @@ -2556,7 +2675,7 @@ let tt_fundef arch_info (env0 : 'asm Env.env) loc (pf : S.pfundef) : 'asm Env.en let return_storage = Option.map_default (List.map (fst |- snd)) [] pf.pdf_rty in check_return_storage ~loc fdef.P.f_name return_storage f_ret; - Env.Funs.push env0 fdef {fs_tin; fs_tout} + Env.Funs.push env0 fdef {fs_al = List.map L.unloc alargs; fs_tin; fs_tout} (* -------------------------------------------------------------------- *) let tt_global_def pd env (gd:S.gpexpr) = @@ -2608,10 +2727,10 @@ let tt_typealias arch_info env id ty = Env.TypeAlias.push env id alias (* -------------------------------------------------------------------- *) -let rec tt_item arch_info (env : 'asm Env.env) pt : 'asm Env.env = +let rec tt_item arch_info n (env : 'asm Env.env) pt : 'asm Env.env = match L.unloc pt with | S.PParam pp -> tt_param arch_info.pd env (L.loc pt) pp - | S.PFundef pf -> tt_fundef arch_info env (L.loc pt) pf + | S.PFundef pf -> tt_fundef arch_info n 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) @@ -2619,18 +2738,18 @@ let rec tt_item arch_info (env : 'asm Env.env) pt : 'asm Env.env = (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 + List.fold_left (tt_file_loc arch_info n from) env fs | S.PNamespace (ns, items) -> let env = Env.enter_namespace env ns in - let env = List.fold_left (tt_item arch_info) env items in + let env = List.fold_left (tt_item arch_info n) env items in let env = Env.exit_namespace env in env | S.PTypeAlias (id,ty) -> tt_typealias arch_info env id ty -and tt_file_loc arch_info from env fname = - fst (tt_file arch_info env from (Some (L.loc fname)) (L.unloc fname)) +and tt_file_loc arch_info n from env fname = + fst (tt_file arch_info n env from (Some (L.loc fname)) (L.unloc fname)) -and tt_file arch_info env from loc fname = +and tt_file arch_info n env from loc fname = match Env.enter_file env from loc fname with | None -> env, [] | Some(env, fname) -> @@ -2641,12 +2760,12 @@ and tt_file arch_info env from loc fname = let loc = Option.map_default (fun l -> Lone l) Lnone loc in hierror ~loc ~kind:"typing" "error reading file %S (%s)" fname err in - let env = List.fold_left (tt_item arch_info) env ast in + let env = List.fold_left (tt_item arch_info n) env ast in Env.exit_file env, ast (* -------------------------------------------------------------------- *) -let tt_program arch_info (env : 'asm Env.env) (fname : string) = - let env, ast = tt_file arch_info env None None fname in +let tt_program arch_info n (env : 'asm Env.env) (fname : string) = + let env, ast = tt_file arch_info n env None None fname in env, Env.decls env, ast (* FIXME : diff --git a/compiler/src/pretyping.mli b/compiler/src/pretyping.mli index 6940149e32..cd0781eaf9 100644 --- a/compiler/src/pretyping.mli +++ b/compiler/src/pretyping.mli @@ -4,13 +4,13 @@ exception TyError of Location.t * tyerror val pp_tyerror : Format.formatter -> tyerror -> unit -type fun_sig = { fs_tin : Prog.epty list ; fs_tout : Prog.epty list } +type fun_sig = { fs_al : Prog.var list; fs_tin : Prog.ety list ; fs_tout : Prog.ety list } module Env : sig type 'asm env val empty : 'asm env - val decls : 'asm env -> (unit, 'asm) Prog.pmod_item list + val decls : 'asm env -> (unit, 'asm) Prog.mod_item list val add_from : 'asm env -> string * string -> 'asm env val dependencies : 'asm env -> string list list @@ -24,12 +24,12 @@ module Env : sig val exit_file : 'asm env -> 'asm env module Funs : sig - val push : 'asm env -> (unit, 'asm) Prog.pfunc -> fun_sig -> 'asm env + val push : 'asm env -> (unit, 'asm) Prog.func -> fun_sig -> 'asm env val find : Annotations.symbol -> 'asm env -> - ((unit, 'asm) Prog.pfunc * fun_sig) option + ((unit, 'asm) Prog.func * fun_sig) option end module Exec : sig @@ -53,6 +53,7 @@ type ('a, 'b, 'c, 'd, 'e, 'f, 'g) arch_info = { val tt_item : ('a, 'b, 'c, 'd, 'e, 'f, 'g) arch_info -> + Type.length_var -> ('a, 'b, 'c, 'd, 'e, 'f, 'g) Arch_extra.extended_op Env.env -> Syntax.pitem Location.located -> ('a, 'b, 'c, 'd, 'e, 'f, 'g) Arch_extra.extended_op Env.env @@ -62,6 +63,7 @@ val tt_param : val tt_fundef : ('a, 'b, 'c, 'd, 'e, 'f, 'g) arch_info -> + Type.length_var -> ('a, 'b, 'c, 'd, 'e, 'f, 'g) Arch_extra.extended_op Env.env -> Location.t -> Syntax.pfundef -> @@ -73,19 +75,21 @@ val tt_global : val tt_fun : 'asm Env.env -> Annotations.symbol Location.located -> - (unit, 'asm) Prog.pfunc * fun_sig + (unit, 'asm) Prog.func * fun_sig val tt_program : ('a, 'b, 'c, 'd, 'e, 'f, 'g) arch_info -> + Type.length_var -> ('a, 'b, 'c, 'd, 'e, 'f, 'g) Arch_extra.extended_op Env.env -> string -> ('a, 'b, 'c, 'd, 'e, 'f, 'g) Arch_extra.extended_op Env.env - * (unit, ('a, 'b, 'c, 'd, 'e, 'f, 'g) Arch_extra.extended_op) Prog.pmod_item + * (unit, ('a, 'b, 'c, 'd, 'e, 'f, 'g) Arch_extra.extended_op) Prog.mod_item list * Syntax.pprogram val tt_file : ('a, 'b, 'c, 'd, 'e, 'f, 'g) arch_info -> + Type.length_var -> ('a, 'b, 'c, 'd, 'e, 'f, 'g) Arch_extra.extended_op Env.env -> Annotations.pident option -> Location.t option -> diff --git a/compiler/src/printCommon.ml b/compiler/src/printCommon.ml index 0d5fbcf182..135b16c9e0 100644 --- a/compiler/src/printCommon.ml +++ b/compiler/src/printCommon.ml @@ -150,8 +150,8 @@ let string_of_op2 = function let pp_opn pd msfsz asmOp fmt o = pp_string fmt (Sopn.string_of_sopn pd msfsz asmOp o) (* -------------------------------------------------------------------- *) -let pp_syscall (o : 'a Syscall_t.syscall_t) = - match o with Syscall_t.RandomBytes _ -> "#randombytes" +let pp_syscall (o : Syscall.syscall_t) = + match o with Syscall.RandomBytes -> "#randombytes" (* -------------------------------------------------------------------- *) let pp_bool fmt b = if b then fprintf fmt "true" else fprintf fmt "false" @@ -171,6 +171,7 @@ let pp_kind fmt = function | Reg (_k, ptr) -> fprintf fmt "reg%a" pp_pointer ptr | Inline -> fprintf fmt "inline" | Global -> fprintf fmt "global" + | Length -> assert false (* -------------------------------------------------------------------- *) let w_of_signedess = function @@ -219,10 +220,6 @@ let pp_arr_slice pp_gvar pp_expr pp_len fmt aa ws x e len = (if aa = Warray_.AAdirect then "." else "") pp_access_size ws pp_expr (peel_implicit_cast_to_uint e) pp_len len -(* -------------------------------------------------------------------- *) -let pp_len fmt len = fprintf fmt "%i" len -let pp_ty fmt = pp_gtype pp_len fmt - (* -------------------------------------------------------------------- *) let pp_datas fmt data = let pp_w fmt w = diff --git a/compiler/src/printCommon.mli b/compiler/src/printCommon.mli index 200c86d5df..00412182e6 100644 --- a/compiler/src/printCommon.mli +++ b/compiler/src/printCommon.mli @@ -11,7 +11,7 @@ val pp_opn : Wsize.wsize -> Wsize.wsize -> 'asm Sopn.asmOp -> Format.formatter -> 'asm Sopn.sopn -> unit -val pp_syscall : (Wsize.wsize * BinNums.positive) Syscall_t.syscall_t -> string +val pp_syscall : Syscall.syscall_t -> string val pp_bool : Format.formatter -> bool -> unit val pp_kind : Format.formatter -> Wsize.v_kind -> unit val pp_btype : ?w:Wsize.signedness -> Format.formatter -> Prog.base_ty -> unit @@ -56,8 +56,6 @@ val pp_arr_slice : 'len -> unit -val pp_len : Format.formatter -> int -> unit -val pp_ty : Format.formatter -> Prog.ty -> unit val pp_datas : Format.formatter -> Word0.word list -> unit val pp_var : Format.formatter -> Var0.Var.var -> unit val pp_var_i : Format.formatter -> Expr.var_i -> unit diff --git a/compiler/src/printExportInfo.ml b/compiler/src/printExportInfo.ml index 2110194473..6b3c1019ef 100644 --- a/compiler/src/printExportInfo.ml +++ b/compiler/src/printExportInfo.ml @@ -14,7 +14,7 @@ module F = Format type export_info = { arch_target : architecture; funcs : export_info_fn list; - params : (pexpr_ gvar * pexpr_ gexpr) list; + params : (var * expr) list; } and export_info_fn = { @@ -73,7 +73,8 @@ let collect_export_info env prog asm_prog = (***********************************************************************) -let pp_size fmt i = F.fprintf fmt "%i" i +let pp_size = Printer.pp_len ~debug:false +(* FIXME: maybe print only consts and assert false or fail for other cases *) let escape_string_json s = String.replace_chars (function @@ -148,7 +149,7 @@ let pp_export_info_json fmt export_info = let pp_param fmt (var, expr) = let pp_gvar fmt var = F.fprintf fmt "%S" var.v_name in F.fprintf fmt "@[{@[\"name\" : %a,@ \"expr\" : @[\"%a\"@]@]}@]" - pp_gvar var (pp_pexpr ~debug:false) expr + pp_gvar var (pp_expr ~debug:false) expr in F.fprintf fmt "@[%a@]" (pp_list ",@ " pp_param) globals in diff --git a/compiler/src/printLinear.ml b/compiler/src/printLinear.ml index 1b2c2e5919..8f816cb825 100644 --- a/compiler/src/printLinear.ml +++ b/compiler/src/printLinear.ml @@ -53,6 +53,8 @@ let pp_instr pd msfsize asmOp fmt i = | LstoreLabel (x, lbl) -> F.fprintf fmt "%a = Label %a" pp_var x pp_label lbl | Lcond (e, lbl) -> F.fprintf fmt "If %a goto %a" pp_fexpr e pp_label lbl +(* arrays should no longer be there, hence the [assert false] *) +let pp_ty = PrintCommon.pp_gtype (fun _ _ -> assert false) let pp_param fmt x = let y = Conv.var_of_cvar x.E.v_var in F.fprintf fmt "%a %a %s" pp_kind y.P.v_kind pp_ty y.P.v_ty y.P.v_name diff --git a/compiler/src/printer.ml b/compiler/src/printer.ml index 91833ac78e..9a6ef450ca 100644 --- a/compiler/src/printer.ml +++ b/compiler/src/printer.ml @@ -66,7 +66,7 @@ let pp_ge_aux ~debug (pp_len: 'len pp) (pp_var: 'len gvar pp) : associativity -> begin match as_string es with | s -> F.fprintf fmt "%S" s | exception Not_found -> - F.fprintf fmt "/* %du8 */ @[{ %a }@]" (Conv.int_of_pos len) (pp_list ",@ " (pp_expr NoAssoc priority_min)) es + F.fprintf fmt "/* %du8 */ @[{ %a }@]" (CoreConv.int_of_cz len) (pp_list ",@ " (pp_expr NoAssoc priority_min)) es end | Pif(_, e,e1,e2) -> let p = priority_ternary in @@ -195,9 +195,15 @@ let rec pp_gi ~debug pp_info pp_len pp_opn pp_var fmt i = (pp_ges ~debug pp_len pp_var) e pp_optional_comment (pp_tag t) - | Csyscall(x, o, e) -> - F.fprintf fmt "@[%a%s(%a);@]" - (pp_glvs ~debug pp_len pp_var) x (pp_syscall o) (pp_ges ~debug pp_len pp_var) e + | Csyscall(x, o, al, e) -> + let pp_al fmt al = + if al = [] then () + else + F.fprintf fmt "{%a}" (pp_list ",@ " pp_len) al + in + F.fprintf fmt "@[%a%s%a(%a);@]" + (pp_glvs ~debug pp_len pp_var) x (pp_syscall o) + pp_al al (pp_ges ~debug pp_len pp_var) e | Cassert(msg, e) -> F.fprintf fmt "@[assert(\"%a\", %a);@]" @@ -242,12 +248,19 @@ let rec pp_gi ~debug pp_info pp_len pp_opn pp_var fmt i = (pp_ge ~debug pp_len pp_var) e (pp_cblock ~debug pp_info pp_len pp_opn pp_var) c' - | Ccall(x, f, e) -> + | Ccall(x, f, al, e) -> let pp_x fmt = function | [] -> () | x -> F.fprintf fmt "%a" (pp_glvs ~debug pp_len pp_var) x in - F.fprintf fmt "@[%a%s(%a);@]" - pp_x x f.fn_name (pp_ges ~debug pp_len pp_var) e + let pp_al fmt al = + if al = [] then () + else + F.fprintf fmt "{%a}" (pp_list ",@ " pp_len) al + in + F.fprintf fmt "@[%a%s%a(%a);@]" + pp_x x f.fn_name + pp_al al + (pp_ges ~debug pp_len pp_var) e (* -------------------------------------------------------------------- *) and pp_gc ~debug pp_info pp_len pp_opn pp_var fmt c = @@ -297,8 +310,8 @@ let pp_gfun ~debug (pp_size:F.formatter -> 'size -> unit) pp_opn pp_var fmt fd = let ds = ScopeTree.get_declaration_sites fd in let pp_vd = pp_var_decl pp_var pp_size in let pp_info fmt (n, _) = - Miloc.find_default Spv.empty n ds - |> Spv.iter (F.fprintf fmt "%a;@ " pp_vd) + Miloc.find_default Sv.empty n ds + |> Sv.iter (F.fprintf fmt "%a;@ " pp_vd) in let ret = List.map L.unloc fd.f_ret in let set_var_type x ty = GV.mk x.v_name x.v_kind ty x.v_dloc x.v_annot in @@ -313,12 +326,18 @@ let pp_gfun ~debug (pp_size:F.formatter -> 'size -> unit) pp_opn pp_var fmt fd = if not (List.mem x fd.f_args) then F.fprintf fmt "%a;@ " pp_vd x) ret; F.fprintf fmt "return @[%a@];" (pp_list ",@ " pp_var) ret in + let pp_al fmt al = + if al = [] then () + else + (F.fprintf fmt "@["; Format.fprintf fmt "{%a}@]" (pp_list ",@ " pp_var) al) + in - F.fprintf fmt "@[%a%a%afn %s @[(%a)@] -> @[(%a)@] {@ @[%a@ %a@]@ }@]" + F.fprintf fmt "@[%a%a%afn %s%a @[(%a)@] -> @[(%a)@] {@ @[%a@ %a@]@ }@]" pp_annotations fd.f_annot.f_user_annot (pp_ocontract ~debug pp_size pp_var) fd.f_contract pp_call_conv fd.f_cc fd.f_name.fn_name + pp_al fd.f_al (pp_list ",@ " pp_vd) fd.f_args (pp_return_type pp_size) (List.combine fd.f_ret_info.ret_annot (List.map2 set_var_type ret fd.f_tyout)) (pp_gc ~debug pp_info pp_size pp_opn pp_var) fd.f_body @@ -353,7 +372,7 @@ and pp_pexpr_ ~debug fmt (PE e) = pp_pexpr ~debug fmt e let pp_ptype ~debug = pp_gtype (pp_pexpr_ ~debug) -let pp_eptype ~debug fmt ty = +let pp_egtype ~debug pp_len fmt ty = match ty with | ETbool -> Format.fprintf fmt "bool" | ETint -> Format.fprintf fmt "int" @@ -365,43 +384,26 @@ let pp_eptype ~debug fmt ty = in Format.fprintf fmt "%s%i" sg (int_of_ws sz) | ETarr(ws, len) -> - Format.fprintf fmt "%a[%a]" (pp_btype ?w:None) (U ws) (pp_pexpr_ ~debug) len + Format.fprintf fmt "%a[%a]" (pp_btype ?w:None) (U ws) (pp_len ~debug) len +let pp_eptype ~debug = pp_egtype ~debug pp_pexpr_ let pp_plval ~debug = pp_glv ~debug (pp_pexpr_ ~debug) pp_pvar -let pp_pprog ~debug pd msfsize asmOp fmt p = - let pp_opn = pp_opn pd msfsize asmOp in - Format.fprintf fmt "@[%a@]" - (pp_list "@ @ " (pp_pitem ~debug (pp_pexpr_ ~debug) pp_opn pp_pvar)) (List.rev p) - -let pp_header_ pp_var fmt fd = +let pp_header_ pp_len pp_var fmt fd = let pp_vd = pp_var_decl pp_var pp_len in let ret = List.map L.unloc fd.f_ret in - F.fprintf fmt "fn %s @[(%a)@] -> @[(%a)@]" + let pp_al fmt al = + if al = [] then () + else + (F.fprintf fmt "@["; Format.fprintf fmt "{%a}@]" (pp_list ",@ " pp_var) al) + in + F.fprintf fmt "fn %s%a @[(%a)@] -> @[(%a)@]" fd.f_name.fn_name + pp_al fd.f_al (pp_list ",@ " pp_vd) fd.f_args (pp_list ",@ " (pp_ty_decl pp_len)) ret -let pp_fun_ ~debug ?pp_locals ?(pp_info=pp_noinfo) pp_opn pp_var fmt fd = - let pp_vd = pp_var_decl pp_var pp_len in - let pp_locals = Option.default (fun fmt -> Sv.iter (F.fprintf fmt "%a;@ " pp_vd)) pp_locals in - let locals = locals fd in - let ret = List.map L.unloc fd.f_ret in - let pp_ret fmt () = - F.fprintf fmt "return @[(%a)@];" - (pp_list ",@ " pp_var) ret in - F.fprintf fmt "@[%a%a%a {@ @[%a@ %a@ %a@]@ }@]" - pp_call_conv fd.f_cc - (pp_ocontract ~debug pp_len pp_var) fd.f_contract - (pp_header_ pp_var) fd - pp_locals locals - (pp_gc ~debug pp_info pp_len pp_opn pp_var) fd.f_body - pp_ret () - -let pp_fun ~debug ?pp_locals ?(pp_info=pp_noinfo) pp_opn pp_var fmt fd = - pp_fun_ ~debug ?pp_locals ~pp_info pp_opn pp_var fmt fd - let pp_var ~debug = if debug then fun fmt x -> F.fprintf fmt "%s.%s" x.v_name (string_of_uid x.v_id) @@ -414,42 +416,71 @@ let pp_dvar ~debug fmt x = in F.fprintf fmt "%a%a" (pp_var ~debug) x pp_dloc x.v_dloc +let rec pp_expr ~debug fmt e = + pp_ge ~debug (pp_len ~debug) (pp_var ~debug) fmt e +and pp_len ~debug fmt (len:length) = + pp_expr ~debug fmt (Prog.expr_of_al len) +let pp_ty ~debug fmt = pp_gtype (pp_len ~debug) fmt + +let pp_etype ~debug = pp_egtype ~debug pp_len + +let pp_pprog ~debug pd msfsize asmOp fmt p = + let pp_opn = pp_opn pd msfsize asmOp in + Format.fprintf fmt "@[%a@]" + (pp_list "@ @ " (pp_pitem ~debug (pp_len ~debug:false) pp_opn pp_pvar)) (List.rev p) + +let pp_fun ~debug ?pp_locals ?(pp_info=pp_noinfo) pp_opn pp_var fmt fd = + let pp_vd = pp_var_decl pp_var (pp_len ~debug) in + let pp_locals = Option.default (fun fmt -> Sv.iter (F.fprintf fmt "%a;@ " pp_vd)) pp_locals in + let locals = locals fd in + let ret = List.map L.unloc fd.f_ret in + let pp_ret fmt () = + F.fprintf fmt "return @[(%a)@];" + (pp_list ",@ " pp_var) ret in + F.fprintf fmt "@[%a%a%a {@ @[%a@ %a@ %a@]@ }@]" + pp_call_conv fd.f_cc + (pp_ocontract ~debug (pp_len ~debug) pp_var) fd.f_contract + (pp_header_ (pp_len ~debug) pp_var) fd + pp_locals locals + (pp_gc ~debug pp_info (pp_len ~debug) pp_opn pp_var) fd.f_body + pp_ret () + let pp_expr ~debug fmt e = - pp_ge ~debug pp_len (pp_var ~debug) fmt e + pp_ge ~debug (pp_len ~debug) (pp_var ~debug) fmt e let pp_eassert ~debug fmt e = - pp_ga ~debug pp_len (pp_var ~debug) fmt e + pp_ga ~debug (pp_len ~debug) (pp_var ~debug) fmt e let pp_lval ~debug fmt x = - pp_glv ~debug pp_len (pp_var ~debug) fmt x + pp_glv ~debug (pp_len ~debug) (pp_var ~debug) fmt x let pp_instr ~debug pd msfsize asmOp fmt i = let pp_opn = pp_opn pd msfsize asmOp in let pp_var = pp_var ~debug in - pp_gi ~debug pp_noinfo pp_len pp_opn pp_var fmt i + pp_gi ~debug pp_noinfo (pp_len ~debug) pp_opn pp_var fmt i let pp_stmt ~debug pd msfsize asmOp fmt i = let pp_opn = pp_opn pd msfsize asmOp in let pp_var = pp_var ~debug in - pp_gc ~debug pp_noinfo pp_len pp_opn pp_var fmt i + pp_gc ~debug pp_noinfo (pp_len ~debug) pp_opn pp_var fmt i let pp_header ~debug fmt fd = + let pp_len = pp_len ~debug in let pp_var = pp_var ~debug in - pp_header_ pp_var fmt fd + pp_header_ pp_len pp_var fmt fd let pp_ifunc ~debug pp_info pd msfsize asmOp fmt fd = let pp_opn = pp_opn pd msfsize asmOp in let pp_var = pp_var ~debug in - pp_fun_ ~debug ~pp_info pp_opn pp_var fmt fd + pp_fun ~debug ~pp_info pp_opn pp_var fmt fd let pp_func ~debug pd msfsize asmOp fmt fd = let pp_opn = pp_opn pd msfsize asmOp in let pp_var = pp_var ~debug in - pp_fun_ ~debug pp_opn pp_var fmt fd + pp_fun ~debug pp_opn pp_var fmt fd -let pp_glob pp_var fmt (x, gd) = - let pp_size fmt i = F.fprintf fmt "%i" i in - let pp_vd = pp_var_decl pp_var pp_size in +let pp_glob pp_len pp_var fmt (x, gd) = + let pp_vd = pp_var_decl pp_var pp_len in let pp_gd fmt gd = match gd with | Global.Gword(ws,w) -> @@ -462,23 +493,25 @@ let pp_glob pp_var fmt (x, gd) = Format.fprintf fmt "@[%a =@ %a;@]" pp_vd x pp_gd gd -let pp_globs pp_var fmt gds = +let pp_globs pp_len pp_var fmt gds = Format.fprintf fmt "@[%a@]" - (pp_list "@ @ " (pp_glob pp_var)) (List.rev gds) + (pp_list "@ @ " (pp_glob pp_len pp_var)) (List.rev gds) let pp_iprog ~debug pp_info pd msfsize asmOp fmt (gd, funcs) = let pp_opn = pp_opn pd msfsize asmOp in + let pp_len = pp_len ~debug in let pp_var = pp_var ~debug in Format.fprintf fmt "@[%a@ %a@]" - (pp_globs pp_var) gd - (pp_list "@ @ " (pp_fun_ ~debug ~pp_info pp_opn pp_var)) (List.rev funcs) + (pp_globs pp_len pp_var) gd + (pp_list "@ @ " (pp_fun ~debug ~pp_info pp_opn pp_var)) (List.rev funcs) let pp_prog ~debug pd msfsize asmOp fmt ((gd, funcs):('info, 'asm) Prog.prog) = let pp_opn = pp_opn pd msfsize asmOp in + let pp_len = pp_len ~debug in let pp_var = pp_var ~debug in Format.fprintf fmt "@[%a@ %a@]" - (pp_globs pp_var) gd - (pp_list "@ @ " (pp_fun_ ~debug pp_opn pp_var)) (List.rev funcs) + (pp_globs pp_len pp_var) gd + (pp_list "@ @ " (pp_fun ~debug pp_opn pp_var)) (List.rev funcs) let pp_to_save ~debug fmt (x, ofs) = Format.fprintf fmt "%a/%a" (pp_var ~debug) (Conv.var_of_cvar x) Z.pp_print (Conv.z_of_cz ofs) @@ -526,7 +559,7 @@ let pp_sprog ~debug pd msfsize asmOp fmt ((funcs, p_extra):('info, 'asm) Prog.sp (pp_return_address ~debug) (f_extra.Expr.sf_return_address) in let pp_fun fmt (f_extra,f) = - Format.fprintf fmt "@[%a@ %a@]" pp_f_extra f_extra (pp_fun_ ~debug pp_opn pp_var) f in + Format.fprintf fmt "@[%a@ %a@]" pp_f_extra f_extra (pp_fun ~debug pp_opn pp_var) f in let pp_p_extra fmt p_extra = Format.fprintf fmt "global data:@ %a" pp_datas p_extra.Expr.sp_globs in Format.fprintf fmt "@[%a@ %a@]" @@ -551,7 +584,7 @@ let pp_err ~debug fmt (pp_e : Compiler_util.pp_error) = Format.fprintf fmt "%a" L.pp_loc loc | Compiler_util.PPElval x -> x |> Conv.lval_of_clval |> - pp_glv ~debug pp_len pp_var fmt + pp_glv ~debug (pp_len ~debug) pp_var fmt | Compiler_util.PPEfunname fn -> Format.fprintf fmt "%s" fn.fn_name | Compiler_util.PPEiinfo ii -> let i_loc, _ = ii in diff --git a/compiler/src/printer.mli b/compiler/src/printer.mli index 52831b6970..118c1b6ecd 100644 --- a/compiler/src/printer.mli +++ b/compiler/src/printer.mli @@ -11,11 +11,12 @@ val pp_eptype : debug:bool -> Format.formatter -> epty -> unit val pp_plval : debug:bool -> Format.formatter -> plval -> unit val pp_pexpr : debug:bool -> Format.formatter -> pexpr -> unit val pp_pprog : debug:bool -> Wsize.wsize -> Wsize.wsize -> ('reg, 'regx, 'xreg, 'rflag, 'cond, 'asm_op, 'extra_op) Arch_extra.extended_op Sopn.asmOp -> - Format.formatter -> ('info, ('reg, 'regx, 'xreg, 'rflag, 'cond, 'asm_op, 'extra_op) Arch_extra.extended_op) pprog -> unit + Format.formatter -> (length,'info, ('reg, 'regx, 'xreg, 'rflag, 'cond, 'asm_op, 'extra_op) Arch_extra.extended_op) gprog -> unit val pp_var : debug:bool -> Format.formatter -> var -> unit val pp_dvar : debug:bool -> Format.formatter -> var -> unit +val pp_etype : debug:bool -> Format.formatter -> ety -> unit val string_of_combine_flags : Operators.combine_flags -> string val pp_expr : debug:bool -> Format.formatter -> expr -> unit @@ -83,3 +84,5 @@ val pp_sprog : debug:bool -> ('reg, 'regx, 'xreg, 'rflag, 'cond, 'asm_op, 'extra_op) Arch_extra.extended_op Sopn.asmOp -> Format.formatter -> ('info, ('reg, 'regx, 'xreg, 'rflag, 'cond, 'asm_op, 'extra_op) Arch_extra.extended_op) sprog -> unit +val pp_len : debug:bool -> Format.formatter -> CoreIdent.length -> unit +val pp_ty : debug:bool -> Format.formatter -> Prog.ty -> unit diff --git a/compiler/src/prog.ml b/compiler/src/prog.ml index 0d52df59b2..587ca42542 100644 --- a/compiler/src/prog.ml +++ b/compiler/src/prog.ml @@ -105,12 +105,12 @@ type ('len, 'info, 'asm) ginstr_r = | Cassgn of 'len glval * E.assgn_tag * 'len gty * 'len gexpr (* turn 'asm Sopn.sopn into 'sopn? could be useful to ensure that we remove things statically *) | Copn of 'len glvals * E.assgn_tag * 'asm Sopn.sopn * 'len gexprs - | Csyscall of 'len glvals * (Wsize.wsize * BinNums.positive) Syscall_t.syscall_t * 'len gexprs + | Csyscall of 'len glvals * Syscall.syscall_t * 'len list * 'len gexprs | Cassert of 'len assertion | Cif of 'len gexpr * ('len, 'info, 'asm) gstmt * ('len, 'info, 'asm) gstmt | Cfor of 'len gvar_i * 'len grange * ('len, 'info, 'asm) gstmt | Cwhile of E.align * ('len, 'info, 'asm) gstmt * 'len gexpr * (IInfo.t * 'info) * ('len, 'info, 'asm) gstmt - | Ccall of 'len glvals * funname * 'len gexprs + | Ccall of 'len glvals * funname * 'len list * 'len gexprs and ('len,'info,'asm) ginstr = { i_desc : ('len, 'info, 'asm) ginstr_r; @@ -137,6 +137,7 @@ type ('len, 'info, 'asm) gfunc = { f_contract: 'len gfcontract option; f_cc : FInfo.call_conv; f_name : funname; + f_al : 'len gvar list; f_tyin : 'len gty list; f_args : 'len gvar list; f_body : ('len, 'info, 'asm) gstmt; @@ -176,7 +177,7 @@ and pexpr = pexpr_ gexpr and pexpr_ = PE of pexpr [@@unboxed] -type range = int grange +type range = length grange type epty = pexpr_ gety @@ -235,24 +236,138 @@ let ws_of_ety = function | ETword(_, ws) -> ws | _ -> assert false +let rec insert_mono x mono = + match mono with + | [] -> [x] + | y :: mono' -> + if x <= y then x :: mono + else y :: insert_mono x mono' + +let add_term ((coeff, _) as cm) terms = + if coeff = 0 then terms else cm :: terms + +let rec insert_term ((coeff, mono) as cm) terms = + match terms with + | [] -> [cm] + | ((coeff', mono') as cm') :: terms' -> + if mono < mono' then cm :: terms + else if mono = mono' then add_term (coeff + coeff', mono) terms' + else cm' :: insert_term cm terms' +let insert_term ((coeff, _) as cm) terms = + if coeff = 0 then terms else insert_term cm terms + +let expanded_form len = + let rec expanded_form terms coeff mono poly = + match poly with + | Const n -> let coeff = n * coeff in insert_term (coeff, mono) terms + | Var x -> let mono = insert_mono x mono in insert_term (coeff, mono) terms + | Neg e -> expanded_form terms (-coeff) mono e + | Add (e1, e2) -> expanded_form (expanded_form terms coeff mono e1) coeff mono e2 + | Sub (e1, e2) -> expanded_form (expanded_form terms coeff mono e1) (-coeff) mono e2 + | Mul (Const n, e) -> let coeff = n * coeff in expanded_form terms coeff mono e + | Mul (Var x, e) -> let mono = insert_mono x mono in expanded_form terms coeff mono e + | Mul (Neg e1, e2) -> expanded_form terms (-coeff) mono (Mul (e1, e2)) + | Mul (Add (e11, e12), e2) -> expanded_form terms coeff mono (Add (Mul (e11, e2), Mul (e12, e2))) + | Mul (Sub (e11, e12), e2) -> expanded_form terms coeff mono (Sub (Mul (e11, e2), Mul (e12, e2))) + | Mul (Mul (e11, e12), e2) -> expanded_form terms coeff mono (Mul (e11, Mul (e12, e2))) + | Mul ((Div _ | Mod _ | Shl _ | Shr _), _) -> [] + | Div _ | Mod _ | Shl _ | Shr _ -> [] + in + expanded_form [] 1 [] len + +let rec is_poly al = + match al with + | Const _ | Var _ -> true + | Neg al -> is_poly al + | Add (al1, al2) | Sub (al1, al2) | Mul (al1, al2) -> is_poly al1 && is_poly al2 + | Div _ | Mod _ | Shl _ | Shr _ -> false + +let size_of_ws = function + | U8 -> 1 + | U16 -> 2 + | U32 -> 4 + | U64 -> 8 + | U128 -> 16 + | U256 -> 32 + +(* FIXME: [=] might be too strict *) +let compare_array_length (ws, al) (ws', al') = + if is_poly al && is_poly al' then + let ef = expanded_form (Mul (Const (size_of_ws ws), al)) in + let ef' = expanded_form (Mul (Const (size_of_ws ws'), al')) in + ef = ef' + else + (ws = ws') && (al = al') + +let ety_equal t1 t2 = + match t1, t2 with + | ETbool, ETbool | ETint, ETint -> true + | ETword(s1,sz1), ETword(s2, sz2) -> s1 = s2 && sz1 = sz2 + | ETarr(ws1, len1) , ETarr(ws2, len2) -> compare_array_length (ws1, len1) (ws2, len2) + | _, _ -> false + +let rec al_of_expr e = + match e with + | Pconst n -> + (* FIXME: change Const to Z and remove this error *) + begin try Const (Z.to_int n) + with Z.Overflow -> + hierror ~loc:Lnone ~kind:"compilation error" ~sub_kind:"param expansion" "number too big" + end + | Pvar x -> assert (is_gkvar x); Var (L.unloc x.gv) + | Papp1 (Oneg Op_int, e) -> + Neg (al_of_expr e) + | Papp2 (Oadd Op_int, e1, e2) -> + Add (al_of_expr e1, al_of_expr e2) + | Papp2 (Osub Op_int, e1, e2) -> + Sub (al_of_expr e1, al_of_expr e2) + | Papp2 (Omul Op_int, e1, e2) -> + Mul (al_of_expr e1, al_of_expr e2) + | Papp2 (Odiv (sg, Op_int), e1, e2) -> + Div (sg, al_of_expr e1, al_of_expr e2) + | Papp2 (Omod (sg, Op_int), e1, e2) -> + Mod (sg, al_of_expr e1, al_of_expr e2) + | Papp2 (Olsl Op_int, e1, e2) -> + Shl (al_of_expr e1, al_of_expr e2) + | Papp2 (Oasr Op_int, e1, e2) -> + Shr (al_of_expr e1, al_of_expr e2) + | _ -> + (* FIXME: better error message *) + hierror ~loc:Lnone ~kind:"compilation error" ~sub_kind:"param expansion" "operations too complex" + +let rec expr_of_al al = + match al with + | Const n -> Pconst (Z.of_int n) + | Var x -> Pvar (gkvar (L.mk_loc L._dummy x)) + | Neg al -> Papp1 (Oneg Op_int, expr_of_al al) + | Add (al1, al2) -> Papp2 (Oadd Op_int, expr_of_al al1, expr_of_al al2) + | Sub (al1, al2) -> Papp2 (Osub Op_int, expr_of_al al1, expr_of_al al2) + | Mul (al1, al2) -> Papp2 (Omul Op_int, expr_of_al al1, expr_of_al al2) + | Div (sg, al1, al2) -> Papp2 (Odiv (sg, Op_int), expr_of_al al1, expr_of_al al2) + | Mod (sg, al1, al2) -> Papp2 (Omod (sg, Op_int), expr_of_al al1, expr_of_al al2) + | Shl (al1, al2) -> Papp2 (Olsl Op_int, expr_of_al al1, expr_of_al al2) + | Shr (al1, al2) -> Papp2 (Oasr Op_int, expr_of_al al1, expr_of_al al2) (* ------------------------------------------------------------------------ *) (* Non parametrized expression *) -type ty = int gty -type var = int gvar -type var_i = int gvar_i -type lval = int glval -type lvals = int glval list -type expr = int gexpr -type exprs = int gexpr list -type eassert = int gassert -type ('info, 'asm) instr = (int, 'info, 'asm) ginstr -type ('info, 'asm) instr_r = (int,'info,'asm) ginstr_r -type ('info, 'asm) stmt = (int, 'info, 'asm) gstmt - -type ('info, 'asm) func = (int, 'info, 'asm) gfunc -type ('info, 'asm) mod_item = (int, 'info, 'asm) gmod_item +type ty = length gty +type var = length gvar +type var_i = length gvar_i +type lval = length glval +type lvals = length glval list +type expr = length gexpr +type exprs = length gexpr list +type eassert = length gassert + +type ety = length gety + +type ('info, 'asm) instr = (length, 'info, 'asm) ginstr +type ('info, 'asm) instr_r = (length,'info,'asm) ginstr_r +type ('info, 'asm) stmt = (length, 'info, 'asm) gstmt + +type ('info, 'asm) func = (length, 'info, 'asm) gfunc +type ('info, 'asm) mod_item = (length, 'info, 'asm) gmod_item type global_decl = var * Global.glob_value type ('info,'asm) prog = global_decl list * ('info, 'asm) func list @@ -266,6 +381,13 @@ let ident_of_var (x:var) : CoreIdent.var = x (* -------------------------------------------------------------------- *) (* used variables *) +let rec rvars_al f s al = + match al with + | Const _ -> s + | Var x -> f x s + | Neg al -> rvars_al f s al + | Add (al1, al2) | Sub (al1, al2) | Mul (al1, al2) | Div (_, al1, al2) | Mod (_, al1, al2) | Shl (al1, al2) | Shr (al1, al2) -> rvars_al f (rvars_al f s al1) al2 + let rvars_v f x s = if is_gkvar x then f (L.unloc x.gv) s else s @@ -303,13 +425,13 @@ let rvars_as f s es = List.fold_left (fun s (_, a) -> rvars_a f s a) s es let rec rvars_i f s i = match i.i_desc with | Cassgn(x, _, _, e) -> rvars_e f (rvars_lv f s x) e - | Copn(x,_,_,e) | Csyscall (x, _, e) -> rvars_es f (rvars_lvs f s x) e + | Copn(x,_,_,e) | Csyscall (x, _, _, e) -> rvars_es f (rvars_lvs f s x) e | Cassert(_, e) -> rvars_a f s e | Cif(e,c1,c2) -> rvars_c f (rvars_c f (rvars_e f s e) c1) c2 | Cfor(x,(_,e1,e2), c) -> rvars_c f (rvars_e f (rvars_e f (f (L.unloc x) s) e1) e2) c | Cwhile(_, c, e, _, c') -> rvars_c f (rvars_e f (rvars_c f s c') e) c - | Ccall(x,_,e) -> rvars_es f (rvars_lvs f s x) e + | Ccall(x,_,_,e) -> rvars_es f (rvars_lvs f s x) e and rvars_c f s c = List.fold_left (rvars_i f) s c @@ -320,9 +442,11 @@ let fold_vars_fc f z fc = let a = fold_vars_ret f z fc in rvars_c f a fc.f_body +let vars_al al = rvars_al Sv.add Sv.empty al let vars_ret fd = fold_vars_ret Sv.add Sv.empty fd let vars_lv z x = rvars_lv Sv.add z x let vars_e e = rvars_e Sv.add Sv.empty e +let pvars_e e = rvars_e Spv.add Spv.empty e let vars_es es = rvars_es Sv.add Sv.empty es let vars_a a = rvars_a Sv.add Sv.empty a let vars_i i = rvars_i Sv.add Sv.empty i @@ -352,8 +476,7 @@ let vars_fc_contract fc = let locals fc = let s1 = params fc in - let s2 = Sv.diff (vars_fc fc) s1 in - Sv.filter V.is_local s2 + Sv.diff (vars_fc fc) s1 let written_lv s = function @@ -366,9 +489,9 @@ let written_lv s = let rec written_vars_i ((v, f) as acc) i = match i.i_desc with | Cassgn(x, _, _, _) -> written_lv v x, f - | Copn(xs, _, _, _) | Csyscall(xs, _, _) + | Copn(xs, _, _, _) | Csyscall(xs, _, _, _) -> List.fold_left written_lv v xs, f - | Ccall(xs, fn, _) -> + | Ccall(xs, fn, _, _) -> List.fold_left written_lv v xs, Mf.modify_def [] fn (fun old -> i.i_loc :: old) f | Cassert (_, _) -> v, f | Cif(_, s1, s2) @@ -412,14 +535,6 @@ let refresh_i_loc_p (p:('info, 'asm) prog) : ('info, 'asm) prog = let int_of_ws = Annotations.int_of_ws -let size_of_ws = function - | U8 -> 1 - | U16 -> 2 - | U32 -> 4 - | U64 -> 8 - | U128 -> 16 - | U256 -> 32 - let string_of_ws = Annotations.string_of_ws let wsize_lt ws1 ws2 = Wsize.wsize_cmp ws1 ws2 = Datatypes.Lt @@ -447,6 +562,10 @@ let array_kind = function | Arr(ws, n) -> ws, n | _ -> assert false +let array_kind_const = function + | Arr (ws, Const n) -> ws, n + | _ -> assert false + let ws_of_ty = function | Bty (U ws) -> ws | _ -> assert false @@ -454,9 +573,19 @@ let ws_of_ty = function let arr_size ws i = size_of_ws ws * i let size_of t = + match t with + | Bty (U ws) -> Const (size_of_ws ws) + | Arr (ws, len) -> + begin match len with + | Const n -> Const (arr_size ws n) + | _ -> Mul (Const (size_of_ws ws), len) + end + | _ -> assert false + +let size_of_const t = match t with | Bty (U ws) -> size_of_ws ws - | Arr (ws', n) -> arr_size ws' n + | Arr (ws', Const n) -> arr_size ws' n | _ -> assert false (* -------------------------------------------------------------------- *) @@ -552,7 +681,7 @@ let spilled fc = spilled_c Sv.empty fc.f_body let assigns = function | Cassgn (x, _, _, _) -> written_lv Sv.empty x - | Copn (xs, _, _, _) | Csyscall (xs, _, _) | Ccall (xs, _, _) -> + | Copn (xs, _, _, _) | Csyscall (xs, _, _, _) | Ccall (xs, _, _, _) -> List.fold_left written_lv Sv.empty xs | Cif _ | Cwhile _ | Cassert _ | Cfor _ -> Sv.empty diff --git a/compiler/src/prog.mli b/compiler/src/prog.mli index 0cbe08da1a..99fda142fa 100644 --- a/compiler/src/prog.mli +++ b/compiler/src/prog.mli @@ -72,12 +72,12 @@ type ('len, 'info, 'asm) ginstr_r = | Cassgn of 'len glval * E.assgn_tag * 'len gty * 'len gexpr (* turn 'asm Sopn.sopn into 'sopn? could be useful to ensure that we remove things statically *) | Copn of 'len glvals * E.assgn_tag * 'asm Sopn.sopn * 'len gexprs - | Csyscall of 'len glvals * (Wsize.wsize * BinNums.positive) Syscall_t.syscall_t * 'len gexprs + | Csyscall of 'len glvals * Syscall.syscall_t * 'len list * 'len gexprs | Cassert of 'len assertion | Cif of 'len gexpr * ('len, 'info, 'asm) gstmt * ('len, 'info, 'asm) gstmt | Cfor of 'len gvar_i * 'len grange * ('len, 'info, 'asm) gstmt | Cwhile of E.align * ('len, 'info, 'asm) gstmt * 'len gexpr * (IInfo.t * 'info) * ('len, 'info, 'asm) gstmt - | Ccall of 'len glvals * funname * 'len gexprs + | Ccall of 'len glvals * funname * 'len list * 'len gexprs and ('len, 'info, 'asm) ginstr = { i_desc : ('len, 'info, 'asm) ginstr_r; @@ -103,6 +103,7 @@ type ('len, 'info, 'asm) gfunc = { f_contract: 'len gfcontract option; f_cc : FInfo.call_conv; f_name : funname; + f_al : 'len gvar list; f_tyin : 'len gty list; f_args : 'len gvar list; f_body : ('len, 'info, 'asm) gstmt; @@ -155,7 +156,7 @@ module PV : sig val hash : pvar -> int - val is_glob : pvar -> bool + val is_length_var : pvar -> bool end val gkglob : 'len gvar_i -> 'len ggvar @@ -170,28 +171,35 @@ val pexpr_equal : pexpr -> pexpr -> bool val epty_equal : epty -> epty -> bool -val ws_of_ety : epty -> wsize (* ------------------------------------------------------------------------ *) (* Non parametrized expression *) -type ty = int gty -type var = int gvar -type var_i = int gvar_i -type lval = int glval -type lvals = int glval list -type expr = int gexpr -type exprs = int gexpr list -type eassert = int gassert - -type range = int grange - -type ('info, 'asm) instr = (int, 'info, 'asm) ginstr -type ('info, 'asm) instr_r = (int,'info,'asm) ginstr_r -type ('info, 'asm) stmt = (int, 'info, 'asm) gstmt - -type ('info, 'asm) func = (int, 'info, 'asm) gfunc -type ('info, 'asm) mod_item = (int, 'info, 'asm) gmod_item +type ty = length gty +type var = length gvar +type var_i = length gvar_i +type lval = length glval +type lvals = length glval list +type expr = length gexpr +type exprs = length gexpr list +type eassert = length gassert + +type ety = length gety +val ety_equal : ety -> ety -> bool +val ws_of_ety : ety -> wsize +val al_of_expr : expr -> length +val expr_of_al : length -> expr +val expanded_form : length -> (int * length gvar list) list +val compare_array_length : wsize * length -> wsize * length -> bool + +type range = length grange + +type ('info, 'asm) instr = (length, 'info, 'asm) ginstr +type ('info, 'asm) instr_r = (length,'info,'asm) ginstr_r +type ('info, 'asm) stmt = (length, 'info, 'asm) gstmt + +type ('info, 'asm) func = (length, 'info, 'asm) gfunc +type ('info, 'asm) mod_item = (length, 'info, 'asm) gmod_item type global_decl = var * Global.glob_value type ('info, 'asm) prog = global_decl list * ('info, 'asm) func list @@ -212,7 +220,7 @@ module V : sig val hash : var -> int - val is_glob : var -> bool + val is_length_var : var -> bool end module Sv : Set.S with type elt = var @@ -231,9 +239,11 @@ val ty_i : 'len gvar_i -> 'len gty val fold_vars_ret : ('ty gvar -> 'acc -> 'acc) -> 'acc -> ('ty, 'info, 'asm) gfunc -> 'acc val fold_vars_fc : ('ty gvar -> 'acc -> 'acc) -> 'acc -> ('ty, 'info, 'asm) gfunc -> 'acc +val vars_al : length -> Sv.t val vars_ret : ('info, 'asm) func -> Sv.t val vars_lv : Sv.t -> lval -> Sv.t val vars_e : expr -> Sv.t +val pvars_e : pexpr -> Spv.t val vars_es : expr list -> Sv.t val vars_a : eassert -> Sv.t val vars_i : ('info, 'asm) instr -> Sv.t @@ -286,9 +296,11 @@ val int_of_velem : velem -> int val is_ty_arr : 'e gty -> bool val array_kind : 'e gty -> wsize * 'e +val array_kind_const : ty -> wsize * int val ws_of_ty : 'e gty -> wsize val arr_size : wsize -> int -> int -val size_of : ty -> int +val size_of : ty -> length +val size_of_const : ty -> int val access_offset : Warray_.arr_access -> wsize -> int -> int (* -------------------------------------------------------------------- *) diff --git a/compiler/src/regalloc.ml b/compiler/src/regalloc.ml index 0baa9605b5..2e2bf4be30 100644 --- a/compiler/src/regalloc.ml +++ b/compiler/src/regalloc.ml @@ -37,12 +37,12 @@ let fill_in_missing_names (f: ('info, 'asm) func) : ('info, 'asm) func = function | Cassgn (lv, tg, ty, e) -> Cassgn (fill_lv lv, tg, ty, e) | Copn (lvs, tg, op, es) -> Copn (fill_lvs lvs, tg, op, es) - | Csyscall (lvs, op, es) -> Csyscall(fill_lvs lvs, op, es) + | Csyscall (lvs, op, al, es) -> Csyscall(fill_lvs lvs, op, al, es) | Cassert (msg, e) -> Cassert (msg, e) | Cif (e, s1, s2) -> Cif (e, fill_stmt s1, fill_stmt s2) | Cfor (i, r, s) -> Cfor (i, r, fill_stmt s) | Cwhile (a, s, e, loc, s') -> Cwhile (a, fill_stmt s, e, loc, fill_stmt s') - | Ccall (lvs, f, es) -> Ccall (fill_lvs lvs, f, es) + | Ccall (lvs, f, al, es) -> Ccall (fill_lvs lvs, f, al, es) and fill_instr i = { i with i_desc = fill_instr_r i.i_desc } and fill_stmt s = List.map fill_instr s in let f_body = fill_stmt f.f_body in @@ -56,7 +56,7 @@ let string_of_kind = | Extra -> "extra (aka mmx)" | Vector -> "vector" | Flag -> "flag" - | Unknown ty -> Format.asprintf "(unknown of type %a)" PrintCommon.pp_ty ty + | Unknown ty -> Format.asprintf "(unknown of type %a)" (Printer.pp_ty ~debug:false) ty let kind_of_type reg_size k = function @@ -277,7 +277,7 @@ let collect_equality_constraints_in_func end | Cassgn _ -> () | Cassert _ -> () - | Ccall (xs, fn, es) -> + | Ccall (xs, fn, _al, es) -> let get_Pvar a = match a with | Pvar { gs = Expr.Slocal ; gv } -> gv @@ -498,7 +498,7 @@ let iter_variables (cb: var -> unit) (f: ('info, 'asm) func) : unit = function | Cassert (_, e) -> iter_assert e | Cassgn (lv, _, _, e) -> iter_lv lv; iter_expr e - | (Ccall (lvs, _, es) | Copn (lvs, _, _, es)) | Csyscall(lvs, _ , es) -> iter_lvs lvs; iter_exprs es + | (Ccall (lvs, _, _, es) | Copn (lvs, _, _, es)) | Csyscall(lvs, _, _, es) -> iter_lvs lvs; iter_exprs es | (Cwhile (_, s1, e, _, s2) | Cif (e, s1, s2)) -> iter_expr e; iter_stmt s1; iter_stmt s2 | Cfor _ -> assert false and iter_instr { i_desc } = iter_instr_r i_desc @@ -703,7 +703,7 @@ module Regalloc (Arch : Arch_full.Arch) then hierror_reg ~loc:(Lmore loc) "variable %a (declared at %a with type “%a”) must be allocated to register %a from an incompatible bank" (Printer.pp_var ~debug:true) x L.pp_sloc x.v_dloc - PrintCommon.pp_ty x.v_ty + (Printer.pp_ty ~debug:false) x.v_ty (Printer.pp_var ~debug:false) y; let i = try Hv.find vars x @@ -823,7 +823,7 @@ let allocate_forced_registers return_addresses nv (vars: int Hv.t) tr (cnf: conf let d, flags = split ~ctxt ~num:num_flags flags in d, regs, regxs, xregs, flags | Unknown ty -> hierror_reg ~loc:(Lmore loc) "unknown type %a for forced register %a" - PrintCommon.pp_ty ty (Printer.pp_var ~debug:true) p + (Printer.pp_ty ~debug:false) ty (Printer.pp_var ~debug:true) p in allocate_one nv vars loc cnf p i d a; (regs, regxs, xregs, flags) @@ -842,7 +842,7 @@ let allocate_forced_registers return_addresses nv (vars: int Hv.t) tr (cnf: conf | Cfor (_, _, s) -> alloc_stmt s c | Copn (lvs, _, op, es) -> forced_registers loc nv vars tr c lvs op es a - | Csyscall(lvs, _, es) -> + | Csyscall(lvs, _, _, es) -> let get_a = function Pvar { gv ; gs = Slocal } -> L.unloc gv | _ -> assert false in let get_r = function Lvar gv -> L.unloc gv | _ -> assert false in alloc_args get_a loc es; @@ -854,7 +854,7 @@ let allocate_forced_registers return_addresses nv (vars: int Hv.t) tr (cnf: conf -> alloc_stmt s1 c |> alloc_stmt s2 | Cassgn _ | Cassert _ -> c - | Ccall (lvs, _, es) -> + | Ccall (lvs, _, _, es) -> (* TODO: check this *) (* let args = List.map (function Pvar { gv ; gs = Slocal } -> (L.unloc gv) | _ -> assert false) es in @@ -1060,7 +1060,7 @@ let greedy_allocation | Flag -> push_var flags i v | Unknown ty -> hierror_reg ~loc:Lnone "unable to allocate variable %a: no register bank for type %a" - pp_var v PrintCommon.pp_ty ty + pp_var v (Printer.pp_ty ~debug:false) ty ) vars; two_phase_coloring Arch.allocatable_vars scalars cnf fr a; two_phase_coloring Arch.extra_allocatable_vars extra_scalars cnf fr a; @@ -1149,7 +1149,7 @@ let pp_liveness vars liveness_per_callsite liveness_table a = let pp_variable fmt i = fprintf fmt "v%d" i in let pp_reg fmt r = pp_var fmt ~debug:false r in let pp_nonreg fmt x = pp_var fmt ~debug:true x in - let pp_decl_type fmt x = fprintf fmt "%a %a" pp_kind x.v_kind pp_ty x.v_ty in + let pp_decl_type fmt x = fprintf fmt "%a %a" pp_kind x.v_kind (pp_ty ~debug:false) x.v_ty in let pp_var fmt x = match Hv.find vars x with | exception Not_found -> pp_nonreg fmt x @@ -1316,7 +1316,7 @@ let global_allocation return_addresses (funcs: ('info, 'asm) func list) : (* Live variables at the end of each function, in addition to returned local variables *) let get_liveness, slive, liveness_per_callsite = let live : (L.i_loc list * Sv.t) list Hf.t = Hf.create 17 in - let slive : ((Wsize.wsize * BinNums.positive) Syscall_t.syscall_t, Sv.t) Hashtbl.t = Hashtbl.create 17 in + let slive : (Syscall.syscall_t, Sv.t) Hashtbl.t = Hashtbl.create 17 in List.iter (fun f -> let f_with_liveness = Hf.find liveness_table f.f_name in let live_when_calling_f = Hf.find_default live f.f_name [[], Sv.empty] in diff --git a/compiler/src/scopeTree.ml b/compiler/src/scopeTree.ml index 4e7befdc4a..fa74975e26 100644 --- a/compiler/src/scopeTree.ml +++ b/compiler/src/scopeTree.ml @@ -60,32 +60,31 @@ let find_common_ancestor (t : tree) (nodes : nodeset) : node = (* --------------------------------------------------------------- *) (* Compute variable occurrences in expressions and instructions *) -let variables_in_gvar x (acc : Spv.t) : Spv.t = - if x.v_kind <> Const then Spv.add x acc else acc +let variables_in_gvar x (acc : Sv.t) : Sv.t = + if x.v_kind <> Const then Sv.add x acc else acc let variables_in_pexpr = rvars_e variables_in_gvar let variables_in_pexprs = rvars_es variables_in_gvar - let variables_in_plval = rvars_lv variables_in_gvar let variables_in_plvals = rvars_lvs variables_in_gvar -let variables_in_instr_r : _ pinstr_r -> Spv.t = function - | Cassgn (x, _, _, e) -> variables_in_pexpr (variables_in_plval Spv.empty x) e - | Copn (xs, _, _, es) | Csyscall (xs, _, es) | Ccall (xs, _, es) -> - variables_in_pexprs (variables_in_plvals Spv.empty xs) es +let variables_in_instr_r : _ instr_r -> Sv.t = function + | Cassgn (x, _, _, e) -> variables_in_pexpr (variables_in_plval Sv.empty x) e + | Copn (xs, _, _, es) | Csyscall (xs, _, _, es) | Ccall (xs, _, _, es) -> + variables_in_pexprs (variables_in_plvals Sv.empty xs) es | Cfor (x, (_, e1, e2), _) -> - variables_in_pexprs (Spv.singleton (L.unloc x)) [ e1; e2 ] - | Cif (e, _, _) | Cwhile (_, _, e, _, _) -> variables_in_pexpr Spv.empty e - | Cassert (_, e) -> rvars_a variables_in_gvar Spv.empty e + variables_in_pexprs (Sv.singleton (L.unloc x)) [ e1; e2 ] + | Cif (e, _, _) | Cwhile (_, _, e, _, _) -> variables_in_pexpr Sv.empty e + | Cassert (_, e) -> rvars_a variables_in_gvar Sv.empty e (** Maps each variable to the set of nodes at which it occurs *) -let variable_occurrences (c : _ pstmt) : nodeset Mpv.t = - let tbl = ref Mpv.empty in - let insert (n : node) (x : pvar) = - tbl := Mpv.modify_def Siloc.empty x (Siloc.add n) !tbl +let variable_occurrences (c : _ stmt) : nodeset Mv.t = + let tbl = ref Mv.empty in + let insert (n : node) (x : var) = + tbl := Mv.modify_def Siloc.empty x (Siloc.add n) !tbl in iter_instr - (fun i -> i.i_desc |> variables_in_instr_r |> Spv.iter (insert i.i_loc)) + (fun i -> i.i_desc |> variables_in_instr_r |> Sv.iter (insert i.i_loc)) c; !tbl @@ -112,10 +111,10 @@ and tree_of_stmt (acc : tree) (t : Tree.t option) (c : _ gstmt) : (** Reverse a map from variable to nodes into the corresponding map from nodes to sets of variables *) -let reverse (m : node Mpv.t) : Spv.t Miloc.t = - Mpv.fold (fun x n -> Miloc.modify_def Spv.empty n (Spv.add x)) m Miloc.empty +let reverse (m : node Mv.t) : Sv.t Miloc.t = + Mv.fold (fun x n -> Miloc.modify_def Sv.empty n (Sv.add x)) m Miloc.empty -let get_declaration_sites (fd : _ pfunc) : Spv.t Miloc.t = +let get_declaration_sites (fd : _ func) : Sv.t Miloc.t = let t, last = tree_of_stmt Miloc.empty None fd.f_body in let occ = variable_occurrences fd.f_body in (* Add occurrences of returned variables at the last instruction, if any *) @@ -125,9 +124,9 @@ let get_declaration_sites (fd : _ pfunc) : Spv.t Miloc.t = | Some t -> List.fold_left (fun occ x -> - Mpv.modify_def Siloc.empty (L.unloc x) (Siloc.add t.data) occ) + Mv.modify_def Siloc.empty (L.unloc x) (Siloc.add t.data) occ) occ fd.f_ret in (* Remove function arguments as they must not be declared *) - let occ = List.fold_left (fun occ x -> Mpv.remove x occ) occ fd.f_args in - Mpv.map (find_common_ancestor t) occ |> reverse + let occ = List.fold_left (fun occ x -> Mv.remove x occ) occ fd.f_args in + Mv.map (find_common_ancestor t) occ |> reverse diff --git a/compiler/src/scopeTree.mli b/compiler/src/scopeTree.mli index c9d96be473..b1480f64aa 100644 --- a/compiler/src/scopeTree.mli +++ b/compiler/src/scopeTree.mli @@ -1,4 +1,4 @@ open Prog -val get_declaration_sites : ('info, 'asm) pfunc -> Spv.t Utils.Miloc.t +val get_declaration_sites : ('info, 'asm) func -> Sv.t Utils.Miloc.t (** Computes for each instruction the set of variables to declare before it. *) diff --git a/compiler/src/sct_checker_forward.ml b/compiler/src/sct_checker_forward.ml index c1dab7d636..f1912686e8 100644 --- a/compiler/src/sct_checker_forward.ml +++ b/compiler/src/sct_checker_forward.ml @@ -168,7 +168,7 @@ let rec modmsf_i fenv i = | Mov_msf | Protect | Other -> NotModified end | Cfor(_, _, c) -> modmsf_c fenv c - | Ccall (_, f, _) -> + | Ccall (_, f, _, _) -> match (FEnv.get_fty fenv f).modmsf with | Modified (l, tr) -> Modified(i.i_loc, (l, f) :: tr) | NotModified -> NotModified @@ -309,7 +309,7 @@ let rec infer_msf_i ~withcheck fenv (tbl:(L.i_loc, Sv.t) Hashtbl.t) i ms = | Cassgn _ -> ms - | Ccall(xs, f, es) -> + | Ccall(xs, f, _, es) -> let fty = FEnv.get_fty fenv f in let ms = let doout ms vfty x = @@ -386,7 +386,7 @@ module Env : sig val dsecret : env -> vty val get_i : venv -> var_i -> vty - val gget : venv -> int ggvar -> vty + val gget : venv -> length ggvar -> vty val fresh2 : ?name:string -> env -> VlPairs.t @@ -555,7 +555,7 @@ end = struct let in_memory = match x.v_kind with | Wsize.Global (* likely unused as global variables are not in venv.vars *) | Stack _ -> true - | Const | Inline | Reg _ -> false + | Const | Inline | Reg _ | Length -> false in let ty = match Mv.find x vtype with @@ -610,7 +610,7 @@ let ssafe_test x aa ws i = let x = L.unloc x in match x.v_kind, x.v_ty, i with | Reg (_, Direct), _, _ -> true - | _, Arr (ws1, len), Pconst v -> + | _, Arr (ws1, Const len), Pconst v -> let len = Z.of_int (arr_size ws1 len) in let v = Z.of_int (access_offset aa ws (Z.to_int v)) in let v_max = Z.add v (Z.of_int (size_of_ws ws - 1)) in @@ -958,9 +958,9 @@ let rec ty_instr is_ct_asm fenv env (msf, venv) i = and ty_instr_r is_ct_asm fenv env ((msf,venv) as msf_e :msf_e) i = let loc = i.i_loc.L.base_loc in match i.i_desc with - | Csyscall (xs, o, es) -> + | Csyscall (xs, o, _, es) -> (* TODO: generalize to other syscalls *) - assert (match o with Syscall_t.RandomBytes _ -> true); + assert (match o with Syscall.RandomBytes -> true); List.iter (ensure_public_address_expr env venv loc) es; (* We don't known what happen to MSF after external function call *) ty_lvals1 env (MSF.toinit, venv) xs (Env.dsecret env) @@ -1078,7 +1078,7 @@ and ty_instr_r is_ct_asm fenv env ((msf,venv) as msf_e :msf_e) i = Env.ensure_le loc venv' venv1; (* venv' <= venv1 *) MSF.enter_if msf2 (Papp1(Onot, e)), venv2 - | Ccall (xs, f, es) -> + | Ccall (xs, f, _, es) -> let fty = FEnv.get_fty fenv f in let modmsf = fty.modmsf in let tyout, tyin, resulting_corruption = Env.clone_for_call env fty in @@ -1288,6 +1288,7 @@ let init_constraint fenv f = | (Stack (Pointer _) | Reg (_, Pointer _)) -> Indirect(Env.fresh2 env, Env.fresh2 env) | Inline -> Env.dpublic env | Global -> Env.dpublic env (* unsure *) + | Length -> assert false end | Some ty -> (* this partly has the same role as Env.init_ty. Remove one occurence? *) begin match x.v_kind, ty with @@ -1298,6 +1299,7 @@ let init_constraint fenv f = | Reg (_, Pointer _), Indirect _ -> () | Inline, Direct _ -> () | Global, Direct _ -> () + | Length, _ -> assert false | _ -> error ~loc "invalid security annotations for %a" pp_var x diff --git a/compiler/src/slicing.ml b/compiler/src/slicing.ml index 0456cbaa26..b6d5c021e4 100644 --- a/compiler/src/slicing.ml +++ b/compiler/src/slicing.ml @@ -40,13 +40,13 @@ and inspect_instr k i = inspect_instr_r k i.i_desc and inspect_instr_r k = function | Cassgn (x, _, _, e) -> inspect_lv (inspect_e k e) x - | Copn (xs, _, _, es) | Csyscall (xs, _, es) -> + | Copn (xs, _, _, es) | Csyscall (xs, _, _, es) -> inspect_lvs (inspect_es k es) xs | Cassert (_, e) -> inspect_a k e | Cif (g, a, b) | Cwhile (_, a, g, _, b) -> inspect_stmt (inspect_stmt (inspect_e k g) a) b | Cfor (_, (_, e1, e2), s) -> inspect_stmt (inspect_es k [ e1; e2 ]) s - | Ccall (xs, fn, es) -> with_fun (inspect_lvs (inspect_es k es) xs) fn + | Ccall (xs, fn, _, es) -> with_fun (inspect_lvs (inspect_es k es) xs) fn let inspect_fun k fd = let k = diff --git a/compiler/src/ssa.ml b/compiler/src/ssa.ml index 0f25931fc4..da7b4ed97c 100644 --- a/compiler/src/ssa.ml +++ b/compiler/src/ssa.ml @@ -37,8 +37,8 @@ let rec written_vars_instr_r allvars w = | Cassert _ -> w | Cassgn (x, _, _, _) -> written_vars_lvar allvars w x | Copn (xs, _, _, _) - | Csyscall(xs,_,_) - | Ccall (xs, _, _) + | Csyscall(xs,_,_,_) + | Ccall (xs, _, _, _) -> written_vars_lvars allvars w xs | Cif (_, s1, s2) | Cwhile (_, s1, _, _, s2) @@ -65,14 +65,14 @@ let split_live_ranges (allvars: bool) (f: ('info, 'asm) func) : (unit, 'asm) fun let es = List.map (rename_expr m) es in let m, ys = rename_lvals allvars m xs in m, Copn (ys, tg, op, es) - | Csyscall (xs, op, es) -> + | Csyscall (xs, op, al, es) -> let es = List.map (rename_expr m) es in let m, ys = rename_lvals allvars m xs in - m, Csyscall(ys, op, es) - | Ccall (xs, n, es) -> + m, Csyscall(ys, op, al, es) + | Ccall (xs, n, al, es) -> let es = List.map (rename_expr m) es in let m, ys = rename_lvals allvars m xs in - m, Ccall (ys, n, es) + m, Ccall (ys, n, al, es) | Cfor _ -> assert false | Cassert _ -> assert false (* no more for loop and assertion *) | Cif (e, s1, s2) -> diff --git a/compiler/src/stackAlloc.ml b/compiler/src/stackAlloc.ml index f09227ac93..cb505c878c 100644 --- a/compiler/src/stackAlloc.ml +++ b/compiler/src/stackAlloc.ml @@ -6,7 +6,7 @@ open Regalloc let pp_var = Printer.pp_var ~debug:true let pp_var_ty fmt x = - Format.fprintf fmt "%a %a" PrintCommon.pp_ty x.v_ty pp_var x + Format.fprintf fmt "%a %a" (Printer.pp_ty ~debug:true) x.v_ty pp_var x let pp_param_info fmt pi = let open Stack_alloc in diff --git a/compiler/src/subst.ml b/compiler/src/subst.ml index dfec213765..dbee9f8f88 100644 --- a/compiler/src/subst.ml +++ b/compiler/src/subst.ml @@ -69,14 +69,14 @@ let rec gsubst_i (flen: ?loc:L.t -> 'len1 -> 'len2) f i = let ty = gsubst_ty (flen ?loc:None) ty in Cassgn(x, tg, ty, e) | Copn(x,t,o,e) -> Copn(gsubst_lvals flen f x, t, o, gsubst_es flen f e) - | Csyscall(x,o,e) -> Csyscall(gsubst_lvals flen f x, o, gsubst_es flen f e) + | Csyscall(x,o,al,e) -> Csyscall(gsubst_lvals flen f x, o, List.map (flen ?loc:None) al, gsubst_es flen f e) | Cassert (msg, e) -> Cassert (msg, gsubst_a flen f e) | Cif(e,c1,c2) -> Cif(gsubst_e flen f e, gsubst_c flen f c1, gsubst_c flen f c2) | Cfor(x,(d,e1,e2),c) -> Cfor(gsubst_vdest f x, (d, gsubst_e flen f e1, gsubst_e flen f e2), gsubst_c flen f c) | Cwhile(a, c, e, loc, c') -> Cwhile(a, gsubst_c flen f c, gsubst_e flen f e, loc, gsubst_c flen f c') - | Ccall(x,fn,e) -> Ccall(gsubst_lvals flen f x, fn, gsubst_es flen f e) in + | Ccall(x,fn,al,e) -> Ccall(gsubst_lvals flen f x, fn, List.map (flen ?loc:None) al, gsubst_es flen f e) in { i with i_desc } and gsubst_c flen f c = List.map (gsubst_i flen f) c @@ -92,6 +92,7 @@ let gsubst_cf_contract flen f c = let gsubst_func (flen: ?loc:L.t -> 'len1 -> 'len2) f fc = let dov v = L.unloc (gsubst_vdest f (L.mk_loc L._dummy v)) in { fc with + f_al = List.map dov fc.f_al; f_tyin = List.map (gsubst_ty (flen ?loc:None)) fc.f_tyin; f_contract = Option.map (gsubst_cf_contract flen f) fc.f_contract; f_args = List.map dov fc.f_args; @@ -106,38 +107,63 @@ let subst_func f fc = (* ---------------------------------------------------------------- *) -type psubst = pexpr_ ggvar -> pexpr - -let rec psubst_e (f: psubst) (e: pexpr) : pexpr = - gsubst_e (psubst_e_ f) f e -and psubst_e_ f ?loc:_ (PE e) = PE (psubst_e f e) - -let psubst_ty f (ty: pty) : pty = +type lsubst = length ggvar -> expr + +let rec psubst_al (f: lsubst) (al: length) : length = + match al with + | Const n -> Const n + | Var x -> + (* x is a var, but we need a ggvar... *) + let x = gkvar (L.mk_loc L._dummy x) in + al_of_expr (f x) + | Neg al -> Neg (psubst_al f al) + | Add (al1, al2) -> Add (psubst_al f al1, psubst_al f al2) + | Sub (al1, al2) -> Sub (psubst_al f al1, psubst_al f al2) + | Mul (al1, al2) -> Mul (psubst_al f al1, psubst_al f al2) + | Div (sg, al1, al2) -> Div (sg, psubst_al f al1, psubst_al f al2) + | Mod (sg, al1, al2) -> Mod (sg, psubst_al f al1, psubst_al f al2) + | Shl (al1, al2) -> Shl (psubst_al f al1, psubst_al f al2) + | Shr (al1, al2) -> Shr (psubst_al f al1, psubst_al f al2) +let psubst_al f ?loc:_ = psubst_al f + +let psubst_e (f: lsubst) (e: expr) : expr = + gsubst_e (psubst_al f) f e + +let psubst_ty f (ty: ty) : ty = match ty with | Bty ty -> Bty ty - | Arr(ty, e) -> Arr(ty, psubst_e_ f e) + | Arr(ty, e) -> Arr(ty, psubst_al f e) + +let psubst_ety f (ty: ety) : ety = +match ty with + | ETbool | ETint | ETword _ -> ty + | ETarr (ws, len) -> ETarr (ws, psubst_al f len) let psubst_v subst = let subst = ref subst in - let rec aux v : pexpr = + let rec aux v : expr = let k = v.gs in - let v = v.gv in - let v_ = v.L.pl_desc in + let gv = v.gv in + let v_ = gv.L.pl_desc in let e = - try Mpv.find v_ !subst + try Mv.find v_ !subst with Not_found -> - assert (not (PV.is_glob v_)); - let ty = psubst_ty aux v_.v_ty in - let v' = PV.mk v_.v_name v_.v_kind ty v_.v_dloc v_.v_annot in - let v = {v with L.pl_desc = v'} in - let v = { gv = v; gs = k } in - let e = Pvar v in - subst := Mpv.add v_ e !subst; - e in + (* length variables are unchanged *) + if V.is_length_var v_ then + Pvar v + else begin + let ty = psubst_ty aux v_.v_ty in + let v' = V.mk v_.v_name v_.v_kind ty v_.v_dloc v_.v_annot in + let gv = {gv with L.pl_desc = v'} in + let v = { gv ; gs = k } in + let e = Pvar v in + subst := Mv.add v_ e !subst; + e + end in match e with | Pvar x -> let k = x.gs in - let x = {x.gv with L.pl_loc = L.loc v} in + let x = {x.gv with L.pl_loc = L.loc gv} in let x = {gv = x; gs = k} in Pvar x | _ -> e in @@ -147,14 +173,14 @@ let psubst_ge f = function | GEword e -> GEword (psubst_e f e) | GEarray es -> GEarray (List.map (psubst_e f) es) -let psubst_prog (prog:('info, 'asm) pprog) = - let subst = ref (Mpv.empty : pexpr Mpv.t) in +let psubst_prog (prog:('info, 'asm) mod_item list) = + let subst = ref (Mv.empty : expr Mv.t) in let rec aux = function | [] -> [], [] | MIparam(v,e) :: items -> let g, p = aux items in let f = psubst_v !subst in - subst := Mpv.add v (psubst_e f e) !subst; + subst := Mv.add v (psubst_e f e) !subst; g, p | MIglobal (v, e) :: items -> let g, p = aux items in @@ -164,7 +190,7 @@ let psubst_prog (prog:('info, 'asm) pprog) = gsubst_gvar f {gv = L.mk_loc L._dummy v; gs = Expr.Sglob} in assert (not (is_gkvar v)); L.unloc v.gv in let e = psubst_ge f e in - subst := Mpv.add v (Pvar (gkglob (L.mk_loc L._dummy v'))) !subst; + subst := Mv.add v (Pvar (gkglob (L.mk_loc L._dummy v'))) !subst; (v', e) :: g, p | MIfun fc :: items -> let g, p = aux items in @@ -173,14 +199,14 @@ let psubst_prog (prog:('info, 'asm) pprog) = let dov v = L.unloc (gsubst_vdest subst_v (L.mk_loc L._dummy v)) in let subst_contract = - gsubst_cf_contract (psubst_e_ subst_v) subst_v + gsubst_cf_contract (psubst_al subst_v) subst_v in let fc = { fc with f_tyin = List.map subst_ty fc.f_tyin; f_contract = Option.map subst_contract fc.f_contract; f_args = List.map dov fc.f_args; - f_body = gsubst_c (psubst_e_ subst_v) subst_v fc.f_body; + f_body = gsubst_c (psubst_al subst_v) subst_v fc.f_body; f_tyout = List.map subst_ty fc.f_tyout; f_ret = List.map (gsubst_vdest subst_v) fc.f_ret } in @@ -189,6 +215,7 @@ let psubst_prog (prog:('info, 'asm) pprog) = (* ---------------------------------------------------------------- *) (* Simplify type *) + (* let int_of_op1 ?loc = function | Oneg Op_int -> Z.neg @@ -217,29 +244,48 @@ let int_of_op2 ?loc o = | Oasr Op_int -> shift_right ?loc | _ -> hierror ?loc "operator %s not allowed in array size (only standard arithmetic operators and modulo are allowed)" (PrintCommon.string_of_op2 o) +let op_of_op2 ?loc o = + match o with + | Oadd Op_int -> fun e1 e2 -> Add (e1, e2) + | Omul Op_int -> fun e1 e2 -> Mul (e1, e2) + | _ -> hierror ?loc "operator %s not allowed in array size" (PrintCommon.string_of_op2 o) + let rec int_of_expr ?loc e = match e with - | Pconst i -> i + | Pconst i -> Const (Z.to_int i) | Papp1 (o, e1) -> - int_of_op1 ?loc o @@ int_of_expr ?loc e1 + begin match int_of_expr ?loc e1 with + | Const n1 -> + Const (Z.to_int (int_of_op1 ?loc o (Z.of_int n1))) + | _ -> hierror ?loc "this is wrong" + end | Papp2 (o, e1, e2) -> - let op = int_of_op2 ?loc o in - op (int_of_expr ?loc e1) (int_of_expr ?loc e2) - | Pbool _ | Parr_init _ | Pvar _ + begin match int_of_expr ?loc e1, int_of_expr ?loc e2 with + | Const n1, Const n2 -> + let op = int_of_op2 ?loc o in + Const (Z.to_int (op (Z.of_int n1) (Z.of_int n2))) + | e1, e2 -> + let op = op_of_op2 ?loc o in + op e1 e2 + end + | Pvar x -> + let { gv; gs = _ } = x in + let v = L.unloc gv in + Var (GV.cast v) + | Pbool _ | Parr_init _ | Pget _ | Psub _ | Pload _ | PappN _ | Pif _ -> - hierror ?loc "expression %a not allowed in array size (only constant arithmetic expressions are allowed)" (Printer.pp_pexpr ~debug:false) e + hierror ?loc "expression %a not allowed in array size (only arithmetic expressions are allowed)" (Printer.pp_pexpr ~debug:false) e +*) -let isubst_len ?loc (PE e) = - let z = int_of_expr ?loc e in - try Z.to_int z - with Z.Overflow -> - hierror ?loc "cannot define a (sub-)array of size %a, this number is too big" Z.pp_print z +let isubst_al ?loc:_ al = + match Type.eval_opt (fun _ -> None) (Conv.cal_of_al al) with + | Some n -> Const (CoreConv.int_of_cz n) + | _ -> al -let isubst_ty ?loc = function +let isubst_ty ?loc:_ = function | Bty ty -> Bty ty - | Arr(ty, e) -> Arr(ty, isubst_len ?loc e) - + | Arr(ty, e) -> Arr(ty, isubst_al e) let isubst_prog glob prog = @@ -249,14 +295,14 @@ let isubst_prog glob prog = let v = v0.gv in let v_ = v.L.pl_desc in let e = - try Mpv.find v_ !subst + try Mv.find v_ !subst with Not_found -> let ty = isubst_ty ~loc:v_.v_dloc v_.v_ty in let v1 = V.mk v_.v_name v_.v_kind ty v_.v_dloc v_.v_annot in let v = { v with L.pl_desc = v1 } in let v0 = { gv = v; gs = k } in let e = Pvar v0 in - subst := Mpv.add v_ e !subst; + subst := Mv.add v_ e !subst; e in match e with | Pvar x -> @@ -267,7 +313,7 @@ let isubst_prog glob prog = | _ -> e in aux in - let subst : expr Mpv.t ref = ref Mpv.empty in + let subst : expr Mv.t ref = ref Mv.empty in let isubst_glob (x, gd) = let subst_v = isubst_v subst in @@ -278,8 +324,8 @@ let isubst_prog glob prog = let gd = match gd with - | GEword e -> GEword (gsubst_e isubst_len subst_v e) - | GEarray es -> GEarray (List.map (gsubst_e isubst_len subst_v) es) in + | GEword e -> GEword (gsubst_e isubst_al subst_v e) + | GEarray es -> GEarray (List.map (gsubst_e isubst_al subst_v) es) in x, gd in let glob = List.map isubst_glob glob in @@ -296,10 +342,11 @@ let isubst_prog glob prog = let f_ret = List.map (gsubst_vdest subst_v) fc.f_ret in let fc = { fc with + f_al = List.map GV.cast fc.f_al; f_tyin = List.map isubst_ty fc.f_tyin; - f_contract = Option.map (gsubst_cf_contract isubst_len subst_v) fc.f_contract; + f_contract = Option.map (gsubst_cf_contract isubst_al subst_v) fc.f_contract; f_args; - f_body = gsubst_c isubst_len subst_v fc.f_body; + f_body = gsubst_c isubst_al subst_v fc.f_body; f_tyout = List.map isubst_ty fc.f_tyout; f_ret; } in @@ -342,7 +389,7 @@ let rec constant_of_expr (e: Prog.expr) : Z.t = | _ -> raise NotAConstantExpr -let remove_params (prog : ('info, 'asm) pprog) = +let remove_params (prog : ('info, 'asm) mod_item list) = let globals, prog = psubst_prog prog in let globals, prog = isubst_prog globals prog in @@ -368,15 +415,15 @@ let remove_params (prog : ('info, 'asm) pprog) = hierror ~loc:x.v_dloc "the expression assigned to global variable %a must evaluate to a constant word" (Printer.pp_var ~debug:false) x end - | Arr (_ws, n), GEarray es when List.length es <> n -> + | Arr (_ws, Const n), GEarray es when List.length es <> n -> let m = List.length es in hierror ~loc:x.v_dloc "array size mismatch for global variable %a: %d %s given (%d expected)" (Printer.pp_var ~debug:false) x (List.length es) (if m > 1 then "values" else "value") n - | Arr (ws, n), GEarray es -> - let p = Conv.pos_of_int (n * size_of_ws ws) in + | Arr (ws, Const n), GEarray es -> + let p = CoreConv.cz_of_int (n * size_of_ws ws) in let mk_word_i i e = try mk_word ws e with NotAConstantExpr -> diff --git a/compiler/src/subst.mli b/compiler/src/subst.mli index 3c14c31039..4494b7d6b9 100644 --- a/compiler/src/subst.mli +++ b/compiler/src/subst.mli @@ -7,7 +7,9 @@ val gsubst_func : (?loc:L.t -> 'ty1 -> 'ty2) -> ('ty1 ggvar -> 'ty2 gexpr) -> (' val subst_func : ('ty gvar_i -> 'ty gexpr) -> ('ty, 'info, 'asm) gfunc -> ('ty, 'info, 'asm) gfunc (* replace parameter by their definition everywhere in the program *) -val remove_params : ('info, 'asm) pprog -> ('info, 'asm) prog +val remove_params : ('info, 'asm) mod_item list -> ('info, 'asm) prog + +val psubst_ety : (length ggvar -> expr) -> ety -> ety (* rename all variable using fresh variables *) val clone_func : ('info, 'asm) func -> ('info, 'asm) func @@ -26,7 +28,7 @@ val vsubst_e : vsubst -> expr -> expr val vsubst_es : vsubst -> exprs -> exprs val vsubst_a : vsubst -> eassert -> eassert -val vsubst_as : vsubst -> int assertion list -> int assertion list +val vsubst_as : vsubst -> length assertion list -> length assertion list val vsubst_lval : vsubst -> lval -> lval val vsubst_lvals : vsubst -> lvals -> lvals diff --git a/compiler/src/syntax.ml b/compiler/src/syntax.ml index 04ed444721..5721103c59 100644 --- a/compiler/src/syntax.ml +++ b/compiler/src/syntax.ml @@ -175,9 +175,9 @@ type pexpr_r = | PEstring of string | PEBool of bool | PEInt of int_representation - | PECall of pident * pexpr list + | PECall of pident * pexpr list * pexpr list | PECombF of pident * pexpr list - | PEPrim of pident * pexpr list + | PEPrim of pident * pexpr list * pexpr list | PEOp1 of peop1 * pexpr | PEOp2 of peop2 * (pexpr * pexpr) | PEIf of pexpr * pexpr * pexpr @@ -274,10 +274,22 @@ module SPrinter = struct | PEstring s -> pp_string fmt s | PEBool b -> F.fprintf fmt "%s" (if b then "true" else "false") | PEInt i -> F.fprintf fmt "%s" i - | PECall (f, args) -> F.fprintf fmt "%a(%a)" pp_var f (pp_list ", " pp_expr) args + | PECall (f, al, args) -> + let pp_al fmt al = + if al = [] then () + else + F.fprintf fmt "{%a}" (pp_list ",@ " pp_expr) al + in + F.fprintf fmt "%a%a(%a)" pp_var f pp_al al (pp_list ", " pp_expr) args | PECombF (f, args) -> F.fprintf fmt "%a(%a)" pp_var f (pp_list ", " pp_expr) args - | PEPrim (f, args) -> F.fprintf fmt "%a%s(%a)" sharp () (L.unloc f) (pp_list ", " pp_expr) args + | PEPrim (f, al, args) -> + let pp_al fmt al = + if al = [] then () + else + F.fprintf fmt "{%a}" (pp_list ",@ " pp_expr) al + in + F.fprintf fmt "%a%s%a(%a)" sharp () (L.unloc f) pp_al al (pp_list ", " pp_expr) args | PEOp1 (op, e) -> let p = prio_of_op1 op in optparent fmt prio p "("; @@ -445,6 +457,7 @@ type pfundef = { pdf_annot : pannotations; pdf_cc : pcall_conv option; pdf_name : pident; + pdf_alargs : pident list; pdf_args : (pannotations * paramdecls) list; pdf_rty : (pannotations * pstotype) list option; pdf_body : pfunbody; diff --git a/compiler/src/syscall_t.ml b/compiler/src/syscall_t.ml deleted file mode 100644 index 73888bff24..0000000000 --- a/compiler/src/syscall_t.ml +++ /dev/null @@ -1,2 +0,0 @@ -type 'a syscall_t = - | RandomBytes of 'a diff --git a/compiler/src/toEC.ml b/compiler/src/toEC.ml index 3fabf2f233..1137b45e23 100644 --- a/compiler/src/toEC.ml +++ b/compiler/src/toEC.ml @@ -504,7 +504,8 @@ module Env: EnvT = struct let add_ty env = function | Bty _ -> () - | Arr (_ws, n) -> add_Array env n + | Arr (_ws, Const n) -> add_Array env n + | _ -> assert false (* not supported yet *) let empty arch pd msfsz array_theories = { @@ -575,9 +576,10 @@ end let check_array env x = match (L.unloc x).v_ty with - | Arr(ws, n) -> + | Arr(ws, Const n) -> Sarraytheory.mem (Array n) (Env.array_theories env) && Sarraytheory.mem (WArray (arr_size ws n)) (Env.array_theories env) + | Arr _ -> assert false (* not supported *) | _ -> true (* ------------------------------------------------------------------- *) @@ -961,6 +963,11 @@ let toec_ty onarray env ty = match ty with | Arr(ws,n) -> onarray env ws n let onarray_ty_dfl env ws n = + let n = + match n with + | Const n -> n + | _ -> assert false + in Format.sprintf "%s.t %s.t" (fmt_Wsz ws) (ec_Array env n) let of_list_dfl env _ws n = @@ -971,13 +978,13 @@ let of_list_dfl env _ws n = module type EcArray = sig val ec_darray8: Env.t -> int -> ec_expr - val ec_cast_array: Env.t -> wsize * int -> wsize * int -> ec_expr -> ec_expr + val ec_cast_array: Env.t -> wsize * length -> wsize * length -> ec_expr -> ec_expr val toec_pget: Env.t -> Memory_model.aligned * Warray_.arr_access * wsize * var * ec_expr -> ec_expr - val toec_psub: Env.t -> Warray_.arr_access * wsize * int * int ggvar * ec_expr -> ec_expr + val toec_psub: Env.t -> Warray_.arr_access * wsize * length * length ggvar * ec_expr -> ec_expr val toec_laset: Env.t -> Warray_.arr_access * wsize * var * ec_expr -> ec_expr -> ec_instr - val toec_lasub: Env.t -> Warray_.arr_access * wsize * int * var L.located * ec_expr -> ec_expr -> ec_expr + val toec_lasub: Env.t -> Warray_.arr_access * wsize * length * var L.located * ec_expr -> ec_expr -> ec_expr - val onarray_ty: Env.t -> wsize -> int -> string + val onarray_ty: Env.t -> wsize -> length -> string val add_arr: Env.t -> wsize -> int -> unit val add_jarray: Env.t -> wsize -> int -> unit val of_list: Env.t -> wsize -> int -> ec_expr @@ -993,7 +1000,8 @@ module EcArrayOld : EcArray = struct let i = Env.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"] + let ec_Array_init env len = + Eident [ec_Array env len; "init"] let ec_initi env (x, n, ws) = let f i = ec_aget x (ec_ident i) in @@ -1012,13 +1020,16 @@ module EcArrayOld : EcArray = struct ) let ec_cast_array env (ws, n) (wse, ne) e = - let i = Env.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]) + match n, ne with + | Const n, Const ne -> + let i = Env.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]) + | _, _ -> assert false (* not supported *) let toec_pget env (_a, aa, ws, x, e) = - let (xws, n) = array_kind x.v_ty in + let (xws, n) = array_kind_const x.v_ty in if ws = xws && aa = Warray_.AAscale then ec_aget (ec_vari env x) e else @@ -1028,10 +1039,12 @@ module EcArrayOld : EcArray = struct ) let toec_psub env (aa, ws, len, x, e) = + match len with + | Const len -> assert (check_array env x.gv); let i = Env.create_name env "i" in let x = L.unloc x.gv in - let (xws,n) = array_kind x.v_ty in + let (xws,n) = array_kind_const x.v_ty in if ws = xws && aa = Warray_.AAscale then Eapp ( ec_Array_init env len, @@ -1048,9 +1061,10 @@ module EcArrayOld : EcArray = struct ]) ) ]) + | _ -> assert false (* not supported *) let toec_laset env (aa, ws, x, e1) e = - let (xws,n) = array_kind x.v_ty in + let (xws,n) = array_kind_const x.v_ty in if ws = xws && aa = Warray_.AAscale then ESasgn ([LvArrItem ([ec_vars env x], e1)], e) else @@ -1066,8 +1080,13 @@ module EcArrayOld : EcArray = struct let toec_lasub env (aa, ws, len, x, e1) e = assert (check_array env x); + let len = + match len with + | Const len -> len + | _ -> assert false + in let x = L.unloc x in - let (xws, n) = array_kind x.v_ty in + let (xws, n) = array_kind_const x.v_ty in if ws = xws && aa = Warray_.AAscale then let i = Env.create_name env "i" in let range_ub = Eop2 (Plus, e1, ec_int len) in @@ -1118,14 +1137,17 @@ module EcWArray: EcArray = struct ) let ec_cast_array env (ws, n) (wse, ne) e = - let sizews = ws2bytes ws in - let sizewb = ws2bytes wse in - Env.add_SubArrayCast env sizews sizewb n ne; - let sa = fmt_array_theory (SubArrayCast { sizews; sizewb; sizes = n; sizeb = ne }) in - Eapp (Eident [sa; "get_sub"], [e; ec_int 0]) + match n, ne with + | Const n, Const ne -> + let sizews = ws2bytes ws in + let sizewb = ws2bytes wse in + Env.add_SubArrayCast env sizews sizewb n ne; + let sa = fmt_array_theory (SubArrayCast { sizews; sizewb; sizes = n; sizeb = ne }) in + Eapp (Eident [sa; "get_sub"], [e; ec_int 0]) + | _ -> assert false (* not supported *) let toec_pget env (_a, aa, ws, x, e) = - let (xws,n) = array_kind x.v_ty in + let (xws,n) = array_kind_const x.v_ty in if ws = xws && aa = Warray_.AAscale then ec_aget (ec_vari env x) e else @@ -1137,37 +1159,40 @@ module EcWArray: EcArray = struct Eapp (Eident [arrayaccesscast; getf], [ec_vari env x; e]) let toec_psub env (aa, ws, len, x, e) = - assert (check_array env x.gv); - let x = L.unloc x.gv in - let (xws,n) = array_kind x.v_ty in - let subf = - if ws = xws then - if aa = Warray_.AAscale then begin - (* Sub-array access aligned *) - Env.add_SubArray env len n; - let subarray = fmt_array_theory (SubArray { sizes = len; sizeb = n }) in - Eident [subarray; "get_sub"] - end else begin - (* Sub-array access unaligned *) - let sizew = ws2bytes ws in - Env.add_SubArrayDirect env sizew len n; - let sa = fmt_array_theory (SubArrayDirect { sizew; sizes = len; sizeb = n }) in - Eident [sa; "get_sub_direct"] + match len with + | Const len -> + assert (check_array env x.gv); + let x = L.unloc x.gv in + let (xws,n) = array_kind_const x.v_ty in + let subf = + if ws = xws then + if aa = Warray_.AAscale then begin + (* Sub-array access aligned *) + Env.add_SubArray env len n; + let subarray = fmt_array_theory (SubArray { sizes = len; sizeb = n }) in + Eident [subarray; "get_sub"] + end else begin + (* Sub-array access unaligned *) + let sizew = ws2bytes ws in + Env.add_SubArrayDirect env sizew len n; + let sa = fmt_array_theory (SubArrayDirect { sizew; sizes = len; sizeb = n }) in + Eident [sa; "get_sub_direct"] + end + else begin + (* Sub-array access typecast (direct or not) *) + let get_sub = if aa = Warray_.AAscale then "get_sub" else "get_sub_direct" in + let sizews = ws2bytes ws in + let sizewb = ws2bytes xws in + Env.add_SubArrayCast env sizews sizewb len n; + let sa = fmt_array_theory (SubArrayCast { sizews; sizewb; sizes = len; sizeb = n }) in + Eident [sa; get_sub] end - else begin - (* Sub-array access typecast (direct or not) *) - let get_sub = if aa = Warray_.AAscale then "get_sub" else "get_sub_direct" in - let sizews = ws2bytes ws in - let sizewb = ws2bytes xws in - Env.add_SubArrayCast env sizews sizewb len n; - let sa = fmt_array_theory (SubArrayCast { sizews; sizewb; sizes = len; sizeb = n }) in - Eident [sa; get_sub] - end - in - Eapp (subf, [ec_vari env x; e]) + in + Eapp (subf, [ec_vari env x; e]) + | _ -> assert false (* not supported *) let toec_laset env (aa, ws, x, e1) e = - let (xws,n) = array_kind x.v_ty in + let (xws,n) = array_kind_const x.v_ty in if ws = xws && aa = Warray_.AAscale then ESasgn ([LvArrItem ([ec_vars env x], e1)], e) else @@ -1183,8 +1208,13 @@ module EcWArray: EcArray = struct let toec_lasub env (aa, ws, len, x, e1) e = assert (check_array env x); + let len = + match len with + | Const len -> len + | _ -> assert false + in let x = L.unloc x in - let (xws, n) = array_kind x.v_ty in + let (xws, n) = array_kind_const x.v_ty in let subf = if ws = xws then if aa = Warray_.AAscale then begin @@ -1225,8 +1255,11 @@ module EcBArray : EcArray = struct Eident [ec_BArray env sz; "darray"] let ec_cast_array (_env:Env.t) (ws1, sz1) (ws2, sz2) e = - assert (Prog.arr_size ws1 sz1 = Prog.arr_size ws2 sz2); - e + match sz1, sz2 with + | Const sz1, Const sz2 -> + assert (Prog.arr_size ws1 sz1 = Prog.arr_size ws2 sz2); + e + | _, _ -> assert false (* not supported *) let direct aa = match aa with @@ -1239,13 +1272,13 @@ module EcBArray : EcArray = struct | Warray_.AAscale -> Format.sprintf "%i" (int_of_ws ws) let toec_pget (env:Env.t) (_a, aa, ws, x, ei) = - let (xws, n) = array_kind x.v_ty in + let (xws, n) = array_kind_const x.v_ty in let sz = arr_size xws n in Eapp (Eident [ec_BArray env sz; Format.sprintf "get%i%s" (int_of_ws ws) (direct aa)], [ec_vari env x; ei]) let toec_laset (env:Env.t) (aa, ws, x, ei) e = - let (xws,n) = array_kind x.v_ty in + let (xws,n) = array_kind_const x.v_ty in let sz = arr_size xws n in let eset = Eapp (Eident [ec_BArray env sz; Format.sprintf "set%i%s" (int_of_ws ws) (direct aa)], @@ -1253,17 +1286,25 @@ module EcBArray : EcArray = struct ESasgn ([LvIdent [ec_vars env x]], eset) let toec_psub (env:Env.t) (aa, ws, len, x, ei) = - let x = L.unloc x.gv in - let (xws,n) = array_kind x.v_ty in - let sizes = arr_size ws len in - let sizeb = arr_size xws n in - let s = { sizes; sizeb } in - Eapp(Eident [ec_SBArray env s; Format.sprintf "get_sub%s" (scale aa ws)], - [ec_vari env x; ei]) + match len with + | Const len -> + let x = L.unloc x.gv in + let (xws,n) = array_kind_const x.v_ty in + let sizes = arr_size ws len in + let sizeb = arr_size xws n in + let s = { sizes; sizeb } in + Eapp(Eident [ec_SBArray env s; Format.sprintf "get_sub%s" (scale aa ws)], + [ec_vari env x; ei]) + | _ -> assert false (* not supported *) let toec_lasub (env:Env.t) (aa, ws, len, x, ei) e = + let len = + match len with + | Const len -> len + | _ -> assert false + in let x = L.unloc x in - let (xws,n) = array_kind x.v_ty in + let (xws,n) = array_kind_const x.v_ty in let sizes = arr_size ws len in let sizeb = arr_size xws n in let s = { sizes; sizeb } in @@ -1271,6 +1312,11 @@ module EcBArray : EcArray = struct [ec_vari env x; ei; e]) let onarray_ty env ws n = + let n = + match n with + | Const n -> n + | _ -> assert false + in Format.sprintf "%s.t" (ec_BArray env (arr_size ws n)) let add_arr env ws n = Env.add_BArray env (arr_size ws n) @@ -1304,10 +1350,6 @@ let ty_expr = function let ty_sopn pd msfsz asmOp op es = match op with - (* Do a special case for copy since the Coq type loose information *) - | Sopn.Opseudo_op (Pseudo_operator.Ocopy(ws, p)) -> - let l = [Arr(ws, Conv.int_of_pos p)] in - l, l | Sopn.Opseudo_op (Pseudo_operator.Oswap _) -> let l = List.map ty_expr es in l, l @@ -1329,7 +1371,7 @@ let rec is_write_i x i = match i.i_desc with | Cassgn (lv,_,_,_) -> is_write_lv x lv - | Copn(lvs,_,_,_) | Ccall(lvs, _, _) | Csyscall(lvs,_,_) -> + | Copn(lvs,_,_,_) | Ccall(lvs, _, _, _) | Csyscall(lvs,_,_,_) -> is_write_lvs x lvs | Cassert _ -> false | Cif(_, c1, c2) | Cwhile(_, c1, _, _, c2) -> @@ -1456,7 +1498,7 @@ module EcExpression(EA: EcArray): EcExpression = struct ) | Oarray len -> Eapp ( - EA.of_list env U8 (Conv.int_of_pos len), + EA.of_list env U8 (CoreConv.int_of_cz len), [Elist (List.map (toec_expr env) es)] ) end @@ -1806,8 +1848,14 @@ struct let ec_syscall env o = match o with - | Syscall_t.RandomBytes (ws, p) -> - let n = arr_size ws (Conv.int_of_pos p) in + | Syscall.RandomBytes -> + let p = assert false in (* FIXME *) + let p = + match p with + | Const p -> p + | _ -> assert false + in + let n = arr_size U8 p in Env.add_randombytes env n; Format.sprintf "%s.randombytes_%i" syscall_mod_arg n @@ -1838,7 +1886,7 @@ struct let ec_e op = Eapp (ec_op op, List.map (toec_cast env) (List.combine itys es)) in (ec_leaks_opn env es) @ (ec_expr_assgn env lvs otys otys' (ec_e op')) - | Ccall (lvs, f, es) -> + | Ccall (lvs, f, _al, es) -> let env = Env.new_aux_range env in let otys, itys = Env.get_funtype env f in let args = List.map (toec_cast env) (List.combine itys es) in @@ -1846,8 +1894,9 @@ struct (ec_leaks_es env es) @ (ec_pcall env lvs leak_lvs otys [Env.get_funname env f] args) @ (ec_leak_call_acc env) - | Csyscall (lvs, o, es) -> - let s = Syscall.syscall_sig_u o in + | Csyscall (lvs, o, _al, es) -> + let n = assert false in (* FIXME *) + let s = Syscall.syscall_sig_u (Env.pd env) n 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 (toec_cast env) (List.combine itys es) in @@ -1957,7 +2006,7 @@ struct let ec_randombytes env = let randombytes_decl a n = - let arr_ty = toec_ty env (Arr (U8, n)) in + let arr_ty = toec_ty env (Arr (U8, Const n)) in { fname = Format.sprintf "randombytes_%i" n; args = [(a, arr_ty)]; @@ -1997,7 +2046,8 @@ struct let add_arrsz env f = let add env x = match x.v_ty with - | Arr(ws, n) -> EA.add_jarray env ws n + | Arr(ws, Const n) -> EA.add_jarray env ws n + | Arr _ -> assert false | _ -> () in let vars = vars_fc f in @@ -2056,7 +2106,7 @@ and used_func_i used i = | 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 - | Ccall (_,f,_) -> Ss.add f.fn_name used + | Ccall (_,f,_,_) -> Ss.add f.fn_name used let extract ((globs,funcs):('info, 'asm) prog) arch pd msfsz asmOp (model: model) amodel fnames array_dir fmt = let save_array_theories array_theories = diff --git a/compiler/src/typing.ml b/compiler/src/typing.ml index b968a28727..5acb530cf8 100644 --- a/compiler/src/typing.ml +++ b/compiler/src/typing.ml @@ -19,17 +19,17 @@ let error loc fmt = let ty_var (x: var) = let ty = x.v_ty in begin match ty with - | Arr(_, n) -> + | Arr(_, Const n) -> if (n < 1) then error (L.i_loc0 x.v_dloc) "the variable %a has type %a, its array size should be positive" - (Printer.pp_var ~debug:false) x PrintCommon.pp_ty ty + (Printer.pp_var ~debug:false) x (Printer.pp_ty ~debug:false) ty | _ -> () end; ty -let ty_gvar (x: int ggvar) = ty_var (L.unloc x.gv) +let ty_gvar (x: length ggvar) = ty_var (L.unloc x.gv) (* -------------------------------------------------------------------- *) @@ -39,28 +39,31 @@ let check_array loc e te = | _ -> error loc "the expression %a has type %a while an array is expected" - (Printer.pp_expr ~debug:false) e PrintCommon.pp_ty te + (Printer.pp_expr ~debug:false) e (Printer.pp_ty ~debug:false) te let subtype t1 t2 = match t1, t2 with | Bty (U ws1), Bty (U ws2) -> wsize_le ws1 ws2 | Bty bty1, Bty bty2 -> bty1 = bty2 - | Arr(ws1,len1), Arr(ws2,len2) -> arr_size ws1 len1 == arr_size ws2 len2 + | Arr(ws1,len1), Arr(ws2,len2) -> Prog.compare_array_length (ws1, len1) (ws2, len2) | _, _ -> false let check_type loc e te ty = if not (subtype ty te) then error loc "the expression %a has type %a while %a is expected" (Printer.pp_expr ~debug:false) e - PrintCommon.pp_ty te PrintCommon.pp_ty ty + (Printer.pp_ty ~debug:true) te (Printer.pp_ty ~debug:true) ty let check_int loc e te = check_type loc e te tint let check_ptr pd loc e te = check_type loc e te (tu pd) let check_length loc len = + match len with + | Const len -> if len <= 0 then error loc "the length should be strictly positive" + | _ -> () (* -------------------------------------------------------------------- *) @@ -179,7 +182,7 @@ let check_lval pd loc x ty = if not (subtype tx ty) then error loc "the left value %a has type %a while %a is expected" (Printer.pp_lval ~debug:false) x - PrintCommon.pp_ty tx PrintCommon.pp_ty ty + (Printer.pp_ty ~debug:false) tx (Printer.pp_ty ~debug:false) ty let check_lvals pd loc xs tys = let len = List.length tys in @@ -206,7 +209,7 @@ let getfun env fn = (* -------------------------------------------------------------------- *) -let rec check_instr pd msfsz asmOp env i = +let rec check_instr pd msfsz asmOp n env i = let loc = i.i_loc in match i.i_desc with | Cassgn(x,_,ty,e) -> @@ -218,10 +221,16 @@ let rec check_instr pd msfsz asmOp env i = check_exprs pd loc es tins; check_lvals pd loc xs tout - | Csyscall(xs, o, es) -> - let s = Syscall.syscall_sig_u o in + | Csyscall(xs, o, al, es) -> + let s = Syscall.syscall_sig_u pd n o in + let f = + let l = List.combine s.scs_al al in + fun x -> List.assoc_opt x l + in let tins = List.map Conv.ty_of_cty s.scs_tin in + let tins = List.map (subst_ty f) tins in let tout = List.map Conv.ty_of_cty s.scs_tout in + let tout = List.map (subst_ty f) tout in check_exprs pd loc es tins; check_lvals pd loc xs tout @@ -230,27 +239,33 @@ let rec check_instr pd msfsz asmOp env i = | Cif(e,c1,c2) -> check_expr pd loc e tbool; - check_cmd pd msfsz asmOp env c1; - check_cmd pd msfsz asmOp env c2 + check_cmd pd msfsz asmOp n env c1; + check_cmd pd msfsz asmOp n env c2 | Cfor(i,(_,e1,e2),c) -> check_expr pd loc (Pvar (gkvar i)) tint; check_expr pd loc e1 tint; check_expr pd loc e2 tint; - check_cmd pd msfsz asmOp env c + check_cmd pd msfsz asmOp n env c | Cwhile(_, c1, e, _, c2) -> check_expr pd loc e tbool; - check_cmd pd msfsz asmOp env c1; - check_cmd pd msfsz asmOp env c2 + check_cmd pd msfsz asmOp n env c1; + check_cmd pd msfsz asmOp n env c2 - | Ccall(xs,fn,es) -> + | Ccall(xs,fn,al,es) -> let fd = getfun env fn in - check_exprs pd loc es fd.f_tyin; - check_lvals pd loc xs fd.f_tyout - -and check_cmd pd msfsz asmOp env c = - List.iter (check_instr pd msfsz asmOp env) c + let f = + let l = List.combine fd.f_al al in + fun x -> List.assoc_opt x l + in + let tyin = List.map (subst_ty f) fd.f_tyin in + check_exprs pd loc es tyin; + let tyout = List.map (subst_ty f) fd.f_tyout in + check_lvals pd loc xs tyout + +and check_cmd pd msfsz asmOp n env c = + List.iter (check_instr pd msfsz asmOp n env) c (* -------------------------------------------------------------------- *) let check_global_decl (g, d) = @@ -259,15 +274,15 @@ let check_global_decl (g, d) = error (L.i_loc0 g.v_dloc) "global variable %a has type %a but its value has type %a" (Printer.pp_var ~debug:false) - g PrintCommon.pp_ty ty PrintCommon.pp_ty vty + g (Printer.pp_ty ~debug:false) ty (Printer.pp_ty ~debug:false) vty in match d with | Global.Garr (len, _) -> if match ty with - | Arr (ws, len') -> Conv.int_of_pos len <> arr_size ws len' + | Arr (ws, Const len') -> CoreConv.int_of_cz len <> arr_size ws len' | _ -> true - then error (Arr (U8, Conv.int_of_pos len)) + then error (Arr (U8, Const (CoreConv.int_of_cz len))) | Gword (ws, _) -> if match ty with Bty (U ws') -> not (wsize_le ws ws') | _ -> true then error (Bty (U ws)) @@ -283,19 +298,19 @@ let check_contract pd loc tyin tyout fc = (* -------------------------------------------------------------------- *) -let check_fun pd msfsz asmOp env fd = +let check_fun pd msfsz asmOp n env fd = let args = List.map (fun x -> Pvar (gkvar (L.mk_loc x.v_dloc x))) fd.f_args in let res = List.map (fun x -> Pvar (gkvar x)) fd.f_ret in let i_loc = L.i_loc0 fd.f_loc in check_exprs pd i_loc args fd.f_tyin; check_exprs pd i_loc res fd.f_tyout; - check_cmd pd msfsz asmOp env fd.f_body; + check_cmd pd msfsz asmOp n env fd.f_body; Option.may (check_contract pd i_loc fd.f_tyin fd.f_tyout) fd.f_contract; Hf.add env fd.f_name fd (* -------------------------------------------------------------------- *) -let check_prog pd msfsz asmOp (gds, funcs) = +let check_prog pd msfsz asmOp n (gds, funcs) = let env = Hf.create 107 in List.iter check_global_decl gds; - List.iter (check_fun pd msfsz asmOp env) (List.rev funcs) + List.iter (check_fun pd msfsz asmOp n env) (List.rev funcs) diff --git a/compiler/src/typing.mli b/compiler/src/typing.mli index 3449397191..69b11d2409 100644 --- a/compiler/src/typing.mli +++ b/compiler/src/typing.mli @@ -2,13 +2,13 @@ open Prog exception TyError of L.i_loc * string -val check_length : L.i_loc -> int -> unit +val check_length : L.i_loc -> length -> unit val ty_lval : Wsize.wsize -> L.i_loc -> lval -> ty val ty_expr : Wsize.wsize -> L.i_loc -> expr -> ty val error : Prog.L.i_loc -> ('a, Format.formatter, unit, 'b) format4 -> 'a val check_prog : - Wsize.wsize -> Wsize.wsize -> 'asm Sopn.asmOp -> ('info, 'asm) prog -> unit + Wsize.wsize -> Wsize.wsize -> 'asm Sopn.asmOp -> Type.length_var -> ('info, 'asm) prog -> unit (* Return the type of the expression but do not type check it *) val type_of_expr : expr -> ty diff --git a/compiler/src/varalloc.ml b/compiler/src/varalloc.ml index cef56a083e..676ee6e0a0 100644 --- a/compiler/src/varalloc.ml +++ b/compiler/src/varalloc.ml @@ -49,7 +49,11 @@ type glob_alloc_oracle_t = (* --------------------------------------------------- *) let incr_liverange r x d : liverange = - let s = size_of x.v_ty in + let s = + match size_of x.v_ty with + | Const s -> s + | _ -> hierror ~loc:(Lone x.v_dloc) "stack variable “%a” cannot be of unknown size" (Printer.pp_var ~debug:false) x + in let g = Mint.find_default Mv.empty s r in let i = match Mv.find x g with @@ -200,11 +204,11 @@ let classes_alignment (onfun : funname -> param_info option list) (gtbl: alignme iter_instr (fun i -> try match i.i_desc with | Cassgn(x,_,_,e) -> add_lv x; add_e e - | Copn(xs,_,_,es) | Csyscall(xs,_,es) -> add_lvs xs; add_es es + | Copn(xs,_,_,es) | Csyscall(xs,_,_,es) -> add_lvs xs; add_es es | Cassert _ -> assert false (* used after remove_assert *) | Cif(e, _, _) | Cwhile (_, _, e, _, _) -> add_e e | Cfor _ -> assert false - | Ccall(xs, fn, es) -> + | Ccall(xs, fn, _al, es) -> add_lvs xs; calls := Sf.add fn !calls; List.iter2 add_p (onfun fn) es @@ -218,7 +222,7 @@ let err_var_not_initialized x = hierror ~loc:Lnone "variable “%a” (declared at %a) may not be initialized" (Printer.pp_var ~debug:true) x Location.pp_loc x.v_dloc let get_slot ?var coloring x = - let sz = size_of x.v_ty in + let sz = size_of_const x.v_ty in try Mv.find x (Mint.find sz coloring) with Not_found -> err_var_not_initialized (Option.default x var) @@ -233,7 +237,13 @@ let init_slots pd stack_pointers alias coloring fv = let add_local x info = Hv.add lalloc x info in (* FIXME: move definition of interval in Alias *) - let r2i (min,max) = Interval.{min;max} in + let r2i v (min,max) = + let max = + match max with + | Const max -> max + | _ -> hierror ~loc:(Lone v.v_dloc) "a stack variable (%a) cannot have a non-constant length" (Printer.pp_var ~debug:true) v + in + Interval.{min;max} in let dovar v = match v.v_kind with | Stack Direct -> @@ -241,23 +251,23 @@ let init_slots pd stack_pointers alias coloring fv = let c = Alias.normalize_var alias v in if c.scope = E.Sglob then (* TODO: do we need to check that we are exact and fail otherwise? *) - add_local v (Direct (c.in_var, r2i c.range, E.Sglob)) + add_local v (Direct (c.in_var, r2i v c.range, E.Sglob)) else begin let slot = get_slot coloring c.in_var in add_slot slot; (* TODO: do we need to check that we are exact and fail otherwise? *) - add_local v (Direct (slot, r2i c.range, E.Slocal)) + add_local v (Direct (slot, r2i v c.range, E.Slocal)) end else begin match v.v_ty with | Bty (U ws) -> let sz = size_of_ws ws in let slot = get_slot coloring v in add_slot slot; - add_local v (Direct (slot, r2i(0, sz), E.Slocal)) + add_local v (Direct (slot, r2i v (0, Const sz), E.Slocal)) | _ -> hierror ~loc:(Lone v.v_dloc) "cannot allocate in the stack the variable “%a” of type %a" (Printer.pp_var ~debug:false) v - PrintCommon.pp_ty v.v_ty + (Printer.pp_ty ~debug:false) v.v_ty end | Stack (Pointer _) -> @@ -351,7 +361,7 @@ let alloc_local_stack size slots atbl = let init_slot (x,ws) = let pos = round_ws ws !size in - let n = size_of x.v_ty in + let n = size_of_const x.v_ty in size := pos + n; (x,ws,pos) in @@ -365,7 +375,7 @@ let get_returned_params ~funname (alias: Alias.alias) args = if is_ptr x.v_kind then let c = Alias.normalize_var alias x in let arg_slices = List.map (Alias.normalize_var alias) args in - match List.index_of c arg_slices with + match List.find_index (Alias.eq_slice c) arg_slices with | None -> let msg = if List.mem c.in_var args @@ -485,7 +495,7 @@ let alloc_mem (gtbl: wsize Hv.t) globs = List.iteri (fun i w -> t.(ofs + i) <- w) w | Global.Garr(p, gt) -> - let ip = Conv.int_of_pos p in + let ip = CoreConv.int_of_cz p in for i = 0 to ip - 1 do let w = match Warray_.WArray.get p Aligned Warray_.AAdirect U8 gt (Conv.cz_of_int i) with diff --git a/compiler/tests/exec/execlib.ml b/compiler/tests/exec/execlib.ml index 17c1943451..1c84393e06 100644 --- a/compiler/tests/exec/execlib.ml +++ b/compiler/tests/exec/execlib.ml @@ -20,7 +20,7 @@ let load_file name = let open Pretyping in try name - |> tt_file Arch.arch_info Env.empty None None + |> tt_file Arch.arch_info Compile.syscall_length_ident Env.empty None None |> fst |> Env.decls |> Compile.preprocess Arch.pointer_data Arch.msf_size Arch.asmOp with TyError (loc, e) -> diff --git a/compiler/tests/negative.expected b/compiler/tests/negative.expected index b7583af66c..c10865725b 100644 --- a/compiler/tests/negative.expected +++ b/compiler/tests/negative.expected @@ -686,51 +686,43 @@ param expansion: array size mismatch for global variable g: 1 value given (4 exp fail/param_expansion/x86-64/array_too_large_arg.jazz: -"fail/param_expansion/x86-64/array_too_large_arg.jazz", line 2 (37-38): -compilation error in function main: -param expansion: cannot define a (sub-)array of size 18446744073709551616, this number is too big +compilation error: +param expansion: number too big fail/param_expansion/x86-64/array_too_large_expr.jazz: -"fail/param_expansion/x86-64/array_too_large_expr.jazz", line 5 (8-9): -compilation error in function main: -param expansion: cannot define a (sub-)array of size 18446744073709551616, this number is too big +compilation error: +param expansion: number too big fail/param_expansion/x86-64/array_too_large_global.jazz: -"fail/param_expansion/x86-64/array_too_large_global.jazz", line 1 (25-26): compilation error: -param expansion: cannot define a (sub-)array of size 18446744073709551616, this number is too big +param expansion: number too big fail/param_expansion/x86-64/array_too_large_lval.jazz: -"fail/param_expansion/x86-64/array_too_large_lval.jazz", line 5 (4-5): -compilation error in function main: -param expansion: cannot define a (sub-)array of size 18446744073709551616, this number is too big +compilation error: +param expansion: number too big fail/param_expansion/x86-64/expression_arg.jazz: -"fail/param_expansion/x86-64/expression_arg.jazz", line 3 (24-25): -compilation error in function f: -param expansion: unary operator (64u) not supported in array sizes +compilation error: +param expansion: operations too complex fail/param_expansion/x86-64/expression_global.jazz: -"fail/param_expansion/x86-64/expression_global.jazz", line 2 (7-8): compilation error: -param expansion: unary operator (64u) not supported in array sizes +param expansion: operations too complex fail/param_expansion/x86-64/expression_global2.jazz: -"fail/param_expansion/x86-64/expression_global2.jazz", line 2 (18-19): compilation error: -param expansion: unary operator (64u) not supported in array sizes +param expansion: operations too complex fail/param_expansion/x86-64/expression_res.jazz: -"fail/param_expansion/x86-64/expression_res.jazz", line 4 (13-14): -compilation error in function f: -param expansion: unary operator (64u) not supported in array sizes +compilation error: +param expansion: operations too complex fail/param_expansion/x86-64/global_array_not_constant.jazz: @@ -746,21 +738,18 @@ param expansion: the expression assigned to global variable b must evaluate to a fail/param_expansion/x86-64/operator_arg.jazz: -"fail/param_expansion/x86-64/operator_arg.jazz", line 3 (26-27): -compilation error in function f: -param expansion: operator &256u not allowed in array size (only standard arithmetic operators and modulo are allowed) +compilation error: +param expansion: operations too complex fail/param_expansion/x86-64/operator_global.jazz: -"fail/param_expansion/x86-64/operator_global.jazz", line 2 (9-10): compilation error: -param expansion: operator &256u not allowed in array size (only standard arithmetic operators and modulo are allowed) +param expansion: operations too complex fail/param_expansion/x86-64/operator_res.jazz: -"fail/param_expansion/x86-64/operator_res.jazz", line 4 (15-16): -compilation error in function f: -param expansion: operator &256u not allowed in array size (only standard arithmetic operators and modulo are allowed) +compilation error: +param expansion: operations too complex fail/pointers/x86-64/test_writable_arguments.jazz: @@ -1400,7 +1389,7 @@ fail/typing/x86-64/lval_mismatch.jazz: fail/typing/x86-64/lval_param.jazz: -"fail/typing/x86-64/lval_param.jazz", line 4 (3-4): param variables are not allowed here +"fail/typing/x86-64/lval_param.jazz", line 4 (3-4): param and length variables are not allowed here fail/typing/x86-64/non_inline_stack_arg.jazz: @@ -1414,7 +1403,7 @@ typing error: t has kind stack, only reg or reg ptr are allowed in result of non fail/typing/x86-64/only_param.jazz: -"fail/typing/x86-64/only_param.jazz", line 3 (10-11): only param variables are allowed here +"fail/typing/x86-64/only_param.jazz", line 3 (10-11): only param and length variables are allowed here fail/typing/x86-64/param_type_mismatch.jazz: @@ -1426,7 +1415,7 @@ fail/typing/x86-64/res_wrong_type.jazz: fail/typing/x86-64/subarray_non_const_len.jazz: -"fail/typing/x86-64/subarray_non_const_len.jazz", line 5 (6-7): only param variables are allowed here +"fail/typing/x86-64/subarray_non_const_len.jazz", line 5 (6-7): only param and length variables are allowed here fail/typing/x86-64/unsupported_primitive.jazz: diff --git a/compiler/tests/printing.ml b/compiler/tests/printing.ml index 5a8bc6b7f6..7189cf5aa0 100644 --- a/compiler/tests/printing.ml +++ b/compiler/tests/printing.ml @@ -55,44 +55,52 @@ and eq_simple_attribute x y = | Astruct a, Astruct b -> eq_annotations a b | (Aint _ | Aid _ | Astring _ | Aws _ | Astruct _), _ -> false -let rec eq_pty x y = + (* FIXME: we need to compare length to compare types, but to compare lengths, + we need to be able to compare vars that contain types... + We break the cycle by defining a dedicated check for length vars, + and check that types are equal to int. + *) + let eq_length_var x y = + x.v_name = y.v_name && x.v_kind = y.v_kind && x.v_ty = Bty Int && y.v_ty = Bty Int + && eq_annotations x.v_annot y.v_annot + +let rec eq_al x y = + match x, y with + | Const n1, Const n2 -> n1 = n2 + | Var x1, Var x2 -> eq_length_var x1 x2 + | Neg al1, Neg al2 -> eq_al al1 al2 + | Add (al11, al12), Add (al21, al22) -> eq_al al11 al21 && eq_al al12 al22 + | Sub (al11, al12), Sub (al21, al22) -> eq_al al11 al21 && eq_al al12 al22 + | Mul (al11, al12), Mul (al21, al22) -> eq_al al11 al21 && eq_al al12 al22 + | Div (sg1, al11, al12), Div (sg2, al21, al22) -> sg1 = sg2 && eq_al al11 al21 && eq_al al12 al22 + | Mod (sg1, al11, al12), Mod (sg2, al21, al22) -> sg1 = sg2 && eq_al al11 al21 && eq_al al12 al22 + | Shl (al11, al12), Shl (al21, al22) -> eq_al al11 al21 && eq_al al12 al22 + | Shr (al11, al12), Shr (al21, al22) -> eq_al al11 al21 && eq_al al12 al22 + | _, _ -> false + +let eq_ty x y = match (x, y) with | Bty a, Bty b -> a = b - | Arr (a, n), Arr (b, m) -> Wsize.wsize_eqb a b && eq_pexpr_ n m + | Arr (a, n), Arr (b, m) -> Wsize.wsize_eqb a b && eq_al n m | (Bty _ | Arr _), _ -> false -and eq_pvar x y = - x.v_name = y.v_name && x.v_kind = y.v_kind && eq_pty x.v_ty y.v_ty + let eq_pvar x y = + x.v_name = y.v_name && x.v_kind = y.v_kind && eq_ty x.v_ty y.v_ty && eq_annotations x.v_annot y.v_annot -and eq_pvar_i x y = eq_pvar (L.unloc x) (L.unloc y) -and eq_pgvar x y = eq_pvar_i x.gv y.gv && x.gs = y.gs - -and eq_plval x y = - match (x, y) with - | Lnone (_, a), Lnone (_, b) -> eq_pty a b - | Lvar a, Lvar b -> eq_pvar_i a b - | Lmem (a, b, _, d), Lmem (e, f, _, h) -> - a = e && Wsize.wsize_eqb b f && eq_pexpr d h - | Laset (a, b, c, d, e), Laset (f, g, h, i, j) -> - a = f && b = g && Wsize.wsize_eqb c h && eq_pvar_i d i && eq_pexpr e j - | Lasub (a, b, c, d, e), Lasub (f, g, h, i, j) -> - a = f && Wsize.wsize_eqb b g && eq_pexpr_ c h && eq_pvar_i d i - && eq_pexpr e j - | (Lnone _ | Lvar _ | Lmem _ | Laset _ | Lasub _), _ -> false - -and eq_plvals x y = List.for_all2 eq_plval x y + let eq_pvar_i x y = eq_pvar (L.unloc x) (L.unloc y) + let eq_pgvar x y = eq_pvar_i x.gv y.gv && x.gs = y.gs -and eq_pexpr x y = + let rec eq_pexpr x y = match (x, y) with | Pconst a, Pconst b -> Z.equal a b | Pbool a, Pbool b -> Stdlib.Bool.equal a b - | Parr_init (a, b), Parr_init (c, d) -> Wsize.wsize_eqb a c && eq_pexpr_ b d + | Parr_init (a, b), Parr_init (c, d) -> Wsize.wsize_eqb a c && eq_al b d | Pvar a, Pvar b -> eq_pgvar a b | Pget (a, b, c, d, e), Pget (f, g, h, i, j) -> a = f && b = g && Wsize.wsize_eqb c h && eq_pgvar d i && eq_pexpr e j | Psub (a, b, c, d, e), Psub (f, g, h, i, j) -> - a = f && Wsize.wsize_eqb b g && eq_pexpr_ c h && eq_pgvar d i + a = f && Wsize.wsize_eqb b g && eq_al c h && eq_pgvar d i && eq_pexpr e j | Pload (a, b, d), Pload (e, f, h) -> a = e && Wsize.wsize_eqb b f && eq_pexpr d h @@ -100,22 +108,21 @@ and eq_pexpr x y = | Papp2 (a, b, c), Papp2 (d, e, f) -> a = d && eq_pexpr b e && eq_pexpr c f | PappN (a, b), PappN (c, d) -> a = c && eq_pexprs b d | Pif (a, b, c, d), Pif (e, f, g, h) -> - eq_pty a e && eq_pexpr b f && eq_pexpr c g && eq_pexpr d h + eq_ty a e && eq_pexpr b f && eq_pexpr c g && eq_pexpr d h | ( ( Pconst _ | Pbool _ | Parr_init _ | Pvar _ | Pget _ | Psub _ | Pload _ | Papp1 _ | Papp2 _ | PappN _ | Pif _ ), _ ) -> false and eq_pexprs x y = List.for_all2 eq_pexpr x y -and eq_pexpr_ (PE x) (PE y) = eq_pexpr x y -let rec push_and (e: pexpr) : pexpr_ gassert = +let rec push_and (e: expr) : length gassert = match e with | Papp2 (Operators.Oand, e1, e2) -> Pand (push_and e1, push_and e2) | _ -> Pexpr e -let rec push_and_a (e : pexpr_ gassert) : pexpr_ gassert = +let rec push_and_a (e : _ gassert) : _ gassert = match e with | Pexpr e -> push_and e | Pand (e1, e2) -> Pand(push_and_a e1, push_and_a e2) @@ -136,13 +143,28 @@ let eq_assertion (msg1, e1) (msg2, e2) = let e2 = push_and_a e2 in eq_gassert e1 e2 +let eq_plval x y = + match (x, y) with + | Lnone (_, a), Lnone (_, b) -> eq_ty a b + | Lvar a, Lvar b -> eq_pvar_i a b + | Lmem (a, b, _, d), Lmem (e, f, _, h) -> + a = e && Wsize.wsize_eqb b f && eq_pexpr d h + | Laset (a, b, c, d, e), Laset (f, g, h, i, j) -> + a = f && b = g && Wsize.wsize_eqb c h && eq_pvar_i d i && eq_pexpr e j + | Lasub (a, b, c, d, e), Lasub (f, g, h, i, j) -> + a = f && Wsize.wsize_eqb b g && eq_al c h && eq_pvar_i d i + && eq_pexpr e j + | (Lnone _ | Lvar _ | Lmem _ | Laset _ | Lasub _), _ -> false + + let eq_plvals x y = List.for_all2 eq_plval x y + let eq_pgexpr x y = match (x, y) with | GEword a, GEword b -> eq_pexpr a b | GEarray a, GEarray b -> eq_pexprs a b | (GEword _ | GEarray _), _ -> false -let eq_prange (x : pexpr_ grange) (y : pexpr_ grange) = +let eq_prange (x : length grange) (y : length grange) = let a, b, c = x and d, e, f = y in a = d && eq_pexpr b e && eq_pexpr c f @@ -151,22 +173,22 @@ let rec eq_pstmt x y = List.for_all2 eq_pinstr x y and eq_pinstr x y = eq_annotations x.i_annot y.i_annot && eq_pinstr_r x.i_desc y.i_desc -and eq_pinstr_r (x : _ pinstr_r) y = +and eq_pinstr_r (x : _ instr_r) y = match (x, y) with | Cassgn (a, b, c, d), Cassgn (e, f, g, h) -> - eq_plval a e && b = f && eq_pty c g && eq_pexpr d h + eq_plval a e && b = f && eq_ty c g && eq_pexpr d h | Copn (a, b, c, d), Copn (e, f, g, h) -> eq_plvals a e && b = f && c = g && eq_pexprs d h | Cassert (a, b), Cassert (c, d) -> eq_assertion (a, b) (c, d) - | Csyscall (a, b, c), Csyscall (d, e, f) -> - eq_plvals a d && b = e && eq_pexprs c f + | Csyscall (a, b, c, d), Csyscall (e, f, g, h) -> + eq_plvals a e && b = f && List.for_all2 eq_al c g && eq_pexprs d h | Cif (a, b, c), Cif (d, e, f) -> eq_pexpr a d && eq_pstmt b e && eq_pstmt c f | Cfor (a, b, c), Cfor (d, e, f) -> eq_pvar_i a d && eq_prange b e && eq_pstmt c f | Cwhile (a, b, c, _d, e), Cwhile (f, g, h, _i, j) -> a = f && eq_pstmt b g && eq_pexpr c h && eq_pstmt e j - | Ccall (a, b, c), Ccall (d, e, f) -> - eq_plvals a d && b.fn_name = e.fn_name && eq_pexprs c f + | Ccall (a, b, c, d), Ccall (e, f, g, h) -> + eq_plvals a e && b.fn_name = f.fn_name && List.for_all2 eq_al c g && eq_pexprs d h | ( ( Cassgn _ | Copn _ | Csyscall _ | Cassert _ | Cif _ | Cfor _ | Cwhile _ | Ccall _ ), _ ) -> @@ -192,9 +214,9 @@ let eq_pfunc x y = eq_f_annot x.f_annot y.f_annot && x.f_cc = y.f_cc && String.equal x.f_name.fn_name y.f_name.fn_name - && List.for_all2 eq_pty x.f_tyin y.f_tyin + && List.for_all2 eq_ty x.f_tyin y.f_tyin && List.for_all2 eq_pvar x.f_args y.f_args - && List.for_all2 eq_pty x.f_tyout y.f_tyout + && List.for_all2 eq_ty x.f_tyout y.f_tyout && List.for_all2 eq_annotations x.f_ret_info.ret_annot y.f_ret_info.ret_annot && List.for_all2 eq_pvar_i x.f_ret y.f_ret && Option.eq ~eq:eq_contract x.f_contract y.f_contract diff --git a/compiler/tests/safety/run.ml b/compiler/tests/safety/run.ml index f71202f4ec..97e7af3e40 100644 --- a/compiler/tests/safety/run.ml +++ b/compiler/tests/safety/run.ml @@ -41,13 +41,16 @@ let load_file arch_info pointer_data msf_size asmOp name = try let open Pretyping in name - |> tt_file arch_info Env.empty None None + |> tt_file arch_info Compile.syscall_length_ident Env.empty None None |> fst |> Env.decls |> Compile.preprocess pointer_data msf_size asmOp - with Syntax.ParseError (loc, msg) -> + with | Syntax.ParseError (loc, msg) -> Format.eprintf "%a: %s@." Location.pp_loc loc (Option.default "parse error" msg); assert false + | Pretyping.TyError (loc, _msg) -> + Format.eprintf "%a: file %s@." Location.pp_loc loc name; + assert false let load_and_analyze ~fmt expect path arch = let (module P : ArchWithAnalyze) = diff --git a/compiler/tests/safety/success/common/randombytes.jazz b/compiler/tests/safety/success/common/randombytes.jazz index 0b5ed8f5e8..50d2031256 100644 --- a/compiler/tests/safety/success/common/randombytes.jazz +++ b/compiler/tests/safety/success/common/randombytes.jazz @@ -1,7 +1,8 @@ export fn test1() -> reg u32 { stack u32[1] r; reg u32 x; - r = #randombytes(r); + reg u64 len = 4; + r = #randombytes{4}(r, len); x = r[0]; return x; } @@ -9,7 +10,8 @@ export fn test1() -> reg u32 { export fn test2() -> reg u32 { stack u32[2] r; reg u32 x; - r[1:1] = #randombytes(r[1:1]); + reg u64 len = 4; + r[1:1] = #randombytes{4}(r[1:1], len); x = r[1]; return x; } diff --git a/compiler/tests/safety/success/x86-64/trusted-termination.jazz b/compiler/tests/safety/success/x86-64/trusted-termination.jazz index 46c310efa2..bcc73d9b31 100644 --- a/compiler/tests/safety/success/x86-64/trusted-termination.jazz +++ b/compiler/tests/safety/success/x86-64/trusted-termination.jazz @@ -2,10 +2,11 @@ export fn eventually_terminates() -> reg u64 { reg u64 r c; stack u8[1] b; + reg u64 len = 1; ?{}, c = #set0(); #[no_termination_check] while { - b = #randombytes(b); + b = #randombytes{1}(b, len); } (b[0] != 0) { c += 1; } diff --git a/compiler/tests/sct-checker/common.ml b/compiler/tests/sct-checker/common.ml index 596f5409f2..b532c390c1 100644 --- a/compiler/tests/sct-checker/common.ml +++ b/compiler/tests/sct-checker/common.ml @@ -12,7 +12,7 @@ let load_file name = let open Pretyping in match name - |> tt_file Arch.arch_info Env.empty None None + |> tt_file Arch.arch_info Compile.syscall_length_ident Env.empty None None |> fst |> Env.decls |> Compile.preprocess Arch.pointer_data Arch.msf_size Arch.asmOp |> Compile.do_spill_unspill Arch.asmOp diff --git a/compiler/tests/sct-checker/error_messages.jazz b/compiler/tests/sct-checker/error_messages.jazz index 07b3e94cb8..c718b6b17c 100644 --- a/compiler/tests/sct-checker/error_messages.jazz +++ b/compiler/tests/sct-checker/error_messages.jazz @@ -8,7 +8,8 @@ export fn syscall() { stack u8[1] t; reg u64 x; x = #init_msf(); - t = #randombytes(t); + reg u64 len = 1; + t = #randombytes{1}(t, len); x = #protect(x, x); } export fn update_msf_not_trans() { diff --git a/compiler/tests/sct-checker/sct_errors.expected b/compiler/tests/sct-checker/sct_errors.expected index 1ec3b70dc6..2280247d07 100644 --- a/compiler/tests/sct-checker/sct_errors.expected +++ b/compiler/tests/sct-checker/sct_errors.expected @@ -24,7 +24,7 @@ Failed as expected call_bad_nomodmsf3: speculative constant type checker: annota Failed as expected call_modmsf_destroys: speculative constant type checker: this function call destroys MSFs and { msf } are required. Trace: - the function modmsf_destroys destroys MSFs at "error_messages.jazz", line 142 (2) to line 144 (3) + the function modmsf_destroys destroys MSFs at "error_messages.jazz", line 143 (2) to line 145 (3) Failed as expected ret_high: speculative constant type checker: return type for p is #secret it should be less than #public Failed as expected ret_transient: speculative constant type checker: return type for p is #transient it should be less than #public Failed as expected ret_msf: speculative constant type checker: return annotation for msf should be msf diff --git a/compiler/tests/success/arm-m4/bug_870.jazz b/compiler/tests/success/arm-m4/bug_870.jazz new file mode 100644 index 0000000000..865aa36f99 --- /dev/null +++ b/compiler/tests/success/arm-m4/bug_870.jazz @@ -0,0 +1,12 @@ +/* stack zeroization uses the alignment of the function as the default clear + step size. Due to the system call, the function is aligned on u128, but stack + zeroization is not implemented for u128 on ARM. Thus we introduce this + annotation to use u32 for the clear step size instead. +*/ +#[stackzerosize=u32] +export +fn rand(reg ptr u8[32] io) -> reg ptr u8[32] { + reg u32 len = 32; + io = #randombytes{32}(io, len); + return io; +} diff --git a/compiler/tests/success/arm-m4/rand.jazz b/compiler/tests/success/arm-m4/rand.jazz index b2c5744788..650deeb6a6 100644 --- a/compiler/tests/success/arm-m4/rand.jazz +++ b/compiler/tests/success/arm-m4/rand.jazz @@ -9,7 +9,8 @@ fn random32() -> reg u32 { stack u8[4] s; reg ptr u8[4] p; p = s; - s = #randombytes(p); + reg u32 len = 4; + s = #randombytes{4}(p, len); reg u32 r x; inline int i; r = (32u)s[0]; diff --git a/compiler/tests/success/arm-m4/variable_initialization.jazz b/compiler/tests/success/arm-m4/variable_initialization.jazz new file mode 100644 index 0000000000..27ab2644e1 --- /dev/null +++ b/compiler/tests/success/arm-m4/variable_initialization.jazz @@ -0,0 +1,22 @@ +fn test_randombytes () { + stack u8[1] r; + reg u32 len = 1; + reg ptr u8[1] q = #randombytes{1}(r, len); +} + +/* stack zeroization uses the alignment of the function as the default clear + step size. Due to the system call, the function is aligned on u128, but stack + zeroization is not implemented for u128 on ARM. Thus we introduce this + annotation to use u32 for the clear step size instead. +*/ +#[stackzerosize=u32] +#[stacksize = 4] +export fn rand() -> reg u32 { + stack u8[4] _x x; + reg u32 len = 4; + x = #randombytes{4}(_x, len); + reg u32 r; + r = x[:u32 0]; + return r; +} + diff --git a/compiler/tests/success/common/variable_initialization.jazz b/compiler/tests/success/common/variable_initialization.jazz index 485a17b839..769a3a52da 100644 --- a/compiler/tests/success/common/variable_initialization.jazz +++ b/compiler/tests/success/common/variable_initialization.jazz @@ -25,11 +25,6 @@ fn test_primitive(){ stack u32[1] b = #copy_32(a[0:1]); } -fn test_randombytes () { - stack u8[1] r; - reg ptr u8[1] q = #randombytes(r); -} - fn test_calls () { reg u32 x= test_basic(); } @@ -38,12 +33,3 @@ export fn sequence() -> reg u32 { reg u32 x = 1, y = x + 1; return y; } - -#[stacksize = 4] -export fn rand() -> reg u32 { - stack u8[4] _x x; - x = #randombytes(_x); - reg u32 r; - r = x[:u32 0]; - return r; -} diff --git a/compiler/tests/success/risc-v/bug_870.jazz b/compiler/tests/success/risc-v/bug_870.jazz new file mode 100644 index 0000000000..04f094337c --- /dev/null +++ b/compiler/tests/success/risc-v/bug_870.jazz @@ -0,0 +1,12 @@ +/* stack zeroization uses the alignment of the function as the default clear + step size. Due to the system call, the function is aligned on u128, but stack + zeroization is not implemented for u128 on RISC-V. Thus we introduce this + annotation to use u32 for the clear step size instead. +*/ +#[stackzerosize=u32] +export +fn rand(reg ptr u8[32] io) -> reg ptr u8[32] { + reg u32 len = 32; + io = #randombytes{32}(io, len); + return io; +} diff --git a/compiler/tests/success/risc-v/variable_initialization.jazz b/compiler/tests/success/risc-v/variable_initialization.jazz new file mode 100644 index 0000000000..c79f01a587 --- /dev/null +++ b/compiler/tests/success/risc-v/variable_initialization.jazz @@ -0,0 +1,22 @@ +fn test_randombytes () { + stack u8[1] r; + reg u64 len = 1; + reg ptr u8[1] q = #randombytes{1}(r, len); +} + +/* stack zeroization uses the alignment of the function as the default clear + step size. Due to the system call, the function is aligned on u128, but stack + zeroization is not implemented for u128 on RISC-V. Thus we introduce this + annotation to use u32 for the clear step size instead. +*/ +#[stackzerosize=u32] +#[stacksize = 4] +export fn rand() -> reg u32 { + stack u8[4] _x x; + reg u32 len = 4; + x = #randombytes{4}(_x, len); + reg u32 r; + r = x[:u32 0]; + return r; +} + diff --git a/compiler/tests/success/syscall/x86-64/align.jazz b/compiler/tests/success/syscall/x86-64/align.jazz index 01dd5bdfdd..27f92369e7 100644 --- a/compiler/tests/success/syscall/x86-64/align.jazz +++ b/compiler/tests/success/syscall/x86-64/align.jazz @@ -3,7 +3,8 @@ export fn randombyte() -> reg u8 { stack u8[1] buf; reg u8 r; - buf = #randombytes(buf); + reg u64 len = 1; + buf = #randombytes{1}(buf, len); r = buf[0]; return r; } diff --git a/compiler/tests/success/syscall/x86-64/nrcase01.jazz b/compiler/tests/success/syscall/x86-64/nrcase01.jazz index 53f13e100a..f7d93477b0 100644 --- a/compiler/tests/success/syscall/x86-64/nrcase01.jazz +++ b/compiler/tests/success/syscall/x86-64/nrcase01.jazz @@ -8,7 +8,8 @@ export fn test2(reg u64 skp) skp = skp; - rb = #randombytes(rb); + reg u64 len = KYBER_SYMBYTES; + rb = #randombytes{KYBER_SYMBYTES}(rb, len); for i=0 to KYBER_SYMBYTES/8 { diff --git a/compiler/tests/success/syscall/x86-64/test_randombytes.jazz b/compiler/tests/success/syscall/x86-64/test_randombytes.jazz index 9f65b05b90..0120f8846a 100644 --- a/compiler/tests/success/syscall/x86-64/test_randombytes.jazz +++ b/compiler/tests/success/syscall/x86-64/test_randombytes.jazz @@ -3,7 +3,8 @@ export fn foo1() -> reg u64 { stack u64[1] r; reg ptr u64[1] p; p = r; - p = #randombytes(p); + reg u64 len = 8; + p = #randombytes{8}(p, len); r = p; res = r[0]; return res; @@ -14,7 +15,8 @@ export fn foo2() -> reg u64 { stack u8[8] r; reg ptr u8[8] p; p = r; - p = #randombytes(p); + reg u64 len = 8; + p = #randombytes{8}(p, len); res = p[:u64 0]; return res; } @@ -22,7 +24,8 @@ export fn foo2() -> reg u64 { export fn foo3() -> reg u8 { reg u8 res; stack u8[12] r; - r = #randombytes(r); + reg u64 len = 12; + r = #randombytes{12}(r, len); res = r[0]; return res; } @@ -30,7 +33,8 @@ export fn foo3() -> reg u8 { export fn foo4() -> reg u64 { reg u64 res; stack u64[2] r; - r[0:1] = #randombytes(r[0:1]); + reg u64 len = 8; + r[0:1] = #randombytes{8}(r[0:1], len); res = r[0]; return res; } diff --git a/compiler/tests/success/common/bug_870.jazz b/compiler/tests/success/x86-64/bug_870.jazz similarity index 56% rename from compiler/tests/success/common/bug_870.jazz rename to compiler/tests/success/x86-64/bug_870.jazz index 001dc4c88d..5066f7d46b 100644 --- a/compiler/tests/success/common/bug_870.jazz +++ b/compiler/tests/success/x86-64/bug_870.jazz @@ -1,5 +1,6 @@ export fn rand(reg ptr u8[32] io) -> reg ptr u8[32] { - io = #randombytes(io); + reg u64 len = 32; + io = #randombytes{32}(io, len); return io; } diff --git a/compiler/tests/success/x86-64/variable_initialization.jazz b/compiler/tests/success/x86-64/variable_initialization.jazz new file mode 100644 index 0000000000..b704f726a3 --- /dev/null +++ b/compiler/tests/success/x86-64/variable_initialization.jazz @@ -0,0 +1,16 @@ +fn test_randombytes () { + stack u8[1] r; + reg u64 len = 1; + reg ptr u8[1] q = #randombytes{1}(r, len); +} + +#[stacksize = 4] +export fn rand() -> reg u32 { + stack u8[4] _x x; + reg u64 len = 4; + x = #randombytes{4}(_x, len); + reg u32 r; + r = x[:u32 0]; + return r; +} + diff --git a/compiler/tests/template/fail/invalid_number_args.jazz b/compiler/tests/template/fail/invalid_number_args.jazz new file mode 100644 index 0000000000..2774873fa7 --- /dev/null +++ b/compiler/tests/template/fail/invalid_number_args.jazz @@ -0,0 +1,18 @@ +fn f{k}(reg ptr u64[k] r, reg ptr u64[k] r2) -> reg u64 { + reg u64 res = r[0]; + return res; +} + +param int N = 5; + +export fn main () -> reg u64 { + stack u64[N] s; + inline int i; + for i = 0 to N { + s[i] = i; + } + reg u64 res = f(s); // not the right number of args, + // but still the length arg of f is inferred; + // it fails with the expected "not the right number of args" + return res; +} diff --git a/compiler/tests/template/fail/invalid_number_length_args.jazz b/compiler/tests/template/fail/invalid_number_length_args.jazz new file mode 100644 index 0000000000..28f4d04e7c --- /dev/null +++ b/compiler/tests/template/fail/invalid_number_length_args.jazz @@ -0,0 +1,17 @@ +fn f{k}(reg ptr u64[k] r) -> reg u64 { + reg u64 res = r[0]; + return res; +} + +param int N = 5; + +export fn main () -> reg u64 { + stack u64[N] s; + inline int i; + for i = 0 to N { + s[i] = i; + } + reg u64 res = f{1,2}(s); // 2 length arguments instead of 1 + + return res; +} diff --git a/compiler/tests/template/fail/length_inference_failed.jazz b/compiler/tests/template/fail/length_inference_failed.jazz new file mode 100644 index 0000000000..4cc68fe171 --- /dev/null +++ b/compiler/tests/template/fail/length_inference_failed.jazz @@ -0,0 +1,16 @@ +fn f{k}(reg ptr u32[k] r) -> reg u64 { + reg u64 res = r[:u64 0]; + return res; +} + +param int N = 5; + +export fn main () -> reg u64 { + stack u64[N] s; + inline int i; + for i = 0 to N { + s[i] = i; + } + reg u64 res = f(s); // the length arg of f cannot be inferred because u32 <> u64 + return res; +} diff --git a/compiler/tests/template/fail/length_inference_failed2.jazz b/compiler/tests/template/fail/length_inference_failed2.jazz new file mode 100644 index 0000000000..7bfa7270be --- /dev/null +++ b/compiler/tests/template/fail/length_inference_failed2.jazz @@ -0,0 +1,16 @@ +fn f{k,l}(reg ptr u64[k] r) -> reg u64 { + reg u64 res = r[0]; + return res; +} + +param int N = 5; + +export fn main () -> reg u64 { + stack u64[N] s; + inline int i; + for i = 0 to N { + s[i] = i; + } + reg u64 res = f(s); // the length args of f cannot be inferred, no info on [l] + return res; +} diff --git a/compiler/tests/template/fail/length_inference_failed3.jazz b/compiler/tests/template/fail/length_inference_failed3.jazz new file mode 100644 index 0000000000..c987165c39 --- /dev/null +++ b/compiler/tests/template/fail/length_inference_failed3.jazz @@ -0,0 +1,18 @@ +fn f{k}(reg ptr u64[k] r) -> reg u64 { + reg u64 res = r[0]; + return res; +} + +param int N = 5; + +export fn main () -> reg u64 { + stack u64[N] s; + inline int i; + for i = 0 to N { + s[i] = i; + } + reg u64 res = f(); // the length args of f cannot be inferred, + // but the fact that we do not have the right number of arguments + // seems more important, should we change the error? + return res; +} diff --git a/compiler/tests/template/fail/length_var_not_allowed.jazz b/compiler/tests/template/fail/length_var_not_allowed.jazz new file mode 100644 index 0000000000..f31efeef4d --- /dev/null +++ b/compiler/tests/template/fail/length_var_not_allowed.jazz @@ -0,0 +1,7 @@ +// n does not really exist as a value, should it fail? +// what if the function is inline? + +export fn main{n} () -> reg u64 { + reg u64 res = n; + return res; +} diff --git a/compiler/tests/template/fail/random_invalid_number_length_args.jazz b/compiler/tests/template/fail/random_invalid_number_length_args.jazz new file mode 100644 index 0000000000..a5b4528702 --- /dev/null +++ b/compiler/tests/template/fail/random_invalid_number_length_args.jazz @@ -0,0 +1,7 @@ +export fn main () -> reg u8 { + stack u8[1] s; + reg u64 len = 1; + s = #randombytes{1,2}(s, len); // 2 length arguments instead of 1 + reg u8 res = s[0]; + return res; +} diff --git a/compiler/tests/template/fail/random_wrong_length.jazz b/compiler/tests/template/fail/random_wrong_length.jazz new file mode 100644 index 0000000000..f7d1f24dde --- /dev/null +++ b/compiler/tests/template/fail/random_wrong_length.jazz @@ -0,0 +1,7 @@ +export fn main () -> reg u8 { + stack u8[1] s; + reg u64 len = 1; + s = #randombytes{2}(s, len); // s is of length 1, not 2 + reg u8 res = s[0]; + return res; +} diff --git a/compiler/tests/template/fail/reg_array.jazz b/compiler/tests/template/fail/reg_array.jazz new file mode 100644 index 0000000000..07175daa1c --- /dev/null +++ b/compiler/tests/template/fail/reg_array.jazz @@ -0,0 +1,5 @@ +export fn main{p} () -> reg u64 { + reg u64[p] r; + reg u64 res = r[0]; + return res; +} diff --git a/compiler/tests/template/fail/stack_unknown_size.jazz b/compiler/tests/template/fail/stack_unknown_size.jazz new file mode 100644 index 0000000000..33c4465001 --- /dev/null +++ b/compiler/tests/template/fail/stack_unknown_size.jazz @@ -0,0 +1,6 @@ +export fn main{n} () -> reg u64 { + stack u64[n] s; // stack variable of unknown size -> failure + s[0] = 0; + reg u64 res = s[0]; + return res; +} diff --git a/compiler/tests/template/fail/wrong_length.jazz b/compiler/tests/template/fail/wrong_length.jazz new file mode 100644 index 0000000000..9631780fa6 --- /dev/null +++ b/compiler/tests/template/fail/wrong_length.jazz @@ -0,0 +1,16 @@ +fn f{k}(reg ptr u64[k] r) -> reg u64 { + reg u64 res = r[0]; + return res; +} + +param int N = 5; + +export fn main () -> reg u64 { + stack u64[N] s; + inline int i; + for i = 0 to N { + s[i] = i; + } + reg u64 res = f{2}(s); // s is of length N = 5, not 2 + return res; +} diff --git a/compiler/tests/template/success/add.jazz b/compiler/tests/template/success/add.jazz new file mode 100644 index 0000000000..b9f3f7644b --- /dev/null +++ b/compiler/tests/template/success/add.jazz @@ -0,0 +1,4 @@ +export fn main{n, m}(reg ptr u64[n+m] sres) -> reg u64 { + reg u64 res = sres[0]; + return res; +} diff --git a/compiler/tests/template/success/add_0.jazz b/compiler/tests/template/success/add_0.jazz new file mode 100644 index 0000000000..b2527d19ff --- /dev/null +++ b/compiler/tests/template/success/add_0.jazz @@ -0,0 +1,12 @@ +// fails at conversion OCaml -> Rocq due to 0 not a positive + +fn f{p}(reg ptr u64[p] r) -> reg u64 { + reg u64 res = r [0]; + return res; +} + +export fn main{p} (reg ptr u64[p+0] r) -> reg u64 { + reg u64 res = f{p}(r); + return res; +} + diff --git a/compiler/tests/template/success/already_declared.jazz b/compiler/tests/template/success/already_declared.jazz new file mode 100644 index 0000000000..31c01c910a --- /dev/null +++ b/compiler/tests/template/success/already_declared.jazz @@ -0,0 +1,12 @@ +param int n = 3; + +export fn main{n}(reg ptr u64[n] x) -> reg ptr u64[n] { + return x; +} + +/* +export fn main(reg ptr u64[n] x) -> reg ptr u64[n] { + reg u64 n = 2; + x[0] = 1; + return x; +}*/ diff --git a/compiler/tests/template/success/convertible.jazz b/compiler/tests/template/success/convertible.jazz new file mode 100644 index 0000000000..b09e8275c2 --- /dev/null +++ b/compiler/tests/template/success/convertible.jazz @@ -0,0 +1,11 @@ +// this tests the power of the convertible function + +fn f{n}(reg ptr u64[n] r) -> reg u64 { + reg u64 res = r[0]; + return res; +} + +export fn main{M,K,L} (reg ptr u64[M+K*L] r) -> reg u64 { + reg u64 res = f{L*K+M}(r); + return res; +} diff --git a/compiler/tests/template/success/function_call.jazz b/compiler/tests/template/success/function_call.jazz new file mode 100644 index 0000000000..7c36a30128 --- /dev/null +++ b/compiler/tests/template/success/function_call.jazz @@ -0,0 +1,9 @@ +fn f{p}(reg ptr u64[p] r) -> reg u64 { + reg u64 res = r [0]; + return res; +} + +export fn main{p,q} (reg ptr u64[p+q] r) -> reg u64 { + reg u64 res = f{p+q}(r); + return res; +} diff --git a/compiler/tests/template/success/inlining.jazz b/compiler/tests/template/success/inlining.jazz new file mode 100644 index 0000000000..fcf957c661 --- /dev/null +++ b/compiler/tests/template/success/inlining.jazz @@ -0,0 +1,22 @@ +// we test template function + inlining +inline fn f{n}(reg ptr u64[n] r) -> reg u64 { + reg u64 res = r[0]; + return res; +} + +export fn main{M,Q} (reg ptr u64[M+Q] r) -> reg u64 { + reg u64 res = f{M+Q}(r); + return res; +} + +/* +inline fn f{n}(reg ptr u64[n] r) -> reg ptr u64[n] { + r[0] = 1; + return r; +} + +export fn main{M,Q} (reg ptr u64[M+Q] r) -> reg ptr u64[M+Q] { + r = f{M+Q}(r); + return r; +} +*/ diff --git a/compiler/tests/template/success/inlining2.jazz b/compiler/tests/template/success/inlining2.jazz new file mode 100644 index 0000000000..3318fb85fe --- /dev/null +++ b/compiler/tests/template/success/inlining2.jazz @@ -0,0 +1,18 @@ +// we test template function + inlining + +fn g{m}(reg ptr u64[m] r, reg u64 x) -> reg ptr u64[m] { + r[0] = x; + return r; +} + +inline fn f{n,m}(reg mut ptr u64[n] r, reg ptr u64[m] r2) -> reg ptr u64[m] { + reg u64 res = r[0]; + r2 = g{m}(r2, res); + return r2; +} + +export fn main{M,Q} (reg ptr u64[M+Q] r) -> reg ptr u64[M+Q], reg u64 { + r = f{M+Q,Q+M}(r, r); + reg u64 res = r[0]; + return r, res; +} diff --git a/compiler/tests/template/success/instantiate_constant.jazz b/compiler/tests/template/success/instantiate_constant.jazz new file mode 100644 index 0000000000..a19095c3cd --- /dev/null +++ b/compiler/tests/template/success/instantiate_constant.jazz @@ -0,0 +1,15 @@ +// we test template function instantiated on a constant +// other tests to try: make ref arg + inlining + +fn f{n}(reg ptr u64[n] r) -> reg u64 { + reg u64 res = r[0]; + return res; +} + +export fn main () -> reg u64 { + stack u64[4] s; + s[0] = 0; + reg ptr u64[4] r = s; + reg u64 res = f{4}(r); + return res; +} diff --git a/compiler/tests/template/success/instantiate_var.jazz b/compiler/tests/template/success/instantiate_var.jazz new file mode 100644 index 0000000000..7acae5ee9e --- /dev/null +++ b/compiler/tests/template/success/instantiate_var.jazz @@ -0,0 +1,11 @@ +// we test template function instantiated on a variable + +fn f{n}(reg ptr u64[n] r) -> reg u64 { + reg u64 res = r[0]; + return res; +} + +export fn main{M,Q} (reg ptr u64[M+Q] r) -> reg u64 { + reg u64 res = f{M+Q}(r); + return res; +} diff --git a/compiler/tests/template/success/length_inference.jazz b/compiler/tests/template/success/length_inference.jazz new file mode 100644 index 0000000000..7507b923ce --- /dev/null +++ b/compiler/tests/template/success/length_inference.jazz @@ -0,0 +1,16 @@ +fn f{k}(reg ptr u64[k] r) -> reg u64 { + reg u64 res = r[0]; + return res; +} + +param int N = 5; + +export fn main () -> reg u64 { + stack u64[N] s; + inline int i; + for i = 0 to N { + s[i] = i; + } + reg u64 res = f(s); // the length arg of f is inferred + return res; +} diff --git a/compiler/tests/template/success/length_inference_manual.jazz b/compiler/tests/template/success/length_inference_manual.jazz new file mode 100644 index 0000000000..9d8f408bfd --- /dev/null +++ b/compiler/tests/template/success/length_inference_manual.jazz @@ -0,0 +1,17 @@ +fn f{k}(reg ptr u32[k] r) -> reg u64 { + reg u64 res = r[:u64 0]; + return res; +} + +param int N = 5; + +export fn main () -> reg u64 { + stack u64[N] s; + inline int i; + for i = 0 to N { + s[i] = i; + } + reg u64 res = f{2*N}(s); // the length arg of f cannot be inferred (because u32 <> u64) + // but we can specify it manually + return res; +} diff --git a/compiler/tests/template/success/make_ref_constant.jazz b/compiler/tests/template/success/make_ref_constant.jazz new file mode 100644 index 0000000000..9afa1e8929 --- /dev/null +++ b/compiler/tests/template/success/make_ref_constant.jazz @@ -0,0 +1,13 @@ +// we test make ref arg instantiated on a constant + +fn f{n}(reg ptr u64[n] r) -> reg u64 { + reg u64 res = r[0]; + return res; +} + +export fn main () -> reg u64 { + stack u64[4] s; + s[0] = 0; + reg u64 res = f{4}(s); + return res; +} diff --git a/compiler/tests/template/success/make_ref_var.jazz b/compiler/tests/template/success/make_ref_var.jazz new file mode 100644 index 0000000000..744ff60f16 --- /dev/null +++ b/compiler/tests/template/success/make_ref_var.jazz @@ -0,0 +1,11 @@ +// we test make ref arg instantiated on a variable + +fn f{n}(reg ptr u64[n] r) -> reg u64 { + reg u64 res = r[0]; + return res; +} + +export fn main{p,q} (reg ptr u64[p+q] r) -> reg u64 { + reg u64 res = f{p+q}(r); + return res; +} diff --git a/compiler/tests/template/success/random.jazz b/compiler/tests/template/success/random.jazz new file mode 100644 index 0000000000..dd7d1ed1c1 --- /dev/null +++ b/compiler/tests/template/success/random.jazz @@ -0,0 +1,7 @@ +export fn main () -> reg u8 { + stack u8[1] s; + reg u64 len = 1; + s = #randombytes{1}(s, len); + reg u8 res = s[0]; + return res; +} diff --git a/compiler/tests/template/success/random_length_inference.jazz b/compiler/tests/template/success/random_length_inference.jazz new file mode 100644 index 0000000000..0a6c06995f --- /dev/null +++ b/compiler/tests/template/success/random_length_inference.jazz @@ -0,0 +1,7 @@ +export fn main () -> reg u8 { + stack u8[1] s; + reg u64 len = 1; + s = #randombytes(s, len); // the length arg is inferred + reg u8 res = s[0]; + return res; +} diff --git a/compiler/tests/template/success/random_var.jazz b/compiler/tests/template/success/random_var.jazz new file mode 100644 index 0000000000..fe72d7097d --- /dev/null +++ b/compiler/tests/template/success/random_var.jazz @@ -0,0 +1,6 @@ +export fn main{N} (reg ptr u64[N] r, reg u64 n) -> reg ptr u64[N], reg u64 { + reg u64 len = 8 * n; + r = #randombytes{8*N}(r, len); + reg u64 res = r[0]; + return r, res; +} diff --git a/compiler/tests/template/success/sum_10_20.jazz b/compiler/tests/template/success/sum_10_20.jazz new file mode 100644 index 0000000000..1e44477052 --- /dev/null +++ b/compiler/tests/template/success/sum_10_20.jazz @@ -0,0 +1,34 @@ +fn sum10 (reg ptr u64[10] r) -> reg u64 { + reg u64 res = 0; + reg u64 i = 0; + while (i < 10) { + res += r[i]; + i += 1; + } + return res; +} + +fn sum20 (reg ptr u64[20] r) -> reg u64 { + reg u64 res = 0; + reg u64 i = 0; + while (i < 20) { + res += r[i]; + } + return res; +} + +export fn main () -> reg u64 { + stack u64[20] s; + inline int i; + for i = 0 to 20 { + s[i] = i; + } + + reg u64 res10 = sum10 (s[0:10]); + + reg u64 res20 = sum20 (s); + + reg u64 res = res10 + res20; + + return res; +} diff --git a/compiler/tests/template/success/sum_10_20_namespace.jazz b/compiler/tests/template/success/sum_10_20_namespace.jazz new file mode 100644 index 0000000000..c2d2bbd62a --- /dev/null +++ b/compiler/tests/template/success/sum_10_20_namespace.jazz @@ -0,0 +1,26 @@ +namespace sum10 { + param int N = 10; + require "sum_10_20_namespace.jinc" +} + +namespace sum20 { + param int N = 20; + require "sum_10_20_namespace.jinc" +} + +export fn main () -> reg u64 { + stack u64[20] s; + inline int i; + for i = 0 to 20 { + s[i] = i; + } + + reg u64 res10 = sum10::sumN (s[0:10]); + + reg u64 res20 = sum20::sumN (s); + + reg u64 res = res10 + res20; + + return res; +} + diff --git a/compiler/tests/template/success/sum_10_20_namespace.jinc b/compiler/tests/template/success/sum_10_20_namespace.jinc new file mode 100644 index 0000000000..46afc40813 --- /dev/null +++ b/compiler/tests/template/success/sum_10_20_namespace.jinc @@ -0,0 +1,9 @@ +fn sumN (reg ptr u64[N] r) -> reg u64 { + reg u64 res = 0; + reg u64 i = 0; + while (i < N) { + res += r[i]; + i += 1; + } + return res; +} diff --git a/compiler/tests/template/success/sum_10_20_template.jazz b/compiler/tests/template/success/sum_10_20_template.jazz new file mode 100644 index 0000000000..3330ea31d2 --- /dev/null +++ b/compiler/tests/template/success/sum_10_20_template.jazz @@ -0,0 +1,28 @@ +fn sum{N} (reg ptr u64[N] r, reg u64 n) -> reg u64 { + reg u64 res = 0; + reg u64 i = 0; + while (i < n) { + res += r[i]; + i += 1; + } + return res; +} + +export fn main () -> reg u64 { + stack u64[20] s; + inline int i; + for i = 0 to 20 { + s[i] = i; + } + + reg u64 len10 = 10; + reg u64 res10 = sum{10} (s[0:10], len10); + reg u64 res = res10; + + reg u64 len20 = 20; + reg u64 res20 = sum{20} (s, len20); + + res += res20; + + return res; +} diff --git a/proofs/arch/arch_decl.v b/proofs/arch/arch_decl.v index 5713209b05..faf4797ca0 100644 --- a/proofs/arch/arch_decl.v +++ b/proofs/arch/arch_decl.v @@ -408,7 +408,7 @@ Record instr_desc_t := { id_eq_size : (size id_in == size id_tin) && (size id_out == size id_tout); id_str_jas : unit -> string; id_check_dest : all2 check_arg_dest id_out id_tout; - id_safe : seq safe_cond; + id_safe : seq (safe_cond Z); id_pp_asm : asm_args -> pp_asm_op; (* Extra properties ensuring that previous information are consistent *) id_safe_wf : all (fun sc => values.sc_needed_args sc <= size id_tin) id_safe; diff --git a/proofs/arch/arch_extra.v b/proofs/arch/arch_extra.v index 00001b9939..22affc7f35 100644 --- a/proofs/arch/arch_extra.v +++ b/proofs/arch/arch_extra.v @@ -298,7 +298,7 @@ Qed. HB.instance Definition _ := hasDecEq.Build extended_op extended_op_eq_axiom. -Lemma atype_of_ltypeP : eval_ltype =1 eval_atype \o atype_of_ltype. +Lemma atype_of_ltypeP env : eval_ltype =1 eval_atype env \o atype_of_ltype. Proof. by case. Qed. (* Sadly, the sumbool decidable equalities generated by elpi.derive are not @@ -317,8 +317,8 @@ Proof. case: ty1; case: ty2; try (right; discriminate). + by left; reflexivity. + by left; reflexivity. - + move=> p1 p2. - case: (Pos.eq_dec p1 p2). + + move=> z1 z2. + case: (Z.eq_dec z1 z2). + by left; congruence. + by right; congruence. move=> ws1 ws2. @@ -342,38 +342,74 @@ Proof. Qed. Definition semi_to_atype {tin tout} (semi: sem_prod (map eval_ltype tin) (exec (sem_tuple (map eval_ltype tout)))) : - sem_prod (map eval_atype (map atype_of_ltype tin)) (exec (sem_tuple (map eval_atype (map atype_of_ltype tout)))) := - let eq l := computational_eq (etrans (eq_map atype_of_ltypeP _) (map_comp eval_atype atype_of_ltype l)) in + forall env, sem_prod (map (eval_atype env) (map atype_of_ltype tin)) (exec (sem_tuple (map (eval_atype env) (map atype_of_ltype tout)))) := + fun env => + let eq l := computational_eq (etrans (eq_map (atype_of_ltypeP env) _) (map_comp (eval_atype env) atype_of_ltype l)) in ecast l (sem_prod l _) (eq tin) (ecast l (sem_prod _ (exec (sem_tuple l))) (eq tout) semi). -Lemma is_not_carr_ltype (tin : seq ltype) : - all is_not_carr (map eval_atype (map atype_of_ltype tin)). +Lemma is_not_carr_ltype (tin : seq ltype) env : + all is_not_carr (map (eval_atype env) (map atype_of_ltype tin)). Proof. elim: tin => [//|ty tys /= ->]. by case: ty. Qed. +Definition safe_cond_to_array_length := map_safe_cond ALConst. + +Lemma sc_needed_args_map_safe_cond {A B} (f : A -> B) s : + sc_needed_args (map_safe_cond f s) = sc_needed_args s. +Proof. by case: s. Qed. + Lemma semi_to_atype_safe_wf tin safe : - all (fun sc : safe_cond => ssrnat.leq (sc_needed_args sc) (size tin)) safe -> - all (fun sc : safe_cond => ssrnat.leq (sc_needed_args sc) (size (map atype_of_ltype tin))) safe. -Proof. by rewrite size_map. Qed. + all (fun sc : safe_cond Z => ssrnat.leq (sc_needed_args sc) (size tin)) safe -> + all (fun sc : safe_cond array_length => ssrnat.leq (sc_needed_args sc) (size (map atype_of_ltype tin))) (map safe_cond_to_array_length safe). +Proof. + rewrite size_map. + elim: safe => [//|s safe ih] /= /andP [hleq /ih{}ih]. + apply /andP; split=> //. + by rewrite sc_needed_args_map_safe_cond. +Qed. -Lemma semi_to_atype_errty tin tout (semi: sem_prod (map eval_ltype tin) (exec (sem_tuple (map eval_ltype tout)))) : +Lemma semi_to_atype_errty tin tout (semi: sem_prod (map eval_ltype tin) (exec (sem_tuple (map eval_ltype tout)))) env : sem_forall (fun r => r <> Error ErrType) (map eval_ltype tin) semi -> - sem_forall (fun r => r <> Error ErrType) (map eval_atype (map atype_of_ltype tin)) (semi_to_atype semi). + sem_forall (fun r => r <> Error ErrType) (map (eval_atype env) (map atype_of_ltype tin)) (semi_to_atype semi env). Proof. rewrite /semi_to_atype. move: (computational_eq _) (computational_eq _) semi => e1 e2. by rewrite -> e1, -> e2. Qed. -Lemma semi_to_atype_safe tin tout (semi: sem_prod (map eval_ltype tin) (exec (sem_tuple (map eval_ltype tout))))safe : +Lemma safe_cond_to_array_lengthP env vs c : + interp_safe_cond vs (eval_safe_cond env (safe_cond_to_array_length c)) -> + interp_safe_cond vs c. +Proof. + case: c => //= ws len n. + rewrite /eval /=. + case: ZltP => // hneg. + by Lia.lia. +Qed. + +Lemma map_safe_cond_to_array_lengthP env vs sc : + ListDef.Forall (interp_safe_cond vs) (map (eval_safe_cond env) (map safe_cond_to_array_length sc)) -> + ListDef.Forall (interp_safe_cond vs) sc. +Proof. + elim: sc => [|c sc ih] //=. + move=> /List_Forall_inv [hsafe /ih{}ih]. + constructor=> //. + by apply: safe_cond_to_array_lengthP hsafe. +Qed. + +Lemma semi_to_atype_safe tin tout (semi: sem_prod (map eval_ltype tin) (exec (sem_tuple (map eval_ltype tout)))) safe env : interp_safe_cond_ty safe semi -> - interp_safe_cond_ty safe (semi_to_atype semi). + interp_safe_cond_ty (map (eval_safe_cond env) (map safe_cond_to_array_length safe)) (semi_to_atype semi env). Proof. rewrite /semi_to_atype. - move: (computational_eq _) (computational_eq _) semi => e1 e2. - by rewrite -> e1, -> e2. + move: (computational_eq _) (computational_eq _) => e1 e2. + rewrite <- e1, <- e2. move=> {e1 e2}. + rewrite /interp_safe_cond_ty. + elim: tin semi (@nil values.value) => //= [ | t ts hrec] semi vs. + + by move=> + /map_safe_cond_to_array_lengthP. + by eauto. Qed. Definition get_instr_desc (o: extended_op) : instruction_desc := @@ -387,12 +423,12 @@ Definition get_instr_desc (o: extended_op) : instruction_desc := ; conflicts:= [::] ; tout := map atype_of_ltype id.(id_tout) ; semi := semi_to_atype id.(id_semi) - ; semu := @vuincl_app_sopn_v _ _ _ (is_not_carr_ltype _) - ; i_safe := id.(id_safe) + ; semu := fun env => @vuincl_app_sopn_v _ _ _ (is_not_carr_ltype _ env) + ; i_safe := map safe_cond_to_array_length id.(id_safe) ; i_valid := id.(id_valid) ; i_safe_wf := semi_to_atype_safe_wf id.(id_safe_wf) - ; i_semi_errty := fun h => semi_to_atype_errty (id.(id_semi_errty) h) - ; i_semi_safe := fun h => semi_to_atype_safe (id.(id_semi_safe) h) + ; i_semi_errty := fun h env => semi_to_atype_errty env (id.(id_semi_errty) h) + ; i_semi_safe := fun h env => semi_to_atype_safe env (id.(id_semi_safe) h) |} | ExtOp o => asm_op_instr o end. diff --git a/proofs/compiler/allocation.v b/proofs/compiler/allocation.v index 70addf8ec9..a5c9dc5457 100644 --- a/proofs/compiler/allocation.v +++ b/proofs/compiler/allocation.v @@ -439,8 +439,8 @@ Fixpoint check_e (e1 e2:pexpr) (m:M.t) : cexec M.t := Let _ := assert (n1 == n2) error_e in ok m | Pbool b1, Pbool b2 => Let _ := assert (b1 == b2) error_e in ok m - | Parr_init ws1 n1, Parr_init ws2 n2 => - Let _ := assert (arr_size ws1 n1 == arr_size ws2 n2) error_e in ok m + | Parr_init ws1 al1, Parr_init ws2 al2 => + Let _ := assert (convertible (aarr ws1 al1) (aarr ws2 al2)) error_e in ok m | Pvar x1, Pvar x2 => check_gv x1 x2 m | Pget al1 aa1 w1 x1 e1, Pget al2 aa2 w2 x2 e2 => Let _ := assert ((al1 == al2) && (aa1 == aa2) && (w1 == w2)) error_e in @@ -576,12 +576,14 @@ Fixpoint check_i (i1 i2:instr_r) r := Let _ := assert (o1 == o2) (alloc_error "operators not equals") in check_es es1 es2 r >>= check_lvals xs1 xs2 - | Csyscall xs1 o1 es1, Csyscall xs2 o2 es2 => + | Csyscall xs1 o1 al1 es1, Csyscall xs2 o2 al2 es2 => Let _ := assert (o1 == o2) (alloc_error "syscall not equals") in + Let _ := assert (al1 == al2) (alloc_error "lengths not equal") in check_es es1 es2 r >>= check_lvals xs1 xs2 - | Ccall x1 f1 arg1, Ccall x2 f2 arg2 => + | Ccall x1 f1 al1 arg1, Ccall x2 f2 al2 arg2 => Let _ := assert (f1 == f2) (alloc_error "functions not equals") in + Let _ := assert (al1 == al2) (alloc_error "lengths not equal") in check_es arg1 arg2 r >>= check_lvals x1 x2 | Cif e1 c11 c12, Cif e2 c21 c22 => diff --git a/proofs/compiler/arm_extra.v b/proofs/compiler/arm_extra.v index 8b4937653c..c41fda7109 100644 --- a/proofs/compiler/arm_extra.v +++ b/proofs/compiler/arm_extra.v @@ -40,7 +40,7 @@ Local Notation E n := (sopn.ADExplicit n sopn.ACR_any). argument. *) Definition Oarm_add_large_imm_instr : instruction_desc := let ty := aword arm_reg_size in - let cty := eval_atype ty in + let cty := cword arm_reg_size in let ctin := [:: cty; cty] in let semi := fun (x y : word arm_reg_size) => (x + y)%w in {| str := (fun _ => "add_large_imm"%string) @@ -49,13 +49,13 @@ Definition Oarm_add_large_imm_instr : instruction_desc := ; tout := [:: ty] ; i_out := [:: E 0] ; conflicts := [:: (APout 0, APin 0)] - ; semi := sem_prod_ok ctin semi - ; semu := @values.vuincl_app_sopn_v ctin [:: cty] (sem_prod_ok ctin semi) refl_equal + ; semi := fun _ => sem_prod_ok ctin semi + ; semu := fun _ => @values.vuincl_app_sopn_v ctin [:: cty] (sem_prod_ok ctin semi) refl_equal ; i_safe := [::] ; i_valid := true ; i_safe_wf := refl_equal - ; i_semi_errty := fun _ => sem_prod_ok_error (tin:=ctin) semi _ - ; i_semi_safe := fun _ => values.sem_prod_ok_safe (tin:=ctin) semi + ; i_semi_errty := fun _ _ => sem_prod_ok_error (tin:=ctin) semi _ + ; i_semi_safe := fun _ _ => values.sem_prod_ok_safe (tin:=ctin) semi |}. Definition smart_li_instr (ws : wsize) : instruction_desc := diff --git a/proofs/compiler/arm_instr_decl.v b/proofs/compiler/arm_instr_decl.v index 6dd6ca76a1..8e1d2621a4 100644 --- a/proofs/compiler/arm_instr_decl.v +++ b/proofs/compiler/arm_instr_decl.v @@ -502,7 +502,7 @@ Proof. rewrite /eq_rect_r /=; apply. Qed. -Lemma safe_wf_cat (tin tin' : seq ltype) sc : +Lemma safe_wf_cat (tin tin' : seq ltype) (sc : seq (safe_cond Z)) : all (fun sc => sc_needed_args sc <= size tin) sc -> all (fun sc => sc_needed_args sc <= size (tin ++ tin')) sc. Proof. apply sub_all => c h; rewrite size_cat; apply: (leq_trans h); apply leq_addr. Qed. @@ -1406,7 +1406,7 @@ Definition arm_BFC_semi (x : wreg) (lsb width : word U8) : exec wreg := in ok (winit reg_size mk). -Definition arm_BFC_semi_sc := [:: ULt U8 1 32%Z; UGe U8 1%Z 2; UaddLe U8 2 1 32%Z]. +Definition arm_BFC_semi_sc : seq (safe_cond Z) := [:: ULt U8 1 32%Z; UGe U8 1%Z 2; UaddLe U8 2 1 32%Z]. Lemma arm_BFC_semi_errty : sem_lforall (fun r : result error (sem_ltuple [:: lreg ]) => r <> Error ErrType) @@ -1462,7 +1462,7 @@ Definition arm_BFI_semi (x y : wreg) (lsb width : word U8) : exec wreg := in ok (winit reg_size mk). -Definition arm_BFI_semi_sc := [:: ULt U8 2 32%Z; UGe U8 1%Z 3; UaddLe U8 3 2 32%Z]. +Definition arm_BFI_semi_sc : seq (safe_cond Z) := [:: ULt U8 2 32%Z; UGe U8 1%Z 3; UaddLe U8 3 2 32%Z]. Lemma arm_BFI_semi_errty : sem_lforall (fun r : result error (sem_ltuple [:: lreg ]) => r <> Error ErrType) @@ -1948,7 +1948,7 @@ Definition bit_field_extract_semi Let _ := assert [&& 1 <=? width & width r <> Error ErrType) diff --git a/proofs/compiler/array_copy.v b/proofs/compiler/array_copy.v index 550c5da357..406794527e 100644 --- a/proofs/compiler/array_copy.v +++ b/proofs/compiler/array_copy.v @@ -16,7 +16,17 @@ all y[i] is init (ok u) Module Import E. Definition pass : string := "array copy". - Definition error := pp_internal_error_s pass "fresh variables are not fresh ...". + Definition fresh_error := pp_internal_error_s pass "fresh variables are not fresh ...". + + Definition error ii msg := {| + pel_msg := pp_box [:: compiler_util.pp_s msg]; + pel_fn := None; + pel_fi := None; + pel_ii := Some ii; + pel_vi := None; + pel_pass := Some pass; + pel_internal := false + |}. End E. @@ -58,7 +68,7 @@ Definition indirect_copy ws x y i := Definition needs_temporary x y : bool := is_var_in_memory x && is_var_in_memory y. -Definition array_copy ii (x: var_i) (ws: wsize) (n: positive) (y: gvar) := +Definition array_copy ii (x: var_i) (ws: wsize) (n: Z) (y: gvar) := let i_name := fresh_counter fi in let i := {| v_var := {| vtype := aint ; vname := i_name |}; v_info := v_info x |} in let ei := Pvar (mk_lvar i) in @@ -66,7 +76,7 @@ Definition array_copy ii (x: var_i) (ws: wsize) (n: positive) (y: gvar) := if eq_gvar (mk_lvar x) y || is_ptr x then Copn [::] AT_none sopn_nop [::] - else Cassgn (Lvar x) AT_none (aarr ws n) (Parr_init ws n) in + else Cassgn (Lvar x) AT_none (aarr ws (ALConst n)) (Parr_init ws (ALConst n)) in [:: MkI ii pre; MkI ii (Cfor i (UpTo, Pconst 0, Pconst n) @@ -115,22 +125,29 @@ Definition get_target V ii (xs: lvals) : cexec (var_i * cmd) := end else Error (pp_internal_error_s_at E.pass ii "copy should have a single destination"). +Definition get_const ii al := + match al with + | ALConst n => ok n + | _ => Error (E.error ii "the array length is not a constant") + end. + 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) => + | Some (ws, al) => Let: (y, pre) := get_source V ii es in Let: (x, post) := get_target V ii xs in - Let _ := assert (convertible (vtype x) (aarr ws n)) - (pp_internal_error_s_at E.pass ii "bad type for copy") in - ok (pre ++ array_copy ii x ws n y ++ post) + Let _ := assert (convertible (vtype x) (aarr ws al)) + (pp_internal_error_s_at E.pass ii "bad type for copy") in + Let n := get_const ii al in + ok (pre ++ array_copy ii x ws n y ++ post) | _ => ok [:: i] end - | Csyscall _ _ _ | Cassert _ => ok [:: i] + | Csyscall _ _ _ _ | Cassert _ => ok [:: i] | Cif e c1 c2 => Let c1 := array_copy_c V array_copy_i c1 in Let c2 := array_copy_c V array_copy_i c2 in @@ -142,7 +159,7 @@ Fixpoint array_copy_i V (i:instr) : cexec cmd := 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 info c2)] - | Ccall _ _ _ => ok [:: i] + | Ccall _ _ _ _ => ok [:: i] end. End FUNCTION. @@ -153,7 +170,7 @@ Definition array_copy_fd (f:fundef) := let V := vars_fd f in let fi := f.(f_info) in let fresh := Sv.add {| vtype := aint ; vname := fresh_counter fi |} (sv_of_list (tmp_var fi) wsizes) in - Let _ := assert (disjoint fresh V) E.error in + Let _ := assert (disjoint fresh V) E.fresh_error in Let c := array_copy_c V (array_copy_i fi) f.(f_body) in ok (with_body f c). diff --git a/proofs/compiler/array_expansion.v b/proofs/compiler/array_expansion.v index 63ee5253da..d6a47258c4 100644 --- a/proofs/compiler/array_expansion.v +++ b/proofs/compiler/array_expansion.v @@ -95,7 +95,7 @@ Definition init_array_info (x : varr_info) (svm:Sv.t * Mvar.t array_info) := let vars := map (fun id => {| vtype := ty; vname := id |}) x.(vi_n) in Let svelems := foldM init_elems (sv,0%Z) vars in let '(sv, len) := svelems in - Let _ := assert [&& (0 + | Csyscall xs o al es => Let xs := add_iinfo ii (expand_lvs m xs) in Let es := add_iinfo ii (expand_es m es) in - ok (MkI ii (Csyscall xs o es)) + ok (MkI ii (Csyscall xs o al es)) | Cassert a => Error (pp_safety_remains_at E.pass ii) @@ -299,11 +299,11 @@ Fixpoint expand_i (m : t) (i : instr) : cexec instr := Let c' := mapM (expand_i m) c' in ok (MkI ii (Cwhile a c e info c')) - | Ccall xs fn es => + | Ccall xs fn al es => if Mf.get fsigs fn is Some (expdin, expdout) then Let xs := add_iinfo ii (rmap flatten (mapM2 length_mismatch (expand_return m) expdout xs)) in Let es := add_iinfo ii (rmap flatten (mapM2 length_mismatch (expand_param m) expdin es)) in - ok (MkI ii (Ccall xs fn es)) + ok (MkI ii (Ccall xs fn al es)) else Error (reg_ierror_no_var "function not found") end. @@ -322,7 +322,7 @@ Definition expand_tyv m b s ty v := Definition expand_fsig fi (entries : seq funname) (fname: funname) (fd: ufundef) := Let x := init_map (fi fname fd) in match fd with - | MkFun _ ci tyin params c tyout res ef => + | MkFun _ ci al tyin params c tyout res ef => let '(m, fi) := x in let exp := ~~(fname \in entries) in Let ins := mapM2 length_mismatch (expand_tyv m exp "the parameters") tyin params in @@ -333,16 +333,16 @@ Definition expand_fsig fi (entries : seq funname) (fname: funname) (fd: ufundef) let tyout := map (fun x => fst (fst x)) outs in let res := map (fun x => snd (fst x)) outs in let outs := map snd outs in - ok (MkFun fi ci (flatten tyin) (flatten params) c (flatten tyout) (flatten res) ef, + ok (MkFun fi ci al (flatten tyin) (flatten params) c (flatten tyout) (flatten res) ef, m, (ins, outs)) end. Definition expand_fbody (fname: funname) (fs: ufundef * t) := let (fd, m) := fs in match fd with - | MkFun fi ci tyin params c tyout res ef => + | MkFun fi ci al tyin params c tyout res ef => Let c := mapM (expand_i m) c in - ok (MkFun fi ci tyin params c tyout res ef) + ok (MkFun fi ci al tyin params c tyout res ef) end. End FSIGS. diff --git a/proofs/compiler/array_init.v b/proofs/compiler/array_init.v index af232c40df..44f0f62f0e 100644 --- a/proofs/compiler/array_init.v +++ b/proofs/compiler/array_init.v @@ -31,7 +31,7 @@ Fixpoint remove_init_i i := if t then [::] else [::i] else [::i] | Copn _ _ _ _ - | Csyscall _ _ _ + | Csyscall _ _ _ _ | Cassert _ => [::i] | Cif e c1 c2 => let c1 := foldr (fun i c => remove_init_i i ++ c) [::] c1 in @@ -44,7 +44,7 @@ Fixpoint remove_init_i i := let c := foldr (fun i c => remove_init_i i ++ c) [::] c in let c' := foldr (fun i c => remove_init_i i ++ c) [::] c' in [:: MkI ii (Cwhile a c e info c') ] - | Ccall _ _ _ => [::i] + | Ccall _ _ _ _ => [::i] end end. @@ -79,10 +79,10 @@ End Section. Definition add_init_aux ii x c := match x.(vtype) with - | aarr ws n => + | aarr ws al => if ~~ is_ptr x then let x := VarI x (var_info_of_ii ii) in - MkI ii (Cassgn (Lvar x) AT_none (aarr ws n) (Parr_init ws n)) :: c + MkI ii (Cassgn (Lvar x) AT_none (aarr ws al) (Parr_init ws al)) :: c else c | _ => c end. diff --git a/proofs/compiler/compiler.v b/proofs/compiler/compiler.v index ac7aa3651b..ff8d693071 100644 --- a/proofs/compiler/compiler.v +++ b/proofs/compiler/compiler.v @@ -202,8 +202,14 @@ Record compiler_params dead_vars_sfd : _sfun_decl -> instr_info -> Sv.t; (* Same as dead_vars_ufd, but for _sfun_decl instead of _ufun_decl. *) pp_sr : sub_region -> pp_error; + syscall_length_ident : Ident.ident; }. +Let syscall_length_var {asm_op : Type} + {asmop : asmOp asm_op} + (lowering_options : Type) + (cparams : compiler_params lowering_options) := LV cparams.(syscall_length_ident). + Context {reg regx xreg rflag cond asm_op extra_op : Type} {asm_e : asm_extra reg regx xreg rflag cond asm_op extra_op} @@ -251,7 +257,7 @@ Definition live_range_splitting (p: uprog) : cexec uprog := ok p. Definition inlining (to_keep: seq funname) (p: uprog) : cexec uprog := - Let p := inline_prog_err cparams.(extend_iinfo) p in + Let p := inline_prog_err (fun vk => cparams.(fresh_var_ident) vk dummy_instr_info) cparams.(extend_iinfo) p in let p := cparams.(print_uprog) Inlining p in Let p := dead_calls_err_seq to_keep p in @@ -296,7 +302,7 @@ Definition compiler_first_part (to_keep: seq funname) (p: uprog) : cexec uprog : let pr := remove_init_prog is_reg_array pv in let pr := cparams.(print_uprog) RemoveArrInit pr in - Let pa := makereference_prog (fresh_var_ident cparams (Reg (Normal, Pointer Writable))) pr in + Let pa := makereference_prog (fresh_var_ident cparams (Reg (Normal, Pointer Writable))) (syscall_length_var cparams) pr in let pa := cparams.(print_uprog) MakeRefArguments pa in Let pe := expand_prog cparams.(expand_fd) to_keep pa in diff --git a/proofs/compiler/constant_prop.v b/proofs/compiler/constant_prop.v index 1bd888c149..810c528aa5 100644 --- a/proofs/compiler/constant_prop.v +++ b/proofs/compiler/constant_prop.v @@ -50,10 +50,15 @@ Definition to_expr (t:ctype) : sem_t t -> exec pexpr := | cword sz => fun w => ok (wconst w) end. +(* FIXME: sem_sop1_typed takes an [env] as an argument, but actually does not + use it. We need to provide one here, we provide a dummy one. + Ideally, sem_sop1_typed would not depend on an env. *) +Definition empty_env : length_var -> option Z := fun _ => None. + Definition ssem_sop1 (o: sop1) (e: pexpr) : pexpr := let r := Let x := of_expr _ e in - Let v := sem_sop1_typed o x in + Let v := sem_sop1_typed empty_env o x in to_expr v in match r with | Ok e => e @@ -64,7 +69,7 @@ Definition ssem_sop2 (o: sop2) (e1 e2: pexpr) : pexpr := let r := Let x1 := of_expr _ e1 in Let x2 := of_expr _ e2 in - Let v := sem_sop2_typed o x1 x2 in + Let v := sem_sop2_typed empty_env o x1 x2 in to_expr v in match r with | Ok e => e @@ -288,7 +293,7 @@ Definition app_sopn := app_sopn of_expr. Arguments app_sopn {A} ts _ _. Definition s_opN (op:opN) (es:pexprs) : pexpr := - match op, app_sopn _ (sem_opN_typed op) es with + match op, app_sopn _ (sem_opN_typed empty_env op) es with | Opack ws _, Ok w => Papp1 (Oword_of_int ws) (Pconst (wunsigned w)) | Ocombine_flags _, Ok b => Pbool b | _, _ => PappN op es @@ -493,10 +498,10 @@ Fixpoint const_prop_ir (m:cpm) ii (ir:instr_r) : cpm * cmd := in (m, [:: MkI ii ir ]) - | Csyscall xs o es => + | Csyscall xs o al es => let es := map (const_prop_e without_globals m) es in let (m,xs) := const_prop_rvs without_globals m xs in - (m, [:: MkI ii (Csyscall xs o es) ]) + (m, [:: MkI ii (Csyscall xs o al es) ]) | Cassert a => let b := const_prop_assert m a.2 in @@ -533,10 +538,10 @@ Fixpoint const_prop_ir (m:cpm) ii (ir:instr_r) : cpm * cmd := end in (m', cw) - | Ccall xs f es => + | Ccall xs f al es => let es := map (const_prop_e without_globals m) es in let (m,xs) := const_prop_rvs without_globals m xs in - (m, [:: MkI ii (Ccall xs f es) ]) + (m, [:: MkI ii (Ccall xs f al es) ]) end diff --git a/proofs/compiler/dead_calls.v b/proofs/compiler/dead_calls.v index 8eb8039713..f6c49b7894 100644 --- a/proofs/compiler/dead_calls.v +++ b/proofs/compiler/dead_calls.v @@ -26,11 +26,11 @@ with i_calls_r (c : Sf.t) (i : instr_r) {struct i} : Sf.t := in match i with - | Cassgn _ _ _ _ | Copn _ _ _ _ | Csyscall _ _ _ | Cassert _ => c + | Cassgn _ _ _ _ | Copn _ _ _ _ | Csyscall _ _ _ _ | Cassert _ => c | Cif _ c1 c2 => c_calls (c_calls c c1) c2 | Cfor _ _ c1 => c_calls c c1 | Cwhile _ c1 _ _ c2 => c_calls (c_calls c c1) c2 - | Ccall _ f _ => Sf.add f c + | Ccall _ f _ _ => Sf.add f c end. Definition c_calls (c : Sf.t) (cmd : cmd) := diff --git a/proofs/compiler/dead_code.v b/proofs/compiler/dead_code.v index 1a082ce85f..f57d015c1d 100644 --- a/proofs/compiler/dead_code.v +++ b/proofs/compiler/dead_code.v @@ -125,7 +125,7 @@ Fixpoint dead_code_i (i:instr) (s:Sv.t) {struct i} : cexec (Sv.t * cmd) := else ok (read_es_rec (read_rvs_rec (Sv.diff s w) xs) es, [:: i]) else ok (read_es_rec (read_rvs_rec (Sv.diff s w) xs) es, [:: i]) - | Csyscall xs o es => + | Csyscall xs _ o es => ok (read_es_rec (read_rvs_rec (Sv.diff s (vrvs xs)) xs) es, [:: i]) | Cassert a => ok (read_eassert_rec s a.2 , [::i]) @@ -155,14 +155,14 @@ Fixpoint dead_code_i (i:instr) (s:Sv.t) {struct i} : cexec (Sv.t * cmd) := let: (s, (c,c')) := sc in ok (s, [:: MkI ii (Cwhile a c e info c')]) - | Ccall xs fn es => + | Ccall xs fn al es => Let sxs := match onfun fn with | None => ok (read_rvs_rec (Sv.diff s (vrvs xs)) xs, xs) | Some bs => add_iinfo ii (check_keep_only xs bs s) end in let '(si,xs) := sxs in - ok (read_es_rec si es, [:: MkI ii (Ccall xs fn es)]) + ok (read_es_rec si es, [:: MkI ii (Ccall xs fn al es)]) end. @@ -177,6 +177,7 @@ Definition dead_code_fd {eft} fn (fd: _fundef eft) : cexec (_fundef eft) := Let c := dead_code_c dead_code_i fd.(f_body) s in ok {| f_info := f_info fd; f_contract := f_contract fd; + f_al := f_al fd; f_tyin := f_tyin fd; f_params := f_params fd; f_body := c.2; diff --git a/proofs/compiler/inline.v b/proofs/compiler/inline.v index 3452e2f308..48eed75a8b 100644 --- a/proofs/compiler/inline.v +++ b/proofs/compiler/inline.v @@ -1,5 +1,5 @@ (* ** Imports and settings *) -From Coq Require Import ZArith. +From Coq Require Import ZArith Uint63. From mathcomp Require Import ssreflect ssrfun ssrbool. Require Import expr compiler_util. @@ -29,6 +29,7 @@ Section INLINE. Context {asm_op syscall_state : Type} {asmop:asmOp asm_op} + (fresh_var_ident : v_kind -> int -> string -> atype -> Ident.ident) (extend_iinfo : instr_info -> instr_info -> instr_info) . @@ -77,9 +78,9 @@ Fixpoint extend_iinfo_i ii i : instr := match ir with | Cassgn _ _ _ _ | Copn _ _ _ _ - | Csyscall _ _ _ + | Csyscall _ _ _ _ | Cassert _ - | Ccall _ _ _ => ir + | Ccall _ _ _ _ => ir | Cif e c1 c2 => Cif e (map (extend_iinfo_i ii) c1) (map (extend_iinfo_i ii) c2) | Cfor x (d,lo,hi) c => @@ -93,12 +94,202 @@ Fixpoint extend_iinfo_i ii i : instr := Definition extend_iinfo_cmd ii c := map (extend_iinfo_i ii) c. +Section SUBST. + +Record subst_map := { + m : Mvar.t var; + counter : int; +}. +Definition empty_sm := {| + m := Mvar.empty _; + counter := 0; +|}. + +Definition mon A := subst_map -> subst_map * A. + +Definition ret {A} (x: A) : mon A := fun sm => (sm, x). +Definition bind {A B} (x : mon A) (f : A -> mon B) : mon B := + fun sm => + let (sm, x) := x sm in + f x sm. +Notation "'let%m' x ':=' m 'in' body" := (bind m (fun x => body)) (x name, at level 25) : result_scope. +Definition mapm {A B} (f : A -> mon B) (l : seq A) : mon (seq B) := + fun sm => fmap (fun sm x => f x sm) sm l. + +Definition clone_with_ty (x:var) n ty := + let xn := + fresh_var_ident (Ident.id_kind x.(vname)) n (Ident.id_name x.(vname)) ty + in + {| vtype := ty; vname := xn |}. +Definition subst_var f x : mon _ := fun sm => + match Mvar.get sm.(m) x with + | Some y => (sm, y) + | None => + let y := clone_with_ty x sm.(counter) (subst_ty f x.(vtype)) in + let m := Mvar.set sm.(m) x y in + let sm := {| m := m; counter := Uint63.succ sm.(counter) |} in + (sm, y) + end. +Definition subst_var_i f x := + let%m v := subst_var f x.(v_var) in + ret {| v_var := v; v_info := x.(v_info) |}. +Definition subst_gvar f x := + if is_glob x then ret x + else + let%m xv := subst_var_i f x.(gv) in + ret {| gv := xv; gs := x.(gs) |}. + +Fixpoint subst_e f e := + match e with + | Pconst _ | Pbool _ => ret e + | Parr_init ws al => + let al := subst_al f al in + ret (Parr_init ws al) + | Pvar x => + let%m x := subst_gvar f x in + ret (Pvar x) + | Pget al aa ws x e => + let%m x := subst_gvar f x in + let%m e := subst_e f e in + ret (Pget al aa ws x e) + | Psub aa ws len x e => + let len := subst_al f len in + let%m x := subst_gvar f x in + let%m e := subst_e f e in + ret (Psub aa ws len x e) + | Pload al ws e => + let%m e := subst_e f e in + ret (Pload al ws e) + | Papp1 op e => + let%m e := subst_e f e in + ret (Papp1 op e) + | Papp2 op e1 e2 => + let%m e1 := subst_e f e1 in + let%m e2 := subst_e f e2 in + ret (Papp2 op e1 e2) + | PappN o es => + let%m es := mapm (subst_e f) es in + ret (PappN o es) + | Pif t e e1 e2 => + let t := subst_ty f t in + let%m e := subst_e f e in + let%m e1 := subst_e f e1 in + let%m e2 := subst_e f e2 in + ret (Pif t e e1 e2) + end. +Definition subst_es f := mapm (subst_e f). + +Definition subst_lval f lv := + match lv with + | Lnone vi ty => + let ty := subst_ty f ty in + ret (Lnone vi ty) + | Lvar x => + let%m x := subst_var_i f x in + ret (Lvar x) + | Lmem al ws vi e => + let%m e := subst_e f e in + ret (Lmem al ws vi e) + | Laset al aa ws x e => + let%m x := subst_var_i f x in + let%m e := subst_e f e in + ret (Laset al aa ws x e) + | Lasub aa ws len x e => + let len := subst_al f len in + let%m x := subst_var_i f x in + let%m e := subst_e f e in + ret (Lasub aa ws len x e) + end. +Definition subst_lvals f := mapm (subst_lval f). + +Fixpoint subst_a f (a : eassert) : mon eassert := + match a with + | Pexpr e => + let%m e := subst_e f e in + ret (Pexpr e) + | PappN_safety o es => + let%m es := subst_es f es in + ret (PappN_safety o es) + | Pis_var_init _ => ret a + | Pis_mem_init e1 e2 => + let%m e1 := subst_e f e1 in + let%m e2 := subst_e f e2 in + ret (Pis_mem_init e1 e2) + | Pand a1 a2 => + let%m a1 := subst_a f a1 in + let%m a2 := subst_a f a2 in + ret (Pand a1 a2) + end. + +Fixpoint subst_i f (i:instr) : mon instr := + let (ii,ir) := i in + match ir with + | Copn xs tg op es => + (* TODO: subst in op too *) + let%m xs := subst_lvals f xs in + let%m es := subst_es f es in + ret (MkI ii (Copn xs tg op es)) + | Cassgn x tg ty e => + let%m x := subst_lval f x in + let ty := subst_ty f ty in + let%m e := subst_e f e in + ret (MkI ii (Cassgn x tg ty e)) + | Cif b c1 c2 => + let%m b := subst_e f b in + let%m c1 := mapm (subst_i f) c1 in + let%m c2 := mapm (subst_i f) c2 in + ret (MkI ii (Cif b c1 c2)) + | Cfor x r c => + let%m x := subst_var_i f x in + let%m r12 := subst_e f r.1.2 in + let%m r2 := subst_e f r.2 in + let r := (r.1.1, r12, r2) in + let%m c := mapm (subst_i f) c in + ret (MkI ii (Cfor x r c)) + | Cwhile a c e info c' => + let%m c := mapm (subst_i f) c in + let%m e := subst_e f e in + let%m c' := mapm (subst_i f) c' in + ret (MkI ii (Cwhile a c e info c')) + | Ccall xs fn alargs es => + let%m xs := subst_lvals f xs in + let alargs := map (subst_al f) alargs in + let%m es := subst_es f es in + ret (MkI ii (Ccall xs fn alargs es)) + | Csyscall xs o al es => + (* TODO: subst in o too *) + let%m xs := subst_lvals f xs in + let%m es := subst_es f es in + ret (MkI ii (Csyscall xs o al es)) + | Cassert (lbl, a) => + let%m e := subst_a f a in + ret (MkI ii (Cassert (lbl, e))) + end. +Definition subst_c f := mapm (subst_i f). + +Definition subst_fd f (fd:ufundef) := + let%m params := mapm (subst_var_i f) fd.(f_params) in + let%m res := mapm (subst_var_i f) fd.(f_res) in + let%m body := subst_c f fd.(f_body) in + ret + {| f_info := fd.(f_info); + f_contract := fd.(f_contract); (* FIXME: is this correct? *) + f_al := [::]; + f_tyin := map (subst_ty f) fd.(f_tyin); + f_params := params; + f_body := body; + f_tyout := map (subst_ty f) fd.(f_tyout); + f_res := res; + f_extra := fd.(f_extra) |}. + +End SUBST. + Fixpoint inline_i (p:ufun_decls) (i:instr) (X:Sv.t) : cexec (Sv.t * cmd) := let '(MkI iinfo ir) := i in match ir with | Cassgn _ _ _ _ | Copn _ _ _ _ - | Csyscall _ _ _ + | Csyscall _ _ _ _ | Cassert _ => ok (Sv.union (read_i ir) X, [::i]) | Cif e c1 c2 => @@ -114,20 +305,29 @@ Fixpoint inline_i (p:ufun_decls) (i:instr) (X:Sv.t) : cexec (Sv.t * cmd) := Let c := inline_c (inline_i p) c X in Let c' := inline_c (inline_i p) c' X in ok (X, [::MkI iinfo (Cwhile a c.2 e info c'.2)]) - | Ccall xs f es => + | Ccall xs fn alargs es => + (* we have to substitute f_al with alargs and to clone the function to + avoid collisions, in that order or the other one. + But we cannot change the type of variables on Coq side, so we have + to call some OCaml code at some point. *) let X := Sv.union (read_i ir) X in if ii_is_inline iinfo then - Let fd := add_iinfo iinfo (get_fun p f) in - Let _ := add_iinfo iinfo (check_disjoint fd (Sv.union (vrvs xs) X)) in + Let fd := add_iinfo iinfo (get_fun p fn) in + let f := + let als := zip fd.(f_al) alargs in + assoc als + in + let (_, fd') := subst_fd f fd empty_sm in + Let _ := add_iinfo iinfo (check_disjoint fd' (Sv.union (vrvs xs) X)) in let ii := ii_with_location iinfo in let rename_args := - assgn_tuple ii (map Lvar fd.(f_params)) AT_rename fd.(f_tyin) es + assgn_tuple ii (map Lvar fd'.(f_params)) AT_rename fd'.(f_tyin) es in let body := - extend_iinfo_cmd iinfo fd.(f_body) + extend_iinfo_cmd iinfo fd'.(f_body) in let rename_res := - assgn_tuple ii xs AT_rename fd.(f_tyout) (map Plvar fd.(f_res)) + assgn_tuple ii xs AT_rename fd'.(f_tyout) (map Plvar fd'.(f_res)) in ok (X, rename_args ++ body ++ rename_res) else ok (X, [::i]) diff --git a/proofs/compiler/linearization.v b/proofs/compiler/linearization.v index 813f9255b0..522828bbb9 100644 --- a/proofs/compiler/linearization.v +++ b/proofs/compiler/linearization.v @@ -449,7 +449,7 @@ Definition pop_to_save | Cassgn lv _ _ e => Error (E.assign_remains ii lv e) | Copn xs tag o es => allM (check_rexpr ii) es >> allM (check_lexpr ii) xs - | Csyscall xs o es => + | Csyscall xs o _ es => ok tt | Cassert _ => Error (E.ii_error ii "assert found in linear") @@ -463,7 +463,7 @@ Definition pop_to_save | Some true => check_c check_i c >> check_c check_i c' | None => check_fexpr ii e >> check_c check_i c >> check_c check_i c' end - | Ccall xs fn es => + | Ccall xs fn _ es => Let _ := assert (fn != this) (E.ii_error ii "call to self") in if get_fundef (p_funcs p) fn is Some fd then let e := f_extra fd in @@ -655,7 +655,7 @@ Fixpoint linear_i (i:instr) (lbl:label) (lc:lcmd) := | _, _ => (lbl, lc) (* absurd case *) end - | Csyscall xs o es => (lbl, MkLI ii (Lsyscall o) :: lc) + | Csyscall xs o _ es => (lbl, MkLI ii (Lsyscall o) :: lc) | Cassert _ => (lbl, lc) (* absurd case *) @@ -710,7 +710,7 @@ Fixpoint linear_i (i:instr) (lbl:label) (lc:lcmd) := end end - | Ccall xs fn' es => + | Ccall xs fn' _ es => if get_fundef (p_funcs p) fn' is Some fd then let e := f_extra fd in let ra := sf_return_address e in diff --git a/proofs/compiler/load_constants_in_cond.v b/proofs/compiler/load_constants_in_cond.v index ae6e311a37..5b51af2b9f 100644 --- a/proofs/compiler/load_constants_in_cond.v +++ b/proofs/compiler/load_constants_in_cond.v @@ -80,9 +80,9 @@ Fixpoint load_constants_i (i : instr) := match ir with | Cassgn _ _ _ _ | Copn _ _ _ _ - | Csyscall _ _ _ + | Csyscall _ _ _ _ | Cassert _ - | Ccall _ _ _ + | Ccall _ _ _ _ => ok [::i] | Cif e c1 c2 => Let: (c, e) := process_condition ii e in diff --git a/proofs/compiler/lower_spill.v b/proofs/compiler/lower_spill.v index 47daf5c136..b828e57ef8 100644 --- a/proofs/compiler/lower_spill.v +++ b/proofs/compiler/lower_spill.v @@ -45,11 +45,11 @@ Fixpoint to_spill_i (s : Sv.t * bool) (i : instr) := | Some (Unspill, _) => (s.1, true) | _ => s end - | Csyscall _ _ _ | Cassert _ => s + | Csyscall _ _ _ _ | Cassert _ => s | Cif _ c1 c2 => foldl to_spill_i (foldl to_spill_i s c1) c2 | Cfor _ _ c => foldl to_spill_i s c | Cwhile _ c1 _ _ c2 => foldl to_spill_i (foldl to_spill_i s c1) c2 - | Ccall _ _ _ => s + | Ccall _ _ _ _ => s end. Definition spill_env := Sv.t. @@ -162,7 +162,7 @@ Fixpoint spill_i (env : spill_env) (i : instr) : cexec (spill_env * cmd) := | Some (Unspill, tys) => Let c := unspill_es ii env tys es in ok (env, c) | None => ok (update_lvs env lvs, [::i]) end - | Csyscall lvs c es => ok (update_lvs env lvs, [::i]) + | Csyscall lvs c _ es => ok (update_lvs env lvs, [::i]) | Cassert _ => ok (env, [::i]) | Cif e c1 c2 => Let ec1 := spill_c spill_i env c1 in @@ -174,7 +174,7 @@ Fixpoint spill_i (env : spill_env) (i : instr) : cexec (spill_env * cmd) := | Cwhile a c1 e info c2 => Let ec := wloop (spill_c spill_i) ii c1 c2 Loop.nb env in ok (ec.1, [:: MkI ii (Cwhile a ec.2.1 e info ec.2.2)]) - | Ccall lvs f es => ok (update_lvs env lvs, [::i]) + | Ccall lvs f _ es => ok (update_lvs env lvs, [::i]) end. End GET. @@ -209,7 +209,7 @@ Definition check_map (m:Mvar.t var) X := Mvar.fold (fun (x:var) (sx:var) bX => (bX.1 && ~~Sv.mem sx bX.2, Sv.add sx bX.2)) m (true, X). -Definition spill_fd (fn:funname) (fd: fundef) : cexec fundef := +Definition spill_fd (fn:funname) (fd: fundef) : cexec fundef := let s := foldl to_spill_i (Sv.empty, false) (f_body fd) in if ~~s.2 then ok fd else let: (m, _) := init_map (f_info fd) s.1 in @@ -217,7 +217,7 @@ Definition spill_fd (fn:funname) (fd: fundef) : cexec fundef := let b := check_map m X in Let _ := assert b.1 (pp_internal_error E.pass (pp_s "invalid map")) in Let ec := spill_c (spill_i (get_spill m)) Sv.empty (f_body fd) in - ok (with_body fd ec.2). + ok (with_body fd ec.2). Definition spill_prog (p: prog) : cexec prog := Let funcs := map_cfprog_name spill_fd (p_funcs p) in diff --git a/proofs/compiler/makeReferenceArguments.v b/proofs/compiler/makeReferenceArguments.v index 47820678d2..5a5ccfb4d6 100644 --- a/proofs/compiler/makeReferenceArguments.v +++ b/proofs/compiler/makeReferenceArguments.v @@ -14,8 +14,10 @@ Module Import E. End E. Section Section. +Context {pd:PointerData}. Context `{asmop:asmOp}. Context (fresh_reg_ptr : instr_info -> int -> string -> atype -> Ident.ident). +Context (N : length_var). Context (p : uprog). Definition with_id vi ii ctr id ty := @@ -126,18 +128,32 @@ Definition mk_info (x:var_i) (ty:atype) := Definition get_sig ii fn := if get_fundef p.(p_funcs) fn is Some fd then - ok (map2 mk_info fd.(f_params) fd.(f_tyin), + ok (fd.(f_al), map2 mk_info fd.(f_params) fd.(f_tyin), map2 mk_info fd.(f_res) fd.(f_tyout)) else Error (E.make_ref_error ii "unknown function"). Definition get_syscall_sig o := - let: s := syscall.syscall_sig_u o in - (map (fun ty => (is_aarr ty, "__p__"%string, ty)) s.(scs_tin), + let: s := syscall.syscall_sig_u N o in + (s.(scs_al), + map (fun ty => (is_aarr ty, "__p__"%string, ty)) s.(scs_tin), map (fun ty => (is_aarr ty, "__p__"%string, ty)) s.(scs_tout)). Definition is_swap_op (op: sopn) : option atype := if op is Opseudo_op (pseudo_operator.Oswap (aarr _ _ as ty)) then Some ty else None. +(* TODO: should we fail if subst fails? or just returns the original? *) +Definition subst_sig al alargs '((params,returns) : seq (bool * string * atype) * seq (bool * string * atype)) := + let f := + let als := zip al alargs in + assoc als + in + let subst := + map (fun '(b, s, ty) => (b, s, subst_ty f ty)) + in + let params := subst params in + let returns := subst returns in + (params, returns). + Fixpoint update_i (X:Sv.t) (i:instr) : cexec cmd := let (ii,ir) := i in match ir with @@ -163,18 +179,20 @@ Fixpoint update_i (X:Sv.t) (i:instr) : cexec cmd := Let c := update_c (update_i X) c in Let c' := update_c (update_i X) c' in ok [::MkI ii (Cwhile a c e info c')] - | Ccall xs fn es => - Let: (params,returns) := get_sig ii fn in + | Ccall xs fn alargs es => + Let: (al,params,returns) := get_sig ii fn in + let (params, returns) := subst_sig al alargs (params, returns) in Let pres := make_prologue ii X 0 params es in let: (prologue, es) := pres in Let xsep := make_epilogue ii X returns xs in let: (xs, epilogue) := xsep in - ok (prologue ++ MkI ii (Ccall xs fn es) :: epilogue) - | Csyscall xs o es => - let: (params,returns) := get_syscall_sig o in + ok (prologue ++ MkI ii (Ccall xs fn alargs es) :: epilogue) + | Csyscall xs o alargs es => + let: (al, params,returns) := get_syscall_sig o in + let (params, returns) := subst_sig al alargs (params, returns) in Let: (prologue, es) := make_prologue ii X 0 params es in Let: (xs, epilogue) := make_epilogue ii X returns xs in - ok (prologue ++ MkI ii (Csyscall xs o es) :: epilogue) + ok (prologue ++ MkI ii (Csyscall xs o alargs es) :: epilogue) end. Definition update_fd (fd: ufundef) := diff --git a/proofs/compiler/merge_varmaps.v b/proofs/compiler/merge_varmaps.v index 7bcf23638d..378c57e647 100644 --- a/proofs/compiler/merge_varmaps.v +++ b/proofs/compiler/merge_varmaps.v @@ -66,12 +66,12 @@ Section WRITE1. match i with | Cassgn x _ _ _ => vrv_rec s x | Copn xs _ _ _ => vrvs_rec s xs - | Csyscall xs o _ => vrvs_rec (Sv.union s syscall_kill) (to_lvals (syscall_sig o).(scs_vout)) + | Csyscall xs o _ _ => vrvs_rec (Sv.union s syscall_kill) (to_lvals (syscall_sig o).(scs_vout)) | Cassert _ => s | Cif _ c1 c2 => foldl write_I_rec (foldl write_I_rec s c2) c1 | Cfor x _ c => foldl write_I_rec (Sv.add x s) c | Cwhile _ c _ _ c' => foldl write_I_rec (foldl write_I_rec s c') c - | Ccall _ fn _ => Sv.union s (writefun_ra_call fn) + | Ccall _ fn _ _ => Sv.union s (writefun_ra_call fn) end with write_I_rec s i := match i with @@ -161,7 +161,7 @@ Section CHECK. | Copn xs tag o es => Let _ := check_es ii D es in check_lvs ii D xs - | Csyscall xs o es => + | Csyscall xs o _ es => let osig := syscall_sig o in let o_params := osig.(scs_vin) in let o_res := osig.(scs_vout) in @@ -187,7 +187,7 @@ Section CHECK. if is_false e then check_c (check_i sz) D c else wloop (check_i sz) ii c (read_e e) c' Loop.nb D - | Ccall xs fn es => + | Ccall xs fn _ es => if get_fundef (p_funcs p) fn is Some fd then let tmp := tmp_call (f_extra fd) in Let _ := check_es ii (Sv.union D tmp) es in diff --git a/proofs/compiler/post_unrolling_check.v b/proofs/compiler/post_unrolling_check.v index 2418b994f1..291676f144 100644 --- a/proofs/compiler/post_unrolling_check.v +++ b/proofs/compiler/post_unrolling_check.v @@ -40,7 +40,7 @@ End CHECK_NO_FOR_LOOP_CMD. Fixpoint check_no_for_loop_instr_r i : cexec unit := match i with - | (Cassgn _ _ _ _ | Copn _ _ _ _ | Csyscall _ _ _ | Cassert _ | Ccall _ _ _) + | (Cassgn _ _ _ _ | Copn _ _ _ _ | Csyscall _ _ _ _ | Cassert _ | Ccall _ _ _ _) => ok tt | (Cif _ c c' | Cwhile _ c _ _ c') => check_no_for_loop_cmd check_no_for_loop_instr c >> check_no_for_loop_cmd check_no_for_loop_instr c' @@ -61,7 +61,7 @@ Definition check_no_inline_instr_cmd (i: instr → cexec unit) (c: cmd) := allM Fixpoint check_no_inline_instr_instr_r i : cexec unit := match i with - | (Cassgn _ _ _ _ | Copn _ _ _ _ | Csyscall _ _ _ | Cassert _ | Cfor _ _ _ | Ccall _ _ _) + | (Cassgn _ _ _ _ | Copn _ _ _ _ | Csyscall _ _ _ _ | Cassert _ | Cfor _ _ _ | Ccall _ _ _ _) => ok tt | (Cif _ c c' | Cwhile _ c _ _ c') => check_no_inline_instr_cmd check_no_inline_instr_instr c >> check_no_inline_instr_cmd check_no_inline_instr_instr c' diff --git a/proofs/compiler/propagate_inline.v b/proofs/compiler/propagate_inline.v index 754a6dd24f..f5db4c31d1 100644 --- a/proofs/compiler/propagate_inline.v +++ b/proofs/compiler/propagate_inline.v @@ -165,12 +165,12 @@ Fixpoint pi_i (pi:pimap) (i:instr) := let (pi, xs) := pi_lvs pi xs in ok (pi, MkI ii (Copn xs tag o es)) - | Csyscall xs o es => + | Csyscall xs o al es => let es := pi_es pi es in (* Remark: for uprog it is not necessary *) let pi := remove_m pi in let (pi, xs) := pi_lvs pi xs in - ok (pi, MkI ii (Csyscall xs o es)) + ok (pi, MkI ii (Csyscall xs o al es)) | Cassert (msg, e) => ok (pi, MkI ii (Cassert (msg, e))) @@ -193,10 +193,10 @@ Fixpoint pi_i (pi:pimap) (i:instr) := let:(pi, c1, e, c2) := pic in ok (pi, MkI ii (Cwhile a c1 e info c2)) - | Ccall xs f es => + | Ccall xs f al es => let es := pi_es pi es in let (pi, xs) := pi_lvs (remove_m pi) xs in - ok (pi, MkI ii (Ccall xs f es)) + ok (pi, MkI ii (Ccall xs f al es)) end. diff --git a/proofs/compiler/remove_assert.v b/proofs/compiler/remove_assert.v index 8f77880e7d..175901c279 100644 --- a/proofs/compiler/remove_assert.v +++ b/proofs/compiler/remove_assert.v @@ -15,7 +15,7 @@ Fixpoint remove_assert_i (i: instr) : cmd := match ir with | Cassert _ => [::] | Cassgn _ _ _ _ - | Copn _ _ _ _ | Csyscall _ _ _ | Ccall _ _ _ => + | Copn _ _ _ _ | Csyscall _ _ _ _ | Ccall _ _ _ _ => [:: i] | Cif e c1 c2 => let c1 := remove_assert_c remove_assert_i c1 in @@ -36,6 +36,7 @@ Definition remove_assert_fd (fd: fundef) := let c := remove_assert_c remove_assert_i fd.(f_body) in {| f_info := fd.(f_info); f_contract := None; + f_al := fd.(f_al); f_tyin := fd.(f_tyin); f_params := fd.(f_params); f_body := c; diff --git a/proofs/compiler/remove_globals.v b/proofs/compiler/remove_globals.v index d1ac2f141c..21a459954e 100644 --- a/proofs/compiler/remove_globals.v +++ b/proofs/compiler/remove_globals.v @@ -9,7 +9,7 @@ Require Import expr compiler_util. Definition type_of_glob_value (gv: glob_value) : atype := match gv with | Gword ws _ => aword ws - | Garr p _ => aarr U8 p + | Garr p _ => aarr U8 (ALConst p) end. Local Open Scope seq_scope. @@ -85,9 +85,10 @@ Section REMOVE. else Error (rm_glob_error_gen ii x [:: pp_s "a cell has a non-constant value"; pp_e pe ]) ). - Definition array_from_cells ii x (len: positive) (cells: pexprs) : result pp_error_loc (WArray.array len) := + Definition array_from_cells ii x (len: Z) (cells: pexprs) : result pp_error_loc (WArray.array len) := Let bytes := evaluate_bytes ii x cells in - match sem_opN (Oarray len) bytes >>= to_arr len with + let env := fun (_ : length_var) => None in + match sem_opN env (Oarray len) bytes >>= to_arr len with | Ok array => Ok _ array | Error _ => Error (rm_glob_error_gen ii x [:: pp_s "cannot fill the array"]) end. @@ -110,7 +111,7 @@ Section REMOVE. else ok gd | _ => ok gd end - | Copn _ _ _ _ | Csyscall _ _ _ | Cassert _ | Ccall _ _ _ => ok gd + | Copn _ _ _ _ | Csyscall _ _ _ _ | Cassert _ | Ccall _ _ _ _ => ok gd | Cif _ c1 c2 => Let gd := foldM extend_glob_i gd c1 in foldM extend_glob_i gd c2 @@ -279,7 +280,7 @@ Section REMOVE. ok (Mvar.set env x g, [::]) else Error (rm_glob_error ii xi) | PappN (Oarray len) cells => - if convertible (vtype x) (aarr U8 len) then + if convertible (vtype x) (aarr U8 (ALConst len)) then Let array := array_from_cells ii x len cells in Let g := find_glob ii xi gd (Garr array) in ok (Mvar.set env x g, [::]) @@ -297,10 +298,10 @@ Section REMOVE. Let lvs := mapM (remove_glob_lv ii env) lvs in Let es := mapM (remove_glob_e ii env) es in ok (env, [::MkI ii (Copn lvs tag o es)]) - | Csyscall lvs o es => + | Csyscall lvs o al es => Let lvs := mapM (remove_glob_lv ii env) lvs in Let es := mapM (remove_glob_e ii env) es in - ok (env, [::MkI ii (Csyscall lvs o es)]) + ok (env, [::MkI ii (Csyscall lvs o al es)]) | Cassert a => Error (pp_safety_remains_at E.pass ii) | Cif e c1 c2 => @@ -332,10 +333,10 @@ Section REMOVE. Let envc := loop check_c Loop.nb env in let: (env, c) := envc in ok (env, [::MkI ii (Cfor xi (d,e1,e2) c)]) - | Ccall lvs fn es => + | Ccall lvs fn al es => Let lvs := mapM (remove_glob_lv ii env) lvs in Let es := mapM (remove_glob_e ii env) es in - ok (env, [::MkI ii (Ccall lvs fn es)]) + ok (env, [::MkI ii (Ccall lvs fn al es)]) end end. diff --git a/proofs/compiler/riscv_extra.v b/proofs/compiler/riscv_extra.v index 1f7d0b30aa..a7bec4412f 100644 --- a/proofs/compiler/riscv_extra.v +++ b/proofs/compiler/riscv_extra.v @@ -34,7 +34,7 @@ Instance eqTC_riscv_extra_op : eqTypeC riscv_extra_op := argument. *) Definition Oriscv_add_large_imm_instr : instruction_desc := let ty := aword riscv_reg_size in - let cty := eval_atype ty in + let cty := cword riscv_reg_size in let ctin := [:: cty; cty] in let semi := fun (x y : word riscv_reg_size) => (x + y)%w in {| str := (fun _ => "add_large_imm"%string) @@ -43,13 +43,13 @@ Definition Oriscv_add_large_imm_instr : instruction_desc := ; tout := [:: ty] ; i_out := [:: E 0] ; conflicts := [:: (APout 0, APin 0)] - ; semi := sem_prod_ok ctin semi - ; semu := @values.vuincl_app_sopn_v ctin [:: cty] (sem_prod_ok ctin semi) refl_equal + ; semi := fun _ => sem_prod_ok ctin semi + ; semu := fun _ => @values.vuincl_app_sopn_v ctin [:: cty] (sem_prod_ok ctin semi) refl_equal ; i_safe := [::] ; i_valid := true ; i_safe_wf := refl_equal - ; i_semi_errty := fun _ => sem_prod_ok_error (tin:=ctin) semi _ - ; i_semi_safe := fun _ => values.sem_prod_ok_safe (tin:=ctin) semi + ; i_semi_errty := fun _ _ => sem_prod_ok_error (tin:=ctin) semi _ + ; i_semi_safe := fun _ _ => values.sem_prod_ok_safe (tin:=ctin) semi |}. Definition get_instr_desc (o: riscv_extra_op) : instruction_desc := diff --git a/proofs/compiler/riscv_lower_addressing.v b/proofs/compiler/riscv_lower_addressing.v index ebb10c603e..781d46e69c 100644 --- a/proofs/compiler/riscv_lower_addressing.v +++ b/proofs/compiler/riscv_lower_addressing.v @@ -76,9 +76,9 @@ Fixpoint lower_addressing_i (i: instr) := else [:: i] else [:: i] | Cassgn _ _ _ _ - | Csyscall _ _ _ + | Csyscall _ _ _ _ | Cassert _ - | Ccall _ _ _ => [:: i] + | Ccall _ _ _ _ => [:: i] | Cif b c1 c2 => let c1 := conc_map lower_addressing_i c1 in let c2 := conc_map lower_addressing_i c2 in diff --git a/proofs/compiler/slh_lowering.v b/proofs/compiler/slh_lowering.v index 9eaf2f5edd..2f22685d22 100644 --- a/proofs/compiler/slh_lowering.v +++ b/proofs/compiler/slh_lowering.v @@ -442,7 +442,7 @@ Fixpoint check_i (i : instr) (env : Env.t) : cexec Env.t := then check_slho ii lvs slho es env else ok (Env.after_assign_vars env (vrvs lvs)) - | Csyscall _ _ _ => ok Env.empty + | Csyscall _ _ _ _ => ok Env.empty | Cassert _ => ok env @@ -458,7 +458,7 @@ Fixpoint check_i (i : instr) (env : Env.t) : cexec Env.t := Let _ := chk_mem ii cond in check_while ii cond (check_cmd c0) (check_cmd c1) Loop.nb env - | Ccall xs fn es => + | Ccall xs fn _ es => let '(in_t, out_t) := fun_info fn in Let _ := check_f_args ii env es in_t in check_f_lvs ii env xs out_t @@ -503,7 +503,7 @@ Fixpoint lower_i (i : instr) : cexec instr := then lower_slho ii lvs tg slho es else ok ir - | Csyscall _ _ _ => + | Csyscall _ _ _ _ => ok ir | Cassert _ => @@ -523,7 +523,7 @@ Fixpoint lower_i (i : instr) : cexec instr := Let c1' := lower_cmd c1 in ok (Cwhile al c0' b info c1') - | Ccall _ _ _ => + | Ccall _ _ _ _ => ok ir end in diff --git a/proofs/compiler/stack_alloc.v b/proofs/compiler/stack_alloc.v index d0aa459487..55f76839ab 100644 --- a/proofs/compiler/stack_alloc.v +++ b/proofs/compiler/stack_alloc.v @@ -55,19 +55,27 @@ End E. (* ------------------------------------------------------------------ *) (* Region *) +Definition get_const al := + match al with + | ALConst n => ok n + | _ => Error (stk_error_no_var "not const") + end. + (* TODO: could [wsize_size] return a [positive] rather than a [Z]? If so, [size_of] could return a positive too. *) -Definition size_of (t:atype) := +Definition size_of_const (t:atype) := match t with - | aword sz => wsize_size sz - | aarr ws n => arr_size ws n - | abool | aint => 1%Z + | aword sz => ok (wsize_size sz) + | aarr ws al => + Let n := get_const al in + ok (arr_size ws n) + | abool | aint => Error (stk_ierror_no_var "size_of") end. Definition slot := var. -Notation size_slot s := (size_of s.(vtype)). +Notation size_slot s := (size_of_const s.(vtype)). (* elpi.derive not clever enough to unfold slot *) Record region := @@ -126,6 +134,7 @@ Module Mr := Mmake CmpR. Inductive sexpr := | Sconst : Z -> sexpr | Svar : var -> sexpr +| Slvar : length_var -> sexpr | Sof_int : wsize -> sexpr -> sexpr | Sto_int : signedness -> wsize -> sexpr -> sexpr | Sneg : op_kind -> sexpr -> sexpr @@ -137,6 +146,7 @@ Fixpoint sexpr_beq (e1 e2 : sexpr) := match e1, e2 with | Sconst n1, Sconst n2 => n1 == n2 | Svar x1, Svar x2 => x1 == x2 + | Slvar n1, Slvar n2 => n1 == n2 | Sof_int ws1 e1, Sof_int ws2 e2 => [&& ws1 == ws2 & sexpr_beq e1 e2] | Sto_int sg1 ws1 e1, Sto_int sg2 ws2 e2 => [&& sg1 == sg2, ws1 == ws2 & sexpr_beq e1 e2] | Sneg opk1 e1, Sneg opk2 e2 => [&& opk1 == opk2 & sexpr_beq e1 e2] @@ -149,11 +159,12 @@ Fixpoint sexpr_beq (e1 e2 : sexpr) := Lemma sexpr_eq_axiom : Equality.axiom sexpr_beq. Proof. elim=> - [z1|x1|ws1 e1 ih1|sg1 ws1 e1 ih1|opk1 e1 ih1|opk1 e11 ih11 e12 ih12|opk1 e11 ih11 e12 ih12|opk1 e11 ih11 e12 ih12] - [z2|x2|ws2 e2 |sg2 ws2 e2 |opk2 e2 |opk2 e21 e22 |opk2 e21 e22 |opk2 e21 e22 ] /=; + [z1|x1|n1|ws1 e1 ih1|sg1 ws1 e1 ih1|opk1 e1 ih1|opk1 e11 ih11 e12 ih12|opk1 e11 ih11 e12 ih12|opk1 e11 ih11 e12 ih12] + [z2|x2|n2|ws2 e2 |sg2 ws2 e2 |opk2 e2 |opk2 e21 e22 |opk2 e21 e22 |opk2 e21 e22 ] /=; try (right; congruence). + by apply (iffP eqP); congruence. + by apply (iffP eqP); congruence. + + by apply (iffP eqP); congruence. + by apply (iffP andP) => -[/eqP -> /ih1 ->]. + by apply (iffP and3P) => -[/eqP -> /eqP -> /ih1 ->]. + by apply (iffP andP) => -[/eqP -> /ih1 ->]. @@ -516,9 +527,51 @@ Definition get_sub_status (status:status) s := | Borrowed i => get_sub_interval i s end. +Fixpoint symbolic_of_al (al : array_length) := + match al with + | ALConst n => Some (Sconst n) + | ALVar x => Some (Slvar x) + | ALNeg al => + let%opt al := symbolic_of_al al in + Some (Sneg Op_int al) + | ALAdd al1 al2 => + let%opt al1 := symbolic_of_al al1 in + let%opt al2 := symbolic_of_al al2 in + Some (Sadd Op_int al1 al2) + | ALSub al1 al2 => + let%opt al1 := symbolic_of_al al1 in + let%opt al2 := symbolic_of_al al2 in + Some (Ssub Op_int al1 al2) + | ALMul al1 al2 => + let%opt al1 := symbolic_of_al al1 in + let%opt al2 := symbolic_of_al al2 in + Some (Smul Op_int al1 al2) + | ALDiv _ _ _ | ALMod _ _ _ | ALShl _ _ | ALShr _ _ => None + end. + +(* TODO: better error message (pp_al?) *) +Definition get_symbolic_of_al al := + let err := + stk_error_no_var_box (pp_hov [:: + pp_s "this array length expression is too complex"]) + in + o2r err (symbolic_of_al al). + +Definition mk_len_int ws len := + let sz := wsize_size ws in + if is_const len is Some i then Sconst (i * sz)%Z + else Smul Op_int (Sconst sz) len. + +Definition symbolic_of_arr_type ty := + if ty is aarr ws al then + Let e := get_symbolic_of_al al in + ok (mk_len_int ws e) + else Error (stk_ierror_no_var "symbolic_of_arr_type") (* impossible case *). + Definition sub_region_status_at_ofs (x:var_i) sr status ofs len := - if (ofs == Sconst 0) && (len == Sconst (size_slot x)) then - (sr, status) + Let e := symbolic_of_arr_type x.(vtype) in + if (ofs == Sconst 0) && (len == e) then + ok (sr, status) else let sr := sub_region_at_ofs sr ofs len in let status := @@ -527,7 +580,7 @@ Definition sub_region_status_at_ofs (x:var_i) sr status ofs len := else Unknown in - (sr, status). + ok (sr, status). (* Returns a zone [z] such that z2 = z1 ++ z, if possible. None => non-disjoint zones, error @@ -651,18 +704,20 @@ Definition set_move (rmap:region_map) x sr status := region_var := rv |}. Definition insert_status x status ofs len statusy := - if (ofs == Sconst 0) && (len == Sconst (size_slot x)) then statusy + Let e := symbolic_of_arr_type x.(vtype) in + if (ofs == Sconst 0) && (len == e) then ok statusy else let s := {| ss_ofs := ofs; ss_len := len |} in if get_sub_status statusy {| ss_ofs := Sconst 0; ss_len := len |} then - fill_status status s + ok (fill_status status s) else - odflt Unknown (clear_status status [:: s]). + ok (odflt Unknown (clear_status status [:: s])). Definition set_move_sub (rmap:region_map) r x status ofs len substatus := - let rv := set_move_status rmap x r (insert_status x status ofs len substatus) in - {| var_region := rmap.(var_region); - region_var := rv |}. + Let status := insert_status x status ofs len substatus in + let rv := set_move_status rmap x r status in + ok {| var_region := rmap.(var_region); + region_var := rv |}. Definition zone_of_cs cs : symbolic_zone := [:: {| ss_ofs := Sconst cs.(cs_ofs); ss_len := Sconst cs.(cs_len) |}]. @@ -682,9 +737,22 @@ Definition check_stack_ptr rv s ws cs x' := let status := get_var_status rv sr.(sr_region) x' in is_valid status. +(* FIXME: redundancy with mk_len_int/symbolic_of_arr_type? *) +Definition size_of (t:atype) := + match t with + | aword sz => ALConst (wsize_size sz) + | aarr ws al => + match al with + | ALConst len => ALConst (arr_size ws len) + | _ => ALMul (ALConst (wsize_size ws)) al + end + | abool | aint => ALConst 1 + end. + Definition sub_region_full x r := - let z := [:: {| ss_ofs := Sconst 0; ss_len := Sconst (size_slot x) |}] in - {| sr_region := r; sr_zone := z |}. + Let len := get_symbolic_of_al (size_of x.(vtype)) in + let z := [:: {| ss_ofs := Sconst 0; ss_len := len |}] in + ok {| sr_region := r; sr_zone := z |}. Definition sub_region_glob x ws := let r := {| r_slot := x; r_align := ws; r_writable := false |} in @@ -701,7 +769,7 @@ Definition get_sub_region_status (rmap:region_map) (x:var_i) := Definition get_gsub_region_status rmap (x:var_i) vpk := match vpk with | VKglob (_, ws) => - let sr := sub_region_glob x ws in + Let sr := sub_region_glob x ws in ok (sr, Valid) | VKptr _pk => get_sub_region_status rmap x @@ -985,9 +1053,14 @@ Definition addr_from_vpk x (vpk:vptr_kind) := Definition bad_arg_number := stk_ierror_no_var "invalid number of args". -Definition not_trivially_incorrect aa ws ofs len := +Definition not_trivially_incorrect aa ws ofs ty := if expr.is_const ofs is Some i then - (0 <=? i * mk_scale aa ws)%Z && (i * mk_scale aa ws + wsize_size ws <=? len)%Z + if ty is aarr ws' al then + if al is ALConst n then + let len := arr_size ws' n in + (0 <=? i * mk_scale aa ws)%Z && (i * mk_scale aa ws + wsize_size ws <=? len)%Z + else true + else true else true. Fixpoint alloc_e (e:pexpr) ty := @@ -1012,7 +1085,7 @@ Fixpoint alloc_e (e:pexpr) ty := | Pget al aa ws x e1 => let xv := x.(gv) in - Let _ := assert (not_trivially_incorrect aa ws e1 (size_of xv.(vtype))) + Let _ := assert (not_trivially_incorrect aa ws e1 xv.(vtype)) (stk_error_no_var "this read is trivially out-of-bounds") in Let e1 := alloc_e e1 aint in Let vk := get_var_kind x in @@ -1088,7 +1161,7 @@ Definition alloc_lval (rmap: region_map) (r:lval) (ty:atype) := end | Laset al aa ws x e1 => - Let _ := assert (not_trivially_incorrect aa ws e1 (size_of x.(vtype))) + Let _ := assert (not_trivially_incorrect aa ws e1 x.(vtype)) (stk_error_no_var "this write is trivially out-of-bounds") in Let e1 := alloc_e rmap e1 aint in match get_local x with @@ -1197,8 +1270,9 @@ Definition alloc_array_move table rmap r tag e := Let: (sr, status) := get_gsub_region_status rmap yv vpk in Let: (table, se1) := get_symbolic_of_pexpr table e1 in let ofs := mk_ofs_int aa ws se1 in - let len := Sconst (arr_size ws len) in - let (sr, status) := sub_region_status_at_ofs yv sr status ofs len in + Let len := get_symbolic_of_al len in + let len := mk_len_int ws len in + Let: (sr, status) := sub_region_status_at_ofs yv sr status ofs len in Let eofs := addr_from_vpk_pexpr rmap yv vpk in Let e1 := alloc_e rmap e1 aint in ok (table, sr, status, mk_mov vpk, eofs.1, mk_ofs aa ws e1 eofs.2) @@ -1251,13 +1325,14 @@ Definition alloc_array_move table rmap r tag e := Let: (sr, status) := get_sub_region_status rmap x in Let: (table, e) := get_symbolic_of_pexpr table e in let ofs := mk_ofs_int aa ws e in - let len := Sconst (arr_size ws len) in - let (sr', _) := sub_region_status_at_ofs x sr status ofs len in + Let len := get_symbolic_of_al len in + let len := mk_len_int ws len in + Let: (sr', _) := sub_region_status_at_ofs x sr status ofs len in Let _ := assert (sry == sr') (regions_are_not_equal "sub-array" x sry sr') in - let rmap := set_move_sub rmap sr.(sr_region) x status ofs len statusy in + Let rmap := set_move_sub rmap sr.(sr_region) x status ofs len statusy in ok (table, rmap, nop) end @@ -1362,6 +1437,7 @@ Fixpoint typecheck e := match e with | Sconst n => ok aint | Svar x => ok x.(vtype) + | Slvar _ => ok aint | Sof_int ws e => Let ty := typecheck e in if ty is aint then ok (aword ws) @@ -1398,6 +1474,7 @@ Fixpoint read_e_rec s (e : sexpr) := match e with | Sconst _ => s | Svar x => Sv.add x s + | Slvar _ => s | Sof_int _ e | Sto_int _ _ e | Sneg _ e => read_e_rec s e | Sadd _ e1 e2 | Smul _ e1 e2 | Ssub _ e1 e2 => read_e_rec (read_e_rec s e1) e2 end. @@ -1619,7 +1696,7 @@ Definition alloc_lval_call (srs:seq (option (bool * sub_region) * pexpr)) rmap ( Definition alloc_call_res rmap srs ret_pos rs := fmapM2 bad_lval_number (alloc_lval_call srs) rmap rs ret_pos. -Definition alloc_call (sao_caller:stk_alloc_oracle_t) rmap rs fn es := +Definition alloc_call (sao_caller:stk_alloc_oracle_t) rmap rs fn al es := let sao_callee := local_alloc fn in Let es := alloc_call_args rmap fn sao_callee.(sao_params) es in let '(rmap, es) := es in @@ -1636,9 +1713,11 @@ Definition alloc_call (sao_caller:stk_alloc_oracle_t) rmap rs fn es := (stk_ierror_no_var "non aligned function call") in let es := map snd es in - ok (rs.1, Ccall rs.2 fn es). + ok (rs.1, Ccall rs.2 fn al es). -(* Before stack_alloc : +(* FIXME: outdated comment + + Before stack_alloc : Csyscall [::x] (getrandom len) [::t] t : arr n & len <= n. return arr len. @@ -1650,24 +1729,21 @@ Definition alloc_call (sao_caller:stk_alloc_oracle_t) rmap rs fn es := Definition alloc_syscall ii rmap rs o es := add_iinfo ii match o with - | RandomBytes ws n => - let len := arr_size ws n in + | RandomBytes => + (* FIXME (* per the semantics, we have [len <= wbase Uptr], but we need [<] *) Let _ := assert (len + | [::Lvar x], [::Pvar xe; Pvar xlen] => let xe := xe.(gv) in - let xlen := with_var xe (vxlen pmap) in Let p := get_regptr xe in Let xp := get_regptr x in Let sr := get_sub_region rmap xe in Let rmap := set_clear rmap xe sr in let rmap := set_move rmap x sr Valid in - ok (rmap, - [:: MkI ii (sap_immediate saparams xlen len); - MkI ii (Csyscall [::Lvar xp] o [:: Plvar p; Plvar xlen])]) + ok (rmap, MkI ii (Csyscall [::Lvar xp] o [::] [:: Plvar p; Pvar xlen])) | _, _ => Error (stk_ierror_no_var "randombytes: invalid args or result") end @@ -1712,7 +1788,7 @@ Definition alloc_declassify_array rmap es := if get_local xv is Some pk then Let: (p, ofs) := addr_from_pk xv pk in let e := add (Plvar p) (cast_const ofs) in - let len := Z.to_pos (size_of xv.(vtype)) in + let len := size_of xv.(vtype) in ok (Copn [::] AT_keep (Opseudo_op (pseudo_operator.Odeclassify_mem len)) [:: e ]) else Error (stk_ierror_basic xv "register array remains") else Error (stk_ierror_no_var "declassify: invalid args"). @@ -1776,10 +1852,10 @@ Fixpoint alloc_i sao (trmap:table*region_map) (i: instr) : cexec (table * region Let rs := add_iinfo ii (alloc_lvals rmap rs (sopn_tout o)) in ok (table, rs.1, [:: MkI ii (Copn rs.2 t o e)]) - | Csyscall rs o es => + | Csyscall rs o _ es => let table := remove_binding_lvals table rs in - Let: (rmap, c) := alloc_syscall ii rmap rs o es in - ok (table, rmap, c) + Let: (rmap, i) := alloc_syscall ii rmap rs o es in + ok (table, rmap, [:: i]) | Cassert _ => Error (pp_at_ii ii (stk_ierror_no_var "don't deal with assert")) @@ -1802,11 +1878,11 @@ Fixpoint alloc_i sao (trmap:table*region_map) (i: instr) : cexec (table * region Let: (table, rmap, (e, c1, c2)) := loop2 ii check_c Loop.nb table rmap in ok (table, rmap, [:: MkI ii (Cwhile a (flatten c1) e info (flatten c2))]) - | Ccall rs fn es => + | Ccall rs fn al es => Let _ := assert (if get_fundef (p_funcs P) fn is None then false else true) (pp_at_ii ii (stk_ierror_no_var "call to a undefined function")) in let table := remove_binding_lvals table rs in - Let ri := add_iinfo ii (alloc_call sao rmap rs fn es) in + Let ri := add_iinfo ii (alloc_call sao rmap rs fn al es) in ok (table, ri.1, [::MkI ii ri.2]) | Cfor _ _ _ => Error (pp_at_ii ii (stk_ierror_no_var "don't deal with for loop")) @@ -1826,7 +1902,7 @@ Definition init_stack_layout (mglob : Mvar.t (Z * wsize)) sao := else if Mvar.get mglob x is Some _ then Error (stk_ierror_no_var "a region is both glob and stack") else if (p <= ofs)%CMP then - let len := size_slot x in + Let len := size_slot x in if (ws <= sao.(sao_align))%CMP then if (Z.land ofs (wsize_size ws - 1) == 0)%Z then let stack := Mvar.set stack x (ofs, ws) in @@ -1854,8 +1930,10 @@ Definition add_alloc globals stack (xpk:var * ptr_kind_init) (lrx: Mvar.t ptr_ki match Mvar.get vars x' with | None => Error (stk_ierror_no_var "unknown region") | Some (ofs', ws') => - if [&& (size_slot x <= cs.(cs_len))%CMP, (0%Z <= cs.(cs_ofs))%CMP & - ((cs.(cs_ofs) + cs.(cs_len))%Z <= size_slot x')%CMP] then + Let lenx := size_slot x in + Let lenx' := size_slot x' in + if [&& (lenx <= cs.(cs_len))%CMP, (0%Z <= cs.(cs_ofs))%CMP & + ((cs.(cs_ofs) + cs.(cs_len))%Z <= lenx')%CMP] then let rmap := if sc is Slocal then let sr := sub_region_stack x' ws' cs in @@ -1877,11 +1955,12 @@ Definition add_alloc globals stack (xpk:var * ptr_kind_init) (lrx: Mvar.t ptr_ki else if xp == x then Error (stk_ierror_no_var "a pseudo-var is equal to a program var") else if Mvar.get locals xp is Some _ then Error (stk_ierror_no_var "a pseudo-var is equal to a program var") else + Let lenx' := size_slot x' in if [&& (Uptr <= ws')%CMP, (0%Z <= cs.(cs_ofs))%CMP, (Z.land cs.(cs_ofs) (wsize_size Uptr - 1) == 0)%Z, (wsize_size Uptr <= cs.(cs_len))%CMP & - ((cs.(cs_ofs) + cs.(cs_len))%Z <= size_slot x')%CMP] then + ((cs.(cs_ofs) + cs.(cs_len))%Z <= lenx')%CMP] then ok (Sv.add xp sv, Pstkptr x' ofs' ws' cs xp, rmap) else Error (stk_ierror_no_var "invalid ptr kind") end @@ -1985,7 +2064,7 @@ Definition init_param (mglob stack : Mvar.t (Z * wsize)) accu pi (x:var_i) := let r := {| r_slot := x; r_align := pi.(pp_align); r_writable := pi.(pp_writable) |} in - let sr := sub_region_full x r in + Let sr := sub_region_full x r in ok (Sv.add pi.(pp_ptr) disj, Mvar.set lmap x (Pregptr pi.(pp_ptr)), set_move rmap x sr Valid, @@ -2043,6 +2122,7 @@ Definition alloc_fd_aux P p_extra mglob (local_alloc: funname -> stk_alloc_oracl ok {| f_info := f_info fd; f_contract := f_contract fd; + f_al := f_al fd; f_tyin := map2 (fun o ty => if o is Some _ then aword Uptr else ty) sao.(sao_params) fd.(f_tyin); f_params := params; f_body := flatten body; @@ -2111,7 +2191,7 @@ Definition check_glob data gv := Definition size_glob gv := match gv with | @Gword ws _ => wsize_size ws - | @Garr p _ => Zpos p + | @Garr p _ => p end. Definition init_map (l:list (var * wsize * Z)) data (gd:glob_decls) : cexec (Mvar.t (Z*wsize)) := @@ -2120,7 +2200,7 @@ Definition init_map (l:list (var * wsize * Z)) data (gd:glob_decls) : cexec (Mva let '(mvar, pos, data) := globals in if (pos <=? p)%Z then if Z.land p (wsize_size ws - 1) == 0%Z then - let s := size_slot v in + Let s := size_slot v in match ztake (p - pos) data with | None => Error (stk_ierror_no_var "bad data 1") | Some (_, data) => diff --git a/proofs/compiler/unrolling.v b/proofs/compiler/unrolling.v index 76cb264290..aea1df3bb8 100644 --- a/proofs/compiler/unrolling.v +++ b/proofs/compiler/unrolling.v @@ -54,9 +54,9 @@ Fixpoint unroll_i (i: instr) : cmd * bool := match ir with | Cassgn _ _ _ _ | Copn _ _ _ _ - | Csyscall _ _ _ + | Csyscall _ _ _ _ | Cassert _ - | Ccall _ _ _ + | Ccall _ _ _ _ => ([:: i ], false) | Cif b c1 c2 => let: (c1', b1) := unroll_cmd unroll_i c1 in diff --git a/proofs/compiler/wint_int.v b/proofs/compiler/wint_int.v index d73a85be7f..a31d261041 100644 --- a/proofs/compiler/wint_int.v +++ b/proofs/compiler/wint_int.v @@ -40,6 +40,7 @@ End E. Section WITH_PARAMS. Context `{asmop:asmOp} {pd: PointerData} {msfsz : MSFsize}. +Context (N : length_var). Definition sc_op1 := sc_op1 (fun _ _ e => e). @@ -206,12 +207,12 @@ Fixpoint wi2i_e (e0:pexpr) : cexec (safety_cond * pexpr) := end. -Definition wi2i_lvar (ety : extended_type positive) (x : var_i) : cexec var_i := +Definition wi2i_lvar (ety : extended_type) (x : var_i) : cexec var_i := Let _ := assert (esubtype (etype_of_var m x) ety) (E.ierror_lv (Lvar x)) in wi2i_vari x. -Definition wi2i_lv (ety : extended_type positive) (lv : lval) : cexec (safety_cond * lval) := +Definition wi2i_lv (ety : extended_type) (lv : lval) : cexec (safety_cond * lval) := let s := sign_of_etype ety in match lv with | Lnone vi ty => @@ -264,8 +265,8 @@ Fixpoint wi2i_eassert (e:eassert) : cexec (safety_cond * eassert) := ok ([::], Pis_var_init x) | Pis_mem_init e1 e2 => - Let _ := assert [&& etype_of_expr m e1 == ETword _ None Uptr - & etype_of_expr m e2 == ETint _] (E.ierror_s "ill typed is_mem_init") in + Let _ := assert [&& etype_of_expr m e1 == ETword None Uptr + & etype_of_expr m e2 == ETint] (E.ierror_s "ill typed is_mem_init") in Let e1 := wi2i_e e1 in Let e2 := wi2i_e e2 in ok (e1.1 ++ e2.1, Pis_mem_init e1.2 e2.2) @@ -279,7 +280,7 @@ Definition wi2i_a_and (a : assertion) := Let e := wi2i_eassert a.2 in ok (a.1, aands (rcons (map Pexpr e.1) e.2)). -Context (sigs : funname -> option (list (extended_type positive) * list (extended_type positive))). +Context (sigs : funname -> option (list extended_type * list extended_type)). Definition get_sig f := match sigs f with @@ -358,13 +359,13 @@ Fixpoint wi2i_ir (ir:instr_r) : cexec (safety_cond * instr_r) := Let xs := wi2i_lvs "invalid dest in Copn" true tout_op.1 xs in ok (es'.1 ++ xs.1, Copn xs.2 t tout_op.2 es'.2) - | Csyscall xs o es => + | Csyscall xs o al es => Let _ := assert (all (fun e => sign_of_expr m e == None) es) (E.ierror_s "invalid args in Csyscall") in Let es := wi2i_es wi2i_e es in - let xtys := map (to_etype None) (syscall_sig_u o).(scs_tout) in + let xtys := map (to_etype None) (syscall_sig_u N o).(scs_tout) in Let xs := wi2i_lvs "invalid dest in Csyscall" true xtys xs in - ok (es.1 ++ xs.1, Csyscall xs.2 o es.2) + ok (es.1 ++ xs.1, Csyscall xs.2 o al es.2) | Cassert a => Let a := wi2i_a_and a in @@ -377,7 +378,7 @@ Fixpoint wi2i_ir (ir:instr_r) : cexec (safety_cond * instr_r) := ok (b.1, Cif b.2 c1 c2) | Cfor x (dir, e1, e2) c => - Let _ := assert [&& in_FV_var x, vtype x == aint, etype_of_expr m e1 == ETint _ & etype_of_expr m e2 == ETint _] + Let _ := assert [&& in_FV_var x, vtype x == aint, etype_of_expr m e1 == ETint & etype_of_expr m e2 == ETint] (E.ierror_s "invalid loop counter") in Let e1 := wi2i_e e1 in Let e2 := wi2i_e e2 in @@ -390,13 +391,13 @@ Fixpoint wi2i_ir (ir:instr_r) : cexec (safety_cond * instr_r) := Let c' := wi2i_c wi2i_i c' in ok ([::], Cwhile a (c ++ safe_assert ii' (map Pexpr e.1)) e.2 ii' c') - | Ccall xs f es => + | Ccall xs f al es => Let sig := get_sig f in Let _ := assert (all2 (fun ety e => esubtype ety (etype_of_expr m e)) sig.1 es) (E.ierror_s "invalid args in Ccall") in Let es := wi2i_es wi2i_e es in Let xs := wi2i_lvs "invalid dest in Ccall" false sig.2 xs in - ok (es.1 ++ xs.1, Ccall xs.2 f es.2) + ok (es.1 ++ xs.1, Ccall xs.2 f al es.2) end with wi2i_i (i:instr) : cexec cmd := @@ -418,7 +419,7 @@ Definition wi2i_ci ci sig := Definition wi2i_fun (fn:funname) (f: fundef) := add_funname fn ( Let sig := get_sig fn in - let 'MkFun ii ci si p c so r ev := f in + let 'MkFun ii ci al si p c so r ev := f in Let ci := match ci with | None => ok None (*TODO: add conditions for params and return values that are wint, maybe do this when default contract are inferred*) @@ -438,10 +439,10 @@ Definition wi2i_fun (fn:funname) (f: fundef) := let mk := map (fun ety => wi2i_type (sign_of_etype ety) (to_atype ety)) in let tin := mk sig.1 in let tout := mk sig.2 in - ok (MkFun ii ci tin p c tout r ev)). + ok (MkFun ii ci al tin p c tout r ev)). Definition build_sig (fd : funname * fundef) := - let 'MkFun ii ci si p c so r ev := fd.2 in + let 'MkFun ii ci al si p c so r ev := fd.2 in let mk := map2 (fun (x:var_i) ty => to_etype (sign_of_var m x) ty) in (fd.1, (mk p si, mk r so)). diff --git a/proofs/compiler/wint_word.v b/proofs/compiler/wint_word.v index b7dc68cb58..463b25070b 100644 --- a/proofs/compiler/wint_word.v +++ b/proofs/compiler/wint_word.v @@ -84,8 +84,8 @@ Fixpoint wi2w_ir (ir:instr_r) : instr_r := | Copn xs t o es => Copn (map wi2w_lv xs) t o (map wi2w_e es) - | Csyscall xs o es => - Csyscall (map wi2w_lv xs) o (map wi2w_e es) + | Csyscall xs o al es => + Csyscall (map wi2w_lv xs) o al (map wi2w_e es) | Cassert (msg, e) => Cassert (msg, e) @@ -99,8 +99,8 @@ Fixpoint wi2w_ir (ir:instr_r) : instr_r := | Cwhile a c e info c' => Cwhile a (map wi2w_i c) (wi2w_e e) info (map wi2w_i c') - | Ccall xs f es => - Ccall (map wi2w_lv xs) f (map wi2w_e es) + | Ccall xs f al es => + Ccall (map wi2w_lv xs) f al (map wi2w_e es) end diff --git a/proofs/compiler/x86_instr_decl.v b/proofs/compiler/x86_instr_decl.v index 880d727755..649998cab3 100644 --- a/proofs/compiler/x86_instr_decl.v +++ b/proofs/compiler/x86_instr_decl.v @@ -1149,7 +1149,7 @@ Definition Ox86_SAR_instr := Definition check_shld (_:wsize):= [::[::rm false; r; ri U8]]. -Definition safe_shxd sz : seq safe_cond := +Definition safe_shxd sz : seq (safe_cond Z) := match sz with | U16 => [:: InRangeMod32 U8 0 16 2 ] | _ => [::] @@ -1193,7 +1193,7 @@ Opaque Z.sub. Transparent Z.sub. Qed. -Lemma safe_wf_shxdP ws : all (λ sc : safe_cond, values.sc_needed_args sc <= size (w2w8_ty ws)) (safe_shxd ws). +Lemma safe_wf_shxdP ws : all (λ sc : safe_cond Z, values.sc_needed_args sc <= size (w2w8_ty ws)) (safe_shxd ws). Proof. by case: ws. Qed. Lemma x86_SHLD_safe (ws : wsize) : diff --git a/proofs/lang/expr.v b/proofs/lang/expr.v index 4cee92733f..c1189c2986 100644 --- a/proofs/lang/expr.v +++ b/proofs/lang/expr.v @@ -14,7 +14,7 @@ Definition uint_of_word ws := Oint_of_word Unsigned ws. Definition sint_of_word ws := Oint_of_word Signed ws. (* Type of unany operators: input, output *) -Definition etype_of_wiop1 {len:Type} (s: signedness) (o:wiop1) : extended_type len * extended_type len := +Definition etype_of_wiop1 (s: signedness) (o:wiop1) : extended_type * extended_type := match o with | WIwint_of_int sz => (tint, twint s sz) | WIint_of_wint sz => (twint s sz, tint) @@ -45,7 +45,7 @@ Definition type_of_opk (k:op_kind) := | Op_w sz => aword sz end. -Definition etype_of_opk {len} (k:op_kind) : extended_type len := +Definition etype_of_opk (k:op_kind) : extended_type := match k with | Op_int => tint | Op_w sz => tword sz @@ -55,7 +55,7 @@ Lemma e_type_of_opk k : type_of_opk k = to_atype (etype_of_opk k). Proof. by case: k. Qed. (* Type of unany operators: input, output *) -Definition etype_of_op1 {len} (o: sop1) : extended_type len * extended_type len := +Definition etype_of_op1 (o: sop1) : extended_type * extended_type := match o with | Oword_of_int sz => (tint, tword sz) | Oint_of_word _ sz => (tword sz, tint) @@ -91,8 +91,8 @@ Proof. Qed. (* Type of binany operators: inputs, output *) -Definition etype_of_wiop2 {len} s sz (o : wiop2) : - extended_type len * extended_type len * extended_type len := +Definition etype_of_wiop2 s sz (o : wiop2) : + extended_type * extended_type * extended_type := match o with | WIadd | WImul | WIsub | WIdiv | WImod => let t := twint s sz in (t, t, t) @@ -139,7 +139,7 @@ Definition opk_of_cmpk k := end. (* Type of binany operators: inputs, output *) -Definition etype_of_op2 {len} (o : sop2) : extended_type len * extended_type len * extended_type len := +Definition etype_of_op2 (o : sop2) : extended_type * extended_type * extended_type := match o with | Obeq | Oand | Oor => (tbool, tbool, tbool) | Oadd k | Omul k | Osub k | Odiv _ k | Omod _ k => @@ -204,7 +204,7 @@ Definition type_of_opN (op: opN) : seq atype * atype := | Opack ws p => let n := nat_of_wsize ws %/ nat_of_pelem p in (nseq n aint, aword ws) - | Oarray len => (nseq (Pos.to_nat len) (aword U8), aarr U8 len) + | Oarray len => (nseq (Z.to_nat len) (aword U8), aarr U8 (ALConst len)) | Ocombine_flags c => (tin_combine_flags, abool) end. @@ -262,10 +262,10 @@ Definition is_glob (x:gvar) := x.(gs) == Sglob. Inductive pexpr : Type := | Pconst :> Z -> pexpr | Pbool :> bool -> pexpr -| Parr_init : wsize -> positive → pexpr +| Parr_init : wsize -> array_length → pexpr | Pvar :> gvar -> pexpr | Pget : aligned -> arr_access -> wsize -> gvar -> pexpr -> pexpr -| Psub : arr_access -> wsize -> positive -> gvar -> pexpr -> pexpr +| Psub : arr_access -> wsize -> array_length -> gvar -> pexpr -> pexpr | Pload : aligned -> wsize -> pexpr -> pexpr | Papp1 : sop1 -> pexpr -> pexpr | Papp2 : sop2 -> pexpr -> pexpr -> pexpr @@ -315,7 +315,7 @@ Variant lval : Type := | Lvar `(var_i) | Lmem of aligned & wsize & var_info & pexpr | Laset of aligned & arr_access & wsize & var_i & pexpr -| Lasub of arr_access & wsize & positive & var_i & pexpr. +| Lasub of arr_access & wsize & array_length & var_i & pexpr. Coercion Lvar : var_i >-> lval. @@ -412,12 +412,12 @@ Context `{asmop:asmOp}. Inductive instr_r := | Cassgn : lval -> assgn_tag -> atype -> pexpr -> instr_r | Copn : lvals -> assgn_tag -> sopn -> pexprs -> instr_r -| Csyscall : lvals -> syscall_t -> pexprs -> instr_r +| Csyscall : lvals -> syscall_t -> seq array_length -> pexprs -> instr_r | Cassert : assertion -> instr_r | Cif : pexpr -> seq instr -> seq instr -> instr_r | Cfor : var_i -> range -> seq instr -> instr_r | Cwhile : align -> seq instr -> pexpr -> instr_info -> seq instr -> instr_r -| Ccall : lvals -> funname -> pexprs -> instr_r +| Ccall : lvals -> funname -> seq array_length -> pexprs -> instr_r with instr := MkI : instr_info -> instr_r -> instr. @@ -435,12 +435,12 @@ Section CMD_RECT. Hypothesis Hcons: forall i c, Pi i -> Pc c -> Pc (i::c). Hypothesis Hasgn: forall x tg ty e, Pr (Cassgn x tg ty e). Hypothesis Hopn : forall xs t o es, Pr (Copn xs t o es). - Hypothesis Hsyscall : forall xs o es, Pr (Csyscall xs o es). + Hypothesis Hsyscall : forall xs o al es, Pr (Csyscall xs o al es). Hypothesis Hassert : forall a, Pr (Cassert a). Hypothesis Hif : forall e c1 c2, Pc c1 -> Pc c2 -> Pr (Cif e c1 c2). Hypothesis Hfor : forall v dir lo hi c, Pc c -> Pr (Cfor v (dir,lo,hi) c). Hypothesis Hwhile : forall a c e info c', Pc c -> Pc c' -> Pr (Cwhile a c e info c'). - Hypothesis Hcall: forall xs f es, Pr (Ccall xs f es). + Hypothesis Hcall: forall xs f al es, Pr (Ccall xs f al es). Section C. Variable instr_rect : forall i, Pi i. @@ -460,12 +460,12 @@ Section CMD_RECT. match i return Pr i with | Cassgn x tg ty e => Hasgn x tg ty e | Copn xs t o es => Hopn xs t o es - | Csyscall xs o es => Hsyscall xs o es + | Csyscall xs o al es => Hsyscall xs o al es | Cassert a => Hassert a | Cif e c1 c2 => @Hif e c1 c2 (cmd_rect_aux instr_Rect c1) (cmd_rect_aux instr_Rect c2) | Cfor i (dir,lo,hi) c => @Hfor i dir lo hi c (cmd_rect_aux instr_Rect c) | Cwhile a c e info c' => @Hwhile a c e info c' (cmd_rect_aux instr_Rect c) (cmd_rect_aux instr_Rect c') - | Ccall xs f es => @Hcall xs f es + | Ccall xs f al es => @Hcall xs f al es end. Definition cmd_rect := cmd_rect_aux instr_Rect. @@ -512,6 +512,7 @@ Record fun_contract := MkContra { Record _fundef (extra_fun_t: Type) := MkFun { f_info : fun_info; f_contract : option fun_contract; + f_al : seq length_var; f_tyin : seq atype; f_params : seq var_i; f_body : cmd; @@ -696,6 +697,7 @@ Definition to_sprog (p:_sprog) : sprog := p. Definition with_body eft (fd:_fundef eft) (body : cmd) := {| f_info := fd.(f_info); f_contract := fd.(f_contract); + f_al := fd.(f_al); f_tyin := fd.(f_tyin); f_params := fd.(f_params); f_body := body; @@ -707,6 +709,7 @@ Definition with_body eft (fd:_fundef eft) (body : cmd) := {| Definition swith_extra {_: PointerData} (fd:ufundef) f_extra : sfundef := {| f_info := fd.(f_info); f_contract := fd.(f_contract); + f_al := fd.(f_al); f_tyin := fd.(f_tyin); f_params := fd.(f_params); f_body := fd.(f_body); @@ -845,12 +848,12 @@ Fixpoint write_i_rec s (i:instr_r) := match i with | Cassgn x _ _ _ => vrv_rec s x | Copn xs _ _ _ => vrvs_rec s xs - | Csyscall xs _ _ => vrvs_rec s xs + | Csyscall xs _ _ _ => vrvs_rec s xs | Cassert _ => s | Cif _ c1 c2 => foldl write_I_rec (foldl write_I_rec s c2) c1 | Cfor x _ c => foldl write_I_rec (Sv.add x s) c | Cwhile _ c _ _ c' => foldl write_I_rec (foldl write_I_rec s c') c - | Ccall x _ _ => vrvs_rec s x + | Ccall x _ _ _ => vrvs_rec s x end with write_I_rec s i := match i with @@ -932,7 +935,7 @@ Fixpoint read_i_rec (s:Sv.t) (i:instr_r) : Sv.t := match i with | Cassgn x _ _ e => read_rv_rec (read_e_rec s e) x | Copn xs _ _ es => read_es_rec (read_rvs_rec s xs) es - | Csyscall xs _ es => read_es_rec (read_rvs_rec s xs) es + | Csyscall xs _ _ es => read_es_rec (read_rvs_rec s xs) es | Cassert a => read_eassert_rec s a.2 | Cif b c1 c2 => let s := foldl read_I_rec s c1 in @@ -945,7 +948,7 @@ Fixpoint read_i_rec (s:Sv.t) (i:instr_r) : Sv.t := let s := foldl read_I_rec s c in let s := foldl read_I_rec s c' in read_e_rec s e - | Ccall xs _ es => read_es_rec (read_rvs_rec s xs) es + | Ccall xs _ _ es => read_es_rec (read_rvs_rec s xs) es end with read_I_rec (s:Sv.t) (i:instr) : Sv.t := match i with @@ -1044,8 +1047,8 @@ Fixpoint eq_instr_r (i1 i2:instr_r) := (tag1 == tag2) && (ty1 == ty2) && eq_lval x1 x2 && eq_expr e1 e2 | Copn x1 tag1 o1 e1, Copn x2 tag2 o2 e2 => all2 eq_lval x1 x2 && (tag1 == tag2) && (o1 == o2) && all2 eq_expr e1 e2 - | Csyscall xs1 o1 es1, Csyscall xs2 o2 es2 => - all2 eq_lval xs1 xs2 && (o1 == o2) && all2 eq_expr es1 es2 + | Csyscall xs1 o1 al1 es1, Csyscall xs2 o2 al2 es2 => + all2 eq_lval xs1 xs2 && (o1 == o2) && (al1 == al2) && all2 eq_expr es1 es2 | Cassert a1, Cassert a2 => (a1.1 == a2.1) && eq_eassert a1.2 a2.2 | Cif e1 c11 c12, Cif e2 c21 c22 => eq_expr e1 e2 && all2 eq_instr c11 c21 && all2 eq_instr c12 c22 @@ -1053,8 +1056,8 @@ Fixpoint eq_instr_r (i1 i2:instr_r) := (v_var i1 == v_var i2) && (dir1 == dir2) && eq_expr lo1 lo2 && eq_expr hi1 hi2 && all2 eq_instr c1 c2 | Cwhile a1 c1 e1 _ c1' , Cwhile a2 c2 e2 _ c2' => (a1 == a2) && all2 eq_instr c1 c2 && eq_expr e1 e2 && all2 eq_instr c1' c2' - | Ccall x1 f1 arg1, Ccall x2 f2 arg2 => - all2 eq_lval x1 x2 && (f1 == f2) && all2 eq_expr arg1 arg2 + | Ccall x1 f1 al1 arg1, Ccall x2 f2 al2 arg2 => + all2 eq_lval x1 x2 && (f1 == f2) && (al1 == al2) && all2 eq_expr arg1 arg2 | _, _ => false end with eq_instr i1 i2 := diff --git a/proofs/lang/expr_facts.v b/proofs/lang/expr_facts.v index 50ecb869dd..6d8cb195ba 100644 --- a/proofs/lang/expr_facts.v +++ b/proofs/lang/expr_facts.v @@ -243,8 +243,8 @@ Let Pc c := forall s, Sv.Equal (foldl write_I_rec s c) (Sv.union s (write_c c)). Lemma write_c_recE s c : Sv.Equal (write_c_rec s c) (Sv.union s (write_c c)). Proof. apply: (cmd_rect (Pr := Pr) (Pi := Pi) (Pc := Pc)) => /= {c s} - [ i ii Hi | | i c Hi Hc | x tg ty e | xs t o es | p x e | a | e c1 c2 Hc1 Hc2 - | v dir lo hi c Hc | a c e ii c' Hc Hc' | ii xs f es ] s; + [ i ii Hi | | i c Hi Hc | x tg ty e | xs t o es | xs o al es | a | e c1 c2 Hc1 Hc2 + | v dir lo hi c Hc | a c e ii c' Hc Hc' | xs f al es ] s; rewrite /write_I /write_I_rec /write_i /write_i_rec -/write_i_rec -/write_I_rec /write_c /= ?Hc1 ?Hc2 /write_c_rec ?Hc ?Hc' ?Hi -?vrv_recE -?vrvs_recE //; by clear; SvD.fsetdec. @@ -272,7 +272,7 @@ Proof. done. Qed. Lemma write_i_opn xs t o es : write_i (Copn xs t o es) = vrvs xs. Proof. done. Qed. -Lemma write_i_syscall xs o es : write_i (Csyscall xs o es) = vrvs xs. +Lemma write_i_syscall xs o al es : write_i (Csyscall xs o al es) = vrvs xs. Proof. done. Qed. Lemma write_i_assert a : write_i (Cassert a) = Sv.empty. @@ -299,8 +299,8 @@ Proof. clear; SvD.fsetdec. Qed. -Lemma write_i_call xs f es : - write_i (Ccall xs f es) = vrvs xs. +Lemma write_i_call xs f al es : + write_i (Ccall xs f al es) = vrvs xs. Proof. done. Qed. Lemma write_Ii ii i: write_I (MkI ii i) = write_i i. @@ -419,8 +419,8 @@ Let Pc c := forall s, Sv.Equal (foldl read_I_rec s c) (Sv.union s (read_c c)). Lemma read_cE s c : Sv.Equal (read_c_rec s c) (Sv.union s (read_c c)). Proof. apply (cmd_rect (Pr := Pr) (Pi := Pi) (Pc := Pc)) => /= {c s} - [ i ii Hi | | i c Hi Hc | x tg ty e | xs t o es | p x e | a | e c1 c2 Hc1 Hc2 - | v dir lo hi c Hc | a c e ii c' Hc Hc' | ii xs f es ] s; + [ i ii Hi | | i c Hi Hc | x tg ty e | xs t o es | xs o al es | a | e c1 c2 Hc1 Hc2 + | v dir lo hi c Hc | a c e ii c' Hc Hc' | xs f al es ] s; rewrite /read_I /read_I_rec /read_i /read_i_rec -/read_i_rec -/read_I_rec /read_c /= ?read_rvE ?read_eE ?read_esE ?read_eassertE ?read_rvE ?read_rvsE ?Hc2 ?Hc1 /read_c_rec ?Hc' ?Hc ?Hi //; by clear; SvD.fsetdec. @@ -446,8 +446,8 @@ Lemma read_i_opn xs t o es: Sv.Equal (read_i (Copn xs t o es)) (Sv.union (read_rvs xs) (read_es es)). Proof. by rewrite /read_i /read_i_rec read_esE read_rvsE; clear; SvD.fsetdec. Qed. -Lemma read_i_syscall xs o es: - Sv.Equal (read_i (Csyscall xs o es)) (Sv.union (read_rvs xs) (read_es es)). +Lemma read_i_syscall xs o al es: + Sv.Equal (read_i (Csyscall xs o al es)) (Sv.union (read_rvs xs) (read_es es)). Proof. rewrite /read_i /write_i /read_i_rec read_esE read_rvsE; clear; SvD.fsetdec. Qed. Lemma read_i_assert a : @@ -476,8 +476,8 @@ Proof. rewrite /read_i /read_i_rec -/read_c_rec !read_eE read_cE; clear; SvD.fsetdec. Qed. -Lemma read_i_call xs f es : - Sv.Equal (read_i (Ccall xs f es)) (Sv.union (read_rvs xs) (read_es es)). +Lemma read_i_call xs f al es : + Sv.Equal (read_i (Ccall xs f al es)) (Sv.union (read_rvs xs) (read_es es)). Proof. rewrite /read_i /read_i_rec read_esE read_rvsE; clear; SvD.fsetdec. Qed. Lemma read_Ii ii i: read_I (MkI ii i) = read_i i. @@ -521,8 +521,8 @@ Lemma vars_I_opn ii xs t o es: Sv.Equal (vars_I (MkI ii (Copn xs t o es))) (Sv.union (vars_lvals xs) (read_es es)). Proof. by rewrite /vars_I read_Ii write_Ii read_i_opn write_i_opn /vars_lvals; clear; SvD.fsetdec. Qed. -Lemma vars_I_syscall ii xs o es: - Sv.Equal (vars_I (MkI ii (Csyscall xs o es))) (Sv.union (vars_lvals xs) (read_es es)). +Lemma vars_I_syscall ii xs o al es: + Sv.Equal (vars_I (MkI ii (Csyscall xs o al es))) (Sv.union (vars_lvals xs) (read_es es)). Proof. by rewrite /vars_I read_Ii write_Ii read_i_syscall write_i_syscall /vars_lvals; clear; SvD.fsetdec. Qed. Lemma vars_I_assert ii a: @@ -550,8 +550,8 @@ Lemma vars_I_for ii i d lo hi c: (Sv.union (Sv.union (vars_c c) (Sv.singleton i)) (Sv.union (read_e lo) (read_e hi))). Proof. rewrite /vars_I read_Ii write_Ii read_i_for write_i_for /vars_c; clear; SvD.fsetdec. Qed. -Lemma vars_I_call ii xs fn args: - Sv.Equal (vars_I (MkI ii (Ccall xs fn args))) (Sv.union (vars_lvals xs) (read_es args)). +Lemma vars_I_call ii xs fn al args: + Sv.Equal (vars_I (MkI ii (Ccall xs fn al args))) (Sv.union (vars_lvals xs) (read_es args)). Proof. rewrite /vars_I read_Ii write_Ii read_i_call write_i_call /vars_lvals; clear; SvD.fsetdec. Qed. Lemma vars_pP p fn fd : get_fundef p fn = Some fd -> Sv.Subset (vars_fd fd) (vars_p p). @@ -920,8 +920,8 @@ Proof. by move=> ????; rewrite /Pr /= !eqxx eq_lval_refl eq_expr_refl. Qed. Lemma Hrefl_opn : forall xs t o es, Pr (Copn xs t o es). Proof. by move=> ????; rewrite /Pr /= !eqxx (all2_refl eq_lval_refl) (all2_refl eq_expr_refl). Qed. -Lemma Hrefl_syscall : forall xs o es, Pr (Csyscall xs o es). -Proof. by move=> ???; rewrite /Pr /= eqxx (all2_refl eq_lval_refl) (all2_refl eq_expr_refl). Qed. +Lemma Hrefl_syscall : forall xs o al es, Pr (Csyscall xs o al es). +Proof. by move=> ????; rewrite /Pr /= !eqxx (all2_refl eq_lval_refl) (all2_refl eq_expr_refl). Qed. Lemma Hrefl_assert : forall a, Pr (Cassert a). Proof. by move=> ?; rewrite /Pr /= eqxx eq_eassert_refl. Qed. @@ -935,8 +935,8 @@ Proof. by move=> ?????; rewrite /Pc /Pr /= !eqxx !eq_expr_refl -/(eq_cmd _ _) => Lemma Hrefl_while : forall a c e info c', Pc c -> Pc c' -> Pr (Cwhile a c e info c'). Proof. by move=> ?????; rewrite /Pc /Pr /= eqxx eq_expr_refl -!/(eq_cmd _ _) => -> ->. Qed. -Lemma Hrefl_call: forall xs f es, Pr (Ccall xs f es). -Proof. by move=> ???; rewrite /Pr /= eqxx (all2_refl eq_lval_refl) (all2_refl eq_expr_refl). Qed. +Lemma Hrefl_call: forall xs f al es, Pr (Ccall xs f al es). +Proof. by move=> ????; rewrite /Pr /= !eqxx (all2_refl eq_lval_refl) (all2_refl eq_expr_refl). Qed. Lemma eq_instr_r_refl i : eq_instr_r i i. Proof. @@ -989,10 +989,10 @@ Proof. by rewrite !eqxx. Qed. -Lemma Hsymm_syscall : forall xs o es, Pr (Csyscall xs o es). +Lemma Hsymm_syscall : forall xs o al es, Pr (Csyscall xs o al es). Proof. - move=> ??? [] //= ??? /andP[] /andP[] /(all2_symm eq_lval_symm) -> /eqP -> /(all2_symm eq_expr_symm) ->. - by rewrite eqxx. + move=> ???? [] //= ???? /andP[] /andP[] /andP[] /(all2_symm eq_lval_symm) -> /eqP -> /eqP -> /(all2_symm eq_expr_symm) ->. + by rewrite !eqxx. Qed. Lemma Hsymm_assert : forall a, Pr (Cassert a). @@ -1017,10 +1017,10 @@ Proof. by rewrite eqxx -!/(eq_cmd _ _) hc hc'. Qed. -Lemma Hsymm_call: forall xs f es, Pr (Ccall xs f es). +Lemma Hsymm_call: forall xs f al es, Pr (Ccall xs f al es). Proof. - move=> ??? [] //= ??? /andP[] /andP[] /(all2_symm eq_lval_symm) -> /eqP -> /(all2_symm eq_expr_symm) ->. - by rewrite eqxx. + move=> ???? [] //= ???? /andP[] /andP[] /andP[] /(all2_symm eq_lval_symm) -> /eqP -> /eqP -> /(all2_symm eq_expr_symm) ->. + by rewrite !eqxx. Qed. Lemma eq_instr_r_symm i1 i2 : eq_instr_r i1 i2 -> eq_instr_r i2 i1. @@ -1077,12 +1077,12 @@ Proof. by rewrite !eqxx (all2_trans eq_lval_trans h12 h23) (all2_trans eq_expr_trans h12' h23'). Qed. -Lemma Htrans_syscall : forall xs o es, Pr (Csyscall xs o es). +Lemma Htrans_syscall : forall xs o al es, Pr (Csyscall xs o al es). Proof. - move=> ??? [] //= ??? [] //= ??? - /andP[] /andP[] h12 /eqP -> h12' - /andP[] /andP[] h23 /eqP -> h23'. - by rewrite eqxx (all2_trans eq_lval_trans h12 h23) (all2_trans eq_expr_trans h12' h23'). + move=> ???? [] //= ???? [] //= ???? + /andP[] /andP[] /andP[] h12 /eqP -> /eqP -> h12' + /andP[] /andP[] /andP[] h23 /eqP -> /eqP -> h23'. + by rewrite !eqxx (all2_trans eq_lval_trans h12 h23) (all2_trans eq_expr_trans h12' h23'). Qed. Lemma Htrans_assert : forall a, Pr (Cassert a). @@ -1115,12 +1115,12 @@ Proof. by rewrite eqxx (eq_expr_trans h12' h23') -!/(eq_cmd _ _) (hc _ _ h12 h23) (hc' _ _ h12'' h23''). Qed. -Lemma Htrans_call: forall xs f es, Pr (Ccall xs f es). +Lemma Htrans_call: forall xs f al es, Pr (Ccall xs f al es). Proof. - move=> ??? [] //= ??? [] //= ??? - /andP[] /andP[] h12 /eqP -> h12' - /andP[] /andP[] h23 /eqP -> h23'. - by rewrite eqxx (all2_trans eq_lval_trans h12 h23) (all2_trans eq_expr_trans h12' h23'). + move=> ???? [] //= ???? [] //= ???? + /andP[] /andP[] /andP[] h12 /eqP -> /eqP -> h12' + /andP[] /andP[] /andP[] h23 /eqP -> /eqP -> h23'. + by rewrite !eqxx (all2_trans eq_lval_trans h12 h23) (all2_trans eq_expr_trans h12' h23'). Qed. Lemma eq_instr_r_trans i2 i1 i3 : @@ -1177,9 +1177,9 @@ Proof. by rewrite !write_i_opn (eq_lvals_vrvs h). Qed. -Lemma Hwrite_syscall : forall xs o es, Pr (Csyscall xs o es). +Lemma Hwrite_syscall : forall xs o al es, Pr (Csyscall xs o al es). Proof. - move=> ??? [] //= ??? /andP[] /andP[] h _ _. + move=> ???? [] //= ???? /andP[] /andP[] /andP[] h _ _. by rewrite !write_i_syscall (eq_lvals_vrvs h). Qed. @@ -1204,9 +1204,9 @@ Proof. by rewrite !write_i_while hc hc'. Qed. -Lemma Hwrite_call: forall xs f es, Pr (Ccall xs f es). +Lemma Hwrite_call: forall xs f al es, Pr (Ccall xs f al es). Proof. - move=> ??? [] //= ??? /andP[] /andP[] h _ _. + move=> ???? [] //= ???? /andP[] /andP[] /andP[] h _ _. by rewrite !write_i_call (eq_lvals_vrvs h). Qed. diff --git a/proofs/lang/extraction.v b/proofs/lang/extraction.v index e1dc4e613e..08dccb4ac1 100644 --- a/proofs/lang/extraction.v +++ b/proofs/lang/extraction.v @@ -8,7 +8,6 @@ From Coq Require ExtrOCamlInt63. (* This is a hack to force the extraction to keep the singleton here, This need should be removed if we add more constructor to syscall_t *) -Extract Inductive syscall.syscall_t => "(Wsize.wsize * BinNums.positive) Syscall_t.syscall_t" ["Syscall_t.RandomBytes"]. Set Extraction File Comment "This prelude is added at extraction time. See lang/extraction.v. *) [@@@ocaml.warning ""-9-20-27-32-33-34-37-39-50-67""] (* End of prelude. ". Extraction Inline ssrbool.is_left. diff --git a/proofs/lang/global.v b/proofs/lang/global.v index 1e3b9c7ac7..5134985a09 100644 --- a/proofs/lang/global.v +++ b/proofs/lang/global.v @@ -8,7 +8,7 @@ Require Export xseq word utils var warray_. Variant glob_value := | Gword : forall (ws:wsize), word ws -> glob_value - | Garr : forall (p:positive), WArray.array p -> glob_value. + | Garr : forall (len:Z), WArray.array len -> glob_value. (* ---------------------------------------------------------------------- *) diff --git a/proofs/lang/operators.v b/proofs/lang/operators.v index f8c0e6c3ff..e58567ae04 100644 --- a/proofs/lang/operators.v +++ b/proofs/lang/operators.v @@ -1,4 +1,4 @@ -Require Import utils wsize. +Require Import utils wsize type. From elpi.apps Require Import derive.std. From HB Require Import structures. From mathcomp Require Import eqtype. @@ -119,14 +119,14 @@ Variant combine_flags := #[only(eqbOK)] derive Variant opN := | Opack of wsize & pelem (* Pack words of size pelem into one word of wsize *) -| Oarray of positive (* Literal array of bytes *) +| Oarray of Z (* Literal array of bytes *) | Ocombine_flags of combine_flags . #[only(eqbOK)] derive Variant opN_safety := -| Ois_arr_init of positive -| Ois_barr_init of positive +| Ois_arr_init of array_length +| Ois_barr_init of array_length . HB.instance Definition _ := hasDecEq.Build op_kind op_kind_eqb_OK. diff --git a/proofs/lang/psem_defs.v b/proofs/lang/psem_defs.v index 0a15e142ae..94adc8c6b4 100644 --- a/proofs/lang/psem_defs.v +++ b/proofs/lang/psem_defs.v @@ -16,24 +16,24 @@ Open Scope vm_scope. (* ** Parameter expressions * -------------------------------------------------------------------- *) -Definition sem_sop1 (o: sop1) (v: value) : exec value := +Definition sem_sop1 env (o: sop1) (v: value) : exec value := Let x := of_val _ v in - Let r := sem_sop1_typed o x in + Let r := sem_sop1_typed env o x in ok (to_val r). -Definition sem_sop2 (o: sop2) (v1 v2: value) : exec value := +Definition sem_sop2 env (o: sop2) (v1 v2: value) : exec value := Let x1 := of_val _ v1 in Let x2 := of_val _ v2 in - Let r := sem_sop2_typed o x1 x2 in + Let r := sem_sop2_typed env o x1 x2 in ok (to_val r). Definition sem_opN - {cfcd : FlagCombinationParams} (op: opN) (vs: values) : exec value := - Let w := app_sopn _ (sem_opN_typed op) vs in + {cfcd : FlagCombinationParams} env (op: opN) (vs: values) : exec value := + Let w := app_sopn _ (sem_opN_typed env op) vs in ok (to_val w). -Definition sem_opN_safety (op: opN_safety) (vs: values) : exec bool := - app_sopn _ (sem_opN_safety_typed op) vs. +Definition sem_opN_safety env (op: opN_safety) (vs: values) : exec bool := + app_sopn _ (sem_opN_safety_typed env op) vs. (* ** Global access * -------------------------------------------------------------------- *) @@ -46,10 +46,11 @@ Definition gv2val (gd:glob_value) := | Garr p a => Varr a end. -Definition get_global gd g : exec value := +(* FIXME: is it normal that [get_global] depends on an [env]? *) +Definition get_global env gd g : exec value := if get_global_value gd g is Some ga then let v := gv2val ga in - if type_of_val v == eval_atype (vtype g) then ok v + if type_of_val v == eval_atype env (vtype g) then ok v else type_error else type_error. @@ -61,23 +62,24 @@ Context {wsw:WithSubWord}. Record estate {syscall_state : Type} - {ep : EstateParams syscall_state} := Estate + {ep : EstateParams syscall_state} + (env : length_var -> option Z) := Estate { escs : syscall_state; emem : mem; - evm : Vm.t + evm : Vm.t env }. -Arguments Estate {syscall_state}%_type_scope {ep} _ _ _%_vm_scope. +Arguments Estate {syscall_state}%_type_scope {ep} _ _ _ _%_vm_scope. (* ** Variable map * -------------------------------------------------------------------- *) -Definition get_gvar (wdb : bool) (gd : glob_decls) (vm : Vm.t) (x : gvar) := +Definition get_gvar env (wdb : bool) (gd : glob_decls) (vm : Vm.t env) (x : gvar) := if is_lvar x then get_var wdb vm x.(gv) - else get_global gd x.(gv). + else get_global env gd x.(gv). -Definition get_var_is wdb vm := mapM (fun x => get_var wdb vm (v_var x)). +Definition get_var_is env wdb (vm : Vm.t env) := mapM (fun x => get_var wdb vm (v_var x)). Definition on_arr_var A (v:exec value) (f:forall n, WArray.array n -> exec A) := Let v := v in @@ -96,15 +98,16 @@ Section ESTATE_UTILS. Context {syscall_state : Type} - {ep : EstateParams syscall_state}. + {ep : EstateParams syscall_state} + (env : length_var -> option Z). -Definition with_vm (s:estate) vm := +Definition with_vm (s:estate env) (vm : Vm.t env) := {| escs := s.(escs); emem := s.(emem); evm := vm |}. -Definition with_mem (s:estate) m := +Definition with_mem (s:estate env) m := {| escs := s.(escs); emem := m; evm := s.(evm) |}. -Definition with_scs (s:estate) scs := +Definition with_scs (s:estate env) scs := {| escs := scs; emem := s.(emem); evm := s.(evm) |}. End ESTATE_UTILS. @@ -115,15 +118,16 @@ Context {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} + (env : length_var -> option Z) (wdb : bool) (gd : glob_decls). -Fixpoint sem_pexpr (s:estate) (e : pexpr) : exec value := +Fixpoint sem_pexpr (s:estate env) (e : pexpr) : exec value := match e with | Pconst z => ok (Vint z) | Pbool b => ok (Vbool b) - | Parr_init ws n => - let len := Z.to_pos (arr_size ws n) in + | Parr_init ws al => + let len := arr_size ws (eval env al) in ok (Varr (WArray.empty len)) | Pvar v => get_gvar wdb gd s.(evm) v | Pget al aa ws x e => @@ -134,7 +138,7 @@ Fixpoint sem_pexpr (s:estate) (e : pexpr) : exec value := | Psub aa ws len x e => Let (n, t) := wdb, gd, s.[x] in Let i := sem_pexpr s e >>= to_int in - Let t' := WArray.get_sub aa ws len t i in + Let t' := WArray.get_sub aa ws (eval env len) t i in ok (Varr t') | Pload al sz e => Let w2 := sem_pexpr s e >>= to_pointer in @@ -142,16 +146,16 @@ Fixpoint sem_pexpr (s:estate) (e : pexpr) : exec value := ok (@to_val (cword sz) w) | Papp1 o e1 => Let v1 := sem_pexpr s e1 in - sem_sop1 o v1 + sem_sop1 env o v1 | Papp2 o e1 e2 => Let v1 := sem_pexpr s e1 in Let v2 := sem_pexpr s e2 in - sem_sop2 o v1 v2 + sem_sop2 env o v1 v2 | PappN op es => Let vs := mapM (sem_pexpr s) es in - sem_opN op vs + sem_opN env op vs | Pif t e e1 e2 => - let t := eval_atype t in + let t := eval_atype env t in Let b := sem_pexpr s e >>= to_bool in Let v1 := sem_pexpr s e1 >>= truncate_val t in Let v2 := sem_pexpr s e2 >>= truncate_val t in @@ -160,21 +164,21 @@ Fixpoint sem_pexpr (s:estate) (e : pexpr) : exec value := Definition sem_pexprs s := mapM (sem_pexpr s). -Definition write_var (x:var_i) (v:value) (s:estate) : exec estate := +Definition write_var (x:var_i) (v:value) (s:estate env) : exec (estate env) := Let vm := set_var wdb s.(evm) x v in ok (with_vm s vm). Definition write_vars xs vs s := fold2 ErrType write_var xs vs s. -Definition write_none (s : estate) ty v := +Definition write_none (s : estate env) ty v := Let _ := assert (truncatable wdb ty v) ErrType in Let _ := assert (DB wdb v) ErrAddrUndef in ok s. -Definition write_lval (l : lval) (v : value) (s : estate) : exec estate := +Definition write_lval (l : lval) (v : value) (s : estate env) : exec (estate env) := match l with - | Lnone _ ty => write_none s (eval_atype ty) v + | Lnone _ ty => write_none s (eval_atype env ty) v | Lvar x => write_var x v s | Lmem al sz x e => Let p := sem_pexpr s e >>= to_pointer in @@ -190,12 +194,13 @@ Definition write_lval (l : lval) (v : value) (s : estate) : exec estate := | Lasub aa ws len x i => Let (n,t) := wdb, s.[x] in Let i := sem_pexpr s i >>= to_int in - Let t' := to_arr (Z.to_pos (arr_size ws len)) v in + let len := eval env len in + Let t' := to_arr (arr_size ws len) v in Let t := @WArray.set_sub n aa ws len t i t' in write_var x (@to_val (carr n) t) s end. -Definition write_lvals (s : estate) xs vs := +Definition write_lvals (s : estate env) xs vs := fold2 ErrType write_lval xs vs s. End SEM_PEXPR. @@ -209,12 +214,12 @@ Context {spp : SemPexprParams} (gd : glob_decls). -Fixpoint sem_eassert (s : estate) (e : eassert) : exec bool := +Fixpoint sem_eassert env (s : estate env) (e : eassert) : exec bool := match e with | Pexpr e => sem_pexpr true gd s e >>= to_bool | PappN_safety op es => Let vs := mapM (sem_pexpr true gd s) es in - sem_opN_safety op vs + sem_opN_safety env op vs | Pis_var_init x => let v := (evm s).[x] in ok (is_defined v) @@ -228,7 +233,7 @@ Fixpoint sem_eassert (s : estate) (e : eassert) : exec bool := ok (b1 && b2) end. -Definition sem_assert (s : estate) (e : assertion) : exec unit := +Definition sem_assert env (s : estate env) (e : assertion) : exec unit := Let _ := assert (assert_allowed) ErrType in Let b := sem_eassert s e.2 in Let _ := assert b (ErrAssert e.1) in @@ -242,14 +247,15 @@ Context {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} - {asmop : asmOp asm_op}. + {asmop : asmOp asm_op} + (env : length_var -> option Z). Definition exec_sopn (o:sopn) (vs:values) : exec values := Let semi := sopn_sem o in - Let t := app_sopn _ semi vs in + Let t := app_sopn _ (semi env) vs in ok (list_ltuple t). -Definition sem_sopn gd o m lvs args := +Definition sem_sopn gd o (m : estate env) lvs args := sem_pexprs true gd m args >>= exec_sopn o >>= write_lvals true gd m lvs. End EXEC_ASM. diff --git a/proofs/lang/pseudo_operator.v b/proofs/lang/pseudo_operator.v index a73ae75fd0..366ac82524 100644 --- a/proofs/lang/pseudo_operator.v +++ b/proofs/lang/pseudo_operator.v @@ -26,9 +26,9 @@ Canonical spill_op_eqType := @ceqT_eqType _ eqTC_spill_op. #[only(eqbOK)] derive Variant pseudo_operator := | Ospill of spill_op & seq atype -| Ocopy of wsize & positive +| Ocopy of wsize & array_length | Odeclassify of atype -| Odeclassify_mem of positive +| Odeclassify_mem of array_length | Onop | Omulu of wsize (* cpu : [aword; aword] -> [aword;aword] *) | Oaddcarry of wsize (* cpu : [aword; aword; abool] -> [abool;aword] *) diff --git a/proofs/lang/safety_common.v b/proofs/lang/safety_common.v index e88da84c0d..58d4699521 100644 --- a/proofs/lang/safety_common.v +++ b/proofs/lang/safety_common.v @@ -9,13 +9,13 @@ Context (m: var -> option (signedness * var)). Definition safety_cond := seq eassert. -Definition esubtype (ty1 ty2 : extended_type positive) := +Definition esubtype (ty1 ty2 : extended_type) := match ty1, ty2 with | ETword None w, ETword None w' => (w ≤ w')%CMP | ETword (Some sg) w, ETword (Some sg') w' => (sg == sg') && (w == w') | ETint, ETint => true | ETbool, ETbool => true - | ETarr ws l, ETarr ws' l' => arr_size ws l == arr_size ws' l' + | ETarr ws al, ETarr ws' al' => convertible (aarr ws al) (aarr ws' al') | _, _ => false end. @@ -35,17 +35,17 @@ Fixpoint aands es := | e::es => Pand e (aands es) end. -Definition to_etype sg (t:atype) : extended_type positive:= +Definition to_etype sg (t:atype) : extended_type := match t with | abool => tbool | aint => tint | aarr ws l => tarr ws l - | aword ws => ETword _ sg ws + | aword ws => ETword sg ws end. Definition sign_of_var x := Option.map fst (m x). -Definition etype_of_var x : extended_type positive := +Definition etype_of_var x : extended_type := to_etype (sign_of_var x) (vtype x). Definition sign_of_gvar (x : gvar) := @@ -54,13 +54,13 @@ Definition sign_of_gvar (x : gvar) := Definition etype_of_gvar x := to_etype (sign_of_gvar x) (vtype (gv x)). -Definition sign_of_etype (ty: extended_type positive) : option signedness := +Definition sign_of_etype (ty: extended_type) : option signedness := match ty with | ETword (Some s) _ => Some s | _ => None end. -Fixpoint etype_of_expr (e:pexpr) : extended_type positive := +Fixpoint etype_of_expr (e:pexpr) : extended_type := match e with | Pconst _ => tint | Pbool _ => tbool diff --git a/proofs/lang/sem_op_typed.v b/proofs/lang/sem_op_typed.v index d495e8fefd..9e5ec026f0 100644 --- a/proofs/lang/sem_op_typed.v +++ b/proofs/lang/sem_op_typed.v @@ -8,9 +8,9 @@ Import Utf8. Definition mk_sem_sop1 (t1 t2 : Type) (o:t1 -> t2) v1 : exec t2 := ok (o v1). -Definition sem_wiop1_typed (sign : signedness) (o: wiop1) : +Definition sem_wiop1_typed env (sign : signedness) (o: wiop1) : let t := type_of_wiop1 o in - let t := (eval_atype t.1, eval_atype t.2) in + let t := (eval_atype env t.1, eval_atype env t.2) in sem_t t.1 → exec (sem_t t.2) := match o with | WIwint_of_int sz => wint_of_int sign sz @@ -26,9 +26,9 @@ Definition sem_wiop1_typed (sign : signedness) (o: wiop1) : Arguments sem_wiop1_typed : clear implicits. -Definition sem_sop1_typed (o : sop1) : +Definition sem_sop1_typed env (o : sop1) : let t := type_of_op1 o in - let t := (eval_atype t.1, eval_atype t.2) in + let t := (eval_atype env t.1, eval_atype env t.2) in sem_t t.1 → exec (sem_t t.2) := match o with | Oword_of_int sz => mk_sem_sop1 (wrepr sz) @@ -39,7 +39,7 @@ Definition sem_sop1_typed (o : sop1) : | Olnot sz => mk_sem_sop1 (@wnot sz) | Oneg Op_int => mk_sem_sop1 Z.opp | Oneg (Op_w sz) => mk_sem_sop1 -%w - | Owi1 sign o => sem_wiop1_typed sign o + | Owi1 sign o => sem_wiop1_typed env sign o end. Arguments sem_sop1_typed : clear implicits. @@ -90,9 +90,9 @@ Definition mk_sem_wishift sign sz (o:Z -> Z -> Z) (w1 : word sz) (w2 : word U8) Definition mk_sem_wicmp sign sz (o:Z -> Z -> bool) (w1 w2 : word sz) : exec bool := ok (o (int_of_word sign w1) (int_of_word sign w2)). -Definition sem_wiop2_typed (sign : signedness) (sz : wsize) ( o : wiop2) : +Definition sem_wiop2_typed env (sign : signedness) (sz : wsize) ( o : wiop2) : let t := type_of_wiop2 sz o in - let t := (eval_atype t.1.1, eval_atype t.1.2, eval_atype t.2) in + let t := (eval_atype env t.1.1, eval_atype env t.1.2, eval_atype env t.2) in sem_t t.1.1 → sem_t t.1.2 → exec (sem_t t.2) := match o with @@ -115,9 +115,9 @@ Definition sem_wiop2_typed (sign : signedness) (sz : wsize) ( o : wiop2) : Arguments sem_wiop2_typed : clear implicits. -Definition sem_sop2_typed (o: sop2) : +Definition sem_sop2_typed env (o: sop2) : let t := type_of_op2 o in - let t := (eval_atype t.1.1, eval_atype t.1.2, eval_atype t.2) in + let t := (eval_atype env t.1.1, eval_atype env t.1.2, eval_atype env t.2) in sem_t t.1.1 → sem_t t.1.2 → exec (sem_t t.2) := match o with | Obeq => mk_sem_sop2 (@eq_op bool) @@ -168,7 +168,7 @@ Definition sem_sop2_typed (o: sop2) : | Ovlsl ve ws => mk_sem_sop2 (sem_vshl ve) | Ovasr ve ws => mk_sem_sop2 (sem_vsar ve) - | Owi2 s sz o => sem_wiop2_typed s sz o + | Owi2 s sz o => sem_wiop2_typed env s sz o end. Arguments sem_sop2_typed : clear implicits. @@ -180,43 +180,49 @@ Context {cfcd : FlagCombinationParams}. Definition sem_combine_flags (cf : combine_flags) (b0 b1 b2 b3 : bool) : bool := cf_xsem negb andb orb (fun x y => x == y) b0 b1 b2 b3 cf. -Definition sem_opN_typed (o: opN) : +Definition sem_opN_typed env (o: opN) : let t := type_of_opN o in - let t := (map eval_atype t.1, eval_atype t.2) in + let t := (map (eval_atype env) t.1, eval_atype env t.2) in sem_prod t.1 (exec (sem_t t.2)) := match o with | Opack sz pe => let ty := curry (A := cint) (sz %/ pe) (λ vs, ok (wpack sz pe vs)) in ecast l (sem_prod l _) (esym (map_nseq _ _ _)) ty | Oarray len => - let ty := sem_prod_app (collect (Pos.to_nat len) [::]) (λ vs : seq (sem_t (cword U8)), WArray.fill len vs) in + let ty := sem_prod_app (collect (Z.to_nat len) [::]) (λ vs : seq (sem_t (cword U8)), WArray.fill _ vs) in ecast l (sem_prod l _) (esym (map_nseq _ _ _)) ty | Ocombine_flags cf => fun b0 b1 b2 b3 => ok (sem_combine_flags cf b0 b1 b2 b3) end. -Lemma sem_opN_typed_ok (op: opN) : - sem_forall (@is_ok _ _) _ (sem_opN_typed op). +Lemma sem_opN_typed_ok env (op: opN) : + sem_forall (@is_ok _ _) _ (sem_opN_typed env op). Proof. case: op => // [ ws pe | len ] /=; rewrite -> map_nseq => /=. + by case: ws pe => - []. - apply: sem_forall_prod_app (size_collect (Pos.to_nat len) [::]) => bytes /=. - rewrite ssrnat.addn0 /WArray.fill => hlen; rewrite hlen eqxx /=. - by case/is_okP: (WArray.fill_aux_ok (Nat.eq_le_incl _ _ hlen)) => ? ->. + apply: sem_forall_prod_app (size_collect (Z.to_nat len) [::]) => bytes /=. + rewrite ssrnat.addn0 => hlen. + rewrite /WArray.fill arr_sizeE wsize8 Z.mul_1_l hlen /eval /=. + case: ZltP => [hpos|hneg]. + + rewrite eqxx /=. + by case/is_okP: (WArray.fill_aux_ok (Nat.eq_le_incl _ _ hlen)) => ? ->. + move: hlen. + rewrite Z_to_nat_le0 /=; last by Lia.lia. + by move=> /size0nil -> /=. Qed. End WITH_PARAMS. -Definition sem_opN_safety_typed (o: opN_safety) : +Definition sem_opN_safety_typed env (o: opN_safety) : let t := type_of_opN_safety o in - let t := (map eval_atype t.1, eval_atype t.2) in + let t := (map (eval_atype env) t.1, eval_atype env t.2) in sem_prod t.1 (exec (sem_t t.2)) := match o with | Ois_arr_init alen => - fun (a:WArray.array alen) (lo:Z) (len:Z) => + fun (a:WArray.array _) (lo:Z) (len:Z) => ok (all (WArray.is_init a) (ziota lo len)) | Ois_barr_init alen => - fun (a:WArray.array alen) (lo:Z) (len:Z) => + fun (a:WArray.array _) (lo:Z) (len:Z) => ok (all (WArray.is_initb a) (ziota lo len)) end. diff --git a/proofs/lang/sem_type.v b/proofs/lang/sem_type.v index fbdaaa4c65..2401a87d28 100644 --- a/proofs/lang/sem_type.v +++ b/proofs/lang/sem_type.v @@ -4,7 +4,7 @@ From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype ssralg. From mathcomp Require Import word_ssrZ. Require Import xseq. -Require Export strings warray_. +Require Export strings type warray_. Import Utf8. (* ----------------------------------------------------------- *) @@ -101,11 +101,13 @@ Qed. Lemma compat_atype_ctype sw ty1 ty2 : compat_atype sw ty1 ty2 -> - compat_ctype sw (eval_atype ty1) (eval_atype ty2). + forall env, + compat_ctype sw (eval_atype env ty1) (eval_atype env ty2). Proof. - case: sw => /=. + move=> hc env. + case: sw hc => /= hc. + by apply subatype_subctype. - move=> hconv; apply /eqP; move: hconv. + apply /eqP. by apply convertible_eval_atype. Qed. diff --git a/proofs/lang/slh_ops.v b/proofs/lang/slh_ops.v index b359665c84..96c00e6f52 100644 --- a/proofs/lang/slh_ops.v +++ b/proofs/lang/slh_ops.v @@ -20,16 +20,16 @@ Variant slh_op := | SLHupdate | SLHmove | SLHprotect of wsize - | SLHprotect_ptr of wsize & positive - | SLHprotect_ptr_fail of wsize & positive. (* Not exported to the user *) + | SLHprotect_ptr of wsize & array_length + | SLHprotect_ptr_fail of wsize & array_length. (* Not exported to the user *) HB.instance Definition _ := hasDecEq.Build slh_op slh_op_eqb_OK. -Definition is_protect_ptr (slho : slh_op) : option (wsize * positive) := - if slho is SLHprotect_ptr ws p then Some (ws, p) else None. +Definition is_protect_ptr (slho : slh_op) : option (wsize * array_length) := + if slho is SLHprotect_ptr ws al then Some (ws, al) else None. -Lemma is_protect_ptrP op : is_reflect (fun '(ws, p) => SLHprotect_ptr ws p) op (is_protect_ptr op). +Lemma is_protect_ptrP op : is_reflect (fun '(ws, al) => SLHprotect_ptr ws al) op (is_protect_ptr op). Proof. case: op; try by constructor. - by move=> ws len; apply: (Is_reflect_some _ (_, _)). + by move=> ws al; apply: (Is_reflect_some _ (_, _)). Qed. diff --git a/proofs/lang/sopn.v b/proofs/lang/sopn.v index 3ea734c652..069831a77e 100644 --- a/proofs/lang/sopn.v +++ b/proofs/lang/sopn.v @@ -29,6 +29,21 @@ Variant arg_position := | APout of nat | APin of nat. +Definition map_safe_cond {A B} (f : A -> B) c := + match c with + | NotZero ws n => NotZero ws n + | X86Division ws sg => X86Division ws sg + | InRangeMod32 ws z1 z2 n => InRangeMod32 ws z1 z2 n + | ULt ws n z => ULt ws n z + | UGe ws z n => UGe ws z n + | UaddLe ws n1 n2 z => UaddLe ws n1 n2 z + | AllInit ws len n => AllInit ws (f len) n + | ScFalse => ScFalse + end. + +Definition eval_safe_cond (env : length_var -> option Z) c := + map_safe_cond (fun al => eval env al) c. + Record instruction_desc := mkInstruction { str : unit -> string; tin : list atype; @@ -36,26 +51,26 @@ Record instruction_desc := mkInstruction { tout : list atype; i_out : seq arg_desc; conflicts: seq (arg_position * arg_position); - semi : sem_prod (map eval_atype tin) (exec (sem_tuple (map eval_atype tout))); - semu : forall vs vs' v, + semi : forall env, sem_prod (map (eval_atype env) tin) (exec (sem_tuple (map (eval_atype env) tout))); + semu : forall env vs vs' v, List.Forall2 value_uincl vs vs' -> - app_sopn_v semi vs = ok v -> - exists2 v', app_sopn_v semi vs' = ok v' & List.Forall2 value_uincl v v'; + app_sopn_v (semi env) vs = ok v -> + exists2 v', app_sopn_v (semi env) vs' = ok v' & List.Forall2 value_uincl v v'; (* This field allows to ensure the validity of the instruction, it is usefull when the its name allows to encode more instructions than the real existing one. See field id_valid in arch/arch_decl.v *) i_valid : bool; - i_safe : seq safe_cond; + i_safe : seq (safe_cond array_length); (* Extra properties ensuring that previous information are consistent *) i_safe_wf : all (fun sc => ssrnat.leq (sc_needed_args sc) (size tin)) i_safe; (* id_semi does not generates type error *) - i_semi_errty : i_valid -> sem_forall (fun r => r <> Error ErrType) (map eval_atype tin) semi; + i_semi_errty : i_valid -> forall env, sem_forall (fun r => r <> Error ErrType) (map (eval_atype env) tin) (semi env); (* safety condition are sufficient to ensure that no error are raised *) - i_semi_safe : i_valid -> interp_safe_cond_ty i_safe semi; + i_semi_safe : i_valid -> forall env, interp_safe_cond_ty (map (eval_safe_cond env) i_safe) (semi env); }. -Arguments semu _ [vs vs' v] _ _. +Arguments semu _ _ [vs vs' v] _ _. Notation mk_instr_desc str tin i_in tout i_out semi safe valid semi_errty semi_safe := {| str := str; @@ -64,8 +79,8 @@ Notation mk_instr_desc str tin i_in tout i_out semi safe valid semi_errty semi_s tout := tout; i_out := i_out; conflicts := [::]; - semi := semi; - semu := @vuincl_app_sopn_v (map eval_atype tin) (map eval_atype tout) semi refl_equal; + semi := fun env => semi env; + semu := fun env => @vuincl_app_sopn_v (map (eval_atype env) tin) (map (eval_atype env) tout) (semi env) refl_equal; i_safe := safe; i_valid := valid; i_safe_wf := refl_equal; @@ -74,9 +89,9 @@ Notation mk_instr_desc str tin i_in tout i_out semi safe valid semi_errty semi_s |}. Notation mk_instr_desc_safe str tin i_in tout i_out semi valid := - (mk_instr_desc str tin i_in tout i_out (sem_prod_ok (map eval_atype tin) semi) [::] valid - (fun _ => (@sem_prod_ok_error _ (map eval_atype tin) semi ErrType)) - (fun _ => (@sem_prod_ok_safe _ (map eval_atype tin) semi))) + (mk_instr_desc str tin i_in tout i_out (fun env => sem_prod_ok (map (eval_atype env) tin) semi) [::] valid + (fun _ env => (@sem_prod_ok_error _ (map (eval_atype env) tin) semi ErrType)) + (fun _ env => (@sem_prod_ok_safe _ (map (eval_atype env) tin) semi))) (only parsing). (* -------------------------------------------------------------------- *) @@ -137,8 +152,8 @@ Qed. HB.instance Definition _ := hasDecEq.Build sopn sopn_eq_axiom. -Definition sopn_copy (ws : wsize) (p : positive) : sopn := - Opseudo_op (Ocopy ws p). +Definition sopn_copy (ws : wsize) (al : array_length) : sopn := + Opseudo_op (Ocopy ws al). Definition sopn_nop : sopn := Opseudo_op Onop. Definition sopn_mulu (ws : wsize) : sopn := Opseudo_op (Omulu ws). Definition sopn_addcarry (ws : wsize) : sopn := Opseudo_op (Oaddcarry ws). @@ -171,7 +186,7 @@ Proof. by case: o => // -[] // ?? [-> ->]. Qed. Local Notation E n := (ADExplicit n ACR_any). Lemma array_copy_errty ws p: - let sz := Z.to_pos (arr_size ws p) in + let sz := arr_size ws p in let tin := [:: carr sz] in let semi := @WArray.copy ws p in sem_forall (fun r : result error (sem_tuple [:: carr sz]) => r <> Error ErrType) tin semi. @@ -193,7 +208,7 @@ Proof. Qed. Lemma array_copy_safe ws p: - let sz := Z.to_pos (arr_size ws p) in + let sz := arr_size ws p in let tin := [:: carr sz] in let semi := @WArray.copy ws p in interp_safe_cond_ty (tin:=tin) [:: AllInit ws p 0] semi. @@ -205,29 +220,29 @@ Proof. + by move=> /=; eauto. move=> j js hj hrec t1 /=. have [w -> /=] := h _ hj; rewrite /WArray.set. - have := [elaborate (writeV (CM:= WArray.array_CM (Z.to_pos (arr_size ws p))))]. + have := [elaborate (writeV (CM:= WArray.array_CM (arr_size ws p)))]. move => /(_ _ w t1 Aligned (j * mk_scale AAscale ws)%Z) wP. assert (h1 : validw t1 Aligned (j * mk_scale AAscale ws)%Z ws). + rewrite /validw /is_aligned_if WArray.is_align_scale andTb. apply ziota_ind => //= i ? hi ->; rewrite andbT; apply/WArray.in_boundP. - rewrite WArray.addE; change (Zpos _) with ((wsize_size ws) * p)%Z;Lia.nia. + rewrite WArray.addE arr_sizeE; Lia.nia. move/wP: h1 => [t2 ->] /=; apply hrec. Qed. -Definition Ocopy_instr ws p := +Definition Ocopy_instr ws al := {| str := pp_sz "copy" ws; - tin := [:: aarr ws p]; + tin := [:: aarr ws al]; i_in := [:: E 1]; - tout := [:: aarr ws p]; + tout := [:: aarr ws al]; i_out := [:: E 0]; conflicts:= [::]; - semi := @WArray.copy ws p; - semu := @vuincl_copy ws p; + semi := fun env => @WArray.copy ws (eval env al); + semu := fun env => @vuincl_copy ws (eval env al); i_valid := true; - i_safe := [:: AllInit ws p 0]; + i_safe := [:: AllInit ws al 0]; i_safe_wf := refl_equal; - i_semi_errty := fun _ => (@array_copy_errty ws p); - i_semi_safe := fun _ => (@array_copy_safe ws p); + i_semi_errty := fun _ env => (@array_copy_errty ws (eval env al)); + i_semi_safe := fun _ env => (@array_copy_safe ws (eval env al)); |}. Definition declassify_semi ty : sem_prod [:: ty ] (exec (sem_tuple [::])) := fun=> ok tt. @@ -246,38 +261,38 @@ Proof. Qed. Definition Odeclassify_instr ty := - let cty := eval_atype ty in + let cty env := eval_atype env ty in {| str := pp_s (string_of_pseudo_operator (Odeclassify ty)); tin := [:: ty ]; i_in := [:: E 0 ]; tout := [:: ]; i_out := [:: ]; conflicts:= [::]; - semi := fun=> ok tt; - semu := @declassify_semu cty; + semi := fun env => declassify_semi (cty env); + semu := fun env => @declassify_semu (cty env); i_safe := [:: ]; i_valid := true; i_safe_wf := refl_equal; - i_semi_errty := fun _ => (@sem_prod_ok_error _ [:: cty ] _ ErrType); - i_semi_safe := fun _ => (@sem_prod_ok_safe _ [:: cty ] _); + i_semi_errty := fun _ env => (@sem_prod_ok_error _ [:: cty env ] _ ErrType); + i_semi_safe := fun _ env => (@sem_prod_ok_safe _ [:: cty env ] _); |}. Definition Odeclassify_mem_instr len := let ty := aword Uptr in - let cty := eval_atype ty in + let cty env := eval_atype env ty in {| str := pp_s (string_of_pseudo_operator (Odeclassify_mem len)); tin := [:: ty ]; i_in := [:: E 0 ]; tout := [:: ]; i_out := [:: ]; conflicts:= [::]; - semi := fun=> ok tt; - semu := @declassify_semu cty; + semi := fun env => declassify_semi (cty env); + semu := fun env => @declassify_semu (cty env); i_safe := [:: ]; i_valid := true; i_safe_wf := refl_equal; - i_semi_errty := fun _ => (@sem_prod_ok_error _ [:: cty ] _ ErrType); - i_semi_safe := fun _ => (@sem_prod_ok_safe _ [:: cty ] _); + i_semi_errty := fun _ env => (@sem_prod_ok_error _ [:: cty env ] _ ErrType); + i_semi_safe := fun _ env => (@sem_prod_ok_safe _ [:: cty env ] _); |}. Definition Onop_instr := @@ -333,46 +348,46 @@ Proof. Qed. Definition Ospill_instr o (tys:seq atype) := - let ctys := map eval_atype tys in - let semi := spill_semi ctys in + let ctys env := map (eval_atype env) tys in + let semi env := spill_semi (ctys env) in {| str := (fun _ => string_of_pseudo_operator (Ospill o tys)); tin := tys; i_in := mapi (fun i _ => E i) tys; tout := [:: ]; i_out := [:: ]; conflicts:= [::]; - semi := sem_prod_ok ctys semi; - semu := @spill_semu ctys; + semi := fun env => sem_prod_ok (ctys env) (semi env); + semu := fun env => @spill_semu (ctys env); i_safe := [:: ]; i_valid := true; i_safe_wf := refl_equal; - i_semi_errty := fun _ => (@sem_prod_ok_error _ ctys semi ErrType); - i_semi_safe := fun _ => (@sem_prod_ok_safe _ ctys semi); + i_semi_errty := fun _ env => (@sem_prod_ok_error _ (ctys env) (semi env) ErrType); + i_semi_safe := fun _ env => (@sem_prod_ok_safe _ (ctys env) (semi env)); |}. Definition Oswap_instr ty := - let cty := eval_atype ty in - let ctys := [:: cty; cty] in - let semi := @swap_semi cty in + let cty env := eval_atype env ty in + let ctys env := [:: cty env; cty env] in + let semi env := @swap_semi (cty env) in {| str := (fun _ => "swap"%string); tin := [:: ty; ty]; i_in := [:: E 0; E 1]; (* this info is relevant *) tout := [:: ty; ty]; i_out := [:: E 0; E 1]; (* this info is relevant *) conflicts:= [::]; - semi := sem_prod_ok ctys semi; - semu := @swap_semu cty; + semi := fun env => sem_prod_ok (ctys env) (semi env); + semu := fun env => @swap_semu (cty env); i_safe := [::]; i_valid := true; i_safe_wf := refl_equal; - i_semi_errty := fun _ => (@sem_prod_ok_error _ ctys semi ErrType); - i_semi_safe := fun _ => (@sem_prod_ok_safe _ ctys semi); + i_semi_errty := fun _ env => (@sem_prod_ok_error _ (ctys env) (semi env) ErrType); + i_semi_safe := fun _ env => (@sem_prod_ok_safe _ (ctys env) (semi env)); |}. Definition pseudo_op_get_instr_desc (o : pseudo_operator) : instruction_desc := match o with | Ospill o tys => Ospill_instr o tys - | Ocopy ws p => Ocopy_instr ws p + | Ocopy ws al => Ocopy_instr ws al | Odeclassify t=> Odeclassify_instr t | Odeclassify_mem len => Odeclassify_mem_instr len | Onop => Onop_instr @@ -398,9 +413,9 @@ Definition se_move_sem (w : wmsf) : wmsf := w. Definition se_protect_sem {ws : wsize} (w : word ws) (msf : wmsf) : word ws := w. -Definition se_protect_ptr_sem {p:positive} (t: WArray.array p) (msf : wmsf) : WArray.array p := t. +Definition se_protect_ptr_sem {p} (t: WArray.array p) (msf : wmsf) : WArray.array p := t. -Definition se_protect_ptr_fail_sem {p:positive} (t: WArray.array p) (msf : wmsf) : exec (WArray.array p) := +Definition se_protect_ptr_fail_sem {p} (t: WArray.array p) (msf : wmsf) : exec (WArray.array p) := Let _ := assert (msf == 0%w) ErrSemUndef in ok t. @@ -459,23 +474,23 @@ Proof. Qed. Definition SLHprotect_ptr_str := "protect_ptr"%string. -Definition SLHprotect_ptr_instr ws p := - let tin := [:: aarr ws p; ty_msf ] in - let ctin := map eval_atype tin in - let semi := @se_protect_ptr_sem (Z.to_pos (arr_size ws p)) in +Definition SLHprotect_ptr_instr ws al := + let tin := [:: aarr ws al; ty_msf ] in + let ctin env := map (eval_atype env) tin in + let semi env := @se_protect_ptr_sem (arr_size ws (eval env al)) in {| str := pp_s SLHprotect_ptr_str; tin := tin; i_in := [:: E 0; E 1 ]; (* this info is irrelevant *) - tout := [:: aarr ws p ]; + tout := [:: aarr ws al ]; i_out := [:: E 2 ]; (* this info is irrelevant *) conflicts:=[::]; - semi := sem_prod_ok ctin semi; - semu := @protect_ptr_semu (Z.to_pos (arr_size ws p)); + semi := fun env => sem_prod_ok (ctin env) (semi env); + semu := fun env => @protect_ptr_semu (arr_size ws (eval env al)); i_safe := [::]; i_valid := true; i_safe_wf := refl_equal; - i_semi_errty := fun _ => (@sem_prod_ok_error _ ctin semi ErrType); - i_semi_safe := fun _ => (@sem_prod_ok_safe _ ctin semi); + i_semi_errty := fun _ env => (@sem_prod_ok_error _ (ctin env) (semi env) ErrType); + i_semi_safe := fun _ env => (@sem_prod_ok_safe _ (ctin env) (semi env)); |}. Lemma protect_ptr_fail_semu p vs vs' v: @@ -511,21 +526,21 @@ Proof. Qed. Definition SLHprotect_ptr_fail_str := "protect_ptr_fail"%string. -Definition SLHprotect_ptr_fail_instr ws p := - let len := (Z.to_pos (arr_size ws p)) in +Definition SLHprotect_ptr_fail_instr ws al := + let len env := arr_size ws (eval env al) in {| str := pp_s SLHprotect_ptr_fail_str; - tin := [:: aarr ws p; ty_msf ]; + tin := [:: aarr ws al; ty_msf ]; i_in := [:: E 0; E 1 ]; (* this info is irrelevant *) - tout := [:: aarr ws p ]; + tout := [:: aarr ws al ]; i_out := [:: E 2 ]; (* this info is irrelevant *) conflicts:=[::]; - semi := @se_protect_ptr_fail_sem len; - semu := @protect_ptr_fail_semu len; + semi := fun env => @se_protect_ptr_fail_sem (len env); + semu := fun env => @protect_ptr_fail_semu (len env); i_safe := [:: ScFalse]; (* See remark on protect_ptr_fail_safe *) i_valid := true; i_safe_wf := refl_equal; - i_semi_errty := fun _ => (@protect_ptr_fail_errty len); - i_semi_safe := fun _ => (@protect_ptr_fail_safe len); + i_semi_errty := fun _ env => (@protect_ptr_fail_errty (len env)); + i_semi_safe := fun _ env => (@protect_ptr_fail_safe (len env)); |}. Definition slh_op_instruction_desc (o : slh_op) : instruction_desc := @@ -534,8 +549,8 @@ Definition slh_op_instruction_desc (o : slh_op) : instruction_desc := | SLHupdate => SLHupdate_instr | SLHmove => SLHmove_instr | SLHprotect ws => SLHprotect_instr ws - | SLHprotect_ptr ws p => SLHprotect_ptr_instr ws p - | SLHprotect_ptr_fail ws p => SLHprotect_ptr_fail_instr ws p + | SLHprotect_ptr ws al => SLHprotect_ptr_instr ws al + | SLHprotect_ptr_fail ws al => SLHprotect_ptr_fail_instr ws al end. (* ---------------------------------------------------------------------- *) @@ -571,9 +586,10 @@ Definition primP {A: Type} (f: wsize -> A) := PrimX86 (map PVp (Uptr :: rem Uptr wsizes)) (fun s => if s is PVp sz then Some (f sz) else None). +(* FIXME: "the size is fixed later" must be fixed *) Definition sopn_prim_string : seq (string * prim_constructor sopn) := [:: - ("copy", primP (fun sz => Opseudo_op (Ocopy sz xH))); (* The size is fixed later *) + ("copy", primP (fun sz => Opseudo_op (Ocopy sz (ALConst xH)))); (* The size is fixed later *) ("swap", primM (Opseudo_op (Oswap abool))); (* The type is fixed later *) (* "NOP" is ignored on purpose *) ("mulu", primP (fun sz => Opseudo_op (Omulu sz))); @@ -583,7 +599,7 @@ Definition sopn_prim_string : seq (string * prim_constructor sopn) := ("update_msf" , primM (Oslh SLHupdate)); ("mov_msf" , primM (Oslh SLHmove)); ("protect" , primP (fun sz => Oslh (SLHprotect sz))); - ("protect_ptr", primM (Oslh (SLHprotect_ptr U8 xH))) (* The size is fixed later *) + ("protect_ptr", primM (Oslh (SLHprotect_ptr U8 (ALConst xH)))) (* The size is fixed later *) ]%string ++ map (fun '(s, p) => (s, map_prim_constructor Oasm p)) prim_string. diff --git a/proofs/lang/syscall.v b/proofs/lang/syscall.v index 18c7cbcfdd..6f5c2d5547 100644 --- a/proofs/lang/syscall.v +++ b/proofs/lang/syscall.v @@ -8,8 +8,8 @@ Require Import utils. #[only(eqbOK)] derive -Variant syscall_t : Type := - | RandomBytes of wsize & positive. +Variant syscall_t : Type := + | RandomBytes. HB.instance Definition _ := hasDecEq.Build syscall_t syscall_t_eqb_OK. @@ -19,19 +19,20 @@ HB.instance Definition _ := hasDecEq.Build syscall_t syscall_t_eqb_OK. (* Before stack alloc ie uprog *) Record syscall_sig_t := { + scs_al : seq length_var; scs_tin : seq atype; scs_tout : seq atype }. -Definition syscall_sig_u (o : syscall_t) : syscall_sig_t := +Definition syscall_sig_u {pd:PointerData} (N : length_var) (o : syscall_t) : syscall_sig_t := match o with - | RandomBytes ws len => {| scs_tin := [:: aarr ws len]; scs_tout := [:: aarr ws len] |} + | RandomBytes => {| scs_al := [:: N]; scs_tin := [:: aarr U8 (ALVar N); aword Uptr]; scs_tout := [:: aarr U8 (ALVar N)] |} end. (* After stack alloc ie sprog *) Definition syscall_sig_s {pd:PointerData} (o:syscall_t) : syscall_sig_t := match o with - | RandomBytes _ _ => {| scs_tin := [::aword Uptr; aword Uptr]; scs_tout := [::aword Uptr] |} + | RandomBytes => {| scs_al := [::]; scs_tin := [::aword Uptr; aword Uptr]; scs_tout := [::aword Uptr] |} end. diff --git a/proofs/lang/syscall_sem.v b/proofs/lang/syscall_sem.v index 3246aaad02..6409042c23 100644 --- a/proofs/lang/syscall_sem.v +++ b/proofs/lang/syscall_sem.v @@ -10,6 +10,7 @@ Local Open Scope Z_scope. +(* Unset Universe Checking. *) Section SourceSysCall. @@ -17,53 +18,174 @@ Context {pd: PointerData} {syscall_state : Type} {sc_sem : syscall_sem syscall_state} . - +(* Definition exec_getrandom_u (scs : syscall_state) len vs := - Let _ := + Let: (a, n) := match vs with - | [:: v] => to_arr len v + | [:: va; vn] => + Let a := to_arr len va in + Let n := to_word Uptr vn in + ok (a, n) | _ => type_error end in - let sd := get_random scs (Zpos len) in + let sd := get_random scs (wunsigned n) in Let t := WArray.fill len sd.2 in - ok (sd.1, [::Varr t]). + Let a' := WArray.set_sub AAscale (ws:=U8) a 0 t in + ok (sd.1, [::Varr a']). Definition exec_syscall_u {pd : PointerData} + (env : length_var -> positive) (scs : syscall_state_t) (m : mem) (o : syscall_t) + (al : seq array_length) (vs : values) : exec (syscall_state_t * mem * values) := match o with - | RandomBytes ws p => - let len := Z.to_pos (arr_size ws p) in - Let sv := exec_getrandom_u scs len vs in - ok (sv.1, m, sv.2) + | RandomBytes ws => + Let al := + match al with + | [:: al] => ok al + | _ => Error ErrType + end + in + let len := Z.to_pos (arr_size ws (eval env al)) in + Let sv := exec_getrandom_u scs len vs in + ok (sv.1, m, sv.2) + end. *) + +Definition exec_getrandom_u_core (scs : syscall_state_t) (m : mem) N (a : WArray.array (arr_size U8 N)) (n:pointer) := + let len := arr_size U8 (wunsigned n) in + let sd := get_random scs len in + Let t := WArray.fill len sd.2 in + Let a' := WArray.set_sub AAscale a 0 t in + ok (sd.1, m, a'). + +Fixpoint dep_type (n : nat) (A : Type) (B : seq A -> Type) : Type := + match n with + | 0%nat => B [::] + | S n => forall (a : A), dep_type n (fun l => B (a :: l)) + end. + +Fixpoint app_dep n A (B : seq A -> Type) : dep_type n B -> forall l : seq A, exec (B l) := + match n with + | 0%nat => fun (b : B [::]) (l : seq A) => if l is [::] then ok b else type_error + | S n => fun (f : forall (a : A), _) (l : seq A) => + if l is a :: l then app_dep (f a) l else type_error end. -Lemma exec_syscallPu scs m o vargs vargs' rscs rm vres : - exec_syscall_u scs m o vargs = ok (rscs, rm, vres) → +Definition sem_syscall_u (N : length_var) (o : syscall_t) : + syscall_state_t -> mem -> + dep_type (size (syscall_sig_u N o).(scs_al)) + (fun l => + let env := + let als := zip (syscall_sig_u N o).(scs_al) l in + xseq.assoc als + in + (sem_prod (map (eval_atype env) (syscall_sig_u N o).(scs_tin)) + (exec (syscall_state_t * mem * sem_tuple (map (eval_atype env) (syscall_sig_u N o).(scs_tout)))))) := + match o with + | RandomBytes => + ecast b (_ -> _ -> forall len, + sem_prod [:: carr (arr_size U8 (if (if b then Some len else None) is Some z then if 0 @exec_getrandom_u_core scs m _) + end. + +Definition exec_syscall_u (N:length_var) (scs : syscall_state_t) (m : mem) (o:syscall_t) (alargs: seq Z) (vs:values) : exec (syscall_state_t * mem * values) := + let semi := sem_syscall_u N o in + Let semi := app_dep (semi scs m) alargs in + Let: (scs', m', t) := app_sopn _ semi vs in + ok (scs', m', list_ltuple t). + +(* +Fixpoint dep_type (A : Type) n : lprod (nseq n A) Type -> Type := + match n with + | 0 => fun B => B + | S n => fun B => forall x : A, dep_type (B x) + end. +Definition dep_type' A n (f:seq A -> Type) := dep_type (curry n f). + +Definition split_tuple A n : ltuple (nseq (S n) A) -> A * ltuple (nseq n A) := + match n with + | 0 => fun a => (a, tt) + | S n => fun a => a + end. + +Fixpoint app (A : Type) n : lprod (nseq n A) Type -> ltuple (nseq n A) -> Type := + match n with + | 0 => fun B _ => B + | S n => fun B l => let (a, l) := split_tuple l in app (B a) l + end. + +Fixpoint app_dep A n (B : lprod (nseq n A) Type) : dep_type B -> forall l : ltuple (nseq n A), app B l. +case: n B. +simpl. move=> B b _. apply b. +move=> n B f l /=. +case: split_tuple => a l'. +have := app_dep A n (B a) (f a) l'. apply: id. +Defined. + +Definition test o N : lprod (nseq (size (syscall_sig_u N o).(scs_al)) positive) Type. apply curry. +simpl. refine (fun l => + let env : length_var -> positive := + let als := zip (syscall_sig_u N o).(scs_al) l in + fun x => + odflt 1%positive (xseq.assoc als x) + in + sem_prod (map (eval_atype env) (syscall_sig_u N o).(scs_tin)) + (exec (syscall_state_t * mem * sem_tuple (map (eval_atype env) (syscall_sig_u N o).(scs_tout))))). +Defined. + +Definition sem_syscall_u (o:syscall_t) (N : length_var) : + syscall_state_t -> mem -> dep_type (test o N). + case: o => ws. + rewrite /test /curry /= /sem_prod /=. + move=> scs m len. rewrite eqtype.eq_refl /=. move=> ??. apply: exec_getrandom_u_core => //. +Defined. +*) + +Lemma exec_syscallPu N scs m o alargs vargs vargs' rscs rm vres : + exec_syscall_u N scs m o alargs vargs = ok (rscs, rm, vres) → List.Forall2 value_uincl vargs vargs' → exists2 vres' : values, - exec_syscall_u scs m o vargs' = ok (rscs, rm, vres') & List.Forall2 value_uincl vres vres'. + exec_syscall_u N scs m o alargs vargs' = ok (rscs, rm, vres') & List.Forall2 value_uincl vres vres'. Proof. - rewrite /exec_syscall_u; case: o => [ ws p ]. - t_xrbindP => -[scs' v'] /= h ??? hu; subst scs' m v'. - move: h; rewrite /exec_getrandom_u. - case: hu => // va va' ?? /of_value_uincl_te h [] //. - t_xrbindP => a /h{h}[? /= -> ?] ra hra ??; subst rscs vres. - by rewrite hra /=; eexists; eauto. + rewrite /exec_syscall_u; case: o. + case: alargs => // al [] //=. + rewrite /eval /=. + rewrite -> eqtype.eq_refl; move=> /=. + move=> + hu. + case: hu => // va va' {}vargs {}vargs' /of_value_uincl_te ha. + case; first by t_xrbindP. + move=> vn vn' {}vargs {}vargs' /of_value_uincl_te hn. + case; last by t_xrbindP. + t_xrbindP=> -[[{}scs' {}m'] ra] a /(ha (carr _)) {ha} [/= a' -> hincl] n /(hn (cword _)) /= -> hexec [<- <- <-]. + move: hexec; rewrite /exec_getrandom_u_core. + t_xrbindP=> t ht {}ra hra <- <- <-. + have [ra' hra' hincl'] := WArray.uincl_set_sub hincl (WArray.uincl_refl _) hra. + by rewrite /= ht /= hra' /=; eexists; eauto. Qed. Definition mem_equiv m1 m2 := stack_stable m1 m2 /\ validw m1 =3 validw m2. -Lemma exec_syscallSu scs m o vargs rscs rm vres : - exec_syscall_u scs m o vargs = ok (rscs, rm, vres) → +Lemma exec_syscallSu N scs m o alargs vargs rscs rm vres : + exec_syscall_u N scs m o alargs vargs = ok (rscs, rm, vres) → mem_equiv m rm. Proof. - rewrite /exec_syscall_u; case: o => [ ws p ]. - by t_xrbindP => -[scs' v'] /= _ _ <- _. + rewrite /exec_syscall_u; case: o. + case: alargs => // al [] //=. + rewrite /eval /=. + rewrite -> eqtype.eq_refl; move=> /=. + case: vargs => // va. + case; first by t_xrbindP. + move=> vn. + case; last by t_xrbindP. + t_xrbindP=> -[[scs' m'] v'] /= ? _ ? _. + rewrite /exec_getrandom_u_core. + by t_xrbindP=> _ _ _ _ _ <- _ _ <- _. Qed. End SourceSysCall. @@ -78,7 +200,7 @@ Definition exec_getrandom_s_core (scs : syscall_state_t) (m : mem) (p:pointer) ( Let m := fill_mem m p sd.2 in ok (sd.1, m, p). -Lemma exec_getrandom_s_core_stable scs m p len rscs rm rp : +Lemma exec_getrandom_s_core_stable scs m p len rscs rm rp : exec_getrandom_s_core scs m p len = ok (rscs, rm, rp) → stack_stable m rm. Proof. by rewrite /exec_getrandom_s_core; t_xrbindP => rm' /fill_mem_stack_stable hf ? <- ?. Qed. @@ -88,54 +210,66 @@ Lemma exec_getrandom_s_core_validw scs m p len rscs rm rp : validw m =3 validw rm. Proof. by rewrite /exec_getrandom_s_core; t_xrbindP => rm' /fill_mem_validw_eq hf ? <- ?. Qed. -Definition sem_syscall (o:syscall_t) : - syscall_state_t -> mem -> sem_prod (map eval_atype (syscall_sig_s o).(scs_tin)) (exec (syscall_state_t * mem * sem_tuple (map eval_atype (syscall_sig_s o).(scs_tout)))) := +Definition sem_syscall_s (o : syscall_t) : + syscall_state_t -> mem -> + dep_type (size (syscall_sig_s o).(scs_al)) + (fun l => + let env := + let als := zip (syscall_sig_s o).(scs_al) l in + xseq.assoc als + in + (sem_prod (map (eval_atype env) (syscall_sig_s o).(scs_tin)) + (exec (syscall_state_t * mem * sem_tuple (map (eval_atype env) (syscall_sig_s o).(scs_tout)))))) := match o with - | RandomBytes _ _ => exec_getrandom_s_core + | RandomBytes => exec_getrandom_s_core end. -Definition exec_syscall_s (scs : syscall_state_t) (m : mem) (o:syscall_t) vs : exec (syscall_state_t * mem * values) := - let semi := sem_syscall o in - Let: (scs', m', t) := app_sopn _ (semi scs m) vs in +Definition exec_syscall_s (scs : syscall_state_t) (m : mem) (o:syscall_t) alargs vs : exec (syscall_state_t * mem * values) := + let semi := sem_syscall_s o in + Let semi := app_dep (semi scs m) alargs in + Let: (scs', m', t) := app_sopn _ semi vs in ok (scs', m', list_ltuple t). -Lemma syscall_sig_s_noarr o : all is_not_carr (map eval_atype (syscall_sig_s o).(scs_tin)). +Lemma syscall_sig_s_noarr o env : all is_not_carr (map (eval_atype env) (syscall_sig_s o).(scs_tin)). Proof. by case: o. Qed. -Lemma exec_syscallPs_eq scs m o vargs vargs' rscs rm vres : - exec_syscall_s scs m o vargs = ok (rscs, rm, vres) → +Lemma exec_syscallPs_eq scs m o alargs vargs vargs' rscs rm vres : + exec_syscall_s scs m o alargs vargs = ok (rscs, rm, vres) → List.Forall2 value_uincl vargs vargs' → - exec_syscall_s scs m o vargs' = ok (rscs, rm, vres). + exec_syscall_s scs m o alargs vargs' = ok (rscs, rm, vres). Proof. - rewrite /exec_syscall_s; t_xrbindP => -[[scs' m'] t] happ [<- <- <-] hu. - by have -> := vuincl_sopn (syscall_sig_s_noarr o) hu happ. + rewrite /exec_syscall_s. + t_xrbindP=> ? -> -[[scs' m'] vres'] happ [<- <- <-] hu /=. + by have -> := vuincl_sopn (syscall_sig_s_noarr o _) hu happ. Qed. - -Lemma exec_syscallPs scs m o vargs vargs' rscs rm vres : - exec_syscall_s scs m o vargs = ok (rscs, rm, vres) → + +Lemma exec_syscallPs scs m o alargs vargs vargs' rscs rm vres : + exec_syscall_s scs m o alargs vargs = ok (rscs, rm, vres) → List.Forall2 value_uincl vargs vargs' → exists2 vres' : values, - exec_syscall_s scs m o vargs' = ok (rscs, rm, vres') & List.Forall2 value_uincl vres vres'. + exec_syscall_s scs m o alargs vargs' = ok (rscs, rm, vres') & List.Forall2 value_uincl vres vres'. Proof. move=> h1 h2; rewrite (exec_syscallPs_eq h1 h2). by exists vres=> //; apply List_Forall2_refl. Qed. -Lemma sem_syscall_equiv o scs m : - mk_forall (fun (rm: (syscall_state_t * mem * _)) => mem_equiv m rm.1.2) - (sem_syscall o scs m). +Lemma sem_syscall_s_equiv o scs m alargs semi : + app_dep (sem_syscall_s o scs m) alargs = ok semi -> + mk_forall (fun (rm: (syscall_state_t * mem * _)) => mem_equiv m rm.1.2) semi. Proof. - case: o => _ws _len /= p len [[scs' rm] t] /= hex; split. + case: o semi => /=. + case: alargs => // _ [<-] /= p n [[scs' rm] t] hex; split. + by apply: exec_getrandom_s_core_stable hex. by apply: exec_getrandom_s_core_validw hex. Qed. -Lemma exec_syscallSs scs m o vargs rscs rm vres : - exec_syscall_s scs m o vargs = ok (rscs, rm, vres) → +Lemma exec_syscallSs scs m o alargs vargs rscs rm vres : + exec_syscall_s scs m o alargs vargs = ok (rscs, rm, vres) → mem_equiv m rm. Proof. - rewrite /exec_syscall_s; t_xrbindP => -[[scs' m'] t] happ [_ <- _]. - apply (mk_forallP (sem_syscall_equiv o scs m) happ). + rewrite /exec_syscall_s. + t_xrbindP=> semi hsemi -[[scs' m'] vres'] happ [_ <- _]. + apply (mk_forallP (sem_syscall_s_equiv hsemi) happ). Qed. End Section. diff --git a/proofs/lang/type.v b/proofs/lang/type.v index 517bb8bb9f..85af3597b2 100644 --- a/proofs/lang/type.v +++ b/proofs/lang/type.v @@ -4,7 +4,7 @@ From HB Require Import structures. From mathcomp Require Import ssreflect ssrfun ssrbool seq eqtype. From mathcomp Require Import word_ssrZ. From Coq Require Import ZArith. -Require Import gen_map utils strings. +Require Import gen_map utils strings ident. Require Export wsize. Import Utf8. @@ -17,12 +17,58 @@ Variant ltype : Set := | lbool | lword of wsize. +Record length_var := LV { lvname : Ident.ident }. + +Definition length_var_beq (v1 v2:length_var) := + let (i1) := v1 in + let (i2) := v2 in + i1 == i2. + +Lemma length_var_eqP : Equality.axiom length_var_beq. +Proof. + by move=> [i1] [i2]; apply (iffP eqP); congruence. +Qed. + +(* Dummy definition *) +Definition is_length_var (v : length_var) := unit. +Lemma is_length_var_inhab v : is_length_var v. +Proof. apply tt. Qed. + +Lemma length_var_beq_correct v1 v2 : length_var_beq v1 v2 = true -> v1 = v2. +Proof. + by move=> /length_var_eqP. +Qed. + +Lemma length_var_beq_refl v : length_var_beq v v = true. +Proof. + by apply /length_var_eqP. +Qed. + +derive.eqbOK.register_axiom length_var is_length_var is_length_var_inhab length_var_beq length_var_beq_correct length_var_beq_refl. + +HB.instance Definition _ := hasDecEq.Build length_var length_var_eqP. + +#[only(eqbOK)] derive +Inductive array_length := +| ALConst : Z -> array_length +| ALVar : length_var -> array_length +| ALNeg : array_length -> array_length +| ALAdd : array_length -> array_length -> array_length +| ALSub : array_length -> array_length -> array_length +| ALMul : array_length -> array_length -> array_length +| ALDiv : signedness -> array_length -> array_length -> array_length +| ALMod : signedness -> array_length -> array_length -> array_length +| ALShl : array_length -> array_length -> array_length +| ALShr : array_length -> array_length -> array_length. + +HB.instance Definition _ := hasDecEq.Build array_length array_length_eqb_OK. + (* Syntax types, i.e. types that appear in programs *) #[only(eqbOK)] derive -Variant atype : Set := +Variant atype := | abool | aint -| aarr of wsize & positive +| aarr of wsize & array_length | aword of wsize. (* Value types, i.e. types appearing in the semantics *) @@ -30,7 +76,7 @@ Variant atype : Set := Variant ctype : Set := | cbool | cint -| carr of positive +| carr of Z | cword of wsize. Definition atype_of_ltype ty := @@ -67,6 +113,131 @@ HB.instance Definition _ := hasDecEq.Build ctype ctype_eqb_OK. (* ** Comparison * -------------------------------------------------------------------- *) +Definition length_var_cmp (v1 v2 : length_var) := + let (i1) := v1 in + let (i2) := v2 in + Ident.Mid.K.cmp i1 i2. + (* for some reason, this works while the more natural [Tident.cmp i1 i2] + produces ill-typed OCaml code *) + (* I think it's just because this adds Obj.magic at extraction, so this + works, but not for a good reason *) + +Definition signedness_cmp sg1 sg2 := + match sg1, sg2 with + | Signed, Signed => Eq + | Signed, Unsigned => Lt + | Unsigned, Unsigned => Eq + | Unsigned, Signed => Gt + end. + +Fixpoint array_length_cmp al1 al2 := + match al1, al2 with + | ALConst z1, ALConst z2 => Z.compare z1 z2 + | ALConst _, _ => Lt + + | ALVar _, ALConst _ => Gt + | ALVar x1, ALVar x2 => length_var_cmp x1 x2 + | ALVar _, _ => Lt + + | ALNeg _, (ALConst _ | ALVar _) => Gt + | ALNeg al1, ALNeg al2 => array_length_cmp al1 al2 + | ALNeg _, _ => Lt + + | ALAdd _ _, (ALConst _ | ALVar _ | ALNeg _) => Gt + | ALAdd al11 al12, ALAdd al21 al22 => Lex (array_length_cmp al11 al21) (array_length_cmp al12 al22) + | ALAdd _ _, _ => Lt + + | ALSub _ _, (ALConst _ | ALVar _ | ALNeg _ | ALAdd _ _) => Gt + | ALSub al11 al12, ALSub al21 al22 => Lex (array_length_cmp al11 al21) (array_length_cmp al12 al22) + | ALSub _ _, _ => Lt + + | ALMul _ _, (ALDiv _ _ _ | ALMod _ _ _ | ALShl _ _ | ALShr _ _) => Lt + | ALMul al11 al12, ALMul al21 al22 => Lex (array_length_cmp al11 al21) (array_length_cmp al12 al22) + | ALMul _ _, _ => Gt + + | ALDiv _ _ _, (ALMod _ _ _ | ALShl _ _ | ALShr _ _) => Lt + | ALDiv sg1 al11 al12, ALDiv sg2 al21 al22 => Lex (signedness_cmp sg1 sg2) (Lex (array_length_cmp al11 al21) (array_length_cmp al12 al22)) + | ALDiv _ _ _, _ => Gt + + | ALMod _ _ _, (ALShl _ _ | ALShr _ _) => Lt + | ALMod sg1 al11 al12, ALMod sg2 al21 al22 => Lex (signedness_cmp sg1 sg2) (Lex (array_length_cmp al11 al21) (array_length_cmp al12 al22)) + | ALMod _ _ _, _ => Gt + + | ALShl _ _, ALShr _ _ => Lt + | ALShl al11 al12, ALShl al21 al22 => Lex (array_length_cmp al11 al21) (array_length_cmp al12 al22) + | ALShl _ _, _ => Gt + + | ALShr al11 al12, ALShr al21 al22 => Lex (array_length_cmp al11 al21) (array_length_cmp al12 al22) + | ALShr _ _, _ => Gt + end. + +Instance length_varO : Cmp length_var_cmp. +Proof. + constructor. + + move=> [i1] [i2] /=. + by apply (cmp_sym (Cmp:=Ident.Mid.K.cmpO)). + + move=> [i1] [i2] [i3] /=. + by apply (cmp_ctrans (Cmp:=Ident.Mid.K.cmpO)). + move=> [i1] [i2] /=. + by move=> /(cmp_eq (Cmp:=Ident.Mid.K.cmpO)) ->. +Qed. + +Instance signednessO : Cmp signedness_cmp. +Proof. + constructor. + + by move=> [|] [|]. + + by move=> [|] [|] [|] //= ? []. + by move=> [|] [|]. +Qed. + +Instance array_lengthO : Cmp array_length_cmp. +Proof. + constructor. + + elim=> + [z1|x1|al1 ih1|al11 ih1 al12 ih2|al11 ih1 al12 ih2|al11 ih1 al12 ih2|sg1 al11 ih1 al12 ih2|sg1 al11 ih1 al12 ih2|al11 ih1 al12 ih2|al11 ih1 al12 ih2] + [z2|x2|al2 |al21 al22 |al21 al22 |al21 al22 |sg2 al21 al22 |sg2 al21 al22 |al21 al22 |al21 al22 ] //=. + + by apply cmp_sym. + + by apply cmp_sym. + + by rewrite !Lex_lex; apply lex_sym. + + by rewrite !Lex_lex; apply lex_sym. + + by rewrite !Lex_lex; apply lex_sym. + + rewrite !Lex_lex; apply lex_sym; first by apply cmp_sym. + by apply lex_sym. + + rewrite !Lex_lex; apply lex_sym; first by apply cmp_sym. + by apply lex_sym. + + by rewrite !Lex_lex; apply lex_sym. + by rewrite !Lex_lex; apply lex_sym. + + elim=> + [z1|x1|al1 ih1|al11 ih1 al12 ih2|al11 ih1 al12 ih2|al11 ih1 al12 ih2|sg1 al11 ih1 al12 ih2|sg1 al11 ih1 al12 ih2|al11 ih1 al12 ih2|al11 ih1 al12 ih2] + [z2|x2|al2 |al21 al22 |al21 al22 |al21 al22 |sg2 al21 al22 |sg2 al21 al22 |al21 al22 |al21 al22 ] + [z3|x3|al3 |al31 al32 |al31 al32 |al31 al32 |sg3 al31 al32 |sg3 al31 al32 |al31 al32 |al31 al32 ] //=; + try (by apply ctrans_Eq); eauto using ctrans_Lt, ctrans_Gt; try apply cmp_ctrans. + + by rewrite !Lex_lex; apply lex_trans; eauto. + + by rewrite !Lex_lex; apply lex_trans; eauto. + + by rewrite !Lex_lex; apply lex_trans; eauto. + + rewrite !Lex_lex; apply lex_trans. + + by apply cmp_ctrans. + apply lex_trans; eauto. + + rewrite !Lex_lex; apply lex_trans. + + by apply cmp_ctrans. + apply lex_trans; eauto. + + by rewrite !Lex_lex; apply lex_trans; eauto. + by rewrite !Lex_lex; apply lex_trans; eauto. + elim=> + [z1|x1|al1 ih1|al11 ih1 al12 ih2|al11 ih1 al12 ih2|al11 ih1 al12 ih2|sg1 al11 ih1 al12 ih2|sg1 al11 ih1 al12 ih2|al11 ih1 al12 ih2|al11 ih1 al12 ih2] + [z2|x2|al2 |al21 al22 |al21 al22 |al21 al22 |sg2 al21 al22 |sg2 al21 al22 |al21 al22 |al21 al22 ] //=. + + by move=> /cmp_eq ->. + + by move=> /cmp_eq ->. + + by move=> /ih1 <-. + + by rewrite Lex_lex => /lex_eq /= [/ih1 <- /ih2 <-]. + + by rewrite Lex_lex => /lex_eq /= [/ih1 <- /ih2 <-]. + + by rewrite Lex_lex => /lex_eq /= [/ih1 <- /ih2 <-]. + + by rewrite !Lex_lex => /lex_eq /= [/cmp_eq <- /lex_eq /= [/ih1 <- /ih2 <-]]. + + by rewrite !Lex_lex => /lex_eq /= [/cmp_eq <- /lex_eq /= [/ih1 <- /ih2 <-]]. + + by rewrite Lex_lex => /lex_eq /= [/ih1 <- /ih2 <-]. + by rewrite Lex_lex => /lex_eq /= [/ih1 <- /ih2 <-]. +Qed. + Definition atype_cmp t t' := match t, t' with | abool , abool => Eq @@ -80,7 +251,7 @@ Definition atype_cmp t t' := | aword w , aword w' => wsize_cmp w w' | aword _ , _ => Gt - | aarr ws n , aarr ws' n' => Lex (wsize_cmp ws ws') (Pos.compare n n') + | aarr ws al , aarr ws' al' => Lex (wsize_cmp ws ws') (array_length_cmp al al') | aarr _ _ , _ => Gt end. @@ -88,14 +259,14 @@ Definition atype_cmp t t' := Instance atypeO : Cmp atype_cmp. Proof. constructor. - + case => [||ws n|w] [||ws' n'|w'] //=. + + case => [||ws al|w] [||ws' al'|w'] //=. + by rewrite !Lex_lex lex_sym //=; apply cmp_sym. by apply cmp_sym. - + move=> y x; case: x y=> [||ws n|w] [||ws' n'|w'] [||ws'' n''|w''] c //=; + + move=> y x; case: x y=> [||ws al|w] [||ws' al'|w'] [||ws'' al''|w''] c //=; try (by apply ctrans_Eq);eauto using ctrans_Lt, ctrans_Gt. + by rewrite !Lex_lex; apply lex_trans; apply cmp_ctrans. by apply cmp_ctrans. - case=> [||n ws|w] [||n' ws'|w'] //=. + case=> [||al ws|w] [||al' ws'|w'] //=. + by rewrite Lex_lex => /lex_eq /= [/cmp_eq <- /cmp_eq <-]. by move=> /cmp_eq <-. Qed. @@ -155,12 +326,12 @@ Module CEDecAtype. | aint => left (erefl aint) | _ => right I end - | aarr ws1 n1 => - match t2 as t0 return {aarr ws1 n1 = t0} + {True} with - | aarr ws2 n2 => + | aarr ws1 al1 => + match t2 as t0 return {aarr ws1 al1 = t0} + {True} with + | aarr ws2 al2 => match wsize_eq_dec ws1 ws2 with | left eqw => - match pos_dec n1 n2 with + match array_length_eqb_OK_sumbool al1 al2 with | left eqn => left (f_equal2 aarr eqw eqn) | right _ => right I end @@ -191,11 +362,10 @@ Module CEDecAtype. Lemma eq_dec_r t1 t2 tt: eq_dec t1 t2 = right tt -> t1 != t2. Proof. - case: tt;case:t1 t2=> [||ws n|w] [||ws' n'|w'] //=. + case: tt;case:t1 t2=> [||ws al|w] [||ws' al'|w'] //=. + case: wsize_eq_dec => eqw. - + case: pos_dec (@pos_dec_r n n' I) => [Heq _ | [] neq ] //=. - move => _; apply/eqP => -[]. - by move/eqP: (neq erefl). + + case: array_length_eqb_OK_sumbool => // eqal. + by move=> _; apply /eqP; congruence. by move=> _; apply/eqP => -[]. case: wsize_eq_dec => // eqw. by move=> _;apply /eqP;congruence. @@ -246,22 +416,74 @@ Definition is_not_carr t := ~~ is_carr t. End OtherDefs. (* -------------------------------------------------------------------- *) -Definition arr_size (ws:wsize) (len:positive) := - (wsize_size ws * len)%Z. -Lemma arr_sizeE ws len : arr_size ws len = (wsize_size ws * len)%Z. -Proof. done. Qed. +Section EVAL. + +Context (env : length_var -> option Z). -Lemma gt0_arr_size ws len : (0 < arr_size ws len)%Z. -Proof. done. Qed. +(* FIXME: duplicated from sem_op_typed *) +Definition zlsl (x i : Z) : Z := + if (0 <=? i)%Z then (x * 2^i)%Z + else (x / 2^(-i))%Z. -Opaque arr_size. +Definition zasr (x i : Z) : Z := + zlsl x (-i). + +(* FIXME: duplicated from word *) +Definition signed {A:Type} (fu fs:A) s := + match s with + | Unsigned => fu + | Signed => fs + end. + +Fixpoint eval_opt (al:array_length) : option Z := + match al with + | ALConst z => Some z + | ALVar v => env v + | ALNeg al => + let%opt z := eval_opt al in + Some (- z) + | ALAdd al1 al2 => + let%opt z1 := eval_opt al1 in + let%opt z2 := eval_opt al2 in + Some (z1 + z2) + | ALSub al1 al2 => + let%opt z1 := eval_opt al1 in + let%opt z2 := eval_opt al2 in + Some (z1 - z2) + | ALMul al1 al2 => + let%opt z1 := eval_opt al1 in + let%opt z2 := eval_opt al2 in + Some (z1 * z2) + | ALDiv sg al1 al2 => + let%opt z1 := eval_opt al1 in + let%opt z2 := eval_opt al2 in + Some (signed Z.div Z.quot sg z1 z2) + | ALMod sg al1 al2 => + let%opt z1 := eval_opt al1 in + let%opt z2 := eval_opt al2 in + Some (signed Z.modulo Z.rem sg z1 z2) + | ALShl al1 al2 => + let%opt z1 := eval_opt al1 in + let%opt z2 := eval_opt al2 in + Some (zlsl z1 z2) + | ALShr al1 al2 => + let%opt z1 := eval_opt al1 in + let%opt z2 := eval_opt al2 in + Some (zasr z1 z2) + end%Z. + +Definition eval al := + if eval_opt al is Some z then + if (0 cbool | aint => cint - | aarr ws len => carr (Z.to_pos (arr_size ws len)) + | aarr ws len => carr (arr_size ws (eval len)) | aword ws => cword ws end. @@ -271,47 +493,410 @@ Definition eval_ltype ty := | lword ws => cword ws end. +End EVAL. + +(* We define a polynom equality checker. This is what ring or lia know how to do. + We could probably call functions coming from their implementation instead. *) +From Equations Require Import Equations. +(* importing equations messes with erefl/refl_equal for some reason... *) +Arguments Logic.eq_refl {_} {_}, [_] _. +From Coq Require Import Lia. + +Fixpoint size_poly poly : nat := + match poly with + | ALConst _ | ALVar _ => 1 + | ALNeg p => S (size_poly p) + | ALAdd p1 p2 | ALSub p1 p2 | ALMul p1 p2 => + size_poly p1 + size_poly p2 + | ALDiv _ _ _ | ALMod _ _ _ | ALShl _ _ | ALShr _ _ => 1 + end. + +Lemma lt0_size_poly p : (0 < size_poly p)%nat. +Proof. by elim: p => /=; lia. Qed. + +Fixpoint size_Mul poly : nat := + match poly with + | ALConst _ | ALVar _ => 0 + | ALNeg p => size_Mul p + | ALAdd p1 p2 | ALSub p1 p2 => size_Mul p1 + size_Mul p2 + | ALMul p1 p2 => 1 + size_Mul p1 + size_Mul p2 + | ALDiv _ _ _ | ALMod _ _ _ | ALShl _ _ | ALShr _ _ => 0 + end. + +Fixpoint left_Mul_under_Mul poly : nat := + match poly with + | ALConst _ | ALVar _ => 0 + | ALNeg p => left_Mul_under_Mul p + | ALAdd p1 p2 | ALSub p1 p2 => left_Mul_under_Mul p1 + left_Mul_under_Mul p2 + | ALMul p1 p2 => size_Mul p1 + left_Mul_under_Mul p2 + | ALDiv _ _ _ | ALMod _ _ _ | ALShl _ _ | ALShr _ _ => 0 + end. + +Fixpoint insert_mono x mono := + match mono with + | [::] => [:: x] + | x2 :: mono => + match length_var_cmp x x2 with + | Lt | Eq => x :: x2 :: mono + | Gt => x2 :: insert_mono x mono + end + end. + +Fixpoint insert_term cm terms := + match terms with + | [::] => [:: cm] + | cm2 :: terms => + match List.list_compare length_var_cmp (snd cm) (snd cm2) with + | Lt => cm :: cm2 :: terms + | Eq => let new_coeff := fst cm + fst cm2 in (* if new_coeff =? 0 then terms else *) (new_coeff, snd cm) :: terms + | Gt => cm2 :: insert_term cm terms + end + end%Z. +Definition insert_term_nice cm terms := + (* if (fst cm =? 0)%Z then terms else *) insert_term cm terms. + +Equations expanded_form (p : array_length) : list (Z * list length_var) := + expanded_form p := aux [::] 1 [::] p + + where aux (terms : list (Z * list length_var)) (coeff : Z) (mono : list length_var) (p : array_length) : list (Z * list length_var) by wf (size_poly p, left_Mul_under_Mul p) (lexprod _ _ lt lt) := + aux terms coeff mono (ALConst n) := let coeff := (n * coeff)%Z in insert_term_nice (coeff, mono) terms; + aux terms coeff mono (ALVar x) := let mono := insert_mono x mono in insert_term_nice (coeff, mono) terms; + aux terms coeff mono (ALNeg e) := aux terms (-coeff) mono e; + aux terms coeff mono (ALAdd e1 e2) := aux (aux terms coeff mono e1) coeff mono e2; + aux terms coeff mono (ALSub e1 e2) := aux (aux terms coeff mono e1) (-coeff) mono e2; + aux terms coeff mono (ALMul (ALConst n) e) := let coeff := (n * coeff)%Z in aux terms coeff mono e; + aux terms coeff mono (ALMul (ALVar x) e) := let mono := insert_mono x mono in aux terms coeff mono e; + aux terms coeff mono (ALMul (ALNeg e1) e2) := aux terms (-coeff) mono (ALMul e1 e2); + aux terms coeff mono (ALMul (ALAdd e11 e12) e2) := aux (aux terms coeff mono (ALMul e11 e2)) coeff mono (ALMul e12 e2); + aux terms coeff mono (ALMul (ALSub e11 e12) e2) := aux (aux terms coeff mono (ALMul e11 e2)) (-coeff) mono (ALMul e12 e2); + aux terms coeff mono (ALMul (ALMul e11 e12) e2) := aux terms coeff mono (ALMul e11 (ALMul e12 e2)); + aux terms coeff mono (ALMul (ALDiv _ _ _) _) := [::]; + aux terms coeff mono (ALMul (ALMod _ _ _) _) := [::]; + aux terms coeff mono (ALMul (ALShl _ _) _) := [::]; + aux terms coeff mono (ALMul (ALShr _ _) _) := [::]; + aux terms coeff mono (ALDiv _ _ _) := [::]; + aux terms coeff mono (ALMod _ _ _) := [::]; + aux terms coeff mono (ALShl _ _) := [::]; + aux terms coeff mono (ALShr _ _) := [::]. +Next Obligation. + simpl. + left. have := lt0_size_poly e2. lia. +Qed. +Next Obligation. + simpl. + left. have := lt0_size_poly e1. lia. +Qed. +Next Obligation. + simpl. left. have := lt0_size_poly e2. lia. +Qed. +Next Obligation. + simpl. left. have := lt0_size_poly e1. lia. +Qed. +Next Obligation. + simpl. left. have := lt0_size_poly e12. lia. +Qed. +Next Obligation. + simpl. left. have := lt0_size_poly e11. lia. +Qed. +Next Obligation. + simpl. left. have := lt0_size_poly e12. lia. +Qed. +Next Obligation. + simpl. left. have := lt0_size_poly e11. lia. +Qed. +Final Obligation. + simpl. rewrite Nat.add_assoc. right. + lia. +Qed. + +Fixpoint is_poly al := + match al with + | ALConst _ | ALVar _ => true + | ALNeg al => is_poly al + | ALAdd al1 al2 | ALSub al1 al2 | ALMul al1 al2 => is_poly al1 && is_poly al2 + | ALDiv _ _ _ | ALMod _ _ _ | ALShl _ _ | ALShr _ _ => false + end. + +(* advanced check when these are polynomials, otherwise just [==] *) +Definition compare_array_length '(ws, al) '(ws', al') := + if is_poly al && is_poly al' then + let ef := expanded_form (ALMul (ALConst (wsize_size ws)) al) in + let ef' := expanded_form (ALMul (ALConst (wsize_size ws')) al') in + ef == ef' + else (ws == ws') && (al == al'). + Definition convertible (t t' : atype) := match t with - | aarr ws n => - if t' is aarr ws' n' then arr_size ws n == arr_size ws' n' else false + | aarr ws al => + if t' is aarr ws' al' then compare_array_length (ws, al) (ws', al') else false | _ => t == t' end. Lemma convertible_refl t : convertible t t. -Proof. by case: t => //=. Qed. +Proof. + case: t => //= ws len. + by case: ifP => _; rewrite !eq_refl. +Qed. #[global] Hint Resolve convertible_refl : core. Lemma convertible_sym ty1 ty2 : convertible ty1 ty2 -> convertible ty2 ty1. Proof. - case: ty1 ty2 => [||ws1 n1|ws1] [||ws2 n2|ws2] //=. - + by rewrite eq_sym. + case: ty1 ty2 => [||ws1 al1|ws1] [||ws2 al2|ws2] //=. + + by rewrite eq_sym (eq_sym ws1) (eq_sym al1) andbC. by rewrite eq_sym. Qed. Lemma convertible_trans ty2 ty1 ty3 : convertible ty1 ty2 -> convertible ty2 ty3 -> convertible ty1 ty3. Proof. - case: ty1 ty2 => [||ws1 n1|ws1] [||ws2 n2|ws2] //=. - + by move=> /eqP ->. + case: ty1 ty2 ty3 => [||ws1 al1|ws1] [||ws2 al2|ws2] [||ws3 al3|ws3] //=. + + case h1: is_poly => /=. + + case h2: is_poly => /=. + + move=> /eqP ->. + case h3: is_poly => //=. + by move=> /andP [_ /eqP]; congruence. + by move=> /andP [_ /eqP]; congruence. + move=> /andP [/eqP heq1 /eqP heq2]. + by move: h1; rewrite heq1 heq2 => -> /=. by move=> /eqP ->. Qed. +Fixpoint eval_mono (env : length_var -> option Z) (mono : list length_var) : option Z := + match mono with + | [::] => Some 1 + | x :: mono => + let%opt zx := env x in + let%opt zmono := eval_mono env mono in + Some (zx * zmono) + end%Z. + +Fixpoint eval_expand (env : length_var -> option Z) terms : option Z := + match terms with + | [::] => Some 0 + | (count, mono) :: terms => + let%opt zmono := eval_mono env mono in + let%opt zterms := eval_expand env terms in + Some (count * zmono + zterms) + end%Z. + +Lemma insert_mono_correct env x mono : + eval_mono env (insert_mono x mono) = + let%opt zx := env x in + let%opt zmono := eval_mono env mono in + Some (zx * zmono)%Z. +Proof. +Local Opaque Z.add Z.mul. + elim: mono => [|x2 mono ih] /=. + - done. + - case: length_var_cmp => //=. + rewrite ih. + case: (env x) (env x2) => [zx|] [zx2|] //=. + case: eval_mono => [?|//]. apply f_equal. lia. +Local Transparent Z.add Z.mul. +Qed. + +Lemma insert_term_correct env cm terms : + eval_expand env (insert_term cm terms) = + let%opt zterms := eval_expand env terms in + let%opt zmono := eval_mono env (snd cm) in + Some (zterms + fst cm * zmono)%Z. +Proof. + elim: terms => [|cm2 terms ih] //=. + - case: cm => [count mono] /=. + case: eval_mono => [?|//]. + apply f_equal. lia. + case: List.list_compareP. + + move=> x y. split. + + by apply cmp_eq. + move=> <-. by apply cmp_refl. + + case: cm ih => [coeff mono] /= ih. + case: cm2 => [coeff2 mono2] /=. + move=> ?; subst mono2. (* + case: Z.eqb_spec. + + move=> ?. + case: eval_mono => [?|//]. + case: eval_expand => [?|//]. + move=> [<-] [->]. + apply f_equal. lia. + move=> _ /=. *) + case: eval_mono => [?|//]. + case: eval_expand => [?|//]. + apply f_equal. lia. + + case: cm ih => [coeff mono] /= ih. + case: cm2 => [coeff2 mono2] /=. move=> ???. + case: (eval_mono env mono) (eval_mono env mono2) (eval_expand env terms) => [?|] [?|] [?|] //. + apply f_equal. lia. + + case: cm ih => [coeff mono] /= ih. + case: cm2 => [coeff2 mono2] /=. move=> ???. + rewrite ih. + case: eval_mono => [?|//]. + case: eval_expand => [?|//]. + case: eval_mono => [?|//]. + apply f_equal. lia. + + case: cm ih => [coeff mono] /= ih. + case: cm2 => [coeff2 mono2] /=. move=> ????????. + case: (eval_mono env mono) (eval_mono env mono2) (eval_expand env terms) => [?|] [?|] [?|] //. + apply f_equal. lia. + case: cm ih => [coeff mono] /= ih. + case: cm2 => [coeff2 mono2] /=. move=> ????????. + rewrite ih. + case: eval_mono => [?|//]. + case: eval_expand => [?|//]. + case: eval_mono => [?|//]. + apply f_equal. lia. +Qed. + +Lemma insert_term_nice_correct env cm terms : + eval_expand env (insert_term_nice cm terms) = + let%opt zterms := eval_expand env terms in + let%opt zmono := eval_mono env (snd cm) in + Some (zterms + fst cm * zmono)%Z. +Proof. + rewrite /insert_term_nice. (* + case: Z.eqb_spec. + + move=> -> -> _. + apply f_equal. lia. + move=> _. *) + by apply insert_term_correct. +Qed. + +Lemma expanded_form_sound p : + is_poly p -> + forall env, + eval_expand env (expanded_form p) = eval_opt env p. +Proof. +Local Opaque Z.add Z.mul. + move=> hpoly env. move: p hpoly. + apply (expanded_form_elim + (P := fun p terms => is_poly p -> eval_expand env terms = eval_opt env p) + (P0 := fun _ terms coeff mono p' terms' => + is_poly p' -> + eval_expand env terms' = + let%opt zterms := eval_expand env terms in + let%opt zmono := eval_mono env mono in + let%opt zp' := eval_opt env p' in + Some (zterms + coeff * zmono * zp')))%Z => //=. (* + match eval_expand env terms, eval_mono env mono, eval env p' with + | Some zterms, Some zmono, Some zp' => Some (zterms + coeff * zmono * zp') + | _, _, _ => None + end))%Z. *) + - move=> p h /h ->. + case: eval_opt => [?|//]. + apply f_equal. lia. + - move=> _ terms coeff mono n _. + rewrite insert_term_nice_correct /=. + case: eval_expand => [?|//]. + case: eval_mono => [?|//]. + apply f_equal. lia. + - move=> _ terms coeff mono x _. + rewrite insert_term_nice_correct /= insert_mono_correct. + case: (eval_expand env terms) (eval_mono env mono) (env x) => [?|] [?|] [?|] //. + apply f_equal. lia. + - move=> p terms coeff mono e h /h ->. + case: eval_expand => [?|//]. + case: eval_mono => [?|//]. + case: eval_opt => [?|//]. + apply f_equal. lia. + - move=> p terms coeff mono e1 e2 /= h1 h2 /andP [/h1{}h1 /h2{}h2]. + rewrite h2 h1. + case: eval_expand => [?|//]. + case: eval_mono => [?|//]. + case: eval_opt => [?|//]. + case: eval_opt => [?|//]. + apply f_equal. lia. + - move=> p terms coeff mono e1 e2 /= h1 h2 /andP [/h1{}h1 /h2{}h2]. + rewrite h2 h1. + case: eval_expand => [?|//]. + case: eval_mono => [?|//]. + case: eval_opt => [?|//]. + case: eval_opt => [?|//]. + apply f_equal. lia. + - move=> p terms coeff mono n e h /h{}h. + rewrite h. + case: eval_expand => [?|//]. + case: eval_mono => [?|//]. + case: eval_opt => [?|//]. + apply f_equal. lia. + - move=> p terms coeff mono x e h /h{}h. + rewrite h insert_mono_correct. + case: eval_expand => [?|//]. + case: (eval_mono env mono) (eval_opt env e) (env x) => [?|] [?|] [?|] //. + apply f_equal. lia. + - move=> p terms coeff mono e1 e2 h /h{}h. + rewrite h. + case: eval_expand => [?|//]. + case: eval_mono => [?|//]. + case: eval_opt => [?|//]. + case: eval_opt => [?|//]. + apply f_equal. lia. + - move=> p terms coeff mono e11 e12 e2 h1 h2 /andP [/andP [hpoly11 hpoly12] hpoly2]. + move: h1 h2; rewrite hpoly11 hpoly12 hpoly2 => /(_ erefl) h1 /(_ erefl) h2. + rewrite h2 h1. + case: eval_expand => [?|//]. + case: eval_mono => [?|//]. + case: (eval_opt env e11) (eval_opt env e12) (eval_opt env e2) => [?|] [?|] [?|] //. + apply f_equal. lia. + - move=> p terms coeff mono e11 e12 e2 h1 h2 /andP [/andP [hpoly11 hpoly12] hpoly2]. + move: h1 h2; rewrite hpoly11 hpoly12 hpoly2 => /(_ erefl) h1 /(_ erefl) h2. + rewrite h2 h1. + case: eval_expand => [?|//]. + case: eval_mono => [?|//]. + case: (eval_opt env e11) (eval_opt env e12) (eval_opt env e2) => [?|] [?|] [?|] //. + apply f_equal. lia. + move=> p terms coeff mono e11 e12 e2 h /andP [/andP [hpoly11 hpoly12] hpoly2]. + move: h; rewrite hpoly11 hpoly12 hpoly2 => /(_ erefl) h. + rewrite h. + case: eval_expand => [?|//]. + case: eval_mono => [?|//]. + case: (eval_opt env e11) (eval_opt env e12) (eval_opt env e2) => [?|] [?|] [?|] //. + apply f_equal. lia. +Local Transparent Z.add Z.mul. +Qed. + +Lemma compare_array_length_eval ws1 len1 ws2 len2 : + compare_array_length (ws1, len1) (ws2, len2) -> + forall env, + arr_size ws1 (eval env len1) = arr_size ws2 (eval env len2). +Proof. +Local Opaque wsize_size Z.mul. + rewrite /compare_array_length. + case: andP. + + move=> [hpoly1 hpoly2] /eqP heq env. + have := @expanded_form_sound (ALMul (ALConst (wsize_size ws1)) len1) hpoly1 env. + have := @expanded_form_sound (ALMul (ALConst (wsize_size ws2)) len2) hpoly2 env. + rewrite /= heq => ->. + rewrite /eval. + case: (eval_opt env len1) (eval_opt env len2) => [z1|] [z2|] //. + move=> []. + rewrite !arr_sizeE. + have ?: (0 < wsize_size ws1)%Z by []. + have ?: (0 < wsize_size ws2)%Z by []. + by case: (ZltP 0 z1) (ZltP 0 z2) => [?|?] [?|?]; nia. + by move=> _ /andP [/eqP -> /eqP ->]. +Local Transparent wsize_size Z.mul. +Qed. + Lemma convertible_eval_atype ty1 ty2 : convertible ty1 ty2 -> - eval_atype ty1 = eval_atype ty2. + forall env, + eval_atype env ty1 = eval_atype env ty2. Proof. - case: ty1 ty2 => [||ws1 n1|ws1] [||ws2 n2|ws2] //=. - + by move=> /eqP <-. +Local Opaque wsize_size Z.mul. + move=> hc env. + case: ty1 ty2 hc => [||ws1 n1|ws1] [||ws2 n2|ws2] //=. + + by move=> /compare_array_length_eval ->. by move=> /eqP [<-]. +Local Transparent wsize_size Z.mul. Qed. Lemma all2_convertible_eval_atype tys1 tys2 : all2 convertible tys1 tys2 -> - map eval_atype tys1 = map eval_atype tys2. + forall env, + map (eval_atype env) tys1 = map (eval_atype env) tys2. Proof. - elim: tys1 tys2 => [|ty1 tys1 ih1] [|ty2 tys2] //=. + move=> hc env. + elim: tys1 tys2 hc => [|ty1 tys1 ih1] [|ty2 tys2] //=. by move=> /andP [/convertible_eval_atype -> /ih1 ->]. Qed. @@ -328,7 +913,7 @@ Lemma subatypeE ty ty' : | _ => convertible ty ty' end. Proof. - case: ty => [||ws n|ws]; try by move/eqP => <-. + case: ty => [||ws al|ws]; try by move/eqP => <-. + by case: ty'. by case: ty' => //; eauto. Qed. @@ -340,21 +925,28 @@ Lemma subatypeEl ty ty' : | _ => convertible ty ty' end. Proof. - case: ty => [||ws n|ws] //=. + case: ty => [||ws al|ws] //=. by case: ty' => //; eauto. Qed. Lemma subatype_refl ty : subatype ty ty. -Proof. case: ty => //=. Qed. +Proof. +Local Opaque convertible. + by case: ty => //=. +Local Transparent convertible. +Qed. #[global] Hint Resolve subatype_refl : core. Lemma subatype_trans ty2 ty1 ty3 : subatype ty1 ty2 -> subatype ty2 ty3 -> subatype ty1 ty3. Proof. - case: ty1 => //= [/eqP<-|/eqP<-|ws1 n1|ws1] //. - + by case: ty2 => //= ws2 n2 /eqP ->. - by case: ty2 => //= ws2 hle; case: ty3 => //= ws3; apply: cmp_le_trans hle. +Local Opaque convertible. + case: ty1 ty2 => [||ws1 al1|ws1] [||ws2 al2|ws2] //=. + + by apply convertible_trans. + case: ty3 => // ws3. + by apply cmp_le_trans. +Local Transparent convertible. Qed. Lemma is_aword_subatype t1 t2 : subatype t1 t2 -> is_aword t1 = is_aword t2. @@ -405,29 +997,73 @@ Qed. Lemma subatype_subctype ty1 ty2 : subatype ty1 ty2 -> - subctype (eval_atype ty1) (eval_atype ty2). + forall env, + subctype (eval_atype env ty1) (eval_atype env ty2). Proof. - case: ty1 ty2 => [||ws1 n1|ws1] [||ws2 n2|ws2] //=. - by move=> /eqP <-. +Local Opaque convertible. + move=> hsub env. + have suff hc: convertible ty1 ty2. + + by move=> /convertible_eval_atype ->. + case: ty1 ty2 hsub hc => [||ws1 n1|ws1] [||ws2 n2|ws2] // hsub hc; eauto. +Local Transparent convertible. Qed. +Section SUBST. + +(* When [f x] returns [None], we preserve [x]. Is this reasonable? + Can this situation happen? If not, then this is a reasonable thing to do. + If yes, does this mean that we ignore an error? Or does this mean that + [x] is a variable that we do not want to substitute? +*) +Context (f : length_var -> option array_length). + +Fixpoint subst_al al := + match al with + | ALConst _ => al + | ALVar x => if f x is Some al' then al' else al + | ALNeg al => ALNeg (subst_al al) + | ALAdd al1 al2 => + ALAdd (subst_al al1) (subst_al al2) + | ALSub al1 al2 => + ALSub (subst_al al1) (subst_al al2) + | ALMul al1 al2 => + ALMul (subst_al al1) (subst_al al2) + | ALDiv sg al1 al2 => + ALDiv sg (subst_al al1) (subst_al al2) + | ALMod sg al1 al2 => + ALMod sg (subst_al al1) (subst_al al2) + | ALShl al1 al2 => + ALShl (subst_al al1) (subst_al al2) + | ALShr al1 al2 => + ALShr (subst_al al1) (subst_al al2) + end. + +Definition subst_ty ty := + match ty with + | aarr ws al => + aarr ws (subst_al al) + | _ => ty + end. + +End SUBST. + (* -------------------------------------------------------------------- *) #[only(eqbOK)] derive -Variant extended_type (len:Type) : Type := +Variant extended_type : Type := | ETbool | ETint - | ETarr of wsize & len + | ETarr of wsize & array_length | ETword of (option signedness) & wsize. -Definition tbool {len} := ETbool len. -Definition tint {len} := ETint len. -Definition tarr {len} (ws : wsize) (l : len) := ETarr ws l. -Definition tword {len} ws : extended_type len:= ETword len None ws. -Definition twint {len} (s : signedness) (ws : wsize) := ETword len (Some s) ws. -Definition tuint {len} ws : extended_type len := twint Unsigned ws. -Definition tsint {len} ws : extended_type len := twint Signed ws. +Definition tbool := ETbool. +Definition tint := ETint. +Definition tarr (ws : wsize) (al : array_length) := ETarr ws al. +Definition tword ws : extended_type := ETword None ws. +Definition twint (s : signedness) (ws : wsize) := ETword (Some s) ws. +Definition tuint ws : extended_type := twint Unsigned ws. +Definition tsint ws : extended_type := twint Signed ws. -Definition to_atype (t:extended_type positive) : atype := +Definition to_atype (t:extended_type) : atype := match t with | ETbool => abool | ETint => aint @@ -435,8 +1071,4 @@ Definition to_atype (t:extended_type positive) : atype := | ETword _ ws => aword ws end. -Section EQ. -Context {L : eqType}. - -HB.instance Definition _ := hasDecEq.Build (extended_type L) (extended_type_eqb_OK (@eqP _)). -End EQ. +HB.instance Definition _ := hasDecEq.Build extended_type extended_type_eqb_OK. diff --git a/proofs/lang/utils.v b/proofs/lang/utils.v index 1bafb464fc..c46d1e51e5 100644 --- a/proofs/lang/utils.v +++ b/proofs/lang/utils.v @@ -1549,6 +1549,7 @@ Proof. move=> /P_ltP ? /P_leP ?;apply /P_ltP; Lia.lia. Qed. (* TODO: when elpi.derive supports it, register Pos.eqb_spec instead *) #[only(eqbOK)] derive positive. +#[only(eqbOK)] derive Z. HB.instance Definition _ := hasDecEq.Build positive positive_eqb_OK. diff --git a/proofs/lang/values.v b/proofs/lang/values.v index ddeddda8a1..9b8f540a76 100644 --- a/proofs/lang/values.v +++ b/proofs/lang/values.v @@ -57,12 +57,12 @@ Lemma Varr_inj n n' t t' (e: @Varr n t = @Varr n' t') : exists en: n = n', eq_rect n (λ s, WArray.array s) t n' en = t'. Proof. case: e => ?; subst n'; exists erefl. - exact: (Eqdep_dec.inj_pair2_eq_dec _ Pos.eq_dec). + exact: (Eqdep_dec.inj_pair2_eq_dec _ Z.eq_dec). Qed. Corollary Varr_inj1 n t t' : @Varr n t = @Varr n t' -> t = t'. Proof. - by move=> /Varr_inj [en ]; rewrite (Eqdep_dec.UIP_dec Pos.eq_dec en erefl). + by move=> /Varr_inj [en ]; rewrite (Eqdep_dec.UIP_dec Z.eq_dec en erefl). Qed. Lemma Vword_inj sz sz' w w' (e: @Vword sz w = @Vword sz' w') : @@ -795,7 +795,7 @@ Proof. Qed. Lemma vuincl_copy_eq ws p : - let sz := Z.to_pos (arr_size ws p) in + let sz := arr_size ws p in forall vs vs' v, List.Forall2 value_uincl vs vs' -> @app_sopn_v [::carr sz] [::carr sz] (@WArray.copy ws p) vs = ok v -> @@ -818,7 +818,7 @@ Proof. Qed. Lemma vuincl_copy ws p : - let sz := Z.to_pos (arr_size ws p) in + let sz := arr_size ws p in forall vs vs' v, List.Forall2 value_uincl vs vs' -> @app_sopn_v [::carr sz] [::carr sz] (@WArray.copy ws p) vs = ok v -> @@ -891,7 +891,7 @@ Section FORALL. End FORALL. -Definition interp_safe_cond (vs : values) (sc : safe_cond) := +Definition interp_safe_cond (vs : values) (sc : safe_cond Z) := match sc with | NotZero ws k => forall w, to_word ws (nth undef_b vs k) = ok w -> wunsigned w <> 0%Z @@ -905,9 +905,9 @@ Definition interp_safe_cond (vs : values) (sc : safe_cond) := forall w1 w2, to_word ws (nth undef_b vs k1) = ok w1 -> to_word ws (nth undef_b vs k2) = ok w2 -> (wunsigned w1 + wunsigned w2 <= z)%Z - | AllInit ws p k => - forall t, to_arr (Z.to_pos (arr_size ws p)) (nth undef_b vs k) = ok t -> - forall i, (0 <= i < p)%Z -> + | AllInit ws len k => + forall t, to_arr (arr_size ws len) (nth undef_b vs k) = ok t -> + forall i, (0 <= i < len)%Z -> exists w, WArray.get Aligned AAscale ws t i = ok w | X86Division sz sign => forall hi lo dv, @@ -931,7 +931,7 @@ Definition interp_safe_cond (vs : values) (sc : safe_cond) := | ScFalse => False end. -Definition sc_needed_args sc := +Definition sc_needed_args {len} (sc : safe_cond len) := match sc with | NotZero _ k | InRangeMod32 _ _ _ k | AllInit _ _ k | ULt _ k _ | UGe _ _ k => S k | UaddLe _ k1 k2 _ => S (if ssrnat.leq k1 k2 then k2 else k1) diff --git a/proofs/lang/var.v b/proofs/lang/var.v index e8f76f7715..cf5e3f5455 100644 --- a/proofs/lang/var.v +++ b/proofs/lang/var.v @@ -98,7 +98,7 @@ Definition is_inline_var (x: var) : bool := Definition is_var_in_memory (x: var) : bool := match Ident.id_kind x.(vname) with | Stack _ | Reg (_, Pointer _) | Global => true - | Const | Inline | Reg (_, Direct) => false + | Const | Inline | Reg (_, Direct) | Length => false end. Definition is_ptr (x: var) : bool := diff --git a/proofs/lang/varmap.v b/proofs/lang/varmap.v index 200c110cb5..5cfb29fd15 100644 --- a/proofs/lang/varmap.v +++ b/proofs/lang/varmap.v @@ -1,4 +1,5 @@ From mathcomp Require Import ssreflect ssrfun ssrbool seq eqtype ssralg. +From mathcomp Require Import word_ssrZ. From Coq Require Import ZArith Setoid Morphisms. Require Export var type values. Import Utf8 ssrbool. @@ -65,7 +66,7 @@ Definition vm_truncate_val ty v := match v, ty with | Vbool _, cbool => v | Vint _, cint => v - | Varr p _, carr p' => if p == p' then v else undef_addr ty + | Varr len _, carr len' => if len == len' then v else undef_addr ty | Vword ws w, cword ws' => if (sw_allowed || (ws' <= ws)%CMP) then if (ws <= ws')%CMP then Vword w else Vword (zero_extend ws' w) @@ -433,36 +434,36 @@ End Section. Module Type VM. - Parameter t : forall {wsw:WithSubWord}, Type. + Parameter t : forall {wsw:WithSubWord}, (length_var -> option Z) -> Type. - Parameter init : forall {wsw:WithSubWord}, t. + Parameter init : forall {wsw:WithSubWord} env, t env. - Parameter get : forall {wsw:WithSubWord}, t -> var -> value. + Parameter get : forall {wsw:WithSubWord} env, t env -> var -> value. - Parameter set : forall {wsw:WithSubWord}, t -> var -> value -> t. + Parameter set : forall {wsw:WithSubWord} env, t env -> var -> value -> t env. - Parameter initP : forall {wsw:WithSubWord} x, - get init x = undef_addr (eval_atype (vtype x)). + Parameter initP : forall {wsw:WithSubWord} env x, + get (init env) x = undef_addr (eval_atype env (vtype x)). - Parameter getP : forall {wsw:WithSubWord} vm x, - compat_val (eval_atype (vtype x)) (get vm x). + Parameter getP : forall {wsw:WithSubWord} env (vm : t env) x, + compat_val (eval_atype env (vtype x)) (get vm x). - Parameter setP : forall {wsw:WithSubWord} vm x v y, - get (set vm x v) y = if x == y then vm_truncate_val (eval_atype (vtype x)) v else get vm y. + Parameter setP : forall {wsw:WithSubWord} env (vm : t env) x v y, + get (set vm x v) y = if x == y then vm_truncate_val (eval_atype env (vtype x)) v else get vm y. - Parameter setP_eq : forall {wsw:WithSubWord} vm x v, get (set vm x v) x = vm_truncate_val (eval_atype (vtype x)) v. + Parameter setP_eq : forall {wsw:WithSubWord} env (vm : t env) x v, get (set vm x v) x = vm_truncate_val (eval_atype env (vtype x)) v. - Parameter setP_neq : forall {wsw:WithSubWord} vm x v y, x != y -> get (set vm x v) y = get vm y. + Parameter setP_neq : forall {wsw:WithSubWord} env (vm : t env) x v y, x != y -> get (set vm x v) y = get vm y. End VM. Module Vm : VM. Section Section. - Context {wsw: WithSubWord}. + Context {wsw: WithSubWord} (env : length_var -> option Z). Definition wf (data: Mvar.t value) := - forall x v, Mvar.get data x = Some v -> compat_val (eval_atype (vtype x)) v. + forall x v, Mvar.get data x = Some v -> compat_val (eval_atype env (vtype x)) v. Record t_ := { data :> Mvar.t value; prop : wf data }. Definition t := t_. @@ -472,28 +473,28 @@ Module Vm : VM. Definition init := {| prop := init_prop |}. - Definition get (vm:t) (x:var) := odflt (undef_addr (eval_atype (vtype x))) (Mvar.get vm x). + Definition get (vm:t) (x:var) := odflt (undef_addr (eval_atype env (vtype x))) (Mvar.get vm x). - Lemma set_prop (vm:t) x v : wf (Mvar.set vm x (vm_truncate_val (eval_atype (vtype x)) v)). + Lemma set_prop (vm:t) x v : wf (Mvar.set vm x (vm_truncate_val (eval_atype env (vtype x)) v)). Proof. move=> y vy; rewrite Mvar.setP; case: eqP => [<- [<-] | _ /prop //]. apply vm_truncate_val_compat. Qed. Definition set (vm:t) (x:var) v := - {| data := Mvar.set vm x (vm_truncate_val (eval_atype (vtype x)) v); prop := @set_prop vm x v |}. + {| data := Mvar.set vm x (vm_truncate_val (eval_atype env (vtype x)) v); prop := @set_prop vm x v |}. - Lemma initP x : get init x = undef_addr (eval_atype (vtype x)). + Lemma initP x : get init x = undef_addr (eval_atype env (vtype x)). Proof. done. Qed. - Lemma getP vm x : compat_val (eval_atype (vtype x)) (get vm x). + Lemma getP vm x : compat_val (eval_atype env (vtype x)) (get vm x). Proof. rewrite /get; case h : Mvar.get => [ v | ] /=;[apply: prop h | apply compat_val_undef_addr]. Qed. Lemma setP vm x v y : - get (set vm x v) y = if x == y then vm_truncate_val (eval_atype (vtype x)) v else get vm y. + get (set vm x v) y = if x == y then vm_truncate_val (eval_atype env (vtype x)) v else get vm y. Proof. by rewrite /get /set Mvar.setP; case: eqP => [<- | hne]. Qed. - Lemma setP_eq vm x v : get (set vm x v) x = vm_truncate_val (eval_atype (vtype x)) v. + Lemma setP_eq vm x v : get (set vm x v) x = vm_truncate_val (eval_atype env (vtype x)) v. Proof. by rewrite setP eqxx. Qed. Lemma setP_neq vm x v y : x != y -> get (set vm x v) y = get vm y. @@ -505,36 +506,36 @@ End Vm. Declare Scope vm_scope. Delimit Scope vm_scope with vm. -Notation "vm .[ x ]" := (@Vm.get _ vm x) : vm_scope. -Notation "vm .[ x <- v ]" := (@Vm.set _ vm x v) : vm_scope. +Notation "vm .[ x ]" := (@Vm.get _ _ vm x) : vm_scope. +Notation "vm .[ x <- v ]" := (@Vm.set _ _ vm x v) : vm_scope. Open Scope vm_scope. Section GET_SET. -Context {wsw: WithSubWord}. +Context {wsw: WithSubWord} (env : length_var -> option Z). -Lemma vm_truncate_val_get x vm : - vm_truncate_val (eval_atype (vtype x)) vm.[x] = vm.[x]. +Lemma vm_truncate_val_get x (vm : Vm.t env) : + vm_truncate_val (eval_atype env (vtype x)) vm.[x] = vm.[x]. Proof. apply/compat_val_vm_truncate_val/Vm.getP. Qed. -Lemma getP_subctype vm x : subctype (type_of_val vm.[x]) (eval_atype (vtype x)). +Lemma getP_subctype (vm : Vm.t env) x : subctype (type_of_val vm.[x]) (eval_atype env (vtype x)). Proof. apply/compat_ctype_subctype/Vm.getP. Qed. -Lemma subctype_undef_get vm x : - subctype (undef_t (eval_atype (vtype x))) (type_of_val vm.[x]). +Lemma subctype_undef_get (vm : Vm.t env) x : + subctype (undef_t (eval_atype env (vtype x))) (type_of_val vm.[x]). Proof. have /compat_ctype_undef_t <- := Vm.getP vm x. apply undef_t_subctype. Qed. -Definition set_var wdb vm x v := +Definition set_var wdb (vm : Vm.t env) x v := Let _ := assert (DB wdb v) ErrAddrUndef in - Let _ := assert (truncatable wdb (eval_atype (vtype x)) v) ErrType in + Let _ := assert (truncatable wdb (eval_atype env (vtype x)) v) ErrType in ok vm.[x <- v]. (* Ensure that the variable is defined *) -Definition get_var wdb vm x := +Definition get_var wdb (vm : Vm.t env) x := let v := vm.[x]%vm in Let _ := assert (~~wdb || is_defined v) ErrAddrUndef in ok v. @@ -542,19 +543,19 @@ Definition get_var wdb vm x := Definition get_vars wdb vm := mapM (get_var wdb vm). Definition vm_initialized_on vm : seq var → Prop := - all (λ x, is_ok (get_var true vm x >>= of_val (eval_atype (vtype x)))). + all (λ x, is_ok (get_var true vm x >>= of_val (eval_atype env (vtype x)))). Lemma set_varP wdb vm x v vm' : - set_var wdb vm x v = ok vm' <-> [/\ DB wdb v, truncatable wdb (eval_atype (vtype x)) v & vm' = vm.[x <- v]]. + set_var wdb vm x v = ok vm' <-> [/\ DB wdb v, truncatable wdb (eval_atype env (vtype x)) v & vm' = vm.[x <- v]]. Proof. by rewrite /set_var; split => [ | [-> -> -> //]]; t_xrbindP. Qed. Lemma set_var_truncate wdb x v : - DB wdb v -> truncatable wdb (eval_atype (vtype x)) v -> + DB wdb v -> truncatable wdb (eval_atype env (vtype x)) v -> forall vm, set_var wdb vm x v = ok vm.[x <- v]. Proof. by rewrite /set_var => -> ->. Qed. Lemma set_var_eq_type wdb x v: - DB wdb v -> type_of_val v = eval_atype (vtype x) -> + DB wdb v -> type_of_val v = eval_atype env (vtype x) -> forall vm, set_var wdb vm x v = ok vm.[x <- v]. Proof. move => h1 h2; apply set_var_truncate => //; rewrite -h2; apply truncatable_type_of. Qed. @@ -562,11 +563,11 @@ Lemma set_varDB wdb vm x v vm' : set_var wdb vm x v = ok vm' -> DB wdb v. Proof. by move=> /set_varP []. Qed. Lemma get_varP wdb vm x v : get_var wdb vm x = ok v -> - [/\ v = vm.[x], ~~wdb || is_defined v & compat_val (eval_atype (vtype x)) v]. + [/\ v = vm.[x], ~~wdb || is_defined v & compat_val (eval_atype env (vtype x)) v]. Proof. rewrite/get_var;t_xrbindP => ? <-; split => //; apply Vm.getP. Qed. Lemma get_var_compat wdb vm x v : get_var wdb vm x = ok v -> - (~~wdb || is_defined v) /\ compat_val (eval_atype (vtype x)) v. + (~~wdb || is_defined v) /\ compat_val (eval_atype env (vtype x)) v. Proof. by move=>/get_varP []. Qed. Lemma get_var_undef vm x v ty h : @@ -575,18 +576,18 @@ Proof. by move=> /get_var_compat [] * ?; subst. Qed. Lemma get_varI vm x v : get_var true vm x = ok v -> match v with - | Vbool _ => eval_atype (vtype x) = cbool - | Vint _ => eval_atype (vtype x) = cint - | Varr len _ => eval_atype (vtype x) = carr len + | Vbool _ => eval_atype env (vtype x) = cbool + | Vint _ => eval_atype env (vtype x) = cint + | Varr len _ => eval_atype env (vtype x) = carr len | Vword ws _ => - exists2 ws', eval_atype (vtype x) = cword ws' & + exists2 ws', eval_atype env (vtype x) = cword ws' & if sw_allowed then ((ws <= ws')%CMP:Prop) else ws = ws' | Vundef ty' _ => False end. Proof. by move=> /get_var_compat [] + /compat_valE; case: v. Qed. Lemma get_varE vm x v : get_var true vm x = ok v -> - match eval_atype (vtype x) with + match eval_atype env (vtype x) with | cbool => exists b, v = Vbool b | cint => exists i, v = Vint i | carr len => exists t, v = @Varr len t @@ -595,12 +596,12 @@ Lemma get_varE vm x v : get_var true vm x = ok v -> if sw_allowed then ((ws' <= ws)%CMP:Prop) else ws = ws' end. Proof. - by move=> /get_var_compat [] h1 /compat_valEl h2; case:vtype h2 h1 => [ | | len | ws] // [->|]. + by move=> /get_var_compat [] h1 /compat_valEl h2; case:eval_atype h2 h1 => [ | | len | ws] // [->|]. Qed. Lemma type_of_get_var wdb x vm v : get_var wdb vm x = ok v -> - subctype (type_of_val v) (eval_atype x.(vtype)). + subctype (type_of_val v) (eval_atype env x.(vtype)). Proof. by move=> /get_var_compat [] _; rewrite /compat_val /compat_ctype; case: ifP => // _ /eqP <-. Qed. @@ -609,16 +610,16 @@ Qed. Lemma type_of_get_var_not_word vm x v : (sw_allowed -> ~ is_aword x.(vtype)) -> get_var true vm x = ok v -> - type_of_val v = eval_atype x.(vtype). + type_of_val v = eval_atype env x.(vtype). Proof. move=> h /get_var_compat [] /= hdb; rewrite /compat_val /compat_ctype hdb orbF. case: ifP => //; last by move=> _ /eqP. by move=> /h; case: vtype => //= [||ws len] _ /subctypeE. Qed. -Lemma get_word_uincl_eq vm x ws (w:word ws) : +Lemma get_word_uincl_eq (vm : Vm.t env) x ws (w:word ws) : value_uincl (Vword w) vm.[x] -> - subctype (eval_atype (vtype x)) (cword ws) -> + subctype (eval_atype env (vtype x)) (cword ws) -> vm.[x] = Vword w. Proof. move => /value_uinclE [ws' [w' [heq ]]]; have := getP_subctype vm x; rewrite heq. @@ -640,29 +641,29 @@ Ltac t_vm_get := Section REL. - Context {wsw1 wsw2 : WithSubWord}. + Context {wsw1 wsw2 : WithSubWord} (env : length_var -> option Z). Section Section. Context (R:value -> value -> Prop). - Definition vm_rel (P : var -> Prop) (vm1 : @Vm.t wsw1) (vm2 : @Vm.t wsw2) := + Definition vm_rel (P : var -> Prop) (vm1 : @Vm.t wsw1 env) (vm2 : @Vm.t wsw2 env) := forall x, P x -> R (Vm.get vm1 x) (Vm.get vm2 x). Lemma vm_rel_set (P : var -> Prop) vm1 vm2 x v1 v2 : - (P x -> R (vm_truncate_val (wsw:=wsw1) (eval_atype (vtype x)) v1) (vm_truncate_val (wsw:=wsw2) (eval_atype (vtype x)) v2)) -> + (P x -> R (vm_truncate_val (wsw:=wsw1) (eval_atype env (vtype x)) v1) (vm_truncate_val (wsw:=wsw2) (eval_atype env (vtype x)) v2)) -> vm_rel (fun z => x <> z /\ P z) vm1 vm2 -> vm_rel P vm1.[x <- v1] vm2.[x <- v2]. Proof. move=> h hu y hy; rewrite !Vm.setP; case: eqP => heq; subst; auto. Qed. Lemma vm_rel_set_r (P : var -> Prop) vm1 vm2 x v2 : - (P x -> R vm1.[x] (vm_truncate_val (wsw:=wsw2) (eval_atype (vtype x)) v2)) -> + (P x -> R vm1.[x] (vm_truncate_val (wsw:=wsw2) (eval_atype env (vtype x)) v2)) -> vm_rel (fun z => x <> z /\ P z) vm1 vm2 -> vm_rel P vm1 (vm2.[x <- v2]). Proof. move=> h hu y hy; rewrite !Vm.setP; case: eqP => heq; subst; auto. Qed. Lemma vm_rel_set_l (P : var -> Prop) vm1 vm2 x v1 : - (P x -> R (vm_truncate_val (wsw:=wsw1) (eval_atype (vtype x)) v1) vm2.[x]) -> + (P x -> R (vm_truncate_val (wsw:=wsw1) (eval_atype env (vtype x)) v1) vm2.[x]) -> vm_rel (fun z => x <> z /\ P z) vm1 vm2 -> vm_rel P vm1.[x <- v1] vm2. Proof. move=> h hu y hy; rewrite !Vm.setP; case: eqP => heq; subst; auto. Qed. @@ -672,61 +673,61 @@ Section REL. #[export] Instance vm_rel_impl : Proper (subrelation ==> pointwise_lifting (Basics.flip Basics.impl) (Tcons var Tnil) ==> - @eq Vm.t ==> @eq Vm.t ==> Basics.impl) vm_rel. + @eq (Vm.t env) ==> @eq (Vm.t env) ==> Basics.impl) vm_rel. Proof. by move=> R1 R2 hR P1 P2 hP vm1 ? <- vm2 ? <- h x hx; apply/hR/h/hP. Qed. #[export] Instance vm_rel_m : Proper (relation_equivalence ==> pointwise_lifting iff (Tcons var Tnil) ==> - @eq Vm.t ==> @eq Vm.t ==> iff) vm_rel. + @eq (Vm.t env) ==> @eq (Vm.t env) ==> iff) vm_rel. Proof. move=> R1 R2 hR P1 P2 hP vm1 ? <- vm2 ? <-; split; apply vm_rel_impl => //. 1,3: by move=> ??;apply hR. 1,2: by move=> x /=; case: (hP x). Qed. - Definition vm_eq (vm1:Vm.t (wsw:=wsw1)) (vm2:Vm.t (wsw:=wsw2)) := + Definition vm_eq (vm1:Vm.t (wsw:=wsw1) env) (vm2:Vm.t (wsw:=wsw2) env) := forall x, vm1.[x] = vm2.[x]. Definition eq_on (X:Sv.t) := vm_rel (@eq value) (fun x => Sv.In x X). Definition eq_ex (X:Sv.t) := vm_rel (@eq value) (fun x => ~Sv.In x X). - Definition vm_uincl (vm1:Vm.t (wsw:=wsw1)) (vm2:Vm.t (wsw:=wsw2)) := + Definition vm_uincl (vm1:Vm.t (wsw:=wsw1) env) (vm2:Vm.t (wsw:=wsw2) env) := forall x, value_uincl vm1.[x] vm2.[x]. Definition uincl_on (X:Sv.t) := vm_rel value_uincl (fun x => Sv.In x X). Definition uincl_ex (X:Sv.t) := vm_rel value_uincl (fun x => ~Sv.In x X). #[export] Instance eq_on_impl : - Proper (Basics.flip Sv.Subset ==> @eq Vm.t ==> @eq Vm.t ==> Basics.impl) eq_on. + Proper (Basics.flip Sv.Subset ==> @eq (Vm.t env) ==> @eq (Vm.t env) ==> Basics.impl) eq_on. Proof. by move=> s1 s2 hS; apply vm_rel_impl. Qed. #[export] Instance eq_on_m : - Proper (Sv.Equal ==> @eq Vm.t ==> @eq Vm.t ==> iff) eq_on. + Proper (Sv.Equal ==> @eq (Vm.t env) ==> @eq (Vm.t env) ==> iff) eq_on. Proof. by move=> s1 s2 hS; apply vm_rel_m. Qed. #[export] Instance eq_ex_impl : - Proper (Sv.Subset ==> @eq Vm.t ==> @eq Vm.t ==> Basics.impl) eq_ex. + Proper (Sv.Subset ==> @eq (Vm.t env) ==> @eq (Vm.t env) ==> Basics.impl) eq_ex. Proof. by move=> s1 s2 hS; apply vm_rel_impl => // x hnx hx; apply/hnx/hS. Qed. #[export] Instance eq_ex_m : - Proper (Sv.Equal ==> @eq Vm.t ==> @eq Vm.t ==> iff) eq_ex. + Proper (Sv.Equal ==> @eq (Vm.t env) ==> @eq (Vm.t env) ==> iff) eq_ex. Proof. by move=> s1 s2 hS; apply vm_rel_m => // x; rewrite hS. Qed. #[export] Instance uincl_on_impl : - Proper (Basics.flip Sv.Subset ==> @eq Vm.t ==> @eq Vm.t ==> Basics.impl) uincl_on. + Proper (Basics.flip Sv.Subset ==> @eq (Vm.t env) ==> @eq (Vm.t env) ==> Basics.impl) uincl_on. Proof. by move=> s1 s2 hS; apply vm_rel_impl. Qed. #[export] Instance uincl_on_m : - Proper (Sv.Equal ==> @eq Vm.t ==> @eq Vm.t ==> iff) uincl_on. + Proper (Sv.Equal ==> @eq (Vm.t env) ==> @eq (Vm.t env) ==> iff) uincl_on. Proof. by move=> s1 s2 hS; apply vm_rel_m. Qed. #[export] Instance uincl_ex_impl : - Proper (Sv.Subset ==> @eq Vm.t ==> @eq Vm.t ==> Basics.impl) uincl_ex. + Proper (Sv.Subset ==> @eq (Vm.t env) ==> @eq (Vm.t env) ==> Basics.impl) uincl_ex. Proof. by move=> s1 s2 hS; apply vm_rel_impl => // x hnx hx; apply/hnx/hS. Qed. #[export] Instance uincl_ex_m : - Proper (Sv.Equal ==> @eq Vm.t ==> @eq Vm.t ==> iff) uincl_ex. + Proper (Sv.Equal ==> @eq (Vm.t env) ==> @eq (Vm.t env) ==> iff) uincl_ex. Proof. by move=> s1 s2 hS; apply vm_rel_m => // x; rewrite hS. Qed. Lemma vm_eq_vm_rel vm1 vm2 : vm_eq vm1 vm2 <-> vm_rel (@eq value) (fun _ => True) vm1 vm2. @@ -761,112 +762,112 @@ Notation "vm1 '<=[\' s ']' vm2" := (uincl_ex s vm1 vm2) format "'[hv ' vm1 <=[\ s ] '/' vm2 ']'") : vm_scope. Section REL_EQUIV. - Context {wsw : WithSubWord}. + Context {wsw : WithSubWord} (env : length_var -> option Z). - Lemma vm_rel_refl R P : Reflexive R -> Reflexive (vm_rel R P). + Lemma vm_rel_refl R P : Reflexive R -> Reflexive (vm_rel (env:=env) R P). Proof. by move=> h x v _. Qed. - Lemma vm_rel_sym R P : Symmetric R -> Symmetric (vm_rel R P). + Lemma vm_rel_sym R P : Symmetric R -> Symmetric (vm_rel (env:=env) R P). Proof. by move=> h x y hxy v hv; apply/h/hxy. Qed. - Lemma vm_rel_trans R P : Transitive R -> Transitive (vm_rel R P). + Lemma vm_rel_trans R P : Transitive R -> Transitive (vm_rel (env:=env) R P). Proof. move=> h x y z hxy hyz v hv; apply: h (hxy v hv) (hyz v hv). Qed. Lemma vm_relI R (P1 P2 : var -> Prop) vm1 vm2 : (forall x, P1 x -> P2 x) -> - vm_rel R P2 vm1 vm2 -> vm_rel R P1 vm1 vm2. + vm_rel (env:=env) R P2 vm1 vm2 -> vm_rel (env:=env) R P1 vm1 vm2. Proof. by move=> h hvm v /h hv; apply hvm. Qed. - #[export]Instance equiv_vm_rel R P : Equivalence R -> Equivalence (vm_rel R P). + #[export]Instance equiv_vm_rel R P : Equivalence R -> Equivalence (vm_rel (env:=env) R P). Proof. by constructor; [apply: vm_rel_refl | apply: vm_rel_sym | apply: vm_rel_trans]. Qed. - #[export]Instance equiv_vm_eq : Equivalence vm_eq. + #[export]Instance equiv_vm_eq : Equivalence (vm_eq (env:=env)). Proof. by constructor => > // => [h1 x | h1 h2 x]; rewrite h1 ?h2. Qed. - #[export]Instance equiv_eq_on s : Equivalence (eq_on s). + #[export]Instance equiv_eq_on s : Equivalence (eq_on (env:=env) s). Proof. apply equiv_vm_rel; apply eq_equivalence. Qed. - #[export]Instance equiv_eq_ex s : Equivalence (eq_ex s). + #[export]Instance equiv_eq_ex s : Equivalence (eq_ex (env:=env) s). Proof. apply equiv_vm_rel; apply eq_equivalence. Qed. - #[export]Instance po_vm_rel R P: PreOrder R -> PreOrder (vm_rel R P). + #[export]Instance po_vm_rel R P: PreOrder R -> PreOrder (vm_rel (env:=env) R P). Proof. by constructor; [apply: vm_rel_refl | apply: vm_rel_trans]. Qed. #[export]Instance po_value_uincl : PreOrder value_uincl. Proof. constructor => // ???; apply value_uincl_trans. Qed. - #[export]Instance po_vm_uincl : PreOrder vm_uincl. + #[export]Instance po_vm_uincl : PreOrder (vm_uincl (env:=env)). Proof. constructor => [ vm1 // | vm1 vm2 vm3]. rewrite !vm_uincl_vm_rel; apply vm_rel_trans => ???; apply value_uincl_trans. Qed. - #[export]Instance po_uincl_on s : PreOrder (uincl_on s). + #[export]Instance po_uincl_on s : PreOrder (uincl_on (env:=env) s). Proof. apply po_vm_rel; apply po_value_uincl. Qed. - #[export]Instance po_uincl_ex s : PreOrder (uincl_ex s). + #[export]Instance po_uincl_ex s : PreOrder (uincl_ex (env:=env) s). Proof. apply po_vm_rel; apply po_value_uincl. Qed. - Lemma vm_uincl_refl vm : vm <=1 vm. + Lemma vm_uincl_refl (vm : Vm.t env) : vm <=1 vm. Proof. done. Qed. - Lemma vm_uinclT vm2 vm1 vm3 : vm1 <=1 vm2 -> vm2 <=1 vm3 -> vm1 <=1 vm3. + Lemma vm_uinclT (vm2 vm1 vm3 : Vm.t env) : vm1 <=1 vm2 -> vm2 <=1 vm3 -> vm1 <=1 vm3. Proof. rewrite !vm_uincl_vm_rel; apply vm_rel_trans => ???; apply: value_uincl_trans. Qed. - Lemma eq_on_refl s vm : vm =[s] vm. + Lemma eq_on_refl s (vm : Vm.t env) : vm =[s] vm. Proof. by apply vm_rel_refl. Qed. - Lemma eq_onT vm2 vm1 vm3 s: + Lemma eq_onT (vm2 vm1 vm3 : Vm.t env) s: vm1 =[s] vm2 -> vm2 =[s] vm3 -> vm1 =[s] vm3. Proof. by apply vm_rel_trans => > -> ->. Qed. - Lemma eq_onS s vm1 vm2 : vm1 =[s] vm2 -> vm2 =[s] vm1. + Lemma eq_onS s (vm1 vm2 : Vm.t env) : vm1 =[s] vm2 -> vm2 =[s] vm1. Proof. by apply vm_rel_sym. Qed. - Lemma eq_onI s1 s2 vm1 vm2 : Sv.Subset s1 s2 -> vm1 =[s2] vm2 -> vm1 =[s1] vm2. + Lemma eq_onI s1 s2 (vm1 vm2 : Vm.t env) : Sv.Subset s1 s2 -> vm1 =[s2] vm2 -> vm1 =[s1] vm2. Proof. move=> h1; apply vm_relI; SvD.fsetdec. Qed. - Lemma eq_ex_refl s vm : vm =[\s] vm. + Lemma eq_ex_refl s (vm : Vm.t env) : vm =[\s] vm. Proof. by apply vm_rel_refl. Qed. - Lemma eq_exT vm2 vm1 vm3 s: + Lemma eq_exT (vm2 vm1 vm3 : Vm.t env) s: vm1 =[\s] vm2 -> vm2 =[\s] vm3 -> vm1 =[\s] vm3. Proof. by apply vm_rel_trans => > -> ->. Qed. - Lemma eq_exS s vm1 vm2 : vm1 =[\s] vm2 -> vm2 =[\s] vm1. + Lemma eq_exS s (vm1 vm2 : Vm.t env) : vm1 =[\s] vm2 -> vm2 =[\s] vm1. Proof. by apply vm_rel_sym. Qed. - Lemma eq_exI s1 s2 vm1 vm2 : Sv.Subset s2 s1 -> vm1 =[\s2] vm2 -> vm1 =[\s1] vm2. + Lemma eq_exI s1 s2 (vm1 vm2 : Vm.t env) : Sv.Subset s2 s1 -> vm1 =[\s2] vm2 -> vm1 =[\s1] vm2. Proof. move=> h1; apply vm_relI; SvD.fsetdec. Qed. - Lemma uincl_on_refl vm s : vm <=[s] vm. + Lemma uincl_on_refl (vm : Vm.t env) s : vm <=[s] vm. Proof. done. Qed. - Lemma uincl_onT vm2 vm1 vm3 s: + Lemma uincl_onT (vm2 vm1 vm3 : Vm.t env) s: vm1 <=[s] vm2 -> vm2 <=[s] vm3 -> vm1 <=[s] vm3. Proof. apply vm_rel_trans => ???; apply value_uincl_trans. Qed. - Lemma uincl_onI s1 s2 vm1 vm2 : Sv.Subset s1 s2 -> vm1 <=[s2] vm2 -> vm1 <=[s1] vm2. + Lemma uincl_onI s1 s2 (vm1 vm2 : Vm.t env) : Sv.Subset s1 s2 -> vm1 <=[s2] vm2 -> vm1 <=[s1] vm2. Proof. move=> h1; apply vm_relI; SvD.fsetdec. Qed. - Lemma uincl_ex_refl s vm : vm <=[\s] vm. + Lemma uincl_ex_refl s (vm : Vm.t env) : vm <=[\s] vm. Proof. apply vm_rel_refl => ?; apply value_uincl_refl. Qed. - Lemma uincl_exT vm2 vm1 vm3 s: + Lemma uincl_exT (vm2 vm1 vm3 : Vm.t env) s: vm1 <=[\s] vm2 -> vm2 <=[\s] vm3 -> vm1 <=[\s] vm3. Proof. apply vm_rel_trans => ???; apply value_uincl_trans. Qed. - Lemma uincl_exI s1 s2 vm1 vm2 : + Lemma uincl_exI s1 s2 (vm1 vm2 : Vm.t env) : Sv.Subset s2 s1 -> vm1 <=[\s2] vm2 -> vm1 <=[\s1] vm2. Proof. move=> h1; apply vm_relI; SvD.fsetdec. Qed. - Lemma eq_ex_union s1 s2 vm1 vm2 : + Lemma eq_ex_union s1 s2 (vm1 vm2 : Vm.t env) : vm1 =[\s1] vm2 -> vm1 =[\Sv.union s1 s2] vm2. Proof. apply: eq_exI; SvD.fsetdec. Qed. - Lemma eq_exTI s1 s2 vm1 vm2 vm3 : + Lemma eq_exTI s1 s2 (vm1 vm2 vm3 : Vm.t env) : vm1 =[\s1] vm2 -> vm2 =[\s2] vm3 -> vm1 =[\Sv.union s1 s2] vm3. @@ -874,13 +875,13 @@ Section REL_EQUIV. move => h12 h23; apply: (@eq_exT vm2); apply: eq_exI; eauto; SvD.fsetdec. Qed. - Lemma eq_ex_eq_on x y z e o : + Lemma eq_ex_eq_on (x y z : Vm.t env) e o : x =[\e] y → z =[o] y → x =[Sv.diff o e] z. Proof. move => he ho j hj; rewrite he ?ho; SvD.fsetdec. Qed. - Lemma vm_rel_set_var (wdb:bool) (P : var -> Prop) vm1 vm1' vm2 x v1 v2 : + Lemma vm_rel_set_var (wdb:bool) (P : var -> Prop) (vm1 vm1' vm2 : Vm.t env) x v1 v2 : value_uincl v1 v2 -> vm_rel value_uincl (fun z => x <> z /\ P z) vm1 vm2 -> set_var wdb vm1 x v1 = ok vm1' -> @@ -896,25 +897,25 @@ Section REL_EQUIV. by apply value_uincl_vm_truncate. Qed. - Lemma vm_uincl_set vm1 vm2 x v1 v2 : - value_uincl (vm_truncate_val (eval_atype (vtype x)) v1) (vm_truncate_val (eval_atype (vtype x)) v2) -> + Lemma vm_uincl_set (vm1 vm2 : Vm.t env) x v1 v2 : + value_uincl (vm_truncate_val (eval_atype env (vtype x)) v1) (vm_truncate_val (eval_atype env (vtype x)) v2) -> vm1 <=1 vm2 -> vm1.[x <- v1] <=1 vm2.[x <- v2]. Proof. by rewrite !vm_uincl_vm_rel => hvu hu; apply vm_rel_set => //; apply: vm_relI hu. Qed. - Lemma vm_uincl_set_l vm1 vm2 x v : - value_uincl (vm_truncate_val (eval_atype (vtype x)) v) vm2.[x] -> + Lemma vm_uincl_set_l (vm1 vm2 : Vm.t env) x v : + value_uincl (vm_truncate_val (eval_atype env (vtype x)) v) vm2.[x] -> vm1 <=1 vm2 -> vm1.[x <- v] <=1 vm2. Proof. by rewrite !vm_uincl_vm_rel => hvu hu; apply vm_rel_set_l => //; apply: vm_relI hu. Qed. - Lemma vm_uincl_set_r vm1 vm2 x v : - value_uincl vm1.[x] (vm_truncate_val (eval_atype (vtype x)) v) -> + Lemma vm_uincl_set_r (vm1 vm2 : Vm.t env) x v : + value_uincl vm1.[x] (vm_truncate_val (eval_atype env (vtype x)) v) -> vm1 <=1 vm2 -> vm1 <=1 vm2.[x <- v]. Proof. by rewrite !vm_uincl_vm_rel => hvu hu; apply vm_rel_set_r => //; apply: vm_relI hu. Qed. - Lemma vm_uincl_set_var wdb vm1 vm1' vm2 x v1 v2 : + Lemma vm_uincl_set_var wdb (vm1 vm1' vm2 : Vm.t env) x v1 v2 : value_uincl v1 v2 -> vm1 <=1 vm2 -> set_var wdb vm1 x v1 = ok vm1' -> @@ -925,75 +926,75 @@ Section REL_EQUIV. by apply: vm_relI h2. Qed. - Lemma uincl_on_set X vm1 vm2 x v1 v2: - (Sv.In x X -> value_uincl (vm_truncate_val (eval_atype (vtype x)) v1) (vm_truncate_val (eval_atype (vtype x)) v2)) -> + Lemma uincl_on_set X (vm1 vm2 : Vm.t env) x v1 v2: + (Sv.In x X -> value_uincl (vm_truncate_val (eval_atype env (vtype x)) v1) (vm_truncate_val (eval_atype env (vtype x)) v2)) -> vm1 <=[Sv.remove x X] vm2 -> vm1.[x <- v1] <=[X] vm2.[x <- v2]. Proof. move=> hvu hu; apply vm_rel_set => //; apply: vm_relI hu; SvD.fsetdec. Qed. - Lemma uincl_on_set_l X vm1 vm2 x v : - (Sv.In x X -> value_uincl (vm_truncate_val (eval_atype (vtype x)) v) vm2.[x]) -> + Lemma uincl_on_set_l X (vm1 vm2 : Vm.t env) x v : + (Sv.In x X -> value_uincl (vm_truncate_val (eval_atype env (vtype x)) v) vm2.[x]) -> vm1 <=[Sv.remove x X] vm2 -> vm1.[x <- v] <=[X] vm2. Proof. move=> hvu hu; apply vm_rel_set_l => //; apply: vm_relI hu; SvD.fsetdec. Qed. - Lemma uincl_on_set_r X vm1 vm2 x v : - (Sv.In x X ->value_uincl vm1.[x] (vm_truncate_val (eval_atype (vtype x)) v)) -> + Lemma uincl_on_set_r X (vm1 vm2 : Vm.t env) x v : + (Sv.In x X ->value_uincl vm1.[x] (vm_truncate_val (eval_atype env (vtype x)) v)) -> vm1 <=[Sv.remove x X] vm2 -> vm1 <=[X] vm2.[x <- v]. Proof. by move=> hvu hu; apply vm_rel_set_r => //; apply: vm_relI hu; SvD.fsetdec. Qed. - Lemma uincl_on_set_var (wdb:bool) s vm1 vm1' vm2 x v1 v2 : + Lemma uincl_on_set_var (wdb:bool) s (vm1 vm1' vm2 : Vm.t env) x v1 v2 : value_uincl v1 v2 -> vm1 <=[Sv.remove x s] vm2 -> set_var wdb vm1 x v1 = ok vm1' -> set_var wdb vm2 x v2 = ok vm2.[x<-v2] /\ vm1' <=[s] vm2.[x<-v2]. Proof. move=> h1 h2; apply vm_rel_set_var => // z hz; apply h2; SvD.fsetdec. Qed. - Lemma eq_ex_set s vm1 vm2 x v1 v2 : - (~Sv.In x s -> vm_truncate_val (eval_atype (vtype x)) v1 = vm_truncate_val (eval_atype (vtype x)) v2) -> + Lemma eq_ex_set s (vm1 vm2 : Vm.t env) x v1 v2 : + (~Sv.In x s -> vm_truncate_val (eval_atype env (vtype x)) v1 = vm_truncate_val (eval_atype env (vtype x)) v2) -> vm1 =[\Sv.add x s] vm2 -> vm1.[x<-v1] =[\ s] vm2.[x<-v2]. Proof. move=> h1 h2; apply vm_rel_set => // z hz; apply h2; SvD.fsetdec. Qed. - Lemma eq_ex_set_r s vm1 vm2 x v : - (~Sv.In x s -> vm1.[x] = vm_truncate_val (eval_atype (vtype x)) v) -> + Lemma eq_ex_set_r s (vm1 vm2 : Vm.t env) x v : + (~Sv.In x s -> vm1.[x] = vm_truncate_val (eval_atype env (vtype x)) v) -> vm1 =[\Sv.add x s] vm2 -> vm1 =[\ s] vm2.[x<-v]. Proof. move=> h1 h2; apply vm_rel_set_r => // z hz; apply h2; SvD.fsetdec. Qed. - Lemma eq_ex_set_l s vm1 vm2 x v : - (~Sv.In x s -> vm_truncate_val (eval_atype (vtype x)) v = vm2.[x]) -> + Lemma eq_ex_set_l s (vm1 vm2 : Vm.t env) x v : + (~Sv.In x s -> vm_truncate_val (eval_atype env (vtype x)) v = vm2.[x]) -> vm1 =[\Sv.add x s] vm2 -> vm1.[x<-v] =[\ s] vm2. Proof. move=> h1 h2; apply vm_rel_set_l => // z hz; apply h2; SvD.fsetdec. Qed. - Lemma uincl_ex_set s vm1 vm2 x v1 v2 : - (~Sv.In x s -> value_uincl (vm_truncate_val (eval_atype (vtype x)) v1) (vm_truncate_val (eval_atype (vtype x)) v2)) -> + Lemma uincl_ex_set s (vm1 vm2 : Vm.t env) x v1 v2 : + (~Sv.In x s -> value_uincl (vm_truncate_val (eval_atype env (vtype x)) v1) (vm_truncate_val (eval_atype env (vtype x)) v2)) -> vm1 <=[\Sv.add x s] vm2 -> vm1.[x<-v1] <=[\ s] vm2.[x<-v2]. Proof. move=> h1 h2; apply vm_rel_set => // z hz; apply h2; SvD.fsetdec. Qed. - Lemma uincl_ex_set_r s vm1 vm2 x v : - (~Sv.In x s -> value_uincl vm1.[x] (vm_truncate_val (eval_atype (vtype x)) v)) -> + Lemma uincl_ex_set_r s (vm1 vm2 : Vm.t env) x v : + (~Sv.In x s -> value_uincl vm1.[x] (vm_truncate_val (eval_atype env (vtype x)) v)) -> vm1 <=[\Sv.add x s] vm2 -> vm1 <=[\ s] vm2.[x<-v]. Proof. move=> h1 h2; apply vm_rel_set_r => // z hz; apply h2; SvD.fsetdec. Qed. - Lemma uincl_ex_set_l s vm1 vm2 x v : - (~Sv.In x s -> value_uincl (vm_truncate_val (eval_atype (vtype x)) v) vm2.[x]) -> + Lemma uincl_ex_set_l s (vm1 vm2 : Vm.t env) x v : + (~Sv.In x s -> value_uincl (vm_truncate_val (eval_atype env (vtype x)) v) vm2.[x]) -> vm1 <=[\Sv.add x s] vm2 -> vm1.[x<-v] <=[\ s] vm2. Proof. move=> h1 h2; apply vm_rel_set_l => // z hz; apply h2; SvD.fsetdec. Qed. - Lemma uincl_ex_set_var (wdb:bool) s vm1 vm1' vm2 x v1 v2 : + Lemma uincl_ex_set_var (wdb:bool) s (vm1 vm1' vm2 : Vm.t env) x v1 v2 : value_uincl v1 v2 -> vm1 <=[\s] vm2 -> set_var wdb vm1 x v1 = ok vm1' -> set_var wdb vm2 x v2 = ok vm2.[x<-v2] /\ vm1' <=[\ Sv.remove x s] vm2.[x<-v2]. Proof. move=> h1 h2; apply vm_rel_set_var => // ??; apply h2; SvD.fsetdec. Qed. - Lemma uincl_on_vm_uincl vm1 vm2 vm1' vm2' d : + Lemma uincl_on_vm_uincl (vm1 vm2 vm1' vm2' : Vm.t env) d : vm1 <=1 vm2 → vm1' <=[d] vm2' → vm1 =[\d] vm1'→ @@ -1005,7 +1006,7 @@ Section REL_EQUIV. by move => hx; rewrite -!(t1, t2) //; apply out. Qed. - Lemma eq_on_eq_vm vm1 vm2 vm1' vm2' d : + Lemma eq_on_eq_vm (vm1 vm2 vm1' vm2' : Vm.t env) d : (vm1 =1 vm2)%vm → vm1' =[d] vm2' → vm1 =[\d] vm1'→ @@ -1017,7 +1018,7 @@ Section REL_EQUIV. by move => hx; rewrite -!(t1, t2) //; apply out. Qed. - Lemma eq_on_union vm1 vm2 vm1' vm2' X Y : + Lemma eq_on_union (vm1 vm2 vm1' vm2' : Vm.t env) X Y : vm1 =[X] vm2 → vm1' =[Y] vm2' → vm1 =[\Y] vm1'→ @@ -1029,7 +1030,7 @@ Section REL_EQUIV. move => hxY; rewrite -!(t1, t2) //; apply out; SvD.fsetdec. Qed. - Lemma uincl_on_union vm1 vm2 vm1' vm2' X Y : + Lemma uincl_on_union (vm1 vm2 vm1' vm2' : Vm.t env) X Y : vm1 <=[X] vm2 → vm1' <=[Y] vm2' → vm1 =[\Y] vm1'→ @@ -1041,12 +1042,12 @@ Section REL_EQUIV. move => hxY; rewrite -!(t1, t2) //; apply out; SvD.fsetdec. Qed. - Lemma set_var_eq_ex (wdb: bool) (x:var) v vm1 vm2 : + Lemma set_var_eq_ex (wdb: bool) (x:var) v (vm1 vm2 : Vm.t env) : set_var wdb vm1 x v = ok vm2 -> vm1 =[\ Sv.singleton x] vm2. Proof. move=> /set_varP [??->] z hz; rewrite Vm.setP_neq //; apply/eqP; SvD.fsetdec. Qed. - Lemma set_var_eq_on1 wdb x v vm1 vm2 vm1': + Lemma set_var_eq_on1 wdb x v (vm1 vm2 vm1' : Vm.t env) : set_var wdb vm1 x v = ok vm2 -> set_var wdb vm1' x v = ok vm1'.[x <- v] /\ vm2 =[Sv.singleton x] vm1'.[x <- v]. Proof. @@ -1054,7 +1055,7 @@ Section REL_EQUIV. move=> z hz; rewrite !Vm.setP; case: eqP => // hne; SvD.fsetdec. Qed. - Lemma set_var_eq_on wdb s x v vm1 vm2 vm1': + Lemma set_var_eq_on wdb s x v (vm1 vm2 vm1' : Vm.t env) : set_var wdb vm1 x v = ok vm2 -> vm1 =[s] vm1' -> set_var wdb vm1' x v = ok vm1'.[x <- v] /\ vm2 =[Sv.add x s] vm1'.[x <- v]. @@ -1064,45 +1065,45 @@ Section REL_EQUIV. apply: (eq_on_union hs h); apply: set_var_eq_ex; eauto. Qed. - Lemma get_var_uincl_at wdb x vm1 vm2 v1 : + Lemma get_var_uincl_at wdb x (vm1 vm2 : Vm.t env) v1 : (value_uincl vm1.[x] vm2.[x]) -> get_var wdb vm1 x = ok v1 -> exists2 v2, get_var wdb vm2 x = ok v2 & value_uincl v1 v2. Proof. rewrite /get_var; t_xrbindP => hu /(value_uincl_defined hu) -> <- /=; eauto. Qed. - Lemma get_var_uincl wdb x vm1 vm2 v1: + Lemma get_var_uincl wdb x (vm1 vm2 : Vm.t env) v1: vm1 <=1 vm2 -> get_var wdb vm1 x = ok v1 -> exists2 v2, get_var wdb vm2 x = ok v2 & value_uincl v1 v2. Proof. move => /(_ x); exact: get_var_uincl_at. Qed. - Lemma eq_on_uincl_on X vm1 vm2 : vm1 =[X] vm2 -> vm1 <=[X] vm2. + Lemma eq_on_uincl_on X (vm1 vm2 : Vm.t env) : vm1 =[X] vm2 -> vm1 <=[X] vm2. Proof. by move=> H ? /H ->. Qed. - Lemma eq_ex_uincl_ex X vm1 vm2: vm1 =[\X] vm2 -> vm1 <=[\X] vm2. + Lemma eq_ex_uincl_ex X (vm1 vm2 : Vm.t env) : vm1 =[\X] vm2 -> vm1 <=[\X] vm2. Proof. by move=> H ? /H ->. Qed. - Lemma vm_uincl_uincl_on dom vm1 vm2 : + Lemma vm_uincl_uincl_on dom (vm1 vm2 : Vm.t env) : vm1 <=1 vm2 → vm1 <=[dom] vm2. Proof. by move => h x _; exact: h. Qed. - Lemma vm_eq_eq_on dom vm1 vm2 : + Lemma vm_eq_eq_on dom (vm1 vm2 : Vm.t env) : (vm1 =1 vm2)%vm → vm1 =[dom] vm2. Proof. by move => h x _; exact: h. Qed. - Lemma eq_on_empty vm1 vm2 : + Lemma eq_on_empty (vm1 vm2 : Vm.t env) : vm1 =[Sv.empty] vm2. Proof. by move => ?; SvD.fsetdec. Qed. - Lemma uincl_on_empty vm1 vm2 : + Lemma uincl_on_empty (vm1 vm2 : Vm.t env) : vm1 <=[Sv.empty] vm2. Proof. by move => ?; SvD.fsetdec. Qed. Hint Resolve eq_on_empty uincl_on_empty : core. - Lemma uincl_on_union_and dom dom' vm1 vm2 : + Lemma uincl_on_union_and dom dom' (vm1 vm2 : Vm.t env) : vm1 <=[Sv.union dom dom'] vm2 ↔ vm1 <=[dom] vm2 ∧ vm1 <=[dom'] vm2. Proof. @@ -1111,31 +1112,31 @@ Section REL_EQUIV. by case => h h' x /Sv.union_spec[]; [ exact: h | exact: h' ]. Qed. - Lemma vm_uincl_uincl_ex dom vm1 vm2 : + Lemma vm_uincl_uincl_ex dom (vm1 vm2 : Vm.t env) : vm1 <=1 vm2 → vm1 <=[\dom] vm2. Proof. by move => h x _; exact: h. Qed. - Instance uincl_ex_trans dom : Transitive (uincl_ex dom). + Instance uincl_ex_trans dom : Transitive (uincl_ex (env:=env) dom). Proof. by move => x y z; apply: uincl_exT. Qed. - Lemma uincl_ex_empty vm1 vm2 : + Lemma uincl_ex_empty (vm1 vm2 : Vm.t env) : vm1 <=[\ Sv.empty ] vm2 ↔ vm_uincl vm1 vm2. Proof. split; last exact: vm_uincl_uincl_ex. move => h x; apply/h; SvD.fsetdec. Qed. - Lemma eq_ex_disjoint_eq_on s s' x y : + Lemma eq_ex_disjoint_eq_on s s' (x y : Vm.t env) : x =[\s] y → disjoint s s' → x =[s'] y. Proof. rewrite /disjoint /is_true Sv.is_empty_spec => h d r hr; apply: h; SvD.fsetdec. Qed. - Lemma vm_uincl_init vm : Vm.init <=1 vm. + Lemma vm_uincl_init (vm : Vm.t env) : Vm.init env <=1 vm. Proof. move=> z; rewrite Vm.initP; apply/compat_value_uincl_undef/Vm.getP. Qed. - Lemma set_var_spec wdb x v vm1 vm2 vm1' : + Lemma set_var_spec wdb x v (vm1 vm2 vm1' : Vm.t env) : set_var wdb vm1 x v = ok vm2 -> exists vm2', [/\ set_var wdb vm1' x v = ok vm2', vm1' =[\ Sv.singleton x] vm2' & vm2'.[x] = vm2.[x] ]. Proof. @@ -1173,6 +1174,6 @@ End REL_EQUIV. #[export] Existing Instance po_uincl_ex. #[export] Existing Instance uincl_ex_trans. -#[ global ]Arguments get_var {wsw} wdb vm%_vm_scope x. -#[ global ]Arguments set_var {wsw} wdb vm%_vm_scope x v. +#[ global ]Arguments get_var {wsw env} wdb vm%_vm_scope x. +#[ global ]Arguments set_var {wsw env} wdb vm%_vm_scope x v. diff --git a/proofs/lang/warray_.v b/proofs/lang/warray_.v index 44e38ac4cf..f2b929b415 100644 --- a/proofs/lang/warray_.v +++ b/proofs/lang/warray_.v @@ -7,7 +7,7 @@ From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype div ssralg. From mathcomp Require Import word_ssrZ. From Coq Require Export ZArith Setoid Morphisms. Require Import xseq. -Require Export utils gen_map type word memory_model. +Require Export utils gen_map word memory_model. Import Utf8 ZArith Lia. #[only(eqbOK)] derive @@ -24,10 +24,10 @@ Definition mk_scale (aa:arr_access) ws := Module WArray. - Record array (s:positive) := + Record array (s:Z) := { arr_data : Mz.t u8 }. - Definition empty (s:positive) : array s := + Definition empty (s:Z) : array s := {| arr_data := Mz.empty _ |}. #[ local ] @@ -71,7 +71,7 @@ Module WArray. Qed. Section CM. - Variable (s:positive). + Variable (s:Z). Definition in_bound (_:array s) p := (0 <=? p) && (p Mz.set data i w end) (Mz.empty _) (ziota 0 size). - Definition get_sub lena (aa:arr_access) ws len (a:array lena) p : exec (array (Z.to_pos (arr_size ws len))) := + Definition get_sub lena (aa:arr_access) ws len (a:array lena) p : exec (array (arr_size ws len)) := let size := arr_size ws len in let start := (p * mk_scale aa ws)%Z in if (0 <=? start) && (start + size <=? lena) then - ok (Build_array (Z.to_pos size) (get_sub_data aa ws len (arr_data a) p)) + ok (Build_array size (get_sub_data aa ws len (arr_data a) p)) else Error ErrOob. Definition set_sub_data (aa:arr_access) ws len (a:Mz.t u8) p (b:Mz.t u8) := @@ -194,7 +194,7 @@ Module WArray. | Some w => Mz.set data (start + i) w end) a (ziota 0 size). - Definition set_sub lena (aa:arr_access) ws len (a:array lena) p (b:array (Z.to_pos (arr_size ws len))) : exec (array lena) := + Definition set_sub lena (aa:arr_access) ws len (a:array lena) p (b:array (arr_size ws len)) : exec (array lena) := let size := arr_size ws len in let start := (p * mk_scale aa ws)%Z in if (0 <=? start) && (start + size <=? lena) then @@ -205,7 +205,7 @@ Module WArray. if len' == len then ok {| arr_data := a.(arr_data) |} else type_error. - Definition of_list {ws} (l:list (word ws)) : array (Z.to_pos (Z.of_nat (size l) * wsize_size ws)) := + Definition of_list {ws} (l:list (word ws)) : array (Z.of_nat (size l) * wsize_size ws) := let m := Mz.empty in let do8 (mz: Mz.t _ * Z) (w:u8) := let '(m,z) := mz in @@ -352,13 +352,13 @@ Module WArray. by rewrite validw_in_range => /andP [] ? /in_rangeP []. Qed. - Lemma get_empty (n:positive) off : + Lemma get_empty (n:Z) off : read (empty n) Aligned off U8 = if (0 <=? off) && (off + Lemma get0 (n:Z) off : (0 <= off ∧ off < n)%Z -> read (empty n) Aligned off U8 = Error ErrAddrUndef. Proof. by rewrite get_empty => -[/ZleP -> /ZltP ->]. Qed. @@ -420,12 +420,15 @@ Module WArray. t_xrbindP => a' w /(uincl_get hu) -> /= ->; apply: hrec. Qed. - Lemma fill_aux_ok len bytes : size bytes ≤ Pos.to_nat len → is_ok (fill_aux len bytes). + Lemma fill_aux_ok len bytes : size bytes ≤ Z.to_nat len → is_ok (fill_aux len bytes). Proof. move => hsize. + have [hneg|hpos] := Z.nonpos_pos_cases len. + + have: size bytes = 0%nat by lia. + by move=> /size0nil ->. have : (0, empty len).1 + Z.of_nat (size bytes) <= len by rewrite /=; lia. clear hsize. - have : bytes = [::] ∨ in_bound (0, empty len).2 (0, empty len).1 by right. + have : bytes = [::] ∨ in_bound (0, empty len).2 (0, empty len).1 by right; apply /ZltP. rewrite /fill_aux; move: (0, empty len). elim: bytes => // b bytes ih [] p t /= [ // | ] hpt. rewrite {2}/set -set_write8 /= /set8 Z.mul_1_r hpt /= => hsize. @@ -438,7 +441,7 @@ Module WArray. Definition fill_size len l a : fill len l = ok a -> - Pos.to_nat len = size l. + Z.to_nat len = size l. Proof. by rewrite /fill; t_xrbindP => /eqP. Qed. Lemma fill_get8 len l a : @@ -458,8 +461,14 @@ Module WArray. last first. + move=> /(_ _ _ hfold) ->. rewrite Z.sub_0_r get_empty /=. - rewrite hsize positive_nat_Z. - by case: andb. + rewrite hsize. + case: len {a hfold hsize} => [|len|len]. + + by move=> /=; case: andb. + + rewrite Z2Nat.id //. + by case: andb. + case: ifPn; rewrite !zify; first by lia. + case: ifPn; rewrite !zify; first by lia. + done. elim: l {hsize hfold} => [ | w l ih] z0 a0 /=. + move=> [_ <-]. by case: ifP => //; rewrite !zify; lia. @@ -486,8 +495,13 @@ Module WArray. else Mz.get a k. Proof. rewrite /set_sub_data. + have [hneg|hpos] := Z.le_gt_cases (arr_size ws len) 0. + + rewrite ziota_neg //=. + case: ifP => //. + rewrite !zify. + by lia. elim /natlike_ind: (arr_size ws len) a; - last by apply: Z.lt_le_incl (gt0_arr_size _ _). + last by apply: Z.lt_le_incl hpos. + move=> data; rewrite ziota0 /=; case: andP => // -[]; rewrite !zify; lia. move=> sz hsz ih data; rewrite ziotaS_cat // foldr_cat Z.add_0_l /= ih. case: ifPn; rewrite !zify => h3; case: ifPn; rewrite !zify => h4 //. @@ -521,7 +535,7 @@ Module WArray. Proof. by rewrite /set_sub; case: ifP => //; rewrite !zify. Qed. Transparent arr_size. Opaque Z.mul ziota. - Lemma set_sub_get lena ws len (t: array lena) i (s: array (Z.to_pos (arr_size ws len))) t': + Lemma set_sub_get lena ws len (t: array lena) i (s: array (arr_size ws len)) t': set_sub AAscale t i s = ok t' -> forall j, get Aligned AAscale ws t' j = @@ -530,9 +544,6 @@ Module WArray. Proof. move=> hget j. have ht':= set_sub_get8 hget. - have := set_sub_bound hget. - have ltws := wsize_size_pos ws; rewrite /arr_size /mk_scale => hb. - have [{hb} h0i hilen'] : (0 <= i /\ i + len <= lena)%Z by nia. rewrite /get !readE !is_aligned_if_is_align ?is_align_scale // /=. case: ifPn. + move=> /andP[]/ZleP ? /ZltP ?. @@ -561,8 +572,13 @@ Module WArray. else None. Proof. rewrite /get_sub_data -(Mz.get0 u8 k). + have [hneg|hpos] := Z.le_gt_cases (arr_size ws len) 0. + + rewrite ziota_neg //=. + case: ifP => //. + rewrite !zify. + by lia. elim /natlike_ind: (arr_size ws len) (Mz.empty u8); - last by apply: Z.lt_le_incl (gt0_arr_size _ _). + last by apply: Z.lt_le_incl hpos. + move => b; rewrite ziota0 /=; case: andP => //; rewrite !zify; lia. move=> sz hsz ih b; rewrite ziotaS_cat // foldr_cat Z.add_0_l /= ih. case: ifPn; rewrite !zify => h3; case: ifPn; rewrite !zify => h4 //. @@ -609,7 +625,7 @@ Module WArray. Qed. Lemma uincl_set_sub {ws len1 len2 len} (a1 a1': array len1) (a2: array len2) aa i - (t1 t2:array (Z.to_pos (arr_size ws len))) : + (t1 t2:array (arr_size ws len)) : uincl a1 a2 -> uincl t1 t2 -> set_sub aa a1 i t1 = ok a1' -> exists2 a2', set_sub aa a2 i t2 = ok a2' & uincl a1' a2'. diff --git a/proofs/lang/wsize.v b/proofs/lang/wsize.v index 062a4a878a..ed7910dbfd 100644 --- a/proofs/lang/wsize.v +++ b/proofs/lang/wsize.v @@ -30,6 +30,17 @@ Definition wsize_size (sz: wsize) : Z := | U256 => 32 end. +Definition arr_size (ws:wsize) (len:Z) := + (wsize_size ws * len)%Z. + +Lemma arr_sizeE ws len : arr_size ws len = (wsize_size ws * len)%Z. +Proof. done. Qed. + +Lemma gt0_arr_size ws len : (0 < len)%Z -> (0 < arr_size ws len)%Z. +Proof. by move=> ?; rewrite arr_sizeE; apply Z.mul_pos_pos. Qed. + +#[global] Opaque arr_size. + (* Size in bits of the elements of a vector. *) #[only(eqbOK)] derive Variant velem := VE8 | VE16 | VE32 | VE64. @@ -183,10 +194,11 @@ Variant v_kind := | Reg of reg_kind * reference (* register variable *) | Inline (* inline variable *) | Global (* global (in memory) constant *) +| Length (* length variable *) . (* -------------------------------------------------------------------- *) -Variant safe_cond := +Variant safe_cond (len : Type) := (* the nth argument must be different from 0 *) | NotZero of wsize & nat (* this is a division instruction, two words by one word; @@ -201,9 +213,17 @@ Variant safe_cond := (* the sum of the nth arguments (unsigned interpretation) must be in the <= z *) | UaddLe of wsize & nat & nat & Z (* the nth argument of is an array ws[p] where all ceil are initialized *) - | AllInit of wsize & positive & nat + | AllInit of wsize & len & nat (* Unsatisfiable safe_cond *) | ScFalse. +Arguments NotZero {_} _ _. +Arguments X86Division {_} _ _. +Arguments InRangeMod32 {_} _ _ _ _. +Arguments ULt {_} _ _ _. +Arguments UGe {_} _ _ _. +Arguments UaddLe {_} _ _ _ _. +Arguments AllInit {_} _ _ _. +Arguments ScFalse {_}. (* -------------------------------------------------------------------- *) Class PointerData := {