header {* \isaheader{CFG well-formedness} *}

theory CFG_wf imports CFG begin

locale CFG_wf = CFG sourcenode targetnode kind valid_edge Entry
    get_proc get_return_edges procs Main
  for sourcenode :: "'edge \<Rightarrow> 'node" and targetnode :: "'edge \<Rightarrow> 'node"
  and kind :: "'edge \<Rightarrow> ('var,'val,'ret,'pname) edge_kind"
  and valid_edge :: "'edge \<Rightarrow> bool"
  and Entry :: "'node" ("'('_Entry'_')")  and get_proc :: "'node \<Rightarrow> 'pname"
  and get_return_edges :: "'edge \<Rightarrow> 'edge set"
  and procs :: "('pname \<times> 'var list \<times> 'var list) list" and Main :: "'pname" +
  fixes Def::"'node \<Rightarrow> 'var set"
  fixes Use::"'node \<Rightarrow> 'var set"
  fixes ParamDefs::"'node \<Rightarrow> 'var list"
  fixes ParamUses::"'node \<Rightarrow> 'var set list"
  assumes Entry_empty:"Def (_Entry_) = {} \<and> Use (_Entry_) = {}"
  and ParamUses_call_source_length:
    "\<lbrakk>valid_edge a; kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs; (p,ins,outs) \<in> set procs\<rbrakk>
    \<Longrightarrow> length(ParamUses (sourcenode a)) = length ins"
  and distinct_ParamDefs:"valid_edge a \<Longrightarrow> distinct (ParamDefs (targetnode a))"
  and ParamDefs_return_target_length:
    "\<lbrakk>valid_edge a; kind a = Q'\<hookleftarrow>\<^bsub>p\<^esub>f'; (p,ins,outs) \<in> set procs\<rbrakk>
    \<Longrightarrow> length(ParamDefs (targetnode a)) = length outs"
  and ParamDefs_in_Def:
    "\<lbrakk>valid_node n; V \<in> set (ParamDefs n)\<rbrakk> \<Longrightarrow> V \<in> Def n"
  and ins_in_Def:
    "\<lbrakk>valid_edge a; kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs; (p,ins,outs) \<in> set procs; V \<in> set ins\<rbrakk>
    \<Longrightarrow> V \<in> Def (targetnode a)"
  and call_source_Def_empty:
    "\<lbrakk>valid_edge a; kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs\<rbrakk> \<Longrightarrow> Def (sourcenode a) = {}"
  and ParamUses_in_Use:
    "\<lbrakk>valid_node n; V \<in> Union (set (ParamUses n))\<rbrakk> \<Longrightarrow> V \<in> Use n"
  and outs_in_Use:
    "\<lbrakk>valid_edge a; kind a = Q\<hookleftarrow>\<^bsub>p\<^esub>f; (p,ins,outs) \<in> set procs; V \<in> set outs\<rbrakk>
    \<Longrightarrow> V \<in> Use (sourcenode a)"
  and CFG_intra_edge_no_Def_equal:
    "\<lbrakk>valid_edge a; V \<notin> Def (sourcenode a); intra_kind (kind a); pred (kind a) s\<rbrakk>
    \<Longrightarrow> state_val (transfer (kind a) s) V = state_val s V"
  and CFG_intra_edge_transfer_uses_only_Use:
    "\<lbrakk>valid_edge a; \<forall>V \<in> Use (sourcenode a). state_val s V = state_val s' V;
      intra_kind (kind a); pred (kind a) s; pred (kind a) s'\<rbrakk>
    \<Longrightarrow> \<forall>V \<in> Def (sourcenode a). state_val (transfer (kind a) s) V =
                                state_val (transfer (kind a) s') V"
  and CFG_edge_Uses_pred_equal:
    "\<lbrakk>valid_edge a; pred (kind a) s; snd (hd s) = snd (hd s');
      \<forall>V \<in> Use (sourcenode a). state_val s V = state_val s' V; length s = length s'\<rbrakk>
    \<Longrightarrow> pred (kind a) s'"
  and CFG_call_edge_length:
    "\<lbrakk>valid_edge a; kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs; (p,ins,outs) \<in> set procs\<rbrakk>
    \<Longrightarrow> length fs = length ins"
  and CFG_call_determ:
    "\<lbrakk>valid_edge a; kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs; valid_edge a'; kind a' = Q':r'\<hookrightarrow>\<^bsub>p'\<^esub>fs';
      sourcenode a = sourcenode a'; pred (kind a) s; pred (kind a') s\<rbrakk>
    \<Longrightarrow> a = a'"
  and CFG_call_edge_params:
    "\<lbrakk>valid_edge a; kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs; i < length ins;
      (p,ins,outs) \<in> set procs; pred (kind a) s; pred (kind a) s';
      \<forall>V \<in> (ParamUses (sourcenode a))!i. state_val s V = state_val s' V\<rbrakk>
    \<Longrightarrow> (params fs (fst (hd s)))!i = (params fs (fst (hd s')))!i"
  and CFG_return_edge_fun:
    "\<lbrakk>valid_edge a; kind a = Q'\<hookleftarrow>\<^bsub>p\<^esub>f'; (p,ins,outs) \<in> set procs\<rbrakk>
     \<Longrightarrow> f' vmap vmap' = vmap'(ParamDefs (targetnode a) [:=] map vmap outs)"
  and deterministic:"\<lbrakk>valid_edge a; valid_edge a'; sourcenode a = sourcenode a';
    targetnode a \<noteq> targetnode a'; intra_kind (kind a); intra_kind (kind a')\<rbrakk>
    \<Longrightarrow> \<exists>Q Q'. kind a = (Q)\<^sub>\<surd> \<and> kind a' = (Q')\<^sub>\<surd> \<and>
             (\<forall>s. (Q s \<longrightarrow> \<not> Q' s) \<and> (Q' s \<longrightarrow> \<not> Q s))"

begin

lemma CFG_equal_Use_equal_call:
  assumes "valid_edge a" and "kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs" and "valid_edge a'"
  and "kind a' = Q':r'\<hookrightarrow>\<^bsub>p'\<^esub>fs'" and "sourcenode a = sourcenode a'"
  and "pred (kind a) s" and "pred (kind a') s'"
  and "snd (hd s) = snd (hd s')" and "length s = length s'"
  and "\<forall>V \<in> Use (sourcenode a). state_val s V = state_val s' V"
  shows "a = a'"
proof -
  from `valid_edge a` `pred (kind a) s` `snd (hd s) = snd (hd s')`
    `\<forall>V \<in> Use (sourcenode a). state_val s V = state_val s' V` `length s = length s'`
  have "pred (kind a) s'" by(rule CFG_edge_Uses_pred_equal)
  with `valid_edge a` `kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs` `valid_edge a'` `kind a' = Q':r'\<hookrightarrow>\<^bsub>p'\<^esub>fs'`
    `sourcenode a = sourcenode a'` `pred (kind a') s'`
  show ?thesis by -(rule CFG_call_determ)
qed

lemma CFG_call_edge_param_in:
  assumes "valid_edge a" and "kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs" and "i < length ins"
  and "(p,ins,outs) \<in> set procs" and "pred (kind a) s" and "pred (kind a) s'"
  and "\<forall>V \<in> (ParamUses (sourcenode a))!i. state_val s V = state_val s' V"
  shows "state_val (transfer (kind a) s) (ins!i) =
         state_val (transfer (kind a) s') (ins!i)"
proof -
  from assms have params:"(params fs (fst (hd s)))!i = (params fs (fst (hd s')))!i"
    by(rule CFG_call_edge_params)
  from `valid_edge a` `kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs` `(p,ins,outs) \<in> set procs`
  have [simp]:"(THE ins. \<exists>outs. (p,ins,outs) \<in> set procs) = ins"
    by(rule formal_in_THE)
  from `pred (kind a) s` obtain cf cfs where [simp]:"s = cf#cfs" by(cases s) auto
  from `pred (kind a) s'` obtain cf' cfs' where [simp]:"s' = cf'#cfs'"
    by(cases s') auto
  from `kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs`
  have eqs:"fst (hd (transfer (kind a) s)) = (empty(ins [:=] params fs (fst cf)))"
    "fst (hd (transfer (kind a) s')) = (empty(ins [:=] params fs (fst cf')))"
    by simp_all
  from `valid_edge a` `kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs` `(p,ins,outs) \<in> set procs`
  have "length fs = length ins" by(rule CFG_call_edge_length)
  from `(p,ins,outs) \<in> set procs` have "distinct ins" by(rule distinct_formal_ins)
  with `i < length ins` `length fs = length ins`
  have "(empty(ins [:=] params fs (fst cf))) (ins!i) = (params fs (fst cf))!i"
    "(empty(ins [:=] params fs (fst cf'))) (ins!i) = (params fs (fst cf'))!i"
    by(fastforce intro:fun_upds_nth)+
  with eqs `kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs` params
  show ?thesis by simp
qed

lemma CFG_call_edge_no_param:
  assumes "valid_edge a" and "kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs" and "V \<notin> set ins"
  and "(p,ins,outs) \<in> set procs" and "pred (kind a) s"
  shows "state_val (transfer (kind a) s) V = None"
proof -
  from `valid_edge a` `kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs` `(p,ins,outs) \<in> set procs`
  have [simp]:"(THE ins. \<exists>outs. (p,ins,outs) \<in> set procs) = ins"
    by(rule formal_in_THE)
  from `pred (kind a) s` obtain cf cfs where [simp]:"s = cf#cfs" by(cases s) auto
  from `V \<notin> set ins` have "(empty(ins [:=] params fs (fst cf))) V = None"
    by(auto dest:fun_upds_notin)
  with `kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs` show ?thesis by simp
qed

lemma CFG_return_edge_param_out:
  assumes "valid_edge a" and "kind a = Q\<hookleftarrow>\<^bsub>p\<^esub>f" and "i < length outs"
  and "(p,ins,outs) \<in> set procs" and "state_val s (outs!i) = state_val s' (outs!i)"
  and "s = cf#cfx#cfs" and "s' = cf'#cfx'#cfs'"
  shows "state_val (transfer (kind a) s) ((ParamDefs (targetnode a))!i) =
         state_val (transfer (kind a) s') ((ParamDefs (targetnode a))!i)"
proof -
  from `valid_edge a` `kind a = Q\<hookleftarrow>\<^bsub>p\<^esub>f` `(p,ins,outs) \<in> set procs`
  have [simp]:"(THE outs. \<exists>ins. (p,ins,outs) \<in> set procs) = outs"
    by(rule formal_out_THE)
  from `valid_edge a` `kind a = Q\<hookleftarrow>\<^bsub>p\<^esub>f` `(p,ins,outs) \<in> set procs` `s = cf#cfx#cfs`
  have transfer:"fst (hd (transfer (kind a) s)) =
    (fst cfx)(ParamDefs (targetnode a) [:=] map (fst cf) outs)"
    by(fastforce intro:CFG_return_edge_fun)
  from `valid_edge a` `kind a = Q\<hookleftarrow>\<^bsub>p\<^esub>f` `(p,ins,outs) \<in> set procs` `s' = cf'#cfx'#cfs'`
  have transfer':"fst (hd (transfer (kind a) s')) =
    (fst cfx')(ParamDefs (targetnode a) [:=] map (fst cf') outs)"
    by(fastforce intro:CFG_return_edge_fun)
  from `state_val s (outs!i) = state_val s' (outs!i)` `i < length outs`
    `s = cf#cfx#cfs` `s' = cf'#cfx'#cfs'`
  have "(fst cf) (outs!i) = (fst cf') (outs!i)" by simp
  from `valid_edge a` have "distinct (ParamDefs (targetnode a))"
    by(fastforce intro:distinct_ParamDefs)
  from `valid_edge a` `kind a = Q\<hookleftarrow>\<^bsub>p\<^esub>f` `(p,ins,outs) \<in> set procs`
  have "length(ParamDefs (targetnode a)) = length outs"
    by(fastforce intro:ParamDefs_return_target_length)
  with `i < length outs` `distinct (ParamDefs (targetnode a))`
  have "(fst cfx)(ParamDefs (targetnode a) [:=] map (fst cf) outs)
    ((ParamDefs (targetnode a))!i) = (map (fst cf) outs)!i"
    and "(fst cfx')(ParamDefs (targetnode a) [:=] map (fst cf') outs)
             ((ParamDefs (targetnode a))!i) = (map (fst cf') outs)!i"
    by(fastforce intro:fun_upds_nth)+
  with transfer transfer' `(fst cf) (outs!i) = (fst cf') (outs!i)` `i < length outs`
  show ?thesis by simp
qed

lemma CFG_slp_no_Def_equal:
  assumes "n -as\<rightarrow>\<^bsub>sl\<^esub>* n'" and "valid_edge a" and "a' \<in> get_return_edges a"
  and "V \<notin> set (ParamDefs (targetnode a'))" and "preds (kinds (a#as@[a'])) s"
  shows "state_val (transfers (kinds (a#as@[a'])) s) V = state_val s V"
proof -
  from `valid_edge a` `a' \<in> get_return_edges a`
  obtain Q r p fs where "kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs"
    by(fastforce dest!:only_call_get_return_edges)
  with `valid_edge a` `a' \<in> get_return_edges a` obtain Q' f' where "kind a' = Q'\<hookleftarrow>\<^bsub>p\<^esub>f'"
    by(fastforce dest!:call_return_edges)
  from `valid_edge a` `a' \<in> get_return_edges a` have "valid_edge a'"
    by(rule get_return_edges_valid)
  from `preds (kinds (a#as@[a'])) s` obtain cf cfs where [simp]:"s = cf#cfs"
    by(cases s,auto simp:kinds_def)
  from `valid_edge a` `kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs` obtain ins outs
    where "(p,ins,outs) \<in> set procs" by(fastforce dest!:callee_in_procs)
  from `kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs` obtain cfx where "transfer (kind a) s = cfx#cf#cfs"
    by simp
  moreover
  from `n -as\<rightarrow>\<^bsub>sl\<^esub>* n'` obtain cfx'
    where "transfers (kinds as) (cfx#cf#cfs) = cfx'#cf#cfs"
    by(fastforce elim:slp_callstack_length_equal)
  moreover
  from `kind a' = Q'\<hookleftarrow>\<^bsub>p\<^esub>f'` `valid_edge a'` `(p,ins,outs) \<in> set procs`
  have "fst (hd (transfer (kind a') (cfx'#cf#cfs))) =
    (fst cf)(ParamDefs (targetnode a') [:=] map (fst cfx') outs)"
    by(simp,simp only:formal_out_THE,fastforce intro:CFG_return_edge_fun)
  ultimately have "fst (hd (transfers (kinds (a#as@[a'])) s)) =
    (fst cf)(ParamDefs (targetnode a') [:=] map (fst cfx') outs)"
    by(simp add:kinds_def transfers_split)
  with `V \<notin> set (ParamDefs (targetnode a'))` show ?thesis
    by(simp add:fun_upds_notin)
qed

lemma [dest!]: "V \<in> Use (_Entry_) \<Longrightarrow> False"
by(simp add:Entry_empty)

lemma [dest!]: "V \<in> Def (_Entry_) \<Longrightarrow> False"
by(simp add:Entry_empty)

lemma CFG_intra_path_no_Def_equal:
  assumes "n -as\<rightarrow>\<^sub>\<iota>* n'" and "\<forall>n \<in> set (sourcenodes as). V \<notin> Def n"
  and "preds (kinds as) s"
  shows "state_val (transfers (kinds as) s) V = state_val s V"
proof -
  from `n -as\<rightarrow>\<^sub>\<iota>* n'` have "n -as\<rightarrow>* n'" and "\<forall>a \<in> set as. intra_kind (kind a)"
    by(simp_all add:intra_path_def)
  from this `\<forall>n \<in> set (sourcenodes as). V \<notin> Def n` `preds (kinds as) s`
  have "state_val (transfers (kinds as) s) V = state_val s V"
  proof(induct arbitrary:s rule:path.induct)
    case (empty_path n)
    thus ?case by(simp add:sourcenodes_def kinds_def)
  next
    case (Cons_path n'' as n' a n)
    note IH = `\<And>s. \<lbrakk>\<forall>a\<in>set as. intra_kind (kind a);
                    \<forall>n\<in>set (sourcenodes as). V \<notin> Def n; preds (kinds as) s\<rbrakk>
      \<Longrightarrow> state_val (transfers (kinds as) s) V = state_val s V`
    from `preds (kinds (a#as)) s` have "pred (kind a) s"
      and "preds (kinds as) (transfer (kind a) s)" by(simp_all add:kinds_def)
    from `\<forall>n\<in>set (sourcenodes (a#as)). V \<notin> Def n`
    have noDef:"V \<notin> Def (sourcenode a)"
      and all:"\<forall>n\<in>set (sourcenodes as). V \<notin> Def n"
      by(auto simp:sourcenodes_def)
    from `\<forall>a\<in>set (a#as). intra_kind (kind a)`
    have "intra_kind (kind a)" and all':"\<forall>a\<in>set as. intra_kind (kind a)"
      by auto
    from `valid_edge a` noDef `intra_kind (kind a)` `pred (kind a) s`
    have "state_val (transfer (kind a) s) V = state_val s V"
     by -(rule CFG_intra_edge_no_Def_equal)
    with IH[OF all' all `preds (kinds as) (transfer (kind a) s)`] show ?case
      by(simp add:kinds_def)
  qed
  thus ?thesis by blast
qed

lemma slpa_preds:
  "\<lbrakk>same_level_path_aux cs as; s = cfsx@cf#cfs; s' = cfsx@cf#cfs';
    length cfs = length cfs'; \<forall>a \<in> set as. valid_edge a; length cs = length cfsx;
    preds (kinds as) s\<rbrakk>
  \<Longrightarrow> preds (kinds as) s'"
proof(induct arbitrary:s s' cf cfsx rule:slpa_induct)
  case (slpa_empty cs) thus ?case by(simp add:kinds_def)
next
  case (slpa_intra cs a as)
  note IH = `\<And>s s' cf cfsx. \<lbrakk>s = cfsx@cf#cfs; s' = cfsx@cf#cfs';
    length cfs = length cfs'; \<forall>a \<in> set as. valid_edge a; length cs = length cfsx;
    preds (kinds as) s\<rbrakk> \<Longrightarrow> preds (kinds as) s'`
  from `\<forall>a\<in>set (a#as). valid_edge a` have "valid_edge a"
    and "\<forall>a \<in> set as. valid_edge a" by simp_all
  from `preds (kinds (a#as)) s` have "pred (kind a) s"
    and "preds (kinds as) (transfer (kind a) s)" by(simp_all add:kinds_def)
  show ?case
  proof(cases cfsx)
    case Nil
    with `length cs = length cfsx` have "length cs = length []" by simp
    from Nil `s = cfsx@cf#cfs` `s' = cfsx@cf#cfs'` `intra_kind (kind a)`
    obtain cfx where "transfer (kind a) s = []@cfx#cfs"
      and "transfer (kind a) s' = []@cfx#cfs'"
      by(cases "kind a",auto simp:kinds_def intra_kind_def)
    from IH[OF this `length cfs = length cfs'` `\<forall>a \<in> set as. valid_edge a`
      `length cs = length []` `preds (kinds as) (transfer (kind a) s)`]
    have "preds (kinds as) (transfer (kind a) s')" .
    moreover
    from Nil `valid_edge a` `pred (kind a) s` `s = cfsx@cf#cfs` `s' = cfsx@cf#cfs'`
      `length cfs = length cfs'`
    have "pred (kind a) s'" by(fastforce intro:CFG_edge_Uses_pred_equal)
    ultimately show ?thesis by(simp add:kinds_def)
  next
    case (Cons x xs)
    with `s = cfsx@cf#cfs` `s' = cfsx@cf#cfs'` `intra_kind (kind a)`
    obtain cfx where "transfer (kind a) s = (cfx#xs)@cf#cfs"
      and "transfer (kind a) s' = (cfx#xs)@cf#cfs'"
      by(cases "kind a",auto simp:kinds_def intra_kind_def)
    from IH[OF this `length cfs = length cfs'` `\<forall>a \<in> set as. valid_edge a` _
      `preds (kinds as) (transfer (kind a) s)`] `length cs = length cfsx` Cons
    have "preds (kinds as) (transfer (kind a) s')" by simp
    moreover
    from Cons `valid_edge a` `pred (kind a) s` `s = cfsx@cf#cfs` `s' = cfsx@cf#cfs'`
      `length cfs = length cfs'`
    have "pred (kind a) s'" by(fastforce intro:CFG_edge_Uses_pred_equal)
    ultimately show ?thesis by(simp add:kinds_def)
  qed
next
  case (slpa_Call cs a as Q r p fs)
  note IH = `\<And>s s' cf cfsx. \<lbrakk>s = cfsx@cf#cfs; s' = cfsx@cf#cfs';
    length cfs = length cfs'; \<forall>a \<in> set as. valid_edge a; length (a#cs) = length cfsx;
    preds (kinds as) s\<rbrakk> \<Longrightarrow> preds (kinds as) s'`
  from `\<forall>a\<in>set (a#as). valid_edge a` have "valid_edge a"
    and "\<forall>a \<in> set as. valid_edge a" by simp_all
  from `preds (kinds (a#as)) s` have "pred (kind a) s"
    and "preds (kinds as) (transfer (kind a) s)" by(simp_all add:kinds_def)
  from `kind a = Q:r\<hookrightarrow>\<^bsub>p\<^esub>fs` `s = cfsx@cf#cfs` `s' = cfsx@cf#cfs'` obtain cfx
    where "transfer (kind a) s = (cfx#cfsx)@cf#cfs"
    and "transfer (kind a) s' = (cfx#cfsx)@cf#cfs'" by(cases cfsx) auto
  from IH[OF this `length cfs = length cfs'` `\<forall>a \<in> set as. valid_edge a` _
    `preds (kinds as) (transfer (kind a) s)`] `length cs = length cfsx`
  have "preds (kinds as) (transfer (kind a) s')" by simp
  moreover
  from `valid_edge a` `pred (kind a) s` `s = cfsx@cf#cfs` `s' = cfsx@cf#cfs'`
    `length cfs = length cfs'` have "pred (kind a) s'"
    by(cases cfsx)(auto intro:CFG_edge_Uses_pred_equal)
  ultimately show ?case by(simp add:kinds_def)
next
  case (slpa_Return cs a as Q p f c' cs')
  note IH = `\<And>s s' cf cfsx. \<lbrakk>s = cfsx@cf#cfs; s' = cfsx@cf#cfs';
    length cfs = length cfs'; \<forall>a \<in> set as. valid_edge a; length cs' = length cfsx;
    preds (kinds as) s\<rbrakk> \<Longrightarrow> preds (kinds as) s'`
  from `\<forall>a\<in>set (a#as). valid_edge a` have "valid_edge a"
    and "\<forall>a \<in> set as. valid_edge a" by simp_all
  from `preds (kinds (a#as)) s` have "pred (kind a) s"
    and "preds (kinds as) (transfer (kind a) s)" by(simp_all add:kinds_def)
  show ?case
  proof(cases cs')
    case Nil
    with `cs = c'#cs'` `s = cfsx@cf#cfs` `s' = cfsx@cf#cfs'`
      `length cs = length cfsx`
    obtain cf' where "s = cf'#cf#cfs" and "s' = cf'#cf#cfs'" by(cases cfsx) auto
    with `kind a = Q\<hookleftarrow>\<^bsub>p\<^esub>f` obtain cf'' where "transfer (kind a) s = []@cf''#cfs"
      and "transfer (kind a) s' = []@cf''#cfs'" by auto
    from IH[OF this `length cfs = length cfs'` `\<forall>a \<in> set as. valid_edge a` _
      `preds (kinds as) (transfer (kind a) s)`] Nil
    have "preds (kinds as) (transfer (kind a) s')" by simp
    moreover
    from `valid_edge a` `pred (kind a) s` `s = cfsx@cf#cfs` `s' = cfsx@cf#cfs'`
      `length cfs = length cfs'`  have "pred (kind a) s'"
      by(cases cfsx)(auto intro:CFG_edge_Uses_pred_equal)
    ultimately show ?thesis by(simp add:kinds_def)
  next
    case (Cons cx csx)
    with `cs = c'#cs'` `length cs = length cfsx` `s = cfsx@cf#cfs` `s' = cfsx@cf#cfs'`
    obtain x x' xs where "s = (x#x'#xs)@cf#cfs" and "s' = (x#x'#xs)@cf#cfs'"
      and "length xs = length csx"
      by(cases cfsx,auto,case_tac list,fastforce+)
    with `kind a = Q\<hookleftarrow>\<^bsub>p\<^esub>f` obtain cf' where "transfer (kind a) s = (cf'#xs)@cf#cfs"
      and "transfer (kind a) s' = (cf'#xs)@cf#cfs'"
      by fastforce
    from IH[OF this `length cfs = length cfs'` `\<forall>a \<in> set as. valid_edge a` _
      `preds (kinds as) (transfer (kind a) s)`] Cons `length xs = length csx`
    have "preds (kinds as) (transfer (kind a) s')" by simp
    moreover
    from `valid_edge a` `pred (kind a) s` `s = cfsx@cf#cfs` `s' = cfsx@cf#cfs'`
      `length cfs = length cfs'`  have "pred (kind a) s'"
      by(cases cfsx)(auto intro:CFG_edge_Uses_pred_equal)
    ultimately show ?thesis by(simp add:kinds_def)
  qed
qed

lemma slp_preds:
  assumes "n -as\<rightarrow>\<^bsub>sl\<^esub>* n'" and "preds (kinds as) (cf#cfs)"
  and "length cfs = length cfs'"
  shows "preds (kinds as) (cf#cfs')"
proof -
  from `n -as\<rightarrow>\<^bsub>sl\<^esub>* n'` have "n -as\<rightarrow>* n'" and "same_level_path_aux [] as"
    by(simp_all add:slp_def same_level_path_def)
  from `n -as\<rightarrow>* n'` have "\<forall>a \<in> set as. valid_edge a" by(rule path_valid_edges)
  with `same_level_path_aux [] as` `preds (kinds as) (cf#cfs)`
    `length cfs = length cfs'`
  show ?thesis by(fastforce elim!:slpa_preds)
qed
end

end


(*<*)
theory Paxos_Proofs
imports Three_Step_MRU "../HO_Transition_System" Heard_Of.Majorities "../Quorums" Paxos_Defs
begin
(*>*)

subsection \<open>Proofs\<close>

type_synonym p_TS_state = "(nat \<times> (process \<Rightarrow> (val pstate)))"

definition Paxos_TS ::
  "(round \<Rightarrow> process HO)
  \<Rightarrow> (round \<Rightarrow> process HO)
  \<Rightarrow> (round \<Rightarrow> process)
  \<Rightarrow> p_TS_state TS"
where
  "Paxos_TS HOs SHOs crds = CHO_to_TS Paxos_Alg HOs SHOs (K o crds)"

lemmas Paxos_TS_defs = Paxos_TS_def CHO_to_TS_def Paxos_Alg_def CHOinitConfig_def
  Paxos_initState_def

definition Paxos_trans_step where
  "Paxos_trans_step HOs SHOs crds nxt_f snd_f stp \<equiv> \<Union>r \<mu>.
    {((r, cfg), (Suc r, cfg'))|cfg cfg'. three_step r = stp  \<and> (\<forall>p.
      \<mu> p \<in> get_msgs (snd_f r) cfg (HOs r) (SHOs r) p
      \<and> nxt_f r p (cfg p) (\<mu> p) (crds r) (cfg' p)
    )}"

lemma three_step_less_D:
  "0 < three_step r \<Longrightarrow> three_step r = 1 \<or> three_step r = 2"
  by(unfold three_step_def, arith)

lemma Paxos_trans:
  "CSHO_trans_alt Paxos_sendMsg Paxos_nextState HOs SHOs (K \<circ> crds) =
  Paxos_trans_step HOs SHOs crds next0 send0 0
  \<union> Paxos_trans_step HOs SHOs crds next1 send1 1
  \<union> Paxos_trans_step HOs SHOs crds next2 send2 2
  "
proof(rule equalityI)
  show "CSHO_trans_alt Paxos_sendMsg Paxos_nextState HOs SHOs (K \<circ> crds)
    \<subseteq> Paxos_trans_step HOs SHOs crds next0 send0 0 \<union>
       Paxos_trans_step HOs SHOs crds next1 send1 1 \<union>
       Paxos_trans_step HOs SHOs crds next2 send2 2"
  by(force simp add: CSHO_trans_alt_def Paxos_sendMsg_def Paxos_nextState_def
    Paxos_trans_step_def K_def dest!: three_step_less_D)
next
  show "Paxos_trans_step HOs SHOs crds next0 send0 0 \<union>
    Paxos_trans_step HOs SHOs crds next1 send1 1 \<union>
    Paxos_trans_step HOs SHOs crds next2 send2 2
    \<subseteq> CSHO_trans_alt Paxos_sendMsg Paxos_nextState HOs SHOs (K \<circ> crds)"
  by(force simp add: CSHO_trans_alt_def Paxos_sendMsg_def Paxos_nextState_def
    Paxos_trans_step_def K_def)
qed

type_synonym rHO = "nat \<Rightarrow> process HO"

subsubsection \<open>Refinement\<close>
(******************************************************************************)

definition coord_vote_to_set :: "nat \<Rightarrow> (process \<Rightarrow> (val pstate)) \<Rightarrow> val set" where
  "coord_vote_to_set r sc \<equiv> (let v = pstate.commt (sc (coord r)) in
      if v = None
          then {}
          else {the v})"

definition paxos_ref_rel :: "(three_step_mru_state \<times> p_TS_state)set" where
  "paxos_ref_rel = {(sa, (r, sc)).
    opt_mru_state.next_round sa = r
    \<and> opt_mru_state.decisions sa = pstate.decide o sc
    \<and> opt_mru_state.mru_vote sa = pstate.mru_vote o sc
    \<and> (three_step r = Suc 0 \<longrightarrow> three_step_mru_state.candidates sa = coord_vote_to_set r sc)
  }"

lemma mru_vote_evolution0:
  "\<forall>p. next0 r p (s p) (msgs p) (crd p) (s' p) \<Longrightarrow> mru_vote o s' = mru_vote o s"
  apply(rule_tac[!] ext, rename_tac x, erule_tac[!] x=x in allE)
  by(auto simp add: next0_def next2_def Let_def)

lemma mru_vote_evolution2:
  "\<forall>p. next2 r p (s p) (msgs p) (crd p) (s' p) \<Longrightarrow> mru_vote o s' = mru_vote o s"
  apply(rule_tac[!] ext, rename_tac x, erule_tac[!] x=x in allE)
  by(auto simp add: next0_def next2_def Let_def)

lemma decide_evolution:
  "\<forall>p. next0 r p (s p) (msgs p) (crd p) (s' p) \<Longrightarrow> decide o s = decide o s'"
  "\<forall>p. next1 r p (s p) (msgs p) (crd p) (s' p) \<Longrightarrow> decide o s = decide o s'"
  apply(rule_tac[!] ext, rename_tac x, erule_tac[!] x=x in allE)
  by(auto simp add: next0_def next1_def Let_def)

lemma msgs_mru_vote:
  assumes
  "\<mu> (coord r) \<in> get_msgs (send0 r) cfg (HOs r) (HOs r) (coord r)" (is "\<mu> ?p \<in> _")
  shows "((msgs_to_lvs (\<mu> ?p)) |` HOs r ?p) = (mru_vote o cfg) |` HOs r ?p" using assms
  by(auto simp add: get_msgs_benign send0_def restrict_map_def msgs_to_lvs_def
      mru_vote_to_msg_def map_comp_def intro!: ext split: option.split)

lemma step0_ref:
  "{paxos_ref_rel}
    (\<Union>r C. majorities.opt_mru_step0 r C),
    Paxos_trans_step HOs HOs crds next0 send0 0 {> paxos_ref_rel}"
proof(clarsimp simp add: PO_rhoare_defs Paxos_trans_step_def all_conj_distrib)
  fix r sa sc sc' \<mu>
  assume R: "(sa, (r, sc)) \<in> paxos_ref_rel"
    and r: "three_step r = 0"
    and \<mu>: "\<forall>p. \<mu> p \<in> get_msgs (send0 r) sc (HOs r) (HOs r) p"
        and nxt: "\<forall>p. next0 r p (sc p) (\<mu> p) (crds r) (sc' p)"
  note \<mu>nxt = \<mu> nxt
  from r have same_coord: "coord (Suc r) = coord r"
    by(auto simp add: three_step_phase_Suc intro: coord_phase)
  define C where "C = coord_vote_to_set (Suc r) sc'"
  have guard: "\<forall>cand\<in>C. \<exists>Q. majorities.opt_mru_guard (mru_vote \<circ> sc) Q cand"
  proof
    fix cand
    assume cand: "cand \<in> C"
    hence Some: "commt (sc' (coord r)) = Some cand" using nxt[THEN spec, where x="coord r"]
      by(auto simp add: C_def coord_vote_to_set_def Let_def same_coord)

    let ?Q = "HOs r (coord r)"
    let ?lvs0 = "mru_vote o sc"

    have "?Q \<in> majs" using Some \<mu>nxt[THEN spec, where x="coord r"]
      by(auto simp add: Let_def majs_def next0_def same_coord get_msgs_dom)
    moreover have
      "map_option snd (option_Max_by fst (ran (?lvs |` ?Q))) \<in> {None, Some cand}"
      using Some nxt[THEN spec, where x="coord r"]
      msgs_mru_vote[where HOs=HOs and \<mu>=\<mu>, OF \<mu>[THEN spec, where x="coord r"]]
      get_msgs_dom[OF \<mu>[THEN spec, of "coord r"]]
      by(auto simp add: next0_def Let_def split: option.split_asm)
    ultimately have "majorities.opt_mru_guard ?lvs0 ?Q cand"
      by(auto simp add: majorities.opt_mru_guard_def Let_def majorities.opt_mru_vote_def)
    thus "\<exists>Q. majorities.opt_mru_guard ?lvs0 Q cand"
      by blast
  qed

  define sa' where "sa' = sa\<lparr>
      next_round := Suc r,
      candidates := C
    \<rparr>"
  have "(sa, sa') \<in> majorities.opt_mru_step0 r C" using R r nxt guard
    by(auto simp add: majorities.opt_mru_step0_def sa'_def paxos_ref_rel_def)
  moreover have "(sa', (Suc r, sc')) \<in> paxos_ref_rel" using R nxt
    apply(auto simp add: sa'_def paxos_ref_rel_def intro!:
      mru_vote_evolution0[OF nxt, symmetric] decide_evolution(1)[OF nxt])
       apply(auto simp add: Let_def C_def o_def intro!: ext)
    done
  ultimately show
    "\<exists>sa'. (\<exists>r C. (sa, sa') \<in> majorities.opt_mru_step0 r C)
        \<and> (sa', Suc r, sc') \<in> paxos_ref_rel"
    by blast
qed

lemma step1_ref:
  "{paxos_ref_rel}
    (\<Union>r S v. majorities.opt_mru_step1 r S v),
    Paxos_trans_step HOs HOs crds next1 send1 (Suc 0) {> paxos_ref_rel}"
proof(clarsimp  simp add: PO_rhoare_defs Paxos_trans_step_def all_conj_distrib)
  fix r sa sc sc' \<mu>
  assume R: "(sa, (r, sc)) \<in> paxos_ref_rel"
    and r: "three_step r = Suc 0"
    and \<mu>: "\<forall>p. \<mu> p \<in> get_msgs (send1 r) sc (HOs r) (HOs r) p"
        and nxt: "\<forall>p. next1 r p (sc p) (\<mu> p) (crds r) (sc' p)"
  note \<mu>nxt = \<mu> nxt

  define v where "v = the (commt (sc (coord r)))"
  define S where "S = {p. coord r \<in> HOs r p \<and> commt (sc (coord r)) \<noteq> None}"
  define sa' where "sa' = sa\<lparr> next_round := Suc r,
    opt_mru_state.mru_vote := opt_mru_state.mru_vote sa ++ const_map (three_phase r, v) S
  \<rparr>"
  have "(sa, sa') \<in> majorities.opt_mru_step1 r S v" using r R
    by(clarsimp simp add: majorities.opt_mru_step1_def sa'_def  S_def v_def
      coord_vote_to_set_def paxos_ref_rel_def)
  moreover have "(sa', (Suc r, sc')) \<in> paxos_ref_rel" using r R
  proof-
    have "mru_vote o sc' = ((mru_vote \<circ> sc) ++ const_map (three_phase r, v) S)"
    proof(rule ext, simp)
      fix p
      show "mru_vote (sc' p) = ((mru_vote \<circ> sc) ++ const_map (three_phase r, v) S) p"
        using \<mu>nxt[THEN spec, of p]
        by(auto simp add: get_msgs_benign next1_def send1_def S_def v_def map_add_def
          const_map_is_None const_map_is_Some restrict_map_def isVote_def split: option.split)
    qed
    thus ?thesis using R r nxt
      by(force simp add: paxos_ref_rel_def sa'_def three_step_Suc intro: decide_evolution)
  qed
  ultimately show
    "\<exists>sa'. (\<exists>r S v. (sa, sa') \<in> majorities.opt_mru_step1 r S v)
        \<and> (sa', Suc r, sc') \<in> paxos_ref_rel"
    by blast
qed

  define dec_f
    where "dec_f p = (if decide (sc' p) \<noteq> decide (sc p) then decide (sc' p) else None)" for p

  have dec_f: "(decide \<circ> sc) ++ dec_f = decide \<circ> sc'"
  proof
    fix p
    show "((decide \<circ> sc) ++ dec_f) p = (decide \<circ> sc') p" using nxt[THEN spec, of p]
      by(auto simp add: map_add_def dec_f_def next2_def split: option.split intro!: ext)
  qed

  define sa' where "sa' = sa\<lparr>
    next_round := Suc r,
    decisions := decisions sa ++ dec_f
  \<rparr>"

  have "(sa', (Suc r, sc')) \<in> paxos_ref_rel" using R r nxt
    by(auto simp add: paxos_ref_rel_def sa'_def dec_f three_step_Suc
      mru_vote_evolution2[OF nxt])
  moreover have "(sa, sa') \<in> majorities.opt_mru_step2 r dec_f" using r R
  proof-
    define sc_r_votes where "sc_r_votes p = (if (\<exists>v. mru_vote (sc p) = Some (three_phase r, v))
        then map_option snd (mru_vote (sc p))
        else None)" for p
    have sc_r_votes: "sc_r_votes = majorities.r_votes sa r" using R r
      by(auto simp add: paxos_ref_rel_def sc_r_votes_def majorities.r_votes_def intro!: ext)
    have "majorities.step2_d_guard dec_f sc_r_votes"
    proof(clarsimp simp add: majorities.step2_d_guard_def)
      fix p v
      assume d_f_p: "dec_f p = Some v"
      let ?Qv = "votes_rcvd (\<mu> p)"
      have Qv: "card ?Qv > N div 2"
        "v = the_rcvd_vote (\<mu> p)" using nxt[THEN spec, of p] d_f_p
        by(auto simp add: next2_def dec_f_def)

      hence "v \<in> snd ` votes_rcvd (\<mu> p)"
        by(fastforce simp add: the_rcvd_vote_def ex_in_conv[symmetric]
          dest!: card_gt_0_iff[THEN iffD1, OF le_less_trans[OF le0]] elim!: imageI intro: someI)
      moreover have "?Qv = map_graph (sc_r_votes) \<inter> (HOs r p \<times> UNIV)" using \<mu>[THEN spec, of p]
        by(auto simp add: get_msgs_benign send2_def restrict_map_def votes_rcvd_def
          sc_r_votes_def image_def split: option.split_asm)
      ultimately show "v \<in> ran sc_r_votes \<and> dom sc_r_votes \<in> majs" using Qv(1)
        by(auto simp add: majs_def inj_on_def map_graph_def fun_graph_def sc_r_votes_def
          the_rcvd_vote_def majs_def intro: ranI
          elim!: less_le_trans intro!: card_inj_on_le[where f=fst])
    qed

    thus ?thesis using r R
      by(auto simp add: majorities.opt_mru_step2_def sa'_def paxos_ref_rel_def sc_r_votes)
  qed

  ultimately show
    "\<exists>sa'. (\<exists>r dec_f. (sa, sa') \<in> majorities.opt_mru_step2 r dec_f)
        \<and> (sa', Suc r, sc') \<in> paxos_ref_rel"
    by blast

qed

lemma Paxos_Refines_ThreeStep_MRU:
  "PO_refines paxos_ref_rel
    majorities.ts_mru_TS (Paxos_TS HOs HOs crds)"
proof(rule refine_basic)
  show "init (Paxos_TS HOs HOs crds) \<subseteq> paxos_ref_rel `` init majorities.ts_mru_TS"
    by(auto simp add: Paxos_TS_defs majorities.ts_mru_TS_def paxos_ref_rel_def
      majorities.ts_mru_init_def)
next
  show
    "{paxos_ref_rel} TS.trans majorities.ts_mru_TS,
      TS.trans (Paxos_TS HOs HOs crds) {> paxos_ref_rel}"
    apply(simp add: majorities.ts_mru_TS_defs Paxos_TS_defs)
    apply(auto simp add: CHO_trans_alt Paxos_trans intro!: step0_ref step1_ref step2_ref)
    done
qed

subsubsection \<open>Termination\<close>
(******************************************************************************)

theorem Paxos_termination:
  assumes run: "CHORun Paxos_Alg rho HOs crds"
      and commR: "\<forall>r. CHOcommPerRd Paxos_M r (HOs r) (crds r)"
      and commG: "CHOcommGlobal Paxos_M HOs crds"
  shows "\<exists>r v. decide (rho r p) = Some v"
proof -
  from commG obtain ph c where
    HOs:
       "coord (nr_steps*ph) = c
         \<and> card (HOs (nr_steps*ph) c) > N div 2
         \<and> (\<forall>p. c \<in> HOs (nr_steps*ph+1) p)
         \<and> (\<forall>p. card (HOs (nr_steps*ph+2) p) > N div 2)"
    by(auto simp add: Paxos_CHOMachine_def Paxos_commGlobal_def)

  \<comment> \<open>The tedious bit: obtain three consecutive rounds linked by send/next functions\<close>
  define r0 where "r0 = nr_steps * ph"
  define cfg0 where "cfg0 = rho r0"
  define r1 where "r1 = Suc r0"
  define cfg1 where "cfg1 = rho r1"
  define r2 where "r2 = Suc r1"
  define cfg2 where "cfg2 = rho r2"
  define cfg3 where "cfg3 = rho (Suc r2)"

  from
    run[simplified CHORun_def, THEN CSHORun_step, THEN spec, where x="r0"]
    run[simplified CHORun_def, THEN CSHORun_step, THEN spec, where x="r1"]
    run[simplified CHORun_def, THEN CSHORun_step, THEN spec, where x="r2"]
    obtain \<mu>0 \<mu>1 \<mu>2 where
    send0: "\<forall>p. \<mu>0 p \<in> get_msgs (send0 r0) cfg0 (HOs r0) (HOs r0) p"
    and three_step0: "\<forall>p. next0 r0 p (cfg0 p) (\<mu>0 p) (crds (Suc r0) p) (cfg1 p)"
    and send1: "\<forall>p. \<mu>1 p \<in> get_msgs (send1 r1) cfg1 (HOs r1) (HOs r1) p"
    and three_step1: "\<forall>p. next1 r1 p (cfg1 p) (\<mu>1 p) (crds (Suc r1) p) (cfg2 p)"
    and send2: "\<forall>p. \<mu>2 p \<in> get_msgs (send2 r2) cfg2 (HOs r2) (HOs r2) p"
    and three_step2: "\<forall>p. next2 r2 p (cfg2 p) (\<mu>2 p) (crds (Suc r2) p) (cfg3 p)"
    apply(auto simp add: Paxos_Alg_def three_step_def Paxos_nextState_def Paxos_sendMsg_def all_conj_distrib
      r0_def r1_def r2_def
      cfg0_def cfg1_def cfg2_def cfg3_def mod_Suc
      )
    done

  \<comment> \<open>The proof: the coordinator hears enough messages in r0 and thus selects a value.\<close>

  from HOs three_step0[THEN spec, of c] send0[THEN spec, of c]
    have
    "commt (cfg1 c) \<noteq> None"
    by(auto simp add: next0_def Let_def r0_def get_msgs_dom)

  then obtain dec_v where dec_v: "commt (cfg1 c) = Some dec_v"
    by (metis option.collapse)

  have step_r0: "three_step r0 = 0"
    by(auto simp add: r0_def three_step_def)
  hence same_coord:
    "coord r1 = coord r0"
    "coord r2 = coord r0"
    by(auto simp add: three_step_phase_Suc r2_def r1_def r0_def intro!: coord_phase)

  \<comment> \<open>All processes hear from the coordinator, and thus set their vote to @{term dec_v}.\<close>
  hence all_vote: "\<forall>p. mru_vote (cfg2 p) = Some (three_phase r2, dec_v)"
    using HOs three_step1 send1 step_r0 dec_v
    by(auto simp add: next1_def Let_def get_msgs_benign send1_def restrict_map_def isVote_def
      r2_def r1_def r0_def[symmetric] same_coord[simplified r2_def r1_def] three_step_phase_Suc)

  \<comment> \<open>And finally, everybody will also decide @{term dec_v}.\<close>
  have all_decide: "\<forall>p. decide (cfg3 p) = Some dec_v"
  proof
    fix p
    have "votes_rcvd (\<mu>2 p) = HOs r2 p \<times> {dec_v}" using send2[THEN spec, where x=p] all_vote
      by(auto simp add: send2_def get_msgs_benign votes_rcvd_def restrict_map_def image_def o_def)

    moreover from HOs have "N div 2 < card (HOs r2 p)"
      by(auto simp add: r2_def r1_def r0_def)

    moreover then have "HOs r2 p \<noteq> {}"
      by (metis card_empty less_nat_zero_code)
    ultimately show "decide (cfg3 p) = Some dec_v"
    using three_step2[THEN spec, where x=p] send2[THEN spec, where x=p] all_vote
      by(auto simp add: next2_def send2_def Let_def get_msgs_benign
        the_rcvd_vote_def restrict_map_def image_def o_def)
  qed

  thus ?thesis
    by(auto simp add: cfg3_def)

qed

end


theory Events
  imports
Main
Integers
Floats
AST
Globalenvs
begin

section \<open>Events and traces\<close>

(** The observable behaviour of programs is stated in terms of
  input/output events, which represent the actions of the program
  that the external world can observe.  CompCert leaves much flexibility as to
  the exact content of events: the only requirement is that they
  do not expose memory states nor pointer values
  (other than pointers to global variables), because these
  are not preserved literally during compilation.  For concreteness,
  we use the following type for events.  Each event represents either:

- A system call (e.g. an input/output operation), recording the
  name of the system call, its parameters, and its result.

- A volatile load from a global memory location, recording the chunk
  and address being read and the value just read.

- A volatile store to a global memory location, recording the chunk
  and address being written and the value stored there.

- An annotation, recording the text of the annotation and the values
  of the arguments.

  The values attached to these events are of the following form.
  As mentioned above, we do not expose pointer values directly.
  Pointers relative to a global variable are shown with the name
  of the variable instead of the block identifier.
*)

datatype eventval =
  EVint m_int
| EVlong m_int64
| EVfloat float64
| EVsingle float32
| EVptr_global AST.ident m_ptrofs

datatype event =
  Event_syscall string "eventval list" eventval
| Event_vload memory_chunk AST.ident m_ptrofs eventval
| Event_vstore memory_chunk AST.ident m_ptrofs eventval
| Event_annot string "eventval list"

(** The dynamic semantics for programs collect traces of events.
  Traces are of two kinds: finite (type [trace]) or infinite (type [traceinf]). *)

type_synonym trace = "event list"
abbreviation E0 :: trace where "E0 \<equiv> []"

codatatype traceinf = Econsinf event traceinf

fun Eappinf :: "trace \<Rightarrow> traceinf \<Rightarrow> traceinf" where
  "Eappinf [] T = T"
| "Eappinf (ev # evs) T = Econsinf ev (Eappinf evs T)"

section \<open>Relating values and event values\<close>

context
  fixes ge :: Senv_t
begin

(** Validity *)

fun eventval_valid :: "eventval \<Rightarrow> bool" where
  "eventval_valid (EVint _) = True"
| "eventval_valid (EVlong _) = True"
| "eventval_valid (EVfloat _) = True"
| "eventval_valid (EVsingle _) = True"
| "eventval_valid (EVptr_global ident ofs) = (Senv.public_symbol ge ident = True)"

fun eventval_type :: "eventval \<Rightarrow> type" where
  "eventval_type (EVint _) = Tint"
| "eventval_type (EVlong _) = Tlong"
| "eventval_type (EVfloat _) = Tfloat"
| "eventval_type (EVsingle _) = Tsingle"
| "eventval_type (EVptr_global ident ofs) = Tptr"

end

(** Compatibility with memory injections *)

definition symbols_inject :: "(block \<Rightarrow> (block * Z) option) \<Rightarrow> Senv_t \<Rightarrow> Senv_t \<Rightarrow> bool" where
  "symbols_inject f ge1 ge2 \<equiv>
    (\<forall> ident. Senv.public_symbol ge2 ident = Senv.public_symbol ge1 ident)
  \<and> (\<forall> ident b1 b2 delta.
       f b1 = Some(b2, delta) \<longrightarrow> Senv.find_symbol ge1 ident = Some b1 \<longrightarrow>
       delta = 0 \<and> Senv.find_symbol ge2 ident = Some b2)
  \<and> (\<forall> ident b1.
       Senv.public_symbol ge1 ident = True \<longrightarrow> Senv.find_symbol ge1 ident = Some b1 \<longrightarrow>
       (\<exists> b2. f b1 = Some(b2, 0) \<and> Senv.find_symbol ge2 ident = Some b2))
  \<and> (\<forall> b1 b2 delta.
       f b1 = Some(b2, delta) \<longrightarrow>
       Senv.block_is_volatile ge2 b2 = Senv.block_is_volatile ge1 b1)"

section \<open>Matching traces\<close>

context
  fixes ge :: Senv_t
begin

(** Matching between traces corresponding to single transitions.
  Arguments (provided by the program) must be equal.
  Results (provided by the outside world) can vary as long as they
  can be converted safely to values. *)

inductive match_traces :: "trace \<Rightarrow> trace \<Rightarrow> bool" where
    match_traces_E0:
      "match_traces [] []"
  | match_traces_syscall:
      "eventval_valid ge res1 \<Longrightarrow> eventval_valid ge res2 \<Longrightarrow> eventval_type res1 = eventval_type res2 \<Longrightarrow>
      match_traces (Event_syscall ident args res1 # []) (Event_syscall ident args res2 # [])"
  | match_traces_vload:
      "eventval_valid ge res1 \<Longrightarrow> eventval_valid ge res2 \<Longrightarrow> eventval_type res1 = eventval_type res2 \<Longrightarrow>
      match_traces (Event_vload chunk ident ofs res1 # []) (Event_vload chunk ident ofs res2 # [])"
  | match_traces_vstore:
      "match_traces (Event_vstore chunk ident ofs a # []) (Event_vstore chunk ident ofs a # [])"
  | match_traces_annot:
      "match_traces (Event_annot ident args # []) (Event_annot ident args # [])"

end

section \<open>Semantics of external functions\<close>

(** For each external function, its behavior is defined by a predicate relating:
- the global symbol environment
- the values of the arguments passed to this function
- the memory state before the call
- the result value of the call
- the memory state after the call
- the trace generated by the call (can be empty).
*)

type_synonym extcall_sem = "Senv_t \<Rightarrow> val list \<Rightarrow> mem \<Rightarrow> trace \<Rightarrow> val \<Rightarrow> mem \<Rightarrow> bool"

(** We now specify the expected properties of this predicate. *)

definition loc_out_of_bounds :: "mem \<Rightarrow> block \<Rightarrow> Z \<Rightarrow> bool" where
  "loc_out_of_bounds m b ofs \<equiv> ~Mem.perm m b ofs Max Nonempty"

definition loc_not_writable :: "mem \<Rightarrow> block \<Rightarrow> Z \<Rightarrow> bool" where
  "loc_not_writable m b ofs \<equiv> ~Mem.perm m b ofs Max Writable"

definition loc_unmapped :: "meminj \<Rightarrow> block \<Rightarrow> Z \<Rightarrow> bool" where
  "loc_unmapped f b ofs \<equiv> f b = None"

definition loc_out_of_reach :: "meminj \<Rightarrow> mem \<Rightarrow> block \<Rightarrow> Z \<Rightarrow> bool" where
  "loc_out_of_reach f m b ofs \<equiv>
    \<forall> b0 delta.
    f b0 = Some(b, delta) \<longrightarrow> ~Mem.perm m b0 (ofs - delta) Max Nonempty"

definition inject_separated :: "meminj \<Rightarrow> meminj \<Rightarrow> mem \<Rightarrow> mem \<Rightarrow> bool" where
  "inject_separated f f' m1 m2 \<equiv>
    \<forall> b1 b2 delta.
    f b1 = None \<longrightarrow> f' b1 = Some(b2, delta) \<longrightarrow>
    ~Mem.valid_block m1 b1 \<and> ~Mem.valid_block m2 b2"

context
  fixes sem :: extcall_sem
  fixes sg :: signature
begin

named_theorems extcall_properties_defs'

(** The return value of an external call must agree with its signature. *)
definition [extcall_properties_defs']: "ec_well_typed \<equiv>
  (\<forall> ge vargs m1 t vres m2.
    sem ge vargs m1 t vres m2 \<longrightarrow>
    Val.has_rettype vres (sig_res sg))"

(** The semantics is invariant under change of global environment that preserves symbols. *)
definition [extcall_properties_defs']: "ec_symbols_preserved \<equiv>
  (\<forall> ge1 ge2 vargs m1 t vres m2.
    Senv.equiv ge1 ge2 \<longrightarrow>
    sem ge1 vargs m1 t vres m2 \<longrightarrow>
    sem ge2 vargs m1 t vres m2)"

(** External calls cannot invalidate memory blocks.  (Remember that
  freeing a block does not invalidate its block identifier.) *)
definition [extcall_properties_defs']: "ec_valid_block \<equiv>
  (\<forall> ge vargs m1 t vres m2 b.
    sem ge vargs m1 t vres m2 \<longrightarrow>
    Mem.valid_block m1 b \<longrightarrow> Mem.valid_block m2 b)"

(** External calls cannot increase the max permissions of a valid block.
    They can decrease the max permissions, e.g. by freeing. *)
definition [extcall_properties_defs']: "ec_max_perm \<equiv>
  (\<forall> ge vargs m1 t vres m2 b ofs p.
    sem ge vargs m1 t vres m2 \<longrightarrow>
    Mem.valid_block m1 b \<longrightarrow> Mem.perm m2 b ofs Max p \<longrightarrow> Mem.perm m1 b ofs Max p)"

(** External call cannot modify memory unless they have [Max, Writable]
   permissions. *)
definition [extcall_properties_defs']: "ec_readonly \<equiv>
  (\<forall> ge vargs m1 t vres m2 b ofs n bytes.
    sem ge vargs m1 t vres m2 \<longrightarrow>
    Mem.valid_block m1 b \<longrightarrow>
    Mem.loadbytes m2 b ofs n = Some bytes \<longrightarrow>
    (\<forall> i ofs. ofs <= i \<and> i < ofs + n \<longrightarrow> ~Mem.perm m1 b i Max Writable) \<longrightarrow>
    Mem.loadbytes m1 b ofs n = Some bytes)"

(** External calls must commute with memory extensions, in the
  following sense. *)
definition [extcall_properties_defs']: "ec_mem_extends \<equiv>
  (\<forall> ge vargs m1 t vres m2 m1' vargs'.
    sem ge vargs m1 t vres m2 \<longrightarrow>
    Mem.extends m1 m1' \<longrightarrow>
    Val.lessdef_list vargs vargs' \<longrightarrow>
    (\<exists> vres'. \<exists> m2'.
       sem ge vargs' m1' t vres' m2'
    \<and> Val.lessdef vres vres'
    \<and> Mem.extends m2 m2'
    \<and> Mem.unchanged_on (loc_out_of_bounds m1) m1' m2'))"

(** External calls must commute with memory injections,
  in the following sense. *)
definition [extcall_properties_defs']: "ec_mem_inject \<equiv>
  (\<forall> ge1 ge2 vargs m1 t vres m2 f m1' vargs'.
    symbols_inject f ge1 ge2 \<longrightarrow>
    sem ge1 vargs m1 t vres m2 \<longrightarrow>
    Mem.inject f m1 m1' \<longrightarrow>
    Val.inject_list f vargs vargs' \<longrightarrow>
    (\<exists> f' vres' m2'.
       sem ge2 vargs' m1' t vres' m2'
    \<and> Val.inject f' vres vres'
    \<and> Mem.inject f' m2 m2'
    \<and> Mem.unchanged_on (loc_unmapped f) m1 m2
    \<and> Mem.unchanged_on (loc_out_of_reach f m1) m1' m2'
    \<and> inject_incr f f'
    \<and> inject_separated f f' m1 m1'))"

(** External calls produce at most one event. *)
definition [extcall_properties_defs']: "ec_trace_length \<equiv>
  (\<forall> ge vargs m t vres m'.
    sem ge vargs m t vres m' \<longrightarrow> (length t \<le> 1))"

(** External calls must be receptive to changes of traces by another, matching trace. *)
definition [extcall_properties_defs']: "ec_receptive \<equiv>
  (\<forall> ge vargs m t1 vres1 m1 t2.
    sem ge vargs m t1 vres1 m1 \<longrightarrow> match_traces ge t1 t2 \<longrightarrow>
    (\<exists> vres2. \<exists> m2. sem ge vargs m t2 vres2 m2))"

(** External calls must be deterministic up to matching between traces. *)
definition [extcall_properties_defs']: "ec_determ \<equiv>
  (\<forall> ge vargs m t1 vres1 m1 t2 vres2 m2.
    sem ge vargs m t1 vres1 m1 \<longrightarrow> sem ge vargs m t2 vres2 m2 \<longrightarrow>
    match_traces ge t1 t2 \<and> (t1 = t2 \<longrightarrow> vres1 = vres2 \<and> m1 = m2))"

inductive extcall_properties where
  "\<lbrakk> ec_well_typed;
    ec_symbols_preserved;
    ec_valid_block;
    ec_max_perm;
    ec_readonly;
    ec_mem_extends;
    ec_mem_inject;
    ec_trace_length;
    ec_receptive;
    ec_determ \<rbrakk> \<Longrightarrow>
  extcall_properties"

lemmas extcall_properties_def = extcall_properties_defs' extcall_properties.simps[simplified]
end

subsection \<open>Semantics of dynamic memory allocation (malloc)\<close>

inductive extcall_malloc_sem :: "Senv_t \<Rightarrow> val list \<Rightarrow> mem \<Rightarrow> trace \<Rightarrow> val \<Rightarrow> mem \<Rightarrow> bool" where
    extcall_malloc_sem_intro:
      "Mem.alloc m (- size_chunk Mptr) (Int64.unsigned sz) = (m', b) \<Longrightarrow>
      Mem.store Mptr m' b (- size_chunk Mptr) (Vptrofs sz) = Some m'' \<Longrightarrow>
      extcall_malloc_sem ge [Vptrofs sz] m E0 (Vptr b 0) m''"

lemma extcall_malloc_unchanged_on:
  assumes "Mem.mem_invariants m"
  assumes "extcall_malloc_sem ge vargs m t vres m''"
  shows "extcall_malloc_sem ge vargs m t vres m'' \<and> Mem.unchanged_on P m m''"
  apply (simp add: assms(2))
  using assms(2)
proof (cases rule: extcall_malloc_sem.cases)
  case (extcall_malloc_sem_intro sz m' b)

  from \<open>Mem.alloc m (- size_chunk Mptr) (Int64.unsigned sz) = (m', b)\<close>
  have b'b: "\<And>b'. Mem.valid_block m b' \<Longrightarrow> b' \<noteq> b"
    using Mem.alloc_valid_block(2) by auto

  have unchanged1: "Mem.unchanged_on P m m'"
    using Mem.alloc_unchanged_on assms(1) local.extcall_malloc_sem_intro(4) by auto

  from \<open>Mem.store Mptr m' b (- size_chunk Mptr) (Vptrofs sz) = Some m''\<close>
  have unchanged2: "Mem.unchanged_on (\<lambda>b ofs. P b ofs \<and> Mem.valid_block m b) m' m''"
    apply (rule Mem.store_unchanged_on)
    using b'b by simp

  note rule = Mem.unchanged_on_trans[OF assms(1), OF unchanged1 unchanged2]

  then show "Mem.unchanged_on P m m''"
    by simp
qed

lemma extcall_malloc_ok:
  "extcall_properties extcall_malloc_sem
                     (mksignature (Tptr # []) (Tret Tptr) cc_default)"
  unfolding extcall_properties_def
  apply (safe elim!: extcall_malloc_sem.cases intro: extcall_malloc_sem_intro)
proof (goal_cases)
  case (1 ge vargs m1 t vres m2 m sz m' b m'' gea)
  then show ?case
    by (simp add: signature.defs)
next
  case (2 ge1 ge2 vargs m1 t vres m2 m sz m' b m'' ge)
  then show ?case
    using "2"(2) "2"(3) extcall_malloc_sem_intro by blast
next
  case (3 ge vargs m1 t vres m2 b m sz m' ba m'' gea)

  then show ?case
    by (meson Mem'.alloc_valid_block(1) Mem'.store_valid_block)
next
  case (4 ge vargs m1 t vres m2 b ofs p m sz m' ba m'' gea)

  then show ?case
    by (meson Mem.alloc_max_perm Mem.store_max_perm)
next
  case (5 ge vargs m1 t vres m2 b ofs n bytes m sz m' ba m'' gea)
  then show ?case sorry
next
  case (6 ge vargs m1 t vres m2 m1' vargs' m sz m' b m'' gea)
  then show ?case sorry
next
  case (7 ge1 ge2 vargs m1 t vres m2 f m1' vargs' m sz m' b m'' ge)
  then show ?case sorry
next
  case (8 ge vargs m t vres m' ma sz m'a b m'' gea)
then show ?case sorry
next
  case (9 ge vargs m t1 vres1 m1 t2 ma sz m' b m'' gea)
  then show ?case sorry
next
  case (10 ge vargs m t1 vres1 m1 t2 vres2 m2 ma sz m' b m'' gea mb sza m'a ba m''a geb)
  then show ?case sorry
next
  case (11 ge vargs m t1 vres1 m1 t2 vres2 m2 ma sz m' b m'' gea mb sza m'a ba m''a geb)
  then show ?case sorry
next
  case (12 ge vargs m t1 vres1 m1 t2 vres2 m2 ma sz m' b m'' gea mb sza m'a ba m''a geb)
  then show ?case sorry
qed

subsection \<open>Semantics of dynamic memory deallocation (free)\<close>

inductive extcall_free_sem :: "Senv_t \<Rightarrow> val list \<Rightarrow> mem \<Rightarrow> trace \<Rightarrow> val \<Rightarrow> mem \<Rightarrow> bool" where
    extcall_free_sem_ptr:
      "Mem.load Mptr m b (Int64.unsigned lo - size_chunk Mptr) = Some (Vptrofs sz) \<Longrightarrow>
      Int64.unsigned sz > 0 \<Longrightarrow>
      Mem.free m b (Int64.unsigned lo - size_chunk Mptr) (Int64.unsigned lo + Int64.unsigned sz) = Some m' \<Longrightarrow>
      extcall_free_sem ge (Vptr b lo # []) m E0 Vundef m'"
  | extcall_free_sem_null:
      "extcall_free_sem ge (Vnullptr # []) m E0 Vundef m"

lemma extcall_free_ok:
  "extcall_properties extcall_free_sem
                     (mksignature (Tptr # []) (Tvoid) cc_default)"
  sorry

subsection \<open>Semantics of [memcpy] operations\<close>

inductive extcall_memcpy_sem :: "Z \<Rightarrow> Z \<Rightarrow> Senv_t \<Rightarrow> val list \<Rightarrow> mem \<Rightarrow> trace \<Rightarrow> val \<Rightarrow> mem \<Rightarrow> bool" where
    extcall_memcpy_sem_intro:
      "al = 1 \<or> al = 2 \<or> al = 4 \<or> al = 8 \<Longrightarrow> sz \<ge> 0 \<Longrightarrow> (al dvd sz) \<Longrightarrow>
      (sz > 0 \<Longrightarrow> (al dvd Int64.unsigned osrc)) \<Longrightarrow>
      (sz > 0 \<Longrightarrow> (al dvd Int64.unsigned odst)) \<Longrightarrow>
      bsrc \<noteq> bdst \<or> Int64.unsigned osrc = Int64.unsigned odst
                   \<or> Int64.unsigned osrc + sz <= Int64.unsigned odst
                   \<or> Int64.unsigned odst + sz <= Int64.unsigned osrc \<Longrightarrow>
      Mem.loadbytes m bsrc (Int64.unsigned osrc) sz = Some bytes \<Longrightarrow>
      Mem.storebytes m bdst (Int64.unsigned odst) bytes = Some m' \<Longrightarrow>
      extcall_memcpy_sem sz al ge (Vptr bdst odst # Vptr bsrc osrc # []) m E0 Vundef m'"

lemma extcall_memcpy_ok:
  "extcall_properties (extcall_memcpy_sem sz al)
                     (mksignature (Tptr # Tptr # []) (Tvoid) cc_default)"
  sorry

(** Combining the semantics given above for the various kinds of external calls,
  we define the predicate [external_call] that relates:
- the external function being invoked
- the values of the arguments passed to this function
- the memory state before the call
- the result value of the call
- the memory state after the call
- the trace generated by the call (can be empty).

This predicate is used in the semantics of all CompCert languages. *)

inductive extcall_dummy_sem :: "extcall_sem" where
    extcall_dummy_sem_intro: "extcall_dummy_sem ge args m E0 sp m"

fun external_call :: "external_function \<Rightarrow> extcall_sem" where
(* TODO: not implemented for now
  "external_call (EF_external name sg) = external_functions_sem name sg"
| "external_call (EF_builtin name sg) = builtin_or_external_sem name sg"
| "external_call (EF_runtime name sg) = builtin_or_external_sem name sg"
| "external_call (EF_vload chunk) = volatile_load_sem chunk"
| "external_call (EF_vstore chunk) = volatile_store_sem chunk" *)
  "external_call EF_malloc = extcall_malloc_sem"
| "external_call EF_free = extcall_free_sem"
| "external_call (EF_memcpy sz al) = extcall_memcpy_sem sz al"
(* TODO: not implemented for now
| "external_call (EF_annot kind txt targs) = extcall_annot_sem txt targs"
| "external_call (EF_annot_val kind txt targ) = extcall_annot_val_sem txt targ"
| "external_call (EF_inline_asm txt sg clb) = inline_assembly_sem txt sg"
| "external_call (EF_debug kind txt targs) = extcall_debug_sem" *)

lemmas extcall_simps =
  extcall_malloc_sem.simps extcall_free_sem.simps extcall_memcpy_sem.simps
lemmas extcall_intros =
  extcall_malloc_sem.intros extcall_free_sem.intros extcall_memcpy_sem.intros

lemmas external_call_intros = extcall_intros[folded external_call.simps]

lemma external_call_spec:
  "extcall_properties (external_call ef) (ef_sig ef)"
  apply (cases ef)
  using extcall_malloc_ok extcall_free_ok extcall_memcpy_ok
  by auto

definition "external_call_well_typed_gen ef \<equiv> ec_well_typed (external_call ef) (ef_sig ef)"
definition "external_call_symbols_preserved ef \<equiv> ec_symbols_preserved (external_call ef)"
definition "external_call_valid_block ef \<equiv> ec_valid_block (external_call ef)"
definition "external_call_max_perm ef \<equiv> ec_max_perm (external_call ef)"
definition "external_call_readonly ef \<equiv> ec_readonly (external_call ef)"
definition "external_call_mem_extends ef \<equiv> ec_mem_extends (external_call ef)"
definition "external_call_mem_inject_gen ef \<equiv> ec_mem_inject (external_call ef)"
definition "external_call_trace_length ef \<equiv> ec_trace_length (external_call ef)"
definition "external_call_receptive ef \<equiv> ec_receptive (external_call ef)"
definition "external_call_determ ef \<equiv> ec_determ (external_call ef)"

(** Corollaries of [external_call_determ]. *)

lemma external_call_match_traces:
  assumes "external_call ef ge vargs m t1 vres1 m1"
  assumes "external_call ef ge vargs m t2 vres2 m2"
  shows "match_traces ge t1 t2"
proof -
  have "external_call_determ ef"
    unfolding external_call_determ_def
    using extcall_properties.cases external_call_spec by auto

  then show ?thesis
    unfolding external_call_determ_def ec_determ_def
    using assms by simp
qed

lemma external_call_deterministic:
  assumes "external_call ef ge vargs m t vres1 m1"
  assumes "external_call ef ge vargs m t vres2 m2"
  shows "vres1 = vres2 \<and> m1 = m2"
proof -
  have "external_call_determ ef"
    unfolding external_call_determ_def
    using extcall_properties.cases external_call_spec by auto

  then show ?thesis
    unfolding external_call_determ_def ec_determ_def
    using assms by simp
qed

section \<open>Additions\<close>

(* modeling results of deterministic external_calls *)
definition external_call_result :: "external_function \<Rightarrow> Senv_t \<Rightarrow> val list \<Rightarrow> mem \<Rightarrow> (event list \<times> val \<times> mem) option" where
  "external_call_result ef ge vargs m \<equiv>
    if \<exists>t vres m'. external_call ef ge vargs m t vres m'
    then Some (THE (t, vres, m'). external_call ef ge vargs m t vres m')
    else None"

declare external_call_result_def[code del]

lemma external_call_resultI:
  assumes "\<And>t vres m'. external_call ef ge vargs m t vres m' \<Longrightarrow> res_fun ge vargs m = Some (t, vres, m')"
  assumes "(\<And>t vres m'. \<not>external_call ef ge vargs m t vres m') \<Longrightarrow> res_fun ge vargs m = None"
  shows "external_call_result ef ge vargs m = res_fun ge vargs m"
  unfolding external_call_result_def
  apply (split if_splits)
  by (smt (z3) Collect_cong The_split_eq assms(1) assms(2) case_prodE case_prodI in_rel_Collect_case_prod_eq option.inject)

print_statement extcall_malloc_sem.simps[simplified]

lemma extcall_malloc_result:
  notes align_Mptr = align_dvd_size_mult[of Mptr "-1"]
  notes store_valid = Mem.store_after_alloc[OF _ _ _ align_Mptr]
  shows
    "external_call_result EF_malloc ge [Vptrofs sz] m =
      (case Mem.alloc m (- size_chunk Mptr) (Int64.unsigned sz) of (m', b) \<Rightarrow>
      (case Mem.store Mptr m' b (- size_chunk Mptr) (Vptrofs sz) of Some m'' \<Rightarrow>
      Some (E0, Vptr b 0, m'') | _ \<Rightarrow> None))"
  apply (rule external_call_resultI; split prod.splits; split option.splits)
   apply (simp)
   apply (erule extcall_malloc_sem.cases)
  unfolding Vptrofs_def
   apply force
  using Vptrofs_def extcall_malloc_sem_intro by fastforce

print_statement extcall_free_sem.simps[simplified]

lemma extcall_free_result:
  shows
    "external_call_result EF_free ge vargs m =
      (if vargs = [Vnullptr] then Some (E0, Vundef, m) else
      (case vargs of [Vptr b lo] \<Rightarrow>
      (case Mem.load Mptr m b (Int64.unsigned lo - size_chunk Mptr) of Some (Vlong sz) \<Rightarrow>
      (if Int64.unsigned sz = 0 then None else
      (case Mem.free m b (Int64.unsigned lo - size_chunk Mptr) (Int64.unsigned lo + Int64.unsigned sz) of Some m' \<Rightarrow>
      Some (E0, Vundef, m') | _ \<Rightarrow> None)) | _ \<Rightarrow> None) | _ \<Rightarrow> None))"
  apply (rule external_call_resultI)
   apply (auto elim!: extcall_free_sem.cases split: option.splits val.splits if_splits list.splits simp: Vptrofs_def Vnullptr_def)
   apply (metis Vnullptr_def extcall_free_sem_null)
  apply (simp add: extcall_free_sem.simps)
  unfolding Vptrofs_def Vnullptr_def
  by (metis linorder_neqE_linordered_idom uint_lt_0)

print_statement extcall_memcpy_sem.simps[simplified]

lemma extcall_memcpy_result:
  shows
    "external_call_result (EF_memcpy sz al) ge vargs m =
      (case vargs of [Vptr bdst odst, Vptr bsrc osrc] \<Rightarrow>
      (if a2 = 1 \<or> a2 = 2 \<or> a2 = 4 \<or> a2 = 8 then
      (if 0 \<le> sz \<or> (al dvd sz) then
      (if 0 < a1 \<longrightarrow> a2 dvd Int64.unsigned osrc then
      (if 0 < a1 \<longrightarrow> a2 dvd Int64.unsigned odst then
      (if bsrc = bdst \<longrightarrow>
          Int64.unsigned osrc = Int64.unsigned odst \<or>
          Int64.unsigned osrc + a1 \<le> Int64.unsigned odst \<or>
          Int64.unsigned odst + a1 \<le> Int64.unsigned osrc then
      (case Mem.loadbytes m bsrc (Int64.unsigned osrc) sz of Some bytes \<Rightarrow>
      (case Mem.storebytes m bdst (Int64.unsigned odst) bytes of Some m' \<Rightarrow>
      Some (E0, Vundef, m') | _ \<Rightarrow> None) | _ \<Rightarrow> None) else None) else None) else None) else None) else None) | _ \<Rightarrow> None)"
proof -
  {
    fix osrc odst bsrc bdst bytes m'

    assume [simp]: "vargs = [Vptr bdst odst, Vptr bsrc osrc]"
    assume [iff]: "a2 = 1 \<or> a2 = 2 \<or> a2 = 4 \<or> a2 = 8"
    assume sz[iff]: "0 \<le> sz \<or> (al dvd sz)"
    assume [iff]: "0 < a1 \<longrightarrow> a2 dvd Int64.unsigned osrc"
    assume [iff]: "0 < a1 \<longrightarrow> a2 dvd Int64.unsigned odst"
    assume [iff]: "bsrc = bdst \<longrightarrow>
          Int64.unsigned osrc = Int64.unsigned odst \<or>
          Int64.unsigned osrc + a1 \<le> Int64.unsigned odst \<or>
          Int64.unsigned odst + a1 \<le> Int64.unsigned osrc"

    assume bytes[simp]: "Mem.loadbytes m bsrc (Int64.unsigned osrc) sz = Some bytes"
    assume m'[simp]: "Mem.storebytes m bdst (Int64.unsigned odst) bytes = Some m'"

    have bytes_len[simp]: "length bytes = nat sz"
      using Mem.loadbytes_len[OF bytes]
      by simp

    have sz_0[iff]: "sz = 0 \<Longrightarrow> m' = m"
      using Mem.storebytes_0 Mem.loadbytes_0 bytes m' by auto

    then have ?thesis
      apply (simp)
      sorry
  }

  then show ?thesis
    sorry

qed

subsection \<open>Determinism\<close>

(*
  all external calls are guaranteed to be deterministic modulo their trace;
  so extcalls not generating a trace are fully deterministic
*)

definition "determ_extfun ef \<equiv>
  \<forall>ge vargs m t vres m'. (external_call ef ge vargs m t vres m' \<longrightarrow> t = E0)"

(* for now, all the external functions we implement are deterministic *)
lemma determ_extfun[iff]: "determ_extfun ef"
  unfolding determ_extfun_def
  apply (cases ef)
  by (auto elim: extcall_malloc_sem.cases extcall_free_sem.cases extcall_memcpy_sem.cases)

lemma determ_extfun_notrace:
  "determ_extfun ef \<Longrightarrow> external_call ef ge vargs m t vres m' \<Longrightarrow> t = E0"
  unfolding determ_extfun_def
  by blast

lemma extcall_determ:
  assumes "determ_extfun ef"
  assumes "external_call ef ge vargs m t vres m'"
  shows "external_call ef ge vargs m t' vres' m'' \<Longrightarrow> t' = t \<and> vres' = vres \<and> m'' = m'"
  using determ_extfun_notrace[OF assms]
  using assms(1) assms(2) determ_extfun_notrace external_call_deterministic by blast

subsection \<open>Equivalance\<close>

lemma extcall_result_equiv:
  assumes "determ_extfun ef"
  shows
    "external_call ef ge vargs m t vres m' \<longleftrightarrow> external_call_result ef ge vargs m = Some (t, vres, m')"
  unfolding external_call_result_def
  apply standard
  using extcall_determ apply auto[1]
  apply (auto split: if_splits)
  by (smt (verit, ccfv_threshold) assms case_prodD case_prodE case_prodI extcall_determ theI')

subsection \<open>Deterministic world\<close>

locale deterministic_world
begin
lemmas extcall_determ = extcall_determ[OF determ_extfun]
lemmas extcall_result_equiv = extcall_result_equiv[OF determ_extfun]
end

end