Require Import compcert.lib.Axioms.

Require Import concurrency.sepcomp. Import SepComp.
Require Import sepcomp.semantics_lemmas.

Require Import concurrency.pos.
Require Import concurrency.scheduler.
Require Import concurrency.TheSchedule.
Require Import concurrency.concurrent_machine.
Require Import concurrency.addressFiniteMap. (*The finite maps*)
Require Import concurrency.pos.
Require Import concurrency.lksize.
Require Import concurrency.permjoin_def.
Require Import Coq.Program.Program.
From mathcomp.ssreflect Require Import ssreflect ssrbool ssrnat ssrfun eqtype seq fintype finfun.
Set Implicit Arguments.

(*NOTE: because of redefinition of [val], these imports must appear
  after Ssreflect eqtype.*)
Require Import compcert.common.AST.     (*for typ*)
Require Import compcert.common.Values. (*for val*)
Require Import compcert.common.Globalenvs.
Require Import compcert.common.Memory.
Require Import compcert.lib.Integers.
Require Import concurrency.threads_lemmas.
Require Import concurrency.semantics.
Require Import concurrency.TheSchedule. Import TheSchedule.

Require Import Coq.ZArith.ZArith.

Require Import concurrency.permissions.
Require Import concurrency.bounded_maps.
Require Import concurrency.threadPool.

Module LocksAndResources.
  (** Dry resources are a permission map for non-lock locations and one for lock
  locations*)
  Definition res := (access_map * access_map)%type.
  Definition lock_info := (access_map * access_map)%type.
End LocksAndResources.

Module ThreadPool (SEM:Semantics)  <: ThreadPoolSig
    with Module TID:= NatTID with Module SEM:=SEM
    with Module RES := LocksAndResources.

    Include (OrdinalPool SEM LocksAndResources).

End ThreadPool.

