Commit 8b923b0b authored by Michael Sammler's avatar Michael Sammler Committed by Rodolphe Lepigre
Browse files

Add SimplExist and SimplForall

parent 5a7b2bf6
Pipeline #55171 passed with stage
in 31 minutes and 13 seconds
...@@ -1288,7 +1288,13 @@ let pp_proof : Coq_path.t -> func_def -> import list -> string list ...@@ -1288,7 +1288,13 @@ let pp_proof : Coq_path.t -> func_def -> import list -> string list
List.iter (fun (x,_) -> pp " arg_%s" x) def.func_args; List.iter (fun (x,_) -> pp " arg_%s" x) def.func_args;
List.iter (fun (x,_) -> pp " local_%s" x) def.func_vars List.iter (fun (x,_) -> pp " local_%s" x) def.func_vars
end; end;
pp ".@;split_blocks (("; pp ".@;";
if func_annot.fa_parameters <> [] then
begin
let pp_var ff (x, _) = pp_print_string ff x in
pp "prepare_parameters (%a).@;" (pp_sep " " pp_var) func_annot.fa_parameters;
end;
pp "split_blocks ((";
let pp_inv (id, annot) = let pp_inv (id, annot) =
(* Opening a box and printing the existentials. *) (* Opening a box and printing the existentials. *)
pp "@; @[<v 2><[ \"%s\" :=" id; pp "@; @[<v 2><[ \"%s\" :=" id;
......
...@@ -53,6 +53,30 @@ Global Instance Pte_BitfieldDesc : BitfieldDesc Pte := {| ...@@ -53,6 +53,30 @@ Global Instance Pte_BitfieldDesc : BitfieldDesc Pte := {|
bitfield_repr := pte_repr; bitfield_repr := pte_repr;
bitfield_wf := pte_wf; bitfield_wf := pte_wf;
|}. |}.
(*
Global Instance simpl_exist_Pte P : SimplExist Pte P
(∃ valid type leaf_attr_lo addr undef leaf_attr_hi,
P {|
pte_valid := valid;
pte_type := type;
pte_leaf_attr_lo := leaf_attr_lo;
pte_addr := addr;
pte_undef := undef;
pte_leaf_attr_hi := leaf_attr_hi;
|}).
Proof. unfold SimplExist. naive_solver. Qed.
Global Instance simpl_forall_Pte P : SimplForall Pte 6 P
(∀ valid type leaf_attr_lo addr undef leaf_attr_hi,
P {|
pte_valid := valid;
pte_type := type;
pte_leaf_attr_lo := leaf_attr_lo;
pte_addr := addr;
pte_undef := undef;
pte_leaf_attr_hi := leaf_attr_hi;
|}).
Proof. unfold SimplForall => ? []. naive_solver. Qed.
*)
Definition addr_of (n : Z) : Z := Definition addr_of (n : Z) : Z :=
bf_slice 12 36 n. bf_slice 12 36 n.
...@@ -119,6 +143,10 @@ Global Instance Prot_BitfieldDesc : BitfieldDesc Prot := {| ...@@ -119,6 +143,10 @@ Global Instance Prot_BitfieldDesc : BitfieldDesc Prot := {|
bitfield_repr := prot_repr; bitfield_repr := prot_repr;
bitfield_wf := prot_wf; bitfield_wf := prot_wf;
|}. |}.
Global Instance simpl_exist_Prot P : SimplExist Prot P ( x w r device, P {| prot_x := x; prot_w := w; prot_r := r; prot_device := device |}).
Proof. unfold SimplExist. naive_solver. Qed.
Global Instance simpl_forall_Prot P : SimplForall Prot 4 P ( x w r device, P {| prot_x := x; prot_w := w; prot_r := r; prot_device := device |}).
Proof. unfold SimplForall => ? []. naive_solver. Qed.
(* struct, const *) (* struct, const *)
......
...@@ -501,7 +501,7 @@ Ltac liExist protect := ...@@ -501,7 +501,7 @@ Ltac liExist protect :=
| _ => idtac | _ => idtac
end; end;
lazymatch goal with lazymatch goal with
| |- @ex ?A _ => | |- @ex ?A ?P =>
first [ first [
custom_exist_tac A protect custom_exist_tac A protect
| lazymatch A with | lazymatch A with
...@@ -512,10 +512,15 @@ Ltac liExist protect := ...@@ -512,10 +512,15 @@ Ltac liExist protect :=
| sigT _ => apply: tac_exist_sigT | sigT _ => apply: tac_exist_sigT
| unit => exists tt | unit => exists tt
| ?A => | ?A =>
lazymatch protect with first [
| true => let Hevar := create_protected_evar A in exists (protected Hevar) let p := constr:(_ : SimplExist A P _) in
| false => eexists _ refine (@simpl_exist_proof _ _ _ p _)
end |
lazymatch protect with
| true => let Hevar := create_protected_evar A in exists (protected Hevar)
| false => eexists _
end
]
end ] end ]
| _ => fail "do_exist: unknown goal" | _ => fail "do_exist: unknown goal"
end. end.
...@@ -595,26 +600,46 @@ Ltac liImpl := ...@@ -595,26 +600,46 @@ Ltac liImpl :=
end. end.
Ltac liForall := Ltac liForall :=
let do_intro name := (* n tells us how many quantifiers we should introduce with this name *)
repeat lazymatch goal with let rec do_intro n name :=
(* relying on the fact that unification variables cannot contain lazymatch n with
dependent variables to distinguish between dependent and non dependent forall *) | S ?n' =>
| |- ?P -> ?Q => fail "implication, not forall" lazymatch goal with
| |- forall _ : ?P, _ => (* relying on the fact that unification variables cannot contain
(* When changing this, also change [prepare_initial_coq_context] in automation.v *) dependent variables to distinguish between dependent and non dependent forall *)
lazymatch P with | |- ?P -> ?Q =>
| (prod _ _) => case lazymatch type of P with
| unit => case | Prop => fail "implication, not forall"
| _ => let H := fresh name in intro H | _ => (* just some unused variable, discard *) move => _
end end
| |- forall _ : ?A, _ =>
(* When changing this, also change [prepare_initial_coq_context] in automation.v *)
lazymatch A with
| (prod _ _) => case; do_intro (S (S O)) name
| unit => case
| _ =>
first [
(* We match again since having e in the context when calling fresh can mess up names. *)
lazymatch goal with
| |- forall e : ?A, @?P e =>
let sn := open_constr:(_ : nat) in
let p := constr:(_ : SimplForall A sn P _) in
refine (@simpl_forall_proof _ _ _ _ p _);
do_intro sn name
end
| let H := fresh name in intro H
]
end
end; do_intro n' name
| O => idtac
end end
in in
lazymatch goal with lazymatch goal with
| |- envs_entails _ (bi_forall (λ name, _)) => notypeclasses refine (tac_do_forall _ _ _ _); do_intro name | |- envs_entails _ (bi_forall (λ name, _)) => notypeclasses refine (tac_do_forall _ _ _ _); do_intro (S O) name
| |- envs_entails _ (bi_wand (bi_exist (λ name, _)) _) => | |- envs_entails _ (bi_wand (bi_exist (λ name, _)) _) =>
notypeclasses refine (tac_do_exist_wand _ _ _ _ _); do_intro name notypeclasses refine (tac_do_exist_wand _ _ _ _ _); do_intro (S O) name
| |- ( name, _) _ => case; do_intro name | |- ( name, _) _ => case; do_intro (S O) name
| |- forall name, _ => do_intro name | |- forall name, _ => do_intro (S O) name
| _ => fail "do_forall: unknown goal" | _ => fail "do_forall: unknown goal"
end. end.
......
From refinedc.lithium Require Import base. From refinedc.lithium Require Import base.
Class SimplExist (T : Type) (e : T Prop) (Q: Prop) := simpl_exist_proof : Q x, e x.
Class SimplForall (T : Type) (n : nat) (e : T Prop) (Q: Prop) := simpl_forall_proof : Q x, e x.
Class SimplImplUnsafe (changed : bool) (P : Prop) (Ps : Prop Prop) := simpl_impl_unsafe T: (Ps T) (P T). Class SimplImplUnsafe (changed : bool) (P : Prop) (Ps : Prop Prop) := simpl_impl_unsafe T: (Ps T) (P T).
Class SimplAndUnsafe (changed : bool) (P : Prop) (Ps : Prop Prop) := simpl_and_unsafe T: (Ps T) (P T). Class SimplAndUnsafe (changed : bool) (P : Prop) (Ps : Prop Prop) := simpl_and_unsafe T: (Ps T) (P T).
Global Instance simplimpl_unsafe_id (P : Prop) : SimplImplUnsafe false P (λ T, P T) | 1000. Global Instance simplimpl_unsafe_id (P : Prop) : SimplImplUnsafe false P (λ T, P T) | 1000.
......
...@@ -278,25 +278,6 @@ Tactic Notation "liRStepUntil" open_constr(id) := ...@@ -278,25 +278,6 @@ Tactic Notation "liRStepUntil" open_constr(id) :=
(** * Tactics for starting a function *) (** * Tactics for starting a function *)
(* Recursively destruct a product in hypothesis H, using the given name as template. *)
Ltac destruct_product_hypothesis name H :=
match goal with
| H : _ * _ |- _ => let tmp1 := fresh "tmp" in
let tmp2 := fresh "tmp" in
destruct H as [tmp1 tmp2];
destruct_product_hypothesis name tmp1;
destruct_product_hypothesis name tmp2
| |- _ => let id := fresh name in
rename H into id
end.
Ltac prepare_initial_coq_context :=
(* The automation assumes that all products in the context are destructed, see liForall *)
repeat lazymatch goal with
| H : _ * _ |- _ => destruct_product_hypothesis H H
| H : unit |- _ => destruct H
end.
(* IMPORTANT: We need to make sure to never call simpl while the code (* IMPORTANT: We need to make sure to never call simpl while the code
(Q) is part of the goal, because simpl seems to take exponential time (Q) is part of the goal, because simpl seems to take exponential time
in the number of blocks! *) in the number of blocks! *)
...@@ -308,7 +289,10 @@ Tactic Notation "start_function" constr(fnname) "(" simple_intropattern(x) ")" : ...@@ -308,7 +289,10 @@ Tactic Notation "start_function" constr(fnname) "(" simple_intropattern(x) ")" :
iIntros ( x ); iIntros ( x );
iSplit; [iPureIntro; simpl; by [repeat constructor] || fail "in" fnname "argument types don't match layout of arguments" |]; iSplit; [iPureIntro; simpl; by [repeat constructor] || fail "in" fnname "argument types don't match layout of arguments" |];
let lsa := fresh "lsa" in let lsv := fresh "lsv" in let lsa := fresh "lsa" in let lsv := fresh "lsv" in
iIntros "!#" (lsa lsv); inv_vec lsv; inv_vec lsa; prepare_initial_coq_context. iIntros "!#" (lsa lsv); inv_vec lsv; inv_vec lsa.
Tactic Notation "prepare_parameters" "(" ident_list(i) ")" :=
revert i; repeat liForall.
Ltac liRSplitBlocksIntro := Ltac liRSplitBlocksIntro :=
repeat ( repeat (
......
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