(*+ Specifications *)

Definition acquire_spec l : ext :=
  mkext
    (nat * (map -> Prop))
    (fun x Ω m =>
       match x with
       | (lx, Rx) =>
         lx = l /\
         islock l Rx m
       end)
    (fun x Ω m =>
       exists m1 m2,
         join m1 m2 m /\
         match x with
         | (lx, Rx) =>
           islock lx Rx m1 /\
           Rx m2
         end).Definition release_spec l : ext :=
  mkext
    (nat * (map -> Prop))
    (fun x Ω m =>
       exists m1 m2,
         join m1 m2 m /\
         match x with
         | (lx, Rx) =>
           lx = l /\
           islock l Rx m1 /\
           precise Rx /\
           Rx m2
         end)
    (fun x Ω m =>
       match x with
       | (lock, Rx) =>
         islock lock Rx m
       end).Definition at_ext : C -> option ext :=
  fun c =>
    match c with
    | acquire l _ => Some (acquire_spec l)
    | release l _ => Some (release_spec l)
    | _ => None
    end.(*+ Concurrent machine *)

(** Semantics of the collection of all threads. Thread and locked
    locks each have their own map. *)

Definition schedule := list nat.Definition threads := list (map * C).Definition lockpool := nat -> option (option map).Definition config := (schedule * threads * lockpool)%type.Definition there_is_a_lock_at (m : map) (l : nat) :=
  exists lock,
    m l = Some (inr lock).Definition map_matches_lock_at (m : map) (l : nat) (mlock : map) :=
  exists lock,
    m l = Some (inr lock) /\
    interp_lock lock mlock.Inductive machine : config -> config -> Prop :=
  | machine_outofschedule thd pool :
      (nil, thd, pool) ===>
      (nil, thd, pool)
  | machine_scheduleoutofbound i sch thd pool :
      nth thd i = None ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_core i sch thd c c' m m' pool :
      corestep c m c' m' ->
      nth thd i = Some (m, normal c) ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', normal c'), pool)
  | machine_release i sch thd m mlock m' l p pool :
      pool l <> None ->
      nth thd i = Some (m, release l p) ->
      (* mlock |= resinvs l -> *)
      map_matches_lock_at m l mlock ->
      join m' mlock m ->
      (i :: sch, thd, pool) ===>
      (sch, nth_upd thd i (m', p), upd pool l (Some (Some mlock)))
  | machine_acquire_failure i sch thd m l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (None) (* locked *) ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_acquire_success i sch thd m mlock m' l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (Some mlock) (* unlocked *) ->
      join m mlock m' ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', p), upd pool l (Some None))
where
" c1 ===> c2 " := (machine c1 c2).Inductive machine : config -> config -> Prop :=
  | machine_outofschedule thd pool :
      (nil, thd, pool) ===>
      (nil, thd, pool)
  | machine_scheduleoutofbound i sch thd pool :
      nth thd i = None ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_core i sch thd c c' m m' pool :
      corestep c m c' m' ->
      nth thd i = Some (m, normal c) ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', normal c'), pool)
  | machine_release i sch thd m mlock m' l p pool :
      pool l <> None ->
      nth thd i = Some (m, release l p) ->
      (* mlock |= resinvs l -> *)
      map_matches_lock_at m l mlock ->
      join m' mlock m ->
      (i :: sch, thd, pool) ===>
      (sch, nth_upd thd i (m', p), upd pool l (Some (Some mlock)))
  | machine_acquire_failure i sch thd m l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (None) (* locked *) ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_acquire_success i sch thd m mlock m' l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (Some mlock) (* unlocked *) ->
      join m mlock m' ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', p), upd pool l (Some None))
where
" c1 ===> c2 " := (machine c1 c2).Inductive machine : config -> config -> Prop :=
  | machine_outofschedule thd pool :
      (nil, thd, pool) ===>
      (nil, thd, pool)
  | machine_scheduleoutofbound i sch thd pool :
      nth thd i = None ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_core i sch thd c c' m m' pool :
      corestep c m c' m' ->
      nth thd i = Some (m, normal c) ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', normal c'), pool)
  | machine_release i sch thd m mlock m' l p pool :
      pool l <> None ->
      nth thd i = Some (m, release l p) ->
      (* mlock |= resinvs l -> *)
      map_matches_lock_at m l mlock ->
      join m' mlock m ->
      (i :: sch, thd, pool) ===>
      (sch, nth_upd thd i (m', p), upd pool l (Some (Some mlock)))
  | machine_acquire_failure i sch thd m l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (None) (* locked *) ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_acquire_success i sch thd m mlock m' l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (Some mlock) (* unlocked *) ->
      join m mlock m' ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', p), upd pool l (Some None))
where
" c1 ===> c2 " := (machine c1 c2).Inductive machine : config -> config -> Prop :=
  | machine_outofschedule thd pool :
      (nil, thd, pool) ===>
      (nil, thd, pool)
  | machine_scheduleoutofbound i sch thd pool :
      nth thd i = None ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_core i sch thd c c' m m' pool :
      corestep c m c' m' ->
      nth thd i = Some (m, normal c) ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', normal c'), pool)
  | machine_release i sch thd m mlock m' l p pool :
      pool l <> None ->
      nth thd i = Some (m, release l p) ->
      (* mlock |= resinvs l -> *)
      map_matches_lock_at m l mlock ->
      join m' mlock m ->
      (i :: sch, thd, pool) ===>
      (sch, nth_upd thd i (m', p), upd pool l (Some (Some mlock)))
  | machine_acquire_failure i sch thd m l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (None) (* locked *) ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_acquire_success i sch thd m mlock m' l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (Some mlock) (* unlocked *) ->
      join m mlock m' ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', p), upd pool l (Some None))
