Theory FWSemantics

(*  Title:      JinjaThreads/Framework/FWSemantics.thy
    Author:     Andreas Lochbihler
*)

section ‹The multithreaded semantics›

theory FWSemantics
imports
  FWWellform
  FWLockingThread
  FWCondAction
  FWInterrupt
begin

inductive redT_upd :: "('l,'t,'x,'m,'w) state  't  ('l,'t,'x,'m,'w,'o) thread_action  'x  'm  ('l,'t,'x,'m,'w) state  bool"
for s t ta x' m'
where
  "redT_updWs t (wset s) taw ws'
   redT_upd s t ta x' m' (redT_updLs (locks s) t tal, ((redT_updTs (thr s) tat)(t  (x', redT_updLns (locks s) t (snd (the (thr s t))) tal)), m'), ws', redT_updIs (interrupts s) tai)"

inductive_simps redT_upd_simps [simp]:
  "redT_upd s t ta x' m' s'"

definition redT_acq :: "('l,'t,'x,'m,'w) state  't  ('l ⇒f nat)  ('l,'t,'x,'m,'w) state"
where
  "ln. redT_acq s t ln = (acquire_all (locks s) t ln, ((thr s)(t  (fst (the (thr s t)), no_wait_locks)), shr s), wset s, interrupts s)"

context final_thread begin

inductive actions_ok :: "('l,'t,'x,'m,'w) state  't  ('l,'t,'x','m,'w,'o) thread_action  bool"
  for s :: "('l,'t,'x,'m,'w) state" and t :: 't and ta :: "('l,'t,'x','m,'w,'o) thread_action"
  where
  " lock_ok_las (locks s) t tal; thread_oks (thr s) tat; cond_action_oks s t tac;
     wset_actions_ok (wset s) t taw; interrupt_actions_ok (interrupts s) tai 
   actions_ok s t ta"

declare actions_ok.intros [intro!]
declare actions_ok.cases [elim!]

lemma actions_ok_iff [simp]:
  "actions_ok s t ta 
   lock_ok_las (locks s) t tal  thread_oks (thr s) tat  cond_action_oks s t tac 
   wset_actions_ok (wset s) t taw  interrupt_actions_ok (interrupts s) tai"
by(auto)

lemma actions_ok_thread_oksD:
  "actions_ok s t ta  thread_oks (thr s) tat"
by(erule actions_ok.cases)

inductive actions_ok' :: "('l,'t,'x,'m,'w) state  't  ('l,'t,'x','m,'w,'o) thread_action  bool" where
  " lock_ok_las' (locks s) t tal; thread_oks (thr s) tat; cond_action_oks' s t tac;
     wset_actions_ok (wset s) t taw; interrupt_actions_ok' (interrupts s) tai 
   actions_ok' s t ta"

declare actions_ok'.intros [intro!]
declare actions_ok'.cases [elim!]

lemma actions_ok'_iff:
  "actions_ok' s t ta 
   lock_ok_las' (locks s) t tal  thread_oks (thr s) tat  cond_action_oks' s t tac 
   wset_actions_ok (wset s) t taw  interrupt_actions_ok' (interrupts s) tai"
by auto

lemma actions_ok'_ta_upd_obs:
  "actions_ok' s t (ta_update_obs ta obs)  actions_ok' s t ta"
by(auto simp add: actions_ok'_iff lock_ok_las'_def ta_upd_simps wset_actions_ok_def)

lemma actions_ok'_empty: "actions_ok' s t ε  wset s t = None"
by(simp add: actions_ok'_iff lock_ok_las'_def)

lemma actions_ok'_convert_extTA:
  "actions_ok' s t (convert_extTA f ta) = actions_ok' s t ta"