Module Concur.

  Module mySchedule := THESCH.

  (** The type of dry machines. This is basically the same as
  [ConcurrentMachineSig] but resources are instantiated with dry
  resources*)
  Module Type DryMachineSig  (SEM: Semantics) <: ConcurrentMachineSig
      with Module ThreadPool.RES:= LocksAndResources
      with Module ThreadPool.TID:=mySchedule.TID.

     Declare Module Events : EventSig.
     Module ThreadPool := ThreadPool SEM.
     Import ThreadPool SEM.
     Import event_semantics Events.

     (** Memories*)
     Definition richMem: Type:= mem.
     Definition dryMem: richMem -> mem:= id.
     Definition diluteMem: mem -> mem := setMaxPerm.

     Notation thread_pool := (ThreadPool.t).

     (** The state respects the memory*)
     Record mem_compatible' tp m : Prop :=
       { compat_th :> forall {tid} (cnt: containsThread tp tid),
             permMapLt (getThreadR cnt).1 (getMaxPerm m) /\
             permMapLt (getThreadR cnt).2 (getMaxPerm m);
         compat_lp : forall l pmaps, lockRes tp l = Some pmaps ->
                                permMapLt pmaps.1 (getMaxPerm m) /\
                                permMapLt pmaps.2 (getMaxPerm m);
         lockRes_blocks: forall l rmap, lockRes tp l = Some rmap ->
                                   Mem.valid_block m l.1}.

     Definition mem_compatible tp m : Prop := mem_compatible' tp m.

     Record invariant' tp :=
       { no_race_thr :
           forall i j (cnti: containsThread tp i) (cntj: containsThread tp j)
             (Hneq: i <> j),
             permMapsDisjoint2 (getThreadR cnti)
                              (getThreadR cntj); (*thread's resources are disjoint *)
         no_race_lr:
           forall laddr1 laddr2 rmap1 rmap2
             (Hneq: laddr1 <> laddr2)
             (Hres1: lockRes tp laddr1 = Some rmap1)
             (Hres2: lockRes tp laddr2 = Some rmap2),
             permMapsDisjoint2 rmap1 rmap2; (*lock's resources are disjoint *)
         no_race:
           forall i laddr (cnti: containsThread tp i) rmap
             (Hres: lockRes tp laddr = Some rmap),
             permMapsDisjoint2 (getThreadR cnti) rmap; (*resources are disjoint
             between threads and locks*)
         (* an address is in the lockres if there is at least one >= Readable
         lock permission - I am writing the weak version where this is required
         only for permissions of threads*)
         (* lock_res_perm: *)
         (*   forall b ofs, *)
         (*     (exists i (cnti: containsThread tp i), *)
         (*         Mem.perm_order' ((getThreadR cnti).2 !! b ofs) Readable) ->  *)
         (*     lockRes tp (b, ofs); *)

         (* if an address is a lock then there can be no data
             permission above non-empty for this address*)
         thread_data_lock_coh:
           forall i (cnti: containsThread tp i),
             (forall j (cntj: containsThread tp j),
                permMapCoherence (getThreadR cntj).1 (getThreadR cnti).2) /\
             (forall laddr rmap,
                 lockRes tp laddr = Some rmap ->
                 permMapCoherence rmap.1 (getThreadR cnti).2);
         locks_data_lock_coh:
           forall laddr rmap
             (Hres: lockRes tp laddr = Some rmap),
             (forall j (cntj: containsThread tp j),
                 permMapCoherence (getThreadR cntj).1 rmap.2) /\
             (forall laddr' rmap',
                 lockRes tp laddr' = Some rmap' ->
                 permMapCoherence rmap'.1 rmap.2);
         lockRes_valid: lr_valid (lockRes tp) (*well-formed locks*)
       }.

     Definition invariant := invariant'.
     Parameter threadStep :
       G ->
       forall tid0 (ms : t) (m : mem),
         containsThread ms tid0 ->
         mem_compatible ms m -> t -> mem -> seq mem_event -> Prop.

     Axiom threadStep_equal_run:
    forall g i tp m cnt cmpt tp' m' tr,
      @threadStep g i tp m cnt cmpt tp' m' tr ->
      forall j,
        (exists cntj q, @getThreadC j tp cntj = Krun q) <->
        (exists cntj' q', @getThreadC j tp' cntj' = Krun q').
     Parameter syncStep :
       bool -> (* if it's a Coarse machine. Temp solution to propagating changes. *)
       G ->
       forall tid0 (ms : t) (m : mem),
         containsThread ms tid0 ->
         mem_compatible ms m -> t -> mem -> sync_event -> Prop.

  Axiom syncstep_equal_run:
    forall b g i tp m cnt cmpt tp' m' tr,
      @syncStep b g i tp m cnt cmpt tp' m' tr ->
      forall j,
        (exists cntj q, @getThreadC j tp cntj = Krun q) <->
        (exists cntj' q', @getThreadC j tp' cntj' = Krun q').

  Axiom syncstep_not_running:
    forall b g i tp m cnt cmpt tp' m' tr,
      @syncStep b g i tp m cnt cmpt tp' m' tr ->
      forall cntj q, ~ @getThreadC i tp cntj = Krun q.

     Parameter threadHalted :
       forall tid0 (ms : t), containsThread ms tid0 -> Prop.
     Parameter init_mach : option RES.res -> G -> val -> seq val -> option t.

  Axiom threadHalt_update:
    forall i j, i <> j ->
      forall tp cnt cnti c' cnt',
        (@threadHalted j tp cnt) <->
        (@threadHalted j (@updThreadC i tp cnti c') cnt') .

  Axiom syncstep_equal_halted:
    forall b g i tp m cnti cmpt tp' m' tr,
      @syncStep b g i tp m cnti cmpt tp' m' tr ->
      forall j cnt cnt',
        (@threadHalted j tp cnt) <->
        (@threadHalted j tp' cnt').

  Axiom threadStep_not_unhalts:
    forall g i tp m cnt cmpt tp' m' tr,
      @threadStep g i tp m cnt cmpt tp' m' tr ->
      forall j cnt cnt',
        (@threadHalted j tp cnt) ->
        (@threadHalted j tp' cnt') .

  End DryMachineSig.

  Module DryMachineShell (SEM:Semantics)  <: DryMachineSig SEM.

     Module Events := Events.
     Module ThreadPool := ThreadPool SEM.
     Import ThreadPool.
     Import ThreadPool.SEM ThreadPool.RES.
     Import event_semantics Events.

     Notation tid := NatTID.tid.

     (** Memories*)
     Definition richMem: Type:= mem.
     Definition dryMem: richMem -> mem:= id.
     Definition diluteMem: mem -> mem := setMaxPerm.

     Notation thread_pool := (ThreadPool.t).

     (** The state respects the memory*)

     Record mem_compatible' tp m : Prop :=
       { compat_th :> forall {tid} (cnt: containsThread tp tid),
             permMapLt (getThreadR cnt).1 (getMaxPerm m) /\
             permMapLt (getThreadR cnt).2 (getMaxPerm m);
         compat_lp : forall l pmaps, lockRes tp l = Some pmaps ->
                                permMapLt pmaps.1 (getMaxPerm m) /\
                                permMapLt pmaps.2 (getMaxPerm m);
         lockRes_blocks: forall l rmap, lockRes tp l = Some rmap ->
                                   Mem.valid_block m l.1}.

     Definition mem_compatible tp m : Prop := mem_compatible' tp m.

     (* should there be something that says that if something is a lock then
     someone has at least readable permission on it?*)
     Record invariant' tp :=
       { no_race_thr :
           forall i j (cnti: containsThread tp i) (cntj: containsThread tp j)
             (Hneq: i <> j),
             permMapsDisjoint2 (getThreadR cnti)
                              (getThreadR cntj); (*thread's resources are disjoint *)
         no_race_lr:
           forall laddr1 laddr2 rmap1 rmap2
             (Hneq: laddr1 <> laddr2)
             (Hres1: lockRes tp laddr1 = Some rmap1)
             (Hres2: lockRes tp laddr2 = Some rmap2),
             permMapsDisjoint2 rmap1 rmap2; (*lock's resources are disjoint *)
         no_race:
           forall i laddr (cnti: containsThread tp i) rmap
             (Hres: lockRes tp laddr = Some rmap),
             permMapsDisjoint2 (getThreadR cnti) rmap; (*resources are disjoint
             between threads and locks*)
         (* an address is in the lockres if there is at least one >= Readable
         lock permission - I am writing the weak version where this is required
         only for permissions of threads*)
         (* lock_res_perm: *)
         (*   forall b ofs, *)
         (*     (exists i (cnti: containsThread tp i), *)
         (*         Mem.perm_order' ((getThreadR cnti).2 !! b ofs) Readable) ->  *)
         (*     lockRes tp (b, ofs); *)

         (* if an address is a lock then there can be no data
             permission above non-empty for this address*)
         thread_data_lock_coh:
           forall i (cnti: containsThread tp i),
             (forall j (cntj: containsThread tp j),
                permMapCoherence (getThreadR cntj).1 (getThreadR cnti).2) /\
             (forall laddr rmap,
                 lockRes tp laddr = Some rmap ->
                 permMapCoherence rmap.1 (getThreadR cnti).2);
         locks_data_lock_coh:
           forall laddr rmap
             (Hres: lockRes tp laddr = Some rmap),
             (forall j (cntj: containsThread tp j),
                 permMapCoherence (getThreadR cntj).1 rmap.2) /\
             (forall laddr' rmap',
                 lockRes tp laddr' = Some rmap' ->
                 permMapCoherence rmap'.1 rmap.2);
         lockRes_valid: lr_valid (lockRes tp) (*well-formed locks*)
       }.
     Definition invariant := invariant'.

     (** Steps*)
     Inductive dry_step genv {tid0 tp m} (cnt: containsThread tp tid0)
               (Hcompatible: mem_compatible tp m) :
       thread_pool -> mem -> seq mem_event -> Prop :=
     | step_dry :
         forall (tp':thread_pool) c m1 m' (c' : code) ev
           (** Instal the permission's of the thread on non-lock locations*)
           (Hrestrict_pmap: restrPermMap (Hcompatible tid0 cnt).1 = m1)
           (Hinv: invariant tp)
           (Hcode: getThreadC cnt = Krun c)
           (Hcorestep: ev_step Sem genv c m1 ev c' m')
           (** the new data resources of the thread are the ones on the
           memory, the lock ones are unchanged by internal steps*)
           (Htp': tp' = updThread cnt (Krun c') (getCurPerm m', (getThreadR cnt).2)),
           dry_step genv cnt Hcompatible tp' m' ev.

     Definition option_function {A B} (opt_f: option (A -> B)) (x:A): option B:=
       match opt_f with
         Some f => Some (f x)
       | None => None
       end.
     Infix "??" := option_function (at level 80, right associativity).

     Inductive ext_step {isCoarse:bool} (genv:G) {tid0 tp m}
               (cnt0:containsThread tp tid0)(Hcompat:mem_compatible tp m):
       thread_pool -> mem -> sync_event -> Prop :=
     | step_acquire :
         forall (tp' tp'':thread_pool) m0 m1 c m' b ofs
           (pmap : LocksAndResources.lock_info)
           (pmap_tid' : access_map)
           (virtueThread : delta_map * delta_map)
           (Hbounded: if isCoarse then
                        ( sub_map virtueThread.1 (getMaxPerm m).2 /\
                          sub_map virtueThread.2 (getMaxPerm m).2)
                      else
                        True ),
           let newThreadPerm := (computeMap (getThreadR cnt0).1 virtueThread.1,
                                  computeMap (getThreadR cnt0).2 virtueThread.2) in
           forall
             (Hinv : invariant tp)
             (Hcode: getThreadC cnt0 = Kblocked c)
             (Hat_external: at_external Sem c = Some (LOCK, Vptr b ofs::nil))
             (** install the thread's permissions on lock locations*)
             (Hrestrict_pmap0: restrPermMap (Hcompat tid0 cnt0).2 = m0)
             (** check if the thread has permission to acquire the lock and the lock is free*)
             (Hload: Mem.load Mint32 m0 b (Int.intval ofs) = Some (Vint Int.one))
             (** set the permissions on the lock location equal to the max permissions on the memory*)
             (Hset_perm: setPermBlock (Some Writable)
                                       b (Int.intval ofs) ((getThreadR cnt0).2) LKSIZE_nat = pmap_tid')
             (Hlt': permMapLt pmap_tid' (getMaxPerm m))
             (Hrestrict_pmap: restrPermMap Hlt' = m1)
             (** acquire the lock*)
             (Hstore: Mem.store Mint32 m1 b (Int.intval ofs) (Vint Int.zero) = Some m')
             (HisLock: lockRes tp (b, Int.intval ofs) = Some pmap)
             (Hangel1: permMapJoin pmap.1 (getThreadR cnt0).1 newThreadPerm.1)
             (Hangel2: permMapJoin pmap.2 (getThreadR cnt0).2 newThreadPerm.2)
             (Htp': tp' = updThread cnt0 (Kresume c Vundef) newThreadPerm)
             (** acquiring the lock leaves empty permissions at the resource pool*)
             (Htp'': tp'' = updLockSet tp' (b, Int.intval ofs) (empty_map, empty_map)),
             ext_step genv cnt0 Hcompat tp'' m'
                      (acquire (b, Int.intval ofs)
                               (Some virtueThread))

     | step_release :
         forall (tp' tp'':thread_pool) m0 m1 c m' b ofs virtueThread virtueLP pmap_tid' rmap
           (Hbounded: if isCoarse then
                        ( sub_map virtueThread.1 (getMaxPerm m).2 /\
                          sub_map virtueThread.2 (getMaxPerm m).2)
                      else
                        True )
           (HboundedLP: if isCoarse then
                        ( map_empty_def virtueLP.1 /\
                          map_empty_def virtueLP.2 /\
                          sub_map virtueLP.1.2 (getMaxPerm m).2 /\
                          sub_map virtueLP.2.2 (getMaxPerm m).2)
                      else
                        True ),
           let newThreadPerm := (computeMap (getThreadR cnt0).1 virtueThread.1,
                                 computeMap (getThreadR cnt0).2 virtueThread.2) in
           forall
             (Hinv : invariant tp)
             (Hcode: getThreadC cnt0 = Kblocked c)
             (Hat_external: at_external Sem c =
                            Some (UNLOCK, Vptr b ofs::nil))
             (** install the thread's permissions on lock locations *)
             (Hrestrict_pmap0: restrPermMap (Hcompat tid0 cnt0).2 = m0)
             (Hload: Mem.load Mint32 m0 b (Int.intval ofs) = Some (Vint Int.zero))
             (** set the permissions on the lock location equal to the max permissions on the memory*)
             (Hset_perm: setPermBlock (Some Writable)
                                      b (Int.intval ofs) ((getThreadR cnt0).2) LKSIZE_nat = pmap_tid')
             (Hlt': permMapLt pmap_tid' (getMaxPerm m))
             (Hrestrict_pmap: restrPermMap Hlt' = m1)
             (** release the lock *)
             (Hstore: Mem.store Mint32 m1 b (Int.intval ofs) (Vint Int.one) = Some m')
             (HisLock: lockRes tp (b, Int.intval ofs) = Some rmap)
             (** And the lock is taken*)
             (Hrmap: forall b ofs, rmap.1 !! b ofs = None /\ rmap.2 !! b ofs = None)
             (Hangel1: permMapJoin newThreadPerm.1 virtueLP.1 (getThreadR cnt0).1)
             (Hangel2: permMapJoin newThreadPerm.2 virtueLP.2 (getThreadR cnt0).2)
             (Htp': tp' = updThread cnt0 (Kresume c Vundef)
                                    (computeMap (getThreadR cnt0).1 virtueThread.1,
                                     computeMap (getThreadR cnt0).2 virtueThread.2))
             (Htp'': tp'' = updLockSet tp' (b, Int.intval ofs) virtueLP),
             ext_step genv cnt0 Hcompat tp'' m'
                      (release (b, Int.intval ofs)
                               (Some virtueLP))
     | step_create :
         forall (tp_upd tp':thread_pool) c b ofs arg virtue1 virtue2
           (Hbounded: if isCoarse then
                        ( sub_map virtue1.1 (getMaxPerm m).2 /\
                          sub_map virtue1.2 (getMaxPerm m).2)
                      else
                        True )
             (Hbounded_new: if isCoarse then
                        ( sub_map virtue2.1 (getMaxPerm m).2 /\
                          sub_map virtue2.2 (getMaxPerm m).2)
                      else
                        True ),
           let threadPerm' := (computeMap (getThreadR cnt0).1 virtue1.1,
                               computeMap (getThreadR cnt0).2 virtue1.2) in
           let newThreadPerm := (computeMap empty_map virtue2.1,
                                 computeMap empty_map virtue2.2) in
           forall
           (Hinv : invariant tp)
           (Hcode: getThreadC cnt0 = Kblocked c)
           (Hat_external: at_external Sem c = Some (CREATE, Vptr b ofs::arg::nil))
           (** we do not need to enforce the almost empty predicate on thread
           spawn as long as it's considered a synchronizing operation *)
           (Hangel1: permMapJoin newThreadPerm.1 threadPerm'.1 (getThreadR cnt0).1)
           (Hangel2: permMapJoin newThreadPerm.2 threadPerm'.2 (getThreadR cnt0).2)
           (Htp_upd: tp_upd = updThread cnt0 (Kresume c Vundef) threadPerm')
           (Htp': tp' = addThread tp_upd (Vptr b ofs) arg newThreadPerm),
             ext_step genv cnt0 Hcompat tp' m
                      (spawn (b, Int.intval ofs)
                             (Some (getThreadR cnt0, virtue1)) (Some virtue2))

     | step_mklock :
         forall  (tp' tp'': thread_pool) m1 c m' b ofs pmap_tid',
           let: pmap_tid := getThreadR cnt0 in
           forall
             (Hinv : invariant tp)
             (Hcode: getThreadC cnt0 = Kblocked c)
             (Hat_external: at_external Sem c = Some (MKLOCK, Vptr b ofs::nil))
             (** install the thread's data permissions*)
             (Hrestrict_pmap: restrPermMap (Hcompat tid0 cnt0).1 = m1)
             (** lock is created in acquired state*)
             (Hstore: Mem.store Mint32 m1 b (Int.intval ofs) (Vint Int.zero) = Some m')
             (** The thread's data permissions are set to Nonempty*)
             (Hdata_perm: setPermBlock
                            (Some Nonempty)
                            b
                            (Int.intval ofs)
                            pmap_tid.1
                            LKSIZE_nat = pmap_tid'.1)
             (** thread lock permission is increased *)
             (Hlock_perm: setPermBlock
                            (Some Writable)
                            b
                            (Int.intval ofs)
                            pmap_tid.2
                            LKSIZE_nat = pmap_tid'.2)
             (** Require that [(b, Int.intval ofs)] was not a lock*)
             (HlockRes: lockRes tp (b, Int.intval ofs) = None)
             (Htp': tp' = updThread cnt0 (Kresume c Vundef) pmap_tid')
             (** the lock has no resources initially *)
             (Htp'': tp'' = updLockSet tp' (b, Int.intval ofs) (empty_map, empty_map)),
             ext_step genv cnt0 Hcompat tp'' m' (mklock (b, Int.intval ofs))

     | step_freelock :
         forall  (tp' tp'': thread_pool) c b ofs pmap_tid' m1 pdata rmap
           (Hbounded: if isCoarse then
                        ( bounded_maps.bounded_nat_func' pdata LKSIZE_nat)
                      else
                        True ),
             let: pmap_tid := getThreadR cnt0 in
           forall
           (Hinv: invariant tp)
           (Hcode: getThreadC cnt0 = Kblocked c)
           (Hat_external: at_external Sem c = Some (FREE_LOCK, Vptr b ofs::nil))
           (** If this address is a lock*)
           (His_lock: lockRes tp (b, (Int.intval ofs)) = Some rmap)
           (** And the lock is taken *)
           (Hrmap: forall b ofs, rmap.1 !! b ofs = None /\ rmap.2 !! b ofs = None)
           (** Install the thread's lock permissions*)
           (Hrestrict_pmap: restrPermMap (Hcompat tid0 cnt0).2 = m1)
           (** To free the lock the thread must have at least Writable on it*)
           (Hfreeable: Mem.range_perm m1 b (Int.intval ofs) ((Int.intval ofs) + LKSIZE) Cur Writable)
           (** lock permissions of the thread are dropped to empty *)
           (Hlock_perm: setPermBlock
                          None
                          b
                          (Int.intval ofs)
                          pmap_tid.2
                          LKSIZE_nat = pmap_tid'.2)
           (** data permissions are computed in a non-deterministic way *)
           (Hneq_perms: forall i,
                 (0 <= Z.of_nat i < LKSIZE)%Z ->
                 Mem.perm_order'' (pdata (S i)) (Some Writable)
           )
           (*Hpdata: perm_order pdata Writable*)
           (Hdata_perm: setPermBlock_var (*=setPermBlockfunc*)
                          pdata
                          b
                          (Int.intval ofs)
                          pmap_tid.1
                          LKSIZE_nat = pmap_tid'.1)
           (Htp': tp' = updThread cnt0 (Kresume c Vundef) pmap_tid')
           (Htp'': tp'' = remLockSet tp' (b, Int.intval ofs)),
           ext_step genv cnt0 Hcompat  tp'' m (freelock (b, Int.intval ofs))
     | step_acqfail :
         forall  c b ofs m1
           (Hinv : invariant tp)
           (Hcode: getThreadC cnt0 = Kblocked c)
           (Hat_external: at_external Sem c = Some (LOCK, Vptr b ofs::nil))
           (** Install the thread's lock permissions*)
           (Hrestrict_pmap: restrPermMap (Hcompat tid0 cnt0).2 = m1)
           (** Lock is already acquired.*)
           (Hload: Mem.load Mint32 m1 b (Int.intval ofs) = Some (Vint Int.zero)),
           ext_step genv cnt0 Hcompat tp m (failacq (b, Int.intval ofs)).

     Definition threadStep (genv : G): forall {tid0 ms m},
         containsThread ms tid0 -> mem_compatible ms m ->
         thread_pool -> mem -> seq mem_event -> Prop:=
       @dry_step genv.

     Lemma threadStep_equal_run:
    forall g i tp m cnt cmpt tp' m' tr,
      @threadStep g i tp m cnt cmpt tp' m' tr ->
      forall j,
        (exists cntj q, @getThreadC j tp cntj = Krun q) <->
        (exists cntj' q', @getThreadC j tp' cntj' = Krun q').
    Proof.
      intros. split.
      - intros [cntj [ q running]].
        inversion H; subst.
        assert (cntj':=cntj).
        eapply (cntUpdate (Krun c') (getCurPerm m', (getThreadR cnt)#2) cntj) in cntj'.
        exists cntj'.
        destruct (NatTID.eq_tid_dec i j).
        + subst j; exists c'.
          rewrite gssThreadCode; reflexivity.
        + exists q.
          rewrite gsoThreadCode; auto.
      - intros [cntj' [ q' running]].
        inversion H; subst.
        assert (cntj:=cntj').
        eapply cntUpdate' with(c0:=Krun c')(p:=(getCurPerm m', (getThreadR cnt)#2)) in cntj; eauto.
        exists cntj.
        destruct (NatTID.eq_tid_dec i j).
        + subst j; exists c.
          rewrite <- Hcode.
          f_equal.
          apply cnt_irr.
        + exists q'.
          rewrite gsoThreadCode in running; auto.
    Qed.

     Definition syncStep (isCoarse:bool) (genv :G) :
       forall {tid0 ms m},
         containsThread ms tid0 -> mem_compatible ms m ->
         thread_pool -> mem -> sync_event -> Prop:=
       @ext_step isCoarse genv.

  Lemma syncstep_equal_run:
    forall b g i tp m cnt cmpt tp' m' tr,
      @syncStep b g i tp m cnt cmpt tp' m' tr ->
      forall j,
        (exists cntj q, @getThreadC j tp cntj = Krun q) <->
        (exists cntj' q', @getThreadC j tp' cntj' = Krun q').
  Proof.
    intros b g i tp m cnt cmpt tp' m' tr H j; split.
    - intros [cntj [ q running]].
      destruct (NatTID.eq_tid_dec i j).
      + subst j. generalize running; clear running.
        inversion H; subst;
          match goal with
          | [ H: getThreadC ?cnt = Kblocked ?c |- _ ] =>
            replace cnt with cntj in H by apply cnt_irr;
              intros HH; rewrite HH in H; inversion H
          end.
      + (*this should be easy to automate or shorten*)
        inversion H; subst.
        * exists (cntUpdateL _ _
                        (cntUpdate (Kresume c Vundef)
                                   newThreadPerm
                                   _ cntj)), q.
          rewrite gLockSetCode.
          rewrite gsoThreadCode; assumption.
        * exists ( (cntUpdateL _ _
                          (cntUpdate (Kresume c Vundef)
                                     (computeMap (getThreadR cnt)#1 virtueThread#1,
                                      computeMap (getThreadR cnt)#2 virtueThread#2)
                                     _ cntj))), q.
          rewrite gLockSetCode.
          rewrite gsoThreadCode; assumption.
        * exists (cntAdd _ _ _
                    (cntUpdate (Kresume c Vundef)
                               threadPerm'
                               _ cntj)), q.
          erewrite gsoAddCode . (*i? *)
          rewrite gsoThreadCode; assumption.
          eapply cntUpdate. eauto.
        * exists ( (cntUpdateL _ _
                          (cntUpdate (Kresume c Vundef)
                                     pmap_tid'
                                     _ cntj))), q.
          rewrite gLockSetCode.
          rewrite gsoThreadCode; assumption.
        * exists ( (cntRemoveL _
                          (cntUpdate (Kresume c Vundef)
                                     pmap_tid'
                                     _ cntj))), q.
          rewrite gRemLockSetCode.
          rewrite gsoThreadCode; assumption.
        * exists cntj, q; assumption.
    - intros [cntj [ q running]].
      destruct (NatTID.eq_tid_dec i j).
      + subst j. generalize running; clear running.
        inversion H; subst;
          try rewrite gLockSetCode;
          try rewrite gRemLockSetCode;
          try rewrite gssThreadCode;
          try solve[intros HH; inversion HH].
        { (*addthread*)
          assert (cntj':=cntj).
          eapply cntAdd' in cntj'; destruct cntj' as [ [HH HHH] | HH].
          * erewrite gsoAddCode; eauto.
            subst; rewrite gssThreadCode; intros AA; inversion AA.
          * erewrite gssAddCode . intros AA; inversion AA.
            assumption. }
          { (*AQCUIRE*)
            replace cntj with cnt by apply cnt_irr.
            rewrite Hcode; intros HH; inversion HH. }
      + generalize running; clear running.
        inversion H; subst;
        try erewrite <- age_getThreadCode;
          try rewrite gLockSetCode;
          try rewrite gRemLockSetCode;
          try (rewrite gsoThreadCode; [|auto]);
        try (intros HH;
        match goal with
        | [ H: getThreadC ?cnt = Krun ?c |- _ ] =>
          exists cntj, c; exact H
        end).
      (*Add thread case*)
        assert (cntj':=cntj).
        eapply cntAdd' in cntj'; destruct cntj' as [ [HH HHH] | HH].
        * erewrite gsoAddCode; eauto.
          destruct (NatTID.eq_tid_dec i j);
            [subst; rewrite gssThreadCode; intros AA; inversion AA|].
          rewrite gsoThreadCode; auto.
          exists HH, q; assumption.
        * erewrite gssAddCode . intros AA; inversion AA.
          assumption.

          Grab Existential Variables.
          eauto. eauto. eauto.
  Qed.

  Lemma syncstep_not_running:
    forall b g i tp m cnt cmpt tp' m' tr,
      @syncStep b g i tp m cnt cmpt tp' m' tr ->
      forall cntj q, ~ @getThreadC i tp cntj = Krun q.
  Proof.
    intros.
    inversion H;
      match goal with
      | [ H: getThreadC ?cnt = _ |- _ ] =>
        erewrite (cnt_irr _ cnt);
          rewrite H; intros AA; inversion AA
      end.
  Qed.

     Inductive threadHalted': forall {tid0 ms},
         containsThread ms tid0 -> Prop:=
     | thread_halted':
         forall tp c tid0
           (cnt: containsThread tp tid0)
           (*Hinv: invariant tp*)
           (Hcode: getThreadC cnt = Krun c)
           (Hcant: halted Sem c),
           threadHalted' cnt.

    Definition threadHalted: forall {tid0 ms},
         containsThread ms tid0 -> Prop:= @threadHalted'.

   (* Lemma updCinvariant': forall {tid} ds c (cnt: containsThread ds tid),
         invariant (updThreadC cnt c) <-> invariant ds.
           split.
           { intros INV; inversion INV.
             constructor.
             - generalize no_race; unfold race_free.
               simpl. intros.
               apply no_race0; auto.
             - simpl; assumption.
             - simpl; assumption.
             - simpl; assumption.
             - simpl; assumption. }

           { intros INV; inversion INV.
             constructor.
             - generalize no_race; unfold race_free.
               simpl. intros.
               apply no_race0; auto.
             - simpl; assumption.
             - simpl; assumption.
             - simpl; assumption.
             - simpl; assumption. }
     Qed. *)

  Lemma threadHalt_update:
    forall i j, i <> j ->
      forall tp cnt cnti c' cnt',
        (@threadHalted j tp cnt) <->
        (@threadHalted j (@updThreadC i tp cnti c') cnt') .
  Proof.
    intros; split; intros HH; inversion HH; subst;
    econstructor; eauto.
    erewrite <- (gsoThreadCC H); exact Hcode.
    erewrite (gsoThreadCC H); exact Hcode.
  Qed.

     Definition one_pos : pos := mkPos NPeano.Nat.lt_0_1.

     Definition initial_machine pmap c :=
       ThreadPool.mk
         one_pos
         (fun _ =>  Krun c)
         (fun _ => (pmap, empty_map)) (*initially there are no locks*)
         empty_lset.

     Definition init_mach (pmap : option RES.res) (genv:G)
                (v:val)(args:list val):option thread_pool :=
       match initial_core Sem genv v args with
       | Some c =>
         match pmap with
         | Some pmap => Some (initial_machine pmap.1 c)
         | None => None
         end
       | None => None
       end.

     Module DryMachineLemmas.

       (*TODO: This lemma should probably be moved. *)
       Lemma threads_canonical:
         forall ds m i (cnt:ThreadPool.containsThread ds i),
           mem_compatible ds m ->
           isCanonical (ThreadPool.getThreadR cnt).1 /\
           isCanonical (ThreadPool.getThreadR cnt).2.
             intros.
             destruct (compat_th H cnt);
               eauto using canonical_lt.
       Qed.
       (** most of these lemmas are in DryMachinLemmas*)

       (** *Invariant Lemmas*)

       (** ** Updating the machine state**)
        (* Manny invaraint lemmas were removed from here. *)
     End DryMachineLemmas.

    (** *More Properties of halted thread*)
      Lemma threadStep_not_unhalts:
    forall g i tp m cnt cmpt tp' m' tr,
      @threadStep g i tp m cnt cmpt tp' m' tr ->
      forall j cnt cnt',
        (@threadHalted j tp cnt) ->
        (@threadHalted j tp' cnt') .
  Proof.
    intros; inversion H; inversion H0; subst.
    destruct (NatTID.eq_tid_dec i j).
    - subst j. simpl in Hcorestep.
      eapply ev_step_ax1 in Hcorestep.
      eapply corestep_not_halted in Hcorestep.
      replace cnt1 with cnt in Hcode0 by apply cnt_irr.
      rewrite Hcode0 in Hcode; inversion Hcode;
      subst c0.
      rewrite Hcorestep in Hcant; inversion Hcant.
    - econstructor; eauto.
      rewrite gsoThreadCode; auto;
      erewrite <- age_getThreadCode; eauto.
  Qed.

  Lemma syncstep_equal_halted:
    forall b g i tp m cnti cmpt tp' m' tr,
      @syncStep b g i tp m cnti cmpt tp' m' tr ->
      forall j cnt cnt',
        (@threadHalted j tp cnt) <->
        (@threadHalted j tp' cnt').
  Proof.
    intros; split; intros HH; inversion HH; subst;
    econstructor; subst; eauto.
    - destruct (NatTID.eq_tid_dec i j).
      + subst j.
        inversion H;
          match goal with
          | [ H: getThreadC ?cnt = Krun ?c,
                 H': getThreadC ?cnt' = Kblocked ?c' |- _ ] =>
            replace cnt with cnt' in H by apply cnt_irr;
              rewrite H' in H; inversion H
          end.
      + inversion H; subst;
        try erewrite <- age_getThreadCode;
          try rewrite gLockSetCode;
          try rewrite gRemLockSetCode;
          try erewrite gsoAddCode; eauto;
          try rewrite gsoThreadCode; try eassumption.
        { (*AQCUIRE*)
            replace cnt' with cnt0 by apply cnt_irr;
          exact Hcode. }
    - destruct (NatTID.eq_tid_dec i j).
      + subst j.
        inversion H; subst;
        match goal with
          | [ H: getThreadC ?cnt = Krun ?c,
                 H': getThreadC ?cnt' = Kblocked ?c' |- _ ] =>
            try erewrite <- age_getThreadCode in H;
              try rewrite gLockSetCode in H;
              try rewrite gRemLockSetCode in H;
              try erewrite gsoAddCode in H; eauto;
              try rewrite gssThreadCode in H;
              try solve[inversion H]
        end.
        { (*AQCUIRE*)
            replace cnt with cnt0 by apply cnt_irr;
          exact Hcode. }
      +
        inversion H; subst;
        match goal with
          | [ H: getThreadC ?cnt = Krun ?c,
                 H': getThreadC ?cnt' = Kblocked ?c' |- _ ] =>
            try erewrite <- age_getThreadCode in H;
              try rewrite gLockSetCode in H;
              try rewrite gRemLockSetCode in H;
              try erewrite gsoAddCode in H; eauto;
              try rewrite gsoThreadCode in H;
              try solve[inversion H]; eauto
        end.
        { (*AQCUIRE*)
            replace cnt with cnt0 by apply cnt_irr;
          exact Hcode. }

        Grab Existential Variables.
        eauto. eauto. eauto.
  Qed.

  End DryMachineShell.

End Concur.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*          Jacques-Henri Jourdan, INRIA Paris-Rocquencourt            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation, either version 2 of the License, or  *)
(*  (at your option) any later version.  This file is also distributed *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Architecture-dependent parameters for PowerPC *)

Require Import ZArith.
Require Import Fappli_IEEE.
Require Import Fappli_IEEE_bits.

Definition ptr64 := false.

Definition big_endian := true.

Definition align_int64 := 8%Z.
Definition align_float64 := 8%Z.

Definition splitlong := true.

Lemma splitlong_ptr32: splitlong = true -> ptr64 = false.
Proof.
  unfold splitlong, ptr64; congruence.
Qed.

Program Definition default_pl_64 : bool * nan_pl 53 :=
  (false, iter_nat 51 _ xO xH).

Definition choose_binop_pl_64 (s1: bool) (pl1: nan_pl 53) (s2: bool) (pl2: nan_pl 53) :=
  false.                        (**r always choose first NaN *)

Program Definition default_pl_32 : bool * nan_pl 24 :=
  (false, iter_nat 22 _ xO xH).

Definition choose_binop_pl_32 (s1: bool) (pl1: nan_pl 24) (s2: bool) (pl2: nan_pl 24) :=
  false.                        (**r always choose first NaN *)

Definition float_of_single_preserves_sNaN := true.

Global Opaque ptr64 big_endian splitlong
              default_pl_64 choose_binop_pl_64
              default_pl_32 choose_binop_pl_32
              float_of_single_preserves_sNaN.

(** Can we use the 64-bit extensions to the PowerPC architecture? *)
Parameter ppc64: bool.


Require Import Program.

Require Import Sem SimProg Skeleton Mod ModSem SimMod SimModSem SimSymb SimMem Sound SimSymb.
Require Import Cop Ctypes ClightC.
Require Import AsmC.
Require SimMemInjInvC SimSymbDropInv.
Require Import CoqlibC.
Require Import ValuesC.
Require Import LinkingC.
Require Import MapsC.
Require Import AxiomsC.
Require Import Ord.
Require Import MemoryC.
Require Import SmallstepC.
Require Import Events.
Require Import Preservation.
Require Import Integers.
Require Import LocationsC Conventions.
Require Import Conventions1C.

Require Import AsmregsC.
Require Import MatchSimModSem.
Require Import StoreArguments StoreArgumentsProps.
Require Import AsmStepInj IntegersC.
Require Import Coq.Logic.PropExtensionality.
Require Import CtypingC.
Require Import CopC.

Require Import MatchSimModSem.
Require Import Conventions1C.

Require Import ClightStepInj.
Require Import IdSimExtra IdSimInvExtra IdSimClightExtra.
Require Import mktac.

Set Implicit Arguments.

Local Opaque Z.mul Z.add Z.sub Z.div.

Section INJINV.

Local Existing Instance SimSymbDropInv.SimMemInvTop.
Local Existing Instance SimSymbDropInv.SimSymbDropInv.
Local Existing Instance SoundTop.Top.

Inductive match_states_clight_inv
  : unit -> Clight.state -> Clight.state -> SimMem.t -> Prop :=
| match_states_clight_inv_intro
    st_src st_tgt j m_src m_tgt sm0
    (MWFSRC: m_src = sm0.(SimMem.src))
    (MWFTGT: m_tgt = sm0.(SimMem.tgt))
    (MWFINJ: j = sm0.(SimMemInjInv.minj).(SimMemInj.inj))
    (MATCHST: match_states_clight_internal st_src st_tgt j m_src m_tgt)
    (MWF: SimMem.wf sm0)
  :
    match_states_clight_inv
      tt st_src st_tgt sm0
.

Lemma clight_inj_inv_drop
      (clight: Clight.program)
      (WF: Sk.wf (module2 clight))
  :
    exists mp,
      (<<SIM: ModPair.sim mp>>)
      /\ (<<SRC: mp.(ModPair.src) = (module2 clight)>>)
      /\ (<<TGT: mp.(ModPair.tgt) = (module2 clight)>>)
.
Proof.
  eexists (ModPair.mk _ _ _); s.
  esplits; eauto. instantiate (1:=SimSymbDropInv.mk bot1 _ _).
  econs; ss; i.
  { econs; ss; i; clarify.
    inv WF. auto. }
  eapply match_states_sim with (match_states := match_states_clight_inv); ss.
  - apply unit_ord_wf.
  - eapply SoundTop.sound_state_local_preservation.

  - i. ss. exploit SimSymbDropInv_match_globals.
    { inv SIMSKENV. ss. eauto. } intros GEMATCH.
    inv INITTGT. inv SAFESRC. inv SIMARGS. inv H. ss.
    exploit match_globals_find_funct; eauto.
    i. clarify.
    esplits; eauto.
    + econs; eauto.
    + refl.
    + econs; eauto. econs; eauto.
      { inv TYP. inv TYP0. eapply inject_list_typify_list; eauto. }
      econs.
    + ss.

  - i. ss. exploit SimSymbDropInv_match_globals.
    { inv SIMSKENV. ss. eauto. } intros GEMATCH.
    des. inv SAFESRC. inv SIMARGS. esplits. econs; ss.
    + eapply match_globals_find_funct; eauto.
    + inv TYP. econs; eauto.
      erewrite <- inject_list_length; eauto.
    + ss.

  - i. ss. inv MATCH; eauto.

  - i. ss. clear SOUND. inv CALLSRC. inv MATCH. inv MATCHST. inv SIMSKENV. ss.
    esplits; eauto.
    + econs; ss; eauto.
      * eapply SimSymbDropInv_find_None; eauto.
        ii. clarify. ss. des. clarify.
      * des. clear EXTERNAL.
        unfold Genv.find_funct, Genv.find_funct_ptr in *. des_ifs_safe.
        inv INJ. inv SIMSKELINK.
        exploit SIMDEF; eauto. i. des. clarify. des_ifs. esplits; eauto.
    + econs; ss.
    + refl.
    + instantiate (1:=top4). ss.

  - i. ss. clear SOUND HISTORY.
    exists (SimMemInjInvC.unlift' sm_arg sm_ret).
    inv AFTERSRC. inv MATCH. inv MATCHST.
    esplits; eauto.
    + econs; eauto. inv SIMRET; ss.
    + inv SIMRET; ss. econs; eauto. econs; eauto.
      { eapply inject_typify; et. }
      ss. eapply match_cont_incr; try eassumption.
      inv MLE. inv MLE1. inv MLE0. inv MLE. etrans; eauto.
    + refl.

  - i. ss. inv FINALSRC. inv MATCH. inv MATCHST. inv CONT.
    esplits; eauto.
    + econs.
    + econs; eauto.
    + refl.

  - left. i. split.
    + eapply modsem2_receptive.
    + ii. inv MATCH. destruct sm0 as [sm0 mem_inv_src mem_inv_tgt].
      cinv MWF. cinv WF0. ss.
      exploit clight_step_preserve_injection2; try eassumption.
      { instantiate (1:=cgenv skenv_link_tgt clight). ss. }
      { eapply function_entry2_inject. ss. }
      { inv SIMSKENV. exploit SimSymbDropInv.sim_skenv_symbols_inject; eauto. }
      { inv SIMSKENV. ss. rpapply SimSymbDropInv_match_globals; eauto. } i. des.
      exploit SimMemInjC.parallel_gen; eauto. i. des.
      hexploit SimMemInjInv.le_inj_wf_wf; eauto. intros MWFINV0.

      esplits; eauto.
      * left. apply plus_one. econs; ss; eauto.
        eapply modsem2_determinate.
      * instantiate (1:=SimMemInjInv.mk _ _ _). econs; ss; eauto.
      * econs; ss; eauto.
Qed.

End INJINV.


From Coq Require Import String Arith NArith ZArith Eqdep_dec.

From Vyper Require FSet Map UInt256.

From Vyper Require Import Config Calldag.
From Vyper.L10 Require Import AST Base Callset Descend.

Local Open Scope list_scope.
Local Open Scope string_scope.

Ltac destruct_let_pair
:= match goal with
   |- (let (_, _) := ?x in _) = let (_, _) := ?x in _ =>
     destruct x
   end.
Ltac destruct_if
:= match goal with
   |- (if ?x then _ else _) = (if ?x then _ else _) =>
     destruct x
   end.

Section Expr.
Context {C: VyperConfig}.

Definition storage_var_is_declared (cd: calldag)
                                   (name: string)
: bool
:= match cd_declmap cd name with
   | Some (StorageVarDecl _) => true
   | _ => false
   end.

Fixpoint interpret_expr {bigger_call_depth_bound smaller_call_depth_bound: nat}
                        (Ebound: bigger_call_depth_bound = S smaller_call_depth_bound)
                        {cd: calldag}
                        (fc: fun_ctx cd bigger_call_depth_bound)
                        (do_call: forall
                                      (fc': fun_ctx cd smaller_call_depth_bound)
                                      (world: world_state)
                                      (arg_values: list uint256),
                                    world_state * expr_result uint256)
                        (builtins: string -> option builtin)
                        (world: world_state)
                        (loc: string_map uint256)
                        (e: expr)
                        (CallOk: let _ := string_set_impl in
                                 FSet.is_subset (expr_callset e)
                                                (decl_callset (fun_decl fc))
                                 = true)
{struct e}
: world_state * expr_result uint256
:= let fix interpret_expr_list (world: world_state)
                           (loc: string_map uint256)
                           (e: list expr)
                           (CallOk: let _ := string_set_impl in
                                    FSet.is_subset (expr_list_callset e)
                                                   (decl_callset (fun_decl fc))
                                    = true)
  {struct e}
  : world_state * expr_result (list uint256)
  := match e as e' return e = e' -> _ with
     | nil => fun _ => (world, ExprSuccess nil)
     | (h :: t)%list => fun E =>
         let (world', result_h) := interpret_expr Ebound fc do_call builtins
                                                  world loc h
                                                  (callset_descend_head E CallOk)
         in match result_h with
            | ExprAbort ab => (world', ExprAbort ab)
            | ExprSuccess x =>
               let (world'', result_t) := interpret_expr_list world' loc t
                                                              (callset_descend_tail E CallOk)
               in (world'', match result_t with
                            | ExprAbort _ => result_t
                            | ExprSuccess y => ExprSuccess (x :: y)%list
                            end)
             end
     end eq_refl
   in match e as e' return e = e' -> _ with
   | Const val => fun _ => (world, ExprSuccess val)
   | LocalVar name => fun _ =>
       (world, match map_lookup loc name with
               | Some val => ExprSuccess val
               | None => expr_error "undeclared local variable"
               end)
   | StorageVar name => fun _ =>
     if storage_var_is_declared cd name
        then (world, ExprSuccess (match storage_lookup world name with
                                  | None => zero256
                                  | Some x => x
                                  end))
        else (world, expr_error "undeclared global variable")
   | UnOp op a => fun E =>
       let (world', result) := interpret_expr Ebound fc do_call builtins
                                              world loc a
                                              (callset_descend_unop E CallOk)
       in (world', match result with
                   | ExprSuccess val => interpret_unop op val
                   | ExprAbort _ => result
                   end)
   | BinOp op a b => fun E =>
       let (world', result_a) := interpret_expr Ebound fc do_call builtins
                                                world loc a
                                                (callset_descend_binop_left E CallOk)
       in match result_a with
       | ExprAbort _ => (world', result_a)
       | ExprSuccess x =>
         let (world'', result_b) := interpret_expr Ebound fc do_call builtins
                                                   world' loc b
                                                   (callset_descend_binop_right E CallOk)
         in (world'', match result_b with
                      | ExprAbort _ => result_b
                      | ExprSuccess y => interpret_binop op x y
                      end)
       end
   | IfThenElse cond yes no => fun E =>
       let (world', result_cond) := interpret_expr Ebound fc do_call builtins
                                                   world loc cond
                                                   (callset_descend_if_cond E CallOk)
       in match result_cond with
          | ExprAbort _ => (world', result_cond)
          | ExprSuccess cond_value =>
              if (Z_of_uint256 cond_value =? 0)%Z
                then interpret_expr Ebound fc do_call builtins
                                    world' loc no
                                    (callset_descend_if_else E CallOk)
                else interpret_expr Ebound fc do_call builtins
                                    world' loc yes
                                    (callset_descend_if_then E CallOk)
          end
   | LogicalAnd a b => fun E =>
       let (world', result_a) := interpret_expr Ebound fc do_call builtins
                                                world loc a
                                                (callset_descend_and_left E CallOk)
       in match result_a with
          | ExprAbort _ => (world', result_a)
          | ExprSuccess a_value =>
              if (Z_of_uint256 a_value =? 0)%Z
                then (world', result_a)
                else interpret_expr Ebound fc do_call builtins
                                    world' loc b
                                    (callset_descend_and_right E CallOk)
          end
   | LogicalOr a b => fun E =>
       let (world', result_a) := interpret_expr Ebound fc do_call builtins
                                                world loc a
                                                (callset_descend_or_left E CallOk)
       in match result_a with
          | ExprAbort msg => (world', result_a)
          | ExprSuccess a_value =>
              if (Z_of_uint256 a_value =? 0)%Z
                then interpret_expr Ebound fc do_call builtins
                                    world' loc b
                                    (callset_descend_or_right E CallOk)
                else (world', result_a)
          end
   | PrivateOrBuiltinCall name args => fun E =>
       let (world', result_args) :=
         interpret_expr_list world loc args
                             (callset_descend_args E CallOk)
       in match result_args with
          | ExprAbort ab => (world', ExprAbort ab)
          | ExprSuccess arg_values =>
              match fun_ctx_descend fc CallOk Ebound E with
              | Some new_fc => do_call new_fc world' arg_values
              | None => (* can't resolve the function, maybe it's a builtin *)
                 match builtins name with
                 | Some (existT _ arity b) =>
                    (if (arity =? List.length arg_values)%nat as arity_ok
                     return _ = arity_ok -> _
                         then fun Earity => call_builtin arg_values Earity (b world')
                         else fun _ => (world', expr_error "builtin with wrong arity"))
                       eq_refl
                 | None => (world', expr_error "can't resolve function name")
                 end
              end
          end
   end eq_refl.

(* This is not needed as PropExtensionality covers it.
   But this is an example of induction on expr.
 *)
Lemma interpret_expr_fun_ctx_irrel {bigger_call_depth_bound smaller_call_depth_bound: nat}
                                   (Ebound: bigger_call_depth_bound = S smaller_call_depth_bound)
                                   {cd: calldag}
                                   {fc1 fc2: fun_ctx cd bigger_call_depth_bound}
                                   (FcOk: fun_name fc1 = fun_name fc2)
                                   (do_call: forall
                                                 (fc': fun_ctx cd smaller_call_depth_bound)
                                                 (world: world_state)
                                                 (arg_values: list uint256),
                                               world_state * expr_result uint256)
                                   (builtins: string -> option builtin)
                                   (world: world_state)
                                   (loc: string_map uint256)
                                   (e: expr)
                                   (CallOk1: let _ := string_set_impl in
                                                FSet.is_subset (expr_callset e)
                                                               (decl_callset (fun_decl fc1))
                                                = true)
                                   (CallOk2: let _ := string_set_impl in
                                                FSet.is_subset (expr_callset e)
                                                               (decl_callset (fun_decl fc2))
                                                = true):
  interpret_expr Ebound fc1 do_call builtins world loc e CallOk1
   =
  interpret_expr Ebound fc2 do_call builtins world loc e CallOk2.
Proof.
revert world loc.
induction e using expr_ind'; cbn; intros.
{ trivial. }
{ trivial. }
{ trivial. }
{ (* unop *)
  now rewrite IHe with (CallOk2 := callset_descend_unop eq_refl CallOk2).
}
{ (* binop *)
  rewrite IHe1 with (CallOk2 := callset_descend_binop_left eq_refl CallOk2).
  destruct_let_pair.
  destruct e. 2:{ trivial. }
  rewrite IHe2 with (CallOk2 := callset_descend_binop_right eq_refl CallOk2).
  destruct_let_pair.
  trivial.
}
{ (* if *)
  rewrite IHe1 with (CallOk2 := callset_descend_if_cond eq_refl CallOk2).
  destruct_let_pair.
  destruct e. 2:{ trivial. }
  destruct_if.
  { now rewrite IHe3 with (CallOk2 := callset_descend_if_else eq_refl CallOk2). }
  now rewrite IHe2 with (CallOk2 := callset_descend_if_then eq_refl CallOk2).
}
{ (* and *)
  rewrite IHe1 with (CallOk2 := callset_descend_and_left eq_refl CallOk2).
  destruct_let_pair.
  destruct e. 2:{ trivial. }
  now destruct_if.
}
{ (* or *)
  rewrite IHe1 with (CallOk2 := callset_descend_or_left eq_refl CallOk2).
  destruct_let_pair.
  destruct e. 2:{ trivial. }
  now destruct_if.
}
(* call *)
remember (fix interpret_expr_list world loc (e: list expr) CallOk := _) as interpret_expr_list1.
remember (fix interpret_expr_list world loc (e: list expr)
                                  (CallOk: FSet.is_subset (expr_list_callset e)
                                           (decl_callset (fun_decl fc2))
                                           = true) := _) as interpret_expr_list2.
assert (L: interpret_expr_list1 world loc args (callset_descend_args eq_refl CallOk1)
            =
           interpret_expr_list2 world loc args (callset_descend_args eq_refl CallOk2)).
{
  remember (callset_descend_args eq_refl CallOk1) as ListCallOk1.
  remember (callset_descend_args eq_refl CallOk2) as ListCallOk2.
  clear HeqListCallOk1 HeqListCallOk2 CallOk1 CallOk2.
  revert world loc ListCallOk1 ListCallOk2.
  induction args; intros. { now subst. }
  rewrite Heqinterpret_expr_list1. rewrite Heqinterpret_expr_list2. cbn.
  rewrite (List.Forall_inv H
            (callset_descend_head eq_refl ListCallOk1)
            (callset_descend_head eq_refl ListCallOk2)).
  destruct_let_pair.
  destruct e. 2:{ trivial. }
  rewrite<- Heqinterpret_expr_list1.
  rewrite<- Heqinterpret_expr_list2.
  rewrite (IHargs (List.Forall_inv_tail H) w loc
            (callset_descend_tail eq_refl ListCallOk1)
            (callset_descend_tail eq_refl ListCallOk2)).
  now destruct_let_pair.
}
clear Heqinterpret_expr_list1 Heqinterpret_expr_list2.
rewrite L.
destruct_let_pair.
destruct e. 2:{ trivial. }
assert (F: fun_ctx_descend fc1 CallOk1 Ebound eq_refl
            =
           fun_ctx_descend fc2 CallOk2 Ebound eq_refl).
{ apply fun_ctx_descend_irrel. }
rewrite F.
now destruct (fun_ctx_descend fc2 CallOk2 Ebound eq_refl).
Qed.

End Expr.

Ltac destruct_interpret_expr_irrel
:= match goal with
   H: fun_name ?fc1 = fun_name ?fc2
   |- (let (_, _) := interpret_expr ?Ebound ?fc1 ?do_call ?builtins ?world ?loc ?e ?c1 in _)
       =
      (let (_, _) := interpret_expr ?Ebound ?fc2 ?do_call ?builtins ?world ?loc ?e ?c2 in _)
       =>
      rewrite (interpret_expr_fun_ctx_irrel Ebound H do_call builtins
                                            world loc e c1 c2);
      destruct_let_pair
   end.


Require Import Coq.Lists.List.
Import ListNotations.

Require Import Tactics.
Require Import Axioms.
Require Import Sigma.
Require Import Equality.
Require Import Sequence.
Require Import Relation.
Require Import Ordinal.
Require Import Syntax.
Require Import SimpSub.
Require Import Dynamic.
Require Import Ofe.
Require Import Uniform.
Require Import Intensional.
Require Import Candidate.
Require Import System.
Require Import Semantics.
Require Import SemanticsKnot.
Require Import Judgement.
Require Import Hygiene.
Require Import ProperClosed.
Require Import ProperFun.
Require Import Shut.

Require Import SemanticsFut.
Require Import Equivalence.
Require Import Equivalences.
Require Import ProperLevel.
Require Import Defined.
Require Import PageType.
Require Import Subsumption.

Local Ltac prove_hygiene :=
  repeat (apply hygiene_auto; cbn; repeat2 split; auto);
  eauto using hygiene_weaken, clo_min, hygiene_shift', hygiene_subst1, subst_closub;
  try (apply hygiene_var; cbn; auto; done).

Lemma pwctx_cons_tml :
  forall i m p s s' a G,
    pwctx i s s' G
    -> hygiene clo m
    -> hygiene clo p
    -> hygiene (ctxpred G) a
    -> (i > 0 -> seqhyp (pred i) m p (hyp_tm (subst s a)) (hyp_tm (subst s' a)))
    -> (forall j s'',
          j < i
          -> pwctx j s s'' G
          -> relhyp j false (hyp_tm (subst s' a)) (hyp_tm (subst s'' a)))
    -> (forall j s'',
          j < i
          -> pwctx j s'' s' G
          -> relhyp j true (hyp_tm (subst s a)) (hyp_tm (subst s'' a)))
    -> pwctx i (dot m s) (dot p s') (cons (hyp_tml a) G).
Proof.
intros i m p s s' a G Hs Hclm Hclp Hcla Hh Hleft Hright.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
apply pwctx_cons; auto.
  {
  simpsub.
  destruct i as [| i].
    {
    apply (seqhyp_tml _#5 (iubase empty_urel)); eauto using subst_closub; try (intro; omega).
    }
  assert (S i > 0) as Hpos by omega.
  invert (Hh Hpos).
  intros R Hal Har Hmp.
  apply (seqhyp_tml _#5 R); eauto using subst_closub.
  }

  {
  intros j b s'' Hsmall Hs'.
  destruct b.
    {
    cbn.
    invert Hsmall.
    intros Hji.
    apply Hleft; auto.
    eapply seqctx_pwctx_demote_left; eauto.
    }

    {
    cbn.
    invert Hsmall.
    intros Hji.
    so (seqctx_impl_closub _#4 Hs') as (_ & Hcls'').
    destruct j as [| j].
      {
      apply (relhyp_tml _#4 (iubase empty_urel)); eauto using subst_closub; intro; omega.
      }
    exploit (Hleft j s'') as H.
      {
      omega.
      }

      {
      cbn in Hs'.
      apply (pwctx_downward (S j)); [omega |].
      refine (seqctx_pwctx_left _#5 _ Hs').
      eapply pwctx_downward; eauto.
      }
    invertc H.
    intros R Hal Har.
    apply (relhyp_tml _#4 R); eauto using subst_closub.
    }
  }

  {
  intros j b s'' Hsmall Hs'.
  destruct b.
    {
    cbn.
    invert Hsmall.
    intros Hji.
    apply Hright; auto.
    eapply seqctx_pwctx_demote_right; eauto.
    }

    {
    cbn.
    invert Hsmall.
    intros Hji.
    so (seqctx_impl_closub _#4 Hs') as (Hcls'' & _).
    destruct j as [| j].
      {
      apply (relhyp_tml _#4 (iubase empty_urel)); eauto using subst_closub; try (intro; omega).
      }
    exploit (Hright j s'') as H.
      {
      omega.
      }

      {
      cbn in Hs'.
      apply (pwctx_downward (S j)); [omega |].
      refine (seqctx_pwctx_right _#5 _ Hs').
      eapply pwctx_downward; eauto.
      }
    invertc H.
    intros R Hal Har.
    apply (relhyp_tml _#4 R); eauto using subst_closub.
    }
  }
Qed.

Lemma pwctx_cons_tml_seq :
  forall i m p s s' a G,
    pwctx i s s' G
    -> hygiene clo m
    -> hygiene clo p
    -> hygiene (ctxpred G) a
    -> (i > 0 -> seqhyp (pred i) m p (hyp_tm (subst s a)) (hyp_tm (subst s' a)))
    -> (forall i t t',
          pwctx i t t' (promote G)
          -> exists pg R,
               interp pg true i (subst t a) R
               /\ interp pg false i (subst t' a) R)
    -> pwctx i (dot m s) (dot p s') (cons (hyp_tml a) G).
Proof.
intros i m p s s' a G Hs Hclm Hclp Hcla Hh Hact.
apply pwctx_cons; auto.
  {
  simpsub.
  so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
  destruct i as [| i].
    {
    apply (seqhyp_tml _#5 (iubase empty_urel)); eauto using subst_closub; try omega.
    }
  invert (Hh (Nat.lt_0_succ _)).
  intros R Hl Hr Hmp.
  apply (seqhyp_tml _#5 R); eauto using subst_closub.
  }

  {
  intros j b u Hsmall Hu.
  destruct b.
    {
    cbn.
    so (pwctx_smaller _#6 Hsmall Hs) as Hsj.
    so (Hact j s s' Hsj) as (pg & R & Hl & Hr).
    so (Hact j s u (seqctx_pwctx_left _#5 Hsj Hu)) as (pg' & R' & Hl' & Hr').
    so (interp_fun _#7 Hl Hl'); subst R'.
    eapply relhyp_tm; eauto using interp_increase, toppg_max.
    }

    {
    cbn.
    cbn in Hu.
    so (pwctx_impl_closub _#4 Hs) as (_ & Hcls').
    so (seqctx_impl_closub _#4 Hu) as (_ & Hclu).
    destruct j as [| j].
      {
      apply (relhyp_tml _#4 (iubase empty_urel)); try (intros; omega);
      eapply subst_closub; eauto.
      }
    so (seqctx_promote _#4 Hu) as Hu'.
    so (pwctx_promote _#4 (pwctx_smaller _#6 Hsmall Hs)) as Hsj.
    cbn in Hsj.
    fold (promote G) in Hsj.
    so (Hact j s s' Hsj) as (pg & R & Hl & Hr).
    so (Hact j s u (seqctx_pwctx_left _#5 Hsj Hu')) as (pg' & R' & Hl' & Hr').
    so (interp_fun _#7 Hl Hl'); subst R'.
    apply (relhyp_tml _#4 R); try (eapply subst_closub; eauto);
    intro; cbn; eauto using interp_increase, toppg_max.
    }
  }

  {
  intros j b u Hsmall Hu.
  destruct b.
    {
    cbn.
    so (pwctx_smaller _#6 Hsmall Hs) as Hsj.
    so (Hact j s s' Hsj) as (pg & R & Hl & Hr).
    so (Hact j u s' (seqctx_pwctx_right _#5 Hsj Hu)) as (pg' & R' & Hl' & Hr').
    so (interp_fun _#7 Hr Hr'); subst R'.
    eapply relhyp_tm; eauto using interp_increase, toppg_max.
    }

    {
    cbn.
    cbn in Hu.
    so (pwctx_impl_closub _#4 Hs) as (Hcls & _).
    so (seqctx_impl_closub _#4 Hu) as (Hclu & _).
    destruct j as [| j].
      {
      apply (relhyp_tml _#4 (iubase empty_urel)); try (intros; omega);
      eapply subst_closub; eauto.
      }
    so (seqctx_promote _#4 Hu) as Hu'.
    so (pwctx_promote _#4 (pwctx_smaller _#6 Hsmall Hs)) as Hsj.
    cbn in Hsj.
    fold (promote G) in Hsj.
    so (Hact j s s' Hsj) as (pg & R & Hl & Hr).
    so (Hact j u s' (seqctx_pwctx_right _#5 Hsj Hu')) as (pg' & R' & Hl' & Hr').
    so (interp_fun _#7 Hr Hr'); subst R'.
    apply (relhyp_tml _#4 R); try (eapply subst_closub; eauto);
    intro; cbn; eauto using interp_increase, toppg_max.
    }
  }
Qed.

Lemma sound_fut_kind_formation :
  forall G lv k k',
    pseq (promote G) (deq k k' (kuniv lv))
    -> pseq G (deq lv lv pagetp)
    -> pseq G (deq (fut k) (fut k') (kuniv lv)).
Proof.
intros G lv k l.
revert G.
refine (seq_pseq_promote 2 [] k [] l 2 true [] _ false [] _ _ _); cbn.
intros G Hclk Hcll Hseq Hseqlv.
rewrite -> seq_eqkind in Hseq |- *.
rewrite -> seq_deq in Hseqlv.
eassert _ as Hlv; [refine (seq_pagetp_invert G lv _) |].
  {
  intros i t t' Ht.
  so (Hseqlv _#3 Ht) as (R & Hl & _ & Hlv & _).
  eauto.
  }
clear Hseqlv.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
destruct i as [| i].
  {
  so (Hlv _#3 Hs) as (pg & Hlvl & Hlvr).
  exists pg, (qfut qone), (iufut0 stop), (pginterp_lt_top _ _ Hlvl).
  simpsub.
  do2 9 split; auto;
  try (apply kinterp_eval_refl; apply interp_kfut_zero; eapply subst_closub; eauto);
  try (apply interp_eval_refl; apply interp_fut_zero; eapply subst_closub; eauto).
  }
so (pwctx_promote _#4 Hs) as Hs'.
so (Hseq _#3 Hs') as (pg & K & R & h & Hlvl & Hlvr & Hkl & Hkr & Hll & Hlr & Hklt & Hkrt & Hllt & Hlrt).
exists pg, (qfut K), (iufut stop (S i) R), h.
simpsub.
do2 9 split; auto;
try (apply kinterp_eval_refl; apply interp_kfut; auto);
try (apply interp_eval_refl; apply interp_fut; auto).
Qed.

Lemma sound_fut_formation :
  forall G a b,
    pseq (promote G) (deqtype a b)
    -> pseq G (deqtype (fut a) (fut b)).
Proof.
intros G a b.
revert G.
refine (seq_pseq_promote 2 [] a [] b 1 true [] _ _ _); cbn.
intros G Hcla Hclb Hseq.
rewrite -> seq_eqtype in Hseq |- *.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
destruct i as [| i].
  {
  exists (iufut0 stop).
  simpsub.
  do2 3 split;
  apply interp_eval_refl; apply interp_fut_zero; eapply subst_closub; eauto.
  }
so (pwctx_promote _#4 Hs) as Hs'.
so (Hseq _#3 Hs') as (R & Hal & Har & Hbl & Hbr).
exists (iufut stop (S i) R).
do2 3 split;
apply interp_eval_refl; apply interp_fut; auto.
Qed.

Lemma sound_fut_formation_univ :
  forall G lv a b,
    pseq (promote G) (deq a b (univ lv))
    -> pseq G (deq lv lv pagetp)
    -> pseq G (deq (fut a) (fut b) (univ lv)).
Proof.
intros G lv a b.
revert G.
refine (seq_pseq_promote 2 [] a [] b 2 true [] _ false [] _ _ _); cbn.
intros G Hcla Hclb Hseq Hseqlv.
rewrite -> seq_univ in Hseq |- *.
rewrite -> seq_deq in Hseqlv.
eassert _ as Hlv; [refine (seq_pagetp_invert G lv _) |].
  {
  intros i t t' Ht.
  so (Hseqlv _#3 Ht) as (R & Hl & _ & Hlv & _).
  eauto.
  }
clear Hseqlv.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
destruct i as [| i].
  {
  so (Hlv _#3 Hs) as (pg & Hlvl & Hlvr).
  exists pg, (iufut0 stop).
  do2 5 split; auto;
  apply interp_eval_refl; apply interp_fut_zero; eapply subst_closub; eauto.
  }
so (pwctx_promote _#4 Hs) as Hs'.
so (Hseq _#3 Hs') as (pg & R & Hlvl & Hlvr & Hal & Har & Hbl & Hbr).
exists pg, (iufut stop (S i) R).
simpsub.
do2 5 split; auto;
apply interp_eval_refl; apply interp_fut; auto.
Qed.

Lemma sound_fut_intro :
  forall G m n a,
    pseq (promote G) (deq m n a)
    -> pseq G (deq (next m) (next n) (fut a)).
Proof.
intros G m n a.
revert G.
refine (seq_pseq_promote 3 [] m [] n [] a 1 true [] _ _ _); cbn.
intros G Hclm Hcln Hcla Hseq.
rewrite -> seq_deq in Hseq |- *.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
destruct i as [| i].
  {
  exists (iufut0 stop).
  simpsub.
  do2 4 split;
  try (apply interp_eval_refl; apply interp_fut_zero; eapply subst_closub; eauto);
  rewrite -> den_iufut0;
  apply fut_action_next_zero; try prove_hygiene.
  }
so (pwctx_promote _#4 Hs) as Hs'.
so (Hseq _#3 Hs') as (R & Hal & Har & Hm & Hn & Hmn).
exists (iufut stop (S i) R).
simpsub.
do2 4 split;
try (apply interp_eval_refl; apply interp_fut; auto);
apply fut_action_next; auto; omega.
Qed.

Lemma sound_fut_elim :
  forall G m n a p q b,
    pseq G (deq m n (fut a))
    -> pseq (promote G) (deqtype a a)
    -> pseq (cons (hyp_tml a) G) (deq p q b)
    -> pseq G (deq (subst1 (prev m) p) (subst1 (prev n) q) (subst1 (prev m) b)).
Proof.
intros G m n a p q b.
revert G.
refine (seq_pseq_promote 1 [] a 3 false [] _ true [] _ false [_] _ _ _); cbn.
intros G Hcla Hseqmn Hseqa Hseqpq.
rewrite -> seq_eqtype in Hseqa.
rewrite -> seq_deq in Hseqmn, Hseqpq |- *.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
so (Hseqmn _#3 Hs) as (Af & Hal & Har & Hm & Hn & Hmn).
assert (forall c d,
          rel (den Af) i c d
          -> pwctx i (dot (prev c) s) (dot (prev d) s') (cons (hyp_tml a) G)) as Hs'.
  {
  intros c d Hcd.
  so (urel_closed _#5 Hcd) as (Hclc & Hcld).
  apply pwctx_cons_tml_seq; auto; try prove_hygiene.
    {
    intro Hpos.
    destruct i as [| i]; [omega |].
    cbn [pred].
    simpsubin Hal.
    simpsubin Har.
    invert (basic_value_inv _#6 value_fut Hal).
    intros A Hal' Heq1.
    invert (basic_value_inv _#6 value_fut Har).
    intros A' Har' Heq2.
    so (eqtrans Heq1 (eqsymm Heq2)) as Heq.
    clear Heq2.
    subst Af.
    so (iufut_inj _#5 Heq); subst A'.
    apply (seqhyp_tm _#5 A); auto.
    apply (fut_action_prev _ (S i)).
    exact Hcd.
    }

    {
    intros j t t' Ht.
    so (Hseqa _#3 Ht) as (R & Hl & Hr & _).
    exists toppg, R.
    auto.
    }
  }
clear Hseqmn.
so (Hseqpq _#3 (Hs' _ _ Hm)) as (B & Hbml & Hbmr & Hmp & _).
so (Hseqpq _#3 (Hs' _ _ Hn)) as (B' & _ & Hbnr & _ & Hnq & _).
so (Hseqpq _#3 (Hs' _ _ Hmn)) as (B'' & Hbml' & Hbnr' & _ & _ & Hmnpq).
so (basic_fun _#7 Hbml Hbml'); subst B''.
so (basic_fun _#7 Hbnr Hbnr'); subst B'.
exists B.
simpsub.
do2 4 split; auto.
Qed.

Lemma sound_fut_elim_eqtype :
  forall G m n a b c,
    pseq G (deq m n (fut a))
    -> pseq (promote G) (deqtype a a)
    -> pseq (cons (hyp_tml a) G) (deqtype b c)
    -> pseq G (deqtype (subst1 (prev m) b) (subst1 (prev n) c)).
Proof.
intros G m n a b c.
revert G.
refine (seq_pseq_promote 1 [] a 3 false [] _ true [] _ false [_] _ _ _); cbn.
intros G Hcla Hseqmn Hseqa Hseqbc.
rewrite -> seq_eqtype in Hseqa, Hseqbc |- *.
rewrite -> seq_deq in Hseqmn.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
so (Hseqmn _#3 Hs) as (Af & Hal & Har & Hm & Hn & Hmn).
assert (forall p q,
          rel (den Af) i p q
          -> pwctx i (dot (prev p) s) (dot (prev q) s') (cons (hyp_tml a) G)) as Hs'.
  {
  intros p q Hpq.
  so (urel_closed _#5 Hpq) as (Hclp & Hclq).
  apply pwctx_cons_tml_seq; auto; try prove_hygiene.
    {
    intro Hpos.
    destruct i as [| i]; [omega |].
    cbn [pred].
    simpsubin Hal.
    simpsubin Har.
    invert (basic_value_inv _#6 value_fut Hal).
    intros A Hal' Heq1.
    invert (basic_value_inv _#6 value_fut Har).
    intros A' Har' Heq2.
    so (eqtrans Heq1 (eqsymm Heq2)) as Heq.
    clear Heq2.
    subst Af.
    so (iufut_inj _#5 Heq); subst A'.
    apply (seqhyp_tm _#5 A); auto.
    apply (fut_action_prev _ (S i)).
    exact Hpq.
    }

    {
    intros j t t' Ht.
    so (Hseqa _#3 Ht) as (R & Hl & Hr & _).
    exists toppg, R.
    auto.
    }
  }
clear Hseqmn.
so (Hseqbc _#3 (Hs' _ _ Hm)) as (R & Hmbl & Hmbr & _).
so (Hseqbc _#3 (Hs' _ _ Hn)) as (R' & _ & _ & Hncl & Hncr).
so (Hseqbc _#3 (Hs' _ _ Hmn)) as (R'' & Hmbl' & _ & _ & Hncr').
so (basic_fun _#7 Hmbl Hmbl'); subst R''.
so (basic_fun _#7 Hncr Hncr'); subst R'.
exists R.
simpsub.
do2 3 split; auto.
Qed.

(* This almost follows from sound_fut_eta_hyp, but not quite. *)
Lemma sound_fut_eta :
  forall G m a,
    pseq G (deq m m (fut a))
    -> pseq G (deq m (next (prev m)) (fut a)).
Proof.
intros G m a.
revert G.
refine (seq_pseq 1 [] m 1 [] _ _ _); cbn.
intros G Hclm Hseq.
rewrite -> seq_deq in Hseq |- *.
intros i s s' Hs.
so (pwctx_impl_closub _#4 Hs) as (Hcls & Hcls').
so (Hseq i s s' Hs) as (R & Hfutl & Hfutr & Hm & _).
exists R.
do2 3 split; auto.
simpsubin Hfutl.
simpsubin Hfutr.
simpsub.
destruct i as [| i].
  {
  invert (basic_value_inv _#6 value_fut Hfutl).
  intros _ <-.
  rewrite -> den_iufut0 in Hm |- *.
  split.
    {
    apply fut_action_next_zero; prove_hygiene.
    }

    {
    destruct Hm as (n & _ & _ & _ & _ & Hsteps & _).
    refine (urel_equiv_1 _#6 _ (equiv_symm _#3 (steps_equiv _#3 Hsteps)) _).
      {
      prove_hygiene.
      }
    so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hsteps (subst_closub _#4 Hcls Hclm))) as H; cbn in H.
    destruct H.
    apply fut_action_next_zero; prove_hygiene.
    }
  }
invert (basic_value_inv _#6 value_fut Hfutl).
intros A Hal Heq1.
invert (basic_value_inv _#6 value_fut Hfutr).
intros A' Har Heq2.
so (eqtrans Heq1 (eqsymm Heq2)) as Heq.
clear Heq2.
subst R.
so (iufut_inj _#5 Heq); subst A'.
cbn in Hm.
split.
  {
  apply fut_action_next; auto.
  eapply fut_action_prev; eauto.
  }

  {
  destruct Hm as (n & n' & _ & _ & _ & Hsteps & Hsteps' & Hn).
  refine (urel_equiv_1 _#6 _ (equiv_symm _#3 (steps_equiv _#3 Hsteps)) _).
    {
    prove_hygiene.
    }
  apply fut_action_next; auto.
  apply (urel_equiv_2 _#4 n').
    {
    prove_hygiene.
    }

    {
    apply equiv_symm.
    eapply equiv_trans.
      {
      apply equiv_prev.
      eapply steps_equiv; eauto.
      }
    apply steps_equiv.
    apply star_one; apply step_prev2.
    }
  apply Hn.
  omega.
  }
Qed.

Lemma sound_fut_eta_hyp_pre :
  forall G1 G2 a m n b,
    hygiene (ctxpred G1) a
    -> hygiene (ctxpred (G2 ++ hyp_tm (fut a) :: G1)) b
    -> seq (promote G1) (deqtype a a)
    -> seq (substctx (dot (next (var 0)) sh1) G2 ++ cons (hyp_tml a) G1) (deq m n (subst (under (length G2) (dot (next (var 0)) sh1)) b))
    -> seq (G2 ++ cons (hyp_tm (fut a)) G1) (deq (subst (under (length G2) (dot (prev (var 0)) sh1)) m) (subst (under (length G2) (dot (prev (var 0)) sh1)) n) b).
Proof.
intros G1 G2 a m n b Hcla Hclb Hseqa Hseq.
rewrite -> seq_eqtype in Hseqa.
eapply subsume_seq_extract; eauto; clear Hseq.
apply subsume_under.
do2 2 split.
  {
  intros j.
  rewrite -> !ctxpred_length.
  cbn [length].
  destruct j as [| j].
    {
    simpsub.
    split; try omega.
    intros _.
    apply hygiene_auto; cbn.
    split; auto.
    apply hygiene_var.
    omega.
    }

    {
    simpsub.
    split.
      {
      intros H.
      apply hygiene_var.
      omega.
      }

      {
      intros H.
      invertc H.
      intro; omega.
      }
    }
  }

  {
  intros j.
  rewrite -> !ctxpred_length.
  cbn [length].
  destruct j as [| j].
    {
    simpsub.
    split; try omega.
    intros _.
    apply hygiene_auto; cbn.
    split; auto.
    apply hygiene_var.
    omega.
    }

    {
    simpsub.
    split.
      {
      intros H.
      apply hygiene_var.
      omega.
      }

      {
      intros H.
      invertc H.
      intro; omega.
      }
    }
  }
intros i ss ss' Hss.
invertc Hss.
intros p q s s' Hs Hpq Hleft Hright <- <-.
simpsubin Hpq.
so (seqhyp_impl_closed _#5 Hpq) as (Hclp & Hclq).
assert (exists p' q' A,
          star step p (next p')
          /\ star step q (next q')
          /\ (i > 0
              -> interp toppg true (pred i) (subst s a) A
                 /\ interp toppg false (pred i) (subst s' a) A
                 /\ rel (den A) (pred i) p' q')) as H.
  {
  invertc Hpq.
  intros R Hfutl Hfutr Hpq.
  invert (basic_value_inv _#6 value_fut Hfutl).
    {
    intros _ <- <-.
    cbn in Hpq.
    decompose Hpq.
    intros p' q' _ _ _ Hp' Hq' _.
    exists p', q', (iubase empty_urel).
    do2 2 split; auto.
    omega.
    }

    {
    intros i' A Hal <- Heq1.
    invert (basic_value_inv _#6 value_fut Hfutr).
    intros A' Har Heq2.
    so (eqtrans Heq1 (eqsymm Heq2)) as Heq; clear Heq2.
    subst R.
    so (iufut_inj _#5 Heq); subst A'.
    cbn in Hpq.
    decompose Hpq.
    intros p' q' _ _ _ Hp' Hq' Hpq'.
    exists p', q', A.
    do2 2 split; auto.
    }
  }
destruct H as (p' & q' & A & Hstepsp & Hstepsq & Hif).
so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hstepsp Hclp)) as H; cbn in H.
destruct H as (Hclp' & _).
so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hstepsq Hclq)) as H; cbn in H.
destruct H as (Hclq' & _).
do2 4 split.
  {
  simpsub.
  apply pwctx_cons_tml_seq; auto; try prove_hygiene.
    {
    intros Hpos.
    so (Hif Hpos) as (Hal & Har & Hpq').
    apply (seqhyp_tm _#5 A); auto.
    eapply urel_equiv; eauto; try prove_hygiene.
      {
      apply equiv_symm.
      apply steps_equiv.
      eapply star_trans.
        {
        apply (star_map' _ _ prev); auto using step_prev1.
        exact Hstepsp.
        }
      apply star_one; apply step_prev2.
      }

      {
      apply equiv_symm.
      apply steps_equiv.
      eapply star_trans.
        {
        apply (star_map' _ _ prev); auto using step_prev1.
        exact Hstepsq.
        }
      apply star_one; apply step_prev2.
      }
    }

    {
    intros j t t' Ht.
    so (Hseqa _#3 Ht) as (R & Hl & Hr & _).
    eauto.
    }
  }

  {
  simpsub.
  apply equivsub_dot; auto using equivsub_refl.
  apply (equiv_trans _ _ (next p')).
    {
    apply equiv_next.
    apply steps_equiv.
    eapply star_trans.
      {
      apply (star_map' _ _ prev); auto using step_prev1.
      exact Hstepsp.
      }
    apply star_one.
    apply step_prev2.
    }

    {
    apply equiv_symm.
    apply steps_equiv; auto.
    }
  }

  {
  simpsub.
  apply equivsub_dot; auto using equivsub_refl.
  apply (equiv_trans _ _ (next q')).
    {
    apply equiv_next.
    apply steps_equiv.
    eapply star_trans.
      {
      apply (star_map' _ _ prev); auto using step_prev1.
      exact Hstepsq.
      }
    apply star_one.
    apply step_prev2.
    }

    {
    apply equiv_symm.
    apply steps_equiv; auto.
    }
  }

  {
  intros j d uu Hj Huu.
  simpsub.
  simpsubin Huu.
  rewrite -> qpromote_cons in Huu |- *.
  rewrite -> qpromote_hyp_tm.
  invertc Huu.
  intros r u Hu Hr <-.
  simpsub.
  apply seqctx_cons; auto.
  simpsub.
  destruct j as [| j].
    {
    so (seqctx_impl_closub _#4 Hu) as (Hcls & Hclu).
    so (seqhyp_impl_closed _#5 Hr) as (_ & Hclr).
    rewrite -> ctxpred_qpromote in Hcls, Hclu.
    apply (seqhyp_tm _#5 (iufut0 stop)).
      {
      apply interp_eval_refl.
      apply interp_fut_zero; prove_hygiene.
      }

      {
      apply interp_eval_refl.
      apply interp_fut_zero; prove_hygiene.
      }

      {
      apply (urel_equiv_1 _#3 (next p')); try prove_hygiene.
        {
        apply equiv_symm; apply steps_equiv; eauto.
        }
      apply fut_action_next_zero; auto; prove_hygiene.
      }
    }
  rewrite -> !substh_qpromote_hyp in Hr.
  so (seqhyp_demote_maybe _#7 Hr) as H.
  simpsubin H.
  invertc H.
  intros A' Hal Hau Hr' _ _ _ _.
  apply (seqhyp_tm _#5 (iufut stop (S j) A')).
    {
    apply interp_eval_refl.
    apply interp_fut.
    apply Hal.
    omega.
    }

    {
    apply interp_eval_refl.
    apply interp_fut.
    apply Hau.
    omega.
    }

    {
    apply (urel_equiv_1 _#3 (next p')); try prove_hygiene.
      {
      apply equiv_symm; apply steps_equiv; eauto.
      }
    apply fut_action_next; auto.
    apply (urel_equiv_1 _#3 (prev p)); try prove_hygiene.
      {
      apply steps_equiv.
      eapply star_trans.
        {
        apply (star_map' _ _ prev); auto using step_prev1.
        exact Hstepsp.
        }
      apply star_one; apply step_prev2.
      }

      {
      apply Hr'.
      omega.
      }
    }
  }

  {
  intros j d uu Hj Huu.
  simpsub.
  simpsubin Huu.
  rewrite -> qpromote_cons in Huu |- *.
  rewrite -> qpromote_hyp_tm.
  invertc Huu.
  intros r u Hu Hr <-.
  simpsub.
  apply seqctx_cons; auto.
  simpsub.
  destruct j as [| j].
    {
    so (seqctx_impl_closub _#4 Hu) as (Hclu & Hcls').
    so (seqhyp_impl_closed _#5 Hr) as (Hclr & _).
    rewrite -> ctxpred_qpromote in Hcls', Hclu.
    apply (seqhyp_tm _#5 (iufut0 stop)).
      {
      apply interp_eval_refl.
      apply interp_fut_zero; prove_hygiene.
      }

      {
      apply interp_eval_refl.
      apply interp_fut_zero; prove_hygiene.
      }

      {
      apply (urel_equiv_2 _#4 (next q')); try prove_hygiene.
        {
        apply equiv_symm; apply steps_equiv; eauto.
        }
      apply fut_action_next_zero; auto; prove_hygiene.
      }
    }
  rewrite -> !substh_qpromote_hyp in Hr.
  so (seqhyp_demote_maybe _#7 Hr) as H.
  simpsubin H.
  invertc H.
  intros A' Hal Hau Hr' _ _ _ _.
  apply (seqhyp_tm _#5 (iufut stop (S j) A')).
    {
    apply interp_eval_refl.
    apply interp_fut.
    apply Hal.
    omega.
    }

    {
    apply interp_eval_refl.
    apply interp_fut.
    apply Hau.
    omega.
    }

    {
    apply (urel_equiv_2 _#4 (next q')); try prove_hygiene.
      {
      apply equiv_symm; apply steps_equiv; eauto.
      }
    apply fut_action_next; auto.
    apply (urel_equiv_2 _#4 (prev q)); try prove_hygiene.
      {
      apply steps_equiv.
      eapply star_trans.
        {
        apply (star_map' _ _ prev); auto using step_prev1.
        exact Hstepsq.
        }
      apply star_one; apply step_prev2.
      }

      {
      apply Hr'.
      omega.
      }
    }
  }
Qed.

Lemma sound_fut_eta_hyp :
  forall G1 G2 a m n b,
    pseq (promote G1) (deqtype a a)
    -> pseq (substctx (dot (next (var 0)) sh1) G2 ++ cons (hyp_tml a) G1) (deq m n (subst (under (length G2) (dot (next (var 0)) sh1)) b))
    -> pseq (G2 ++ cons (hyp_tm (fut a)) G1) (deq (subst (under (length G2) (dot (prev (var 0)) sh1)) m) (subst (under (length G2) (dot (prev (var 0)) sh1)) n) b).
Proof.
intros G1 G2 a m n b (i1, Hseqa) (i2, Hseq).
so (shut_term _ G1 a) as (i3 & Hcla).
so (shut_term _ (G2 ++ hyp_tm (fut a) :: G1) b) as (i4 & Hclb).
so (upper_bound_all 4 i1 i2 i3 i4) as (i & Hi1 & Hi2 & Hi3 & Hi4 & _).
exists i; intros j Hj.
autorewrite with canonlist.
eapply sound_fut_eta_hyp_pre; try (finish_pseq j).
rewrite -> promote_append.
rewrite -> promote_shut.
apply Hseqa; eauto using le_trans.
Qed.

Lemma sound_fut_ext :
  forall G a b c m n,
    pseq G (deq m m (fut b))
    -> pseq G (deq n n (fut c))
    -> pseq G (deq (next (prev m)) (next (prev n)) (fut a))
    -> pseq G (deq m n (fut a)).
Proof.
intros G a b c m n.
revert G.
refine (seq_pseq 0 3 [] _ [] _ [] _ _ _).
cbn.
intros G Hseqm Hseqn Hseq.
rewrite -> seq_deq in Hseqm, Hseqn, Hseq |- *.
intros i s s' Hs.
assert (exists m1 m2,
          hygiene clo (subst s m)
          /\ hygiene clo (subst s' m)
          /\ star step (subst s m) (next m1)
          /\ star step (subst s' m) (next m2)) as (m1 & m2 & Hclm & Hclm' & Hstepm1 & Hstepm2).
  {
  so (Hseqm _ _ _ Hs) as (R & Hl & _ & Hm & _).
  simpsubin Hl.
  invert (basic_value_inv _#6 value_fut Hl).
    {
    intros _ <- <-.
    rewrite -> den_iufut0 in Hm.
    destruct Hm as (m1 & m2 & _ & Hcl & Hcl' & Hstep & Hstep' & _).
    exists m1, m2.
    auto.
    }
  intros i' A _ <- <-.
  rewrite -> den_iufut in Hm.
  destruct Hm as (m1 & m2 & _ & Hcl & Hcl' & Hstep & Hstep' & _).
  exists m1, m2.
  auto.
  }
assert (exists n1 n2,
          hygiene clo (subst s n)
          /\ hygiene clo (subst s' n)
          /\ star step (subst s n) (next n1)
          /\ star step (subst s' n) (next n2)) as (n1 & n2 & Hcln & Hcln' & Hstepn1 & Hstepn2).
  {
  so (Hseqn _ _ _ Hs) as (R & Hl & _ & Hn & _).
  simpsubin Hl.
  invert (basic_value_inv _#6 value_fut Hl).
    {
    intros _ <- <-.
    rewrite -> den_iufut0 in Hn.
    destruct Hn as (n1 & n2 & _ & Hcl & Hcl' & Hstep & Hstep' & _).
    exists n1, n2.
    auto.
    }
  intros i' A _ <- <-.
  rewrite -> den_iufut in Hn.
  destruct Hn as (n1 & n2 & _ & Hcl & Hcl' & Hstep & Hstep' & _).
  exists n1, n2.
  auto.
  }
clear Hseqm Hseqn.
so (Hseq _ _ _ Hs) as (R & Hl & Hr & Hm & Hn & Hmn).
exists R.
do2 2 split; auto.
simpsubin Hl.
simpsubin Hr.
simpsubin Hm.
simpsubin Hn.
simpsubin Hmn.
destruct i as [| i].
  {
  invert (basic_value_inv _#6 value_fut Hl).
  intros _ <-.
  rewrite -> !den_iufut0.
  do2 2 split.
    {
    exists m1, m2.
    do2 5 split; auto.
    intros H.
    omega.
    }

    {
    exists n1, n2.
    do2 5 split; auto.
    intros H.
    omega.
    }

    {
    exists m1, n2.
    do2 5 split; auto.
    intros H.
    omega.
    }
  }
invert (basic_value_inv _#6 value_fut Hl).
intros A Hal <-.
rewrite -> !den_iufut in Hm, Hn, Hmn |- *.
destruct Hm as (m1' & m2' & _ & _ & _ & Hstep1 & Hstep2 & H).
so (determinism_normal_value _#3 value_next Hstep1) as Heq.
injection Heq.
intros <-.
so (H (Nat.lt_0_succ _)) as Hm.
clear Heq Hstep1 H.
so (determinism_normal_value _#3 value_next Hstep2) as Heq.
injection Heq.
intros <-.
clear Heq Hstep2.
cbn in Hm.
destruct Hn as (n1' & n2' & _ & _ & _ & Hstep1 & Hstep2 & H).
so (determinism_normal_value _#3 value_next Hstep1) as Heq.
injection Heq.
intros <-.
so (H (Nat.lt_0_succ _)) as Hn.
clear Heq Hstep1 H.
so (determinism_normal_value _#3 value_next Hstep2) as Heq.
injection Heq.
intros <-.
clear Heq Hstep2.
cbn in Hn.
destruct Hmn as (m1' & n2' & _ & _ & _ & Hstep1 & Hstep2 & H).
so (determinism_normal_value _#3 value_next Hstep1) as Heq.
injection Heq.
intros <-.
so (H (Nat.lt_0_succ _)) as Hmn.
clear Heq Hstep1 H.
so (determinism_normal_value _#3 value_next Hstep2) as Heq.
injection Heq.
intros <-.
clear Heq Hstep2.
cbn in Hmn.
so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hstepm1 Hclm)) as H.
cbn in H.
destruct H as (Hclm1 & _).
so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hstepm2 Hclm')) as H.
cbn in H.
destruct H as (Hclm2 & _).
so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hstepn1 Hcln)) as H.
cbn in H.
destruct H as (Hcln1 & _).
so (hygiene_invert_auto _#5 (steps_hygiene _#4 Hstepn2 Hcln')) as H.
cbn in H.
destruct H as (Hcln2 & _).
assert (equiv (prev (subst s m)) m1) as Hequivm1.
  {
  apply steps_equiv.
  eapply star_trans.
    {
    apply star_map'; eauto using step_prev1 with dynamic.
    }
  apply star_one.
  apply step_prev2.
  }
assert (equiv (prev (subst s' m)) m2) as Hequivm2.
  {
  apply steps_equiv.
  eapply star_trans.
    {
    apply star_map'; eauto using step_prev1 with dynamic.
    }
  apply star_one.
  apply step_prev2.
  }
assert (equiv (prev (subst s n)) n1) as Hequivn1.
  {
  apply steps_equiv.
  eapply star_trans.
    {
    apply star_map'; eauto using step_prev1 with dynamic.
    }
  apply star_one.
  apply step_prev2.
  }
assert (equiv (prev (subst s' n)) n2) as Hequivn2.
  {
  apply steps_equiv.
  eapply star_trans.
    {
    apply star_map'; eauto using step_prev1 with dynamic.
    }
  apply star_one.
  apply step_prev2.
  }
do2 2 split.
  {
  exists m1, m2.
  do2 5 split; auto.
  intros _.
  cbn.
  eapply urel_equiv; eauto.
  }

  {
  exists n1, n2.
  do2 5 split; auto.
  intros _.
  cbn.
  eapply urel_equiv; eauto.
  }

  {
  exists m1, n2.
  do2 5 split; auto.
  intros _.
  cbn.
  eapply urel_equiv; eauto.
  }
Qed.