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 ...@@ -173,14 +173,14 @@ module N
let lemma value_sub_head (x:map int limb) (n m:int) let lemma value_sub_head (x:map int limb) (n m:int)
requires { n < m } 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 = value_sub_concat x n (n+1) m
let lemma value_sub_update (x:map int limb) (i n m:int) (v:limb) let lemma value_sub_update (x:map int limb) (i n m:int) (v:limb)
requires { n <= i < m } requires { n <= i < m }
ensures { ensures {
value_sub (Map.set x i v) n m = 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) n i };
assert { MapEq.map_eq_sub x (Map.set x i v) (i+1) m }; assert { MapEq.map_eq_sub x (Map.set x i v) (i+1) m };
...@@ -1247,13 +1247,14 @@ module N ...@@ -1247,13 +1247,14 @@ module N
radix * rh <= (radix -1) * (radix -1) radix * rh <= (radix -1) * (radix -1)
}; };
c := Limb.(+) rh carry; c := Limb.(+) rh carry;
let ghost k = p2i !i in value_tail r !i;
i := Int32.(+) !i (Int32.of_int 1); value_tail x !i;
value_sub_tail (pelts r) r.offset (r.offset + k); assert { value x (!i+1) * y
value_sub_tail (pelts x) x.offset (x.offset + k); = value x !i * y + power radix !i * (!lx * y) };
assert { value r !i + (power radix !i) * !c = (*nonlinear, needed for reflection*)
value x !i * y assert { value r (!i+1) + (power radix (!i+1)) * !c =
by value x (!i+1) * y
(* by
value r !i + !c * (power radix !i) value r !i + !c * (power radix !i)
= value r k + res * (power radix k) = value r k + res * (power radix k)
+ (power radix !i) * !c + (power radix !i) * !c
...@@ -1272,8 +1273,9 @@ module N ...@@ -1272,8 +1273,9 @@ module N
+ (power radix k) * !lx * y + (power radix k) * !lx * y
= value x k * y + (power radix k) * !lx * y = value x k * y + (power radix k) * !lx * y
= (value x k + (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; done;
!c !c
...@@ -1307,14 +1309,15 @@ module N ...@@ -1307,14 +1309,15 @@ module N
invariant { forall j. j < r.offset \/ r.offset + sz <= j -> invariant { forall j. j < r.offset \/ r.offset + sz <= j ->
(pelts r)[j] = (pelts (old r))[j] } (pelts r)[j] = (pelts (old r))[j] }
label StartLoop in label StartLoop in
let ghost k = p2i !i in
lx := get_ofs x !i; lx := get_ofs x !i;
lr := get_ofs r !i; lr := get_ofs r !i;
assert { !lr = (pelts (old r))[r.offset + !i] }; assert { !lr = (pelts (old r))[r.offset + !i] };
let rl, rh = Limb.mul_double !lx y in let rl, rh = Limb.mul_double !lx y in
let res, carry = Limb.add3 !lr rl !c in let res, carry = Limb.add3 !lr rl !c in
value_sub_tail (pelts r) r.offset (r.offset + k); value_tail r !i;
value_sub_tail (pelts x) x.offset (x.offset + k); 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) value_sub_update (pelts r) (r.offset + p2i !i)
r.offset (r.offset + p2i !i +1) res; r.offset (r.offset + p2i !i +1) res;
set_ofs r !i res; set_ofs r !i res;
...@@ -1325,33 +1328,32 @@ module N ...@@ -1325,33 +1328,32 @@ module N
= (pelts (old r))[r.offset+j] }; = (pelts (old r))[r.offset+j] };
assert { value r (!i + 1) assert { value r (!i + 1)
= value (r at StartLoop) (!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) assert { rl + radix * rh <= (radix-1)*(radix-1)
by by
(!lx * y <= !lx * (radix-1) <= (radix-1)*(radix-1) (!lx * y <= !lx * (radix-1) <= (radix-1)*(radix-1)
by by
0 <= !lx <= radix - 1 /\ 0 <= y <= radix -1) 0 <= !lx <= radix - 1 /\ 0 <= y <= radix -1)
/\ /\
rl + radix * rh = !lx * y rl + radix * rh = !lx * y };
};
assert { rh < radix - 1 assert { rh < radix - 1
by by
rl + radix * rh <= (radix -1) * (radix -1) rl + radix * rh <= (radix -1) * (radix -1)
so so
radix * rh <= (radix -1) * (radix -1) radix * rh <= (radix -1) * (radix -1) };
};
assert { rh = radix - 2 -> rl <= 1 assert { rh = radix - 2 -> rl <= 1
by by
rl + radix * rh <= (radix-1)*(radix-1) }; rl + radix * rh <= (radix-1)*(radix-1) };
assert { rh = radix - 2 -> carry <= 1 assert { rh = radix - 2 -> carry <= 1
by rl <= 1 }; by rl <= 1 };
c := Limb.(+) rh carry; c := Limb.(+) rh carry;
i := Int32.(+) !i (Int32.of_int 1); assert { value x (!i + 1) * y
assert { value r !i + (power radix !i) * !c = value x !i * y + (power radix !i) * (!lx * y) };
= value (old r) !i (* nonlinear part *)
+ value x !i * y assert { value r (!i+1) + (power radix (!i+1)) * !c
by = value (old r) (!i+1)
+ value x (!i+1) * y
(* by
(value r !i + (power radix !i) * !c (value r !i + (power radix !i) * !c
= value (r at StartLoop) !i + = value (r at StartLoop) !i +
(power radix k) * (res - !lr) (power radix k) * (res - !lr)
...@@ -1394,8 +1396,9 @@ module N ...@@ -1394,8 +1396,9 @@ module N
by by
value (old r) !i = value (old r) k value (old r) !i = value (old r) k
+ (power radix k) * (!lr) + (power radix k) * (!lr)
) ) *)
}; };
i := Int32.(+) !i (Int32.of_int 1);
done; done;
!c !c
......
...@@ -37,18 +37,23 @@ let init_renv kn crc lv env task = ...@@ -37,18 +37,23 @@ let init_renv kn crc lv env task =
task = task; task = task;
} }
let rec is_const t =
let r = match t.t_node with
| Tconst _ -> true
| Tvar _ -> false
| Tapp (_, []) -> false
| Tapp (_, l) -> List.for_all is_const l
| _ -> 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 rec reify_term renv t rt =
let is_pvar p = match p.pat_node with Pvar _ -> true | _ -> false in 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 (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 "use_interp %a: %b@." Pretty.print_term t r;
r in
let rec invert_nonvar_pat vl (renv:reify_env) (p,f) t = let rec invert_nonvar_pat vl (renv:reify_env) (p,f) t =
if debug if debug
then Format.printf then Format.printf
...@@ -116,15 +121,15 @@ let rec reify_term renv t rt = ...@@ -116,15 +121,15 @@ let rec reify_term renv t rt =
| Pvar _, Tapp (ls, _hd::_tl), _ | Pvar _, Tapp (ls, _hd::_tl), _
-> if debug then Format.printf "case interp@."; -> if debug then Format.printf "case interp@.";
invert_interp renv ls t 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 _ | Papp (cs, [{pat_node = Pvar v}]), Tvar v', Tconst _
when vs_equal v v' when vs_equal v v'
-> if debug then Format.printf "case var_const@."; -> if debug then Format.printf "case var_const@.";
renv, t_app cs [t] (Some p.pat_ty) 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, _) -> | Papp _, Tapp (ls1, _), Tapp(ls2, _) ->
if debug then Format.printf "head symbol mismatch %a %a@." if debug then Format.printf "head symbol mismatch %a %a@."
Pretty.print_ls ls1 Pretty.print_ls ls2; Pretty.print_ls ls1 Pretty.print_ls ls2;
...@@ -489,7 +494,7 @@ exception CannotReduce ...@@ -489,7 +494,7 @@ exception CannotReduce
exception Raised of string * string exception Raised of string * string
let append l = List.fold_left (fun acc s -> acc^":"^s) "" l let append l = List.fold_left (fun acc s -> acc^":"^s) "" l
type value = type value =
| Vconstr of rsymbol * field list | Vconstr of rsymbol * field list
| Vint of BigInt.t | Vint of BigInt.t
...@@ -1070,7 +1075,7 @@ let reflection_by_function s env = Trans.store (fun task -> ...@@ -1070,7 +1075,7 @@ let reflection_by_function s env = Trans.store (fun task ->
ths None in ths None in
let (_pmod, rs) = if o = None let (_pmod, rs) = if o = None
then (if debug then Format.printf "Symbol %s not found@." s; then (if debug then Format.printf "Symbol %s not found@." s;
raise Exit) raise Not_found)
else Opt.get o in else Opt.get o in
(*let (_, ms, _) = Pmodule.restore_path rs.rs_name in*) (*FIXME remove or adapt*) (*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 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