by(simp add: actions_ok'_iff)

inductive actions_subset :: "('l,'t,'x,'m,'w,'o) thread_action  ('l,'t,'x','m,'w,'o) thread_action  bool"
where
 " collect_locks' ta'l  collect_locks tal; 
    collect_cond_actions ta'c  collect_cond_actions tac;
    collect_interrupts ta'i  collect_interrupts tai 
   actions_subset ta' ta"

declare actions_subset.intros [intro!]
declare actions_subset.cases [elim!]

lemma actions_subset_iff:
  "actions_subset ta' ta  
   collect_locks' ta'l  collect_locks tal 
   collect_cond_actions ta'c  collect_cond_actions tac 
   collect_interrupts ta'i  collect_interrupts tai"
by auto

lemma actions_subset_refl [intro]:
  "actions_subset ta ta"
by(auto intro: actions_subset.intros collect_locks'_subset_collect_locks del: subsetI)

definition final_thread :: "('l,'t,'x,'m,'w) state  't  bool" where
  "ln. final_thread s t  (case thr s t of None  False | (x, ln)  final x  ln = no_wait_locks  wset s t = None)"

definition final_threads :: "('l,'t,'x,'m,'w) state  't set" 
where "final_threads s  {t. final_thread s t}"

lemma [iff]: "t  final_threads s = final_thread s t"
  by (simp add: final_threads_def)

lemma [pred_set_conv]: "final_thread s = (λt. t  final_threads s)"
  by simp

definition mfinal :: "('l,'t,'x,'m,'w) state  bool"
where "mfinal s  (t x ln. thr s t = (x, ln)  final x  ln = no_wait_locks  wset s t = None)"

lemma final_threadI:
  " thr s t = (x, no_wait_locks); final x; wset s t = None   final_thread s t"
by(simp add: final_thread_def)

lemma final_threadE:
  assumes "final_thread s t"
  obtains x where "thr s t = (x, no_wait_locks)" "final x" "wset s t = None"
using assms by(auto simp add: final_thread_def)

lemma mfinalI:
  "(t x ln. thr s t = (x, ln)  final x  ln = no_wait_locks  wset s t = None)  mfinal s"
unfolding mfinal_def by blast

lemma mfinalD:
  fixes ln
  assumes "mfinal s" "thr s t = (x, ln)"
  shows "final x" "ln = no_wait_locks" "wset s t = None"
using assms unfolding mfinal_def by blast+

lemma mfinalE:
  fixes ln
  assumes "mfinal s" "thr s t = (x, ln)"
  obtains "final x" "ln = no_wait_locks" "wset s t = None"
using mfinalD[OF assms] by(rule that)

lemma mfinal_def2: "mfinal s  dom (thr s)  final_threads s"
by(fastforce elim: mfinalE final_threadE intro: mfinalI final_threadI)

end

locale multithreaded_base = final_thread +
  constrains final :: "'x  bool" 
  fixes r :: "('l,'t,'x,'m,'w,'o) semantics" ("_  _ -_ _" [50,0,0,50] 80)
  and convert_RA :: "'l released_locks  'o list"
begin

abbreviation
  r_syntax :: "'t  'x  'm  ('l,'t,'x,'m,'w,'o) thread_action  'x  'm  bool"
              ("_  _, _ -_ _, _" [50,0,0,0,0,0] 80)
where
  "t  x, m -ta x', m'  t  (x, m) -ta (x', m')"

inductive
  redT :: "('l,'t,'x,'m,'w) state  't × ('l,'t,'x,'m,'w,'o) thread_action  ('l,'t,'x,'m,'w) state  bool" and
  redT_syntax1 :: "('l,'t,'x,'m,'w) state  't  ('l,'t,'x,'m,'w,'o) thread_action  ('l,'t,'x,'m,'w) state  bool" ("_ -__ _" [50,0,0,50] 80)
where
  "s -tta s'  redT s (t, ta) s'"

|  redT_normal:
  " t  x, shr s -ta x', m';
     thr s t = (x, no_wait_locks);
     actions_ok s t ta;
     redT_upd s t ta x' m' s' 
   s -tta s'"

| redT_acquire:
  "ln.  thr s t = (x, ln); ¬ waiting (wset s t);
     may_acquire_all (locks s) t ln; ln $ n > 0;
     s' = (acquire_all (locks s) t ln, ((thr s)(t  (x, no_wait_locks)), shr s), wset s, interrupts s) 
   s -t((K$ []), [], [], [], [], convert_RA ln) s'"

abbreviation
  redT_syntax2 :: "('l,'t) locks  ('l,'t,'x) thread_info × 'm  ('w,'t) wait_sets  't interrupts
                    't  ('l,'t,'x,'m,'w,'o) thread_action
                    ('l,'t) locks  ('l,'t,'x) thread_info × 'm  ('w,'t) wait_sets  't interrupts  bool"
                  ("_, _, _, _ -__ _, _, _, _" [0,0,0,0,0,0,0,0,0] 80)
where
  "ls, tsm, ws, is -tta ls', tsm', ws', is'  (ls, tsm, ws, is) -tta (ls', tsm', ws', is')"


lemma redT_elims [consumes 1, case_names normal acquire]:
  assumes red: "s -tta s'"
  and normal: "x x' m' ws'.
     t  x, shr s -ta x', m';
      thr s t = (x, no_wait_locks);
      lock_ok_las (locks s) t tal;
      thread_oks (thr s) tat;
      cond_action_oks s t tac;
      wset_actions_ok (wset s) t taw;
      interrupt_actions_ok (interrupts s) tai;
      redT_updWs t (wset s) taw ws';
      s' = (redT_updLs (locks s) t tal, ((redT_updTs (thr s) tat)(t  (x', redT_updLns (locks s) t no_wait_locks tal)), m'), ws', redT_updIs (interrupts s) tai) 
     thesis"
   and acquire: "x ln n.
     thr s t = (x, ln);
      ta = (K$ [], [], [], [], [], convert_RA ln);
      ¬ waiting (wset s t);
      may_acquire_all (locks s) t ln; 0 < ln $ n;
      s' = (acquire_all (locks s) t ln, ((thr s)(t  (x, no_wait_locks)), shr s), wset s, interrupts s) 
     thesis"
  shows thesis