where
" c1 ===> c2 " := (machine c1 c2).Inductive machine : config -> config -> Prop :=
  | machine_outofschedule thd pool :
      (nil, thd, pool) ===>
      (nil, thd, pool)
  | machine_scheduleoutofbound i sch thd pool :
      nth thd i = None ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_core i sch thd c c' m m' pool :
      corestep c m c' m' ->
      nth thd i = Some (m, normal c) ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', normal c'), pool)
  | machine_release i sch thd m mlock m' l p pool :
      pool l <> None ->
      nth thd i = Some (m, release l p) ->
      (* mlock |= resinvs l -> *)
      map_matches_lock_at m l mlock ->
      join m' mlock m ->
      (i :: sch, thd, pool) ===>
      (sch, nth_upd thd i (m', p), upd pool l (Some (Some mlock)))
  | machine_acquire_failure i sch thd m l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (None) (* locked *) ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_acquire_success i sch thd m mlock m' l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (Some mlock) (* unlocked *) ->
      join m mlock m' ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', p), upd pool l (Some None))
where
" c1 ===> c2 " := (machine c1 c2).Inductive machine : config -> config -> Prop :=
  | machine_outofschedule thd pool :
      (nil, thd, pool) ===>
      (nil, thd, pool)
  | machine_scheduleoutofbound i sch thd pool :
      nth thd i = None ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_core i sch thd c c' m m' pool :
      corestep c m c' m' ->
      nth thd i = Some (m, normal c) ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', normal c'), pool)
  | machine_release i sch thd m mlock m' l p pool :
      pool l <> None ->
      nth thd i = Some (m, release l p) ->
      (* mlock |= resinvs l -> *)
      map_matches_lock_at m l mlock ->
      join m' mlock m ->
      (i :: sch, thd, pool) ===>
      (sch, nth_upd thd i (m', p), upd pool l (Some (Some mlock)))
  | machine_acquire_failure i sch thd m l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (None) (* locked *) ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_acquire_success i sch thd m mlock m' l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (Some mlock) (* unlocked *) ->
      join m mlock m' ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', p), upd pool l (Some None))
where
" c1 ===> c2 " := (machine c1 c2).Inductive machine : config -> config -> Prop :=
  | machine_outofschedule thd pool :
      (nil, thd, pool) ===>
      (nil, thd, pool)
  | machine_scheduleoutofbound i sch thd pool :
      nth thd i = None ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_core i sch thd c c' m m' pool :
      corestep c m c' m' ->
      nth thd i = Some (m, normal c) ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', normal c'), pool)
  | machine_release i sch thd m mlock m' l p pool :
      pool l <> None ->
      nth thd i = Some (m, release l p) ->
      (* mlock |= resinvs l -> *)
      map_matches_lock_at m l mlock ->
      join m' mlock m ->
      (i :: sch, thd, pool) ===>
      (sch, nth_upd thd i (m', p), upd pool l (Some (Some mlock)))
  | machine_acquire_failure i sch thd m l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (None) (* locked *) ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_acquire_success i sch thd m mlock m' l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (Some mlock) (* unlocked *) ->
      join m mlock m' ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', p), upd pool l (Some None))
where
" c1 ===> c2 " := (machine c1 c2).Inductive machine : config -> config -> Prop :=
  | machine_outofschedule thd pool :
      (nil, thd, pool) ===>
      (nil, thd, pool)
  | machine_scheduleoutofbound i sch thd pool :
      nth thd i = None ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_core i sch thd c c' m m' pool :
      corestep c m c' m' ->
      nth thd i = Some (m, normal c) ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', normal c'), pool)
  | machine_release i sch thd m mlock m' l p pool :
      pool l <> None ->
      nth thd i = Some (m, release l p) ->
      (* mlock |= resinvs l -> *)
      map_matches_lock_at m l mlock ->
      join m' mlock m ->
      (i :: sch, thd, pool) ===>
      (sch, nth_upd thd i (m', p), upd pool l (Some (Some mlock)))
  | machine_acquire_failure i sch thd m l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (None) (* locked *) ->
      (i :: sch, thd, pool) ===>
      (sch, thd, pool)
  | machine_acquire_success i sch thd m mlock m' l p pool :
      nth thd i = Some (m, acquire l p) ->
      pool l = Some (Some mlock) (* unlocked *) ->
      join m mlock m' ->
      (i :: sch, thd, pool) ===>
      (i :: sch, nth_upd thd i (m', p), upd pool l (Some None))
where
" c1 ===> c2 " := (machine c1 c2).(*+ Proving machine safety from the invariant *)

Definition reindex (thd:threads) pool : _ -> map :=
  fun x : nat + nat =>
           match x with
           | inl n =>
             match nth thd n with
             | Some (m, _) => m
             | None => emptymap
             end
           | inr n =>
             match pool n with
             | Some (Some m) => m
             | Some None => emptymap
             | None => emptymap
             end
           end.Definition lockpool_matches_map (pool : lockpool) (Phi : map) :=
  forall l,
    match pool l with
    | Some (Some mlock) => map_matches_lock_at Phi l mlock
    | Some None => there_is_a_lock_at Phi l
    | None => True
    end.Definition map_matches_lockpool (pool : lockpool) (Phi : map) :=
  forall l lock,
    Phi l = Some (inr lock) ->
    pool l <> None.Definition invariant n (x : config) :=
  match x with (_, thd, pool) =>
    exists Phi,
      jointo (reindex thd pool) Phi /\
      lockpool_matches_map pool Phi /\
      map_matches_lockpool pool Phi /\
      (forall i oracle m p,
          nth thd i = Some (m, p) ->
          safeN_ at_ext n oracle p m)
  end.

Theorem progress n x : invariant (S n) x -> exists y, x ===> y.