Require Import DirCache.
Require Import Balloc.
Require Import Prog ProgMonad.
Require Import BasicProg.
Require Import Bool.
Require Import Word.
Require Import BFile Bytes Rec Inode.
Require Import String.
Require Import FSLayout.
Require Import Pred.
Require Import Arith.
Require Import GenSepN.
Require Import List ListUtils.
Require Import Hoare.
Require Import Log.
Require Import SepAuto.
Require Import Array.
Require Import FunctionalExtensionality.
Require Import AsyncDisk.
Require Import DiskSet.
Require Import GenSepAuto.
Require Import Lock.
Require Import Errno.
Import ListNotations.
Require Import DirTreePath.
Require Import DirTreeDef.
Require Import DirTreePred.
Require Import DirTreeRep.
Require Import DirTreeSafe.
Require Import DirTreeNames.
Require Import DirTreeInodes.

Set Implicit Arguments.

Module SDIR := CacheOneDir.

Module DIRTREE.

  (* Programs *)

  Notation MSLL := BFILE.MSLL.
  Notation MSAlloc := BFILE.MSAlloc.
  Notation MSAllocC := BFILE.MSAllocC.
  Notation MSIAllocC := BFILE.MSIAllocC.
  Notation MSICache := BFILE.MSICache.
  Notation MSCache := BFILE.MSCache.
  Notation MSDBlocks := BFILE.MSDBlocks.

  Definition namei fsxp dnum (fnlist : list string) mscs :=
    let '(lxp, bxp, ibxp, ixp) := ((FSXPLog fsxp), (FSXPBlockAlloc fsxp),
                                   fsxp, (FSXPInode fsxp)) in
    let^ (mscs, inum, isdir, valid) <- ForEach fn fnrest fnlist
      Hashmap hm
      Ghost [ mbase m sm F Fm IFs Ftop treetop freeinodes freeinode_pred ilist freeblocks mscs0 ]
      Loopvar [ mscs inum isdir valid ]
      Invariant
        LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs) sm hm *
        exists tree bflist fndone,
        [[ fndone ++ fnrest = fnlist ]] *
        [[ valid = OK tt ->
           (Ftop * tree_pred_except ibxp fndone treetop * tree_pred ibxp tree * freeinode_pred)%pred (list2nmem bflist) ]] *
        [[ isError valid ->
           (Ftop * tree_pred ibxp treetop * freeinode_pred)%pred (list2nmem bflist) ]] *
        [[ (Fm * BFILE.rep bxp IFs ixp bflist ilist freeblocks (MSAllocC mscs) (MSCache mscs) (MSICache mscs) (MSDBlocks mscs) *
            IAlloc.rep BFILE.freepred ibxp freeinodes freeinode_pred (IAlloc.mk_memstate (MSLL mscs) (MSIAllocC mscs)))%pred
           (list2nmem m) ]] *
        [[ dnum = dirtree_inum treetop ]] *
        [[ valid = OK tt -> inum = dirtree_inum tree ]] *
        [[ valid = OK tt -> isdir = dirtree_isdir tree ]] *
        [[ valid = OK tt -> find_subtree fnlist treetop = find_subtree fnrest tree ]] *
        [[ valid = OK tt -> find_subtree fndone treetop = Some tree ]] *
        [[ isError valid -> find_subtree fnlist treetop = None ]] *
        [[ MSAlloc mscs = MSAlloc mscs0 ]] *
        [[ MSAllocC mscs = MSAllocC mscs0 ]] *
        [[ MSDBlocks mscs = MSDBlocks mscs0 ]]
      OnCrash
        LOG.intact fsxp.(FSXPLog) F mbase sm hm
      Begin
        match valid with
        | Err e =>
          Ret ^(mscs, inum, isdir, Err e)
        | OK _ =>
          If (bool_dec isdir true) {
            let^ (mscs, r) <- SDIR.lookup lxp ixp inum fn mscs;
            match r with
            | Some (inum, isdir) => Ret ^(mscs, inum, isdir, OK tt)
            | None => Ret ^(mscs, inum, isdir, Err ENOENT)
            end
          } else {
            Ret ^(mscs, inum, isdir, Err ENOTDIR)
          }
        end
    Rof ^(mscs, dnum, true, OK tt);
    match valid with
    | OK _ =>
      Ret ^(mscs, OK (inum, isdir))
    | Err e =>
      Ret ^(mscs, Err e)
    end.

  Definition mkfile fsxp dnum name fms :=
    let '(lxp, bxp, ibxp, ixp) := ((FSXPLog fsxp), (FSXPBlockAlloc fsxp),
                                   fsxp, (FSXPInode fsxp)) in
    let '(al, alc, ialc, ms, icache, cache, dbcache) := (MSAlloc fms, MSAllocC fms, MSIAllocC fms, MSLL fms, MSICache fms, MSCache fms, MSDBlocks fms) in
    let^ (ms, oi) <- IAlloc.alloc lxp ibxp (IAlloc.mk_memstate ms ialc);
    let fms := BFILE.mk_memstate al (IAlloc.MSLog ms) alc (IAlloc.MSCache ms) icache cache dbcache in
    match oi with
    | None => Ret ^(fms, Err ENOSPCINODE)
    | Some inum =>
      let^ (fms, ok) <- SDIR.link lxp bxp ixp dnum name inum false fms;
      match ok with
      | OK _ =>
        Ret ^(fms, OK (inum : addr))
      | Err e =>
        Ret ^(fms, Err e)
      end
    end.

  Definition mkdir fsxp dnum name fms :=
    let '(lxp, bxp, ibxp, ixp) := ((FSXPLog fsxp), (FSXPBlockAlloc fsxp),
                                   fsxp, (FSXPInode fsxp)) in
    let '(al, alc, ialc, ms, icache, cache, dbcache) := (MSAlloc fms, MSAllocC fms, MSIAllocC fms, MSLL fms, MSICache fms, MSCache fms, MSDBlocks fms) in
    let^ (ms, oi) <- IAlloc.alloc lxp ibxp (IAlloc.mk_memstate ms ialc);
    let fms := BFILE.mk_memstate al (IAlloc.MSLog ms) alc (IAlloc.MSCache ms) icache cache dbcache in
    match oi with
    | None => Ret ^(fms, Err ENOSPCINODE)
    | Some inum =>
      let^ (fms, ok) <- SDIR.link lxp bxp ixp dnum name inum true fms;
      match ok with
      | OK _ =>
        Ret ^(fms, OK (inum : addr))
      | Err e =>
        Ret ^(fms, Err e)
      end
    end.

  Definition delete fsxp dnum name mscs :=
    let '(lxp, bxp, ibxp, ixp) := ((FSXPLog fsxp), (FSXPBlockAlloc fsxp),
                                   fsxp, (FSXPInode fsxp)) in
    let^ (mscs, oi) <- SDIR.lookup lxp ixp dnum name mscs;
    match oi with
    | None => Ret ^(mscs, Err ENOENT)
    | Some (inum, isdir) =>
      let^ (mscs, ok) <- If (bool_dec isdir false) {
        Ret ^(mscs, true)
      } else {
        let^ (mscs, l) <- SDIR.readdir lxp ixp inum mscs;
        match l with
        | nil => Ret ^(mscs, true)
        | _ => Ret ^(mscs, false)
        end
      };
      If (bool_dec ok false) {
        Ret ^(mscs, Err ENOTEMPTY)
      } else {
        let^ (mscs, ok) <- SDIR.unlink lxp ixp dnum name mscs;
        match ok with
        | OK _ =>
          mscs <- BFILE.reset lxp bxp ixp inum mscs;
          mscs' <- IAlloc.free lxp ibxp inum (IAlloc.mk_memstate (MSLL mscs) (MSIAllocC mscs));
          Ret ^(BFILE.mk_memstate (MSAlloc mscs) (IAlloc.MSLog mscs') (MSAllocC mscs) (IAlloc.MSCache mscs') (MSICache mscs) (MSCache mscs) (MSDBlocks mscs), OK tt)
        | Err e =>
          Ret ^(mscs, Err e)
        end
     }
    end.

  Definition rename fsxp dnum srcpath srcname dstpath dstname mscs :=
    let '(lxp, bxp, ibxp, ixp) := ((FSXPLog fsxp), (FSXPBlockAlloc fsxp),
                                   fsxp, (FSXPInode fsxp)) in
    let^ (mscs, osrcdir) <- namei fsxp dnum srcpath mscs;
    match osrcdir with
    | Err _ => Ret ^(mscs, Err ENOENT)
    | OK (_, false) => Ret ^(mscs, Err ENOTDIR)
    | OK (dsrc, true) =>
      let^ (mscs, osrc) <- SDIR.lookup lxp ixp dsrc srcname mscs;
      match osrc with
      | None => Ret ^(mscs, Err ENOENT)
      | Some (inum, inum_isdir) =>
        let^ (mscs, _) <- SDIR.unlink lxp ixp dsrc srcname mscs;
        let^ (mscs, odstdir) <- namei fsxp dnum dstpath mscs;
        match odstdir with
        | Err _ => Ret ^(mscs, Err ENOENT)
        | OK (_, false) => Ret ^(mscs, Err ENOTDIR)
        | OK (ddst, true) =>
          let^ (mscs, odst) <- SDIR.lookup lxp ixp ddst dstname mscs;
          match odst with
          | None =>
            let^ (mscs, ok) <- SDIR.link lxp bxp ixp ddst dstname inum inum_isdir mscs;
            Ret ^(mscs, ok)
          | Some _ =>
            let^ (mscs, ok) <- delete fsxp ddst dstname mscs;
            match ok with
            | OK _ =>
              let^ (mscs, ok) <- SDIR.link lxp bxp ixp ddst dstname inum inum_isdir mscs;
              Ret ^(mscs, ok)
            | Err e =>
              Ret ^(mscs, Err e)
            end
          end
        end
      end
    end.

  Definition read fsxp inum off mscs :=
    let^ (mscs, v) <- BFILE.read (FSXPLog fsxp) (FSXPInode fsxp) inum off mscs;
    Ret ^(mscs, v).

  Definition write fsxp inum off v mscs :=
    mscs <- BFILE.write (FSXPLog fsxp) (FSXPInode fsxp) inum off v mscs;
    Ret mscs.

  Definition dwrite fsxp inum off v mscs :=
    mscs <- BFILE.dwrite (FSXPLog fsxp) (FSXPInode fsxp) inum off v mscs;
    Ret mscs.

  Definition datasync fsxp inum mscs :=
    mscs <- BFILE.datasync (FSXPLog fsxp) (FSXPInode fsxp) inum mscs;
    Ret mscs.

  Definition sync fsxp mscs :=
    mscs <- BFILE.sync (FSXPLog fsxp) (FSXPInode fsxp) mscs;
    Ret mscs.

  Definition sync_noop fsxp mscs :=
    mscs <- BFILE.sync_noop (FSXPLog fsxp) (FSXPInode fsxp) mscs;
    Ret mscs.

  Definition truncate fsxp inum nblocks mscs :=
    let^ (mscs, ok) <- BFILE.truncate (FSXPLog fsxp) (FSXPBlockAlloc fsxp) (FSXPInode fsxp)
                                     inum nblocks mscs;
    Ret ^(mscs, ok).

  Definition getlen fsxp inum mscs :=
    let^ (mscs, len) <- BFILE.getlen (FSXPLog fsxp) (FSXPInode fsxp) inum mscs;
    Ret ^(mscs, len).

  Definition getattr fsxp inum mscs :=
    let^ (mscs, attr) <- BFILE.getattrs (FSXPLog fsxp) (FSXPInode fsxp) inum mscs;
    Ret ^(mscs, attr).

  Definition setattr fsxp inum attr mscs :=
    mscs <- BFILE.setattrs (FSXPLog fsxp) (FSXPInode fsxp) inum attr mscs;
    Ret mscs.

  Definition updattr fsxp inum kv mscs :=
    mscs <- BFILE.updattr (FSXPLog fsxp) (FSXPInode fsxp) inum kv mscs;
    Ret mscs.

  (* Specs and proofs *)

  Local Hint Unfold SDIR.rep_macro rep : hoare_unfold.

  Theorem namei_ok : forall fsxp dnum fnlist mscs,
    {< F mbase m sm Fm Ftop tree ilist freeblocks,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs) sm hm *
           [[ (Fm * rep fsxp Ftop tree ilist freeblocks mscs sm)%pred (list2nmem m) ]] *
           [[ dnum = dirtree_inum tree ]] *
           [[ dirtree_isdir tree = true ]]
    POST:hm' RET:^(mscs',r)
           LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs') sm hm' *
           [[ (Fm * rep fsxp Ftop tree ilist freeblocks mscs' sm)%pred (list2nmem m) ]] *
           [[ (isError r /\ None = find_name fnlist tree) \/
              (exists v, (r = OK v /\ Some v = find_name fnlist tree))%type ]] *
           [[ MSAlloc mscs' = MSAlloc mscs ]]
    CRASH:hm'
           LOG.intact fsxp.(FSXPLog) F mbase sm hm'
    >} namei fsxp dnum fnlist mscs.
  Proof.
    unfold namei.
    step.

    (* Prove loop entry: fndone = nil *)
    rewrite app_nil_l; eauto.
    pred_apply; cancel.
    reflexivity.

    assert (tree_names_distinct tree).
    eapply rep_tree_names_distinct with (m := list2nmem m).
    pred_apply. unfold rep. cancel.

    (* Lock up the initial memory description, because our memory stays the
     * same, and without this lock-up, we end up with several distinct facts
     * about the same memory.
     *)

    all: denote! (_ (list2nmem m)) as Hm0; rewrite <- locked_eq in Hm0.

    destruct_branch.
    step.

    (* isdir = true *)
    destruct tree0; simpl in *; subst; intuition.
    step.
    denote (tree_dir_names_pred) as Hx.
    unfold tree_dir_names_pred in Hx; destruct_lift Hx.
    safestep; eauto.

    (* Lock up another copy of a predicate about our running memory. *)
    denote! (_ (list2nmem m)) as Hm1; rewrite <- locked_eq in Hm1.
    denote (dirlist_pred) as Hx; assert (Horig := Hx).
    destruct_branch.

    (* dslookup = Some _: extract subtree before [cancel] *)
    prestep.
    norml; unfold stars; simpl; inv_option_eq; msalloc_eq.
    destruct a2.

    (* subtree is a directory *)
    rewrite tree_dir_extract_subdir in Hx by eauto; destruct_lift Hx.
    norm. cancel. intuition simpl.
    rewrite cons_app. rewrite app_assoc. reflexivity.

    3: pred_apply; cancel.
    pred_apply; cancel.
    eapply pimpl_trans; [ eapply pimpl_trans | ].
    2: eapply subtree_absorb with
          (xp := fsxp) (fnlist := fndone) (tree := tree)
          (subtree := TreeDir n l0) (subtree' := TreeDir n l0); eauto.
    simpl; unfold tree_dir_names_pred; cancel; eauto.

    rewrite update_subtree_same; eauto.

    eapply pimpl_trans.
    eapply subtree_extract with
          (xp := fsxp) (fnlist := fndone ++ [elem])
          (subtree := TreeDir a1 dummy5).

    erewrite find_subtree_app by eauto.
    eauto.
    reflexivity.

    pred_apply; cancel.

    auto. auto.
    rewrite cons_app. rewrite app_assoc.
    erewrite find_subtree_app. reflexivity.
    erewrite find_subtree_app by eauto. eauto.
    erewrite find_subtree_app by eauto. eauto.
    eauto.

    (* subtree is a file *)
    rewrite tree_dir_extract_file in Hx by eauto. destruct_lift Hx.
    norm; unfold stars; simpl. cancel.
    intuition idtac.
    rewrite cons_app. rewrite app_assoc. reflexivity.
    3: pred_apply; cancel.
    pred_apply; cancel.
    eassign (TreeFile a1 dummy5).
    3: auto. 3: auto.

    eapply pimpl_trans; [ eapply pimpl_trans | ].
    2: eapply subtree_absorb with
          (xp := fsxp) (fnlist := fndone) (tree := tree)
          (subtree := TreeDir n l0) (subtree' := TreeDir n l0); eauto.
    simpl; unfold tree_dir_names_pred; cancel; eauto.

    rewrite update_subtree_same; eauto.

    eapply pimpl_trans.
    eapply subtree_extract with
          (xp := fsxp) (fnlist := fndone ++ [elem])
          (subtree := TreeFile a1 dummy5).

    erewrite find_subtree_app by eauto.
    eauto.
    reflexivity.

    pred_apply; cancel.

    rewrite cons_app. rewrite app_assoc.
    erewrite find_subtree_app. reflexivity.

    erewrite find_subtree_app by eauto. eauto.
    erewrite find_subtree_app by eauto. eauto.
    eauto.

    (* dslookup = None *)
    prestep. norm; msalloc_eq. cancel. intuition idtac.
    all: try solve [ exfalso; congruence ].
    rewrite cons_app. rewrite app_assoc. reflexivity.
    2: pred_apply; cancel.
    pred_apply; cancel.

    eapply pimpl_trans; [ | eapply pimpl_trans ].
    2: eapply subtree_absorb with (xp := fsxp) (fnlist := fndone) (tree := tree) (subtree' := TreeDir n l0).
    cancel. unfold tree_dir_names_pred. cancel; eauto.
    eauto. eauto. eauto.

    rewrite update_subtree_same by eauto. cancel.
    erewrite <- find_subtree_none; eauto.
    eauto.
    cancel.

    prestep. norm; msalloc_eq. cancel. intuition idtac.
    rewrite cons_app. rewrite app_assoc. reflexivity.
    all: try solve [ exfalso; congruence ].
    2: pred_apply; cancel.
    pred_apply; cancel.

    eapply pimpl_trans; [ | eapply pimpl_trans ].
    2: eapply subtree_absorb with (xp := fsxp) (fnlist := fndone) (tree := tree) (subtree' := tree0).
    cancel. eauto. eauto. eauto.
    rewrite update_subtree_same by eauto. cancel.
    denote (find_subtree) as Hx; rewrite Hx.
    destruct tree0; intuition.
    eauto.

    step.
    rewrite cons_app. rewrite app_assoc. reflexivity.

    (* Ret : OK *)
    assert (tree_names_distinct tree).
    eapply rep_tree_names_distinct with (m := locked (list2nmem m)).
    pred_apply. unfold rep. cancel.

    step; msalloc_eq.

    rewrite subtree_absorb.
    rewrite update_subtree_same.
    cancel.
    all: eauto.

    right; eexists; intuition.
    denote! (find_subtree (fndone ++ _) _ = _) as Hx.
    unfold find_name; rewrite Hx.
    destruct tree0; reflexivity.

    left; intuition.
    denote (find_subtree (fndone ++ _) _ = _) as Hx.
    unfold find_name; rewrite Hx; eauto.

    Grab Existential Variables.
    all: try exact unit.
    all: try exact None.
    all: intros; try exact tt.
    all: try congruence.
  Qed.

  Hint Extern 1 ({{_}} Bind (namei _ _ _ _) _) => apply namei_ok : prog.

  Theorem mkdir_ok' : forall fsxp dnum name mscs,
    {< F mbase m sm Fm Ftop tree tree_elem ilist freeblocks,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs) sm hm *
           [[ (Fm * rep fsxp Ftop tree ilist freeblocks mscs sm)%pred (list2nmem m) ]] *
           [[ tree = TreeDir dnum tree_elem ]]
    POST:hm' RET:^(mscs',r)
           exists m', LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m') (MSLL mscs') sm hm' *
           [[ MSAlloc mscs' = MSAlloc mscs ]] *
           ([[ isError r ]] \/
            exists inum ilist' freeblocks',
            let tree' := TreeDir dnum ((name, TreeDir inum nil) :: tree_elem) in
            [[ r = OK inum ]] *
            [[ (Fm * rep fsxp Ftop tree' ilist' freeblocks' mscs' sm)%pred (list2nmem m') ]] *
            [[ dirtree_safe ilist  (BFILE.pick_balloc freeblocks  (MSAlloc mscs')) tree
                            ilist' (BFILE.pick_balloc freeblocks' (MSAlloc mscs')) tree' ]] )
    CRASH:hm'
           LOG.intact fsxp.(FSXPLog) F mbase sm hm'
    >} mkdir fsxp dnum name mscs.
  Proof.
    unfold mkdir, rep.
    step.
    subst; simpl in *.
    denote tree_dir_names_pred as Hx;
    unfold tree_dir_names_pred in Hx; destruct_lift Hx.
    unfold IAlloc.MSLog in *.
    step.
    eapply IAlloc.ino_valid_goodSize; eauto.
    destruct_branch; [ | step ].
    prestep; norml; inv_option_eq; msalloc_eq.

    cancel.
    match goal with a: IAlloc.Alloc.memstate |- _
      => destruct a; cbn in *; subst
    end.
    or_r; cancel.

    unfold tree_dir_names_pred at 1. cancel; eauto.
    denote (dummy1 =p=> _) as Hx. rewrite Hx.
    unfold tree_dir_names_pred; cancel.
    denote (BFILE.freepred _) as Hy. unfold BFILE.freepred in Hy. subst.
    apply SDIR.bfile0_empty.
    apply emp_empty_mem.
    apply sep_star_comm. apply ptsto_upd_disjoint. auto. auto.

    msalloc_eq.
    eapply dirlist_safe_mkdir; auto.

    Unshelve.
    all: try eauto; exact emp; try exact nil; try exact empty_mem; try exact BFILE.bfile0.
  Qed.

  Theorem mkdir_ok : forall fsxp dnum name mscs,
    {< F mbase sm m pathname Fm Ftop tree tree_elem ilist frees,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs) sm hm *
           [[ (Fm * rep fsxp Ftop tree ilist frees mscs sm)%pred (list2nmem m) ]] *
           [[ find_subtree pathname tree = Some (TreeDir dnum tree_elem) ]]
    POST:hm' RET:^(mscs',r)
           exists m', LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m') (MSLL mscs') sm hm' *
           [[ MSAlloc mscs' = MSAlloc mscs ]] *
           ([[ isError r ]] \/
            exists inum tree' ilist' frees', [[ r = OK inum ]] *
            [[ tree' = update_subtree pathname (TreeDir dnum
                      ((name, TreeDir inum nil) :: tree_elem)) tree ]] *
            [[ (Fm * rep fsxp Ftop tree' ilist' frees' mscs' sm)%pred (list2nmem m') ]] *
            [[ dirtree_safe ilist  (BFILE.pick_balloc frees  (MSAlloc mscs')) tree
                            ilist' (BFILE.pick_balloc frees' (MSAlloc mscs')) tree' ]] )
    CRASH:hm'
           LOG.intact fsxp.(FSXPLog) F mbase sm hm'
    >} mkdir fsxp dnum name mscs.
  Proof.
    intros; eapply pimpl_ok2. apply mkdir_ok'.
    unfold rep; cancel.
    rewrite subtree_extract; eauto. simpl. instantiate (tree_elem0 := tree_elem). cancel.
    step.
    apply pimpl_or_r; right. cancel.
    rewrite <- subtree_absorb; eauto.
    cancel.
    eapply dirlist_safe_subtree; eauto.
  Qed.

  Theorem mkfile_ok' : forall fsxp dnum name mscs,
    {< F mbase sm m pathname Fm Ftop tree tree_elem ilist frees,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs) sm hm *
           [[ (Fm * rep fsxp Ftop tree ilist frees mscs sm)%pred (list2nmem m) ]] *
           [[ find_subtree pathname tree = Some (TreeDir dnum tree_elem) ]]
    POST:hm' RET:^(mscs',r) exists m',
           LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m') (MSLL mscs') sm hm' *
           [[ MSAlloc mscs' = MSAlloc mscs ]] *
           ([[ isError r ]] \/
            exists inum ilist' tree' frees',
            [[ r = OK inum ]] * [[ ~ In name (map fst tree_elem) ]] *
            [[ tree' = update_subtree pathname (TreeDir dnum
                        (tree_elem ++ [(name, (TreeFile inum dirfile0))] )) tree ]] *
            [[ (Fm * rep fsxp Ftop tree' ilist' frees' mscs' sm)%pred (list2nmem m') ]] *
            [[ dirtree_safe ilist  (BFILE.pick_balloc frees  (MSAlloc mscs')) tree
                            ilist' (BFILE.pick_balloc frees' (MSAlloc mscs')) tree' ]])
    CRASH:hm'
           LOG.intact fsxp.(FSXPLog) F mbase sm hm'
    >} mkfile fsxp dnum name mscs.
  Proof.
    unfold mkfile, rep.
    step.
    subst; simpl in *.

    denote tree_pred as Ht;
    rewrite subtree_extract in Ht; eauto.
    assert (tree_names_distinct (TreeDir dnum tree_elem)).
    eapply rep_tree_names_distinct with (m := list2nmem m).
    pred_apply; unfold rep; cancel.

    simpl in *.
    denote tree_dir_names_pred as Hx;
    unfold tree_dir_names_pred in Hx; destruct_lift Hx.
    unfold IAlloc.MSLog in *.
    step.
    unfold SDIR.rep_macro.
    eapply IAlloc.ino_valid_goodSize; eauto.

    destruct_branch; [ | step ].
    prestep; norml; inv_option_eq.

    cancel.
    match goal with a: IAlloc.Alloc.memstate |- _
      => destruct a; cbn in *; subst
    end.
    msalloc_eq.
    or_r; cancel.
    eapply dirname_not_in; eauto.

    rewrite <- subtree_absorb; eauto.
    cancel.
    unfold tree_dir_names_pred.
    cancel; eauto.
    denote (dummy1 =p=> _) as Hx; rewrite Hx.
    unfold BFILE.freepred.
    rewrite dirlist_pred_split; simpl; cancel.
    apply tree_dir_names_pred'_app; simpl.
    apply sep_star_assoc; apply emp_star_r.
    apply ptsto_upd_disjoint; auto.

    eapply dirlist_safe_subtree; eauto.
    msalloc_eq.
    eapply dirlist_safe_mkfile; eauto.

    pred_apply.
    denote (dummy1 =p=> _) as Hx; rewrite Hx; unfold BFILE.freepred.
    cancel.

    eapply dirname_not_in; eauto.

    Unshelve.
    all: eauto.
  Qed.

  Hint Extern 0 (okToUnify (rep _ _ _ _ _ _ _) (rep _ _ _ _ _ _ _)) => constructor : okToUnify.

  (* same as previous one, but use tree_graft *)
  Theorem mkfile_ok : forall fsxp dnum name mscs,
    {< F mbase sm m pathname Fm Ftop tree tree_elem ilist frees,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs) sm hm *
           [[ (Fm * rep fsxp Ftop tree ilist frees mscs sm)%pred (list2nmem m) ]] *
           [[ find_subtree pathname tree = Some (TreeDir dnum tree_elem) ]]
    POST:hm' RET:^(mscs',r) exists m',
           LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m') (MSLL mscs') sm hm' *
           [[ MSAlloc mscs' = MSAlloc mscs ]] *
           ([[ isError r ]] \/
            exists inum ilist' tree' frees',
            [[ r = OK inum ]] *
            [[ tree' = tree_graft dnum tree_elem pathname name (TreeFile inum dirfile0) tree ]] *
            [[ (Fm * rep fsxp Ftop tree' ilist' frees' mscs' sm)%pred (list2nmem m') ]] *
            [[ dirtree_safe ilist  (BFILE.pick_balloc frees  (MSAlloc mscs')) tree
                            ilist' (BFILE.pick_balloc frees' (MSAlloc mscs')) tree' ]])
    CRASH:hm'
           LOG.intact fsxp.(FSXPLog) F mbase sm hm'
    >} mkfile fsxp dnum name mscs.
  Proof.
    unfold mkfile; intros.
    eapply pimpl_ok2. apply mkfile_ok'.
    cancel.
    eauto.
    step.

    or_r; cancel.
    rewrite tree_graft_not_in_dirents; auto.
    rewrite <- tree_graft_not_in_dirents; auto.
  Qed.

  Hint Extern 1 ({{_}} Bind (mkdir _ _ _ _) _) => apply mkdir_ok : prog.
  Hint Extern 1 ({{_}} Bind (mkfile _ _ _ _) _) => apply mkfile_ok : prog.

  Lemma false_False_true : forall x,
    (x = false -> False) -> x = true.
  Proof.
    destruct x; tauto.
  Qed.

  Lemma true_False_false : forall x,
    (x = true -> False) -> x = false.
  Proof.
    destruct x; tauto.
  Qed.

  Ltac subst_bool :=
    repeat match goal with
    | [ H : ?x = true |- _ ] => is_var x; subst x
    | [ H : ?x = false |- _ ] => is_var x; subst x
    | [ H : ?x = false -> False  |- _ ] => is_var x; apply false_False_true in H; subst x
    | [ H : ?x = true -> False   |- _ ] => is_var x; apply true_False_false in H; subst x
    end.

  Hint Extern 0 (okToUnify (tree_dir_names_pred _ _ _) (tree_dir_names_pred _ _ _)) => constructor : okToUnify.

  Theorem delete_ok' : forall fsxp dnum name mscs,
    {< F mbase sm m Fm Ftop tree tree_elem frees ilist,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs) sm hm *
           [[ (Fm * rep fsxp Ftop tree ilist frees mscs sm)%pred (list2nmem m) ]] *
           [[ tree = TreeDir dnum tree_elem ]]
    POST:hm' RET:^(mscs',r)
           exists m', LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m') (MSLL mscs') sm hm' *
           [[ MSAlloc mscs' = MSAlloc mscs ]] *
           ([[ isError r ]] \/
            [[ r = OK tt ]] * exists frees' ilist',
            let tree' := delete_from_dir name tree in
            [[ (Fm * rep fsxp Ftop tree' ilist' frees' mscs' sm)%pred (list2nmem m') ]] *
            [[ dirtree_safe ilist  (BFILE.pick_balloc frees  (MSAlloc mscs')) tree
                            ilist' (BFILE.pick_balloc frees' (MSAlloc mscs')) tree' ]] *
            [[ forall inum def', inum <> dnum ->
                 (In inum (tree_inodes tree') \/ (~ In inum (tree_inodes tree))) ->
                 selN ilist inum def' = selN ilist' inum def' ]])
    CRASH:hm'
           LOG.intact fsxp.(FSXPLog) F mbase sm hm'
    >} delete fsxp dnum name mscs.
  Proof.
    unfold delete, rep.

    (* extract some basic facts from rep *)
    intros; eapply pimpl_ok2; monad_simpl; eauto with prog; intros; norm'l.
    assert (tree_inodes_distinct (TreeDir dnum tree_elem)) as HiID.
    eapply rep_tree_inodes_distinct with (m := list2nmem m).
    pred_apply; unfold rep; cancel.
    assert (tree_names_distinct (TreeDir dnum tree_elem)) as HdID.
    eapply rep_tree_names_distinct with (m := list2nmem m).
    pred_apply; unfold rep; cancel.

    (* lookup *)
    subst; simpl in *.
    denote tree_dir_names_pred as Hx;
    unfold tree_dir_names_pred in Hx; destruct_lift Hx.
    safecancel. 2: eauto.
    unfold SDIR.rep_macro.
    cancel; eauto.

    denote! (_ (list2nmem m)) as Hm0; rewrite <- locked_eq in Hm0.
    step.
    step.
    step.

    (* unlink *)
    step.

    (* is_file: prepare for reset *)
    prestep. norml.
    denote dirlist_pred as Hx.
    erewrite dirlist_extract with (inum := a0) in Hx; eauto.
    destruct_lift Hx.
    destruct dummy4; simpl in *; try congruence; subst.
    denote dirlist_pred_except as Hx; destruct_lift Hx; auto.
    cancel.

    (* is_file: prepare for free *)
    prestep. norml; msalloc_eq.
    denote dirlist_pred as Hx.
    erewrite dirlist_extract with (inum := n) in Hx; eauto.
    destruct_lift Hx.
    denote dirlist_pred_except as Hx; destruct_lift Hx; auto.
    unfold IAlloc.MSLog in *; cancel.
    match goal with H: (_ * ptsto ?a _)%pred ?m |- context [ptsto ?a]
      => exists m; solve [pred_apply; cancel]
    end.

    (* post conditions *)
    step.
    or_r; safecancel.
    denote (pimpl _ freepred') as Hx; rewrite <- Hx.
    rewrite dir_names_delete with (dnum := dnum); eauto.
    rewrite dirlist_pred_except_delete; eauto.
    cancel.
    eauto.
    apply dirlist_safe_delete; auto.

    (* inum inside the new modified tree *)
    denote! (tree_dir_names_pred' _ _) as Hy.
    eapply find_dirlist_exists in Hy as Hy'.
    deex.
    denote dirlist_combine as Hx.
    eapply tree_inodes_distinct_delete in Hx as Hx'; eauto.
    eassumption.

    (* inum outside the original tree *)
    denote! (forall _ _, (_ = _ -> False) -> _ = _) as Hz.
    eapply Hz.
    intro; subst.
    denote! (In _ _ -> False) as Hq.
    eapply Hq.
    denote ((name |-> (_, false))%pred) as Hy.
    eapply find_dirlist_exists in Hy as Hy'; eauto.
    deex.
    denote (dirtree_inum _ = dirtree_inum _ ) as Hd.
    rewrite Hd.
    eapply find_dirlist_tree_inodes; eauto.

    cancel.
    cancel.

    unfold IAlloc.MSLog in *; cancel.
    or_l. cancel.

    (* case 2: is_dir: check empty *)
    prestep.
    intros; norm'l.
    denote dirlist_pred as Hx; subst_bool.
    rewrite dirlist_extract_subdir in Hx; eauto; simpl in Hx.
    unfold tree_dir_names_pred in Hx; destruct_lift Hx.
    cancel. eauto.

    step.
    step.
    step.
    step.
    step. msalloc_eq.
    cancel.
    exists (list2nmem flist'). eexists.
    pred_apply. cancel.
    unfold IAlloc.MSLog in *.
    step.

    (* post conditions *)
    or_r; cancel.
    denote (pimpl _ freepred') as Hx; rewrite <- Hx.
    denote (tree_dir_names_pred' _ _) as Hz.
    erewrite (@dlist_is_nil _ _ _ _ _ Hz); eauto.
    rewrite dirlist_pred_except_delete; eauto.
    rewrite dir_names_delete with (dnum := dnum).
    cancel. eauto. eauto. eauto.
    reflexivity.
    apply dirlist_safe_delete; auto.

    (* inum inside the new modified tree *)
    eapply find_dirlist_exists in H9 as H9'.
    deex.
    denote dirlist_combine as Hx.
    eapply tree_inodes_distinct_delete in Hx as Hx'; eauto.
    eassumption.

    (* inum outside the original tree *)
    denote (selN _ _ _ = selN _ _ _) as Hs.
    denote (In _ (dirlist_combine _ _)) as Hi.
    denote (tree_dir_names_pred' tree_elem) as Ht.
    apply Hs.
    intro; subst.
    eapply Hi.
    eapply find_dirlist_exists with (inum := a0) in Ht as Ht'.
    deex.
    eapply find_dirlist_tree_inodes; eauto.
    eassumption.

    step.
    step.
    cancel; auto.
    cancel; auto.

    Unshelve.
    all: try match goal with | [ |- DirTreePred.SDIR.rep _ _ ] => eauto end.
    all: try exact unit.
    all: try solve [repeat constructor].
    all: eauto.
    all: try exact string_dec.
  Qed.

  Theorem read_ok : forall fsxp inum off mscs,
    {< F mbase sm m pathname Fm Ftop tree f B v ilist frees,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs) sm hm *
           [[ (Fm * rep fsxp Ftop tree ilist frees mscs sm)%pred (list2nmem m) ]] *
           [[ find_subtree pathname tree = Some (TreeFile inum f) ]] *
           [[ (B * off |-> v)%pred (list2nmem (DFData f)) ]]
    POST:hm' RET:^(mscs',r)
           LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs') sm hm' *
           [[ (Fm * rep fsxp Ftop tree ilist frees mscs' sm)%pred (list2nmem m) ]] *
           [[ r = fst v /\ MSAlloc mscs' = MSAlloc mscs ]]
    CRASH:hm'
           LOG.intact fsxp.(FSXPLog) F mbase sm hm'
    >} read fsxp inum off mscs.
  Proof.
    unfold read, rep.
    intros. prestep. norml.
    rewrite subtree_extract in * by eauto.
    cbn [tree_pred] in *. destruct_lifts.
    cancel.

    eapply list2nmem_inbound; eauto.
    step; msalloc_eq.
    cancel.

    rewrite <- subtree_fold by eauto.
    pred_apply. cancel.

    cancel; eauto.
  Qed.

  Theorem dwrite_ok : forall fsxp inum off v mscs,
    {< F ds sm pathname Fm Ftop tree f Fd vs ilist frees,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn ds ds!!) (MSLL mscs) sm hm *
           [[[ ds!! ::: Fm * rep fsxp Ftop tree ilist frees mscs sm ]]] *
           [[ find_subtree pathname tree = Some (TreeFile inum f) ]] *
           [[[ (DFData f) ::: (Fd * off |-> vs) ]]] *
           [[ PredCrash.sync_invariant F ]]
    POST:hm' RET:mscs'
           exists ds' tree' f' sm' bn,
           LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn ds' ds'!!) (MSLL mscs') sm' hm' *
           [[ ds' = dsupd ds bn (v, vsmerge vs) ]] *
           [[ BFILE.block_belong_to_file ilist bn inum off ]] *
           [[ MSAlloc mscs' = MSAlloc mscs ]] *
           [[ MSCache mscs' = MSCache mscs ]] *
           [[ MSAllocC mscs' = MSAllocC mscs ]] *
           [[ MSIAllocC mscs' = MSIAllocC mscs ]] *
           (* spec about files on the latest diskset *)
           [[[ ds'!! ::: (Fm  * rep fsxp Ftop tree' ilist frees mscs' sm') ]]] *
           [[ tree' = update_subtree pathname (TreeFile inum f') tree ]] *
           [[[ (DFData f') ::: (Fd * off |-> (v, vsmerge vs)) ]]] *
           [[ f' = mk_dirfile (updN (DFData f) off (v, vsmerge vs)) (DFAttr f) ]] *
           [[ dirtree_safe ilist (BFILE.pick_balloc frees (MSAlloc mscs')) tree
                           ilist (BFILE.pick_balloc frees (MSAlloc mscs')) tree' ]]
    XCRASH:hm'
           LOG.recover_any fsxp.(FSXPLog) F ds hm' \/
           exists bn, [[ BFILE.block_belong_to_file ilist bn inum off ]] *
           LOG.recover_any fsxp.(FSXPLog) F (dsupd ds bn (v, vsmerge vs)) hm'
    >} dwrite fsxp inum off v mscs.
  Proof.
    unfold dwrite, rep.
    intros. prestep. norml.
    rewrite subtree_extract in * by eauto.
    cbn [tree_pred] in *. destruct_lifts.
    cancel.
    eapply list2nmem_inbound; eauto.
    prestep. norm. cancel.
    intuition auto; msalloc_eq.
    pred_apply; cancel.

    rewrite <- subtree_absorb by eauto.
    cancel.
    auto.

    eapply dirlist_safe_subtree; eauto.
    apply dirtree_safe_file.
  Qed.

 Theorem datasync_ok : forall fsxp inum mscs,
    {< F ds sm pathname Fm Ftop tree f ilist frees,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn ds ds!!) (MSLL mscs) sm hm *
           [[[ ds!! ::: Fm * rep fsxp Ftop tree ilist frees mscs sm ]]] *
           [[ find_subtree pathname tree = Some (TreeFile inum f) ]] *
           [[ PredCrash.sync_invariant F ]]
    POST:hm' RET:mscs'
           exists ds' sm' tree' al,
           LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn ds' ds'!!) (MSLL mscs') sm' hm' *
           [[ tree' = update_subtree pathname (TreeFile inum (synced_dirfile f)) tree ]] *
           [[ ds' = dssync_vecs ds al ]] *
           [[[ ds'!! ::: (Fm * rep fsxp Ftop tree' ilist frees mscs' sm') ]]] *
           [[ MSAlloc mscs' = MSAlloc mscs ]] *
           [[ MSCache mscs' = MSCache mscs ]] *
           [[ MSAllocC mscs' = MSAllocC mscs ]] *
           [[ MSIAllocC mscs' = MSIAllocC mscs ]] *
           [[ length al = length (DFData f) /\ forall i, i < length al ->
              BFILE.block_belong_to_file ilist (selN al i 0) inum i ]] *
           [[ dirtree_safe ilist (BFILE.pick_balloc frees (MSAlloc mscs')) tree
                           ilist (BFILE.pick_balloc frees (MSAlloc mscs')) tree' ]]
    CRASH:hm'
           LOG.recover_any fsxp.(FSXPLog) F ds hm'
    >} datasync fsxp inum mscs.
  Proof.
    unfold datasync, rep.
    intros. prestep. norml.
    rewrite subtree_extract in * by eauto.
    cbn [tree_pred] in *. destruct_lifts.
    cancel.
    step; msalloc_eq.
    cancel.

    rewrite <- subtree_absorb by eauto.
    pred_apply. cancel.

    eapply dirlist_safe_subtree; eauto.
    apply dirtree_safe_file.
  Qed.

  Theorem sync_ok : forall fsxp mscs,
    {< F ds sm Fm Ftop tree ilist frees,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.NoTxn ds) (MSLL mscs) sm hm *
           [[[ ds!! ::: Fm * rep fsxp Ftop tree ilist frees mscs sm ]]] *
           [[ PredCrash.sync_invariant F ]]
    POST:hm' RET:mscs'
           LOG.rep fsxp.(FSXPLog) F (LOG.NoTxn (ds!!, nil)) (MSLL mscs') sm hm' *
           [[ MSCache mscs' = MSCache mscs ]] *
           [[ MSAlloc mscs' = negb (MSAlloc mscs) ]] *
           [[ MSIAllocC mscs' = MSIAllocC mscs ]] *
           [[ MSAllocC mscs' = MSAllocC mscs ]] *
           [[ MSICache mscs' = MSICache mscs ]] *
           [[ MSDBlocks mscs' = MSDBlocks mscs ]]
    XCRASH:hm'
           LOG.recover_any fsxp.(FSXPLog) F ds hm'
     >} sync fsxp mscs.
  Proof.
    unfold sync, rep.
    hoare.
  Qed.

  Theorem sync_noop_ok : forall fsxp mscs,
    {< F ds sm Fm Ftop tree ilist frees,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.NoTxn ds) (MSLL mscs) sm hm *
           [[[ ds!! ::: Fm * rep fsxp Ftop tree ilist frees mscs sm ]]] *
           [[ PredCrash.sync_invariant F ]]
    POST:hm' RET:mscs'
           LOG.rep fsxp.(FSXPLog) F (LOG.NoTxn ds) (MSLL mscs') sm hm' *
           [[ MSCache mscs' = MSCache mscs ]] *
           [[ MSAlloc mscs' = negb (MSAlloc mscs) ]]
    XCRASH:hm'
           LOG.recover_any fsxp.(FSXPLog) F ds hm'
     >} sync_noop fsxp mscs.
  Proof.
    unfold sync_noop, rep.
    hoare.
  Qed.

  Theorem truncate_ok : forall fsxp inum nblocks mscs,
    {< F ds sm d pathname Fm Ftop tree f frees ilist,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn ds d) (MSLL mscs) sm hm *
           [[[ d ::: Fm * rep fsxp Ftop tree ilist frees mscs sm ]]] *
           [[ find_subtree pathname tree = Some (TreeFile inum f) ]]
    POST:hm' RET:^(mscs', ok)
           exists d',
           LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn ds d') (MSLL mscs') sm hm' *
           [[ MSCache mscs' = MSCache mscs ]] *
           [[ MSAlloc mscs' = MSAlloc mscs ]] *
          ([[ isError ok ]] \/
           [[ ok = OK tt ]] *
           exists tree' f' ilist' frees',
           [[[ d' ::: Fm * rep fsxp Ftop tree' ilist' frees' mscs' sm ]]] *
           [[ tree' = update_subtree pathname (TreeFile inum f') tree ]] *
           [[ f' = mk_dirfile (setlen (DFData f) nblocks ($0, nil)) (DFAttr f) ]] *
           [[ dirtree_safe ilist  (BFILE.pick_balloc frees  (MSAlloc mscs')) tree
                           ilist' (BFILE.pick_balloc frees' (MSAlloc mscs')) tree' ]] *
           [[ nblocks >= Datatypes.length (DFData f) -> BFILE.treeseq_ilist_safe inum ilist ilist' ]])
    CRASH:hm'
           LOG.intact fsxp.(FSXPLog) F ds sm hm'
    >} truncate fsxp inum nblocks mscs.
  Proof.
    unfold truncate, rep.
    intros. prestep. norml.
    rewrite subtree_extract in * by eauto.
    cbn [tree_pred] in *. destruct_lifts.
    cancel.
    step; msalloc_eq.
    or_r.
    cancel.
    rewrite <- subtree_absorb by eauto. cancel.

    eapply dirlist_safe_subtree; eauto.
    apply dirtree_safe_file_trans; auto.
  Qed.

  Theorem getlen_ok : forall fsxp inum mscs,
    {< F mbase sm m pathname Fm Ftop tree f frees ilist,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs) sm hm *
           [[ (Fm * rep fsxp Ftop tree ilist frees mscs sm)%pred (list2nmem m) ]] *
           [[ find_subtree pathname tree = Some (TreeFile inum f) ]]
    POST:hm' RET:^(mscs',r)
           LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs') sm hm' *
           [[ (Fm * rep fsxp Ftop tree ilist frees mscs' sm)%pred (list2nmem m) ]] *
           [[ r = length (DFData f) ]] *
           [[ MSCache mscs' = MSCache mscs ]] *
           [[ MSAlloc mscs' = MSAlloc mscs ]]
    CRASH:hm'
           LOG.intact fsxp.(FSXPLog) F mbase sm hm'
    >} getlen fsxp inum mscs.
  Proof.
    unfold getlen, rep.
    intros. prestep. norml.
    rewrite subtree_extract in * by eauto.
    cbn [tree_pred] in *. destruct_lifts.
    cancel.
    step; msalloc_eq.
    cancel.
    rewrite <- subtree_fold by eauto. pred_apply; cancel.
    cancel; eauto.
  Qed.

  Theorem getattr_ok : forall fsxp inum mscs,
    {< F ds sm d pathname Fm Ftop tree f ilist frees,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn ds d) (MSLL mscs) sm hm *
           [[[ d ::: Fm * rep fsxp Ftop tree ilist frees mscs sm ]]] *
           [[ find_subtree pathname tree = Some (TreeFile inum f) ]]
    POST:hm' RET:^(mscs',r)
           LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn ds d) (MSLL mscs') sm hm' *
           [[[ d ::: Fm * rep fsxp Ftop tree ilist frees mscs' sm ]]] *
           [[ MSCache mscs' = MSCache mscs ]] *
           [[ r = DFAttr f /\ MSAlloc mscs' = MSAlloc mscs ]]
    CRASH:hm'
           LOG.intact fsxp.(FSXPLog) F ds sm hm'
    >} getattr fsxp inum mscs.
  Proof.
    unfold getattr, rep.
    intros. prestep. norml.
    rewrite subtree_extract in * by eauto.
    cbn [tree_pred] in *. destruct_lifts.
    cancel.
    step; msalloc_eq.
    cancel.
    rewrite <- subtree_fold by eauto. pred_apply; cancel.
    cancel; eauto.
  Qed.

  Theorem setattr_ok : forall fsxp inum attr mscs,
    {< F mbase sm m pathname Fm Ftop tree f ilist frees,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs) sm hm *
           [[ (Fm * rep fsxp Ftop tree ilist frees mscs sm)%pred (list2nmem m) ]] *
           [[ find_subtree pathname tree = Some (TreeFile inum f) ]]
    POST:hm' RET:mscs'
           exists m' tree' f' ilist',
           LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m') (MSLL mscs') sm hm' *
           [[ (Fm * rep fsxp Ftop tree' ilist' frees mscs' sm)%pred (list2nmem m') ]] *
           [[ tree' = update_subtree pathname (TreeFile inum f') tree ]] *
           [[ f' = mk_dirfile (DFData f) attr ]] *
           [[ MSAlloc mscs' = MSAlloc mscs ]] *
           [[ dirtree_safe ilist  (BFILE.pick_balloc frees  (MSAlloc mscs')) tree
                           ilist' (BFILE.pick_balloc frees  (MSAlloc mscs')) tree' ]] *
           [[ BFILE.treeseq_ilist_safe inum ilist ilist' ]]
    CRASH:hm'
           LOG.intact fsxp.(FSXPLog) F mbase sm hm'
    >} setattr fsxp inum attr mscs.
  Proof.
    unfold setattr, rep.
    intros. prestep. norml.
    rewrite subtree_extract in * by eauto.
    cbn [tree_pred] in *. destruct_lifts.
    cancel.
    step; msalloc_eq.
    cancel.
    rewrite <- subtree_absorb by eauto.
    pred_apply; cancel.
    eapply dirlist_safe_subtree; eauto.
    apply dirtree_safe_file_trans; auto.
  Qed.

  Hint Extern 1 ({{_}} Bind (read _ _ _ _) _) => apply read_ok : prog.
  Hint Extern 1 ({{_}} Bind (dwrite _ _ _ _ _) _) => apply dwrite_ok : prog.
  Hint Extern 1 ({{_}} Bind (datasync _ _ _) _) => apply datasync_ok : prog.
  Hint Extern 1 ({{_}} Bind (sync _ _) _) => apply sync_ok : prog.
  Hint Extern 1 ({{_}} Bind (sync_noop _ _) _) => apply sync_noop_ok : prog.
  Hint Extern 1 ({{_}} Bind (truncate _ _ _ _) _) => apply truncate_ok : prog.
  Hint Extern 1 ({{_}} Bind (getlen _ _ _) _) => apply getlen_ok : prog.
  Hint Extern 1 ({{_}} Bind (getattr _ _ _) _) => apply getattr_ok : prog.
  Hint Extern 1 ({{_}} Bind (setattr _ _ _ _) _) => apply setattr_ok : prog.

  Theorem delete_ok : forall fsxp dnum name mscs,
    {< F mbase sm m pathname Fm Ftop tree tree_elem ilist frees,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs) sm hm *
           [[ (Fm * rep fsxp Ftop tree ilist frees mscs sm)%pred (list2nmem m) ]] *
           [[ find_subtree pathname tree = Some (TreeDir dnum tree_elem) ]]
    POST:hm' RET:^(mscs',r)
           exists m', LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m') (MSLL mscs') sm hm' *
           [[ MSAlloc mscs' = MSAlloc mscs ]] *
           ([[ isError r ]] \/
            [[ r = OK tt ]] * exists tree' ilist' frees',
            [[ tree' = update_subtree pathname
                      (delete_from_dir name (TreeDir dnum tree_elem)) tree ]] *
            [[ (Fm * rep fsxp Ftop tree' ilist' frees' mscs' sm)%pred (list2nmem m') ]] *
            [[ dirtree_safe ilist  (BFILE.pick_balloc frees  (MSAlloc mscs')) tree
                            ilist' (BFILE.pick_balloc frees' (MSAlloc mscs')) tree' ]] *
            [[ forall inum def', inum <> dnum ->
                 (In inum (tree_inodes tree') \/ (~ In inum (tree_inodes tree))) ->
                selN ilist inum def' = selN ilist' inum def' ]])
    CRASH:hm'
           LOG.intact fsxp.(FSXPLog) F mbase sm hm'
    >} delete fsxp dnum name mscs.
  Proof.
    intros; eapply pimpl_ok2. apply delete_ok'.

    intros; norml; unfold stars; simpl.
    rewrite rep_tree_distinct_impl in *.
    unfold rep in *; cancel.

    rewrite subtree_extract; eauto. simpl. instantiate (tree_elem0:=tree_elem). cancel.
    step.
    apply pimpl_or_r; right. cancel.
    rewrite <- subtree_absorb; eauto.
    cancel.
    eapply dirlist_safe_subtree; eauto.
    denote (dirlist_combine tree_inodes _) as Hx.
    specialize (Hx inum def' H4).
    intuition; try congruence.

    destruct_lift H0.
    edestruct tree_inodes_pathname_exists. 3: eauto.
    eapply tree_names_distinct_update_subtree; eauto.
    eapply tree_names_distinct_delete_from_list.
    eapply tree_names_distinct_subtree; eauto.

    eapply tree_inodes_distinct_update_subtree; eauto.
    eapply tree_inodes_distinct_delete_from_list.
    eapply tree_inodes_distinct_subtree; eauto.
    simpl. eapply incl_cons2.
    eapply tree_inodes_incl_delete_from_list.

    (* case A: inum inside tree' *)

    repeat deex.
    destruct (pathname_decide_prefix pathname x); repeat deex.

    (* case 1: in the directory *)
    erewrite find_subtree_app in *; eauto.
    eapply H11.

    eapply find_subtree_inum_present in H16; simpl in *.
    intuition. exfalso; eauto.

    (* case 2: outside the directory *)
    eapply H9.
    intro.
    edestruct tree_inodes_pathname_exists with (tree := TreeDir dnum tree_elem) (inum := dirtree_inum subtree).
    3: eassumption.

    eapply tree_names_distinct_subtree; eauto.
    eapply tree_inodes_distinct_subtree; eauto.

    destruct H20.
    destruct H20.

    eapply H6.
    exists x0.

    edestruct find_subtree_before_prune_general; eauto.

    eapply find_subtree_inode_pathname_unique.
    eauto. eauto.
    intuition eauto.
    erewrite find_subtree_app; eauto.
    intuition congruence.

    (* case B: outside original tree *)
    eapply H11; eauto.
    right.
    contradict H7; intuition eauto. exfalso; eauto.
    eapply tree_inodes_find_subtree_incl; eauto.
    simpl; intuition.
  Unshelve.
    all: eauto.
  Qed.

  Hint Extern 1 ({{_}} Bind (delete _ _ _ _) _) => apply delete_ok : prog.

  Theorem rename_cwd_ok : forall fsxp dnum srcpath srcname dstpath dstname mscs,
    {< F mbase m sm Fm Ftop tree tree_elem ilist frees,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs) sm hm *
           [[ (Fm * rep fsxp Ftop tree ilist frees mscs sm)%pred (list2nmem m) ]] *
           [[ tree = TreeDir dnum tree_elem ]]
    POST:hm' RET:^(mscs',r)
           exists m', LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m') (MSLL mscs') sm hm' *
           [[ MSAlloc mscs' = MSAlloc mscs ]] *
           ([[ isError r ]] \/
            [[ r = OK tt ]] * exists snum sents dnum dents subtree pruned tree' ilist' frees',
            [[ find_subtree srcpath tree = Some (TreeDir snum sents) ]] *
            [[ find_dirlist srcname sents = Some subtree ]] *
            [[ pruned = tree_prune snum sents srcpath srcname tree ]] *
            [[ find_subtree dstpath pruned = Some (TreeDir dnum dents) ]] *
            [[ tree' = tree_graft dnum dents dstpath dstname subtree pruned ]] *
            [[ (Fm * rep fsxp Ftop tree' ilist' frees' mscs' sm)%pred (list2nmem m') ]] *
            [[ dirtree_safe ilist  (BFILE.pick_balloc frees  (MSAlloc mscs')) tree
                            ilist' (BFILE.pick_balloc frees' (MSAlloc mscs')) tree' ]] *
            [[ forall inum' def', inum' <> snum -> inum' <> dnum ->
               (In inum' (tree_inodes tree') \/ (~ In inum' (tree_inodes tree))) ->
               selN ilist inum' def' = selN ilist' inum' def' ]] )
    CRASH:hm'
           LOG.intact fsxp.(FSXPLog) F mbase sm hm'
    >} rename fsxp dnum srcpath srcname dstpath dstname mscs.
  Proof.
    unfold rename, rep.

    (* extract some basic facts *)
    prestep; norm'l.
    assert (tree_inodes_distinct (TreeDir dnum tree_elem)) as HnID.
    eapply rep_tree_inodes_distinct with (m := list2nmem m).
    pred_apply; unfold rep; cancel.
    assert (tree_names_distinct (TreeDir dnum tree_elem)) as HiID.
    eapply rep_tree_names_distinct with (m := list2nmem m).
    pred_apply; unfold rep; cancel.

    (* namei srcpath, isolate root tree file before cancel *)
    subst; simpl in *.
    denote tree_dir_names_pred as Hx; assert (Horig := Hx).
    unfold tree_dir_names_pred in Hx; destruct_lift Hx.
    cancel.

    (* BFILE.rep in post condition of namei doesn't unify with  BFILE.rep in context,
       because namei may change cache content and promises a new BFILE.rep in its post
       condition, which we should use from now on. Should we clear the old BFILE.rep? *)
    denote! (_ (list2nmem m)) as Hm0; rewrite <- locked_eq in Hm0.

    instantiate (tree := TreeDir dnum tree_elem).
    unfold rep; simpl.
    unfold tree_dir_names_pred; cancel.
    all: eauto.

    (* lookup srcname, isolate src directory before cancel *)
    destruct_branch; [ | step ].
    destruct_branch; destruct_branch; [ | step ].

    prestep; norm'l.

    (* lock the old BFILE.rep again, but not the new one. *)
    denote! ( (Fm * BFILE.rep _ _ _ _ _ _ _ (MSCache mscs) _ _ * _)%pred (list2nmem m)) as Hm0; rewrite <- locked_eq in Hm0.

    intuition; inv_option_eq; repeat deex; destruct_pairs.
    denote find_name as Htree.
    apply eq_sym in Htree.
    apply find_name_exists in Htree.
    destruct Htree. intuition.

    denote find_subtree as Htree; assert (Hx := Htree).
    apply subtree_extract with (xp := fsxp) in Hx.
    denote tree_dir_names_pred as Hy; assert (Hsub := Hy).
    eapply pimpl_trans in Hsub; [ | | eapply pimpl_sep_star; [ apply pimpl_refl | apply Hx ] ];
      [ | cancel ]. clear Hx.
    destruct x; simpl in *; subst; try congruence.
    unfold tree_dir_names_pred in Hsub.
    destruct_lift Hsub.
    denote (_ |-> _)%pred as Hsub.

    safecancel.
    cancel. 2: eauto.

    (* unlink src *)
    step.

    (* lock an old BFILE.rep *)
    denote! ( ((Fm * BFILE.rep _ _ _ _ _ _ _ (MSCache a) _ _) * _)%pred (list2nmem m)) as Hm1; rewrite <- locked_eq in Hm1.

    (* namei for dstpath, find out pruning subtree before step *)
    denote (tree_dir_names_pred' l0 _) as Hx1.
    denote (_ |-> (_, _))%pred as Hx2.
    pose proof (ptsto_subtree_exists _ Hx1 Hx2) as Hx.
    destruct Hx; intuition.

    step; msalloc_eq.
    cancel.
    {
      cancel.
      match goal with |- context [(?inum_ |-> _)%pred] =>
        eapply pimpl_trans; [ eapply pimpl_trans; [ |
        eapply subtree_prune_absorb with (inum := inum_) (ri := dnum) (re := tree_elem) (xp := fsxp) (path := srcpath)
        ] | ]
      end.
      all: eauto using dir_names_pred_delete'.
      cancel.
    }
    rewrite tree_prune_preserve_inum; auto.
    rewrite tree_prune_preserve_isdir; auto.

    (* fold back predicate for the pruned tree in hypothesis as well  *)
    denote (list2nmem flist0) as Hinterm.
    apply helper_reorder_sep_star_2 in Hinterm.
    erewrite subtree_prune_absorb in Hinterm; eauto.
    2: apply dir_names_pred_delete'; auto.
    apply helper_reorder_sep_star_2 in Hinterm.
    rename x into mvtree.

    (* lookup dstname *)
    destruct_branch; [ | step ].
    destruct_branch; destruct_branch; [ | step ].

    (* lock an old BFILE.rep; we have a new one from namei *)
    denote! ( (_* BFILE.rep _ _ _ _ _ _ _ (MSCache a0) _ _)%pred (list2nmem m)) as Hm2; rewrite <- locked_eq in Hm2.

    prestep; norm'l.
    intuition; inv_option_eq; repeat deex; destruct_pairs.

    denote find_name as Hpruned.
    apply eq_sym in Hpruned.
    apply find_name_exists in Hpruned.
    destruct Hpruned. intuition.

    denote (list2nmem dummy9) as Hinterm1.
    denote find_subtree as Hpruned; assert (Hx := Hpruned).
    apply subtree_extract with (xp := fsxp) in Hx.
    assert (Hdst := Hinterm1); rewrite Hx in Hdst; clear Hx.
    destruct x; simpl in *; subst; try congruence; inv_option_eq.
    unfold tree_dir_names_pred in Hdst.
    destruct_lift Hdst.

    safecancel. eauto.

    denote! ( (Fm * _ * BFILE.rep _ _ _ _ _ _ _ (MSCache a4) _ _)%pred (list2nmem m')) as Hm3; rewrite <- locked_eq in Hm3.

    (* grafting back *)
    destruct_branch.

    (* case 1: dst exists, try delete *)
    prestep.
    norml; msalloc_eq.
    unfold stars; simpl; inv_option_eq.
    denote (tree_dir_names_pred' _ _) as Hx3.
    denote (_ |-> (_, _))%pred as Hx4.
    pose proof (ptsto_subtree_exists _ Hx3 Hx4) as Hx.
    destruct Hx; intuition.

    denote! ( ((Fm * BFILE.rep _ _ _ _ _ _ (MSAllocC a1) _ _ _) * _)%pred (list2nmem m')) as Hm4; rewrite <- locked_eq in Hm4.

    (* must unify [find_subtree] in [delete]'s precondition with
       the root tree node.  have to do this manually *)
    unfold rep; norm. cancel. intuition.
    pred_apply; norm. cancel. intuition.
    eassign (tree_prune v_1 l0 srcpath srcname (TreeDir dnum tree_elem)).
    (* it would have been nice if we could have used Hinterm, as the old
       proof did, but flist has changed because of caching, and we need to
       use the latest flist and fold things back together again. *)
    2: eauto.
    pred_apply.
    cancel.
    rewrite helper_reorder_sep_star_3.
    rewrite fold_back_dir_pred; eauto.
    rewrite helper_reorder_sep_star_4.
    rewrite subtree_fold; eauto.
    cancel.

    (* now, get ready for link *)
    destruct_branch; [ | step ].
    prestep; norml; inv_option_eq; msalloc_eq.
    denote mvtree as Hx. assert (Hdel := Hx).
    setoid_rewrite subtree_extract in Hx at 2.
    2: subst; eapply find_update_subtree; eauto.
    simpl in Hx; unfold tree_dir_names_pred in Hx; destruct_lift Hx.

    denote! ( _ (list2nmem m')) as Hm5; rewrite <- locked_eq in Hm5.
    cancel.
    eauto.

    eapply tree_pred_ino_goodSize; eauto.

    pred_apply' Hdel; cancel.

    safestep; msalloc_eq.
    or_l; cancel.
    or_r; cancel; eauto.
    eapply subtree_graft_absorb_delete; eauto.
    msalloc_eq.
    eapply dirtree_safe_rename_dest_exists; eauto.

    (* case 1: in the new tree *)
    denote BFILE.treeseq_ilist_safe as Hsafe.
    unfold BFILE.treeseq_ilist_safe in Hsafe; destruct Hsafe as [Hsafe0 Hsafe1].
    rewrite <- Hsafe1 by auto.

    denote (selN ilist _ _ = selN ilist' _ _) as Hi.
    eapply Hi; eauto.

    eapply prune_graft_preserves_inodes; eauto.

    (* case 2: out of the original tree *)
    denote BFILE.treeseq_ilist_safe as Hsafe.
    unfold BFILE.treeseq_ilist_safe in Hsafe; destruct Hsafe as [Hsafe0 Hsafe1].
    rewrite <- Hsafe1 by auto.

    denote (selN ilist _ _ = selN ilist' _ _) as Hi.
    eapply Hi; eauto.
    right. intros HH.
    eapply tree_inodes_incl_delete_from_dir in HH; eauto.
    unfold tree_prune in *.
    cbn in *; intuition.

    cancel.

    (* dst is None *)
    safestep.
    safestep.
    eapply tree_pred_ino_goodSize; eauto.
    denote (_ (list2nmem flist1)) as H'.
    pred_apply' H'; cancel.   (* Hinterm as above *)

    safestep; msalloc_eq.
    or_l; cancel.
    or_r; cancel; eauto.

    rewrite helper_reorder_sep_star_5.
    eapply subtree_graft_absorb; eauto.
    msalloc_eq.
    eapply dirtree_safe_rename_dest_none; eauto.
    eapply notindomain_not_in_dirents; eauto.

    denote BFILE.treeseq_ilist_safe as Hsafe.
    unfold BFILE.treeseq_ilist_safe in Hsafe; destruct Hsafe as [Hsafe0 Hsafe1].
    apply Hsafe1; auto.

    denote BFILE.treeseq_ilist_safe as Hsafe.
    unfold BFILE.treeseq_ilist_safe in Hsafe; destruct Hsafe as [Hsafe0 Hsafe1].
    apply Hsafe1; auto.

    cancel.
    cancel; auto.

    cancel.
    Unshelve.
    all: try exact unit.
    all: try solve [repeat econstructor].
    all: try eauto.
    all: cbv [Mem.EqDec]; decide equality.
  Qed.

  Theorem rename_ok : forall fsxp dnum srcpath srcname dstpath dstname mscs,
    {< F mbase sm m pathname Fm Ftop tree tree_elem ilist frees,
    PRE:hm LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m) (MSLL mscs) sm hm *
           [[ (Fm * rep fsxp Ftop tree ilist frees mscs sm)%pred (list2nmem m) ]] *
           [[ find_subtree pathname tree = Some (TreeDir dnum tree_elem) ]]
    POST:hm' RET:^(mscs',r)
           exists m', LOG.rep fsxp.(FSXPLog) F (LOG.ActiveTxn mbase m') (MSLL mscs') sm hm' *
           [[ MSAlloc mscs' = MSAlloc mscs ]] *
           ([[ isError r ]] \/
            [[ r = OK tt ]] *
            exists srcnum srcents dstnum dstents subtree pruned renamed tree' ilist' frees',
            [[ find_subtree srcpath (TreeDir dnum tree_elem) = Some (TreeDir srcnum srcents) ]] *
            [[ find_dirlist srcname srcents = Some subtree ]] *
            [[ pruned = tree_prune srcnum srcents srcpath srcname (TreeDir dnum tree_elem) ]] *
            [[ find_subtree dstpath pruned = Some (TreeDir dstnum dstents) ]] *
            [[ renamed = tree_graft dstnum dstents dstpath dstname subtree pruned ]] *
            [[ tree' = update_subtree pathname renamed tree ]] *
            [[ (Fm * rep fsxp Ftop tree' ilist' frees' mscs' sm)%pred (list2nmem m') ]] *
            [[ dirtree_safe ilist  (BFILE.pick_balloc frees  (MSAlloc mscs')) tree
                            ilist' (BFILE.pick_balloc frees' (MSAlloc mscs')) tree' ]] *
            [[ forall inum' def', inum' <> srcnum -> inum' <> dstnum ->
               In inum' (tree_inodes tree') ->
               selN ilist inum' def' = selN ilist' inum' def' ]] )
    CRASH:hm'
           LOG.intact fsxp.(FSXPLog) F mbase sm hm'
    >} rename fsxp dnum srcpath srcname dstpath dstname mscs.
  Proof.
    intros; eapply pimpl_ok2. apply rename_cwd_ok.

    intros; norml; unfold stars; simpl.
    rewrite rep_tree_distinct_impl in *.
    unfold rep in *; cancel.
    rewrite subtree_extract; eauto. simpl. instantiate (tree_elem0:=tree_elem). cancel.
    step.
    apply pimpl_or_r; right. cancel; eauto.
    rewrite <- subtree_absorb; eauto.
    cancel.
    rewrite tree_graft_preserve_inum; auto.
    rewrite tree_prune_preserve_inum; auto.
    rewrite tree_graft_preserve_isdir; auto.
    rewrite tree_prune_preserve_isdir; auto.
    eapply dirlist_safe_subtree; eauto.

    denote! (((Fm * BFILE.rep _ _ _ _ _ _ _ _ _ _) * IAlloc.rep _ _ _ _ _)%pred _) as Hm'.
    eapply pimpl_apply in Hm'.
    eapply rep_tree_names_distinct in Hm' as Hnames.
    eapply rep_tree_inodes_distinct in Hm' as Hinodes.
    2: unfold rep; cancel.
    2: rewrite <- subtree_absorb.
    2: cancel. 2: apply pimpl_refl. 2: eauto.
    2: rewrite tree_graft_preserve_inum; auto.
    2: rewrite tree_prune_preserve_inum; auto.
    2: rewrite tree_graft_preserve_isdir; auto.
    2: rewrite tree_prune_preserve_isdir; auto.

    edestruct tree_inodes_pathname_exists. 3: eauto. all: eauto.
    repeat deex.
    destruct (pathname_decide_prefix pathname x); repeat deex.

    (* case 1: inum inside tree' *)
    erewrite find_subtree_app in *; eauto.

    (* case 2: inum outside tree' *)
    denote (selN ilist _ _ = selN ilist' _ _) as Hilisteq.
    eapply Hilisteq; eauto.
    right. intros.

    denote ([[ tree_names_distinct _ ]]%pred) as Hlift. destruct_lift Hlift.
    edestruct find_subtree_update_subtree_oob_general; eauto.
    edestruct tree_inodes_pathname_exists with (tree := TreeDir dnum tree_elem) (inum := dirtree_inum subtree0) as [pn_conflict ?].
    eapply tree_names_distinct_subtree; [ | eauto ]; eauto.
    eapply tree_inodes_distinct_subtree; [ | | eauto ]; eauto.
    simpl; intuition.

    denote! (exists _, find_subtree _ _ = _ /\ dirtree_inum _ = dirtree_inum _) as Hx.
    destruct Hx.

    denote! (~ (exists _, _ = _ ++ _)) as Hsuffix.
    eapply Hsuffix.
    exists pn_conflict.

    eapply find_subtree_inode_pathname_unique with (tree := tree).
    eauto. eauto.

    intuition eauto.
    erewrite find_subtree_app by eauto; intuition eauto.
    intuition congruence.

  Grab Existential Variables.
    all: try exact unit.
    all: intros; eauto using BFILE.MSIAlloc.
    all: try solve [do 5 econstructor].
    all: try (cbv [Mem.EqDec]; decide equality).
    all: try exact emp.
    all: intros; try exact True.
  Qed.

  Hint Extern 1 ({{_}} Bind (rename _ _ _ _ _ _ _) _) => apply rename_ok : prog.

End DIRTREE.


From hahn Require Import Hahn.
Require Import Exec.
Require Import Events.

Section RfFunc.

Lemma init_dec exec E : {init exec E} + {~(init exec E)}.
Proof.
  destruct (IW exec) as [iw|] eqn:eqinit.
  - destruct (mev_eq_dec iw E).
    + subst. left. unfold init. rewrite eqinit. reflexivity.
    + right. intro. apply n. unfold init in H.
      rewrite eqinit in H. auto.
  - right. intro H. unfold init in H. rewrite eqinit in H.
    contradiction.
Qed.

Definition rf_func exec :=
  functional (rf exec)⁻¹.

Notation "a ²" := (a × a) (at level 1, format "a ²").

Definition aligned_and_no_overlap exec :=
  (EV exec)\₁(init exec) ⊆₁ aligned /\ overlap ∩ (EV exec \₁ init exec)² ⊆ same_loc.

Definition strong_tearfree e :=
  functional ((rf e) ∩ (((tearfree e)² ∩ same_loc) ∪ (init e × tearfree e)))⁻¹.

Definition unisized exec := aligned_and_no_overlap exec /\ strong_tearfree exec.

Lemma uni__tf exec :
  consistent exec ->
  unisized exec ->
  forall E, EV exec E -> tearfree exec E.
Proof.
  intros cst [[aligned nover] _] E EVE.
  destruct (init_dec exec E).
  - right. assumption.
  - left. split.
    + apply aligned.
      split; assumption.
    + assumption.
Qed.

Lemma uni__sameloc exec :
  well_formed exec ->
  unisized exec ->
  ⦗EV exec \₁ init exec⦘ ⨾ rf exec ⊆ same_loc.
Proof.
  intros wf alnoov X Y H.
  destruct (alnoov) as [[_ noov] _].
  unfolder in H.
  destruct H as [[EVX ninitX] rfXY].
  apply noov.
  split.
  - apply rf__overlap with exec; assumption.
  - destruct rfXY as [b [_ rfbXY]].
    destruct (wf_rfb_wr exec wf b) as [H _].
    apply H in rfbXY.
    unfolder in rfbXY.
    destruct rfbXY as [_ [_ WY]].
    destruct (WY).
    split; split; try assumption.
    intro initY.
    apply wf_iww in initY; try assumption.
    destruct initY.
    contradiction.
Qed.

Theorem rf_is_func exec :
  well_formed exec -> consistent exec ->
  unisized exec -> rf_func exec.
Proof.
  intros wf cst uni R.
  assert (forall W, rf exec W R ->
      ((tearfree exec)² ∩ same_loc ∪ init exec × tearfree exec) W R)
    as lemma.
  {
    intros W rfWR.
    assert (tearfree exec R). {
      apply uni__tf; try assumption.
      apply rf__ev in rfWR; try assumption.
      destruct rfWR.
      assumption.
    }
    assert (EV exec W). {
      apply rf__ev in rfWR; try assumption.
      destruct rfWR.
      assumption.
    }
    destruct (init_dec exec W) as [IW | nIW].
    + right. split; assumption.
    + left. split.
      * split; try assumption.
        apply uni__tf; assumption.
      * apply uni__sameloc with exec; try assumption.
        exists W.
        repeat (split; auto).
  }
  intros W1 W2.
  unfold transp.
  intros rf1 rf2.
  destruct (uni) as [[align noov] tf].
  apply tf with R;
  split;
  try assumption;
  apply lemma;
  assumption.
Qed.

End RfFunc.


Require Import Lia Setoid Program.Basics.
From hahn Require Import Hahn.
From PromisingLib Require Import Basic Language.
From imm Require Import Events Prog Execution ProgToExecution.
Require Import AuxDef.
Require Import AuxRel.
Require Import EventStructure.
Require Import LblStep.
Require Import ProgLoc.
Require Import Consistency.
Require Import EventToAction.

Set Implicit Arguments.
Local Open Scope program_scope.

Definition thread_lts (t : thread_id) : Language.t (list label) :=
  @Language.mk (list label)
    (list Instr.t) state
    init
    is_terminal
    (ilbl_step t).

Definition prog_init_threads (prog : Prog.t) :
  IdentMap.t {lang : Language.t (list label) & Language.state lang} :=
  IdentMap.mapi
    (fun tid (linstr : list Instr.t) =>
       existT _ (thread_lts tid) (ProgToExecution.init linstr))
    prog.

Definition stable_prog_type := IdentMap.t { linstr & stable_lprog linstr }.
Definition stable_prog_to_prog (prog : stable_prog_type) : Prog.t :=
  (IdentMap.map (fun x => projT1 x) prog).

Lemma stable_prog_to_prog_in prog thread :
  IdentMap.In thread (stable_prog_to_prog prog) <-> IdentMap.In thread prog.
Proof.
  unfold stable_prog_to_prog.
  eapply RegMap.Facts.map_in_iff.
Qed.

Lemma stable_prog_to_prog_no_init prog
      (PROG_NINIT : ~ IdentMap.In tid_init prog) :
  ~ IdentMap.In tid_init (stable_prog_to_prog prog).
Proof. by rewrite stable_prog_to_prog_in. Qed.

Definition prog_init_K
           (prog : stable_prog_type) :
  list (cont_label * {lang : Language.t (list label) & Language.state lang}) :=
  map
    (fun tidc =>
       let tid    := fst tidc in
       let linstr := projT1 (snd tidc) in
       let STBL   := projT2 (snd tidc) in
       let st'    := proj1_sig (get_stable
                                  tid (init linstr) STBL
                                  (rt_refl _ _ (init linstr))) in
       (CInit tid, existT _ (thread_lts tid) st'))
    (RegMap.elements prog).

Definition prog_l_es_init (prog : stable_prog_type) (locs : list location) :=
  ES.init (undup locs) (prog_init_K prog).

Definition prog_es_init (prog : stable_prog_type) :=
  prog_l_es_init prog (prog_locs (stable_prog_to_prog prog)).

Lemma prog_es_init_alt (prog : stable_prog_type) :
  prog_es_init prog = ES.init
                        (prog_locs (stable_prog_to_prog prog))
                        (prog_init_K prog).
Proof.
  unfold prog_es_init, prog_l_es_init, prog_locs.
  rewrite undup_nodup; eauto.
  apply NoDup_nodup.
Qed.

Definition g_locs (G : execution) :=
  undup (flatten (map (fun e =>
                         match e with
                         | InitEvent l => [l]
                         | _ => []
                         end)
                      (acts G))).

Definition prog_g_es_init prog (G : execution) :=
  prog_l_es_init prog (g_locs G).

Lemma prog_g_es_init_alt prog (G : execution) :
  prog_g_es_init prog G = ES.init (g_locs G) (prog_init_K prog).
Proof.
  unfold prog_g_es_init, prog_l_es_init, g_locs.
  rewrite undup_nodup; auto.
Qed.

Lemma prog_l_es_init_ninit locs prog :
  ES.acts_ninit_set (prog_l_es_init prog locs) ≡₁ ∅.
Proof.
  split; [|basic_solver].
  red. unfold prog_l_es_init, ES.init. intros x HH.
  apply HH. red. split; auto.
  apply HH.
Qed.

Lemma prog_g_es_init_ninit G prog :
  ES.acts_ninit_set (prog_g_es_init prog G) ≡₁ ∅.
Proof. apply prog_l_es_init_ninit. Qed.

Lemma prog_l_es_init_sb locs prog :
  ES.sb (prog_l_es_init prog locs) ≡ ∅₂.
Proof.
  split; [|basic_solver].
  unfold prog_l_es_init, ES.init. simpls.
Qed.

Lemma prog_g_es_init_sb G prog :
  ES.sb (prog_g_es_init prog G) ≡ ∅₂.
Proof. apply prog_l_es_init_sb. Qed.

Lemma prog_l_es_init_jf locs prog :
  ES.jf (prog_l_es_init prog locs) ≡ ∅₂.
Proof.
  split; [|basic_solver].
  unfold prog_l_es_init, ES.init. simpls.
Qed.

Lemma prog_g_es_init_jf G prog :
  ES.jf (prog_g_es_init prog G) ≡ ∅₂.
Proof. apply prog_l_es_init_jf. Qed.

Lemma prog_l_es_init_sw locs prog :
  sw (prog_l_es_init prog locs) ≡ ∅₂.
Proof.
  split; [|basic_solver].
  unfold sw. rewrite prog_l_es_init_jf. basic_solver.
Qed.

Lemma prog_g_es_init_sw G prog :
  sw (prog_g_es_init prog G) ≡ ∅₂.
Proof. apply prog_l_es_init_sw. Qed.

Lemma prog_l_es_init_hb locs prog :
  hb (prog_l_es_init prog locs) ≡ ∅₂.
Proof.
  split; [|basic_solver].
  unfold hb.
  rewrite prog_l_es_init_sw, prog_l_es_init_sb.
  rewrite ct_no_step; basic_solver.
Qed.

Lemma prog_g_es_init_hb G prog :
  hb (prog_g_es_init prog G) ≡ ∅₂.
Proof. apply prog_l_es_init_hb. Qed.

Lemma prog_l_es_init_cf locs prog :
  ES.cf (prog_l_es_init prog locs) ≡ ∅₂.
Proof.
  split; [|basic_solver].
  unfold ES.cf. rewrite prog_l_es_init_ninit. basic_solver.
Qed.

Lemma prog_g_es_init_cf G prog :
  ES.cf (prog_g_es_init prog G) ≡ ∅₂.
Proof. apply prog_l_es_init_cf. Qed.

Lemma prog_l_es_init_psc_f locs prog :
  psc_f (prog_l_es_init prog locs) Weakestmo ≡ ∅₂.
Proof.
  unfold psc_f.
  rewrite prog_l_es_init_hb.
  basic_solver.
Qed.

Lemma prog_l_es_init_scb locs prog :
  scb (prog_l_es_init prog locs) ≡ ∅₂.
Proof.
  unfold scb.
  unfold ES.fr, ES.rf.
  rewrite prog_l_es_init_sb.
  rewrite prog_l_es_init_hb.
  rewrite prog_l_es_init_jf.
  basic_solver.
Qed.

Lemma prog_l_es_init_psc_base locs prog :
  psc_base (prog_l_es_init prog locs) ≡ ∅₂.
Proof.
  unfold psc_base.
  rewrite prog_l_es_init_scb.
  basic_solver.
Qed.

Lemma prog_l_es_init_rmw locs prog :
  ES.rmw (prog_l_es_init prog locs) ≡ ∅₂.
Proof.
  split; [|basic_solver].
  unfold prog_l_es_init, ES.init. simpls.
Qed.

Hint Rewrite prog_g_es_init_ninit
     prog_g_es_init_sb
     prog_g_es_init_jf
     prog_g_es_init_sw
     prog_g_es_init_hb
     prog_g_es_init_cf
  : prog_g_es_init_db.

Hint Rewrite prog_l_es_init_ninit
     prog_l_es_init_sb
     prog_l_es_init_jf
     prog_l_es_init_sw
     prog_l_es_init_hb
     prog_l_es_init_cf
     prog_l_es_init_psc_f
     prog_l_es_init_psc_base
     prog_l_es_init_rmw
  : prog_l_es_init_db.

Lemma prog_l_es_init_consistent locs prog :
  @es_consistent (prog_l_es_init prog locs) Weakestmo.
Proof.
  constructor; unfold ecf, ES.jfe, ES.icf.
  all: autorewrite with prog_l_es_init_db; auto.
  (* 7: apply acyclic_disj. *)
  all: basic_solver.
Qed.

Lemma prog_g_es_init_consistent G prog :
  @es_consistent (prog_g_es_init prog G) Weakestmo.
Proof. apply prog_l_es_init_consistent. Qed.

Lemma prog_es_init_consistent prog :
  @es_consistent (prog_es_init prog) Weakestmo.
Proof. apply prog_l_es_init_consistent. Qed.

Lemma prog_l_es_init_act_in prog locs
      e (ACT : ES.acts_set (prog_l_es_init prog locs) e) :
  exists l,
    In (e, init_write l)
       (indexed_list
          (map init_write (undup locs))).
Proof.
  ins.
  assert
    (exists b,
        In (e, b) (indexed_list
                     (map init_write (undup locs))))
    as [b IN].
  { apply indexed_list_range. desf. }

  assert (In b (map init_write (undup locs)))
    as BIN.
  { clear -IN.
    apply In_map_snd in IN.
    rewrite <- indexed_list_map_snd; eauto. }

  apply in_map_iff in BIN. destruct BIN as [l [LB INL]].
  rewrite <- LB in *. simpls. desf.
  eauto.
Qed.

Lemma prog_g_es_init_act_in prog G
      e (ACT : ES.acts_set (prog_g_es_init prog G) e) :
  exists l,
    In (e, init_write l)
       (indexed_list
          (map init_write (g_locs G))).
Proof.
  apply prog_l_es_init_act_in in ACT.
  unfold g_locs in *.
  rewrite undup_nodup in ACT; auto.
Qed.

Lemma prog_l_es_init_act_lab prog locs
      e (ACT : ES.acts_set (prog_l_es_init prog locs) e) :
  exists l, ES.lab (prog_l_es_init prog locs) e = Astore Xpln Opln l 0.
Proof.
  apply prog_l_es_init_act_in in ACT. destruct ACT as [l LL].
  exists l. unfold ES.lab, prog_g_es_init, ES.init.
  apply l2f_in; desf.
  apply indexed_list_fst_nodup.
Qed.

Lemma prog_g_es_init_act_lab prog G
      e (ACT : ES.acts_set (prog_g_es_init prog G) e) :
  exists l, ES.lab (prog_g_es_init prog G) e = Astore Xpln Opln l 0.
Proof. by apply prog_l_es_init_act_lab. Qed.

Lemma prog_l_es_init_w locs prog :
  ES.acts_set (prog_l_es_init prog locs) ≡₁
  ES.acts_set (prog_l_es_init prog locs) ∩₁
  (fun a => is_true (is_w (ES.lab (prog_l_es_init prog locs)) a)).
Proof.
  split; [|basic_solver].
  unfolder. intros. split; auto.
  unfold is_w.
  apply prog_l_es_init_act_lab in H. desf.
Qed.

Lemma prog_g_es_init_w G prog :
  ES.acts_set (prog_g_es_init prog G) ≡₁
  ES.acts_set (prog_g_es_init prog G) ∩₁
  (fun a => is_true (is_w (ES.lab (prog_g_es_init prog G)) a)).
Proof. apply prog_l_es_init_w. Qed.

Lemma prog_l_es_seqn locs prog x : ES.seqn (prog_l_es_init prog locs) x = 0.
Proof.
  unfold ES.seqn. autorewrite with prog_l_es_init_db; eauto.
  relsf.
  apply countNatP_empty.
Qed.

Lemma prog_g_es_seqn G prog x : ES.seqn (prog_g_es_init prog G) x = 0.
Proof. apply prog_l_es_seqn. Qed.

Lemma prog_l_es_init_init locs prog :
  ES.acts_set (prog_l_es_init prog locs) ≡₁
  ES.acts_init_set (prog_l_es_init prog locs).
Proof. unfold ES.acts_init_set. simpls. basic_solver. Qed.

Lemma prog_es_init_init prog :
  ES.acts_set (prog_es_init prog) ≡₁
  ES.acts_init_set (prog_es_init prog).
Proof. apply prog_l_es_init_init. Qed.

Lemma prog_g_es_init_init G prog :
  ES.acts_set (prog_g_es_init prog G) ≡₁
  ES.acts_init_set (prog_g_es_init prog G).
Proof. apply prog_l_es_init_init. Qed.

Lemma length_nempty {A : Type} (l : list A) (nEmpty : l <> []) :
  0 < length l.
Proof.
  unfold length.
  destruct l.
  { intuition. }
  apply Nat.lt_0_succ.
Qed.

Lemma prog_l_es_init_nempty locs prog
      (nInitProg : ~ IdentMap.In tid_init prog)
      (nLocsEmpty : locs <> []) :
  ~ ES.acts_init_set (prog_l_es_init prog locs) ≡₁ ∅.
Proof.
  intros HH. eapply HH.
  apply prog_l_es_init_init.
  unfold ES.acts_set.
  unfold prog_l_es_init, ES.init.
  simpls.
  erewrite map_length.
  eapply length_nempty.
  by apply undup_nonnil.
Qed.

Lemma prog_g_es_init_nempty G prog
      (nInitProg : ~ IdentMap.In tid_init prog)
      (nLocsEmpty : g_locs G <> []) :
  ~ ES.acts_init_set (prog_g_es_init prog G) ≡₁ ∅.
Proof. by apply prog_l_es_init_nempty. Qed.

Lemma prog_l_es_init_wf locs prog
      (nInitProg : ~ IdentMap.In tid_init prog)
      (nLocsEmpty : locs <> []) :
  ES.Wf (prog_l_es_init prog locs).
Proof.
  assert
    (NoDup (map init_write (undup locs)))
    as NNDD.
  { apply nodup_map.
    2: { ins. intros HH. inv HH. }
    unfold g_locs. apply nodup_undup. }
  constructor.
  all: autorewrite with prog_l_es_init_db; auto.
  all: simpls.
  all: try basic_solver.
  { ins. red. exists b.
    splits; auto.
    red. split; auto. }
  { intros e [AA BB].
    eapply prog_l_es_init_act_lab; eauto. }
  { red. ins.
    destruct SX as [SX _]. apply prog_l_es_init_act_in in SX.
    destruct SY as [SY _]. apply prog_l_es_init_act_in in SY.
    desf.
    assert (l0 = l); subst.
    { unfold loc, init_write in *.
      erewrite l2f_in in EQ; eauto.
      2: by apply indexed_list_fst_nodup.
      erewrite l2f_in in EQ; eauto.
      2: by apply indexed_list_fst_nodup.
      desf. }
    eapply indexed_list_snd_nodup; eauto. }
  { apply prog_l_es_init_nempty; eauto. }
  { red. basic_solver. }
  { unfolder. ins. eexists.
    splits; eauto.
    2: by red.
    apply prog_l_es_seqn. }
  { rewrite prog_l_es_init_w. type_solver. }
  { intros ol a b [[EA _] WA] [[EB _] WB].
    set (CA := EA). apply prog_l_es_init_act_in in CA. desf.
    set (CB := EB). apply prog_l_es_init_act_in in CB. desf.
    assert (l0 = l); subst.
    { unfold loc, init_write in *.
      erewrite l2f_in in WB; eauto.
      2: by apply indexed_list_fst_nodup.
      erewrite l2f_in in WB; eauto.
      2: by apply indexed_list_fst_nodup.
      desf. }
    unfolder. ins. exfalso. apply nEW. splits; auto.
    clear -CA CB NNDD.
    eapply indexed_list_snd_nodup; eauto. }
  { split; [|basic_solver].
    unfolder. ins. desf. splits; auto.
    all: eapply prog_l_es_init_w; eauto.
    Unshelve. all: auto. }
  { intros HH. desf.
    unfold prog_l_es_init, ES.init, ES.cont_thread, ES.cont_set in *.
    simpls.
    unfold prog_init_K in KK.
    apply in_map_iff in KK.
    desf. destruct x as [tid k]; simpls; desf.
    apply RegMap.elements_complete in KK0.
    apply nInitProg.
    apply RegMap.Facts.in_find_iff.
    rewrite KK0. desf. }
  { intros HH. desf. inv RMW. }
  { unfold prog_l_es_init, ES.init, ES.cont_thread, ES.cont_set in *.
    simpls.
    unfold prog_init_K in *.
    ins.
    apply in_map_iff in CK. apply in_map_iff in CK'.
    desf.
    destruct x. destruct x0.
    apply RegMap.elements_complete in CK0.
    apply RegMap.elements_complete in CK'0.
    simpls; desf. }
  { ins. by apply prog_l_es_init_ninit in EE. }
  { ins. exfalso.
    red in inK.
    unfold prog_g_es_init, ES.init in *. simpls.
    unfold prog_init_K in *.
    apply in_map_iff in inK. desf. }
  ins. exfalso.
  unfold ES.cont_adjacent
    in ADJ.
  desc.
  unfold ES.cont_set,
         ES.cont,
         prog_g_es_init,
         prog_init_K
    in KK'.
  simpl in KK'.
  apply in_map_iff in KK'.
  destruct KK' as [HA [HB HC]].
  inversion HB. congruence.
Qed.

Lemma prog_g_es_init_wf G prog
      (nInitProg : ~ IdentMap.In tid_init prog)
      (nLocsEmpty : g_locs G <> []) :
  ES.Wf (prog_g_es_init prog G).
Proof. by apply prog_l_es_init_wf. Qed.

Lemma prog_es_init_wf prog
      (nInitProg : ~ IdentMap.In tid_init prog)
      (nLocsEmpty : prog_locs (stable_prog_to_prog prog) <> []) :
  ES.Wf (prog_es_init prog).
Proof. by apply prog_l_es_init_wf. Qed.

Lemma prog_g_es_init_same_lab prog G (WF : Wf G) :
  eq_dom (ES.acts_set (prog_g_es_init prog G))
         (ES.lab (prog_g_es_init prog G))
         (Execution.lab G ∘ e2a (prog_g_es_init prog G)).
Proof.
  red. ins.
  arewrite (undup (g_locs G) = g_locs G).
  { unfold g_locs. rewrite undup_nodup; auto. }
  unfold compose.

  apply prog_g_es_init_act_in in DX. desf.
  rewrite prog_g_es_init_alt.
  unfold e2a, ES.init, ES.acts_set in *; simpls; desf.
  unfold Events.loc.
  erewrite l2f_in; [|by apply indexed_list_fst_nodup|by eauto].
  simpls. rewrite wf_init_lab; auto.
Qed.

Lemma prog_l_es_init_K prog locs k state
      (INK : ES.cont_set
               (prog_l_es_init prog locs)
               (k, existT _
                     (thread_lts (ES.cont_thread (prog_l_es_init prog locs)
                                                 k))
                     state)) :
  exists thread,
    ⟪ KTID  : k = CInit thread ⟫ /\
    ⟪ STEPS : (istep thread [])＊ (init (instrs state)) state ⟫ /\
    ⟪ STBL  : stable_state state ⟫.
Proof.
  assert (forall A B (c : A) (a b : B)
                 (OO : (c, a) = (c, b)), a = b) as OO.
  { ins. inv OO. }
  ins. red in INK.
  unfold prog_l_es_init, ES.init, prog_init_K, ES.cont_thread in *.
  simpls.
  apply in_map_iff in INK. desc. inv INK.
  destruct x. simpls. desf.
  apply OO in INK.
  inv INK.
  destruct s; simpls.
  eexists; splits; eauto.
  all: pose (AA :=
               @proj2_sig
                 _ _
                 (get_stable t (init x) s
                             (rt_refl state (step t) (init x)))).
  arewrite
    (instrs
       (proj1_sig
          (get_stable t (init x) s (rt_refl state (step t) (init x)))) =
     instrs (init x)).
  all: red in AA; desf.
  eapply steps_same_instrs; eauto.
  apply eps_steps_in_steps. eauto.
Qed.

Lemma prog_g_es_init_K prog G k state
      (INK : ES.cont_set
               (prog_g_es_init prog G)
               (k, existT _
                     (thread_lts (ES.cont_thread (prog_g_es_init prog G)
                                                 k))
                     state)) :
  exists thread,
    ⟪ KTID  : k = CInit thread ⟫ /\
    ⟪ STEPS : (istep thread [])＊ (init (instrs state)) state ⟫ /\
    ⟪ STBL  : stable_state state ⟫.
Proof. by apply prog_l_es_init_K. Qed.

Lemma prog_l_es_init_lab prog locs e :
  << ELAB : ES.lab (prog_l_es_init prog locs) e = Afence Orlx >> \/
  exists l,
  << ELAB : ES.lab (prog_l_es_init prog locs) e = init_write l >>.
Proof.
  unfold prog_l_es_init, ES.init. simpls.
  unnw.
  edestruct @l2f_v with (A:=nat)
                        (l:=indexed_list (map init_write (undup locs)))
                        (a:=e)
                        (DEC:=Nat.eq_dec).
  { apply indexed_list_fst_nodup. }

  2: { desf. left. eauto. }
  desf. right.
  generalize dependent e.
  unfold indexed_list in *.
  remember 0 as n. clear Heqn.
  generalize dependent n.
  induction (undup locs); simpls.
  ins. desf; eauto.
Qed.

Lemma prog_g_es_init_lab prog G e :
  << ELAB : ES.lab (prog_g_es_init prog G) e = Afence Orlx >> \/
  exists l,
  << ELAB : ES.lab (prog_g_es_init prog G) e = init_write l >>.
Proof. apply prog_l_es_init_lab. Qed.

Lemma traverse_map_indexed_list {A B} (f : A -> B) l :
  indexed_list (map f l) =
  map (fun p : nat * A => let (a, b) := p in (a, f b))
      (indexed_list l).
Proof.
  unfold indexed_list in *.
  remember 0 as n. clear Heqn.
  generalize dependent n.
  induction l; simpls.
  congruence.
Qed.

Lemma prog_l_es_init_init_loc prog locs :
  (fun l => In l locs) ≡₁ ES.init_loc (prog_l_es_init prog locs).
Proof.
  split.
  { intros l L_IN.
    apply in_undup_iff in L_IN.
    specialize (indexed_list_in_exists l (undup locs) L_IN) as [e Foo].
    exists e. splits.
    { apply prog_l_es_init_init.
      unfold prog_l_es_init, ES.init.
      unfold ES.acts_set, ES.next_act. rewrite length_map.
      apply indexed_list_range. eauto. }
    unfold prog_l_es_init, ES.init. simpl.
    unfold Events.loc.
    arewrite ((list_to_fun
                 Nat.eq_dec
                 (Afence Orlx)
                 (indexed_list (map init_write (undup locs)))) e =
              init_write l); [|done].
    apply l2f_in.
    { apply indexed_list_fst_nodup. }
    rewrite traverse_map_indexed_list.
    eapply in_map with
        (f := (fun p : nat * location => let (a, b) := p in (a, init_write b))) in Foo.
    auto. }
  intros l [a HH]. desf.
  unfold prog_l_es_init, ES.init, ES.lab in LOCA.
  specialize (l2f_codom (indexed_list (map init_write (undup locs)))
                        a
                        (Afence Orlx) Nat.eq_dec) as RR.
  desf; unfold loc in LOCA; desf.
  all: rewrite traverse_map_indexed_list in RR;
    apply in_map_iff in RR; desf.
  apply In_map_snd in RR0.
  rewrite indexed_list_map_snd in RR0.
  by apply in_undup_iff.
Qed.

Lemma prog_g_init_init_loc prog G :
  (fun l => In l (g_locs G)) ≡₁ ES.init_loc (prog_g_es_init prog G).
Proof. by apply prog_l_es_init_init_loc. Qed.

Lemma prog_es_init_init_loc prog :
  (fun l => In l (prog_locs (stable_prog_to_prog prog))) ≡₁ ES.init_loc (prog_es_init prog).
Proof. by apply prog_l_es_init_init_loc. Qed.


From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.
From PromisingLib Require Import Language.

From PromisingLib Require Import Event.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import FulfillStep.

Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import SimThread.

Require Import SplitAcqCommon.

Set Implicit Arguments.

Definition local_acqrel (lc:Local.t) :=
  (Local.mk (TView.write_fence_tview
               (TView.read_fence_tview (Local.tview lc) Ordering.acqrel)
               TimeMap.bot
               Ordering.acqrel)
            (Local.promises lc)).

Lemma sim_local_promise_acqrel
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      lc2_tgt mem2_tgt
      loc from to msg kind
      (STEP_TGT: Local.promise_step lc1_tgt mem1_tgt loc from to msg lc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local SimPromises.bot lc1_src (local_acqrel lc1_tgt))
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src mem2_src,
    <<STEP_SRC: Local.promise_step lc1_src mem1_src loc from to msg lc2_src mem2_src kind>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src (local_acqrel lc2_tgt)>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  inv LOCAL1. inv STEP_TGT.
  exploit SimPromises.promise_bot; eauto.
  { apply WF1_SRC. }
  { apply WF1_TGT. }
  i. des.
  exploit Memory.promise_future; try apply PROMISE_SRC; try apply WF1_SRC; eauto.
  { destruct msg; ss. inv CLOSED. econs.
    eapply sim_memory_closed_opt_view; eauto. }
  i. des.
  esplits; eauto.
  - econs; eauto.
    destruct msg; ss. inv CLOSED. econs.
    eapply sim_memory_closed_opt_view; eauto.
  - econs; eauto.
Qed.

Lemma sim_local_fulfill_acqrel
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt
      loc from to val releasedm_src releasedm_tgt released ord_src ord_tgt
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_WF: View.opt_wf releasedm_src)
      (RELM_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (RELM_TGT: Time.le (View.rlx (View.unwrap releasedm_tgt) loc) from)
      (WF_RELM_TGT: View.opt_wf releasedm_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (ORD_TGT: Ordering.le ord_tgt Ordering.acqrel)
      (STEP_TGT: fulfill_step lc1_tgt sc1_tgt loc from to val releasedm_tgt released ord_tgt lc2_tgt sc2_tgt)
      (LOCAL1: sim_local SimPromises.bot lc1_src (local_acquired lc1_tgt))
      (ACQUIRED1: View.le (TView.cur (Local.tview lc1_src))
                          (View.join (TView.cur (Local.tview lc1_tgt)) (View.unwrap releasedm_tgt)))
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src sc2_src,
    <<STEP_SRC: fulfill_step lc1_src sc1_src loc from to val releasedm_src released ord_src lc2_src sc2_src>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src (local_acqrel lc2_tgt)>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>>.
Proof.
  inv STEP_TGT.
  assert (RELT_LE:
   View.opt_le
     (TView.write_released (Local.tview lc1_src) sc1_src loc to releasedm_src ord_src)
     (TView.write_released (Local.tview lc1_tgt) sc2_tgt loc to releasedm_tgt ord_tgt)).
  { unfold TView.write_released, TView.write_tview. ss. viewtac.
    repeat (condtac; aggrtac;
            try match goal with
                | [|- View.opt_le _ _] => econs
                end);
      try apply WF1_TGT.
    - etrans; eauto. aggrtac.
    - etrans; [apply WF1_SRC|]. etrans; eauto. aggrtac.
    - etrans; [apply LOCAL1|]. aggrtac.
  }
  assert (RELT_WF:
   View.opt_wf (TView.write_released (Local.tview lc1_src) sc1_src loc to releasedm_src ord_src)).
  { unfold TView.write_released. condtac; econs.
    repeat (try condtac; viewtac; try apply WF1_SRC).
  }
  exploit SimPromises.remove_bot; try exact REMOVE;
    try exact MEM1; try apply LOCAL1; eauto.
  i. des. esplits.
  - econs; eauto.
    inv WRITABLE. econs.
    eapply TimeFacts.le_lt_lt; [apply ACQUIRED1|]. viewtac.
    eapply TimeFacts.le_lt_lt; eauto.
  - econs; eauto. s.
    unfold TView.write_tview, TView.write_fence_tview, TView.read_fence_tview. ss.
    econs; ss; repeat (condtac; aggrtac).
    all: try by destruct ord_src, ord_tgt.
    all: try by apply WF1_TGT.
    + etrans; [apply LOCAL1|]. repeat (try condtac; aggrtac).
    + etrans; [apply LOCAL1|]. aggrtac.
      etrans; [apply WF1_TGT|]. etrans; [apply WF1_TGT|]. aggrtac.
    + etrans; [apply LOCAL1|]. aggrtac.
      etrans; [apply WF1_TGT|]. etrans; [apply WF1_TGT|]. aggrtac.
    + etrans; [apply LOCAL1|]. repeat (try condtac; aggrtac).
      etrans; [apply WF1_TGT|]. etrans; [apply WF1_TGT|]. aggrtac.
    + etrans; [apply LOCAL1|]. ss. condtac; aggrtac.
    + etrans; [apply LOCAL1|]. aggrtac.
  - ss.
Qed.

Lemma sim_local_write_acqrel
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt mem2_tgt
      loc from to val releasedm_src releasedm_tgt released_tgt ord_src ord_tgt kind
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_SRC_WF: View.opt_wf releasedm_src)
      (RELM_SRC_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (RELM_TGT_WF: View.opt_wf releasedm_tgt)
      (RELM_TGT_CLOSED: Memory.closed_opt_view releasedm_tgt mem1_tgt)
      (RELM_TGT: Time.le (View.rlx (View.unwrap releasedm_tgt) loc) from)
      (ORD: Ordering.le ord_src ord_tgt)
      (ORD_TGT: Ordering.le ord_tgt Ordering.acqrel)
      (STEP_TGT: Local.write_step lc1_tgt sc1_tgt mem1_tgt loc from to val releasedm_tgt released_tgt ord_tgt lc2_tgt sc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local SimPromises.bot lc1_src (local_acquired lc1_tgt))
      (ACQUIRED1: View.le (TView.cur (Local.tview lc1_src))
                          (View.join (TView.cur (Local.tview lc1_tgt)) (View.unwrap releasedm_tgt)))
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists released_src lc2_src sc2_src mem2_src,
    <<STEP_SRC: Local.write_step lc1_src sc1_src mem1_src loc from to val releasedm_src released_src ord_src lc2_src sc2_src mem2_src kind>> /\
    <<REL2: View.opt_le released_src released_tgt>> /\
    <<LOCAL2: sim_local SimPromises.bot lc2_src (local_acqrel lc2_tgt)>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  exploit write_promise_fulfill; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit sim_local_promise_acquired; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  hexploit sim_local_fulfill_acqrel; try apply STEP2;
    try apply LOCAL2; try apply MEM2; eauto.
  { eapply Memory.future_closed_opt_view; eauto. }
  { inv STEP_SRC. inv STEP1. ss. }
  i. des.
  exploit promise_fulfill_write_sim_memory; try exact STEP_SRC; try exact STEP_SRC0; eauto.
  { i. hexploit ORD0; eauto.
    i. des. splits; auto. eapply sim_local_nonsynch_loc; eauto.
  }
  i. des. esplits; eauto. etrans; eauto.
Qed.


Require Import AutoSep Malloc Bootstrap CountUnique.

Module Type S.
  Variable heapSize : nat.
End S.

Module Make(M : S).
Import M.

Section boot.
  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.

  Definition size := heapSize + 50 + 0.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize * 4).
    goodSize.
  Qed.

  Definition bootS := bootS heapSize 0.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "top"!"top" @ [topS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%nat;;

        Assert [PREonly[_] 0 =?> heapSize];;

        Call "malloc"!"init"(0, heapSize)
        [PREonly[_] mallocHeap 0];;

        Call "top"!"top"()
        [PREonly[_] [| False |] ]
      end
    }}.

  Theorem ok : moduleOk boot.
    vcgen; abstract genesis.
  Qed.

  Require ExampleImpl.

  Definition m0 := link ExampleImpl.m boot.
  Definition m1 := link all m0.

  Lemma ok0 : moduleOk m0.
    link ExampleImpl.ok ok.
  Qed.

  Lemma ok1 : moduleOk m1.
    link all_ok ok0.
  Qed.

  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m1)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m1)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis mem_low : forall n, (n < size * 4)%nat -> st.(Mem) n <> None.
  Hypothesis mem_high : forall w, ($(size * 4) <= w)%word -> st.(Mem) w = None.

  Theorem safe : sys_safe stn prog (w, st).
    safety ok1.
  Qed.
End boot.

End Make.


From iris.proofmode Require Import tactics.
From iris.program_logic Require Export weakestpre.
From iris.heap_lang Require Export lang.
From iris.heap_lang Require Import proofmode notation.
From iris Require Import options.

Definition assert : val :=
  λ: "v", if: "v" #() then #() else #0 #0. (* #0 #0 is unsafe *)
(* just below ;; *)
Notation "'assert:' e" := (assert (λ: <>, e)%E) (at level 99) : expr_scope.
Notation "'assert:' e" := (assert (λ: <>, e)%V) (at level 99) : val_scope.

Lemma twp_assert `{!heapG Σ} E (Φ : val → iProp Σ) e :
  WP e @ E [{ v, ⌜v = #true⌝ ∧ Φ #() }] -∗
  WP (assert: e)%V @ E [{ Φ }].
Proof.
  iIntros "HΦ". wp_lam.
  wp_apply (twp_wand with "HΦ"). iIntros (v) "[% ?]"; subst. by wp_if.
Qed.

Lemma wp_assert `{!heapG Σ} E (Φ : val → iProp Σ) e :
  WP e @ E {{ v, ⌜v = #true⌝ ∧ ▷ Φ #() }} -∗
  WP (assert: e)%V @ E {{ Φ }}.
Proof.
  iIntros "HΦ". wp_lam.
  wp_apply (wp_wand with "HΦ"). iIntros (v) "[% ?]"; subst. by wp_if.
Qed.


Require Import RGref.DSL.DSL.
Require Import Coq.Arith.Arith.

Section MemoTable.

  (* Apparently the instances below stick around after the section ends... *)
  Variable B : nat -> Set.
  Variable f : forall (x:nat), B x.
  Parameter safe_f : Safe f.
  Existing Instance safe_f.
  Parameter safe_B : Safe B.
  Existing Instance safe_B.

  Definition prefernat {P:nat->Set}(g:forall x:nat, P x)(a:nat) : forall x:nat, P x.
    refine(let v := g a in
             (fun x => if eq_nat_dec x a then _ else g x)).
    subst. exact v.
  Defined.
  Print prefernat.

  Definition obs_equiv {A:Set}{P:A->Set}(f g:forall x, P x)(_ _:heap) :=
    forall x, f x = g x.
  Lemma obs_eq_refl : forall A P, hreflexive (@obs_equiv A P).
  Proof. intros; red. compute. eauto. Qed.
  Hint Resolve obs_eq_refl.
  Lemma precise_obs_equiv : precise_rel (@obs_equiv nat (fun _ => nat)).
  Proof. compute. intuition. Qed.
  Hint Resolve precise_obs_equiv.

  Instance safe_prefernat : Safe (@prefernat).
(*  Instance prior_safe (r:ref{forall x:nat,B x|any}[obs_equiv,obs_equiv]) (n:nat)
    : Safe (@prefernat B (@deref _ _ _ _ _ _ (obs_eq_refl _ _) eq_refl r) n). *)
  Instance prior_safe (r:ref{forall x:nat,B x|any}[obs_equiv,obs_equiv]) (n:nat)
                              : ESafe 0 (@prefernat B f n).
    repeat solve_applications.
  Defined.

  Program Definition prioritize {Γ} (r:ref{forall x:nat,B x|any}[obs_equiv,obs_equiv]) (n:nat) : rgref Γ unit Γ :=
    [r]:= prefernat (!r) n.
  Next Obligation.
    repeat solve_applications.
  Qed.
  Next Obligation.
    red. unfold prefernat. intros. induction (eq_nat_dec x n); intuition; eauto.
    subst. compute. eauto.
  Qed.
(* Doesn't (and shouldn't!) typecheck *)
  Program Example should_not_typecheck {Γ} (r:ref{nat|any}[havoc,havoc]) : rgref Γ (ref{nat->nat|any}[havoc,havoc]) Γ :=
    Alloc (fun x => !r). (*;
    prioritize _ r 0.
  (*Print should_not_typecheck.*)
*)
  Next Obligation. compute; eauto. Defined.
  Next Obligation.
    (* Cannot typecheck because (λ x:N. !r) is in fact not safe! *)
  Admitted.

End MemoTable.