using red
proof cases
  case redT_normal
  thus ?thesis using normal by(cases s')(auto)
next
  case redT_acquire
  thus ?thesis by-(rule acquire, fastforce+)
qed

definition
  RedT :: "('l,'t,'x,'m,'w) state  ('t × ('l,'t,'x,'m,'w,'o) thread_action) list  ('l,'t,'x,'m,'w) state  bool"
          ("_ -▹_→* _" [50,0,50] 80)
where
  "RedT  rtrancl3p redT"

lemma RedTI:
  "rtrancl3p redT s ttas s'  RedT s ttas s'"
by(simp add: RedT_def)

lemma RedTE:
  " RedT s ttas s'; rtrancl3p redT s ttas s'  P   P"
by(auto simp add: RedT_def)

lemma RedTD:
  "RedT s ttas s'  rtrancl3p redT s ttas s'"
by(simp add: RedT_def)

lemma RedT_induct [consumes 1, case_names refl step]:
  " s -▹ttas→* s';
     s. P s [] s;
     s ttas s' t ta s''.  s -▹ttas→* s'; P s ttas s'; s' -tta s''   P s (ttas @ [(t, ta)]) s''
   P s ttas s'"
unfolding RedT_def
by(erule rtrancl3p.induct) auto

lemma RedT_induct' [consumes 1, case_names refl step]:
  " s -▹ttas→* s';
     P s [] s;
     ttas s' t ta s''.  s -▹ttas→* s'; P s ttas s'; s' -tta s''   P s (ttas @ [(t, ta)]) s''
   P s ttas s'"
  unfolding RedT_def
apply(erule rtrancl3p_induct', blast)
apply(case_tac b, blast)
done

lemma RedT_lift_preserveD:
  assumes Red: "s -▹ttas→* s'"
  and P: "P s"
  and preserve: "s t tas s'.  s -ttas s'; P s   P s'"
  shows "P s'"
  using Red P
  by(induct rule: RedT_induct)(auto intro: preserve)

lemma RedT_refl [intro, simp]:
  "s -▹[]→* s"
by(rule RedTI)(rule rtrancl3p_refl)

lemma redT_has_locks_inv:
  " ls, (ts, m), ws, is -tta ls', (ts', m'), ws', is'; t  t'  
  has_locks (ls $ l) t' = has_locks (ls' $ l) t'"
by(auto elim!: redT.cases intro: redT_updLs_has_locks[THEN sym, simplified] may_acquire_all_has_locks_acquire_locks[symmetric])

lemma redT_has_lock_inv:
  " ls, (ts, m), ws, is -tta ls', (ts', m'), ws', is'; t  t' 
   has_lock (ls' $ l) t' = has_lock (ls $ l) t'"
by(auto simp add: redT_has_locks_inv)

lemma redT_ts_Some_inv:
  " ls, (ts, m), ws, is -tta ls', (ts', m'), ws', is'; t  t'; ts t' = x   ts' t' = x"
by(fastforce elim!: redT.cases simp: redT_updTs_upd[THEN sym] intro: redT_updTs_Some)

lemma redT_thread_not_disappear:
  " s -tta s'; thr s' t' = None  thr s t' = None"
apply(cases "t  t'")
apply(auto elim!: redT_elims simp add: redT_updTs_upd[THEN sym] intro: redT_updTs_None)
done

lemma RedT_thread_not_disappear:
  " s -▹ttas→* s'; thr s' t' = None  thr s t' = None"
apply(erule contrapos_pp[where Q="thr s' t' = None"])
apply(drule (1) RedT_lift_preserveD)
apply(erule_tac Q="thr sa t' = None" in contrapos_nn)
apply(erule redT_thread_not_disappear)
apply(auto)
done

lemma redT_preserves_wset_thread_ok:
  " s -tta s'; wset_thread_ok (wset s) (thr s)   wset_thread_ok (wset s') (thr s')"
by(fastforce elim!: redT.cases intro: wset_thread_ok_upd redT_updTs_preserves_wset_thread_ok redT_updWs_preserve_wset_thread_ok)

lemma RedT_preserves_wset_thread_ok:
  " s -▹ttas→* s'; wset_thread_ok (wset s) (thr s)   wset_thread_ok (wset s') (thr s')"
by(erule (1) RedT_lift_preserveD)(erule redT_preserves_wset_thread_ok)

lemma redT_new_thread_ts_Some:
  " s -tta s'; NewThread t' x m''  set tat; wset_thread_ok (wset s) (thr s) 
   thr s' t' = (x, no_wait_locks)"
by(erule redT_elims)(auto dest: thread_oks_new_thread elim: redT_updTs_new_thread_ts)

lemma RedT_new_thread_ts_not_None:
  " s -▹ttas→* s'; NewThread t x m''  set (concat (map (thr_a  snd) ttas)); wset_thread_ok (wset s) (thr s) 
    thr s' t  None"
proof(induct rule: RedT_induct)
  case refl thus ?case by simp
next
  case (step S TTAS S' T TA S'')
  note Red = S -▹TTAS→* S'
  note IH =  NewThread t x m''  set (concat (map (thr_a  snd) TTAS)); wset_thread_ok (wset S) (thr S)   thr S' t  None
  note red = S' -TTA S''
  note ins = NewThread t x m''  set (concat (map (thr_a  snd) (TTAS @ [(T, TA)])))
  note wto = wset_thread_ok (wset S) (thr S)
  from Red wto have wto': "wset_thread_ok (wset S') (thr S')" by(auto dest: RedT_preserves_wset_thread_ok)  
  show ?case
  proof(cases "NewThread t x m''  set TAt")
    case True thus ?thesis using red wto'
      by(auto dest!: redT_new_thread_ts_Some)
  next
    case False
    hence "NewThread t x m''  set (concat (map (thr_a  snd) TTAS))" using ins by(auto)
    hence "thr S' t  None" using wto by(rule IH)
    with red show ?thesis
      by -(erule contrapos_nn, auto dest: redT_thread_not_disappear)
  qed
qed

lemma redT_preserves_lock_thread_ok:
  " s -tta s'; lock_thread_ok (locks s) (thr s)   lock_thread_ok (locks s') (thr s')"
by(auto elim!: redT_elims intro: redT_upds_preserves_lock_thread_ok acquire_all_preserves_lock_thread_ok)

lemma RedT_preserves_lock_thread_ok:
  " s -▹ttas→* s'; lock_thread_ok (locks s) (thr s)   lock_thread_ok (locks s') (thr s')"
by(erule (1) RedT_lift_preserveD)(erule redT_preserves_lock_thread_ok)

lemma redT_ex_new_thread:
  assumes "s -t'ta s'" "wset_thread_ok (wset s) (thr s)" "thr s' t = (x, w)" "thr s t = None"
  shows "m. NewThread t x m  set tat  w = no_wait_locks"
using assms
by cases (fastforce split: if_split_asm dest: wset_thread_okD redT_updTs_new_thread)+

lemma redT_ex_new_thread':
  assumes "s -t'ta s'" "thr s' t = (x, w)" "thr s t = None"
  shows "m x. NewThread t x m  set tat"
using assms
by(cases)(fastforce split: if_split_asm dest!: redT_updTs_new_thread)+

definition deterministic :: "('l,'t,'x,'m,'w) state set  bool"
where
  "deterministic I  
  (s t x ta' x' m' ta'' x'' m''. 
    s  I
     thr s t = (x, no_wait_locks)
     t  x, shr s -ta' x', m' 
     t  x, shr s -ta'' x'', m'' 
     actions_ok s t ta'  actions_ok s t ta''
     ta' = ta''  x' = x''  m' = m'')  invariant3p redT I"

lemma determisticI:
  "s t x ta' x' m' ta'' x'' m''.
       s  I; thr s t = (x, no_wait_locks); 
        t  x, shr s -ta' x', m'; t  x, shr s -ta'' x'', m''; 
        actions_ok s t ta'; actions_ok s t ta'' 
       ta' = ta''  x' = x''  m' = m'';
    invariant3p redT I 
   deterministic I"
unfolding deterministic_def by blast

lemma deterministicD:
  " deterministic I;
    t  x, shr s -ta' x', m'; t  x, shr s -ta'' x'', m'';
    thr s t = (x, no_wait_locks); actions_ok s t ta'; actions_ok s t ta''; s  I 
   ta' = ta''  x' = x''  m' = m''"
unfolding deterministic_def by blast

lemma deterministic_invariant3p:
  "deterministic I  invariant3p redT I"
unfolding deterministic_def by blast

lemma deterministic_THE:
  " deterministic I; thr s t = (x, no_wait_locks); t  x, shr s -ta x', m'; actions_ok s t ta; s  I 
   (THE (ta, x', m'). t  x, shr s -ta x', m'  actions_ok s t ta) = (ta, x', m')"
by(rule the_equality)(blast dest: deterministicD)+

end

locale multithreaded = multithreaded_base +
  constrains final :: "'x  bool"
  and r :: "('l,'t,'x,'m,'w,'o) semantics"
  and convert_RA :: "'l released_locks  'o list"
  assumes new_thread_memory: " t  s -ta s'; NewThread t' x m  set tat   m = snd s'"
  and final_no_red: " t  (x, m) -ta (x', m'); final x   False"
begin

lemma redT_new_thread_common:
  " s -tta s'; NewThread t' x m''  set tat; taw = []   m'' = shr s'"
by(auto elim!: redT_elims rtrancl3p_cases dest: new_thread_memory)

lemma redT_new_thread:
  assumes "s -t'ta s'" "thr s' t = (x, w)" "thr s t = None" "taw = []"
  shows "NewThread t x (shr s')  set tat  w = no_wait_locks"
using assms
apply(cases rule: redT_elims)
apply(auto split: if_split_asm del: conjI elim!: rtrancl3p_cases)
apply(drule (2) redT_updTs_new_thread)
apply(auto dest: new_thread_memory)
done

lemma final_no_redT: 
  " s -tta s'; thr s t = (x, no_wait_locks)   ¬ final x"
by(auto elim!: redT_elims dest: final_no_red)

lemma mfinal_no_redT:
  assumes redT: "s -tta s'" and mfinal: "mfinal s"
  shows False
using redT mfinalD[OF mfinal, of t]
by cases (metis final_no_red, metis neq_no_wait_locks_conv)

end

end