Commit 66f99021 authored by Ralf Jung's avatar Ralf Jung

add basic notions of literals, unary operators and binary operators, and use...

add basic notions of literals, unary operators and binary operators, and use them to define +, -, <=, ...
parent eb82a9c7
...@@ -6,18 +6,24 @@ Module heap_lang. ...@@ -6,18 +6,24 @@ Module heap_lang.
(** Expressions and vals. *) (** Expressions and vals. *)
Definition loc := positive. (* Really, any countable type. *) Definition loc := positive. (* Really, any countable type. *)
Inductive base_lit : Set :=
| LitNat (n : nat) | LitBool (b : bool) | LitUnit.
Inductive un_op : Set :=
| NegOp.
Inductive bin_op : Set :=
| PlusOp | MinusOp | LeOp | LtOp | EqOp.
Inductive expr := Inductive expr :=
(* Base lambda calculus *) (* Base lambda calculus *)
| Var (x : var) | Var (x : var)
| Rec (e : {bind 2 of expr}) (* These are recursive lambdas. | Rec (e : {bind 2 of expr}) (* These are recursive lambdas.
The *inner* binder is the recursive call! *) The *inner* binder is the recursive call! *)
| App (e1 e2 : expr) | App (e1 e2 : expr)
(* Natural numbers *) (* Base types and their operations *)
| LitNat (n : nat) | Lit (l : base_lit)
| Plus (e1 e2 : expr) | UnOp (op : un_op) (e : expr)
| Le (e1 e2 : expr) | BinOp (op : bin_op) (e1 e2 : expr)
(* Unit *) | If (e0 e1 e2 : expr)
| LitUnit
(* Products *) (* Products *)
| Pair (e1 e2 : expr) | Pair (e1 e2 : expr)
| Fst (e : expr) | Fst (e : expr)
...@@ -40,29 +46,19 @@ Instance Rename_expr : Rename expr. derive. Defined. ...@@ -40,29 +46,19 @@ Instance Rename_expr : Rename expr. derive. Defined.
Instance Subst_expr : Subst expr. derive. Defined. Instance Subst_expr : Subst expr. derive. Defined.
Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed. Instance SubstLemmas_expr : SubstLemmas expr. derive. Qed.
(* This sugar is used by primitive reduction riles (<=, CAS) and hence
defined here. *)
Notation LitTrue := (InjL LitUnit).
Notation LitFalse := (InjR LitUnit).
Inductive val := Inductive val :=
| RecV (e : {bind 2 of expr}) (* These are recursive lambdas. | RecV (e : {bind 2 of expr}) (* These are recursive lambdas.
The *inner* binder is the recursive call! *) The *inner* binder is the recursive call! *)
| LitNatV (n : nat) | LitV (l : base_lit)
| LitUnitV
| PairV (v1 v2 : val) | PairV (v1 v2 : val)
| InjLV (v : val) | InjLV (v : val)
| InjRV (v : val) | InjRV (v : val)
| LocV (l : loc). | LocV (l : loc).
Definition LitTrueV := InjLV LitUnitV.
Definition LitFalseV := InjRV LitUnitV.
Fixpoint of_val (v : val) : expr := Fixpoint of_val (v : val) : expr :=
match v with match v with
| RecV e => Rec e | RecV e => Rec e
| LitNatV n => LitNat n | LitV l => Lit l
| LitUnitV => LitUnit
| PairV v1 v2 => Pair (of_val v1) (of_val v2) | PairV v1 v2 => Pair (of_val v1) (of_val v2)
| InjLV v => InjL (of_val v) | InjLV v => InjL (of_val v)
| InjRV v => InjR (of_val v) | InjRV v => InjR (of_val v)
...@@ -71,8 +67,7 @@ Fixpoint of_val (v : val) : expr := ...@@ -71,8 +67,7 @@ Fixpoint of_val (v : val) : expr :=
Fixpoint to_val (e : expr) : option val := Fixpoint to_val (e : expr) : option val :=
match e with match e with
| Rec e => Some (RecV e) | Rec e => Some (RecV e)
| LitNat n => Some (LitNatV n) | Lit l => Some (LitV l)
| LitUnit => Some LitUnitV
| Pair e1 e2 => v1 to_val e1; v2 to_val e2; Some (PairV v1 v2) | Pair e1 e2 => v1 to_val e1; v2 to_val e2; Some (PairV v1 v2)
| InjL e => InjLV <$> to_val e | InjL e => InjLV <$> to_val e
| InjR e => InjRV <$> to_val e | InjR e => InjRV <$> to_val e
...@@ -87,10 +82,10 @@ Definition state := gmap loc val. ...@@ -87,10 +82,10 @@ Definition state := gmap loc val.
Inductive ectx_item := Inductive ectx_item :=
| AppLCtx (e2 : expr) | AppLCtx (e2 : expr)
| AppRCtx (v1 : val) | AppRCtx (v1 : val)
| PlusLCtx (e2 : expr) | UnOpCtx (op : un_op)
| PlusRCtx (v1 : val) | BinOpLCtx (op : bin_op) (e2 : expr)
| LeLCtx (e2 : expr) | BinOpRCtx (op : bin_op) (v1 : val)
| LeRCtx (v1 : val) | IfCtx (e1 e2 : expr)
| PairLCtx (e2 : expr) | PairLCtx (e2 : expr)
| PairRCtx (v1 : val) | PairRCtx (v1 : val)
| FstCtx | FstCtx
...@@ -112,10 +107,10 @@ Definition fill_item (Ki : ectx_item) (e : expr) : expr := ...@@ -112,10 +107,10 @@ Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
match Ki with match Ki with
| AppLCtx e2 => App e e2 | AppLCtx e2 => App e e2
| AppRCtx v1 => App (of_val v1) e | AppRCtx v1 => App (of_val v1) e
| PlusLCtx e2 => Plus e e2 | UnOpCtx op => UnOp op e
| PlusRCtx v1 => Plus (of_val v1) e | BinOpLCtx op e2 => BinOp op e e2
| LeLCtx e2 => Le e e2 | BinOpRCtx op v1 => BinOp op (of_val v1) e
| LeRCtx v1 => Le (of_val v1) e | IfCtx e1 e2 => If e e1 e2
| PairLCtx e2 => Pair e e2 | PairLCtx e2 => Pair e e2
| PairRCtx v1 => Pair (of_val v1) e | PairRCtx v1 => Pair (of_val v1) e
| FstCtx => Fst e | FstCtx => Fst e
...@@ -134,18 +129,43 @@ Definition fill_item (Ki : ectx_item) (e : expr) : expr := ...@@ -134,18 +129,43 @@ Definition fill_item (Ki : ectx_item) (e : expr) : expr :=
Definition fill (K : ectx) (e : expr) : expr := fold_right fill_item e K. Definition fill (K : ectx) (e : expr) : expr := fold_right fill_item e K.
(** The stepping relation *) (** The stepping relation *)
Definition un_op_eval (op : un_op) (l : base_lit) : option base_lit :=
match op, l with
| NegOp, LitBool b => Some $ LitBool (negb b)
| _, _ => None
end.
(* FIXME RJ I am *sure* this already exists somewhere... but I can't find it. *)
Definition sum2bool {A B} (x : { A } + { B }) : bool :=
match x with
| left _ => true
| right _ => false
end.
Definition bin_op_eval (op : bin_op) (l1 l2 : base_lit) : option base_lit :=
match op, l1, l2 with
| PlusOp, LitNat n1, LitNat n2 => Some $ LitNat (n1 + n2)
| MinusOp, LitNat n1, LitNat n2 => Some $ LitNat (n1 - n2)
| LeOp, LitNat n1, LitNat n2 => Some $ LitBool $ sum2bool $ decide (n1 n2)
| LtOp, LitNat n1, LitNat n2 => Some $ LitBool $ sum2bool $ decide (n1 < n2)
| EqOp, LitNat n1, LitNat n2 => Some $ LitBool $ sum2bool $ decide (n1 = n2)
| _, _, _ => None
end.
Inductive head_step : expr -> state -> expr -> state -> option expr -> Prop := Inductive head_step : expr -> state -> expr -> state -> option expr -> Prop :=
| BetaS e1 e2 v2 σ : | BetaS e1 e2 v2 σ :
to_val e2 = Some v2 to_val e2 = Some v2
head_step (App (Rec e1) e2) σ e1.[(Rec e1),e2/] σ None head_step (App (Rec e1) e2) σ e1.[(Rec e1),e2/] σ None
| PlusS n1 n2 σ: | UnOpS op l l' σ:
head_step (Plus (LitNat n1) (LitNat n2)) σ (LitNat (n1 + n2)) σ None un_op_eval op l = Some l'
| LeTrueS n1 n2 σ : head_step (UnOp op (Lit l)) σ (Lit l') σ None
n1 n2 | BinOpS op l1 l2 l' σ:
head_step (Le (LitNat n1) (LitNat n2)) σ LitTrue σ None bin_op_eval op l1 l2 = Some l'
| LeFalseS n1 n2 σ : head_step (BinOp op (Lit l1) (Lit l2)) σ (Lit l') σ None
n1 > n2 | IfTrueS e1 e2 σ :
head_step (Le (LitNat n1) (LitNat n2)) σ LitFalse σ None head_step (If (Lit $ LitBool true) e1 e2) σ e1 σ None
| IfFalseS e1 e2 σ :
head_step (If (Lit $ LitBool false) e1 e2) σ e2 σ None
| FstS e1 v1 e2 v2 σ : | FstS e1 v1 e2 v2 σ :
to_val e1 = Some v1 to_val e2 = Some v2 to_val e1 = Some v1 to_val e2 = Some v2
head_step (Fst (Pair e1 e2)) σ e1 σ None head_step (Fst (Pair e1 e2)) σ e1 σ None
...@@ -159,7 +179,7 @@ Inductive head_step : expr -> state -> expr -> state -> option expr -> Prop := ...@@ -159,7 +179,7 @@ Inductive head_step : expr -> state -> expr -> state -> option expr -> Prop :=
to_val e0 = Some v0 to_val e0 = Some v0
head_step (Case (InjR e0) e1 e2) σ e2.[e0/] σ None head_step (Case (InjR e0) e1 e2) σ e2.[e0/] σ None
| ForkS e σ: | ForkS e σ:
head_step (Fork e) σ LitUnit σ (Some e) head_step (Fork e) σ (Lit LitUnit) σ (Some e)
| AllocS e v σ l : | AllocS e v σ l :
to_val e = Some v σ !! l = None to_val e = Some v σ !! l = None
head_step (Alloc e) σ (Loc l) (<[l:=v]>σ) None head_step (Alloc e) σ (Loc l) (<[l:=v]>σ) None
...@@ -168,15 +188,15 @@ Inductive head_step : expr -> state -> expr -> state -> option expr -> Prop := ...@@ -168,15 +188,15 @@ Inductive head_step : expr -> state -> expr -> state -> option expr -> Prop :=
head_step (Load (Loc l)) σ (of_val v) σ None head_step (Load (Loc l)) σ (of_val v) σ None
| StoreS l e v σ : | StoreS l e v σ :
to_val e = Some v is_Some (σ !! l) to_val e = Some v is_Some (σ !! l)
head_step (Store (Loc l) e) σ LitUnit (<[l:=v]>σ) None head_step (Store (Loc l) e) σ (Lit LitUnit) (<[l:=v]>σ) None
| CasFailS l e1 v1 e2 v2 vl σ : | CasFailS l e1 v1 e2 v2 vl σ :
to_val e1 = Some v1 to_val e2 = Some v2 to_val e1 = Some v1 to_val e2 = Some v2
σ !! l = Some vl vl v1 σ !! l = Some vl vl v1
head_step (Cas (Loc l) e1 e2) σ LitFalse σ None head_step (Cas (Loc l) e1 e2) σ (Lit $ LitBool false) σ None
| CasSucS l e1 v1 e2 v2 σ : | CasSucS l e1 v1 e2 v2 σ :
to_val e1 = Some v1 to_val e2 = Some v2 to_val e1 = Some v1 to_val e2 = Some v2
σ !! l = Some v1 σ !! l = Some v1
head_step (Cas (Loc l) e1 e2) σ LitTrue (<[l:=v2]>σ) None. head_step (Cas (Loc l) e1 e2) σ (Lit $ LitBool true) (<[l:=v2]>σ) None.
(** Atomic expressions *) (** Atomic expressions *)
Definition atomic (e: expr) := Definition atomic (e: expr) :=
...@@ -263,7 +283,7 @@ Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 : ...@@ -263,7 +283,7 @@ Lemma fill_item_no_val_inj Ki1 Ki2 e1 e2 :
fill_item Ki1 e1 = fill_item Ki2 e2 Ki1 = Ki2. fill_item Ki1 e1 = fill_item Ki2 e2 Ki1 = Ki2.
Proof. Proof.
destruct Ki1, Ki2; intros; try discriminate; simplify_equality'; destruct Ki1, Ki2; intros; try discriminate; simplify_equality';
try match goal with repeat match goal with
| H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H | H : to_val (of_val _) = None |- _ => by rewrite to_of_val in H
end; auto. end; auto.
Qed. Qed.
......
...@@ -38,14 +38,13 @@ Ltac reshape_expr e tac := ...@@ -38,14 +38,13 @@ Ltac reshape_expr e tac :=
lazymatch e1 with lazymatch e1 with
| of_val ?v1 => go (AppRCtx v1 :: K) e2 | _ => go (AppLCtx e2 :: K) e1 | of_val ?v1 => go (AppRCtx v1 :: K) e2 | _ => go (AppLCtx e2 :: K) e1
end end
| Plus ?e1 ?e2 => | UnOp ?op ?e =>
go (UnOpCtx op :: K) e
| BinOp ?op ?e1 ?e2 =>
lazymatch e1 with lazymatch e1 with
| of_val ?v1 => go (PlusRCtx v1 :: K) e2 | _ => go (PlusLCtx e2 :: K) e1 | of_val ?v1 => go (BinOpRCtx op v1 :: K) e2 | _ => go (BinOpLCtx op e2 :: K) e1
end
| Le ?e1 ?e2 =>
lazymatch e1 with
| of_val ?v1 => go (LeRCtx v1 :: K) e2 | _ => go (LeLCtx e2 :: K) e1
end end
| If ?e0 ?e1 ?e2 => go (IfCtx e1 e2 :: K) e0
| Pair ?e1 ?e2 => | Pair ?e1 ?e2 =>
lazymatch e1 with lazymatch e1 with
| of_val ?v1 => go (PairRCtx v1 :: K) e2 | _ => go (PairLCtx e2 :: K) e1 | of_val ?v1 => go (PairRCtx v1 :: K) e2 | _ => go (PairLCtx e2 :: K) e1
......
...@@ -48,36 +48,36 @@ Qed. ...@@ -48,36 +48,36 @@ Qed.
Lemma wp_store_pst E σ l e v v' Q : Lemma wp_store_pst E σ l e v v' Q :
to_val e = Some v σ !! l = Some v' to_val e = Some v σ !! l = Some v'
(ownP σ (ownP (<[l:=v]>σ) - Q LitUnitV)) wp E (Store (Loc l) e) Q. (ownP σ (ownP (<[l:=v]>σ) - Q $ LitV LitUnit)) wp E (Store (Loc l) e) Q.
Proof. Proof.
intros. rewrite -(wp_lift_atomic_det_step σ LitUnitV (<[l:=v]>σ) None) intros. rewrite -(wp_lift_atomic_det_step σ (LitV LitUnit) (<[l:=v]>σ) None)
?right_id //; last by intros; inv_step; eauto. ?right_id //; last by intros; inv_step; eauto.
Qed. Qed.
Lemma wp_cas_fail_pst E σ l e1 v1 e2 v2 v' Q : Lemma wp_cas_fail_pst E σ l e1 v1 e2 v2 v' Q :
to_val e1 = Some v1 to_val e2 = Some v2 σ !! l = Some v' v' v1 to_val e1 = Some v1 to_val e2 = Some v2 σ !! l = Some v' v' v1
(ownP σ (ownP σ - Q LitFalseV)) wp E (Cas (Loc l) e1 e2) Q. (ownP σ (ownP σ - Q $ LitV $ LitBool false)) wp E (Cas (Loc l) e1 e2) Q.
Proof. Proof.
intros. rewrite -(wp_lift_atomic_det_step σ LitFalseV σ None) ?right_id //; intros. rewrite -(wp_lift_atomic_det_step σ (LitV $ LitBool false) σ None) ?right_id //;
last by intros; inv_step; eauto. last by intros; inv_step; eauto.
Qed. Qed.
Lemma wp_cas_suc_pst E σ l e1 v1 e2 v2 Q : Lemma wp_cas_suc_pst E σ l e1 v1 e2 v2 Q :
to_val e1 = Some v1 to_val e2 = Some v2 σ !! l = Some v1 to_val e1 = Some v1 to_val e2 = Some v2 σ !! l = Some v1
(ownP σ (ownP (<[l:=v2]>σ) - Q LitTrueV)) wp E (Cas (Loc l) e1 e2) Q. (ownP σ (ownP (<[l:=v2]>σ) - Q $ LitV $ LitBool true)) wp E (Cas (Loc l) e1 e2) Q.
Proof. Proof.
intros. rewrite -(wp_lift_atomic_det_step σ LitTrueV (<[l:=v2]>σ) None) intros. rewrite -(wp_lift_atomic_det_step σ (LitV $ LitBool true) (<[l:=v2]>σ) None)
?right_id //; last by intros; inv_step; eauto. ?right_id //; last by intros; inv_step; eauto.
Qed. Qed.
(** Base axioms for core primitives of the language: Stateless reductions *) (** Base axioms for core primitives of the language: Stateless reductions *)
Lemma wp_fork E e : Lemma wp_fork E e :
wp (Σ:=Σ) coPset_all e (λ _, True) wp E (Fork e) (λ v, (v = LitUnitV)). wp (Σ:=Σ) coPset_all e (λ _, True) wp E (Fork e) (λ v, (v = LitV $ LitUnit)).
Proof. Proof.
rewrite -(wp_lift_pure_det_step (Fork e) LitUnit (Some e)) //=; rewrite -(wp_lift_pure_det_step (Fork e) (Lit LitUnit) (Some e)) //=;
last by intros; inv_step; eauto. last by intros; inv_step; eauto.
apply later_mono, sep_intro_True_l; last done. apply later_mono, sep_intro_True_l; last done.
by rewrite -(wp_value' _ _ LitUnit) //; apply const_intro. by rewrite -(wp_value' _ _ (Lit _)) //; apply const_intro.
Qed. Qed.
Lemma wp_rec E erec e v Q : Lemma wp_rec E erec e v Q :
...@@ -88,30 +88,36 @@ Proof. ...@@ -88,30 +88,36 @@ Proof.
?right_id //=; last by intros; inv_step; eauto. ?right_id //=; last by intros; inv_step; eauto.
Qed. Qed.
Lemma wp_plus E n1 n2 Q : Lemma wp_un_op E op l l' Q :
Q (LitNatV (n1 + n2)) wp E (Plus (LitNat n1) (LitNat n2)) Q. un_op_eval op l = Some l'
Q (LitV l') wp E (UnOp op (Lit l)) Q.
Proof. Proof.
rewrite -(wp_lift_pure_det_step (Plus _ _) (LitNat (n1 + n2)) None) intros Heval. rewrite -(wp_lift_pure_det_step (UnOp op _) (Lit l') None)
?right_id //; last by intros; inv_step; eauto. ?right_id //; last by intros; inv_step; eauto.
by rewrite -wp_value'. by rewrite -wp_value'.
Qed. Qed.
Lemma wp_le_true E n1 n2 Q : Lemma wp_bin_op E op l1 l2 l' Q :
n1 n2 bin_op_eval op l1 l2 = Some l'
Q LitTrueV wp E (Le (LitNat n1) (LitNat n2)) Q. Q (LitV l') wp E (BinOp op (Lit l1) (Lit l2)) Q.
Proof. Proof.
intros. rewrite -(wp_lift_pure_det_step (Le _ _) LitTrue None) ?right_id //; intros Heval. rewrite -(wp_lift_pure_det_step (BinOp op _ _) (Lit l') None)
last by intros; inv_step; eauto with omega. ?right_id //; last by intros; inv_step; eauto.
by rewrite -wp_value'. by rewrite -wp_value'.
Qed. Qed.
Lemma wp_le_false E n1 n2 Q : Lemma wp_if_true E e1 e2 Q :
n1 > n2 wp E e1 Q wp E (If (Lit $ LitBool true) e1 e2) Q.
Q LitFalseV wp E (Le (LitNat n1) (LitNat n2)) Q.
Proof. Proof.
intros. rewrite -(wp_lift_pure_det_step (Le _ _) LitFalse None) ?right_id //; rewrite -(wp_lift_pure_det_step (If _ _ _) e1 None)
last by intros; inv_step; eauto with omega. ?right_id //; last by intros; inv_step; eauto.
by rewrite -wp_value'. Qed.
Lemma wp_if_false E e1 e2 Q :
wp E e2 Q wp E (If (Lit $ LitBool false) e1 e2) Q.
Proof.
rewrite -(wp_lift_pure_det_step (If _ _ _) e2 None)
?right_id //; last by intros; inv_step; eauto.
Qed. Qed.
Lemma wp_fst E e1 v1 e2 v2 Q : Lemma wp_fst E e1 v1 e2 v2 Q :
...@@ -148,15 +154,4 @@ Proof. ...@@ -148,15 +154,4 @@ Proof.
?right_id //; last by intros; inv_step; eauto. ?right_id //; last by intros; inv_step; eauto.
Qed. Qed.
(** Some derived stateless axioms *)
Lemma wp_le E n1 n2 P Q :
(n1 n2 P Q LitTrueV)
(n1 > n2 P Q LitFalseV)
P wp E (Le (LitNat n1) (LitNat n2)) Q.
Proof.
intros; destruct (decide (n1 n2)).
* rewrite -wp_le_true; auto.
* rewrite -wp_le_false; auto with omega.
Qed.
End lifting. End lifting.
...@@ -5,11 +5,6 @@ Import uPred heap_lang. ...@@ -5,11 +5,6 @@ Import uPred heap_lang.
Definition Lam (e : {bind expr}) := Rec e.[ren(+1)]. Definition Lam (e : {bind expr}) := Rec e.[ren(+1)].
Definition Let (e1 : expr) (e2: {bind expr}) := App (Lam e2) e1. Definition Let (e1 : expr) (e2: {bind expr}) := App (Lam e2) e1.
Definition Seq (e1 e2 : expr) := Let e1 e2.[ren(+1)]. Definition Seq (e1 e2 : expr) := Let e1 e2.[ren(+1)].
Definition If (e0 e1 e2 : expr) := Case e0 e1.[ren(+1)] e2.[ren(+1)].
Definition Lt e1 e2 := Le (Plus e1 $ LitNat 1) e2.
Definition Eq e1 e2 :=
Let e1 (Let e2.[ren(+1)]
(If (Le (Var 0) (Var 1)) (Le (Var 1) (Var 0)) LitFalse)).
Definition LamV (e : {bind expr}) := RecV e.[ren(+1)]. Definition LamV (e : {bind expr}) := RecV e.[ren(+1)].
...@@ -21,8 +16,10 @@ Module notations. ...@@ -21,8 +16,10 @@ Module notations.
Bind Scope lang_scope with expr. Bind Scope lang_scope with expr.
Arguments wp {_ _} _ _%L _. Arguments wp {_ _} _ _%L _.
Coercion LitNat : nat >-> expr. Coercion LitNat : nat >-> base_lit.
Coercion LitNatV : nat >-> val. Coercion LitBool : bool >-> base_lit.
(* No coercion from base_lit to expr. This makes is slightly easier to tell
apart language and Coq expressions. *)
Coercion Loc : loc >-> expr. Coercion Loc : loc >-> expr.
Coercion LocV : loc >-> val. Coercion LocV : loc >-> val.
Coercion App : expr >-> Funclass. Coercion App : expr >-> Funclass.
...@@ -35,10 +32,13 @@ Module notations. ...@@ -35,10 +32,13 @@ Module notations.
Notation "# n" := (Var n) (at level 1, format "# n") : lang_scope. Notation "# n" := (Var n) (at level 1, format "# n") : lang_scope.
Notation "! e" := (Load e%L) (at level 10, format "! e") : lang_scope. Notation "! e" := (Load e%L) (at level 10, format "! e") : lang_scope.
Notation "'ref' e" := (Alloc e%L) (at level 30) : lang_scope. Notation "'ref' e" := (Alloc e%L) (at level 30) : lang_scope.
Notation "e1 + e2" := (Plus e1%L e2%L) Notation "e1 + e2" := (BinOp PlusOp e1%L e2%L)
(at level 50, left associativity) : lang_scope. (at level 50, left associativity) : lang_scope.
Notation "e1 ≤ e2" := (Le e1%L e2%L) (at level 70) : lang_scope. Notation "e1 - e2" := (BinOp MinusOp e1%L e2%L)
Notation "e1 < e2" := (Lt e1%L e2%L) (at level 70) : lang_scope. (at level 50, left associativity) : lang_scope.
Notation "e1 ≤ e2" := (BinOp LeOp e1%L e2%L) (at level 70) : lang_scope.
Notation "e1 < e2" := (BinOp LtOp e1%L e2%L) (at level 70) : lang_scope.
Notation "e1 = e2" := (BinOp EqOp e1%L e2%L) (at level 70) : lang_scope.
(* The unicode ← is already part of the notation "_ ← _; _" for bind. *) (* The unicode ← is already part of the notation "_ ← _; _" for bind. *)
Notation "e1 <- e2" := (Store e1%L e2%L) (at level 80) : lang_scope. Notation "e1 <- e2" := (Store e1%L e2%L) (at level 80) : lang_scope.
Notation "e1 ; e2" := (Seq e1%L e2%L) (at level 100) : lang_scope. Notation "e1 ; e2" := (Seq e1%L e2%L) (at level 100) : lang_scope.
...@@ -46,7 +46,7 @@ Module notations. ...@@ -46,7 +46,7 @@ Module notations.
Notation "'λ:' e" := (Lam e%L) (at level 102) : lang_scope. Notation "'λ:' e" := (Lam e%L) (at level 102) : lang_scope.
Notation "'rec::' e" := (Rec e%L) (at level 102) : lang_scope. Notation "'rec::' e" := (Rec e%L) (at level 102) : lang_scope.
Notation "'if' e1 'then' e2 'else' e3" := (If e1%L e2%L e3%L) Notation "'if' e1 'then' e2 'else' e3" := (If e1%L e2%L e3%L)
(at level 200, e1, e2, e3 at level 200, only parsing) : lang_scope. (at level 200, e1, e2, e3 at level 200) : lang_scope.
End notations. End notations.
Section suger. Section suger.
...@@ -63,35 +63,39 @@ Proof. ...@@ -63,35 +63,39 @@ Proof.
to talk to the Autosubst guys. *) to talk to the Autosubst guys. *)
by asimpl. by asimpl.
Qed. Qed.
Lemma wp_let E e1 e2 Q : Lemma wp_let E e1 e2 Q :
wp E e1 (λ v, wp E (e2.[of_val v/]) Q) wp E (Let e1 e2) Q. wp E e1 (λ v, wp E (e2.[of_val v/]) Q) wp E (Let e1 e2) Q.
Proof. Proof.
rewrite -(wp_bind [LetCtx e2]). apply wp_mono=>v. rewrite -(wp_bind [LetCtx e2]). apply wp_mono=>v.
by rewrite -wp_lam //= to_of_val. by rewrite -wp_lam //= to_of_val.
Qed. Qed.
Lemma wp_if_true E e1 e2 Q : wp E e1 Q wp E (If LitTrue e1 e2) Q.
Proof. rewrite -wp_case_inl //. by asimpl. Qed. Lemma wp_le E (n1 n2 : nat) P Q :
Lemma wp_if_false E e1 e2 Q : wp E e2 Q wp E (If LitFalse e1 e2) Q. (n1 n2 P Q (LitV true))
Proof. rewrite -wp_case_inr //. by asimpl. Qed. (n1 > n2 P Q (LitV false))
Lemma wp_lt E n1 n2 P Q : P wp E (BinOp LeOp (Lit n1) (Lit n2)) Q.
(n1 < n2 P Q LitTrueV) Proof.
(n1 n2 P Q LitFalseV) intros ? ?. rewrite -wp_bin_op //; [].
P wp E (Lt (LitNat n1) (LitNat n2)) Q. destruct (decide _); by eauto with omega.
Qed.
Lemma wp_lt E (n1 n2 : nat) P Q :
(n1 < n2