diff --git a/compiler/linter/Analyser/BackwardAnalyser.ml b/compiler/linter/Analyser/BackwardAnalyser.ml index f166b67a4..7409bcc05 100644 --- a/compiler/linter/Analyser/BackwardAnalyser.ml +++ b/compiler/linter/Analyser/BackwardAnalyser.ml @@ -15,12 +15,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 + -> (Wsize.wsize * length) Syscall_t.syscall_t -> exprs -> domain -> domain annotation @@ -199,9 +199,9 @@ struct | Copn (lvs, tag, sopn, es) -> let annotation = Annotation.bind annotation (L.opn loc lvs tag sopn es) in (Copn (lvs, tag, sopn, es), annotation) - | Ccall (lvs, fn, es) -> - let annotation = Annotation.bind annotation (L.funcall loc lvs fn es) in - (Ccall (lvs, fn, es), annotation) + | 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, es) -> let annotation = Annotation.bind annotation (L.syscall loc lvs sc es) in (Csyscall (lvs, sc, es), annotation) diff --git a/compiler/linter/Analyser/BackwardAnalyser.mli b/compiler/linter/Analyser/BackwardAnalyser.mli index d10e82cb8..69d4e87d7 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.Wsize.wsize * Jasmin.CoreIdent.length) Jasmin.Syscall_t.syscall_t -> Jasmin.Prog.exprs -> domain -> domain Annotation.annotation (** diff --git a/compiler/linter/Analyser/ForwardAnalyser.ml b/compiler/linter/Analyser/ForwardAnalyser.ml index 2f061ab62..21a5ee0a7 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 + -> (Wsize.wsize * length) Syscall_t.syscall_t -> exprs -> domain -> domain annotation @@ -180,9 +180,9 @@ module Make (Logic : Logic) : S with type domain = Logic.domain = struct | Copn (lvs, tag, sopn, es) -> let annotation = Annotation.bind annotation (Logic.opn loc lvs tag sopn es) in (Copn (lvs, tag, sopn, es), annotation) - | Ccall (lvs, fn, es) -> - let annotation = Annotation.bind annotation (Logic.funcall loc lvs fn es) in - (Ccall (lvs, fn, es), annotation) + | 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, es) -> let annotation = Annotation.bind annotation (Logic.syscall loc lvs sc es) in (Csyscall (lvs, sc, es), annotation) diff --git a/compiler/linter/Analyser/ForwardAnalyser.mli b/compiler/linter/Analyser/ForwardAnalyser.mli index b31a2d2e0..2f9146946 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.Wsize.wsize * Jasmin.CoreIdent.length) Jasmin.Syscall_t.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 4b7353617..0277f5d0c 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) + (_ : (Wsize.wsize * length) Syscall_t.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 186770f27..4aea09447 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 dce69fd94..9d3041351 100644 --- a/compiler/linter/Checker/VariableInitialisation.ml +++ b/compiler/linter/Checker/VariableInitialisation.ml @@ -51,7 +51,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 | Cif (e, _, _) -> check_e i_info e diff --git a/compiler/safetylib/safetyAbsExpr.ml b/compiler/safetylib/safetyAbsExpr.ml index 763f09ead..ad96788f5 100644 --- a/compiler/safetylib/safetyAbsExpr.ml +++ b/compiler/safetylib/safetyAbsExpr.ml @@ -27,7 +27,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 @@ -39,10 +45,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 @@ -215,7 +227,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))) + (PrintCommon.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 @@ -223,7 +235,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 (PrintCommon.pp_ty ~debug:false) gv.v_ty; raise (Aint_error "Bad type") let check_is_word v = @@ -232,7 +244,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 (PrintCommon.pp_ty ~debug:false) gv.v_ty; raise (Aint_error "Bad type") @@ -415,8 +427,14 @@ module AbsExpr (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 @@ -451,7 +469,7 @@ module AbsExpr (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 @@ -461,6 +479,11 @@ module AbsExpr (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 @@ -1067,6 +1090,11 @@ module AbsExpr (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 @@ -1078,7 +1106,7 @@ module AbsExpr (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 @@ -1145,6 +1173,11 @@ module AbsExpr (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 001e10c39..8a406674b 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/safetyInterpreter.ml b/compiler/safetylib/safetyInterpreter.ml index 6799e8906..7c2702196 100644 --- a/compiler/safetylib/safetyInterpreter.ml +++ b/compiler/safetylib/safetyInterpreter.ml @@ -39,7 +39,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 (PrintCommon.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)) @@ -133,6 +133,7 @@ let pp_ows fmt ws = let pp_arr_slice fmt slice = let open PrintCommon in + let pp_len = 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 @@ -141,7 +142,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 @@ -227,7 +228,7 @@ let add64 x e = Papp2 (E.Oadd ( E.Op_w U64), Pvar x, e) 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; @@ -349,6 +350,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 @@ -383,6 +389,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 @@ -430,6 +441,11 @@ let safe_opn safe opn es = let n = Papp2 (E.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 @@ -467,7 +483,7 @@ let safe_instr ginstr = match ginstr.i_desc with | Copn (lvs,_,opn,es) -> safe_opn (safe_lvals lvs @ safe_es es) opn es | 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 = @@ -1622,7 +1638,7 @@ end = struct | 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' @@ -1755,7 +1771,12 @@ end = struct let aeval_syscall state sc lvs _es = match sc with | Syscall_t.RandomBytes (ws, len) -> - let n = BinInt.Z.to_pos (Type.arr_size ws len) in + let len = + match len with + | Prog.Const len -> len + | _ -> assert false + in + let n = Conv.pos_of_int (Prog.arr_size ws len) in let cells = match lvs with | [ Lnone _ ] -> [] | [ Lvar x ] -> cells_of_array x 0 n @@ -2054,7 +2075,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 180986ac3..498aad45e 100644 --- a/compiler/safetylib/safetyPreanalysis.ml +++ b/compiler/safetylib/safetyPreanalysis.ml @@ -104,8 +104,8 @@ end = struct 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) @@ -364,7 +364,7 @@ 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 = @@ -427,7 +427,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 diff --git a/compiler/safetylib/safetyVar.ml b/compiler/safetylib/safetyVar.ml index 9f18cabe0..f91466922 100644 --- a/compiler/safetylib/safetyVar.ml +++ b/compiler/safetylib/safetyVar.ml @@ -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 034f71401..2128dfa3d 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 d098a02d3..00ce15133 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 && Typing.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 (PrintCommon.pp_len ~debug:false) hi let pp_slice fmt s = match s.kind with @@ -58,15 +66,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 -> @@ -121,9 +139,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 @@ -149,13 +170,17 @@ 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 + | _ -> assert false + end (* Precondition: s1 and s2 are normal forms (aka roots) in a *) (* x1[e1:n1] = x2[e2:n2] *) @@ -173,8 +198,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 @@ -186,6 +211,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 -> @@ -197,7 +227,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 @@ -244,7 +274,7 @@ 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) + | Ccall (xs, fn, _al, es) -> link_array_return params a xs es (cc fn) | Csyscall (xs, o, 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) -> diff --git a/compiler/src/alias.mli b/compiler/src/alias.mli index 25f32ee80..51022159b 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 2997daf14..494f162ac 100644 --- a/compiler/src/array_expand.ml +++ b/compiler/src/array_expand.ml @@ -4,7 +4,7 @@ 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 ws, sz = array_kind_const 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 diff --git a/compiler/src/compile.ml b/compiler/src/compile.ml index 599815cd0..5ddeb2bdd 100644 --- a/compiler/src/compile.ml +++ b/compiler/src/compile.ml @@ -100,9 +100,10 @@ let do_wint_int raise (HiError e) 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 diff --git a/compiler/src/conv.ml b/compiler/src/conv.ml index c80cbe624..0819de002 100644 --- a/compiler/src/conv.ml +++ b/compiler/src/conv.ml @@ -33,17 +33,33 @@ 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_pos n) + | ALVar x -> Var x + | ALAdd (al1, al2) -> Add (al_of_cal al1, al_of_cal al2) + | ALMul (al1, al2) -> Mul (al_of_cal al1, al_of_cal al2) + +let rec cal_of_al al = + let open Type in + match al with + | Const n -> ALConst (pos_of_int n) + | Var x -> ALVar x + | Add (al1, al2) -> ALAdd (cal_of_al al1, cal_of_al al2) + | Mul (al1, al2) -> ALMul (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 +101,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 +118,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 +139,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 +147,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) (* ------------------------------------------------------------------------ *) @@ -143,6 +159,10 @@ let expr_of_cexprs es = List.map (expr_of_cexpr) es (* ------------------------------------------------------------------------ *) +let map_syscall (f : 'a -> 'b) (o : (W.wsize * 'a) Syscall_t.syscall_t) : (W.wsize * 'b) Syscall_t.syscall_t = + match o with + | RandomBytes (ws, x) -> RandomBytes (ws, f x) + let rec cinstr_of_instr i = let n = i.i_loc, i.i_annot in cinstr_r_of_instr_r n i.i_desc @@ -161,7 +181,7 @@ and cinstr_r_of_instr_r p i = | Csyscall(x,o,e) -> let ir = - C.Csyscall(clval_of_lvals x, o, cexpr_of_exprs e) in + C.Csyscall(clval_of_lvals x, map_syscall cal_of_al o, cexpr_of_exprs e) in C.MkI(p, ir) | Cif(e,c1,c2) -> @@ -180,8 +200,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 = @@ -202,7 +222,7 @@ and instr_r_of_cinstr_r = function 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) + Csyscall(lval_of_clvals x, map_syscall al_of_cal o, expr_of_cexprs e) | C.Cif(e,c1,c2) -> let c1 = stmt_of_cstmt c1 in @@ -218,8 +238,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 @@ -234,6 +254,7 @@ let cufdef_of_fdef fd = let f_body = cstmt_of_stmt fd.f_body in let f_res = List.map cvari_of_vari fd.f_ret in fn, { C.f_info = f_info; + 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; @@ -250,6 +271,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; @@ -289,7 +311,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 90bf4999e..3d507182d 100644 --- a/compiler/src/conv.mli +++ b/compiler/src/conv.mli @@ -29,6 +29,9 @@ val z_of_word : wsize -> Obj.t -> Z.t val z_unsigned_of_word : wsize -> Obj.t -> Z.t (* -------------------------------------------------------------------- *) +val map_syscall : ('a -> 'b) -> (wsize * 'a) Syscall_t.syscall_t -> (wsize * 'b) Syscall_t.syscall_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 diff --git a/compiler/src/coreIdent.ml b/compiler/src/coreIdent.ml index 487d18ccc..7332a46ae 100644 --- a/compiler/src/coreIdent.ml +++ b/compiler/src/coreIdent.ml @@ -86,13 +86,28 @@ module GV = struct let is_glob v = v.v_kind = Const let is_local v = not (is_glob v) + + (* 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 + | Add of length * length + | Mul of length * length + +type ty = length gty +type var = length gvar module V = struct type t = var diff --git a/compiler/src/coreIdent.mli b/compiler/src/coreIdent.mli index 028e6bc96..8ca111047 100644 --- a/compiler/src/coreIdent.mli +++ b/compiler/src/coreIdent.mli @@ -78,13 +78,20 @@ module GV : sig (* Fixme : still used *) val is_local : '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 + | Add of length * length + | Mul of length * length + +type ty = length gty +type var = length gvar module V : sig type t = var diff --git a/compiler/src/ct_checker_forward.ml b/compiler/src/ct_checker_forward.ml index 118731927..00b814934 100644 --- a/compiler/src/ct_checker_forward.ml +++ b/compiler/src/ct_checker_forward.ml @@ -179,7 +179,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 @@ -586,7 +586,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/evaluator.ml b/compiler/src/evaluator.ml index 1ecbd5f05..8ca18e71c 100644 --- a/compiler/src/evaluator.ml +++ b/compiler/src/evaluator.ml @@ -51,24 +51,24 @@ type ('syscall_state, 'asm) state = exception Final of Memory.mem * values -let return ep spp s = +let return ep spp env s = assert (s.s_cmd = []); match s.s_stk with | Sempty(ii, f) -> let s2 = s.s_estate in let m2 = s2.emem and vm2 = s2.evm in let vres = - exn_exec ii (mapM (fun (x:var_i) -> get_var nosubword true vm2 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 + exn_exec ii (mapM (fun (x:var_i) -> get_var nosubword env true vm2 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 raise (Final(m2, vres')) | Scall(ii,f,xs,vm1,c,stk) -> let gd = s.s_prog.p_globs in let {escs = scs2; emem = m2; evm = vm2} = s.s_estate in let vres = - exn_exec ii (mapM (fun (x:var_i) -> get_var nosubword true vm2 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 - let s1 = exn_exec ii (write_lvals nosubword ep spp true gd {escs = scs2; emem = m2; evm = vm1 } xs vres') in + exn_exec ii (mapM (fun (x:var_i) -> get_var nosubword env true vm2 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 + let s1 = exn_exec ii (write_lvals nosubword ep spp env true gd {escs = scs2; emem = m2; evm = vm1 } xs vres') in { s with s_cmd = c; s_estate = s1; @@ -78,14 +78,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 @@ -93,68 +93,67 @@ 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 + let ves = exn_exec ii (sem_pexprs nosubword ep spp env true gd s1 es) in 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__ sip._sc_sem ep._pd env s1.escs s1.emem o 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 } | 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 + | Ccall(xs,fn,al,es) -> + let vargs' = exn_exec ii (sem_pexprs nosubword ep spp env true gd s1 es) in let f = match get_fundef s.s_prog.p_funcs fn with | Some f -> f | None -> assert false in - let vargs = exn_exec ii (mapM2 ErrType truncate_val (List.map eval_atype f.f_tyin) vargs') in + let vargs = exn_exec ii (mapM2 ErrType truncate_val (List.map (eval_atype env) f.f_tyin) vargs') in let {escs; emem = m1; evm = vm1} = s1 in let stk = Scall(ii,f, xs, vm1, c, s.s_stk) in let sf = - exn_exec ii (write_vars nosubword ep true f.f_params vargs {escs; emem = m1; evm = Vm.init nosubword}) in + exn_exec ii (write_vars nosubword ep env true f.f_params vargs {escs; emem = m1; evm = Vm.init nosubword env}) in {s with s_cmd = f.f_body; s_estate = sf; 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 scs0 p ii fn args m = +let init_state ep env scs0 p ii fn args m = let f = BatOption.get (get_fundef p.p_funcs fn) in - let vargs = exn_exec ii (mapM2 ErrType truncate_val (List.map eval_atype f.f_tyin) args) in - 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) args) in + 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 { s_prog = p; s_cmd = f.f_body; s_estate; s_stk = Sempty (ii, f) } -let exec ep spp sip scs0 p ii fn args m = - let s = init_state ep scs0 p ii fn args m in - try small_step ep spp sip s +let exec ep spp sip env scs0 p ii fn args m = + let s = init_state ep env scs0 p ii fn args m in + try small_step ep spp sip env s with Final(m,vs) -> m, vs (* ----------------------------------------------------------- *) @@ -183,7 +182,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 = diff --git a/compiler/src/evaluator.mli b/compiler/src/evaluator.mli index 20c7017c6..0b557586d 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.positive) -> '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 fd319e87a..81aba746c 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 iac_stmt pd is = List.map (iac_instr pd) is and iac_instr pd i = { i with i_desc = iac_instr_r pd i.i_loc i.i_desc } @@ -41,10 +41,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 (Conv.pos_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) @@ -68,8 +68,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 (Conv.pos_of_int len)) in Copn(xs,t,Sopn.Opseudo_op op, es) | Sopn.Opseudo_op(Pseudo_operator.Oswap _), x::_ -> (* Fix the type it is dummy for the moment *) @@ -77,9 +77,9 @@ and iac_instr_r pd loc ir = Copn(xs, t, Sopn.Opseudo_op(Pseudo_operator.Oswap ty), es) | 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 (Conv.pos_of_int len)) in Copn(xs,t, Sopn.Oslh op, es) | (Sopn.Opseudo_op(Pseudo_operator.Ocopy _) | Sopn.Oslh (SLHprotect_ptr _)), _ -> assert false | _ -> ir @@ -93,8 +93,8 @@ and iac_instr_r pd loc ir = 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) + let ws, len = array_kind_const ty in + Csyscall(xs, Syscall_t.RandomBytes (ws, Const len), es) end | Ccall _ -> ir diff --git a/compiler/src/intervalGraphColoring.ml b/compiler/src/intervalGraphColoring.ml index de8bfe40a..78cae256a 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 ee460ea44..92198a0d0 100644 --- a/compiler/src/latex_printer.ml +++ b/compiler/src/latex_printer.ml @@ -210,7 +210,7 @@ let rec pp_expr_rec prio fmt pe = F.fprintf fmt "(%a)[@[%a@]]" pp_svsize vs (pp_list ",@ " pp_expr) es | PEBool b -> F.fprintf fmt "%s" (if b then "true" else "false") | PEInt i -> F.fprintf fmt "%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 @@ -260,6 +260,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 c98fe60ba..672a02d93 100644 --- a/compiler/src/lexer.mll +++ b/compiler/src/lexer.mll @@ -190,6 +190,8 @@ rule main = parse | "}" { RBRACE } | "(" { LPAREN } | ")" { RPAREN } + | "<|" { LABRACKET } (* left angle bracket *) + | "|>" { RABRACKET } | "->" { RARROW } | "," { COMMA } | ";" { SEMICOLON } diff --git a/compiler/src/liveness.ml b/compiler/src/liveness.ml index 818e223f2..2c6cef1d0 100644 --- a/compiler/src/liveness.ml +++ b/compiler/src/liveness.ml @@ -71,9 +71,9 @@ 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) -> let s_i = Sv.union (vars_es es) (dep_lvs s_o xs) in @@ -97,11 +97,11 @@ 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 -> (Wsize.wsize * length) Syscall_t.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 + | 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 _) -> () ) f.f_body diff --git a/compiler/src/liveness.mli b/compiler/src/liveness.mli index 367c25e67..417857c29 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 -> (Wsize.wsize * length) Syscall_t.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 e52a79c18..4f462682d 100644 --- a/compiler/src/parser.mly +++ b/compiler/src/parser.mly @@ -13,6 +13,8 @@ %token RBRACE %token LPAREN %token RPAREN +%token LABRACKET +%token RABRACKET %token T_BOOL %token T_INT @@ -312,8 +314,8 @@ pexpr_r: | e=parens(pexpr) { PEParens e } -| f=var args=parens_tuple(pexpr) - { PECall (f, args) } +| f=var alargs=loption(abrackets_tuple(pexpr)) args=parens_tuple(pexpr) + { PECall (f, alargs, args) } | f=prim args=parens_tuple(pexpr) { PEPrim (f, args) } @@ -376,10 +378,10 @@ pinstr_r: | 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(abrackets_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) } | s=pif { s } @@ -476,6 +478,7 @@ pfundef: cc=call_conv? FN name = ident + alargs = loption(abrackets_tuple(var)) (* ident instead of var? *) args = parens_tuple(annot_pparamdecl) rty = prefix(RARROW, tuple(annot_stor_type))? body = pfunbody @@ -483,6 +486,7 @@ pfundef: { { pdf_annot; pdf_cc = cc; pdf_name = name; + pdf_alargs = alargs; pdf_args = args; pdf_rty = rty ; pdf_body = body; } } @@ -557,6 +561,9 @@ module_: %inline brackets(X): | x=delimited(LBRACKET, X, RBRACKET) { x } +%inline abrackets(X): +| x=delimited(LABRACKET, X, RABRACKET) { x } + %inline braces(X): | x=delimited(LBRACE, X, RBRACE) { x } @@ -577,3 +584,6 @@ module_: %inline brackets_tuple(X): | s=brackets(rtuple(X)) { s } + +%inline abrackets_tuple(X): +| s=abrackets(rtuple1(X)) { s } diff --git a/compiler/src/pp_stack_alloc.ml b/compiler/src/pp_stack_alloc.ml index daee48313..b35535bb1 100644 --- a/compiler/src/pp_stack_alloc.ml +++ b/compiler/src/pp_stack_alloc.ml @@ -19,6 +19,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 201d2c7ea..1a88125fd 100644 --- a/compiler/src/pretyping.ml +++ b/compiler/src/pretyping.ml @@ -239,7 +239,7 @@ 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.pvar list; fs_tin : P.epty list ; fs_tout : P.epty list } module Env : sig type 'asm env @@ -1092,17 +1092,25 @@ let cast_int loc os e ety = (* -------------------------------------------------------------------- *) -let conv_ty : BinNums.positive T.extended_type -> P.epty = function +let rec pexpr_of_al al = + let open Type in + match al with + | ALConst n -> P.cnst (Conv.z_of_pos n) + | ALVar _ -> assert false + | ALAdd (al1, al2) -> Papp2 (Oadd Op_int, pexpr_of_al al1, pexpr_of_al al2) + | ALMul (al1, al2) -> Papp2 (Omul Op_int, pexpr_of_al al1, pexpr_of_al al2) + +let conv_ty : T.extended_type -> P.epty = 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, PE (pexpr_of_al al)) let conv_cty : T.atype -> P.epty = 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, PE (pexpr_of_al al)) let type_of_op2 op = let (ty1, ty2), tyo = E.etype_of_op2 op in @@ -1344,7 +1352,8 @@ 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 -> + assert (alargs = []); tt_expr ~mode pd env (L.mk_loc (L.loc pe) (S.PECombF(id,args))) | S.PECall _ -> @@ -1886,7 +1895,7 @@ let cassgn_for (x: P.plval) (tg: E.assgn_tag) (ty: P.epty) (e: P.pexpr) : (unit, 'asm) P.pinstr_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 -> () @@ -1923,7 +1932,7 @@ let mk_call loc inline lvs f es = 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 @@ -1935,27 +1944,50 @@ let tt_annot_paramdecls dfl_writable pd env (annot, (ty,vs)) = let vars = List.map (fun v -> aty, v) vs in tt_vardecls_push dfl_writable pd env vars +let tt_alarg env x = + let { L.pl_desc = x; L.pl_loc = xlc; } = x in + let xety = Prog.ETint in + let x = mk_var x W.Const xety xlc [] in + let env = Env.Vars.push_local env (x, xety) in + env, L.mk_loc xlc x + +let subst_one (f_al:P.pvar list) alargs ty = + let als = List.combine f_al alargs in + let f x = + match List.assoc_opt (L.unloc x.Prog.gv) als with + | Some e -> e + | None -> P.Pvar x + in + Subst.psubst_ety f ty +let subst f_al alargs tys = + List.map (subst_one f_al alargs) tys + let rec tt_instr arch_info (env : 'asm Env.env) ((annot,pi) : S.pinstr) : 'asm Env.env * (unit, 'asm) P.pinstr list = 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 -> + assert(alargs= []); 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 = tt_exprs_cast arch_info.pd env_rhs (L.loc pi) alargs (List.init (List.length alargs) (fun _ -> Prog.ETint)) in + let tout = subst 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 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)] + (* FIXME: List.map (fun e -> P.PE e) is ugly *) + [mk_i ~annot (mk_call (L.loc pi) is_inline lvs f (List.map (fun e -> P.PE e) alargs) es)] | (ls, xs), `Raw, { pl_desc = PEPrim (f, args) }, None when L.unloc f = "spill" || L.unloc f = "unspill" -> let op = L.unloc f in @@ -1989,7 +2021,7 @@ let rec tt_instr arch_info (env : 'asm Env.env) ((annot,pi) : S.pinstr) : 'asm E (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))] + [mk_i (P.Csyscall([x], Syscall_t.RandomBytes (U8, PE (Pconst Z.one)), es))] | (ls, xs), `Raw, { pl_desc = PEPrim (f, args) }, None when L.unloc f = "swap" -> let loc = L.loc pi in @@ -2326,6 +2358,16 @@ 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 pp_var fmt x = F.fprintf fmt "%s.%s" x.P.v_name (CoreIdent.string_of_uid x.P.v_id) in + (* variables used in the type of other variables are not dead *) + let used = ref used in + let pvars_ty ty = + match ty with + | P.Bty _ -> P.Spv.empty + | Arr (_, P.PE e) -> P.pvars_e e + in + Env.Vars.iter_locals (fun x -> + used := P.Spv.union !used (pvars_ty x.v_ty)) env; + let used = !used in Env.Vars.iter_locals (fun x -> if not (P.Spv.mem x used) then warning UnusedVar (L.i_loc0 x.v_dloc) "unused variable %a" pp_var x) @@ -2338,6 +2380,8 @@ let tt_fundef arch_info (env0 : 'asm Env.env) loc (pf : S.pfundef) : 'asm Env.en 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 @@ -2356,6 +2400,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; @@ -2371,7 +2416,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) = diff --git a/compiler/src/pretyping.mli b/compiler/src/pretyping.mli index 6940149e3..a4fe13249 100644 --- a/compiler/src/pretyping.mli +++ b/compiler/src/pretyping.mli @@ -4,7 +4,7 @@ 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.pvar list; fs_tin : Prog.epty list ; fs_tout : Prog.epty list } module Env : sig type 'asm env diff --git a/compiler/src/printCommon.ml b/compiler/src/printCommon.ml index cf8dc4632..a3139500c 100644 --- a/compiler/src/printCommon.ml +++ b/compiler/src/printCommon.ml @@ -224,8 +224,23 @@ let pp_arr_slice pp_gvar pp_expr pp_len fmt aa ws x e len = 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 rec pp_len ~debug fmt (len:length) = + (* TODO: clean that, it was backported from printer.ml *) + let pp_var = + if debug then + fun fmt x -> fprintf fmt "%s.%s" x.v_name (string_of_uid x.v_id) + else + fun fmt x -> fprintf fmt "%s" x.v_name + in + let rec pp_len fmt (len:length) = + match len with + | Const n -> fprintf fmt "%i" n + | Var x -> fprintf fmt "%a" pp_var x + | Add (e1, e2) -> fprintf fmt "(%a) + (%a)" pp_len e1 pp_len e2 + | Mul (e1, e2) -> fprintf fmt "(%a) * (%a)" pp_len e1 pp_len e2 + in + pp_len fmt len +let pp_ty ~debug fmt = pp_gtype (pp_len ~debug) fmt (* -------------------------------------------------------------------- *) let pp_datas fmt data = diff --git a/compiler/src/printCommon.mli b/compiler/src/printCommon.mli index a34711f03..2ffb4e857 100644 --- a/compiler/src/printCommon.mli +++ b/compiler/src/printCommon.mli @@ -10,7 +10,7 @@ val string_of_op2 : Expr.sop2 -> string val pp_opn : 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 : 'a Syscall_t.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 @@ -55,8 +55,8 @@ val pp_arr_slice : 'len -> unit -val pp_len : Format.formatter -> int -> unit -val pp_ty : Format.formatter -> Prog.ty -> unit +val pp_len : debug:bool -> Format.formatter -> CoreIdent.length -> unit +val pp_ty : debug:bool -> Format.formatter -> Prog.ty -> unit val pp_datas : Format.formatter -> Obj.t 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 d6bf194df..2761e8d9e 100644 --- a/compiler/src/printExportInfo.ml +++ b/compiler/src/printExportInfo.ml @@ -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 = PrintCommon.pp_len ~debug:false +(* FIXME: maybe print only consts and assert false or fail for other cases *) let pp_type_with_ptr fmt var = if is_ptr var.v_kind then diff --git a/compiler/src/printLinear.ml b/compiler/src/printLinear.ml index 4e39bb31b..a78600cb6 100644 --- a/compiler/src/printLinear.ml +++ b/compiler/src/printLinear.ml @@ -41,7 +41,7 @@ let pp_instr pd asmOp fmt i = pp_cast op (pp_opn pd asmOp) op (pp_list ",@ " pp_rexpr) es - | Lsyscall o -> F.fprintf fmt "SysCall %s" (pp_syscall o) + | Lsyscall o -> F.fprintf fmt "SysCall %s" (pp_syscall (Conv.map_syscall Conv.al_of_cal o)) | Lcall(lr, lbl) -> let pp_o fmt o = match o with None -> () | Some v -> Format.fprintf fmt "%a " pp_var_i v in F.fprintf fmt "Call %a%a" pp_o lr pp_remote_label lbl @@ -55,7 +55,7 @@ let pp_instr pd asmOp fmt i = 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 + F.fprintf fmt "%a %a %s" pp_kind y.P.v_kind (pp_ty ~debug:false) y.P.v_ty y.P.v_name let pp_stackframe fmt (sz, ws) = F.fprintf fmt "maximal stack usage: %a, alignment = %s" diff --git a/compiler/src/printer.ml b/compiler/src/printer.ml index c238982c0..46b9f64a1 100644 --- a/compiler/src/printer.ml +++ b/compiler/src/printer.ml @@ -190,12 +190,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 = @@ -243,12 +250,17 @@ let pp_gfun ~debug pp_info (pp_size:F.formatter -> 'size -> unit) pp_opn pp_var let pp_ret fmt () = 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%afn %s @[(%a)@] -> @[(%a)@] {@ @[%a@ %a@ %a@]@ }@]" + F.fprintf fmt "@[%a%afn %s%a @[(%a)@] -> @[(%a)@] {@ @[%a@ %a@ %a@]@ }@]" pp_annotations fd.f_annot.f_user_annot 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_locals fd @@ -306,16 +318,22 @@ let pp_pprog ~debug pd asmOp fmt p = 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_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 @@ -324,9 +342,9 @@ let pp_fun_ ~debug ?pp_locals ?(pp_info=pp_noinfo) pp_opn pp_var fmt fd = (pp_list ",@ " pp_var) ret in F.fprintf fmt "@[%a%a {@ @[%a@ %a@ %a@]@ }@]" pp_call_conv fd.f_cc - (pp_header_ pp_var) fd + (pp_header_ (pp_len ~debug) pp_var) fd pp_locals locals - (pp_gc ~debug pp_info pp_len pp_opn pp_var) fd.f_body + (pp_gc ~debug pp_info (pp_len ~debug) 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 = @@ -345,24 +363,25 @@ let pp_dvar ~debug fmt x = F.fprintf fmt "%a%a" (pp_var ~debug) x pp_dloc x.v_dloc 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_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 asmOp fmt i = let pp_opn = pp_opn pd 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 asmOp fmt i = let pp_opn = pp_opn pd 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 asmOp fmt fd = let pp_opn = pp_opn pd asmOp in @@ -374,9 +393,8 @@ let pp_func ~debug pd asmOp fmt fd = let pp_var = pp_var ~debug in 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) -> @@ -389,22 +407,24 @@ 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 asmOp fmt (gd, funcs) = let pp_opn = pp_opn pd 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_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 asmOp fmt ((gd, funcs):('info, 'asm) Prog.prog) = let pp_opn = pp_opn pd 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_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) = @@ -478,7 +498,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/prog.ml b/compiler/src/prog.ml index 910a75caf..a25a51856 100644 --- a/compiler/src/prog.ml +++ b/compiler/src/prog.ml @@ -95,11 +95,11 @@ 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 * (Wsize.wsize * 'len) Syscall_t.syscall_t * 'len gexprs | 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; @@ -117,6 +117,7 @@ type ('len, 'info, 'asm) gfunc = { f_info : 'info; 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; @@ -156,7 +157,7 @@ and pexpr = pexpr_ gexpr and pexpr_ = PE of pexpr [@@unboxed] -type range = int grange +type range = length grange type epty = pexpr_ gety @@ -219,20 +220,20 @@ let ws_of_ety = function (* ------------------------------------------------------------------------ *) (* 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 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 ('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) 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 = (int, 'info, 'asm) gfunc -type ('info, 'asm) mod_item = (int, 'info, 'asm) gmod_item +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 @@ -279,7 +280,7 @@ let rec rvars_i f s i = | 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 @@ -294,6 +295,7 @@ let fold_vars_fc f z fc = 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_i i = rvars_i Sv.add Sv.empty i let vars_c c = rvars_c Sv.add Sv.empty c @@ -325,7 +327,7 @@ let rec written_vars_i ((v, f) as acc) i = | Cassgn(x, _, _, _) -> written_lv v x, f | 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 | Cif(_, s1, s2) | Cwhile(_, s1, _, _, s2) @@ -403,6 +405,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 @@ -410,9 +416,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 (* -------------------------------------------------------------------- *) @@ -508,7 +524,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 _ |Cfor _ -> Sv.empty diff --git a/compiler/src/prog.mli b/compiler/src/prog.mli index 434e07091..d8e704050 100644 --- a/compiler/src/prog.mli +++ b/compiler/src/prog.mli @@ -62,11 +62,11 @@ 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 * (Wsize.wsize * 'len) Syscall_t.syscall_t * 'len gexprs | 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; @@ -84,6 +84,7 @@ type ('len, 'info, 'asm) gfunc = { f_info : 'info; 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; @@ -156,23 +157,23 @@ 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 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 range = int grange +type range = length 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) 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 = (int, 'info, 'asm) gfunc -type ('info, 'asm) mod_item = (int, 'info, 'asm) gmod_item +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 @@ -215,6 +216,7 @@ val fold_vars_fc : ('ty gvar -> 'acc -> 'acc) -> 'acc -> ('ty, 'info, 'asm) gfun 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_i : ('info, 'asm) instr -> Sv.t val vars_c : ('info, 'asm) stmt -> Sv.t @@ -257,9 +259,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 023aaf5d6..46d7bf5eb 100644 --- a/compiler/src/regalloc.ml +++ b/compiler/src/regalloc.ml @@ -41,7 +41,7 @@ let fill_in_missing_names (f: ('info, 'asm) func) : ('info, 'asm) func = | 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 @@ -55,7 +55,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)" (PrintCommon.pp_ty ~debug:false) ty let kind_of_type reg_size k = function @@ -275,7 +275,7 @@ let collect_equality_constraints_in_func | (None, _) | (_, None) -> () end | Cassgn _ -> () - | Ccall (xs, fn, es) -> + | Ccall (xs, fn, _al, es) -> let get_Pvar a = match a with | Pvar { gs = Expr.Slocal ; gv } -> gv @@ -492,7 +492,7 @@ let iter_variables (cb: var -> unit) (f: ('info, 'asm) func) : unit = let rec iter_instr_r = function | 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 @@ -697,7 +697,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 + (PrintCommon.pp_ty ~debug:false) x.v_ty (Printer.pp_var ~debug:false) y; let i = try Hv.find vars x @@ -772,7 +772,7 @@ let allocate_forced_registers return_addresses nv (vars: int Hv.t) tr (cnf: conf hierror_reg ~loc:(Lmore loc) "unexpected flag register %a" pp_var p | Unknown ty -> hierror_reg ~loc:(Lmore loc) "unknown type %a for forced register %a" - PrintCommon.pp_ty ty (Printer.pp_var ~debug:true) p + (PrintCommon.pp_ty ~debug:false) ty (Printer.pp_var ~debug:true) p in allocate_one nv vars loc cnf p i d a; (rs, xs) @@ -800,7 +800,7 @@ let allocate_forced_registers return_addresses nv (vars: int Hv.t) tr (cnf: conf -> alloc_stmt s1 c |> alloc_stmt s2 | Cassgn _ -> 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 @@ -999,7 +999,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 (PrintCommon.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; @@ -1110,7 +1110,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 @@ -1258,7 +1258,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 : ((Wsize.wsize * length) Syscall_t.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/sct_checker_forward.ml b/compiler/src/sct_checker_forward.ml index d0c06e396..55b0e149d 100644 --- a/compiler/src/sct_checker_forward.ml +++ b/compiler/src/sct_checker_forward.ml @@ -167,7 +167,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 @@ -306,7 +306,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 = @@ -384,7 +384,7 @@ module Env : sig val get : venv -> var -> vty val get_i : venv -> var_i -> vty - val gget : venv -> int ggvar -> vty + val gget : venv -> length ggvar -> vty val fresh : ?name:string -> env -> Lvl.t val fresh2 : ?name:string -> env -> VlPairs.t @@ -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 @@ -1081,7 +1081,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 diff --git a/compiler/src/slicing.ml b/compiler/src/slicing.ml index a046f1e88..ca480f3bb 100644 --- a/compiler/src/slicing.ml +++ b/compiler/src/slicing.ml @@ -36,7 +36,7 @@ and inspect_instr_r k = function | 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 slice fs (gd, fds) = let funs = diff --git a/compiler/src/ssa.ml b/compiler/src/ssa.ml index abd689c61..b034022c3 100644 --- a/compiler/src/ssa.ml +++ b/compiler/src/ssa.ml @@ -37,7 +37,7 @@ let rec written_vars_instr_r allvars w = | Cassgn (x, _, _, _) -> written_vars_lvar allvars w x | Copn (xs, _, _, _) | Csyscall(xs,_,_) - | Ccall (xs, _, _) + | Ccall (xs, _, _, _) -> written_vars_lvars allvars w xs | Cif (_, s1, s2) | Cwhile (_, s1, _, _, s2) @@ -68,10 +68,10 @@ 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, Csyscall(ys, op, es) - | Ccall (xs, n, 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 | Cif (e, s1, s2) -> let os = written_vars_stmt allvars (written_vars_stmt allvars Sv.empty s1) s2 in diff --git a/compiler/src/stackAlloc.ml b/compiler/src/stackAlloc.ml index 5078a1fe6..63e1b4689 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" (PrintCommon.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 cbd6c07ed..078e7cb33 100644 --- a/compiler/src/subst.ml +++ b/compiler/src/subst.ml @@ -58,13 +58,13 @@ 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,e) -> Csyscall(gsubst_lvals flen f x, Conv.map_syscall (flen ?loc:None) o, gsubst_es 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 @@ -72,6 +72,7 @@ and gsubst_c flen f c = List.map (gsubst_i 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_args = List.map dov fc.f_args; f_body = gsubst_c flen f fc.f_body; @@ -96,6 +97,11 @@ let psubst_ty f (ty: pty) : pty = | Bty ty -> Bty ty | Arr(ty, e) -> Arr(ty, psubst_e_ f e) +let psubst_ety f (ty: epty) : epty = +match ty with + | ETbool | ETint | ETword _ -> ty + | ETarr (ws, len) -> ETarr (ws, psubst_e_ f len) + let psubst_v subst = let subst = ref subst in let rec aux v : pexpr = @@ -105,14 +111,20 @@ let psubst_v subst = let e = try Mpv.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 + (* the Const case can now be a length variable *) + (* assert (not (PV.is_glob v_)); *) + if PV.is_glob v_ then + Pvar {gv=v; gs=k} + else begin + 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 + (* FIXME: I think subst is updated, but then immediately thrown away *) + subst := Mpv.add v_ e !subst; + e + end in match e with | Pvar x -> let k = x.gs in @@ -190,24 +202,43 @@ let int_of_op2 ?loc o = | Expr.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 + | Expr.Oadd Op_int -> fun e1 e2 -> Add (e1, e2) + | Expr.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 + try int_of_expr ?loc e with Z.Overflow -> - hierror ?loc "cannot define a (sub-)array of size %a, this number is too big" Z.pp_print z + hierror ?loc "cannot define a (sub-)array of such size, it contains numbers that are too big" let isubst_ty ?loc = function | Bty ty -> Bty ty @@ -269,6 +300,7 @@ 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_args; f_body = gsubst_c isubst_len subst_v fc.f_body; @@ -340,14 +372,14 @@ let remove_params (prog : ('info, 'asm) pprog) = hierror ~loc:x.v_dloc "the expression assigned to global variable %a must evaluate to a constant" (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 -> + | Arr (ws, Const n), GEarray es -> let p = Conv.pos_of_int (n * size_of_ws ws) in let mk_word_i i e = try mk_word ws e diff --git a/compiler/src/subst.mli b/compiler/src/subst.mli index a152fdfcc..cd3531b91 100644 --- a/compiler/src/subst.mli +++ b/compiler/src/subst.mli @@ -9,6 +9,8 @@ val subst_func : ('ty gvar_i -> 'ty gexpr) -> ('ty, 'info, 'asm) gfunc -> ('ty, (* replace parameter by their definition everywhere in the program *) val remove_params : ('info, 'asm) pprog -> ('info, 'asm) prog +val psubst_ety : (pexpr_ ggvar -> pexpr) -> epty -> epty + (* rename all variable using fresh variables *) val clone_func : ('info, 'asm) func -> ('info, 'asm) func diff --git a/compiler/src/syntax.ml b/compiler/src/syntax.ml index 95c7a6b67..208a6f22c 100644 --- a/compiler/src/syntax.ml +++ b/compiler/src/syntax.ml @@ -174,7 +174,7 @@ type pexpr_r = | PEpack of svsize * pexpr list | 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 | PEOp1 of peop1 * pexpr @@ -299,6 +299,7 @@ type pfundef = { pdf_annot : annotations; pdf_cc : pcall_conv option; pdf_name : pident; + pdf_alargs : pident list; pdf_args : (annotations * paramdecls) list; pdf_rty : (annotations * pstotype) list option; pdf_body : pfunbody; diff --git a/compiler/src/toEC.ml b/compiler/src/toEC.ml index 2162d7b8f..6fe03d4d1 100644 --- a/compiler/src/toEC.ml +++ b/compiler/src/toEC.ml @@ -497,7 +497,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 array_theories = { @@ -567,9 +568,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 (* ------------------------------------------------------------------- *) @@ -957,6 +959,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 = @@ -967,13 +974,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 @@ -989,7 +996,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 @@ -1008,13 +1016,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 @@ -1024,10 +1035,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, @@ -1044,9 +1057,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 @@ -1062,8 +1076,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 @@ -1114,14 +1133,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 @@ -1133,37 +1155,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 @@ -1179,8 +1204,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 @@ -1221,8 +1251,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 @@ -1235,13 +1268,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)], @@ -1249,17 +1282,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 @@ -1267,6 +1308,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) @@ -1300,10 +1346,6 @@ let ty_expr = function let ty_sopn pd 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 @@ -1325,7 +1367,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 | Cif(_, c1, c2) | Cwhile(_, c1, _, _, c2) -> is_write_c x c1 || is_write_c x c2 @@ -1763,7 +1805,8 @@ struct let add_ty env = function | Bty _ -> () - | Arr (ws, n) -> EA.add_arr env ws n + | Arr (ws, Const n) -> EA.add_arr env ws n + | _ -> assert false (* not supported *) let ec_assgn env lv (etyo, etyi) e = @@ -1804,7 +1847,12 @@ 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 + let p = + match p with + | Const p -> p + | _ -> assert false + in + let n = arr_size ws p in Env.add_randombytes env n; Format.sprintf "%s.randombytes_%i" syscall_mod_arg n @@ -1835,7 +1883,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 @@ -1844,7 +1892,7 @@ struct (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 + let s = Syscall.syscall_sig_u (Conv.map_syscall Conv.cal_of_al 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 @@ -1953,7 +2001,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)]; @@ -1993,7 +2041,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 @@ -2052,7 +2101,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 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 713c2025d..c7c449d6c 100644 --- a/compiler/src/typing.ml +++ b/compiler/src/typing.ml @@ -20,17 +20,17 @@ let error loc fmt = let ty_var (x:var_i) = let ty = (L.unloc x).v_ty in begin match ty with - | Arr(_, n) -> + | Arr(_, Const n) -> if (n < 1) then error (L.i_loc0 (L.unloc x).v_dloc) "the variable %a has type %a, its array size should be positive" - (Printer.pp_var ~debug:false) (L.unloc x) PrintCommon.pp_ty ty + (Printer.pp_var ~debug:false) (L.unloc x) (PrintCommon.pp_ty ~debug:false) ty | _ -> () end; ty -let ty_gvar (x:int ggvar) = ty_var x.gv +let ty_gvar (x:length ggvar) = ty_var x.gv (* -------------------------------------------------------------------- *) @@ -40,28 +40,69 @@ 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 (PrintCommon.pp_ty ~debug:false) te + +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 + | Add (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 (Add (e11, e12), e2) -> expanded_form terms coeff mono (Add (Mul (e11, e2), Mul (e12, e2))) + | Mul (Mul (e11, e12), e2) -> expanded_form terms coeff mono (Mul (e11, Mul (e12, e2))) + in + expanded_form [] 1 [] len + +let compare_array_length (ws, al) (ws', al') = + 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' 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) -> 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 + (PrintCommon.pp_ty ~debug:true) te (PrintCommon.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" + | _ -> () (* -------------------------------------------------------------------- *) @@ -161,7 +202,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 + (PrintCommon.pp_ty ~debug:false) tx (PrintCommon.pp_ty ~debug:false) ty let check_lvals pd loc xs tys = let len = List.length tys in @@ -176,6 +217,17 @@ let getfun env fn = (* -------------------------------------------------------------------- *) +let rec subst_al (f : var -> length) al = + match al with + | Const _ -> al + | Var x -> f x + | Add (al1, al2) -> Add (subst_al f al1, subst_al f al2) + | Mul (al1, al2) -> Mul (subst_al f al1, subst_al f al2) +let subst_ty f ty = + match ty with + | Bty _ -> ty + | Arr (ws, al) -> Arr (ws, subst_al f al) + let rec check_instr pd asmOp env i = let loc = i.i_loc in match i.i_desc with @@ -189,7 +241,7 @@ let rec check_instr pd asmOp env i = check_lvals pd loc xs tout | Csyscall(xs, o, es) -> - let s = Syscall.syscall_sig_u o in + let s = Syscall.syscall_sig_u (Conv.map_syscall Conv.cal_of_al o) in let tins = List.map Conv.ty_of_cty s.scs_tin in let tout = List.map Conv.ty_of_cty s.scs_tout in check_exprs pd loc es tins; @@ -211,10 +263,16 @@ let rec check_instr pd asmOp env i = check_cmd pd asmOp env c1; check_cmd pd asmOp 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 + let f = + let l = List.combine fd.f_al al in + fun x -> List.assoc 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 asmOp env c = List.iter (check_instr pd asmOp env) c diff --git a/compiler/src/typing.mli b/compiler/src/typing.mli index ae0697d0a..64f0d5051 100644 --- a/compiler/src/typing.mli +++ b/compiler/src/typing.mli @@ -1,8 +1,10 @@ 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 -> 'asm Sopn.asmOp -> ('info, 'asm) prog -> unit + +val compare_array_length : Wsize.wsize * length -> Wsize.wsize * length -> bool diff --git a/compiler/src/varalloc.ml b/compiler/src/varalloc.ml index c57b9a69a..3f1d06e7b 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 @@ -199,7 +203,7 @@ let classes_alignment (onfun : funname -> param_info option list) (gtbl: alignme | Copn(xs,_,_,es) | Csyscall(xs,_,es) -> add_lvs xs; add_es es | 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 @@ -213,7 +217,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) @@ -228,7 +232,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 -> @@ -236,19 +246,19 @@ 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 let sz = size_of v.v_ty 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, sz), E.Slocal)) | Stack (Pointer _) -> let xp = get_stack_pointer stack_pointers v in @@ -341,7 +351,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 @@ -355,7 +365,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 diff --git a/compiler/tests/negative.expected b/compiler/tests/negative.expected index 76e262fcb..0a319d718 100644 --- a/compiler/tests/negative.expected +++ b/compiler/tests/negative.expected @@ -688,25 +688,25 @@ 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 +param expansion: cannot define a (sub-)array of such size, it contains numbers that are 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 +param expansion: cannot define a (sub-)array of such size, it contains numbers that are 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: cannot define a (sub-)array of such size, it contains numbers that are 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 +param expansion: cannot define a (sub-)array of such size, it contains numbers that are too big fail/param_expansion/x86-64/expression_arg.jazz: @@ -748,19 +748,19 @@ 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) +param expansion: unary operator (256u) not supported in array sizes 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: unary operator (256u) not supported in array sizes 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) +param expansion: unary operator (256u) not supported in array sizes fail/pointers/x86-64/test_writable_arguments.jazz: diff --git a/compiler/tests/printing.ml b/compiler/tests/printing.ml index 5047b4b7b..80d2ad7af 100644 --- a/compiler/tests/printing.ml +++ b/compiler/tests/printing.ml @@ -138,8 +138,8 @@ and eq_pinstr_r (x : _ pinstr_r) y = 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 && eq_pexprs (List.map (fun (PE e) -> e) c) (List.map (fun (PE e) -> e) g) && eq_pexprs d h | (Cassgn _ | Copn _ | Csyscall _ | Cif _ | Cfor _ | Cwhile _ | Ccall _), _ -> false diff --git a/compiler/tests/template/test.jazz b/compiler/tests/template/test.jazz new file mode 100644 index 000000000..b085ae06b --- /dev/null +++ b/compiler/tests/template/test.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/test1.jazz b/compiler/tests/template/test1.jazz new file mode 100644 index 000000000..ddb2191f0 --- /dev/null +++ b/compiler/tests/template/test1.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/test10.jazz b/compiler/tests/template/test10.jazz new file mode 100644 index 000000000..2822922d9 --- /dev/null +++ b/compiler/tests/template/test10.jazz @@ -0,0 +1,7 @@ +// fails at conversion OCaml -> Rocq due to 0 not a positive + +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/test11.jazz b/compiler/tests/template/test11.jazz new file mode 100644 index 000000000..e11f16d29 --- /dev/null +++ b/compiler/tests/template/test11.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/test12.jazz b/compiler/tests/template/test12.jazz new file mode 100644 index 000000000..410df0b57 --- /dev/null +++ b/compiler/tests/template/test12.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/test13.jazz b/compiler/tests/template/test13.jazz new file mode 100644 index 000000000..ec2c3af00 --- /dev/null +++ b/compiler/tests/template/test13.jazz @@ -0,0 +1,18 @@ +inline fn f () -> reg u64 { + reg u64 i = 2; + return i; +} + +inline fn g () -> reg u64 { + reg u64 i = 3; + reg u64 res = f(); + res += i; + return res; +} + +export fn main () -> reg u64 { + reg u64 res1 = f (); + reg u64 res2 = g (); + reg u64 res = res1 + res2; + return res; +} diff --git a/compiler/tests/template/test2.jazz b/compiler/tests/template/test2.jazz new file mode 100644 index 000000000..cb4f6bb7f --- /dev/null +++ b/compiler/tests/template/test2.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/test3.jazz b/compiler/tests/template/test3.jazz new file mode 100644 index 000000000..fc6b17c1b --- /dev/null +++ b/compiler/tests/template/test3.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/test4.jazz b/compiler/tests/template/test4.jazz new file mode 100644 index 000000000..22ea4a2bd --- /dev/null +++ b/compiler/tests/template/test4.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/test5.jazz b/compiler/tests/template/test5.jazz new file mode 100644 index 000000000..ddeb3f13a --- /dev/null +++ b/compiler/tests/template/test5.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/test6.jazz b/compiler/tests/template/test6.jazz new file mode 100644 index 000000000..1903625db --- /dev/null +++ b/compiler/tests/template/test6.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/test7.jazz b/compiler/tests/template/test7.jazz new file mode 100644 index 000000000..4560acf96 --- /dev/null +++ b/compiler/tests/template/test7.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/test8.jazz b/compiler/tests/template/test8.jazz new file mode 100644 index 000000000..f909c1eeb --- /dev/null +++ b/compiler/tests/template/test8.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/test9.jazz b/compiler/tests/template/test9.jazz new file mode 100644 index 000000000..6aedd17a5 --- /dev/null +++ b/compiler/tests/template/test9.jazz @@ -0,0 +1,6 @@ +// fails with bad error + +export fn main<|p,q|> (reg u64[p+q] r) -> reg u64 { + reg u64 res = f<|p+q|>(r); + return res; +} diff --git a/proofs/arch/arch_decl.v b/proofs/arch/arch_decl.v index 708e50ae1..f7cd33564 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 positive); 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 88f881830..39b2d8488 100644 --- a/proofs/arch/arch_extra.v +++ b/proofs/arch/arch_extra.v @@ -296,7 +296,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 @@ -340,35 +340,51 @@ 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 positive => 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 : eval_safe_cond env \o safe_cond_to_array_length =1 id. +Proof. by case. 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 -(map_comp (eval_safe_cond env)) (eq_map (safe_cond_to_array_lengthP env)) map_id. rewrite /semi_to_atype. move: (computational_eq _) (computational_eq _) semi => e1 e2. by rewrite -> e1, -> e2. @@ -385,12 +401,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 775110c98..8089f2308 100644 --- a/proofs/compiler/allocation.v +++ b/proofs/compiler/allocation.v @@ -437,8 +437,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 @@ -578,8 +578,9 @@ Fixpoint check_i (i1 i2:instr_r) r := Let _ := assert (o1 == o2) (alloc_error "syscall not equals") 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 925e3cade..e3fced964 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)%R 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 fcb37e756..1cbad6223 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 positive)) : 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 positive) := [:: 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 positive) := [:: 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 958f66fed..84ce93026 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. @@ -62,7 +72,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) @@ -111,18 +121,25 @@ 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 @@ -138,20 +155,20 @@ 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. Context {pT: progT}. Definition array_copy_fd V (f:fundef) := - let 'MkFun fi tyin params c tyout res ev := f in + let 'MkFun fi al tyin params c tyout res ev := f in Let c := array_copy_c V array_copy_i c in - ok (MkFun fi tyin params c tyout res ev). + ok (MkFun fi al tyin params c tyout res ev). Definition array_copy_prog (p:prog) := let V := vars_p (p_funcs p) in let fresh := Sv.add {| vtype := aint ; vname := fresh_counter |} (sv_of_list tmp_var wsizes) in - Let _ := assert (disjoint fresh V) E.error in + Let _ := assert (disjoint fresh V) E.fresh_error in Let fds := map_cfprog (array_copy_fd V) (p_funcs p) in ok {| p_funcs := fds; p_globs := p_globs p; diff --git a/proofs/compiler/array_expansion.v b/proofs/compiler/array_expansion.v index 4e382794f..71268b4a0 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 + | 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. @@ -319,7 +319,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 _ tyin params c tyout res ef => + | MkFun _ 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 @@ -330,16 +330,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 (flatten tyin) (flatten params) c (flatten tyout) (flatten res) ef, + ok (MkFun fi 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 tyin params c tyout res ef => + | MkFun fi al tyin params c tyout res ef => Let c := mapM (expand_i m) c in - ok (MkFun fi tyin params c tyout res ef) + ok (MkFun fi 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 363b61b5d..6b1e75e42 100644 --- a/proofs/compiler/array_init.v +++ b/proofs/compiler/array_init.v @@ -43,7 +43,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. @@ -53,6 +53,7 @@ Context {pT: progT}. Definition remove_init_fd (fd:fundef) := {| f_info := fd.(f_info); + f_al := fd.(f_al); f_tyin := fd.(f_tyin); f_params := fd.(f_params); f_body := remove_init_c fd.(f_body); @@ -85,10 +86,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. @@ -118,6 +119,7 @@ Definition add_init_fd (fd:fundef) := let I := vrvs [seq (Lvar i) | i <- f_params fd] in let f_body := (add_init_c add_init_i I fd.(f_body)).1 in {| f_info := fd.(f_info); + f_al := fd.(f_al); f_tyin := fd.(f_tyin); f_params := fd.(f_params); f_body := f_body; diff --git a/proofs/compiler/compiler.v b/proofs/compiler/compiler.v index 646cd2fa5..b8fe66958 100644 --- a/proofs/compiler/compiler.v +++ b/proofs/compiler/compiler.v @@ -244,7 +244,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 (wsw := withsubword) cparams.(rename_fd) cparams.(dead_vars_ufd) p in + Let p := inline_prog_err (fun vk n id ty => cparams.(fresh_var_ident) vk dummy_instr_info n id ty) cparams.(rename_fd) p in let p := cparams.(print_uprog) Inlining p in Let p := dead_calls_err_seq to_keep p in diff --git a/proofs/compiler/constant_prop.v b/proofs/compiler/constant_prop.v index 4bf028592..06b873d1c 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 -> positive := fun _ => 1%positive. + 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,9 +293,9 @@ Definition app_sopn := app_sopn of_expr. Arguments app_sopn {A} ts _ _. Definition s_opN (op:opN) (es:pexprs) : pexpr := - match app_sopn _ (sem_opN_typed op) es with + match app_sopn _ (sem_opN_typed empty_env op) es with | Ok r => - match op return sem_t (eval_atype (type_of_opN op).2) -> _ with + match op return sem_t (eval_atype empty_env (type_of_opN op).2) -> _ with | Opack ws _ => fun w => Papp1 (Oword_of_int ws) (Pconst (wunsigned w)) | Ocombine_flags _ => fun b => Pbool b end r @@ -530,10 +535,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 @@ -548,9 +553,9 @@ Section Section. Context {pT: progT}. Definition const_prop_fun (gd: glob_decls) (f: fundef) := - let 'MkFun ii si p c so r ev := f in + let 'MkFun ii al si p c so r ev := f in let (_, c) := const_prop (const_prop_i gd) empty_cpm c in - MkFun ii si p c so r ev. + MkFun ii al si p c so r ev. Definition const_prop_prog (p:prog) : prog := map_prog (const_prop_fun p.(p_globs)) p. diff --git a/proofs/compiler/dead_calls.v b/proofs/compiler/dead_calls.v index dccb2b9ee..c939f297f 100644 --- a/proofs/compiler/dead_calls.v +++ b/proofs/compiler/dead_calls.v @@ -30,7 +30,7 @@ with i_calls_r (c : Sf.t) (i : instr_r) {struct i} : Sf.t := | 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 973c57153..f915d7cd8 100644 --- a/proofs/compiler/dead_code.v +++ b/proofs/compiler/dead_code.v @@ -153,14 +153,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. @@ -169,12 +169,12 @@ Section Section. Context {pT: progT}. Definition dead_code_fd {eft} fn (fd: _fundef eft) : cexec (_fundef eft) := - let 'MkFun ii tyi params c tyo res ef := fd in + let 'MkFun ii al tyi params c tyo res ef := fd in let res := fn_keep_only fn res in let tyo := fn_keep_only fn tyo in let s := read_es (map Plvar res) in Let c := dead_code_c dead_code_i c s in - ok (MkFun ii tyi params c.2 tyo res ef). + ok (MkFun ii al tyi params c.2 tyo res ef). Definition dead_code_prog_tokeep (p: prog) : cexec prog := Let funcs := map_cfprog_name dead_code_fd (p_funcs p) in diff --git a/proofs/compiler/inline.v b/proofs/compiler/inline.v index 1b2e7c975..90e91436e 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 allocation. @@ -30,6 +30,7 @@ Context {wsw : WithSubWord} {asm_op syscall_state : Type} {asmop:asmOp asm_op} + (fresh_var_ident : v_kind -> int -> string -> atype -> Ident.ident) (rename_fd : instr_info -> funname -> ufundef -> ufundef) (dead_vars_fd : ufun_decl -> instr_info -> Sv.t) . @@ -62,8 +63,8 @@ Definition locals_p (fd:ufundef) := Definition locals fd := Sv.diff (locals_p fd) (sparams fd). -Definition check_rename f (fd1 fd2:ufundef) (s:Sv.t) := - Let _ := check_ufundef dead_vars_fd tt tt (f,fd1) (f,fd2) tt in +Definition check_rename (fn:funname) (fd1 fd2:ufundef) (s:Sv.t) := +(* Let _ := check_ufundef dead_vars_fd tt tt (f,fd1) (f,fd2) tt in *) let s2 := locals_p fd2 in if disjoint s s2 then ok tt else Error (inline_error (pp_s "invalid refreshing in function")). @@ -74,6 +75,193 @@ Definition get_fun (p:ufun_decls) (f:funname) := | None => Error (inline_error (pp_box [::pp_s "Unknown function"; PPEfunname f])) end. +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. + +Fixpoint subst_al (f: length_var -> array_length) al := + match al with + | ALConst _ => al + | ALVar x => f x + | ALAdd al1 al2 => + let al1 := subst_al f al1 in + let al2 := subst_al f al2 in + ALAdd al1 al2 + | ALMul al1 al2 => + let al1 := subst_al f al1 in + let al2 := subst_al f al2 in + ALMul al1 al2 + end. +Definition subst_ty f ty := + match ty with + | aarr ws al => + let al := subst_al f al in + aarr ws al + | _ => ty + end. +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_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 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 es)) + 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_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 @@ -94,12 +282,22 @@ 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 fd' := rename_fd iinfo f fd in - Let _ := add_iinfo iinfo (check_rename f fd 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 + fun x => odflt (ALVar x) (assoc als x) + in + let (_, fd') := subst_fd f fd empty_sm in + (* no real need to rename, but it changes the instr_info, so we keep it *) + let fd' := rename_fd iinfo fn fd' in + Let _ := add_iinfo iinfo (check_rename fn fd 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 @@ -107,16 +305,17 @@ Fixpoint inline_i (p:ufun_decls) (i:instr) (X:Sv.t) : cexec (Sv.t * cmd) := let rename_res := assgn_tuple ii xs AT_rename fd'.(f_tyout) (map Plvar fd'.(f_res)) in - ok (X, rename_args ++ fd'.(f_body) ++ rename_res) + let c := rename_args ++ fd'.(f_body) ++ rename_res in + ok (X, c) else ok (X, [::i]) end. Definition inline_fd (p:ufun_decls) (fd:ufundef) := match fd with - | MkFun ii tyin params c tyout res ef => + | MkFun ii al tyin params c tyout res ef => let s := read_es (map Plvar res) in Let c := inline_c (inline_i p) c s in - ok (MkFun ii tyin params c.2 tyout res ef) + ok (MkFun ii al tyin params c.2 tyout res ef) end. Definition inline_fd_cons (ffd:funname * ufundef) (p:cexec ufun_decls) := diff --git a/proofs/compiler/linearization.v b/proofs/compiler/linearization.v index ada3677ab..7bcf59027 100644 --- a/proofs/compiler/linearization.v +++ b/proofs/compiler/linearization.v @@ -461,7 +461,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 @@ -706,7 +706,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 482ee9037..9df888bc3 100644 --- a/proofs/compiler/load_constants_in_cond.v +++ b/proofs/compiler/load_constants_in_cond.v @@ -81,7 +81,7 @@ Fixpoint load_constants_i (i : instr) := | Cassgn _ _ _ _ | Copn _ _ _ _ | Csyscall _ _ _ - | 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 07cb06667..0eacac6ae 100644 --- a/proofs/compiler/lower_spill.v +++ b/proofs/compiler/lower_spill.v @@ -55,7 +55,7 @@ Fixpoint to_spill_i (s : Sv.t * bool) (i : instr) := | 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. @@ -179,7 +179,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. @@ -215,7 +215,7 @@ Definition check_map (m:Mvar.t var) X := (bX.1 && ~~Sv.mem sx bX.2, Sv.add sx bX.2)) m (true, X). Definition spill_fd {eft} (fn:funname) (fd: _fundef eft) : cexec (_fundef eft) := - let 'MkFun ii tyi params c tyo res ef := fd in + let 'MkFun ii al tyi params c tyo res ef := fd in let s := foldl to_spill_i (Sv.empty, false) c in if ~~s.2 then ok fd else let: (m, _) := init_map s.1 in @@ -223,7 +223,7 @@ Definition spill_fd {eft} (fn:funname) (fd: _fundef eft) : cexec (_fundef eft) : 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 c in - ok (MkFun ii tyi params ec.2 tyo res ef). + ok (MkFun ii al tyi params ec.2 tyo res ef). 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 b89492d07..1f4aef6ab 100644 --- a/proofs/compiler/makeReferenceArguments.v +++ b/proofs/compiler/makeReferenceArguments.v @@ -126,7 +126,7 @@ 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"). @@ -138,6 +138,44 @@ Definition get_syscall_sig o := Definition is_swap_op (op: sopn) : option atype := if op is Opseudo_op (pseudo_operator.Oswap (aarr _ _ as ty)) then Some ty else None. +Fixpoint subst_al (f: length_var -> option array_length) al := + match al with + | ALConst _ => Some al + | ALVar x => f x + | ALAdd al1 al2 => + let%opt al1 := subst_al f al1 in + let%opt al2 := subst_al f al2 in + Some (ALAdd al1 al2) + | ALMul al1 al2 => + let%opt al1 := subst_al f al1 in + let%opt al2 := subst_al f al2 in + Some (ALMul al1 al2) + end. +Definition subst_ty f ty := + match ty with + | aarr ws al => + let%opt al := subst_al f al in + Some (aarr ws al) + | _ => Some ty + end. + +(* TODO: should we fail if subst fails? or just returns the original? *) +Definition subst_sig ii 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 := + mapM (fun '(b, s, ty) => + match subst_ty f ty with + | None => Error (make_ref_error ii "subst_sig") + | Some ty => ok (b, s, ty) + end) + in + Let params := subst params in + Let returns := subst returns in + ok (params, returns). + Fixpoint update_i (X:Sv.t) (i:instr) : cexec cmd := let (ii,ir) := i in match ir with @@ -162,13 +200,14 @@ 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 ii 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) + ok (prologue ++ MkI ii (Ccall xs fn alargs es) :: epilogue) | Csyscall xs o es => let: (params,returns) := get_syscall_sig o in Let: (prologue, es) := make_prologue ii X 0 params es in diff --git a/proofs/compiler/merge_varmaps.v b/proofs/compiler/merge_varmaps.v index ce7a82c80..176d39c9c 100644 --- a/proofs/compiler/merge_varmaps.v +++ b/proofs/compiler/merge_varmaps.v @@ -70,7 +70,7 @@ Section WRITE1. | 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 @@ -184,7 +184,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 adf65c4df..8b05cdfd3 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 _ _ _ | Ccall _ _ _) + | (Cassgn _ _ _ _ | Copn _ _ _ _ | Csyscall _ _ _ | 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 _ _ _ | Cfor _ _ _ | Ccall _ _ _) + | (Cassgn _ _ _ _ | Copn _ _ _ _ | Csyscall _ _ _ | 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 613cb3b99..f4463375c 100644 --- a/proofs/compiler/propagate_inline.v +++ b/proofs/compiler/propagate_inline.v @@ -190,10 +190,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. @@ -202,9 +202,9 @@ Section Section. Context {pT:progT}. Definition pi_fun (f:fundef) := - let 'MkFun ii si p c so r ev := f in + let 'MkFun ii al si p c so r ev := f in Let pic := pi_c pi_i piempty c in - ok (MkFun ii si p pic.2 so r ev). + ok (MkFun ii al si p pic.2 so r ev). Definition pi_prog (p:prog) := Let funcs := map_cfprog pi_fun (p_funcs p) in diff --git a/proofs/compiler/remove_globals.v b/proofs/compiler/remove_globals.v index be3ad89f1..ec4465927 100644 --- a/proofs/compiler/remove_globals.v +++ b/proofs/compiler/remove_globals.v @@ -83,7 +83,7 @@ Section REMOVE. else ok gd | _ => ok gd end - | Copn _ _ _ _ | Csyscall _ _ _ | Ccall _ _ _ => ok gd + | Copn _ _ _ _ | Csyscall _ _ _ | Ccall _ _ _ _ => ok gd | Cif _ c1 c2 => Let gd := foldM extend_glob_i gd c1 in foldM extend_glob_i gd c2 @@ -297,10 +297,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. @@ -315,6 +315,7 @@ Section REMOVE. Let envc := remove_glob remove_glob_i env f.(f_body) in ok {| f_info := f.(f_info); + f_al := f.(f_al); f_tyin := f.(f_tyin); f_params := f.(f_params); f_body := envc.2; diff --git a/proofs/compiler/riscv_extra.v b/proofs/compiler/riscv_extra.v index dac73f70f..742f2983e 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)%R 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 54119f15b..751981f81 100644 --- a/proofs/compiler/riscv_lower_addressing.v +++ b/proofs/compiler/riscv_lower_addressing.v @@ -77,7 +77,7 @@ Fixpoint lower_addressing_i (i: instr) := else [:: i] | Cassgn _ _ _ _ | Csyscall _ _ _ - | 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 6fac13c93..6cd25c8c7 100644 --- a/proofs/compiler/slh_lowering.v +++ b/proofs/compiler/slh_lowering.v @@ -456,7 +456,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 @@ -518,7 +518,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 @@ -528,9 +528,9 @@ Definition lower_cmd (c : cmd) : cexec cmd := rec_cmd lower_i c. Definition lower_fd (fn:funname) (fd:fundef) := Let _ := check_fd fn fd in - let 'MkFun ii si p c so r ev := fd in + let 'MkFun ii al si p c so r ev := fd in Let c := lower_cmd c in - ok (MkFun ii si p c so r ev). + ok (MkFun ii al si p c so r ev). Definition is_slh_none ty := if ty is Slh_None then true else false. diff --git a/proofs/compiler/stack_alloc.v b/proofs/compiler/stack_alloc.v index e15030102..2fc946c82 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,8 +527,25 @@ 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 => Sconst n + | ALVar x => Slvar x + | ALAdd al1 al2 => Sadd Op_int (symbolic_of_al al1) (symbolic_of_al al2) + | ALMul al1 al2 => Smul Op_int (symbolic_of_al al1) (symbolic_of_al al2) + end. + +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 mk_len_int ws (symbolic_of_al al) + else Sconst 0 (* 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 + if (ofs == Sconst 0) && (len == symbolic_of_arr_type x.(vtype)) then (sr, status) else let sr := sub_region_at_ofs sr ofs len in @@ -651,7 +679,7 @@ 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 + if (ofs == Sconst 0) && (len == symbolic_of_arr_type x.(vtype)) then statusy else let s := {| ss_ofs := ofs; ss_len := len |} in if get_sub_status statusy {| ss_ofs := Sconst 0; ss_len := len |} then @@ -682,8 +710,21 @@ 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 (Z.to_pos (wsize_size sz)) + | aarr ws al => + match al with + | ALConst len => ALConst (Z.to_pos (arr_size ws len)) + | _ => ALMul (ALConst (Z.to_pos (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 + let len := symbolic_of_al (size_of x.(vtype)) in + let z := [:: {| ss_ofs := Sconst 0; ss_len := len |}] in {| sr_region := r; sr_zone := z |}. Definition sub_region_glob x ws := @@ -985,9 +1026,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 +1058,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 +1134,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,7 +1243,7 @@ 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 len := mk_len_int ws (symbolic_of_al 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 @@ -1251,7 +1297,7 @@ 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 len := mk_len_int ws (symbolic_of_al len) in let (sr', _) := sub_region_status_at_ofs x sr status ofs len in Let _ := assert (sry == sr') @@ -1362,6 +1408,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 +1445,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 +1667,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,7 +1684,7 @@ 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 : Csyscall [::x] (getrandom len) [::t] @@ -1651,11 +1699,11 @@ Definition alloc_syscall ii rmap rs o es := add_iinfo ii match o with | RandomBytes ws n => - let len := arr_size ws n in + (* FIXME (* per the semantics, we have [len <= wbase Uptr], but we need [<] *) Let _ := assert (len let xe := xe.(gv) in @@ -1666,7 +1714,7 @@ Definition alloc_syscall ii rmap rs o es := 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 (sap_immediate saparams xlen 2); (* FIXME: dummy value, we probably don't want to reimplement some part of makeref arg that at all anyway *) MkI ii (Csyscall [::Lvar xp] o [:: Plvar p; Plvar xlen])]) | _, _ => Error (stk_ierror_no_var "randombytes: invalid args or result") @@ -1777,11 +1825,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")) @@ -1801,7 +1849,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 @@ -1829,8 +1877,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 @@ -1852,11 +1902,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 @@ -2017,6 +2068,7 @@ Definition alloc_fd_aux P p_extra mglob (local_alloc: funname -> stk_alloc_oracl check_results pmap rmap paramsi fd.(f_params) sao.(sao_return) fd.(f_res) in ok {| f_info := f_info 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; @@ -2094,7 +2146,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 6dc4fe515..85b5ed538 100644 --- a/proofs/compiler/unrolling.v +++ b/proofs/compiler/unrolling.v @@ -55,7 +55,7 @@ Fixpoint unroll_i (i: instr) : cmd * bool := | Cassgn _ _ _ _ | Copn _ _ _ _ | Csyscall _ _ _ - | Ccall _ _ _ + | Ccall _ _ _ _ => ([:: i ], false) | Cif b c1 c2 => let: (c1', b1) := unroll_cmd unroll_i c1 in @@ -81,9 +81,9 @@ Section Section. Context {pT: progT}. Definition unroll_fun (f: fun_decl) := - let: (fn, MkFun ii si p c so r ev) := f in + let: (fn, MkFun ii al si p c so r ev) := f in let: (c', b) := unroll_cmd unroll_i c in - ((fn, MkFun ii si p c' so r ev), b). + ((fn, MkFun ii al si p c' so r ev), b). Definition unroll_prog (p: prog) : prog * bool := let: (fds, b) := map_repeat unroll_fun (p_funcs p) in diff --git a/proofs/compiler/wint_int.v b/proofs/compiler/wint_int.v index dff2639ca..e6cdaccff 100644 --- a/proofs/compiler/wint_int.v +++ b/proofs/compiler/wint_int.v @@ -62,13 +62,13 @@ Definition wi2i_op2 (o : sop2) : sop2 := | None => o end. -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. @@ -105,17 +105,17 @@ Section Section. Context (m: var -> option (signedness * var)). Context (FV: Sv.t). -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) := @@ -124,13 +124,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 @@ -221,12 +221,12 @@ Fixpoint wi2i_e (e0:pexpr) : cexec pexpr := ok (Pif ty e1 e2 e3) 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 x) ety) (E.ierror_lv (Lvar x)) in wi2i_vari x. -Definition wi2i_lv (ety : extended_type positive) (lv : lval) : cexec lval := +Definition wi2i_lv (ety : extended_type) (lv : lval) : cexec lval := let s := sign_of_etype ety in match lv with | Lnone vi ty => @@ -255,7 +255,7 @@ Definition wi2i_lv (ety : extended_type positive) (lv : lval) : cexec lval := ok (Lasub aa ws len x e) end. -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 @@ -312,13 +312,13 @@ Fixpoint wi2i_ir (ir:instr_r) : cexec instr_r := Let c' := mapM wi2i_i c' in ok (Cwhile a c e info 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 e)) sig.1 es) (E.ierror_s "invalid args in Ccall") in Let xs := mapM2 (E.ierror_s "bad xs length in Ccall") wi2i_lv sig.2 xs in Let es := mapM wi2i_e es in - ok (Ccall xs f es) + ok (Ccall xs f al es) end with wi2i_i (i:instr) : cexec instr := @@ -330,7 +330,7 @@ with wi2i_i (i:instr) : cexec instr := Definition wi2i_fun (fn:funname) (f: fundef) := add_funname fn ( Let sig := get_sig fn in - let 'MkFun ii si p c so r ev := f in + let 'MkFun ii al si p c so r ev := f in Let p := mapM2 (E.ierror_s "bad params in fun") wi2i_lvar sig.1 p in Let c := mapM wi2i_i c in Let r := mapM2 (E.ierror_s "bad return in fun") (fun ety x => @@ -340,10 +340,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 tin p c tout r ev)). + ok (MkFun ii al tin p c tout r ev)). Definition build_sig (fd : funname * fundef) := - let 'MkFun ii si p c so r ev := fd.2 in + let 'MkFun ii al si p c so r ev := fd.2 in let mk := map2 (fun (x:var_i) ty => to_etype (sign_of_var 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 b209efd9a..d769d3d24 100644 --- a/proofs/compiler/wint_word.v +++ b/proofs/compiler/wint_word.v @@ -96,8 +96,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 811d35f5a..a827cb6a7 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 positive) := 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 positive, 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 49cb0da69..7bf06a863 100644 --- a/proofs/lang/expr.v +++ b/proofs/lang/expr.v @@ -142,7 +142,7 @@ HB.instance Definition _ := hasDecEq.Build opN opN_eqb_OK. (* ----------------------------------------------------------------------------- *) (* 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) @@ -173,7 +173,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 @@ -183,7 +183,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) @@ -219,8 +219,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) @@ -267,7 +267,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 => @@ -384,10 +384,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 @@ -428,7 +428,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. @@ -519,7 +519,7 @@ Inductive 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. @@ -541,7 +541,7 @@ Section CMD_RECT. 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. @@ -565,7 +565,7 @@ Section CMD_RECT. | 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. @@ -604,6 +604,7 @@ Class progT := { Record _fundef (extra_fun_t: Type) := MkFun { f_info : fun_info; + f_al : seq length_var; f_tyin : seq atype; f_params : seq var_i; f_body : cmd; @@ -787,6 +788,7 @@ Definition to_sprog (p:_sprog) : sprog := p. (* Update functions *) Definition with_body eft (fd:_fundef eft) (body : cmd) := {| f_info := fd.(f_info); + f_al := fd.(f_al); f_tyin := fd.(f_tyin); f_params := fd.(f_params); f_body := body; @@ -797,6 +799,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_al := fd.(f_al); f_tyin := fd.(f_tyin); f_params := fd.(f_params); f_body := fd.(f_body); @@ -939,7 +942,7 @@ Fixpoint write_i_rec s (i:instr_r) := | 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 @@ -1022,7 +1025,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 diff --git a/proofs/lang/extraction.v b/proofs/lang/extraction.v index ff55fd12e..f93884153 100644 --- a/proofs/lang/extraction.v +++ b/proofs/lang/extraction.v @@ -8,7 +8,7 @@ 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"]. +Extract Inductive syscall.syscall_t => "(Wsize.wsize * Type.array_length) Syscall_t.syscall_t" ["Syscall_t.RandomBytes"]. Extraction Inline ssrbool.is_left. Extraction Inline ssrbool.predT ssrbool.pred_of_argType. diff --git a/proofs/lang/psem_defs.v b/proofs/lang/psem_defs.v index b37eb80d0..48d5f7c3c 100644 --- a/proofs/lang/psem_defs.v +++ b/proofs/lang/psem_defs.v @@ -16,20 +16,20 @@ 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). (* ** Global access @@ -43,10 +43,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. @@ -58,23 +59,24 @@ Context {wsw:WithSubWord}. Record estate {syscall_state : Type} - {ep : EstateParams syscall_state} := Estate + {ep : EstateParams syscall_state} + (env : length_var -> positive) := 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 @@ -93,15 +95,16 @@ Section ESTATE_UTILS. Context {syscall_state : Type} - {ep : EstateParams syscall_state}. + {ep : EstateParams syscall_state} + (env : length_var -> positive). -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. @@ -112,15 +115,16 @@ Context {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} + (env : length_var -> positive) (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 := Z.to_pos (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 => @@ -131,7 +135,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 @@ -139,16 +143,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 @@ -157,21 +161,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 @@ -187,12 +191,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 len := eval env len in Let t' := to_arr (Z.to_pos (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. @@ -203,14 +208,15 @@ Context {asm_op syscall_state : Type} {ep : EstateParams syscall_state} {spp : SemPexprParams} - {asmop : asmOp asm_op}. + {asmop : asmOp asm_op} + (env : length_var -> positive). 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 79468a9a5..04686be5c 100644 --- a/proofs/lang/pseudo_operator.v +++ b/proofs/lang/pseudo_operator.v @@ -26,7 +26,7 @@ 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 | Onop | Omulu of wsize (* cpu : [aword; aword] -> [aword;aword] *) | Oaddcarry of wsize (* cpu : [aword; aword; abool] -> [abool;aword] *) diff --git a/proofs/lang/sem_op_typed.v b/proofs/lang/sem_op_typed.v index e5c4e7f85..f480cce16 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 (-%R)%R - | 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,9 +180,9 @@ 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 => diff --git a/proofs/lang/sem_type.v b/proofs/lang/sem_type.v index de3b8a0d2..70acc68c8 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 b359665c8..96c00e6f5 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 faddf9c87..7c17183fb 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 -> positive) c := + map_safe_cond (eval env) 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). @@ -206,20 +221,20 @@ Proof. 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 Onop_instr := @@ -275,46 +290,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 | Onop => Onop_instr | Omulu sz => Omulu_instr sz | Oaddcarry sz => Oaddcarry_instr sz @@ -399,23 +414,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 (Z.to_pos (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 (Z.to_pos (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: @@ -451,21 +466,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 := Z.to_pos (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 := @@ -474,8 +489,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. (* ---------------------------------------------------------------------- *) @@ -511,9 +526,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))); @@ -523,7 +539,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 18c7cbcfd..34787e76a 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 of wsize & array_length. HB.instance Definition _ := hasDecEq.Build syscall_t syscall_t_eqb_OK. @@ -19,6 +19,7 @@ HB.instance Definition _ := hasDecEq.Build syscall_t syscall_t_eqb_OK. (* Before stack alloc ie uprog *) Record syscall_sig_t := { + scs_tin : seq atype; scs_tout : seq atype }. diff --git a/proofs/lang/syscall_sem.v b/proofs/lang/syscall_sem.v index 3246aaad0..746d0f659 100644 --- a/proofs/lang/syscall_sem.v +++ b/proofs/lang/syscall_sem.v @@ -30,23 +30,24 @@ Definition exec_getrandom_u (scs : syscall_state) len vs := Definition exec_syscall_u {pd : PointerData} + (env : length_var -> positive) (scs : syscall_state_t) (m : mem) (o : syscall_t) (vs : values) : exec (syscall_state_t * mem * values) := match o with - | RandomBytes ws p => - let len := Z.to_pos (arr_size ws p) in + | RandomBytes ws al => + 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. -Lemma exec_syscallPu scs m o vargs vargs' rscs rm vres : - exec_syscall_u scs m o vargs = ok (rscs, rm, vres) → +Lemma exec_syscallPu env scs m o vargs vargs' rscs rm vres : + exec_syscall_u env scs m o 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 env scs m o 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'. @@ -58,8 +59,8 @@ 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 env scs m o vargs rscs rm vres : + exec_syscall_u env scs m o vargs = ok (rscs, rm, vres) → mem_equiv m rm. Proof. rewrite /exec_syscall_u; case: o => [ ws p ]. @@ -89,53 +90,53 @@ Lemma exec_getrandom_s_core_validw scs m p len rscs rm rp : 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)))) := + forall env, syscall_state_t -> mem -> 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 _ _ => fun _ => 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 +Definition exec_syscall_s env (scs : syscall_state_t) (m : mem) (o:syscall_t) vs : exec (syscall_state_t * mem * values) := + let semi := sem_syscall o env in Let: (scs', m', t) := app_sopn _ (semi scs m) 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 env scs m o vargs vargs' rscs rm vres : + exec_syscall_s env scs m o 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 env scs m o 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. + by have -> := vuincl_sopn (syscall_sig_s_noarr o env) 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 env scs m o vargs vargs' rscs rm vres : + exec_syscall_s env scs m o 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 env scs m o 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 : +Lemma sem_syscall_equiv o env scs m : mk_forall (fun (rm: (syscall_state_t * mem * _)) => mem_equiv m rm.1.2) - (sem_syscall o scs m). + (sem_syscall o env scs m). Proof. case: o => _ws _len /= p len [[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 env scs m o vargs rscs rm vres : + exec_syscall_s env scs m o 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). + apply (mk_forallP (sem_syscall_equiv o env scs m) happ). Qed. End Section. diff --git a/proofs/lang/type.v b/proofs/lang/type.v index 517bb8bb9..1185d3642 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,52 @@ 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 : positive -> array_length +| ALVar : length_var -> array_length +| ALAdd : array_length -> array_length -> array_length +| ALMul : 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 *) @@ -67,6 +107,70 @@ 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 *) + +Fixpoint array_length_cmp al1 al2 := + match al1, al2 with + | ALConst p1, ALConst p2 => Pos.compare p1 p2 + | ALConst _, _ => Lt + + | ALVar _, ALConst _ => Gt + | ALVar x1, ALVar x2 => length_var_cmp x1 x2 + | ALVar _, _ => Lt + + | ALAdd _ _, ALConst _ => Gt + | ALAdd _ _, ALVar _ => Gt + | ALAdd al11 al12, ALAdd al21 al22 => Lex (array_length_cmp al11 al21) (array_length_cmp al12 al22) + | ALAdd _ _, _ => Lt + + | ALMul al11 al12, ALMul al21 al22 => Lex (array_length_cmp al11 al21) (array_length_cmp al12 al22) + | ALMul _ _, _ => 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 array_lengthO : Cmp array_length_cmp. +Proof. + constructor. + + elim=> + [p1|x1|al11 ih1 al12 ih2|al11 ih1 al12 ih2] + [p2|x2|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. + + elim=> + [p1|x1|al11 ih1 al12 ih2|al11 ih1 al12 ih2] + [p2|x2|al21 al22 |al21 al22 ] + [p3|x3|al31 al32 |al31 al32 ] //=; + try (by apply ctrans_Eq); eauto using ctrans_Lt, ctrans_Gt; try apply cmp_ctrans. + + move=> c. + by rewrite !Lex_lex; apply lex_trans; eauto. + move=> c. + by rewrite !Lex_lex; apply lex_trans; eauto. + elim=> + [p1|x1|al11 ih1 al12 ih2|al11 ih1 al12 ih2] + [p2|x2|al21 al22 |al21 al22 ] //=. + + by move=> /cmp_eq ->. + + by move=> /cmp_eq ->. + + 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 +184,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 +192,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 +259,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 +295,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. @@ -257,11 +360,23 @@ Proof. done. Qed. Opaque arr_size. +Section EVAL. + +Context (env : length_var -> positive). + +Fixpoint eval (al:array_length) : positive := + match al with + | ALConst p => p + | ALVar v => env v + | ALAdd al1 al2 => eval al1 + eval al2 + | ALMul al1 al2 => eval al1 * eval al2 + end. + Definition eval_atype ty := match ty with | abool => cbool | aint => cint - | aarr ws len => carr (Z.to_pos (arr_size ws len)) + | aarr ws len => carr (Z.to_pos (arr_size ws (eval len))) | aword ws => cword ws end. @@ -271,10 +386,101 @@ 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 + | ALAdd p1 p2 | ALMul p1 p2 => + size_poly p1 + size_poly p2 + 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 + | ALAdd p1 p2 => size_Mul p1 + size_Mul p2 + | ALMul p1 p2 => 1 + size_Mul p1 + size_Mul p2 + end. + +Fixpoint left_Mul_under_Mul poly : nat := + match poly with + | ALConst _ | ALVar _ => 0 + | ALAdd p1 p2 => left_Mul_under_Mul p1 + left_Mul_under_Mul p2 + | ALMul p1 p2 => size_Mul p1 + left_Mul_under_Mul p2 + 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 (ALAdd 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 (ALAdd 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)). +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. +Final Obligation. + simpl. rewrite Nat.add_assoc. right. + lia. +Qed. + +Definition compare_array_length '(ws, al) '(ws', al') := + let ef := expanded_form (ALMul (ALConst (Z.to_pos (wsize_size ws))) al) in + let ef' := expanded_form (ALMul (ALConst (Z.to_pos (wsize_size ws'))) al') in + ef == ef'. + 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. @@ -285,7 +491,7 @@ 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] //=. + case: ty1 ty2 => [||ws1 al1|ws1] [||ws2 al2|ws2] //=. + by rewrite eq_sym. by rewrite eq_sym. Qed. @@ -293,25 +499,136 @@ 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] //=. + case: ty1 ty2 => [||ws1 al1|ws1] [||ws2 al2|ws2] //=. + by move=> /eqP ->. by move=> /eqP ->. Qed. +Fixpoint eval_mono (env : length_var -> positive) (mono : list length_var) : Z := + match mono with + | [::] => 1 + | x :: mono => env x * eval_mono env mono + end. + +Fixpoint eval_expand (env : length_var -> positive) terms : Z := + match terms with + | [::] => 0 + | (count, mono) :: terms => + count * eval_mono env mono + eval_expand env terms + end. + +Lemma insert_mono_correct env x mono : + eval_mono env (insert_mono x mono) = (env x * eval_mono env mono)%Z. +Proof. +Local Opaque Z.add Z.mul. + elim: mono => [|x2 mono ih] /=. + - done. + - case: length_var_cmp => //=. + rewrite ih. lia. +Local Transparent Z.add Z.mul. +Qed. + +Lemma insert_term_correct env cm terms : + eval_expand env (insert_term cm terms) = (eval_expand env terms + fst cm * eval_mono env (snd cm))%Z. +Proof. + elim: terms => [|cm2 terms ih] //=. + - case: cm => [count mono] /=. 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. + + lia. + move=> /=. + lia. + + case: cm ih => [coeff mono] /= ih. + case: cm2 => [coeff2 mono2] /=. move=> ???. lia. + + case: cm ih => [coeff mono] /= ih. + case: cm2 => [coeff2 mono2] /=. move=> ???. lia. + + case: cm ih => [coeff mono] /= ih. + case: cm2 => [coeff2 mono2] /=. move=> ???. lia. + case: cm ih => [coeff mono] /= ih. + case: cm2 => [coeff2 mono2] /=. move=> ???. lia. +Qed. + +Lemma insert_term_nice_correct env cm terms : + eval_expand env (insert_term_nice cm terms) = (eval_expand env terms + fst cm * eval_mono env (snd cm))%Z. +Proof. + rewrite /insert_term_nice. + case: Z.eqb_spec. + + lia. + move=> _. + by apply insert_term_correct. +Qed. + +Lemma expanded_form_sound p : + forall env, eval_expand env (expanded_form p) = eval env p. +Proof. +Local Opaque Z.add Z.mul. + move=> env. move: p. + apply (expanded_form_elim + (P := fun p terms => eval_expand env terms = eval env p) + (P0 := fun _ terms coeff mono p' terms' => eval_expand env terms' = eval_expand env terms + coeff * eval_mono env mono * eval env p'))%Z. + - move=> p /=. lia. + - move=> _ terms coeff mono n /=. + rewrite insert_term_nice_correct /=. lia. + - move=> _ terms coeff mono x /=. + rewrite insert_term_nice_correct /=. + rewrite insert_mono_correct /=. lia. + - move=> p terms coeff mono e1 e2 /= h1 h2. + rewrite h2 h1. lia. + - move=> p terms coeff mono n e /= h. + rewrite h. lia. + - move=> p terms coeff mono x e /= h. + rewrite h insert_mono_correct. lia. + - move=> p terms coeff mono e11 e12 e2 /= h1 h2. + rewrite h2 h1. lia. + - move=> p terms coeff mono e11 e12 e2 /= h. + rewrite h. lia. +Local Transparent Z.add Z.mul. +Qed. + +Lemma compare_array_length_eval_atype 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))%Z. +Proof. +Local Opaque wsize_size. + rewrite /compare_array_length => /eqP heq. + move=> env. + have := expanded_form_sound (ALMul (ALConst (Z.to_pos (wsize_size ws1))) len1) env. + have := expanded_form_sound (ALMul (ALConst (Z.to_pos (wsize_size ws2))) len2) env. + rewrite /eval /= -/(eval _). rewrite heq. move=> ->. + rewrite !arr_sizeE. + have: (0 < wsize_size ws1)%Z by []. + have: (0 < wsize_size ws2)%Z by []. + nia. +Local Transparent wsize_size. +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. + move=> hc env. + case: ty1 ty2 hc => [||ws1 n1|ws1] [||ws2 n2|ws2] //=. + + by move=> /compare_array_length_eval_atype /(_ env) ->. by move=> /eqP [<-]. +Local Transparent wsize_size. 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 +645,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,20 +657,20 @@ 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. by case: ty => //= ??; rewrite !eq_refl. 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 ->. + case: ty1 => //= [/eqP<-|/eqP<-|ws1 al1|ws1] //. + + by case: ty2 => //= ws2 al2 /eqP ->. by case: ty2 => //= ws2 hle; case: ty3 => //= ws3; apply: cmp_le_trans hle. Qed. @@ -405,29 +722,31 @@ 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 <-. + move=> hc env. + case: ty1 ty2 hc => [||ws1 n1|ws1] [||ws2 n2|ws2] //=. + by move=> /compare_array_length_eval_atype /(_ env) ->. Qed. (* -------------------------------------------------------------------- *) #[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 +754,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/values.v b/proofs/lang/values.v index 9ca9e1117..b51e29500 100644 --- a/proofs/lang/values.v +++ b/proofs/lang/values.v @@ -869,7 +869,7 @@ Section FORALL. End FORALL. -Definition interp_safe_cond (vs : values) (sc : safe_cond) := +Definition interp_safe_cond (vs : values) (sc : safe_cond positive) := match sc with | NotZero ws k => forall w, to_word ws (nth undef_b vs k) = ok w -> wunsigned w <> 0%Z @@ -909,7 +909,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/varmap.v b/proofs/lang/varmap.v index dbf5605ec..fc98dd4b9 100644 --- a/proofs/lang/varmap.v +++ b/proofs/lang/varmap.v @@ -431,36 +431,36 @@ End Section. Module Type VM. - Parameter t : forall {wsw:WithSubWord}, Type. + Parameter t : forall {wsw:WithSubWord}, (length_var -> positive) -> 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 -> positive). 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_. @@ -470,28 +470,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. @@ -503,36 +503,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 -> positive). -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. @@ -540,19 +540,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. @@ -560,11 +560,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 : @@ -573,18 +573,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 @@ -598,7 +598,7 @@ 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. @@ -607,16 +607,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. @@ -638,29 +638,29 @@ Ltac t_vm_get := Section REL. - Context {wsw1 wsw2 : WithSubWord}. + Context {wsw1 wsw2 : WithSubWord} (env : length_var -> positive). 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. @@ -670,61 +670,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. @@ -759,112 +759,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 -> positive). - 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. @@ -872,13 +872,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' -> @@ -894,25 +894,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' -> @@ -923,75 +923,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'→ @@ -1003,7 +1003,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'→ @@ -1015,7 +1015,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'→ @@ -1027,7 +1027,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'→ @@ -1039,12 +1039,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. @@ -1052,7 +1052,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]. @@ -1062,45 +1062,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. @@ -1109,31 +1109,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. @@ -1171,6 +1171,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 c46c6cb42..5b551bb07 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 array gen_map type word memory_model. +Require Export utils array gen_map word memory_model. Import Utf8 ZArith Lia. #[only(eqbOK)] derive diff --git a/proofs/lang/wsize.v b/proofs/lang/wsize.v index b2b05d863..4e327c21d 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:positive) := + (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 < arr_size ws len)%Z. +Proof. done. Qed. + +Opaque arr_size. + (* Size in bits of the elements of a vector. *) #[only(eqbOK)] derive Variant velem := VE8 | VE16 | VE32 | VE64. @@ -191,7 +202,7 @@ Variant v_kind := . (* -------------------------------------------------------------------- *) -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; @@ -206,9 +217,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 := {