Commit 693db5a7 authored by Léon Gondelman's avatar Léon Gondelman

mini-compiler: proved (4 goals by coq)

parent 057b8d9f
......@@ -185,6 +185,35 @@ module Compile_com
meta rewrite_def function exn_bool_old
function loop_invariant (c: com) : ('a,machine_state) -> pos -> pred =
\ x p msi. let ms0 = snd x in
match ms0, msi with
| VMS _ s0 m0, VMS pi si mi ->
pi = p /\ s0 = si /\ exists mf. ceval m0 c mf /\ ceval mi c mf
end
meta rewrite_def function loop_invariant
function loop_post (c : com) (len: pos) : ('a,machine_state) -> pos -> pred =
\ x p msf. let ms0 = snd x in
match ms0, msf with
| VMS _ s0 m0, VMS pf sf mf ->
pf = p + len /\ s0 = sf /\ ceval m0 c mf
end
meta rewrite_def function loop_post
function loop_variant (c : com) (test: bexpr) : ('a -> pos -> post) =
\ x p msj msi.
match msj, msi with
| VMS pj sj mj, VMS pi si mi ->
pj = pi /\ sj = si /\ ceval mi c mj /\ beval mi test = True
end
meta rewrite_def function loop_variant
let rec compile_com (cmd: com) : hl 'a
variant { cmd }
ensures { result.pre = com_pre cmd }
......@@ -201,12 +230,45 @@ module Compile_com
$ compile_bexpr cond False (code_true.code.length + 1) ~
(($ code_true ~ $ ibranchf code_false.code.length) % exn_bool cond False) ~
($ code_false % exn_bool_old cond True)
| _ -> absurd
| Cwhile test body ->
let code_body = compile_com body in
let body_length = length code_body.code + 1 in
let code_test = compile_bexpr test False (body_length) in
let ofs = (length code_test.code + body_length) in
let wp_while = $ code_test ~
($ code_body ~ $ ibranchf (- ofs)) % exn_bool test False in
let ghost inv = loop_invariant cmd in
let ghost var = loop_variant body test in
let ghost post = loop_post cmd ofs in
let hl_while = hoare inv wp_while (loop_preservation inv var post) in
$ inil () ~ $ make_loop_hl hl_while inv var post
end
in
let ghost pre = com_pre cmd in
let ghost post = com_post cmd res.wcode.length in
hoare pre res post
hoare pre res post
let compile_com_natural (com: com) : code
ensures {
forall c p s m m'.
ceval m com m' ->
codeseq_at c p result ->
transition_star c
(VMS p s m)
(VMS (p + length result) s m') }
= let res = compile_com com : hl unit in
assert { forall p s m m'. ceval m com m' -> res.pre () p (VMS p s m) };
res.code
let compile_program (prog : com) : code
ensures { forall mi mf: state.
ceval mi prog mf -> vm_terminates result mi mf }
= compile_com_natural prog ++ ihalt
end
......
......@@ -151,33 +151,38 @@ module Compiler_logic
end
meta rewrite prop trivial_pre_lemma
inductive acc ('a -> 'a -> bool) 'a =
| Acc : forall r,x:'a. (forall y. r y x -> acc r y) -> acc r x
function loop_post (inv:'a -> pos -> pred)
| Acc : forall r, x:'a. (forall y. r y x -> acc r y) -> acc r x
function loop_preservation
(inv:'a -> pos -> pred)
(var:'a -> pos -> post)
(post:'a -> pos -> post)
(x:'a)
(p:pos)
(ms:machine_state) : pred =
\ms'. (inv x p ms /\ var x p ms' ms) \/ post x p ms ms'
(post:'a -> pos -> pred) : 'a -> pos -> post =
\x p ms ms'. (inv x p ms' /\ var x p ms' ms) \/ post x p ms'
meta rewrite_def function loop_preservation
function forget_old (post: 'a -> pos -> pred) : 'a -> pos -> post =
\x p ms . post x p
meta rewrite_def function loop_post
meta rewrite_def function forget_old
(* Variant of hoare triplet introduction rule for looping code. *)
let make_loop (c:wp 'a)
(* Variant of hoare triplet introduction rule for looping code. *)
let make_loop_hl (c:hl 'a)
(ghost inv:'a -> pos -> pred)
(ghost var: 'a -> pos -> post)
(ghost post : 'a -> pos -> post) : hl 'a
requires { wp_correctness c }
(ghost post : 'a -> pos -> pred) : hl 'a
requires { hl_correctness c }
requires { forall x p ms. inv x p ms -> acc (var x p) ms }
requires { forall x p ms. inv x p ms ->
(c.wp x p (loop_post inv var post x p ms)) ms }
ensures { result.pre = inv /\ result.post = post }
ensures { result.code.length = c.wcode.length /\ hl_correctness result }
= { code = c.wcode ; pre = inv ; post = post }
requires { c.pre = inv }
requires { c.post = loop_preservation inv var post }
ensures { result.pre = inv /\ result.post = forget_old post }
ensures { result.code.length = c.code.length /\ hl_correctness result }
= { code = c.code ; pre = inv ; post = forget_old post }
end
......
......@@ -431,55 +431,54 @@ Inductive acc {a:Type} {a_WT:WhyType a}: (func a (func a bool)) -> a ->
| Acc : forall (r:(func a (func a bool))) (x:a), (forall (y:a),
((infix_at (infix_at r y) x) = true) -> (acc r y)) -> (acc r x).
Parameter loop_post: forall {a:Type} {a_WT:WhyType a}, (func a (func Z (func
Parameter loop_preservation: forall {a:Type} {a_WT:WhyType a}, (func a (func
Z (func machine_state bool))) -> (func a (func Z (func machine_state (func
machine_state bool)))) -> (func a (func Z (func machine_state bool))) ->
(func a (func Z (func machine_state (func machine_state bool)))).
Axiom loop_preservation_def : forall {a:Type} {a_WT:WhyType a},
forall (inv:(func a (func Z (func machine_state bool)))) (var:(func a (func
Z (func machine_state (func machine_state bool))))) (post2:(func a (func Z
(func machine_state bool)))) (x:a) (p:Z) (ms:machine_state)
(ms':machine_state),
((infix_at (infix_at (infix_at (infix_at (loop_preservation inv var post2)
x) p) ms) ms') = true) <-> ((((infix_at (infix_at (infix_at inv x) p)
ms') = true) /\ ((infix_at (infix_at (infix_at (infix_at var x) p) ms')
ms) = true)) \/ ((infix_at (infix_at (infix_at post2 x) p) ms') = true)).
Parameter forget_old: forall {a:Type} {a_WT:WhyType a}, (func a (func Z (func
machine_state bool))) -> (func a (func Z (func machine_state (func
machine_state bool)))) -> (func a (func Z (func machine_state (func
machine_state bool)))) -> a -> Z -> machine_state -> (func machine_state
bool).
Axiom loop_post_def : forall {a:Type} {a_WT:WhyType a}, forall (inv:(func a
(func Z (func machine_state bool)))) (var:(func a (func Z (func
machine_state (func machine_state bool))))) (post2:(func a (func Z (func
machine_state (func machine_state bool))))) (x:a) (p:Z) (ms:machine_state)
(ms':machine_state), ((infix_at (loop_post inv var post2 x p ms)
ms') = true) <-> ((((infix_at (infix_at (infix_at inv x) p) ms) = true) /\
((infix_at (infix_at (infix_at (infix_at var x) p) ms') ms) = true)) \/
((infix_at (infix_at (infix_at (infix_at post2 x) p) ms) ms') = true)).
machine_state bool)))).
Axiom forget_old_def : forall {a:Type} {a_WT:WhyType a}, forall (post2:(func
a (func Z (func machine_state bool)))) (x:a) (p:Z) (ms:machine_state),
((infix_at (infix_at (infix_at (forget_old post2) x) p)
ms) = (infix_at (infix_at post2 x) p)).
Require Import Why3.
Ltac ae := why3 "Alt-Ergo,0.95.2,".
Ltac cvc := why3 "CVC4,1.4,".
(* Why3 goal *)
Theorem WP_parameter_make_loop : forall {a:Type} {a_WT:WhyType a},
forall (c:(list instr)) (c1:(func a (func Z (func (func machine_state bool)
(func machine_state bool))))) (inv:(func a (func Z (func machine_state
bool)))) (var:(func a (func Z (func machine_state (func machine_state
bool))))) (post2:(func a (func Z (func machine_state (func machine_state
bool))))), ((forall (x:a) (p:Z) (post3:(func machine_state bool))
(ms:machine_state), ((infix_at (infix_at (infix_at (infix_at (wp1 (mk_wp c
c1)) x) p) post3) ms) = true) -> exists ms':machine_state, ((infix_at post3
ms') = true) /\ (contextual_irrelevance (wcode (mk_wp c c1)) p ms ms')) /\
Theorem WP_parameter_make_loop_hl : forall {a:Type} {a_WT:WhyType a},
forall (c:(list instr)) (c1:(func a (func Z (func machine_state bool))))
(c2:(func a (func Z (func machine_state (func machine_state bool)))))
(inv:(func a (func Z (func machine_state bool)))) (var:(func a (func Z
(func machine_state (func machine_state bool))))) (post2:(func a (func Z
(func machine_state bool)))), ((hl_correctness (mk_hl c c1 c2)) /\
((forall (x:a) (p:Z) (ms:machine_state), ((infix_at (infix_at (infix_at inv
x) p) ms) = true) -> (acc (infix_at (infix_at var x) p) ms)) /\
forall (x:a) (p:Z) (ms:machine_state), ((infix_at (infix_at (infix_at inv
x) p) ms) = true) -> ((infix_at (infix_at (infix_at (infix_at c1 x) p)
(loop_post inv var post2 x p ms)) ms) = true))) -> forall (x:a) (p:Z)
(ms:machine_state), ((infix_at (infix_at (infix_at (pre (mk_hl c inv
post2)) x) p) ms) = true) -> exists ms':machine_state,
((infix_at (infix_at (infix_at (infix_at (post1 (mk_hl c inv post2)) x) p)
ms) ms') = true) /\ (contextual_irrelevance (code1 (mk_hl c inv post2)) p
ms ms').
intros a a_WT c c1 inv var post2 (h1,(h2,h3)) x p ms h4.
((c1 = inv) /\ (c2 = (loop_preservation inv var post2))))) ->
(hl_correctness (mk_hl c inv (forget_old post2))).
(* Why3 intros a a_WT c c1 c2 inv var post2 (h1,(h2,(h3,h4))). *)
intros a a_WT c c1 c2 inv var post2 (h1,(h2,(h3,h4))).
unfold hl_correctness in *.
intros.
simpl in *.
remember h4 as h5 eqn:eqn;clear eqn.
apply h2 in h4.
remember (infix_at (infix_at var x) p) as R eqn:eqR.
induction h4.
remember h5 as h6 eqn:eqn;clear eqn.
apply h3 in h5.
apply h1 in h5.
destruct h5 as [ms' [h7 h8]].
apply loop_post_def in h7.
destruct h7 as [[h9 h10]|h9].
remember H as H' eqn : eqn; clear eqn.
apply h2 in H'.
remember (infix_at (infix_at var x) p) as R eqn : eqR.
induction H'.
ae.
Qed.
......@@ -2,12 +2,12 @@
<!DOCTYPE why3session PUBLIC "-//Why3//proof session v5//EN"
"http://why3.lri.fr/why3session.dtd">
<why3session shape_version="4">
<prover id="0" name="Coq" version="8.4pl4" timelimit="5" memlimit="1000"/>
<prover id="1" name="CVC4" version="1.4" timelimit="5" memlimit="1000"/>
<prover id="0" name="CVC4" version="1.4" timelimit="5" memlimit="1000"/>
<prover id="1" name="Coq" version="8.4pl2" timelimit="5" memlimit="1000"/>
<prover id="2" name="Alt-Ergo" version="0.95.2" timelimit="5" memlimit="1000"/>
<prover id="3" name="CVC4" version="1.3" timelimit="5" memlimit="1000"/>
<file name="../logic.mlw" expanded="true">
<theory name="Compiler_logic" sum="278b30fc74b84398bcf3b01149ec3ca2" expanded="true">
<theory name="Compiler_logic" sum="230cac94b76c20b9d89901f39b823027" expanded="true">
<goal name="seq_wp_lemma">
<proof prover="2"><result status="valid" time="0.04"/></proof>
</goal>
......@@ -45,7 +45,7 @@
<goal name="WP_parameter infix %" expl="VC for infix %">
<transf name="split_goal_wp">
<goal name="WP_parameter infix %.1" expl="1. postcondition">
<proof prover="1"><result status="valid" time="0.10"/></proof>
<proof prover="0"><result status="valid" time="0.10"/></proof>
</goal>
</transf>
</goal>
......@@ -58,7 +58,7 @@
<goal name="WP_parameter hoare" expl="VC for hoare">
<transf name="split_goal_wp">
<goal name="WP_parameter hoare.1" expl="1. postcondition">
<proof prover="1"><result status="valid" time="0.07"/></proof>
<proof prover="0"><result status="valid" time="0.07"/></proof>
<proof prover="3"><result status="valid" time="0.07"/></proof>
</goal>
</transf>
......@@ -66,15 +66,10 @@
<goal name="trivial_pre_lemma">
<proof prover="2"><result status="valid" time="0.04"/></proof>
</goal>
<goal name="WP_parameter make_loop" expl="VC for make_loop" expanded="true">
<goal name="WP_parameter make_loop_hl" expl="VC for make_loop_hl" expanded="true">
<transf name="split_goal_wp" expanded="true">
<goal name="WP_parameter make_loop.1" expl="1. postcondition" expanded="true">
<proof prover="2"><result status="unknown" time="0.04"/></proof>
<transf name="inline_goal" expanded="true">
<goal name="WP_parameter make_loop.1.1" expl="1. postcondition" expanded="true">
<proof prover="0" edited="logic_Compiler_logic_WP_parameter_make_loop_1.v" obsolete="true"><undone/></proof>
</goal>
</transf>
<goal name="WP_parameter make_loop_hl.1" expl="1. postcondition" expanded="true">
<proof prover="1" edited="logic_Compiler_logic_WP_parameter_make_loop_hl_1.v"><result status="valid" time="1.69"/></proof>
</goal>
</transf>
</goal>
......
......@@ -7,12 +7,10 @@
<prover id="2" name="Alt-Ergo" version="0.95.2" timelimit="5" memlimit="1000"/>
<prover id="3" name="CVC4" version="1.3" timelimit="5" memlimit="1000"/>
<file name="../specs.mlw" expanded="true">
<theory name="VM_arith_instr_spec" sum="286760edf6bd01966f483d98d4242ea2">
<theory name="VM_arith_instr_spec" sum="89f02e7f809e0639fc6e34941844fd75">
<goal name="WP_parameter iconstf" expl="VC for iconstf">
<proof prover="2" obsolete="true"><result status="unknown" time="0.07"/></proof>
<transf name="split_goal_wp">
<goal name="WP_parameter iconstf.1" expl="1. assertion">
<proof prover="2" obsolete="true"><result status="unknown" time="0.05"/></proof>
<transf name="split_goal_wp">
<goal name="WP_parameter iconstf.1.1" expl="1. assertion">
<proof prover="2"><result status="valid" time="0.03"/></proof>
......@@ -29,14 +27,12 @@
</transf>
</goal>
<goal name="WP_parameter iconstf.2" expl="2. postcondition">
<proof prover="2" obsolete="true"><result status="unknown" time="0.06"/></proof>
<transf name="split_goal_wp">
<goal name="WP_parameter iconstf.2.1" expl="1.">
<proof prover="2"><result status="valid" time="0.03"/></proof>
</goal>
<goal name="WP_parameter iconstf.2.2" expl="2.">
<proof prover="0"><result status="valid" time="0.08"/></proof>
<proof prover="2" obsolete="true"><result status="unknown" time="0.05"/></proof>
</goal>
</transf>
</goal>
......@@ -83,10 +79,8 @@
<proof prover="2"><result status="valid" time="0.05"/></proof>
</goal>
<goal name="WP_parameter create_binop" expl="VC for create_binop">
<proof prover="2" obsolete="true"><result status="unknown" time="0.15"/></proof>
<transf name="split_goal_wp">
<goal name="WP_parameter create_binop.1" expl="1. assertion">
<proof prover="2" obsolete="true"><result status="unknown" time="0.07"/></proof>
<transf name="split_goal_wp">
<goal name="WP_parameter create_binop.1.1" expl="1. assertion">
<proof prover="2"><result status="valid" time="0.04"/></proof>
......@@ -123,7 +117,7 @@
<proof prover="2"><result status="valid" time="0.05"/></proof>
</goal>
</theory>
<theory name="VM_bool_instr_spec" sum="d5a1cc70de787ba183b03ea3799f894c" expanded="true">
<theory name="VM_bool_instr_spec" sum="32274015eab190519cb2670676a7edbf" expanded="true">
<goal name="WP_parameter inil" expl="VC for inil">
<transf name="split_goal_wp">
<goal name="WP_parameter inil.1" expl="1. postcondition">
......
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