SessionTypes: simplified and proved a key invariant

This commit is contained in:
Adam Chlipala 2018-05-13 09:32:31 -04:00
parent 91fc06122d
commit b9893a0e92
2 changed files with 120 additions and 142 deletions

View file

@ -335,7 +335,7 @@ Definition add2_once (input output : channel) : proc :=
* of the first process as the fancy *implementation* and the second process as * of the first process as the fancy *implementation* and the second process as
* the simpler *specification*. *) * the simpler *specification*. *)
Inductive R_add2 : proc -> proc -> Prop := Inductive R_add2 : proc -> proc -> Prop :=
| Initial : forall input output, | Starting : forall input output,
input <> output input <> output
-> R_add2 -> R_add2
(New[input;output](ch); ??input(n : nat); !!ch(n + 1); Done (New[input;output](ch); ??input(n : nat); !!ch(n + 1); Done

View file

@ -14,14 +14,11 @@ Set Asymmetric Patterns.
Inductive type := Inductive type :=
| TSend (ch : channel) (A : Set) (t : type) | TSend (ch : channel) (A : Set) (t : type)
| TRecv (ch : channel) (A : Set) (t : type) | TRecv (ch : channel) (A : Set) (t : type)
| TPar (t1 t2 : type)
| TDup (t : type)
| TDone | TDone
| InternalChoice (t1 t2 : type) | InternalChoice (t1 t2 : type)
| ExternalChoice (t1 t2 : type). | ExternalChoice (t1 t2 : type).
Infix "||" := Par : st_scope.
Delimit Scope st_scope with st. Delimit Scope st_scope with st.
Bind Scope st_scope with type. Bind Scope st_scope with type.
Notation "!!! ch ( A ) ; k" := (TSend ch A k%st) (right associativity, at level 45, ch at level 0) : st_scope. Notation "!!! ch ( A ) ; k" := (TSend ch A k%st) (right associativity, at level 45, ch at level 0) : st_scope.
@ -29,116 +26,13 @@ Notation "??? ch ( A ) ; k" := (TRecv ch A k%st) (right associativity, at level
Infix "|?|" := InternalChoice (at level 40) : st_scope. Infix "|?|" := InternalChoice (at level 40) : st_scope.
Infix "?|?" := ExternalChoice (at level 40) : st_scope. Infix "?|?" := ExternalChoice (at level 40) : st_scope.
Inductive ignoresChannel (ch : channel) : type -> Prop :=
| IcSend : forall ch' A t,
ch' <> ch
-> ignoresChannel ch t
-> ignoresChannel ch (TSend ch' A t)
| IcRecv : forall ch' A t,
ch' <> ch
-> ignoresChannel ch t
-> ignoresChannel ch (TRecv ch' A t)
| IcPar : forall t1 t2,
ignoresChannel ch t1
-> ignoresChannel ch t2
-> ignoresChannel ch (TPar t1 t2)
| IcDup : forall t,
ignoresChannel ch t
-> ignoresChannel ch (TDup t)
| IcDone :
ignoresChannel ch TDone
| IcInternalChoice : forall t1 t2,
ignoresChannel ch t1
-> ignoresChannel ch t2
-> ignoresChannel ch (InternalChoice t1 t2)
| IcExternalChoice : forall t1 t2,
ignoresChannel ch t1
-> ignoresChannel ch t2
-> ignoresChannel ch (ExternalChoice t1 t2).
Inductive hideChannel (ch : channel) : type -> type -> Prop :=
| HideIgnored : forall t,
ignoresChannel ch t
-> hideChannel ch t t
| HideExtSend1 : forall ch' A t1 t2 t',
ch' <> ch
-> ignoresChannel ch' t2
-> hideChannel ch (TPar t1 t2) t'
-> hideChannel ch (TPar (TSend ch' A t1) t2) (TSend ch' A t')
| HideExtRecv1 : forall ch' A t1 t2 t',
ch' <> ch
-> ignoresChannel ch' t2
-> hideChannel ch (TPar t1 t2) t'
-> hideChannel ch (TPar (TRecv ch' A t1) t2) (TRecv ch' A t')
| HideExtSend2 : forall ch' A t1 t2 t',
ch' <> ch
-> ignoresChannel ch' t2
-> hideChannel ch (TPar t1 t2) t'
-> hideChannel ch (TPar t1 (TSend ch' A t2)) (TSend ch' A t')
| HideExtRecv2 : forall ch' A t1 t2 t',
ch' <> ch
-> ignoresChannel ch' t2
-> hideChannel ch (TPar t1 t2) t'
-> hideChannel ch (TPar t1 (TRecv ch' A t2)) (TRecv ch' A t')
| HideRendezvous1 : forall A t1 t2 t',
hideChannel ch (TPar t1 t2) t'
-> hideChannel ch (TPar (TSend ch A t1) (TRecv ch A t2)) t'
| HideRendezvous2 : forall A t1 t2 t',
hideChannel ch (TPar t1 t2) t'
-> hideChannel ch (TPar (TRecv ch A t1) (TSend ch A t2)) t'.
Fixpoint shrink (t : type) : type :=
match t with
| TSend ch A t1 => TSend ch A (shrink t1)
| TRecv ch A t1 => TRecv ch A (shrink t1)
| TPar t1 t2 =>
let t1' := shrink t1 in
let t2' := shrink t2 in
match t1', t2' with
| TDone, _ => t2'
| _, TDone => t1'
| _, _ => TPar t1' t2'
end
| TDup t1 =>
let t1' := shrink t1 in
match t1' with
| TDone => TDone
| _ => TDup t1'
end
| TDone => TDone
| InternalChoice t1 t2 => InternalChoice (shrink t1) (shrink t2)
| ExternalChoice t1 t2 => ExternalChoice (shrink t1) (shrink t2)
end.
Inductive hasty : proc -> type -> Prop := Inductive hasty : proc -> type -> Prop :=
| HtNewChannel : forall notThese k t tc tcs,
(forall ch, ~In ch notThese -> hasty (k ch) (t ch))
-> (forall ch, ~In ch notThese -> hideChannel ch (t ch) tc)
-> shrink tc = tcs
-> hasty (NewChannel notThese k) tcs
| HtBlockChannel : forall ch pr t tc tcs,
hasty pr t
-> hideChannel ch t tc
-> shrink tc = tcs
-> hasty (BlockChannel ch pr) tcs
| HtSend : forall ch (A : Set) (v : A) k t, | HtSend : forall ch (A : Set) (v : A) k t,
hasty k t hasty k t
-> hasty (Send ch v k) (TSend ch A t) -> hasty (Send ch v k) (TSend ch A t)
| HtRecv : forall ch (A : Set) (k : A -> _) t, | HtRecv : forall ch (A : Set) (k : A -> _) t,
(forall v, hasty (k v) t) (forall v, hasty (k v) t)
-> hasty (Recv ch k) (TRecv ch A t) -> hasty (Recv ch k) (TRecv ch A t)
| HtPar : forall pr1 pr2 t1 t2,
hasty pr1 t1
-> hasty pr2 t2
-> hasty (Par pr1 pr2) (TPar t1 t2)
| HtDup : forall pr t,
hasty pr t
-> hasty (Dup pr) (TDup t)
| HtDone : | HtDone :
hasty Done TDone hasty Done TDone
@ -162,37 +56,10 @@ Definition addN (k : nat) (input output : channel) : proc :=
!!output(n + k); !!output(n + k);
Done. Done.
Ltac hasty := simplify; repeat (constructor; simplify).
Theorem addN_typed : forall k input output, Theorem addN_typed : forall k input output,
hasty (addN k input output) (???input(nat); !!!output(nat); TDone). hasty (addN k input output) (???input(nat); !!!output(nat); TDone).
Proof.
simplify.
repeat (constructor; simplify).
Qed.
Definition add2 (input output : channel) : proc :=
Dup (New[input;output](intermediate);
addN 1 input intermediate
|| addN 1 intermediate output).
Ltac hide1 := apply HideRendezvous1 || apply HideRendezvous2
|| (eapply HideIgnored; repeat constructor; equality)
|| (eapply HideExtSend1; [ equality | repeat constructor; equality | ])
|| (eapply HideExtRecv1; [ equality | repeat constructor; equality | ])
|| (eapply HideExtSend2; [ equality | repeat constructor; equality | ])
|| (eapply HideExtRecv2; [ equality | repeat constructor; equality | ]).
Ltac hide := repeat hide1.
Ltac hasty1 :=
match goal with
| [ |- hasty _ _ ] => econstructor; simplify
end.
Ltac hasty := simplify; repeat hasty1; simplify; hide; try equality.
Theorem add2_typed : forall input output,
input <> output
-> hasty (add2 input output) (TDup (???input(nat); !!!output(nat); TDone)).
Proof. Proof.
hasty. hasty.
Qed. Qed.
@ -204,8 +71,6 @@ Fixpoint complement (t : type) : type :=
match t with match t with
| TSend ch A t1 => TRecv ch A (complement t1) | TSend ch A t1 => TRecv ch A (complement t1)
| TRecv ch A t1 => TSend ch A (complement t1) | TRecv ch A t1 => TSend ch A (complement t1)
| TPar t1 t2 => TPar (complement t1) (complement t2)
| TDup t1 => TDup (complement t1)
| TDone => TDone | TDone => TDone
| InternalChoice t1 t2 => ExternalChoice (complement t1) (complement t2) | InternalChoice t1 t2 => ExternalChoice (complement t1) (complement t2)
@ -213,13 +78,126 @@ Fixpoint complement (t : type) : type :=
end. end.
Definition add2_client (input output : channel) : proc := Definition add2_client (input output : channel) : proc :=
Dup (!!input(42); !!input(42);
??output(_ : nat); ??output(_ : nat);
Done). Done.
Theorem add2_client_typed : forall input output, Theorem add2_client_typed : forall input output,
input <> output input <> output
-> hasty (add2_client input output) (complement (TDup (???input(nat); !!!output(nat); TDone))). -> hasty (add2_client input output) (complement (???input(nat); !!!output(nat); TDone)).
Proof. Proof.
hasty. hasty.
Qed. Qed.
(** * Parallel execution preserves the existence of complementary session types. *)
Definition trsys_of pr := {|
Initial := {pr};
Step := lstepSilent
|}.
(* Note: here we force silent steps, so that all channel communication is
* internal. *)
Hint Constructors hasty.
Lemma hasty_not_NewChannel : forall chs pr t,
hasty (NewChannel chs pr) t
-> False.
Proof.
induct 1; auto.
Qed.
Lemma hasty_not_BlockChannel : forall ch pr t,
hasty (BlockChannel ch pr) t
-> False.
Proof.
induct 1; auto.
Qed.
Lemma hasty_not_Dup : forall pr t,
hasty (Dup pr) t
-> False.
Proof.
induct 1; auto.
Qed.
Lemma hasty_not_Par : forall pr1 pr2 t,
hasty (pr1 || pr2) t
-> False.
Proof.
induct 1; auto.
Qed.
Hint Immediate hasty_not_NewChannel hasty_not_BlockChannel hasty_not_Dup hasty_not_Par.
Lemma input_typed : forall pr ch A v pr',
lstep pr (Input {| Channel := ch; TypeOf := A; Value := v |}) pr'
-> forall t, hasty pr t
-> exists k, pr = Recv ch k /\ pr' = k v.
Proof.
induct 1; simplify; try solve [ exfalso; eauto ].
induct H; eauto.
Qed.
Lemma output_typed : forall pr ch A v pr',
lstep pr (Output {| Channel := ch; TypeOf := A; Value := v |}) pr'
-> forall t, hasty pr t
-> exists k, pr = Send ch v k /\ pr' = k.
Proof.
induct 1; simplify; try solve [ exfalso; eauto ].
induct H; eauto.
Qed.
Lemma complementarity_rendezvous : forall ch (A : Set) (k1 : A -> _) t,
hasty (Recv ch k1) t
-> forall (v : A) k2, hasty (Send ch v k2) (complement t)
-> exists t', hasty (k1 v) t' /\ hasty k2 (complement t').
Proof.
induct 1; invert 1; simplify; eauto.
Qed.
Lemma complement_inverse : forall t,
t = complement (complement t).
Proof.
induct t; simplify; equality.
Qed.
Lemma complementarity_forever : forall pr1 pr2 t,
hasty pr1 t
-> hasty pr2 (complement t)
-> invariantFor (trsys_of (pr1 || pr2))
(fun pr => exists pr1' pr2' t',
pr = pr1' || pr2'
/\ hasty pr1' t'
/\ hasty pr2' (complement t')).
Proof.
simplify.
apply invariant_induction; simplify.
propositional; subst.
eauto 6.
clear pr1 pr2 t H H0.
first_order; subst.
invert H2.
invert H6; try solve [ exfalso; eauto ].
invert H6; try solve [ exfalso; eauto ].
eapply input_typed in H4; eauto.
eapply output_typed in H5; eauto.
first_order; subst.
eapply complementarity_rendezvous in H0; eauto.
first_order.
eapply input_typed in H5; eauto.
eapply output_typed in H4; eauto.
first_order; subst.
rewrite complement_inverse in H0.
eapply complementarity_rendezvous in H1; eauto.
first_order.
rewrite complement_inverse in H.
first_order.
Qed.