Commit 1e470a3a authored by MEVEL Glen's avatar MEVEL Glen

dumped code from private repo

parents
CoqMakefile.conf
Makefile.coq
*.v.d
*.aux
*.glob
*.vo
.lia.cache
## Compiling
To compile the Coq scripts:
cd src/
make
The first time (and each time `_CoqProject` is updated), it also creates the
file `Makefile.coq`.
Other recipes are available, such as `all`, `clean` and `userinstall` (Makefile
taken from [here][coqproject]).
[coqproject]: https://blog.zhenzhang.me/2016/09/19/coq-dev.html
## Index of modules
* `Misc`: some basic things
* `Auth_nat`, `Auth_mnat`: simple lemmas about the authoritative resources on
(ℕ, +) and (ℕ, max)
* `Reduction`: generic lemmas about reduction, safety, closedness, fresh
locations… [should be renamed or split into several files]
* `Tactics`: tactics that help reducing concrete terms
* `Translation`: definition of the translation and syntactic lemmas about it
* `Simulation`: Lemmas about the operational semantics of the translation
* `TimeCredits`: implementation of time credits
* `TimeReceipts`: implementation of time receipts
* `Examples`: a (too) simple example illustrating the use of time credits
* `LibThunk`: implementation of timed thunks using time credits [WIP, does not
compile for now]
* `test`: an alternative proof of the main theorem of time credits, that does
not rely on the unsafe behaviour of `tick` [to be merged into `TimeCredits`]
From iris Require Export algebra.auth base_logic.lib.own proofmode.tactics.
Notation "'●mnat' n" := (Auth (A:=mnat) (Excl' n%nat) ε) (at level 20).
Notation "'◯mnat' n" := (Auth (A:=mnat) None n%nat) (at level 20).
Section Auth_mnat.
Context `{inG Σ (authR mnatUR)}.
Lemma own_auth_mnat_null (γ : gname) (m : mnat) :
own γ (mnat m) -
own γ (mnat m) own γ (mnat 0).
Proof.
by rewrite - own_op (_ : mnat m mnat 0 = mnat m).
Qed.
Global Arguments own_auth_mnat_null _ _%nat_scope.
Lemma auth_mnat_update_read_auth (γ : gname) (m : mnat) :
own γ (mnat m) -
|==> own γ (mnat m) own γ (mnat m).
Proof.
iIntros "H●".
iDestruct (own_auth_mnat_null with "H●") as "[H● H◯]".
(iMod (own_update_2 with "H● H◯") as "[$ $]" ; last done).
apply auth_update, mnat_local_update. lia.
Qed.
Global Arguments auth_mnat_update_read_auth _ _%nat_scope.
Lemma auth_mnat_update_incr (γ : gname) (m k : mnat) :
own γ (mnat m) -
|==> own γ (mnat (m + k : mnat)).
Proof.
iIntros "H●". iDestruct (own_auth_mnat_null with "H●") as "[H● H◯]".
iMod (own_update_2 with "H● H◯") as "[$ _]" ; last done.
apply auth_update, mnat_local_update. lia.
Qed.
Global Arguments auth_mnat_update_incr _ (_ _)%nat_scope.
End Auth_mnat.
\ No newline at end of file
From iris Require Export algebra.auth base_logic.lib.own proofmode.tactics.
Notation "'●nat' n" := (Auth (A:=nat) (Excl' n%nat) ε) (at level 20).
Notation "'◯nat' n" := (Auth (A:=nat) None n%nat) (at level 20).
Section Auth_nat.
Context `{inG Σ (authR natUR)}.
Lemma auth_nat_alloc (n : nat) :
(|==> γ, own γ ( n) own γ ( n))%I.
Proof.
by iMod (own_alloc ( n n)) as (γ) "[? ?]" ; auto with iFrame.
Qed.
Lemma own_auth_nat_le (γ : gname) (m n : nat) :
own γ (nat m) -
own γ (nat n) -
(n m)%nat.
Proof.
iIntros "H● H◯".
by iDestruct (own_valid_2 with "H● H◯")
as % [?%nat_le_sum _] % auth_valid_discrete_2.
Qed.
Lemma own_auth_nat_null (γ : gname) (m : nat) :
own γ (nat m) -
own γ (nat m) own γ (nat 0).
Proof.
by rewrite - own_op (_ : nat m nat 0 = nat m).
Qed.
Lemma auth_nat_update_incr (γ : gname) (m k : nat) :
own γ (nat m) -
|==> own γ (nat (m + k)) own γ (nat k).
Proof.
iIntros "H●". iDestruct (own_auth_nat_null with "H●") as "[H● H◯]".
iMod (own_update_2 with "H● H◯") as "[$ $]" ; last done.
apply auth_update, nat_local_update. lia.
Qed.
Lemma auth_nat_update_decr (γ : gname) (m n k : nat) :
(k n)%nat
own γ (nat m) -
own γ (nat n) -
|==> own γ (nat (m - k)) own γ (nat (n - k)).
Proof.
iIntros (I) "H● H◯".
iDestruct (own_auth_nat_le with "H● H◯") as %J.
iMod (own_update_2 with "H● H◯") as "[$ $]" ; last done.
apply auth_update, nat_local_update. lia.
Qed.
Lemma own_auth_nat_weaken (γ : gname) (n n : nat) :
(n n)%nat
own γ (nat n) -
own γ (nat n).
Proof.
iIntros (I) "H".
rewrite (_ : n = (n - n) + n)%nat ; last lia.
iDestruct "H" as "[_$]".
Qed.
End Auth_nat.
\ No newline at end of file
(* code taken from the Iris tutorial… *)
From iris.heap_lang Require Import proofmode notation.
From iris.program_logic Require Import adequacy.
Require Import TimeCredits Reduction.
(** A function that sums all elements of a list, defined as a heap-lang value: *)
Definition sum_list : val :=
rec: "sum_list" "l" :=
match: "l" with
NONE => #0
| SOME "p" =>
let: "x" := Fst !"p" in
let: "l" := Snd !"p" in
"x" + "sum_list" "l"
end.
(** Representation predicate in separation logic for a list of integers [l]: *)
Fixpoint is_list `{heapG Σ} (l : list Z) (v : val) : iProp Σ :=
match l with
| [] => v = NONEV
| x :: l' => (p : loc), v = SOMEV #p
(v' : val), p (#x, v') is_list l' v'
end%I.
(* [is_list_tr l v] means that the translation of [v] represents [l]: *)
Fixpoint is_list_tr `{timeCreditHeapG Σ} (l : list Z) (v : val) : iProp Σ :=
match l with
| [] => v = NONEV
| x :: l' => (p : loc), v = SOMEV #p
(v' : val), p (#x, «v'») is_list_tr l' v'
end%I.
(* some proofs: *)
Lemma is_list_translation `{!timeCreditHeapG Σ} l v :
(is_list l v - is_list l v v = «v»%V)%I.
Proof.
iIntros "Hl".
destruct l as [|x l] ; simpl.
- by iDestruct "Hl" as %->.
- iDestruct "Hl" as (p) "[-> ?]".
iSplitL.
+ iExists p. by iFrame.
+ done.
Qed.
Lemma is_list_tr_translation `{!timeCreditHeapG Σ} l v :
(is_list_tr l v - is_list_tr l v v = «v»%V)%I.
Proof.
iIntros "Hl".
destruct l as [|x l] ; simpl.
- by iDestruct "Hl" as %->.
- iDestruct "Hl" as (p) "[-> Hl]" ; iDestruct "Hl" as (v') "[Hp Hl']".
iSplitL.
+ iExists p. iSplit ; first done. eauto with iFrame.
+ done.
Qed.
Lemma is_list_tr_is_list_translation `{!timeCreditHeapG Σ} l v :
(is_list_tr l v is_list l «v»%V)%I.
Proof.
iSplit ; iIntros "Hl".
{
iInduction l as [|x l] "IH" forall (v) ; simpl.
- iDestruct "Hl" as %->.
done.
- iDestruct "Hl" as (p) "[-> Hl]" ; iDestruct "Hl" as (v) "[Hp Hl]".
iPoseProof ("IH" with "Hl") as "Hl". eauto with iFrame.
}
{
iInduction l as [|x l] "IH" forall (v) ; simpl.
- iDestruct "Hl" as %Eq. iPureIntro. by eapply translationV_injective.
- iDestruct "Hl" as (p) "[Eq Hl]" ; iDestruct "Eq" as %Eq ; iDestruct "Hl" as (v') "[Hp Hl]".
change (InjRV #p)%V with «InjRV #p»%V in Eq. apply translationV_injective in Eq as ->.
iDestruct (is_list_translation with "Hl") as "[Hl ->]".
iPoseProof ("IH" with "Hl") as "Hl". eauto with iFrame.
}
Qed.
Lemma is_list_is_list_tr `{!timeCreditHeapG Σ} l v :
(is_list l v is_list_tr l v)%I.
Proof.
iSplit ; iIntros "Hl".
{
iInduction l as [|x l] "IH" forall (v) ; simpl.
- done.
- iDestruct "Hl" as (p) "[-> Hl]" ; iDestruct "Hl" as (v) "[Hp Hl]".
iExists p. iSplitR ; first done. iExists v.
iDestruct (is_list_translation with "Hl") as "[Hl <-]".
iFrame.
iApply ("IH" with "Hl").
}
{
iInduction l as [|x l] "IH" forall (v) ; simpl.
- done.
- iDestruct "Hl" as (p) "[-> Hl]" ; iDestruct "Hl" as (v) "[Hp Hl]".
iExists p. iSplitR ; first done. iExists v.
iDestruct (is_list_tr_translation with "Hl") as "[Hl <-]".
iFrame.
iApply ("IH" with "Hl").
}
Qed.
Definition sum_list_coq (l : list Z) : Z :=
fold_right Z.add 0 l.
(** The proof using induction over [l]: *)
Lemma sum_list_spec `{!heapG Σ} (l : list Z) (v : val) :
{{{ is_list l v }}} sum_list v {{{ RET #(sum_list_coq l) ; is_list l v }}}.
Proof.
iIntros (Φ) "Hl Post".
iInduction l as [|x l] "IH" forall (v Φ) ; simpl.
- iDestruct "Hl" as %->.
wp_rec.
wp_match.
by iApply "Post".
- iDestruct "Hl" as (p) "[-> Hl]". iDestruct "Hl" as (v) "[Hp Hl]".
wp_rec.
wp_match.
wp_load. wp_proj. wp_let.
wp_load. wp_proj. wp_let.
wp_apply ("IH" with "Hl"). iIntros "Hl".
wp_op.
iApply "Post". eauto with iFrame.
Qed.
Lemma sum_list_translation_spec `{!timeCreditHeapG Σ} (l : list Z) (v : val) :
TICKCTXT -
{{{ is_list_tr l v TC (3 + 10 * length l) }}} « sum_list v » {{{ RET #(sum_list_coq l) ; is_list_tr l v }}}.
Proof.
iIntros "#Htickinv !#" (Φ) "[Hl Htc] Post".
iInduction l as [|x l] "IH" forall (v Φ).
- simpl.
rewrite !translation_of_val.
iDestruct "Hl" as %->.
wp_tick ; unlock sum_list ; wp_rec.
wp_tick ; wp_match ; do 2 wp_lam ; wp_tick.
by iApply "Post".
- replace (3 + 10 * length (x :: l))%nat with (13 + 10 * length l)%nat by (simpl ; lia).
simpl.
rewrite !translation_of_val. setoid_rewrite translation_of_val.
iDestruct "Hl" as (p) "[-> Hl]" ; iDestruct "Hl" as (v) "[Hp Hl]".
wp_tick ; unlock sum_list ; wp_rec.
wp_tick ; wp_match ; do 2 wp_lam ; wp_tick ; wp_lam.
wp_tick ; wp_load. wp_tick ; wp_proj. wp_tick ; wp_let.
wp_tick ; wp_load. wp_tick ; wp_proj. wp_tick ; wp_let.
iDestruct "Htc" as "[Htc1 Htc]".
wp_apply ("IH" with "Hl Htc"). iIntros "Hl".
wp_tick ; wp_op.
iApply "Post". eauto with iFrame.
Qed.
Definition make_list : val :=
rec: "make_list" "n" :=
if: "n" = #0 then
NONE
else
SOME (ref ("n", "make_list" ("n" - #1))).
Fixpoint make_list_coq (n : nat) : list Z :=
match n with
| 0%nat => []
| S n' => Z.of_nat n :: make_list_coq n'
end.
(** The proof using induction over [l]: *)
Lemma make_list_spec `{!heapG Σ} (n : nat) :
{{{ True }}} make_list #n {{{ v, RET v ; is_list (make_list_coq n) v }}}.
Proof.
iIntros (Φ) "_ Post".
iInduction n as [|n'] "IH" forall (Φ) ; simpl.
- wp_rec. wp_op. wp_if.
by iApply "Post".
- wp_rec. wp_op. wp_if.
wp_op.
assert (Z.of_nat n' = Z.of_nat (S n') - 1) as Eq by lia ; simpl in Eq ; destruct Eq.
wp_apply "IH". iIntros (v') "Hl".
change (Z.pos $ Pos.of_succ_nat n') with (Z.of_nat $ S n').
wp_alloc p.
iApply "Post". eauto with iFrame.
Qed.
Lemma make_list_translation_spec `{!timeCreditHeapG Σ} (n : nat) :
TICKCTXT -
{{{ TC (3+5*n) }}} «make_list #n» {{{ v', RET v' ; is_list (make_list_coq n) v' }}}.
Proof.
iIntros "#Htickinv !#" (Φ) "Htc Post".
iInduction n as [|n'] "IH" forall (Φ).
- simpl.
rewrite !translation_of_val.
wp_tick ; unlock make_list ; wp_rec. wp_tick ; wp_op. wp_tick ; wp_if.
by iApply "Post".
- replace (3 + 5 * S n')%nat with (8 + 5 * n')%nat by lia.
simpl.
rewrite !translation_of_val.
wp_tick ; unlock make_list ; wp_rec. wp_tick ; wp_op. wp_tick ; wp_if.
wp_tick ; wp_op.
assert (Z.of_nat n' = Z.of_nat (S n') - 1) as Eq by lia ; simpl in Eq ; destruct Eq.
iDestruct "Htc" as "[Htc1 Htc]".
wp_apply ("IH" with "Htc"). iIntros (v') "Hl".
change (Z.pos $ Pos.of_succ_nat n') with (Z.of_nat $ S n').
wp_tick ; wp_alloc p.
iApply "Post". eauto with iFrame.
Qed.
Let prgm (n : nat) : expr :=
sum_list (make_list #n).
Lemma length_make_list_coq (n : nat) :
length (make_list_coq n) = n.
Proof.
induction n as [|n' IH].
- done.
- simpl. by f_equal.
Qed.
Lemma sum_list_coq_make_list_coq (n : nat) :
sum_list_coq (make_list_coq n) = (Z.of_nat n * (Z.of_nat n + 1)) `div` 2.
Proof.
rewrite - Z.div2_div.
assert (2 * sum_list_coq (make_list_coq n) = (Z.of_nat n * (Z.of_nat n + 1))) as Eq.
{
induction n as [|n' IH].
- done.
- rewrite /= Z.mul_add_distr_l IH. lia.
}
assert (Zeven (Z.of_nat n * (Z.of_nat n + 1))) as Heven % Zeven_div2.
{
pose proof (Zeven_odd_dec n) as [ Heven | Hodd ].
- by apply Zeven_mult_Zeven_l.
- by apply Zeven_mult_Zeven_r, Zodd_plus_Zodd.
}
lia.
Qed.
Lemma prgm_spec `{!heapG Σ} (n : nat) :
{{{ True }}} prgm n {{{ v, RET v ; v = #(n*(n+1)/2) }}}.
Proof.
iIntros (Φ) "_ Post".
unfold prgm.
wp_apply (make_list_spec with "[//]"). iIntros (v) "Hl".
wp_apply (sum_list_spec with "Hl"). iIntros "Hl".
iApply ("Post" with "[%]"). repeat f_equal. apply sum_list_coq_make_list_coq.
Qed.
Lemma prgm_translation_spec `{!timeCreditHeapG Σ} (n : nat) :
TICKCTXT -
{{{ TC (6+15*n) }}} «prgm n» {{{ v, RET v ; v = #(n*(n+1)/2) }}}.
Proof.
iIntros "#Htickinv !#" (Φ) "Htc Post".
unfold prgm.
change « sum_list (make_list (LitV n)) » with («sum_list» (tick «make_list #n»)).
rewrite !translation_of_val.
replace (6+15*n)%nat with ((3+5*n) + (3+10*n))%nat by lia ;
rewrite TC_plus ; iDestruct "Htc" as "[Htc_make Htc_sum]".
wp_apply (make_list_translation_spec with "Htickinv Htc_make"). iIntros (v) "Hl".
iDestruct (is_list_translation with "Hl") as "[Hl ->]".
rewrite - !translation_of_val.
change (« sum_list » (tick « v »)) with « sum_list v ».
wp_apply (sum_list_translation_spec with "Htickinv [Hl Htc_sum]"). {
rewrite - is_list_tr_is_list_translation.
erewrite length_make_list_coq. iFrame.
} iIntros "Hl".
iApply ("Post" with "[%]"). repeat f_equal. apply sum_list_coq_make_list_coq.
Qed.
Theorem spec_tctranslation__adequate_and_bounded' {Σ} m (φ : val Prop) e :
( v, φ v closure_free v)
is_closed [] e
( `{timeCreditHeapG Σ},
TICKCTXT -
{{{ TC m }}} «e» {{{ v, RET v ; ⌜φ v }}}
)
{_ : timeCreditHeapPreG Σ} σ,
adequate NotStuck e σ φ bounded_time e σ m.
Proof.
intros Hφ Hclosed Hspec HpreG σ.
apply (spec_tctranslation__adequate_and_bounded (Σ:=Σ)) ; try assumption.
intros HtcHeapG.
iIntros "#Htickinv !#" (Φ) "Htc Post".
wp_apply (Hspec with "Htickinv Htc"). iIntros (v Hv).
iApply ("Post" with "[%]").
by apply closure_free_predicate.
Qed.
Lemma prgm_timed_spec (n : nat) (σ : state) `{!timeCreditHeapPreG Σ} :
adequate NotStuck (prgm n) σ (λ v, v = #(n*(n+1)/2))
bounded_time (prgm n) σ (6 + 15 * n)%nat.
Proof.
apply (spec_tctranslation__adequate_and_bounded (Σ:=Σ)).
- rewrite !andb_True ; repeat split ; apply is_closed_of_val.
- intros HtcHeapG.
iIntros "#Htickinv !#". iIntros (Φ) "Htc Post".
wp_apply (prgm_translation_spec with "Htickinv Htc"). iIntros (v ->).
iApply ("Post" with "[%]"). done.
- assumption.
Restart.
apply (spec_tctranslation__adequate_and_bounded' (Σ:=Σ)).
- by intros _ ->.
- rewrite !andb_True ; repeat split ; apply is_closed_of_val.
- intros HtcHeapG. apply prgm_translation_spec.
- assumption.
Qed.
\ No newline at end of file
From iris.heap_lang Require Import proofmode notation adequacy.
From iris.algebra Require Import auth.
From iris.base_logic Require Import invariants.
From stdpp Require Import namespaces.
Require Import Auth_nat Auth_mnat.
Section Thunk.
(*
Context `{heapG Σ}.
Context { TC : nat → iProp Σ }.
Context { tick : val }.
Context `{ ∀ m n, TC (m+n) ≡ (TC m ∗ TC n)%I }.
Context `{ ∀ n, Timeless (TC n) }.
Context `{ ∀ (v : val), {{{ TC 1 }}} tick v {{{ RET v ; True }}} }.
*)
Require Import TimeCredits.
Context `{timeCreditHeapG Σ}.
Context `{inG Σ (authR mnatUR)}.
(** Notations for thunks *)
Notation UNEVALUATED f := (InjL f%V) (only parsing).
Notation EVALUATING := (InjR (InjL #())) (only parsing).
Notation EVALUATED v := (InjR (InjR v%V)) (only parsing).
Notation UNEVALUATEDV f := (InjLV f%E) (only parsing).
Notation EVALUATINGV := (InjRV (InjLV #())) (only parsing).
Notation EVALUATEDV v := (InjRV (InjRV v%V)) (only parsing).
Notation "'match:' e0 'with' 'UNEVALUATED' x1 => e1 | 'EVALUATING' => e2 | 'EVALUATED' x3 => e3 'end'" :=
(Match e0 x1%bind e1 x3%bind (Match x3%bind BAnon e2 x3%bind e3)) (* hackish! *)
(e0, e1, e2, x3, e3 at level 200, only parsing) : expr_scope.
(** /notations *)
From iris.base_logic Require Import invariants.
Definition thunkN (t : loc) := nroot .@ "thunk" .@ string_of_pos t.
From iris.algebra Require Import excl cmra.
Definition token := Excl ().
Context `{inG Σ (exclR unitC)}.
Definition ThunkInv (t : loc) (γ γtok : gname) (nc : nat) (φ : val iProp Σ) : iProp Σ := (
(ac : nat),
own γ (mnat ac)
(
( (f : val),
t UNEVALUATEDV f
{{{ TC nc }}} f #() {{{ v, RET v ; φ v }}}
TC ac
own γtok token
)
( t EVALUATINGV
(ac nc)%nat
)
( (v : val),
t EVALUATEDV v
φ v
(ac nc)%nat
own γtok token
)
)
)%I.
Definition Thunk (t : loc) (n : nat) (φ : val iProp Σ) : iProp Σ := (
(γ γtok : gname) (nc : nat),
inv (thunkN t) (ThunkInv t γ γtok nc φ)
own γ (mnat (nc-n))
)%I.
Lemma own_auth_mnat_weaken (γ : gname) (n n : mnat) :
(n n)%nat
own γ (mnat n) -
own γ (mnat n).
Proof.
iIntros (I) "H".
rewrite (_ : n = n `max` n)%nat ; last (by rewrite max_l).
iDestruct "H" as "[_$]".
Qed.
Global Arguments own_auth_mnat_weaken _ (_ _ _)%nat_scope.
Lemma Thunk_weaken (t : loc) (n n : nat) (φ : val iProp Σ) :
(n n)%nat
Thunk t n φ -
Thunk t n φ.
Proof.
iIntros (I) "H". iDestruct "H" as (γ γtok nc) "[Hinv Hγ◯]".
iExists (γ), (γtok), (nc). iFrame "Hinv".
iDestruct (own_auth_mnat_weaken _ (nc-n)%nat (nc-n)%nat with "Hγ◯") as "$" ; first lia.
Qed.
Lemma TC_weaken (n n : nat) :
(n n)%nat
TC n - TC n.
Admitted.
Definition create : val :=
λ: "f",
ref (UNEVALUATED "f").
Definition force : val :=
rec: "force" "t" :=
match: ! "t" with
UNEVALUATED "f" =>
if: CAS "t" (UNEVALUATED "f") EVALUATING then
let: "v" := "f" #() in
if: CAS "t" EVALUATING (EVALUATED "v") then
"v"
else
#() #() (* will not happen *)
else
"force" "t"
| EVALUATING =>
"force" "t"
| EVALUATED "v" =>
"v"
end.
Lemma zero_TC :
TICKCTXT ={}= TC 0.
Proof.
iIntros "#Htickinv".
iInv timeCreditN as (m) ">[Hcounter H●]" "Hclose".
iDestruct (own_auth_nat_null with "H●") as "[H● $]".
iApply "Hclose" ; eauto with iFrame.
Qed.
Lemma auth_mnat_alloc `{inG Σ (authR natUR)} (n : mnat) :
(|==> γ, own γ (mnat n) own γ (mnat n))%I.
Proof.
by iMod (own_alloc (mnat n mnat n)) as (γ) "[? ?]" ; auto with iFrame.
Qed.
Global Arguments auth_mnat_alloc {_} n%nat.
Lemma create_spec (E : coPset) (f : val) (nc : nat) (φ : val iProp Σ) :
TICKCTXT -
{{{ ( {{{ TC nc }}} f #() {{{ v, RET v ; φ v }}} ) }}}