Une MAJ de sécurité est nécessaire sur notre version actuelle. Elle sera effectuée lundi 02/08 entre 12h30 et 13h. L'interruption de service devrait durer quelques minutes (probablement moins de 5 minutes).

Commit 939eb5a4 authored by Raphael Rieu-Helft's avatar Raphael Rieu-Helft
Browse files

Add an intermediary decision procedure with more expressive terms, some...

Add an intermediary decision procedure with more expressive terms, some subtraction/multiplication examples
parent a99cc75e
......@@ -173,14 +173,14 @@ module N
let lemma value_sub_head (x:map int limb) (n m:int)
requires { n < m }
ensures { value_sub x n m = l2i x[n] + radix * value_sub x (n+1) m }
ensures { value_sub x n m = x[n] + radix * value_sub x (n+1) m }
= value_sub_concat x n (n+1) m
let lemma value_sub_update (x:map int limb) (i n m:int) (v:limb)
requires { n <= i < m }
ensures {
value_sub (Map.set x i v) n m =
value_sub x n m + power radix (i - n) * (l2i v - l2i (Map.get x i))
value_sub x n m + power radix (i - n) * (v -(Map.get x i))
}
= assert { MapEq.map_eq_sub x (Map.set x i v) n i };
assert { MapEq.map_eq_sub x (Map.set x i v) (i+1) m };
......@@ -1247,13 +1247,14 @@ module N
radix * rh <= (radix -1) * (radix -1)
};
c := Limb.(+) rh carry;
let ghost k = p2i !i in
i := Int32.(+) !i (Int32.of_int 1);
value_sub_tail (pelts r) r.offset (r.offset + k);
value_sub_tail (pelts x) x.offset (x.offset + k);
assert { value r !i + (power radix !i) * !c =
value x !i * y
by
value_tail r !i;
value_tail x !i;
assert { value x (!i+1) * y
= value x !i * y + power radix !i * (!lx * y) };
(*nonlinear, needed for reflection*)
assert { value r (!i+1) + (power radix (!i+1)) * !c =
value x (!i+1) * y
(* by
value r !i + !c * (power radix !i)
= value r k + res * (power radix k)
+ (power radix !i) * !c
......@@ -1272,8 +1273,9 @@ module N
+ (power radix k) * !lx * y
= value x k * y + (power radix k) * !lx * y
= (value x k + (power radix k) * !lx) * y
= value x !i * y
= value x !i * y *)
};
i := Int32.(+) !i (Int32.of_int 1);
done;
!c
......@@ -1307,14 +1309,15 @@ module N
invariant { forall j. j < r.offset \/ r.offset + sz <= j ->
(pelts r)[j] = (pelts (old r))[j] }
label StartLoop in
let ghost k = p2i !i in
lx := get_ofs x !i;
lr := get_ofs r !i;
assert { !lr = (pelts (old r))[r.offset + !i] };
let rl, rh = Limb.mul_double !lx y in
let res, carry = Limb.add3 !lr rl !c in
value_sub_tail (pelts r) r.offset (r.offset + k);
value_sub_tail (pelts x) x.offset (x.offset + k);
value_tail r !i;
value_tail x !i;
assert { value (old r) (!i+1) = value (old r) !i + power radix !i * !lr };
(* value_tail (old r) !i... *)
value_sub_update (pelts r) (r.offset + p2i !i)
r.offset (r.offset + p2i !i +1) res;
set_ofs r !i res;
......@@ -1325,33 +1328,32 @@ module N
= (pelts (old r))[r.offset+j] };
assert { value r (!i + 1)
= value (r at StartLoop) (!i + 1)
+ (power radix !i) * (res - !lr)
};
+ (power radix !i) * (res - !lr) };
assert { rl + radix * rh <= (radix-1)*(radix-1)
by
(!lx * y <= !lx * (radix-1) <= (radix-1)*(radix-1)
by
0 <= !lx <= radix - 1 /\ 0 <= y <= radix -1)
/\
rl + radix * rh = !lx * y
};
rl + radix * rh = !lx * y };
assert { rh < radix - 1
by
rl + radix * rh <= (radix -1) * (radix -1)
so
radix * rh <= (radix -1) * (radix -1)
};
radix * rh <= (radix -1) * (radix -1) };
assert { rh = radix - 2 -> rl <= 1
by
rl + radix * rh <= (radix-1)*(radix-1) };
assert { rh = radix - 2 -> carry <= 1
by rl <= 1 };
c := Limb.(+) rh carry;
i := Int32.(+) !i (Int32.of_int 1);
assert { value r !i + (power radix !i) * !c
= value (old r) !i
+ value x !i * y
by
assert { value x (!i + 1) * y
= value x !i * y + (power radix !i) * (!lx * y) };
(* nonlinear part *)
assert { value r (!i+1) + (power radix (!i+1)) * !c
= value (old r) (!i+1)
+ value x (!i+1) * y
(* by
(value r !i + (power radix !i) * !c
= value (r at StartLoop) !i +
(power radix k) * (res - !lr)
......@@ -1394,8 +1396,9 @@ module N
by
value (old r) !i = value (old r) k
+ (power radix k) * (!lr)
)
) *)
};
i := Int32.(+) !i (Int32.of_int 1);
done;
!c
......
......@@ -37,18 +37,23 @@ let init_renv kn crc lv env task =
task = task;
}
let rec is_const t =
let rec reify_term renv t rt =
let is_pvar p = match p.pat_node with Pvar _ -> true | _ -> false in
let rec use_interp t =
let r = match t.t_node with
| Tconst _ -> true
| Tvar _ -> false
| Tapp (_, []) -> false
| Tapp (_, l) -> List.for_all is_const l
| Tapp (ls, []) ->
begin match find_logic_definition renv.kn ls with
| None -> false
| Some ld ->
let _,t = open_ls_defn ld in
use_interp t
end
| Tapp (_, _) -> true
| _ -> false in
if debug then Format.printf "is_const %a: %b@." Pretty.print_term t r;
r
let rec reify_term renv t rt =
let is_pvar p = match p.pat_node with Pvar _ -> true | _ -> false in
if debug then Format.printf "use_interp %a: %b@." Pretty.print_term t r;
r in
let rec invert_nonvar_pat vl (renv:reify_env) (p,f) t =
if debug
then Format.printf
......@@ -116,15 +121,15 @@ let rec reify_term renv t rt =
| Pvar _, Tapp (ls, _hd::_tl), _
-> if debug then Format.printf "case interp@.";
invert_interp renv ls t
| Papp (cs, [{pat_node = Pvar _}]), Tapp(ls, _hd::_tl), _
when is_const t
-> if debug then Format.printf "case interp_const@.";
let renv, rt = invert_interp renv ls t in
renv, (t_app cs [rt] (Some p.pat_ty))
| Papp (cs, [{pat_node = Pvar v}]), Tvar v', Tconst _
when vs_equal v v'
-> if debug then Format.printf "case var_const@.";
renv, t_app cs [t] (Some p.pat_ty)
| Papp (cs, [{pat_node = Pvar _}]), Tapp(ls, _hd::_tl), _
when use_interp t (*FIXME*)
-> if debug then Format.printf "case interp_var@.";
let renv, rt = invert_interp renv ls t in
renv, (t_app cs [rt] (Some p.pat_ty))
| Papp _, Tapp (ls1, _), Tapp(ls2, _) ->
if debug then Format.printf "head symbol mismatch %a %a@."
Pretty.print_ls ls1 Pretty.print_ls ls2;
......@@ -1070,7 +1075,7 @@ let reflection_by_function s env = Trans.store (fun task ->
ths None in
let (_pmod, rs) = if o = None
then (if debug then Format.printf "Symbol %s not found@." s;
raise Exit)
raise Not_found)
else Opt.get o in
(*let (_, ms, _) = Pmodule.restore_path rs.rs_name in*) (*FIXME remove or adapt*)
let lpost = List.map open_post rs.rs_cty.cty_post in
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment