Simplify stack programs

theories/logrel/F_mu_ref_conc/examples/lock.v

@@ -7,20 +7,26 @@ Definition newlock : expr := Alloc (#♭ false).
 Definition acquire : expr :=
   Rec (If (CAS (Var 1) (#♭ false) (#♭ true)) (Unit) (App (Var 0) (Var 1))).
 (** [release = λ x. x <- false] *)
-Definition release : expr := Rec (Store (Var 1) (#♭ false)).
+Definition release : expr := Lam (Store (Var 0) (#♭ false)).
 (** [with_lock e l = λ x. (acquire l) ;; e x ;; (release l)] *)
 Definition with_lock (e : expr) (l : expr) : expr :=
-  Rec
-    (App (Rec (App (Rec (App (Rec (Var 3)) (App release l.[ren (+6)])))
-                   (App e.[ren (+4)] (Var 3))))
-         (App acquire l.[ren (+2)])
+  Lam
+    (Seq
+       (App acquire l.[ren (+1)])
+       (LetIn
+          (App e.[ren (+1)] (Var 0))
+          (Seq (App release l.[ren (+2)]) (Var 0))
+       )
     ).
 
 Definition with_lockV (e l : expr) : val :=
-  RecV
-    (App (Rec (App (Rec (App (Rec (Var 3)) (App release l.[ren (+6)])))
-                   (App e.[ren (+4)] (Var 3))))
-         (App acquire l.[ren (+2)])
+  LamV
+    (Seq
+       (App acquire l.[ren (+1)])
+       (LetIn
+          (App e.[ren (+1)] (Var 0))
+          (Seq (App release l.[ren (+2)]) (Var 0))
+       )
     ).
 
 Lemma with_lock_to_val e l : to_val (with_lock e l) = Some (with_lockV e l).
@@ -29,6 +35,7 @@ Proof. trivial. Qed.
 Lemma with_lock_of_val e l : of_val (with_lockV e l) = with_lock e l.
 Proof. trivial. Qed.
 
+Global Typeclasses Opaque with_lockV.
 Global Opaque with_lockV.
 
 Lemma newlock_closed f : newlock.[f] = newlock.
@@ -43,15 +50,10 @@ Lemma release_closed f : release.[f] = release.
 Proof. by asimpl. Qed.
 Hint Rewrite release_closed : autosubst.
 
-Lemma with_lock_subst (e l : expr) f :  (with_lock e l).[f] = with_lock e.[f] l.[f].
+Lemma with_lock_subst (e l : expr) f :
+  (with_lock e l).[f] = with_lock e.[f] l.[f].
 Proof. unfold with_lock; asimpl; trivial. Qed.
 
-Lemma with_lock_closed e l:
-  (∀ f : var → expr, e.[f] = e) →
-  (∀ f : var → expr, l.[f] = l) →
-  ∀ f, (with_lock e l).[f] = with_lock e l.
-Proof. asimpl => H1 H2 f. unfold with_lock. by rewrite ?H1 ?H2. Qed.
-
 Definition LockType := Tref TBool.
 
 Lemma newlock_type Γ : typed Γ newlock LockType.
@@ -68,18 +70,20 @@ Lemma with_lock_type e l Γ τ τ' :
   typed Γ l LockType →
   typed Γ (with_lock e l) (TArrow τ τ').
 Proof.
-  intros H1 H2. do 3 econstructor; eauto.
-  - repeat (econstructor; eauto using release_type).
-    + eapply (context_weakening [_; _; _; _; _; _]); eauto.
-    + eapply (context_weakening [_; _; _; _]); eauto.
-  - eapply acquire_type.
-  - eapply (context_weakening [_; _]); eauto.
+  intros ??.
+  do 3 econstructor; eauto using acquire_type.
+  - eapply (context_weakening [_]); eauto.
+  - econstructor; eauto using typed.
+    eapply (context_weakening [_]); eauto.
+  - econstructor; eauto using typed.
+    econstructor; eauto using release_type.
+    eapply (context_weakening [_;_]); eauto.
 Qed.
 
 Section proof.
   Context `{cfgSG Σ}.
   Context `{heapIG Σ}.
-  
+
   Lemma steps_newlock E ρ j K :
     nclose specN ⊆ E →
     spec_ctx ρ ∗ j ⤇ fill K newlock
@@ -89,6 +93,7 @@ Section proof.
     by iMod (step_alloc _ _ j K with "[Hj]") as "Hj"; eauto.
   Qed.
 
+  Global Typeclasses Opaque newlock.
   Global Opaque newlock.
 
   Lemma steps_acquire E ρ j K l :
@@ -107,6 +112,7 @@ Section proof.
     Unshelve. all:trivial.
   Qed.
 
+  Global Typeclasses Opaque acquire.
   Global Opaque acquire.
 
   Lemma steps_release E ρ j K l b:
@@ -115,48 +121,45 @@ Section proof.
       ⊢ |={E}=> j ⤇ fill K Unit ∗ l ↦ₛ (#♭v false).
   Proof.
     iIntros (HNE) "[#Hspec [Hl Hj]]". unfold release.
-    iMod (step_rec _ _ j K with "[Hj]") as "Hj"; eauto; try done.
-    iMod (step_store _ _ j K _ _ _ _ _ with "[Hj Hl]") as "[Hj Hl]"; eauto.
-    { by iFrame. }
+    iMod (do_step_pure with "[$Hj]") as "Hj"; eauto; try done.
+    iMod (step_store with "[$Hj $Hl]") as "[Hj Hl]"; eauto.
     by iIntros "!> {$Hj $Hl}".
-    Unshelve. all: trivial.
   Qed.
 
+  Global Typeclasses Opaque release.
   Global Opaque release.
 
   Lemma steps_with_lock E ρ j K e l P Q v w:
     nclose specN ⊆ E →
-    (∀ f, e.[f] = e) (* e is a closed term *) →
+    (* (∀ f, e.[f] = e) (* e is a closed term *) → *)
     (∀ K', spec_ctx ρ ∗ P ∗ j ⤇ fill K' (App e (of_val w))
             ⊢ |={E}=> j ⤇ fill K' (of_val v) ∗ Q) →
     spec_ctx ρ ∗ P ∗ l ↦ₛ (#♭v false)
                 ∗ j ⤇ fill K (App (with_lock e (Loc l)) (of_val w))
       ⊢ |={E}=> j ⤇ fill K (of_val v) ∗ Q ∗ l ↦ₛ (#♭v false).
   Proof.
-    iIntros (HNE H1 H2) "[#Hspec [HP [Hl Hj]]]".
-    iMod (step_rec _ _ j K _ _ _ _ with "[Hj]") as "Hj"; eauto.
-    iAsimpl. rewrite H1.
-    iMod (steps_acquire _ _ j ((AppRCtx (RecV _)) :: K)
-                   _ _ with "[Hj Hl]") as "[Hj Hl]"; eauto.
-    { simpl. iFrame "Hspec Hj Hl"; eauto. }
-    simpl.
-    iMod (step_rec _ _ j K _ _ _ _ with "[Hj]") as "Hj"; eauto.
-    iAsimpl. rewrite H1.
-    iMod (H2 ((AppRCtx (RecV _)) :: K) with "[Hj HP]") as "[Hj HQ]"; eauto.
-    { simpl. iFrame "Hspec Hj HP"; eauto. }
+    iIntros (HNE He) "[#Hspec [HP [Hl Hj]]]".
+    iMod (do_step_pure with "[$Hj]") as "Hj"; eauto.
+    iAsimpl.
+    iMod (steps_acquire _ _ j (SeqCtx _ :: K) with "[$Hj Hl]") as "[Hj Hl]";
+      auto. simpl.
+    iMod (do_step_pure with "[$Hj]") as "Hj"; eauto.
+    iMod (He (LetInCtx _ :: K) with "[$Hj HP]") as "[Hj HQ]"; eauto.
     simpl.
-    iMod (step_rec _ _ j K _ _ _ _ with "[Hj]") as "Hj"; eauto.
+    iMod (do_step_pure with "[$Hj]") as "Hj"; eauto.
     iAsimpl.
-    iMod (steps_release _ _ j ((AppRCtx (RecV _)) :: K) _ _ with "[Hj Hl]")
+    iMod (steps_release _ _ j (SeqCtx _ :: K) _ _ with "[$Hj $Hl]")
       as "[Hj Hl]"; eauto.
-    { simpl. by iFrame. }
-    rewrite ?fill_app /=.
-    iMod (step_rec _ _ j K _ _ _ _ with "[Hj]") as "Hj"; eauto.
-    iAsimpl. iModIntro; by iFrame.
-    Unshelve.
-    all: try match goal with |- to_val _ = _ => auto using to_of_val end.
-    trivial.
+    simpl.
+    iMod (do_step_pure with "[$Hj]") as "Hj"; eauto.
+    iModIntro; by iFrame.
   Qed.
 
+  Global Typeclasses Opaque with_lock.
   Global Opaque with_lock.
 End proof.
+
+Global Hint Rewrite newlock_closed : autosubst.
+Global Hint Rewrite acquire_closed : autosubst.
+Global Hint Rewrite release_closed : autosubst.
+Global Hint Rewrite with_lock_subst : autosubst.

theories/logrel/F_mu_ref_conc/examples/stack/FG_stack.v

-From iris_examples.logrel.F_mu_ref_conc Require Import  typing.
+From iris_examples.logrel.F_mu_ref_conc Require Import typing.
 
 Definition FG_StackType τ :=
   TRec (Tref (TSum TUnit (TProd τ.[ren (+1)] (TVar 0)))).
@@ -7,103 +7,99 @@ Definition FG_Stack_Ref_Type τ :=
   Tref (TSum TUnit (TProd τ (FG_StackType τ))).
 
 Definition FG_push (st : expr) : expr :=
-  Rec (App (Rec
-              (* try push *)
-              (If (CAS (st.[ren (+4)]) (Var 1)
-                       (Alloc (InjR (Pair (Var 3) (Fold (Var 1)))))
-                  )
-                  Unit (* push succeeds we return unit *)
-                  (App (Var 2) (Var 3)) (* push fails, we try again *)
-              )
+  Rec
+    (LetIn
+       (Load st.[ren (+2)])
+       (* try push *)
+       (If (CAS (st.[ren (+3)]) (Var 0)
+                (Alloc (InjR (Pair (Var 2) (Fold (Var 0)))))
            )
-           (Load st.[ren (+2)]) (* read the stack pointer *)
-      ).
+           Unit (* push succeeds we return unit *)
+           (App (Var 1) (Var 2)) (* push fails, we try again *)
+       )
+    ).
+
 Definition FG_pushV (st : expr) : val :=
-  RecV (App (Rec
-              (* try push *)
-              (If (CAS (st.[ren (+4)]) (Var 1)
-                       (Alloc (InjR (Pair (Var 3) (Fold (Var 1)))))
-                  )
-                  Unit (* push succeeds we return unit *)
-                  (App (Var 2) (Var 3)) (* push fails, we try again *)
-              )
+  RecV
+    (LetIn
+       (Load st.[ren (+2)])
+       (* try push *)
+       (If (CAS (st.[ren (+3)]) (Var 0)
+                (Alloc (InjR (Pair (Var 2) (Fold (Var 0)))))
            )
-           (Load st.[ren (+2)]) (* read the stack pointer *)
-       ).
+           Unit (* push succeeds we return unit *)
+           (App (Var 1) (Var 2)) (* push fails, we try again *)
+       )
+    ).
 
 Definition FG_pop (st : expr) : expr :=
-  Rec (App (Rec
-              (App
-                 (Rec
-                    (
-                      Case (Var 1)
-                           (InjL Unit)
-                           ( (* try popping *)
-                             If
-                               (CAS
-                                  (st.[ren (+7)])
-                                  (Var 4)
-                                  (Unfold (Snd (Var 0)))
-                               )
-                               (InjR (Fst (Var 0))) (* pop succeeds *)
-                               (App (Var 5) (Var 6)) (* pop fails, we retry*)
-                           )
-                     )
-                 )
-                 (
-                   (Load (Var 1))
+  Rec
+    (LetIn
+       (Load st.[ren (+ 2)])
+       (LetIn
+          (Load (Var 0))
+          (Case
+             (Var 0)
+             (InjL Unit)
+             ( (* try popping *)
+               If
+                 (CAS
+                    (st.[ren (+5)])
+                    (Var 2)
+                    (Unfold (Snd (Var 0)))
                  )
-              )
-           )
-           (Load st.[ren (+ 2)])
-      ).
+                 (InjR (Fst (Var 0))) (* pop succeeds *)
+                 (App (Var 3) (Var 4)) (* pop fails, we retry*)
+             )
+          )
+       )
+    ).
+
 Definition FG_popV (st : expr) : val :=
   RecV
-    (App
-       (Rec
-          ( App
-              (Rec
-                 (
-                   Case (Var 1)
-                        (InjL Unit)
-                        ( (* try popping *)
-                          If
-                            (CAS
-                               (st.[ren (+7)])
-                               (Var 4)
-                               (Unfold (Snd (Var 0)))
-                            )
-                            (InjR (Fst (Var 0))) (* pop succeeds *)
-                            (App (Var 5) (Var 6)) (* pop fails, we retry*)
-                        )
+    (LetIn
+       (Load st.[ren (+ 2)])
+       (LetIn
+          (Load (Var 0))
+          (Case
+             (Var 0)
+             (InjL Unit)
+             ( (* try popping *)
+               If
+                 (CAS
+                    (st.[ren (+5)])
+                    (Var 2)
+                    (Unfold (Snd (Var 0)))
                  )
-              )
-              (
-                (Load (Var 1))
-              )
+                 (InjR (Fst (Var 0))) (* pop succeeds *)
+                 (App (Var 3) (Var 4)) (* pop fails, we retry*)
+             )
           )
        )
-       (Load st.[ren (+ 2)])
     ).
 
 Definition FG_iter (f : expr) : expr :=
   Rec
     (Case (Load (Unfold (Var 1)))
           Unit
-          (App (Rec (App (Var 3) (Snd (Var 2)))) (* recursive_call *)
-               (App f.[ren (+3)] (Fst (Var 0)))
+          (Seq
+             (App f.[ren (+3)] (Fst (Var 0)))
+             (App (Var 1) (Snd (Var 0))) (* recursive_call *)
           )
     ).
+
 Definition FG_iterV (f : expr) : val :=
   RecV
     (Case (Load (Unfold (Var 1)))
           Unit
-          (App (Rec (App (Var 3) (Snd (Var 2)))) (* recursive_call *)
-               (App f.[ren (+3)] (Fst (Var 0)))
+          (Seq
+             (App f.[ren (+3)] (Fst (Var 0)))
+             (App (Var 1) (Snd (Var 0))) (* recursive_call *)
           )
     ).
+
 Definition FG_read_iter (st : expr) : expr :=
-  Rec (App (FG_iter (Var 1)) (Fold (Load st.[ren (+2)]))).
+  Lam (App (FG_iter (Var 0)) (Fold (Load st.[ren (+1)]))).
 
 Definition FG_stack_body (st : expr) : expr :=
   Pair (Pair (FG_push st) (FG_pop st)) (FG_read_iter st).
@@ -116,34 +112,19 @@ Section FG_stack.
   (* Fine-grained push *)
   Lemma FG_push_folding (st : expr) :
     FG_push st =
-    Rec (App (Rec
-                (* try push *)
-                (If (CAS (st.[ren (+4)]) (Var 1)
-                         (Alloc (InjR (Pair (Var 3) (Fold (Var 1)))))
-                    )
-                    Unit (* push succeeds we return unit *)
-                    (App (Var 2) (Var 3)) (* push fails, we try again *)
-                )
-             )
-             (Load st.[ren (+2)]) (* read the stack pointer *)
-        ).
+    Rec
+    (LetIn
+       (Load st.[ren (+2)])
+       (* try push *)
+       (If (CAS (st.[ren (+3)]) (Var 0)
+                (Alloc (InjR (Pair (Var 2) (Fold (Var 0)))))
+           )
+           Unit (* push succeeds we return unit *)
+           (App (Var 1) (Var 2)) (* push fails, we try again *)
+       )
+    ).
   Proof. trivial. Qed.
 
-  Section FG_push_type.
-    Lemma FG_push_type st Γ τ :
-      typed Γ st (Tref (FG_Stack_Ref_Type τ)) →
-      typed Γ (FG_push st) (TArrow τ TUnit).
-    Proof.
-      intros HTst.
-      repeat match goal with
-               |- typed _ _ _ => econstructor; eauto
-             end; repeat econstructor; eauto.
-      - eapply (context_weakening [_; _; _; _]); eauto.
-      - by asimpl.
-      -  eapply (context_weakening [_; _]); eauto.
-    Qed.
-
-  End FG_push_type.
 
   Lemma FG_push_to_val st : to_val (FG_push st) = Some (FG_pushV st).
   Proof. trivial. Qed.
@@ -151,83 +132,95 @@ Section FG_stack.
   Lemma FG_push_of_val st : of_val (FG_pushV st) = FG_push st.
   Proof. trivial. Qed.
 
+  Global Typeclasses Opaque FG_pushV.
   Global Opaque FG_pushV.
 
-  Lemma FG_push_closed (st : expr) :
-    (∀ f, st.[f] = st) → ∀ f, (FG_push st).[f] = FG_push st.
-  Proof. intros H f. asimpl. unfold FG_push. rewrite ?H; trivial. Qed.
+  Lemma FG_push_type st Γ τ :
+    typed Γ st (Tref (FG_Stack_Ref_Type τ)) →
+    typed Γ (FG_push st) (TArrow τ TUnit).
+  Proof.
+    intros ?.
+    do 2 econstructor.
+    { econstructor; eapply (context_weakening [_; _]); eauto. }
+    econstructor; eauto using typed.
+    econstructor; eauto using typed; repeat econstructor.
+    - eapply (context_weakening [_; _; _]); eauto.
+    - by asimpl.
+  Qed.
 
-  Lemma FG_push_subst (st : expr) f : (FG_push st).[f] = FG_push st.[f].
-  Proof. unfold FG_push. by asimpl. Qed.
+  Lemma FG_push_subst (st : expr) f :
+    (FG_push st).[f] = FG_push st.[f].
+  Proof. by rewrite /FG_push; asimpl. Qed.
 
+  Hint Rewrite FG_push_subst : autosubst.
+
+  Global Typeclasses Opaque FG_push.
   Global Opaque FG_push.
 
   (* Fine-grained push *)
   Lemma FG_pop_folding (st : expr) :
     FG_pop st =
-    Rec (App (Rec
-                ( App
-                    (Rec
-                       (
-                         Case (Var 1)
-                              (InjL Unit)
-                              ( (* try popping *)
-                                If
-                                  (CAS
-                                     (st.[ren (+7)])
-                                     (Var 4)
-                                     (Unfold (Snd (Var 0)))
-                                  )
-                                  (InjR (Fst (Var 0))) (* pop succeeds *)
-                                  (App (Var 5) (Var 6)) (* pop fails, we retry*)
-                              )
-                       )
-                    )
-                    (
-                      (Load (Var 1))
-                    )
-                )
-             )
-             (Load st.[ren (+ 2)])
-        ).
+    Rec
+      (LetIn
+         (Load st.[ren (+ 2)])
+         (LetIn
+            (Load (Var 0))
+            (Case
+               (Var 0)
+               (InjL Unit)
+               ( (* try popping *)
+                 If
+                   (CAS
+                      (st.[ren (+5)])
+                      (Var 2)
+                    (Unfold (Snd (Var 0)))
+                   )
+                   (InjR (Fst (Var 0))) (* pop succeeds *)
+                   (App (Var 3) (Var 4)) (* pop fails, we retry*)
+               )
+            )
+         )
+      ).
   Proof. trivial. Qed.
 
-  Section FG_pop_type.
-
-    Lemma FG_pop_type st Γ τ :
-      typed Γ st (Tref (FG_Stack_Ref_Type τ)) →
-      typed Γ (FG_pop st) (TArrow TUnit (TSum TUnit τ)).