Theory AutoCorres2.Padding_Equivalence
theory Padding_Equivalence
imports
TypHeap
SepCode
CProof
More_Lib
begin
lemma field_lookup_padding_field_name:
fixes
t:: "('a, 'b) typ_info " and
st :: "('a, 'b) typ_info_struct" and
ts :: "('a, 'b) typ_info_tuple list" and
x :: "('a, 'b) typ_info_tuple"
shows
"field_lookup t [f] n = Some (s, m) ⟹ padding_field_name f ⟹ wf_padding t ⟹
is_padding_tag s"
"field_lookup_struct st [f] n = Some (s, m) ⟹ padding_field_name f ⟹ wf_padding_struct st ⟹
is_padding_tag s"
"field_lookup_list ts [f] n = Some (s, m) ⟹ padding_field_name f ⟹ wf_padding_list ts ⟹
is_padding_tag s"
"field_lookup_tuple x [f] n = Some (s, m) ⟹ padding_field_name f ⟹ wf_padding_tuple x ⟹
is_padding_tag s"
by (induct t and st and ts and x arbitrary: n m and n m and n m and n m)
(auto split: if_split_asm option.splits)
lemma field_lookup_access_ti_take_drop':
fixes t::"('a, 'b) typ_info"
and st::"('a, 'b) typ_info_struct"
and ts::"('a, 'b) typ_info_tuple list"
and x::"('a, 'b) typ_info_tuple"
shows
"field_lookup t f m = Some (s, m + n) ⟹ wf_fd t ⟹ wf_desc t ⟹ wf_size_desc t ⟹ length bs = size_td t ⟹
access_ti s v (take (size_td s) (drop n bs)) =
(take (size_td s) (drop n (access_ti t v bs)))"
"field_lookup_struct st f m = Some (s, m + n) ⟹ wf_fd_struct st ⟹ wf_desc_struct st ⟹ wf_size_desc_struct st ⟹ length bs = size_td_struct st ⟹
access_ti s v (take (size_td s) (drop n bs)) =
(take (size_td s) (drop n (access_ti_struct st v bs)))"
"field_lookup_list ts f m = Some (s, m + n) ⟹ wf_fd_list ts ⟹ wf_desc_list ts ⟹ wf_size_desc_list ts ⟹ length bs = size_td_list ts ⟹
access_ti s v (take (size_td s) (drop n bs)) =
(take (size_td s) (drop n (access_ti_list ts v bs)))"
"field_lookup_tuple x f m = Some (s, m + n) ⟹ wf_fd_tuple x ⟹ wf_desc_tuple x ⟹ wf_size_desc_tuple x ⟹ length bs = size_td_tuple x ⟹
access_ti s v (take (size_td s) (drop n bs)) =
(take (size_td s) (drop n (access_ti_tuple x v bs)))"
proof (induct t and st and ts and x arbitrary: f m n s bs v and f m n s bs v and f m n s bs v and f m n s bs v)
case (TypDesc algn st nm)
then show ?case
by (auto split: if_split_asm)
(metis TypDesc.prems(2) TypDesc.prems(5) access_ti.simps le_refl length_fa_ti take_all)
next
term TypDesc
case (TypScalar algn st d)
then show ?case by auto
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
obtain d nm y where x: "x = DTuple d nm y" by (cases x) auto
from Cons_typ_desc.prems obtain
lbs: "length bs = size_td_tuple x + size_td_list fs" and
wf_fd_x: "wf_fd_tuple (DTuple d nm y)" and
wf_desc_x: "wf_desc_tuple (DTuple d nm y)" and
wf_fd_fs: "wf_fd_list fs" and
wf_size_desc_x: "wf_size_desc_tuple (DTuple d nm y)" and
wf_size_desc_fs: "wf_size_desc_list fs" and
nm_notin: "nm ∉ dt_snd ` set fs" and
wf_desc_fs: "wf_desc_list fs" and
commutes: "fu_commutes (update_ti_t d) (update_ti_list_t fs)"
by (auto simp add: x)
from lbs
have lbs_drop: "length (drop (size_td_tuple x) bs) = size_td_list fs"
by simp
from lbs
have lbs_take: "length (take (size_td_tuple x) bs) = size_td_tuple (DTuple d nm y)"
by (simp add: x)
from lbs wf_fd_x
have eq1: "length (access_ti d v (take (size_td d) bs)) = size_td d"
by (metis lbs_take length_fa_ti size_td_tuple.simps wf_fd_tuple.simps x)
from Cons_typ_desc.prems obtain f1 fxs
where f: "f = f1#fxs"
by (cases f) auto
show ?case
proof (cases "f1 = nm")
case True
show ?thesis
proof (cases "field_lookup d fxs m")
case None
from Cons_typ_desc.prems field_lookup_list_None [OF nm_notin]
have False
by (simp add: True None f x)
thus ?thesis by simp
next
case (Some r)
from Cons_typ_desc.prems have r: "r = (s, m + n)"
by (simp add: x True Some f)
hence fl: "field_lookup_tuple (DTuple d nm y) f m = Some (s, m + n)"
by (simp add: f True Some r)
from td_set_wf_size_desc(4)[OF wf_size_desc_x td_set_tuple_field_lookup_tupleD, OF fl]
have "wf_size_desc s" .
from wf_size_desc_gt(1)[OF this]
have "0 < size_td s" .
with td_set_tuple_offset_size_m [OF td_set_tuple_field_lookup_tupleD, OF fl]
have n_le: "n < size_td d"
by auto
have bound: "size_td s + (m + n - m) ≤ size_td_tuple (DTuple d nm y)" by fact
from bound
have take_eq: "(take (size_td s) (drop n (take (size_td d) bs))) =
(take (size_td s) (drop n bs))"
by (simp add: take_drop)
from Cons_typ_desc.hyps(1)[simplified x, OF fl wf_fd_x wf_desc_x wf_size_desc_x lbs_take, of v] lbs bound
show ?thesis by (simp add: x True Some r take_eq eq1)
qed
next
case False
with Cons_typ_desc.prems
have fl: "field_lookup_list fs (f1 # fxs) (m + size_td d) = Some (s, m + n)"
by (clarsimp simp add: x f False)
hence n_bound: "size_td d ≤ n"
by (meson field_lookup_offset_le(3) nat_add_left_cancel_le)
from fl
have fl: "field_lookup_list fs (f1 # fxs) (m + size_td d) = Some (s, (m + size_td d) + (n - size_td d))"
by (metis Nat.diff_cancel field_lookup_list_offset2 field_lookup_list_offsetD)
from n_bound
have take_eq: "(take (size_td s) (drop (n - size_td d + size_td d) bs)) =
(take (size_td s) (drop n bs))"
by simp
from Cons_typ_desc.hyps(2) [OF fl wf_fd_fs wf_desc_fs wf_size_desc_fs lbs_drop, of v]
False n_bound
show ?thesis
by (simp add: x f eq1)
qed
next
case (DTuple_typ_desc d nm y)
then show ?case apply (cases f) by (auto split: if_split_asm)
qed
lemma field_lookup_access_ti_take_drop:
"field_lookup t f 0 = Some (s, n) ⟹ wf_fd t ⟹ wf_desc t ⟹ wf_size_desc t ⟹ length bs = size_td t ⟹
access_ti s v (take (size_td s) (drop n bs)) =
(take (size_td s) (drop n (access_ti t v bs)))"
using field_lookup_access_ti_take_drop' [where m=0] by auto
lemma field_lookup_nth_focus':
fixes t::"('a, 'b) typ_info"
and st::"('a, 'b) typ_info_struct"
and ts::"('a, 'b) typ_info_tuple list"
and x::"('a, 'b) typ_info_tuple"
shows
"⟦field_lookup t f m = Some (s, m + n); n ≤ i; i < n + size_td s; length bs = size_td t;
wf_fd t; wf_desc t; wf_size_desc t⟧ ⟹
access_ti t v bs ! i = access_ti s v (take (size_td s) (drop n bs)) ! (i - n)"
"⟦field_lookup_struct st f m = Some (s, m + n); n ≤ i; i < n + size_td s; length bs = size_td_struct st;
wf_fd_struct st; wf_desc_struct st; wf_size_desc_struct st⟧ ⟹
access_ti_struct st v bs ! i = access_ti s v (take (size_td s) (drop n bs)) ! (i - n)"
"⟦field_lookup_list ts f m = Some (s, m + n); n ≤ i; i < n + size_td s; length bs = size_td_list ts;
wf_fd_list ts; wf_desc_list ts; wf_size_desc_list ts⟧ ⟹
access_ti_list ts v bs ! i = access_ti s v (take (size_td s) (drop n bs)) ! (i - n)"
"⟦field_lookup_tuple x f m = Some (s, m + n); n ≤ i; i < n + size_td s; length bs = size_td_tuple x;
wf_fd_tuple x; wf_desc_tuple x; wf_size_desc_tuple x⟧ ⟹
access_ti_tuple x v bs ! i = access_ti s v (take (size_td s) (drop n bs)) ! (i - n)"
proof (induct t and st and ts and x arbitrary: f m n i s bs v and f m n i s bs v and f m n i s bs v and f m n i s bs v)
case (TypDesc algn st nm)
then show ?case by (auto split: if_split_asm)
next
case (TypScalar sz algn d)
then show ?case by auto
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
obtain d nm y where x: "x = DTuple d nm y" by (cases x) auto
from Cons_typ_desc.prems obtain
lbs: "length bs = size_td_tuple x + size_td_list fs" and
wf_fd_x: "wf_fd_tuple (DTuple d nm y)" and
wf_desc_x: "wf_desc_tuple (DTuple d nm y)" and
wf_fd_fs: "wf_fd_list fs" and
wf_size_desc_x: "wf_size_desc_tuple (DTuple d nm y)" and
wf_size_desc_fs: "wf_size_desc_list fs" and
nm_notin: "nm ∉ dt_snd ` set fs" and
wf_desc_fs: "wf_desc_list fs" and
i_lower: "n ≤ i" and
i_upper: "i < n + size_td s"
by (auto simp add: x)
from lbs
have lbs_drop: "length (drop (size_td_tuple x) bs) = size_td_list fs"
by simp
from lbs
have lbs_take: "length (take (size_td_tuple x) bs) = size_td_tuple (DTuple d nm y)"
by (simp add: x)
from lbs wf_fd_x
have eq1: "length (access_ti d v (take (size_td d) bs)) = size_td d"
by (metis lbs_take length_fa_ti size_td_tuple.simps wf_fd_tuple.simps x)
from Cons_typ_desc.prems obtain f1 fxs
where f: "f = f1#fxs"
by (cases f) auto
thm Cons_typ_desc.hyps [simplified x]
show ?case
proof (cases "f1 = nm")
case True
show ?thesis
proof (cases "field_lookup d fxs m")
case None
from Cons_typ_desc.prems field_lookup_list_None [OF nm_notin]
have False
by (simp add: True None f x)
thus ?thesis by simp
next
case (Some r)
from Cons_typ_desc.prems have r: "r = (s, m + n)"
by (simp add: x True Some f)
hence fl: "field_lookup_tuple (DTuple d nm y) f m = Some (s, m + n)"
by (simp add: f True Some r)
from td_set_wf_size_desc(4)[OF wf_size_desc_x td_set_tuple_field_lookup_tupleD, OF fl]
have "wf_size_desc s" .
from wf_size_desc_gt(1)[OF this]
have "0 < size_td s" .
with td_set_tuple_offset_size_m [OF td_set_tuple_field_lookup_tupleD, OF fl]
have n_le: "n < size_td d"
by auto
have i_in_d: "i < size_td d"
using ‹size_td s + (m + n - m) ≤ size_td_tuple (DTuple d nm y)› i_upper by auto
have bound: "size_td s + (m + n - m) ≤ size_td_tuple (DTuple d nm y)" by fact
from bound
have take_eq: "(take (size_td s) (drop n (take (size_td d) bs))) =
(take (size_td s) (drop n bs))"
by (simp add: take_drop)
from Cons_typ_desc.hyps(1)[simplified x, OF fl i_lower i_upper lbs_take wf_fd_x wf_desc_x wf_size_desc_x, of v] lbs bound
show ?thesis
by (simp add: x True Some r take_eq eq1 nth_append i_in_d)
qed
next
case False
with Cons_typ_desc.prems
have fl: "field_lookup_list fs (f1 # fxs) (m + size_td d) = Some (s, m + n)"
by (clarsimp simp add: x f False)
hence n_bound: "size_td d ≤ n"
by (meson field_lookup_offset_le(3) nat_add_left_cancel_le)
from fl
have fl: "field_lookup_list fs (f1 # fxs) (m + size_td d) = Some (s, (m + size_td d) + (n - size_td d))"
by (metis Nat.diff_cancel field_lookup_list_offset2 field_lookup_list_offsetD)
from n_bound
have take_eq: "(take (size_td s) (drop (n - size_td d + size_td d) bs)) =
(take (size_td s) (drop n bs))"
by simp
have i_lower': "n - size_td d ≤ i - size_td d"
using diff_le_mono i_lower by blast
have i_upper': "i - size_td d < n - size_td d + size_td s"
using i_lower i_upper by linarith
have i_notin_d: "¬ i < size_td d"
by (meson i_lower leD less_le_trans n_bound)
from Cons_typ_desc.hyps(2) [OF fl i_lower' i_upper' lbs_drop wf_fd_fs wf_desc_fs wf_size_desc_fs, where v=v]
False n_bound
show ?thesis
by (simp add: x f eq1 nth_append i_notin_d)
qed
next
case (DTuple_typ_desc d nm y)
then show ?case apply (cases f) by (auto split: if_split_asm)
qed
lemma field_lookup_nth_focus:
"⟦field_lookup t f 0 = Some (s, n); n ≤ i; i < n + size_td s; length bs = size_td t;
wf_fd t; wf_desc t; wf_size_desc t⟧ ⟹
access_ti t v bs ! i = access_ti s v (take (size_td s) (drop n bs)) ! (i - n)"
using field_lookup_nth_focus' [where m=0] by auto
lemma field_lookup_nth_update_focus':
fixes t::"('a, 'b) typ_info"
and st::"('a, 'b) typ_info_struct"
and ts::"('a, 'b) typ_info_tuple list"
and x::"('a, 'b) typ_info_tuple"
shows
"⟦field_lookup t f m = Some (s, m + n); n ≤ i; i < n + size_td s; length bs = size_td t;
wf_fd t; wf_desc t; wf_size_desc t⟧ ⟹
access_ti t v (bs[i := b]) =
super_update_bs (access_ti s v ((take (size_td s) (drop n bs))[i - n := b]))
(access_ti t v bs) n"
"⟦field_lookup_struct st f m = Some (s, m + n); n ≤ i; i < n + size_td s; length bs = size_td_struct st;
wf_fd_struct st; wf_desc_struct st; wf_size_desc_struct st⟧ ⟹
access_ti_struct st v (bs[i := b]) =
super_update_bs (access_ti s v ((take (size_td s) (drop n bs))[i - n := b]))
(access_ti_struct st v bs) n"
"⟦field_lookup_list ts f m = Some (s, m + n); n ≤ i; i < n + size_td s; length bs = size_td_list ts;
wf_fd_list ts; wf_desc_list ts; wf_size_desc_list ts⟧ ⟹
access_ti_list ts v (bs[i := b]) =
super_update_bs (access_ti s v ((take (size_td s) (drop n bs))[i - n := b]))
(access_ti_list ts v bs) n"
"⟦field_lookup_tuple x f m = Some (s, m + n); n ≤ i; i < n + size_td s; length bs = size_td_tuple x;
wf_fd_tuple x; wf_desc_tuple x; wf_size_desc_tuple x⟧ ⟹
access_ti_tuple x v (bs[i := b]) =
super_update_bs (access_ti s v ((take (size_td s) (drop n bs))[i - n := b]))
(access_ti_tuple x v bs) n"
proof (induct t and st and ts and x arbitrary: f m n i s bs v and f m n i s bs v and f m n i s bs v and f m n i s bs v)
case (TypDesc algn st nm)
then show ?case
by (auto split: if_split_asm simp add: super_update_bs_def)
(metis TypDesc.prems(4) TypDesc.prems(5) access_ti.simps le_refl length_fa_ti length_list_update)
next
case (TypScalar sz algn d)
then show ?case by auto
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
obtain d nm y where x: "x = DTuple d nm y" by (cases x) auto
from Cons_typ_desc.prems obtain
lbs: "length bs = size_td_tuple x + size_td_list fs" and
wf_fd_x: "wf_fd_tuple (DTuple d nm y)" and
wf_desc_x: "wf_desc_tuple (DTuple d nm y)" and
wf_fd_fs: "wf_fd_list fs" and
wf_size_desc_x: "wf_size_desc_tuple (DTuple d nm y)" and
wf_size_desc_fs: "wf_size_desc_list fs" and
nm_notin: "nm ∉ dt_snd ` set fs" and
wf_desc_fs: "wf_desc_list fs" and
i_lower: "n ≤ i" and
i_upper: "i < n + size_td s"
by (auto simp add: x)
from lbs
have lbs_drop: "length (drop (size_td_tuple x) bs) = size_td_list fs"
by simp
from lbs
have lbs_take: "length (take (size_td_tuple x) bs) = size_td_tuple (DTuple d nm y)"
by (simp add: x)
from lbs wf_fd_x
have eq1: "length (access_ti d v (take (size_td d) bs)) = size_td d"
by (metis lbs_take length_fa_ti size_td_tuple.simps wf_fd_tuple.simps x)
from Cons_typ_desc.prems obtain f1 fxs
where f: "f = f1#fxs"
by (cases f) auto
thm Cons_typ_desc.hyps [simplified x]
show ?case
proof (cases "f1 = nm")
case True
show ?thesis
proof (cases "field_lookup d fxs m")
case None
from Cons_typ_desc.prems field_lookup_list_None [OF nm_notin]
have False
by (simp add: True None f x)
thus ?thesis by simp
next
case (Some r)
from Cons_typ_desc.prems have r: "r = (s, m + n)"
by (simp add: x True Some f)
hence fl: "field_lookup_tuple (DTuple d nm y) f m = Some (s, m + n)"
by (simp add: f True Some r)
from td_set_wf_size_desc(4)[OF wf_size_desc_x td_set_tuple_field_lookup_tupleD, OF fl]
have "wf_size_desc s" .
from wf_size_desc_gt(1)[OF this]
have "0 < size_td s" .
with td_set_tuple_offset_size_m [OF td_set_tuple_field_lookup_tupleD, OF fl]
have n_le: "n < size_td d"
by auto
have i_in_d: "i < size_td d"
using ‹size_td s + (m + n - m) ≤ size_td_tuple (DTuple d nm y)› i_upper by auto
have bound: "size_td s + (m + n - m) ≤ size_td_tuple (DTuple d nm y)" by fact
from bound
have take_eq: "(take (size_td s) (drop n (take (size_td d) bs))) =
(take (size_td s) (drop n bs))"
by (simp add: take_drop)
from bound
have take_upd_eq: " ((take (size_td d) bs)[i := b]) = (take (size_td d) (bs[i := b]))"
by (simp add: take_update_swap)
have take_eq1: "take (size_td s) (drop n (take (size_td d) bs)) = take (size_td s) (drop n bs)"
using take_eq by blast
have l_take_s: "length (take (size_td s) (drop n bs)) = size_td s"
using bound lbs_take by auto
have sz_s: "size_td s ≤ length bs - n"
using l_take_s by auto
from fl
have fd_cons_s: "fd_cons s"
using wf_fd_consD wf_fd_field_lookup(4) wf_fd_x by blast
have l_acc_s: "length (access_ti s v ((take (size_td s) (drop n bs))[i - n := b])) = size_td s"
by (simp add: fd_cons_length [OF fd_cons_s] sz_s eq1)
have take_eq2: "(take (size_td s) (drop n (take (size_td d) bs)))[i - n := b] = (take (size_td s) (drop n bs))[i - n := b]"
using take_eq1 by presburger
note hyp = Cons_typ_desc.hyps(1)[simplified x, OF fl i_lower i_upper lbs_take wf_fd_x wf_desc_x wf_size_desc_x, of v,
simplified, simplified x, simplified, simplified take_upd_eq]
from lbs bound
show ?thesis
apply (simp add: x True Some r take_eq take_upd_eq eq1 list_update_append i_in_d)
apply (simp add: hyp)
apply (subst super_update_bs_append1)
apply (simp add: l_acc_s eq1)
apply (simp add: take_eq2)
done
qed
next
case False
with Cons_typ_desc.prems
have fl: "field_lookup_list fs (f1 # fxs) (m + size_td d) = Some (s, m + n)"
by (clarsimp simp add: x f False)
hence n_bound: "size_td d ≤ n"
by (meson field_lookup_offset_le(3) nat_add_left_cancel_le)
from fl
have fl: "field_lookup_list fs (f1 # fxs) (m + size_td d) = Some (s, (m + size_td d) + (n - size_td d))"
by (metis Nat.diff_cancel field_lookup_list_offset2 field_lookup_list_offsetD)
from n_bound
have take_eq: "(take (size_td s) (drop (n - size_td d + size_td d) bs)) =
(take (size_td s) (drop n bs))"
by simp
have i_lower': "n - size_td d ≤ i - size_td d"
using diff_le_mono i_lower by blast
have i_upper': "i - size_td d < n - size_td d + size_td s"
using i_lower i_upper by linarith
have i_notin_d: "¬ i < size_td d"
by (meson i_lower leD less_le_trans n_bound)
from i_notin_d have take_d_eq: "take (size_td d) (bs[i := b]) = take (size_td d) bs"
by simp
have drop_shift: "(drop (size_td d) bs)[i - size_td d := b] = drop (size_td d) (bs[i := b])"
by (metis drop_update_swap i_notin_d le_def)
note hyp = Cons_typ_desc.hyps(2) [OF fl i_lower' i_upper' lbs_drop wf_fd_fs wf_desc_fs wf_size_desc_fs, where v=v,
simplified x, simplified, simplified drop_shift]
from False n_bound
show ?thesis
apply (simp add: x f eq1 nth_append i_notin_d)
apply (subst super_update_bs_append2)
apply (simp add: eq1)
apply (simp add: take_d_eq add: eq1)
apply (simp add: hyp)
done
qed
next
case (DTuple_typ_desc d nm y)
then show ?case apply (cases f) by (auto split: if_split_asm)
qed
lemma field_lookup_nth_update_focus:
shows
"⟦field_lookup t f 0 = Some (s, n); n ≤ i; i < n + size_td s; length bs = size_td t;
wf_fd t; wf_desc t; wf_size_desc t⟧ ⟹
access_ti t v (bs[i := b]) =
super_update_bs (access_ti s v ((take (size_td s) (drop n bs))[i - n := b]))
(access_ti t v bs) n"
using field_lookup_nth_update_focus' [where m=0] by auto
context mem_type
begin
lemma mem_type_field_lookup_access_ti_take_drop:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n)"
assumes lbs : "length bs = size_of TYPE('a)"
shows "access_ti s v (take (size_td s) (drop n bs)) =
take (size_td s) (drop n (access_ti (typ_info_t TYPE('a)) v bs))"
proof -
have wf_fd: "wf_fd (typ_info_t TYPE('a))"
by (simp add: wf_fdp_fdD wf_lf_fdp)
have wf_desc: "wf_desc (typ_info_t TYPE('a))" by simp
have wf_size: "wf_size_desc (typ_info_t TYPE('a))" by simp
from field_lookup_access_ti_take_drop [OF fl wf_fd wf_desc wf_size lbs [simplified size_of_def]]
show ?thesis .
qed
lemma mem_type_update_ti_super_update_bs:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n)"
assumes lbs: "length bs = size_of TYPE('a)"
assumes lv: "length v = size_td s"
shows "update_ti s v (update_ti (typ_info_t TYPE('a)) bs w) =
update_ti (typ_info_t TYPE('a)) (super_update_bs v bs n) w"
proof -
have wf_fd: "wf_fd (typ_info_t TYPE('a))"
by (simp add: wf_fdp_fdD wf_lf_fdp)
have lsuper: "length (super_update_bs v bs n) = size_td (typ_info_t TYPE('a))"
by (metis add.commute field_lookup_offset_size' fl lbs length_super_update_bs local.size_of_def lv)
from fi_fu_consistentD [OF fl wf_fd lbs [simplified size_of_def] lv, of w] lbs
show ?thesis
by (simp add: update_ti_t_def lsuper lv size_of_def)
qed
lemma mem_type_update_ti_from_bytes_super_update_bs:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n)"
assumes lbs: "length bs = size_of TYPE('a)"
assumes lv: "length v = size_td s"
shows "update_ti s v (from_bytes bs) = update_ti (typ_info_t TYPE('a)) (super_update_bs v bs n) undefined"
proof -
from mem_type_update_ti_super_update_bs [OF fl lbs lv, of undefined]
show ?thesis
by (simp add: from_bytes_def update_ti_t_def lbs size_of_def)
qed
lemma mem_type_field_lookup_nth_focus:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n)"
assumes i_lower: "n ≤ i"
assumes i_upper: "i < n + size_td s"
assumes lbs : "length bs = size_of TYPE('a)"
shows "access_ti (typ_info_t TYPE('a)) v bs ! i =
access_ti s v (take (size_td s) (drop n bs)) ! (i - n)"
proof -
have wf_fd: "wf_fd (typ_info_t TYPE('a))"
by (simp add: wf_fdp_fdD wf_lf_fdp)
have wf_desc: "wf_desc (typ_info_t TYPE('a))" by simp
have wf_size: "wf_size_desc (typ_info_t TYPE('a))" by simp
from field_lookup_nth_focus [OF fl i_lower i_upper lbs [simplified size_of_def] wf_fd wf_desc wf_size]
show ?thesis .
qed
lemma mem_type_field_lookup_nth_update_focus:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n)"
assumes i_lower: "n ≤ i"
assumes i_upper: "i < n + size_td s"
assumes lbs : "length bs = size_of TYPE('a)"
shows
"access_ti (typ_info_t TYPE('a)) v (bs[i := b]) =
super_update_bs (access_ti s v ((take (size_td s) (drop n bs))[i - n := b]))
(access_ti (typ_info_t TYPE('a)) v bs) n"
proof -
have wf_fd: "wf_fd (typ_info_t TYPE('a))"
by (simp add: wf_fdp_fdD wf_lf_fdp)
have wf_desc: "wf_desc (typ_info_t TYPE('a))" by simp
have wf_size: "wf_size_desc (typ_info_t TYPE('a))" by simp
from field_lookup_nth_update_focus [OF fl i_lower i_upper lbs [simplified size_of_def] wf_fd wf_desc wf_size]
show ?thesis .
qed
end
ML ‹@{term "xs[i := v]"}›
lemma nth_take_drop_index_shift:
"n ≤ i ⟹ i < m + n ⟹ m + n ≤ length xs ⟹ take m (drop n xs) ! (i - n) = xs ! i"
proof (induct xs arbitrary: n i m)
case Nil
then show ?case by simp
next
case (Cons x1 xs)
then show ?case by auto
qed
lemma super_update_bs_update_index_shift: "n ≤ i ⟹ i - n < length bs ⟹ n + length bs ≤ length xbs ⟹
(super_update_bs bs xbs n)[i := b] = super_update_bs (bs[i - n := b]) xbs n"
apply (simp add: super_update_bs_def)
apply (simp add: list_update_append)
done
lemma super_update_bs_nth_shift:
"n ≤ i ⟹ i - n < length bs ⟹ n + length bs ≤ length xbs ⟹ super_update_bs bs xbs n ! i = bs ! (i - n)"
apply (simp add: super_update_bs_def)
apply (simp add: nth_append)
done
lemma (in mem_type) field_lookup_is_padding_byte_outer_to_inner:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n)"
assumes lower_bound_x: "n ≤ x"
assumes upper_bound_x: "x < n + size_td s"
assumes is_padding: "padding_base.is_padding_byte (access_ti (typ_info_t (TYPE('a)))) (update_ti (typ_info_t (TYPE('a)))) (size_td (typ_info_t (TYPE('a)))) x"
shows "padding_base.is_padding_byte (access_ti s) (update_ti s) (size_td s) (x - n)"
proof (rule padding_base.is_padding_byteI)
from lower_bound_x upper_bound_x show "x - n < size_td s" by simp
next
fix v::'a and bs::"byte list"
assume "x - n < size_td s"
assume lbs: "length bs = size_td s"
from fl have sz: "size_td s + n ≤ size_of TYPE('a)"
by (simp add: field_lookup_offset_size' size_of_def)
obtain pfx sfx xbs where
xbs: "xbs = pfx @ bs @ sfx" and
lpfx: "length pfx = n" and
lsfx: "length sfx = size_of TYPE('a) - n - size_td s"
by (metis Ex_list_of_length)
with sz have lxbs: "length xbs = size_of TYPE('a)"
by (metis add_leD2 add_le_imp_le_diff lbs le_add_diff_inverse length_append)
from xbs lpfx lsfx xbs lbs have bs: "(take (size_td s) (drop n xbs)) = bs"
by simp
have bound: "x - n < size_td s" by fact
have lacc: "length (access_ti (typ_info_t TYPE('a)) v xbs) = size_of TYPE('a)"
by (simp add: length_fa_ti lxbs size_of_def)
from mem_type_field_lookup_access_ti_take_drop [OF fl lxbs, simplified bs, of v]
have acc_conv: "access_ti s v bs =
take (size_td s) (drop n (access_ti (typ_info_t TYPE('a)) v xbs))" .
from padding_base.is_padding_byte_acc_eq [OF is_padding, of xbs v] lxbs
have "access_ti (typ_info_t TYPE('a)) v xbs ! x = xbs ! x"
by (simp add: size_of_def)
moreover have "xbs ! x = bs ! (x - n)"
using xbs lpfx lsfx lxbs bound
apply (simp add: xbs)
by (metis bs drop_append_miracle le_def lower_bound_x nth_append nth_take xbs)
moreover have "take (size_td s) (drop n (access_ti (typ_info_t TYPE('a)) v xbs)) ! (x - n) =
access_ti (typ_info_t TYPE('a)) v xbs ! x"
using lacc lxbs bound lower_bound_x upper_bound_x
by (metis less_diff_conv2 nth_take_drop_index_shift sz)
ultimately show "access_ti s v bs ! (x - n) = bs ! (x - n)"
by (simp add: acc_conv)
next
fix v::'a and bs::"byte list" and b::byte
assume "x - n < size_td s"
assume lbs: "length bs = size_td s"
from fl have sz: "size_td s + n ≤ size_of TYPE('a)"
by (simp add: local.field_lookup_offset_size local.size_of_def)
obtain pfx sfx xbs where
xbs: "xbs = pfx @ bs @ sfx" and
lpfx: "length pfx = n" and
lsfx: "length sfx = size_of TYPE('a) - n - size_td s"
by (metis Ex_list_of_length)
with sz have lxbs: "length xbs = size_of TYPE('a)"
by (metis add_leD2 add_le_imp_le_diff lbs le_add_diff_inverse length_append)
from xbs lpfx lsfx xbs lbs have bs: "(take (size_td s) (drop n xbs)) = bs"
by simp
have v_upd_conv: "(update_ti (typ_info_t TYPE('a)) (to_bytes v xbs) v) = v"
by (simp add: fu_fa length_fa_ti local.size_of_def local.to_bytes_def lxbs update_ti_update_ti_t)
have lxto: "length (to_bytes v xbs) = size_of TYPE('a)"
by (simp add: length_fa_ti lxbs size_of_def to_bytes_def)
from lxto lbs
have lsuper: "length (super_update_bs bs (to_bytes v xbs) n) = size_of TYPE('a)"
using sz by auto
have bound: "x - n < size_td s" by fact
have xbs_super: "xbs = super_update_bs bs xbs n"
by (simp add: lpfx super_update_bs_def xbs)
from mem_type_update_ti_super_update_bs [OF fl lxto lbs, of v, simplified v_upd_conv]
have upd_eq1:
"update_ti s bs v =
update_ti (typ_info_t TYPE('a)) (super_update_bs bs (to_bytes v xbs) n) v" .
have lbs': "length (bs[x - n := b]) = size_td s"
using lbs by auto
from mem_type_update_ti_super_update_bs [OF fl lxto lbs', of v, simplified v_upd_conv]
have upd_eq2:
"update_ti s (bs[x - n := b]) v =
update_ti (typ_info_t TYPE('a)) (super_update_bs (bs[x - n := b]) (to_bytes v xbs) n) v" .
from lxto lxbs lbs lower_bound_x upper_bound_x bound sz
have super_eq: "(super_update_bs bs (to_bytes v xbs) n)[x := b] = super_update_bs (bs[x - n := b]) (to_bytes v xbs) n"
by (simp add: super_update_bs_update_index_shift)
from padding_base.is_padding_byte_upd_eq [OF is_padding, of "(super_update_bs bs (to_bytes v xbs) n)" v b] lsuper
have upd_pad: "update_ti (typ_info_t TYPE('a)) (super_update_bs bs (to_bytes v xbs) n) v =
update_ti (typ_info_t TYPE('a)) ((super_update_bs bs (to_bytes v xbs) n)[x := b]) v"
by (simp add: size_of_def)
show "update_ti s bs v = update_ti s (bs[x - n := b]) v"
apply (simp add: upd_eq1)
apply (simp add: upd_pad)
apply (simp add: upd_eq2)
apply (simp add: super_eq)
done
qed
lemma (in mem_type) field_lookup_is_padding_byte_inner_to_outer:
assumes fl: "field_lookup (typ_info_t (TYPE('a))) f 0 = Some (s, n)"
assumes lower_bound_x: "n ≤ x"
assumes upper_bound_x: "x < n + size_td s"
assumes is_padding: "padding_base.is_padding_byte (access_ti s) (update_ti s) (size_td s) (x - n)"
shows "padding_base.is_padding_byte (access_ti (typ_info_t (TYPE('a)))) (update_ti (typ_info_t (TYPE('a)))) (size_td (typ_info_t (TYPE('a)))) x"
proof (rule padding_base.is_padding_byteI)
from lower_bound_x upper_bound_x fl
show "x < size_td (typ_info_t TYPE('a))"
using field_lookup_offset_size' by fastforce
next
fix v::'a and bs::"byte list"
assume sz: "x < size_td (typ_info_t TYPE('a))"
assume lbs: "length bs = size_td (typ_info_t TYPE('a))"
from mem_type_field_lookup_nth_focus [OF fl lower_bound_x upper_bound_x, simplified size_of_def, OF lbs]
have eq1:
"access_ti (typ_info_t TYPE('a)) v bs ! x =
access_ti s v (take (size_td s) (drop n bs)) ! (x - n)" .
from lbs fl
have l_take_drop: "length (take (size_td s) (drop n bs)) = size_td s"
using field_lookup_offset_size' by fastforce
from padding_base.is_padding_byte_acc_eq [OF is_padding l_take_drop, of v]
have eq2:
"access_ti s v (take (size_td s) (drop n bs)) ! (x - n) =
take (size_td s) (drop n bs) ! (x - n)" .
have eq3:
"take (size_td s) (drop n bs) ! (x - n) = bs ! x"
by (metis add.commute field_lookup_offset_size' fl lbs lower_bound_x nth_take_drop_index_shift upper_bound_x)
show "access_ti (typ_info_t TYPE('a)) v bs ! x = bs ! x"
apply (simp add: eq1)
apply (simp add: eq2)
apply (simp add: eq3)
done
next
fix v::'a and bs::"byte list" and b::byte
assume sz: "x < size_td (typ_info_t TYPE('a))"
assume lbs: "length bs = size_td (typ_info_t TYPE('a))"
have v_upd_conv: "(update_ti (typ_info_t TYPE('a)) (to_bytes v bs) v) = v"
by (simp add: fu_fa lbs length_fa_ti to_bytes_def update_ti_update_ti_t)
have lto: "length (to_bytes v bs) = size_td (typ_info_t TYPE('a))"
by (simp add: lbs length_fa_ti to_bytes_def)
note upd_focus = mem_type_update_ti_super_update_bs [OF fl, simplified size_of_def, OF lto, where w=v, simplified v_upd_conv]
from lbs lower_bound_x upper_bound_x sz
have lbs1: "length (take (size_td s) (drop n bs)) = size_td s"
by (metis add_le_imp_le_diff field_lookup_offset_size' fl length_drop length_take min.absorb2)
from lbs lower_bound_x upper_bound_x
have bs_upd_eq: "(take (size_td s) (drop n bs))[x - n := b] = take (size_td s) (drop n (bs[x := b]))"
by (metis drop_update_swap take_update_swap)
from lbs lbs1 lower_bound_x upper_bound_x
have lbs2: "length (take (size_td s) (drop n (bs[x := b]))) = size_td s"
by (metis bs_upd_eq length_list_update)
from lbs lbs1
have bs_super_conv: "(super_update_bs (take (size_td s) (drop n bs)) bs n) = bs"
by (metis append_take_drop_id super_update_bs_def take_drop_append)
from lbs lbs1 lower_bound_x upper_bound_x
have bs_upd_super_conv: "(super_update_bs (take (size_td s) (drop n (bs[x := b]))) bs n) = bs[x := b]"
by (metis add.commute bs_super_conv bs_upd_eq field_lookup_offset_size' fl
nat_diff_less super_update_bs_update_index_shift)
from mem_type_update_ti_super_update_bs [OF fl, simplified size_of_def, OF lbs lbs1, simplified bs_super_conv, where w=v]
have eq1:
"update_ti (typ_info_t TYPE('a)) bs v =
update_ti s (take (size_td s) (drop n bs)) (update_ti (typ_info_t TYPE('a)) bs v)" by simp
from mem_type_update_ti_super_update_bs [OF fl, simplified size_of_def, OF lbs lbs2, simplified bs_upd_super_conv, where w=v]
have eq2:
"update_ti s (take (size_td s) (drop n (bs[x := b])))
(update_ti (typ_info_t TYPE('a)) bs v) =
update_ti (typ_info_t TYPE('a)) (bs[x := b]) v" .
thm upd_focus [OF lbs1]
note pad_eq= padding_base.is_padding_byte_upd_eq [OF is_padding, OF lbs1, where b=b]
show "update_ti (typ_info_t TYPE('a)) bs v =
update_ti (typ_info_t TYPE('a)) (bs[x := b]) v"
apply (subst eq1)
apply (simp add: pad_eq)
apply (simp add: bs_upd_eq)
apply (simp add: eq2)
done
qed
lemma (in mem_type) field_lookup_is_padding_byte:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n)"
assumes lower_bound_x: "n ≤ x"
assumes upper_bound_x: "x < n + size_td s"
shows
"padding_base.is_padding_byte (access_ti s) (update_ti s) (size_td s) (x - n) ⟷
padding_base.is_padding_byte
(access_ti (typ_info_t (TYPE('a)))) (update_ti (typ_info_t (TYPE('a)))) (size_td (typ_info_t (TYPE('a)))) x"
using field_lookup_is_padding_byte_outer_to_inner [OF fl lower_bound_x upper_bound_x]
field_lookup_is_padding_byte_inner_to_outer [OF fl lower_bound_x upper_bound_x]
by blast
lemma (in mem_type) field_lookup_is_value_byte_outer_to_inner:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n)"
assumes lower_bound_x: "n ≤ x"
assumes upper_bound_x: "x < n + size_td s"
assumes is_value: "padding_base.is_value_byte (access_ti (typ_info_t (TYPE('a)))) (update_ti (typ_info_t (TYPE('a)))) (size_td (typ_info_t (TYPE('a)))) x"
shows "padding_base.is_value_byte (access_ti s) (update_ti s) (size_td s) (x - n)"
proof (rule padding_base.is_value_byteI)
from lower_bound_x upper_bound_x show "x - n < size_td s" by simp
next
fix v::'a and bs::"byte list" and bs'::"byte list"
assume "x - n < size_td s"
assume lbs: "length bs = size_td s"
assume lbs': "length bs' = size_td s"
from fl have sz: "size_td s + n ≤ size_of TYPE('a)"
by (metis (no_types, lifting) diff_add_zero diff_is_0_eq dual_order.trans field_lookup_offset_size' size_of_def)
obtain pfx sfx xbs where
xbs: "xbs = pfx @ bs @ sfx" and
lpfx: "length pfx = n" and
lsfx: "length sfx = size_of TYPE('a) - n - size_td s"
by (metis Ex_list_of_length)
with sz have lxbs: "length xbs = size_of TYPE('a)"
by (metis add_leD2 add_le_imp_le_diff lbs le_add_diff_inverse length_append)
from xbs lpfx lsfx xbs lbs have bs: "(take (size_td s) (drop n xbs)) = bs"
by simp
obtain pfx' sfx' xbs' where
xbs': "xbs' = pfx' @ bs' @ sfx'" and
lpfx': "length pfx' = n" and
lsfx': "length sfx' = size_of TYPE('a) - n - size_td s"
by (metis Ex_list_of_length)
with sz have lxbs': "length xbs' = size_of TYPE('a)"
by (metis add_leD2 add_le_imp_le_diff lbs' le_add_diff_inverse length_append)
from xbs' lpfx' lsfx' xbs' lbs' have bs': "(take (size_td s) (drop n xbs')) = bs'"
by simp
have bound: "x - n < size_td s" by fact
have lacc: "length (access_ti (typ_info_t TYPE('a)) v xbs) = size_of TYPE('a)"
by (simp add: fd_cons_length lxbs size_of_def wf_fd_consD)
have v_upd_conv: "(update_ti (typ_info_t TYPE('a)) (to_bytes v xbs) v) = v"
by (simp add: fu_fa lacc lxbs size_of_def to_bytes_def update_ti_update_ti_t)
have lxto: "length (to_bytes v xbs) = size_of TYPE('a)"
by (simp add: lacc to_bytes_def)
from lxto lbs
have lsuper: "length (super_update_bs bs (to_bytes v xbs) n) = size_of TYPE('a)"
using sz by auto
have bound: "x - n < size_td s" by fact
have xbs_super: "xbs = super_update_bs bs xbs n"
by (simp add: lpfx super_update_bs_def xbs)
from mem_type_update_ti_super_update_bs [OF fl lxto lbs, of v, simplified v_upd_conv]
have upd_eq1:
"update_ti s bs v =
update_ti (typ_info_t TYPE('a)) (super_update_bs bs (to_bytes v xbs) n) v" .
have idx_shift1:
"take (size_td s) (drop n
(access_ti (typ_info_t TYPE('a))
(update_ti (typ_info_t TYPE('a)) (super_update_bs bs (to_bytes v xbs) n) v) xbs'))
! (x - n)
= access_ti (typ_info_t TYPE('a))
(update_ti (typ_info_t TYPE('a)) (super_update_bs bs (to_bytes v xbs) n) v) xbs'
! x "
by (metis bound fd_cons_length less_diff_conv2 local.wf_fd lower_bound_x lxbs'
nth_take_drop_index_shift size_of_def sz wf_fd_consD)
from lxto lbs lower_bound_x upper_bound_x sz
have super_nth: "super_update_bs bs (to_bytes v xbs) n ! x = bs ! (x - n)"
by (simp add: super_update_bs_nth_shift)
note val_eq = padding_base.is_value_byte_acc_upd_cancel [OF is_value lsuper [simplified size_of_def] lxbs' [simplified size_of_def]]
note acc_eq = mem_type_field_lookup_access_ti_take_drop [OF fl lxbs', simplified bs' ]
show "access_ti s (update_ti s bs v) bs' ! (x - n) = bs ! (x - n)"
apply (simp add: upd_eq1)
apply (simp add: acc_eq)
apply (simp add: idx_shift1 )
apply (simp add: val_eq)
apply (simp add: super_nth)
done
next
fix v::'a and bs::"byte list" and b::"byte"
assume "x - n < size_td s"
assume lbs: "length bs = size_td s"
from fl have sz: "size_td s + n ≤ size_of TYPE('a)"
by (metis (no_types, lifting) diff_add_zero diff_is_0_eq dual_order.trans field_lookup_offset_size' size_of_def)
obtain pfx sfx xbs where
xbs: "xbs = pfx @ bs @ sfx" and
lpfx: "length pfx = n" and
lsfx: "length sfx = size_of TYPE('a) - n - size_td s"
by (metis Ex_list_of_length)
with sz have lxbs: "length xbs = size_of TYPE('a)"
by (metis add_leD2 add_le_imp_le_diff lbs le_add_diff_inverse length_append)
from xbs lpfx lsfx xbs lbs have bs: "(take (size_td s) (drop n xbs)) = bs"
by simp
obtain xbs' where
xbs': "xbs' = pfx @ bs [x - n := b] @ sfx" by blast
from lxbs lbs xbs have lxbs': "length xbs' = size_of TYPE('a)"
using xbs' by auto
from xbs' lpfx lxbs' lbs have bs': "(take (size_td s) (drop n xbs')) = bs[x - n :=b]"
by simp
from lbs lower_bound_x upper_bound_x sz lpfx lsfx
have xbs'_conv: "xbs' = xbs[x := b]"
by (simp add: xbs xbs' list_update_append)
note eq1 = mem_type_field_lookup_access_ti_take_drop [OF fl lxbs, simplified bs, of v]
note eq2 = mem_type_field_lookup_access_ti_take_drop [OF fl lxbs', simplified bs', of v]
note val_eq = padding_base.is_value_byte_acc_eq [OF is_value lxbs [simplified size_of_def], where b=b]
show "access_ti s v bs = access_ti s v (bs[x - n := b])"
apply (simp add: eq1)
apply (simp add: val_eq)
apply (simp add: eq2)
apply (simp add: xbs'_conv)
done
qed
lemma (in mem_type) field_lookup_is_value_byte_inner_to_outer:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n)"
assumes lower_bound_x: "n ≤ x"
assumes upper_bound_x: "x < n + size_td s"
assumes is_value: "padding_base.is_value_byte (access_ti s) (update_ti s) (size_td s) (x - n)"
shows "padding_base.is_value_byte (access_ti (typ_info_t (TYPE('a)))) (update_ti (typ_info_t (TYPE('a)))) (size_td (typ_info_t (TYPE('a)))) x"
proof (rule padding_base.is_value_byteI)
from lower_bound_x upper_bound_x fl
show "x < size_td (typ_info_t TYPE('a))"
using field_lookup_offset_size' by fastforce
next
fix v::'a and bs::"byte list" and bs'::"byte list"
assume sz: "x < size_td (typ_info_t TYPE('a))"
assume lbs: "length bs = size_td (typ_info_t TYPE('a))"
assume lbs': "length bs' = size_td (typ_info_t TYPE('a))"
from fl have sz: "size_td s + n ≤ size_of TYPE('a)"
by (metis (no_types, lifting) diff_add_zero diff_is_0_eq dual_order.trans field_lookup_offset_size' size_of_def)
from sz lbs
have super_bs: "(super_update_bs (take (size_td s) (drop n bs)) bs n) = bs"
by (metis (no_types, lifting) append.assoc append_len2 append_take_drop_id diff_diff_cancel
length_drop nat_move_sub_le size_of_def super_update_bs_def take_add)
from lower_bound_x upper_bound_x lbs sz
have l_take_drop: "length (take (size_td s) (drop n bs)) = size_td s"
by (simp add: size_of_def)
from lower_bound_x upper_bound_x lbs' sz
have l_take_drop': "length (take (size_td s) (drop n bs')) = size_td s"
by (simp add: size_of_def)
from lbs lower_bound_x upper_bound_x sz
have take_drop_eq: "take (size_td s) (drop n bs) ! (x - n) = bs ! x"
by (simp add: size_of_def)
note upd_focus = mem_type_update_ti_super_update_bs [OF fl, simplified size_of_def, OF lbs l_take_drop, simplified super_bs, symmetric ]
note acc_focus = mem_type_field_lookup_nth_focus [OF fl lower_bound_x upper_bound_x, simplified size_of_def, OF lbs']
note cancel = padding_base.is_value_byte_acc_upd_cancel [OF is_value l_take_drop l_take_drop']
show "access_ti (typ_info_t TYPE('a)) (update_ti (typ_info_t TYPE('a)) bs v) bs' ! x =
bs ! x"
apply (subst upd_focus)
apply (simp add: acc_focus)
apply (simp add: cancel)
apply (simp add: take_drop_eq)
done
next
fix v::'a and bs::"byte list" and b::"byte"
assume sz: "x < size_td (typ_info_t TYPE('a))"
assume lbs: "length bs = size_td (typ_info_t TYPE('a))"
from fl have sz: "size_td s + n ≤ size_of TYPE('a)"
by (metis (no_types, lifting) diff_add_zero diff_is_0_eq dual_order.trans field_lookup_offset_size' size_of_def)
note eq1 = mem_type_field_lookup_access_ti_take_drop [OF fl, simplified size_of_def, OF lbs ]
from sz lower_bound_x upper_bound_x lbs
have l_take_s: "length (take (size_td s) (drop n bs)) = size_td s"
by (simp add: size_of_def)
from lbs sz lower_bound_x upper_bound_x
have super_eq:
"super_update_bs (access_ti s v (take (size_td s) (drop n bs)))
(access_ti (typ_info_t TYPE('a)) v bs) n = (access_ti (typ_info_t TYPE('a)) v bs)"
by (metis append_take_drop_id eq1 l_take_s length_drop length_fa_ti
length_take local.wf_fd super_update_bs_def take_drop_append)
note focus1 = mem_type_field_lookup_nth_update_focus [OF fl lower_bound_x upper_bound_x, simplified size_of_def, OF lbs]
note pad_eq = padding_base.is_value_byte_acc_eq [OF is_value l_take_s, symmetric]
show "access_ti (typ_info_t TYPE('a)) v bs =
access_ti (typ_info_t TYPE('a)) v (bs[x := b])"
apply (simp add: focus1)
apply (subst pad_eq)
apply (simp add: super_eq)
done
qed
lemma (in mem_type) field_lookup_is_value_byte:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n)"
assumes lower_bound_x: "n ≤ x"
assumes upper_bound_x: "x < n + size_td s"
shows "padding_base.is_value_byte (access_ti s) (update_ti s) (size_td s) (x - n) ⟷
padding_base.is_value_byte (access_ti (typ_info_t (TYPE('a))))
(update_ti (typ_info_t (TYPE('a)))) (size_td (typ_info_t (TYPE('a)))) x"
using field_lookup_is_value_byte_inner_to_outer [OF fl lower_bound_x upper_bound_x]
field_lookup_is_value_byte_outer_to_inner [OF fl lower_bound_x upper_bound_x]
by blast
thm padding_base.eq_padding_def
thm padding_base.eq_upto_padding_def
lemma td_set_component_descs_independent:
fixes t::"'a xtyp_info"
and st::"'a xtyp_info_struct"
and ts::"'a xtyp_info_tuple list"
and x::"'a xtyp_info_tuple"
shows
"(s, n) ∈ td_set t m ⟹ component_descs_independent t ⟹ component_descs_independent s"
"(s, n) ∈ td_set_struct st m ⟹ component_descs_independent_struct st ⟹ component_descs_independent s"
"(s, n) ∈ td_set_list ts m ⟹ component_descs_independent_list ts ⟹ component_descs_independent s"
"(s, n) ∈ td_set_tuple x m ⟹ component_descs_independent_tuple x ⟹ component_descs_independent s"
proof (induct t and st and ts and x arbitrary: m and m and m and m)
case (TypDesc algn st nm)
then show ?case by auto
next
case (TypScalar sz algn d)
then show ?case by auto
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
then show ?case by auto
next
case (DTuple_typ_desc d nm y)
then show ?case by auto
qed
lemma td_set_wf_component_descs:
fixes t::"'a xtyp_info"
and st::"'a xtyp_info_struct"
and ts::"'a xtyp_info_tuple list"
and x::"'a xtyp_info_tuple"
shows
"(s, n) ∈ td_set t m ⟹ wf_component_descs t ⟹ wf_component_descs s"
"(s, n) ∈ td_set_struct st m ⟹ wf_component_descs_struct st ⟹ wf_component_descs s"
"(s, n) ∈ td_set_list ts m ⟹ wf_component_descs_list ts ⟹ wf_component_descs s"
"(s, n) ∈ td_set_tuple x m ⟹ wf_component_descs_tuple x ⟹ wf_component_descs s"
proof (induct t and st and ts and x arbitrary: m and m and m and m)
case (TypDesc algn st nm)
then show ?case by auto
next
case (TypScalar sz algn d)
then show ?case by auto
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
then show ?case by auto
next
case (DTuple_typ_desc d nm y)
then show ?case by auto
qed
lemma td_set_field_descs:
fixes t::"'a xtyp_info"
and st::"'a xtyp_info_struct"
and ts::"'a xtyp_info_tuple list"
and x::"'a xtyp_info_tuple"
shows
"(s, n) ∈ td_set t m ⟹ wf_component_descs t ⟹ component_desc s ∈ insert (component_desc t) (set (field_descs t))"
"(s, n) ∈ td_set_struct st m ⟹ wf_component_descs_struct st ⟹ component_desc s ∈ (set (field_descs_struct st))"
"(s, n) ∈ td_set_list ts m ⟹ wf_component_descs_list ts ⟹ component_desc s ∈ (set (field_descs_list ts))"
"(s, n) ∈ td_set_tuple x m ⟹ wf_component_descs_tuple x ⟹ component_desc s ∈ (set (field_descs_tuple x))"
proof (induct t and st and ts and x arbitrary: m and m and m and m)
case (TypDesc algn st nm)
then show ?case by auto
next
case (TypScalar sz algn d)
then show ?case by auto
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
then show ?case by auto
next
case (DTuple_typ_desc d nm y)
then show ?case by auto
qed
lemma td_set_wf_field_descs:
fixes t::"'a xtyp_info"
and st::"'a xtyp_info_struct"
and ts::"'a xtyp_info_tuple list"
and x::"'a xtyp_info_tuple"
shows
"(s, n) ∈ td_set t m ⟹ wf_field_descs (set (field_descs t)) ⟹ wf_field_descs (set (field_descs s))"
"(s, n) ∈ td_set_struct st m ⟹wf_field_descs (set (field_descs_struct st)) ⟹ wf_field_descs (set (field_descs s))"
"(s, n) ∈ td_set_list ts m ⟹ wf_field_descs (set (field_descs_list ts)) ⟹ wf_field_descs (set (field_descs s))"
"(s, n) ∈ td_set_tuple x m ⟹ wf_field_descs (set (field_descs_tuple x)) ⟹ wf_field_descs (set (field_descs s))"
proof (induct t and st and ts and x arbitrary: m and m and m and m)
case (TypDesc algn st nm)
then show ?case by auto
next
case (TypScalar sz algn d)
then show ?case by auto
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
then show ?case by auto
next
case (DTuple_typ_desc d nm y)
then show ?case by auto
qed
context xmem_type
begin
lemma xmem_type_td_set_field_descs:
"(s,n) ∈ td_set (typ_info_t TYPE('a)) m ⟹
component_desc s ∈ insert (component_desc (typ_info_t TYPE('a))) (set (field_descs (typ_info_t TYPE('a))))"
using td_set_field_descs local.wf_component_descs by blast
lemma field_lookup_component_desc:
"field_lookup (typ_info_t TYPE('a)) f m = Some (s, n) ⟹
component_desc s ∈ insert (component_desc (typ_info_t TYPE('a))) (set (field_descs (typ_info_t TYPE('a))))"
using xmem_type_td_set_field_descs td_set_field_lookupD
by blast
lemma field_lookup_wf_field_desc:
"field_lookup (typ_info_t TYPE('a)) f m = Some (s, n) ⟹
wf_field_desc (component_desc s)"
using field_lookup_component_desc
by (meson local.wf_field_descs' wf_field_descs_def)
lemma field_lookup_component_descs_independent:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f m = Some (s, n)"
shows "component_descs_independent s"
using field_lookup_component_desc [OF fl]
by (meson fl local.component_descs_independent td_set_component_descs_independent(1) td_set_field_lookupD)
lemma field_lookup_wf_component_descs:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f m = Some (s, n)"
shows "wf_component_descs s"
using field_lookup_component_desc [OF fl] td_set_wf_component_descs fl
local.wf_component_descs td_set_field_lookupD by blast
lemma field_lookup_wf_field_descs:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f m = Some (s, n)"
shows "wf_field_descs (set (field_descs s))"
using td_set_wf_field_descs fl local.wf_field_descs td_set_field_lookupD by blast
lemma field_lookup_field_access_access_ti:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f m = Some (s, n)"
shows "field_access (component_desc s) = access_ti s"
using access_ti_component_desc_compatible(1) [OF field_lookup_wf_component_descs [OF fl]
field_lookup_component_descs_independent [OF fl] field_lookup_wf_field_descs [OF fl]]
by (simp add: fun_eq_iff)
lemma field_lookup_field_update_update_ti:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f m = Some (s, n)"
shows "field_update (component_desc s) = update_ti s"
using update_ti_component_desc_compatible(1) [OF field_lookup_wf_component_descs [OF fl]
field_lookup_component_descs_independent [OF fl] field_lookup_wf_field_descs [OF fl]]
by (simp add: fun_eq_iff)
lemma field_lookup_field_sz_size_td:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f m = Some (s, n)"
shows "field_sz (component_desc s) = size_td s"
using size_td_field_sz(1) [OF field_lookup_wf_component_descs [OF fl] ]
by simp
lemma field_lookup_component_desc_complement_padding:
"field_lookup (typ_info_t TYPE('a)) f m = Some (s, n) ⟹
complement_padding (field_access (component_desc s)) (field_update (component_desc s)) (field_sz (component_desc s))"
using field_lookup_component_desc
by (meson field_lookup_wf_field_desc padding_lense.axioms(1) wf_field_desc.axioms)
lemma field_lookup_component_desc_complement_padding':
assumes fl: "field_lookup (typ_info_t TYPE('a)) f m = Some (s, n)"
shows "complement_padding (access_ti s) (update_ti s) (size_td s)"
using field_lookup_component_desc_complement_padding
field_lookup_field_access_access_ti [OF fl]
field_lookup_field_update_update_ti [OF fl]
field_lookup_field_sz_size_td [OF fl]
by (metis fl)
lemma field_lookup_padding_lense:
"field_lookup (typ_info_t TYPE('a)) f m = Some (s, n) ⟹
padding_lense (access_ti s) (update_ti s) (size_td s)"
by (metis field_lookup_field_access_access_ti field_lookup_field_update_update_ti
field_lookup_wf_component_descs field_lookup_wf_field_desc size_td_field_sz(1) wf_field_desc_def)
sublocale lense: padding_lense
"access_ti (typ_info_t TYPE('a))"
"update_ti (typ_info_t TYPE('a))"
"size_of TYPE('a)"
using local.field_access_access_ti local.field_sz_size_of
local.field_update_update_ti local.xmem_type_wf_field_desc.padding_lense_axioms by simp
end
lemma eq_padding_access_update_field_cancel:
assumes fl: "field_lookup (typ_info_t (TYPE('a::xmem_type))) f 0 = Some (s, n)"
assumes lower_bound_x: "n ≤ x"
assumes upper_bound_x: "x < n + size_of TYPE('b)"
assumes match: "export_uinfo s = typ_uinfo_t TYPE('b::xmem_type)"
assumes lbs: "length bs = size_of TYPE('b)"
assumes lbs': "length bs' = size_of TYPE('a)"
assumes eq_padding: "padding_base.eq_padding (access_ti s) (size_td s) bs (take (size_of TYPE('b)) (drop n bs'))"
shows "access_ti (typ_info_t TYPE('a::xmem_type)) (update_ti s bs v) bs' ! x = bs ! (x - n)"
proof -
obtain i where i: "i = x - n" by blast
from match fl have sz_b: "size_of TYPE('b) = size_td s"
using export_size_of by blast
interpret cps: complement_padding "access_ti s" "update_ti s" "size_td s"
by (rule field_lookup_component_desc_complement_padding' [OF fl])
from lower_bound_x upper_bound_x sz_b
have x_n_bound: "x - n < size_td s"
by simp
from eq_padding
have l_take_drop_bs': "length (take (size_td s) (drop n bs')) = size_td s"
by (metis lbs padding_base.eq_padding_length_eq sz_b)
from lower_bound_x upper_bound_x fl lbs'
have acc_bs': "take (size_td s) (drop n bs') ! (x - n) = bs' ! x"
by (metis add.commute field_lookup_offset_size nth_take_drop_index_shift size_of_def sz_b)
from mem_type_field_lookup_nth_focus [OF fl lower_bound_x [simplified size_of_def] upper_bound_x [simplified sz_b] lbs']
have "access_ti (typ_info_t TYPE('a)) (update_ti s bs v) bs' ! x =
access_ti s (update_ti s bs v) (take (size_td s) (drop n bs')) ! (x - n) " .
also have "… = bs ! (x - n)" (is "?lhs = ?rhs")
proof (cases "padding_base.is_padding_byte (access_ti s) (update_ti s) (size_td s) (x - n)")
case True
from padding_base.is_padding_byte_acc_eq [OF True l_take_drop_bs' ] acc_bs'
have "?lhs = bs' ! x" by simp
also have "bs' ! x = bs ! (x - n)"
using cps.eq_padding_padding_byte_id [OF eq_padding True] acc_bs' sz_b
by simp
finally show ?thesis .
next
case False
then have is_value: "cps.is_value_byte (x - n)" using cps.complement x_n_bound by simp
from cps.is_value_byte_acc_upd_cancel [OF is_value lbs [simplified sz_b] l_take_drop_bs']
show ?thesis .
qed
finally show ?thesis .
qed
context xmem_type
begin
sublocale xmem_type_padding: complement_padding
"access_ti (typ_info_t TYPE('a))"
"update_ti (typ_info_t TYPE('a))"
"size_of TYPE('a)"
using xmem_type_wf_field_desc.complement_padding_axioms
by (simp add: field_access_access_ti field_update_update_ti field_sz_size_td size_of_def)
end
lemma drop_heap_list_le2:
"heap_list h n (x + of_nat k)
= drop k (heap_list h (n + k) x)"
by (simp add: drop_heap_list_le)
lemma heap_list_take_drop:
assumes N_bound: "unat a + N ≤ 2 ^ len_of TYPE(addr_bitsize)"
shows "n + m ≤ N ⟹ take m (drop n (heap_list hp N a)) =
heap_list hp m (a + word_of_nat n)"
apply (induct m arbitrary: n)
apply simp
apply simp
using N_bound
by auto
(metis (no_types, opaque_lifting) add.left_commute add.right_neutral add_Suc_right drop_heap_list_le2 heap_list_rec take_drop take_heap_list_le)
lemma heap_list_take_drop':
assumes N_bound: "unat a + N ≤ addr_card"
assumes bound: "n + m ≤ N"
shows "take m (drop n (heap_list hp N a)) =
heap_list hp m (a + word_of_nat n)"
proof -
have "addr_card = 2 ^ len_of TYPE(addr_bitsize)"
by (simp add: addr_card)
from heap_list_take_drop [OF N_bound [simplified this ] bound] show ?thesis by blast
qed
experiment
fixes proj:: "'a::xmem_type ⇒ 'b::xmem_type"
fixes t::"'a xtyp_info"
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (t, n)"
and eu: "export_uinfo t = typ_uinfo_t TYPE('b)"
assumes access_comp: "access_ti t v = access_ti (typ_info_t TYPE('b)) (proj v)"
assumes surj: "surj proj"
begin
lemma sz: "size_td t = size_of TYPE('b)"
using eu
by (metis export_uinfo_size size_of_def typ_uinfo_size)
lemma "padding_base.eq_padding (access_ti t) (size_td t) =
padding_base.eq_padding (access_ti (typ_info_t TYPE('b))) (size_of TYPE('b))"
unfolding padding_base.eq_padding_def
apply (rule ext)
apply (rule ext)
apply (simp add: sz)
apply (simp add: access_comp)
using surj
by (metis surj_def)
end
definition is_padding_byte::"typ_uinfo ⇒ nat ⇒ bool" where
"is_padding_byte t i ≡ i < size_td t ∧
(∀bs b. length bs = size_td t ⟶ norm_tu t (bs[i := b]) = norm_tu t bs)"
definition is_value_byte::"typ_uinfo ⇒ nat ⇒ bool" where
"is_value_byte t i ≡ i < size_td t ∧
(∃bs b. length bs = size_td t ∧ norm_tu t (bs[i := b]) ≠ norm_tu t bs)"
lemma is_padding_byteI:
assumes "i < size_td t"
assumes "⋀i bs b. length bs = size_td t ⟹ norm_tu t (bs[i := b]) = norm_tu t bs"
shows "is_padding_byte t i"
using assms by (simp add: is_padding_byte_def)
lemma complement_tu_padding:
"i < size_td t ⟹ is_padding_byte t i ≠ is_value_byte t i"
by (auto simp add: is_padding_byte_def is_value_byte_def)
definition eq_padding::"typ_uinfo ⇒ byte list ⇒ byte list ⇒ bool" where
"eq_padding t bs bs' ≡ length bs = size_td t ∧ length bs' = size_td t ∧
(∀i. is_padding_byte t i ⟶ bs ! i = bs' ! i)"
definition eq_upto_padding::"typ_uinfo ⇒ byte list ⇒ byte list ⇒ bool" where
"eq_upto_padding t bs bs' ≡ length bs = size_td t ∧ length bs' = size_td t ∧
(∀i. is_value_byte t i ⟶ bs ! i = bs' ! i)"
lemma eq_padding_refl[simp]: "length bs = size_td t ⟹ eq_padding t bs bs"
by (auto simp add: eq_padding_def)
lemma eq_upto_padding_refl[simp]: "length bs = size_td t ⟹ eq_upto_padding t bs bs"
by (auto simp add: eq_upto_padding_def)
lemma eq_padding_sym: "eq_padding t bs bs' ⟷ eq_padding t bs' bs"
by (auto simp add: eq_padding_def)
lemma eq_padding_symp: "symp (eq_padding t)"
by (simp add: symp_def eq_padding_sym)
lemma eq_upto_padding_sym: "eq_upto_padding t bs bs' ⟷ eq_upto_padding t bs' bs"
by (auto simp add: eq_upto_padding_def)
lemma eq_upto_padding_symp: "symp (eq_upto_padding t)"
by (simp add: symp_def eq_upto_padding_sym)
lemma eq_padding_trans: "eq_padding t bs1 bs2 ⟹ eq_padding t bs2 bs3 ⟹ eq_padding t bs1 bs3"
by (auto simp add: eq_padding_def)
lemma eq_padding_transp: "transp (eq_padding t)"
unfolding transp_def
by (auto intro: eq_padding_trans)
lemma eq_upto_padding_trans: "eq_upto_padding t bs1 bs2 ⟹ eq_upto_padding t bs2 bs3 ⟹ eq_upto_padding t bs1 bs3"
by (auto simp add: eq_upto_padding_def)
lemma eq_upto_padding_transp: "transp (eq_upto_padding t)"
unfolding transp_def
by (auto intro: eq_upto_padding_trans)
lemma eq_padding_eq_upto_padding_eq: "eq_padding t bs bs' ⟹ eq_upto_padding t bs bs' ⟹ bs = bs'"
proof -
assume a1: "eq_padding t bs bs'"
assume a2: "eq_upto_padding t bs bs'"
have f3: "length bs' = size_td t"
using a1 by (simp add: eq_padding_def)
have "length bs = size_td t"
using a1 eq_padding_def by blast
then show ?thesis
using f3 a2 a1 by (metis (full_types) complement_tu_padding eq_padding_def eq_upto_padding_def nth_equalityI)
qed
thm padding_base.is_padding_byte_def
lemma is_padding_byte_access_ti':
fixes t::"'a xtyp_info"
and st::"'a xtyp_info_struct"
and ts::"'a xtyp_info_tuple list"
and x::"'a xtyp_info_tuple"
shows
"⟦ wf_desc t; wf_size_desc t; wf_field_descs (set (field_descs t)); wf_component_descs t; wf_fd t;
i < size_td t; length bs = size_td t;
∀bs b. length bs = size_td t ⟶ norm_tu (map_td field_norm (λ_. ()) t) (bs[i := b]) = norm_tu (export_uinfo t) bs⟧
⟹ access_ti t v bs ! i = bs ! i"
"⟦ wf_desc_struct st; wf_size_desc_struct st; wf_field_descs (set (field_descs_struct st));
wf_component_descs_struct st; wf_fd_struct st; i < size_td_struct st; length bs = size_td_struct st;
∀bs b. length bs = size_td_struct st ⟶ norm_tu_struct (map_td_struct field_norm (λ_. ()) st) (bs[i := b]) = norm_tu_struct ((map_td_struct field_norm (λ_. ()) st)) bs⟧
⟹ access_ti_struct st v bs ! i = bs ! i"
"⟦ wf_desc_list ts; wf_size_desc_list ts; wf_field_descs (set (field_descs_list ts));
wf_component_descs_list ts; wf_fd_list ts; i < size_td_list ts; length bs = size_td_list ts;
∀bs b. length bs = size_td_list ts ⟶ norm_tu_list (map_td_list field_norm (λ_. ()) ts) (bs[i := b]) = norm_tu_list ((map_td_list field_norm (λ_. ()) ts)) bs⟧
⟹ access_ti_list ts v bs ! i = bs ! i"
"⟦ wf_desc_tuple x; wf_size_desc_tuple x; wf_field_descs (set (field_descs_tuple x));
wf_component_descs_tuple x; wf_fd_tuple x; i < size_td_tuple x; length bs = size_td_tuple x;
∀bs b. length bs = size_td_tuple x ⟶ norm_tu_tuple (map_td_tuple field_norm (λ_. ()) x) (bs[i := b]) = norm_tu_tuple ((map_td_tuple field_norm (λ_. ()) x)) bs⟧
⟹ access_ti_tuple x v bs ! i = bs ! i"
proof (induct t and st and ts and x arbitrary: bs i and bs i and bs i and bs i)
case (TypDesc algn st nm)
then show ?case by auto
next
case (TypScalar sz algn d)
from TypScalar obtain
wf_d: "wf_field_desc d" and
field_sz: "field_sz d =sz" and
i_bound: "i < sz" and
lbs: "length bs = sz" and
padding: "⋀bs b. length bs = sz ⟹
field_norm sz algn d (bs[i := b]) = field_norm sz algn d bs"
by simp
interpret wf: wf_field_desc d by (rule wf_d)
show ?case
proof (cases "wf.is_padding_byte i")
case True
then show ?thesis
using field_sz lbs wf.is_padding_byte_acc_id by auto
next
case False
note not_padding = this
with wf.complement field_sz i_bound have is_value: "wf.is_value_byte i" by blast
from is_value padding have False
by (auto simp add: field_norm_def)
(metis (mono_tags, opaque_lifting) field_sz i_bound list_update_id not_padding padding_base.is_value_byte_upd_neq
wf.access_result_size wf.is_padding_byte_def wf.update_access wf.update_access_unequal)
then show ?thesis by blast
qed
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
obtain d nm y where x: "x = DTuple d nm y" by (cases x) auto
from Cons_typ_desc.prems obtain
wf_desc_d: "wf_desc d" and
wf_fd_x: "wf_fd_tuple (DTuple d nm y)" and
wf_fd_d: "wf_fd d" and
wf_fd_fs: "wf_fd_list fs" and
nm_notin: "nm ∉ dt_snd ` set fs" and
wf_desc_fs: "wf_desc_list fs" and
wf_sz_d: "wf_size_desc d" and
wf_sz_fs: "wf_size_desc_list fs" and
wf_field_d: "wf_field_desc (component_desc d)" and
wf_fields_d: "wf_field_descs (set (field_descs d))" and
wf_fields_fs: "wf_field_descs (set (field_descs_list fs))" and
y: "y = component_desc d" and
wf_comp_d: "wf_component_descs d" and
wf_comp_fs: "wf_component_descs_list fs" and
i_bound:"i < size_td d + size_td_list fs" and
lbs: "length bs = size_td d + size_td_list fs" and
wf_desc_x: "wf_desc_tuple x" and
wf_sz_x: "wf_size_desc_tuple x" and
wf_decs_x: "wf_field_descs (set (field_descs_tuple x))" and
wf_comp_x: "wf_component_descs_tuple x" and
padding: "⋀bs b . length bs = size_td d + size_td_list fs ⟹
norm_tu (map_td field_norm (λ_. ()) d)
(take (size_td d) (bs[i := b])) @
norm_tu_list (map_td_list field_norm (λ_. ()) fs)
(drop (size_td d) (bs[i := b])) =
norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) bs) @
norm_tu_list (map_td_list field_norm (λ_. ()) fs)
(drop (size_td d) bs)"
by (auto simp add: x)
have padding_d: "∀bs. length bs = size_td d ⟶
(∀b. norm_tu (map_td field_norm (λ_. ()) d) (bs[i := b]) =
norm_tu (map_td field_norm (λ_. ()) d) bs)"
proof (safe)
fix bs::"byte list" and b::"byte"
assume lbs: "length bs = size_td d"
from lbs obtain xbs sfx where xbs: "xbs = bs @ sfx" and lxbs: "length xbs = size_td d + size_td_list fs"
by (metis Ex_list_of_length length_append)
from lbs
have eq1: "(take (size_td d) ((bs @ sfx)[i := b])) = bs[i := b]" by (simp add: list_update_append)
from lbs
have lbs': "length (bs[i:=b]) = size_td d" by simp
from wf_fd_norm_tu(1)[rule_format, OF wf_fd_d lbs ] lbs
have lnorm1:"length (norm_tu (map_td field_norm (λ_. ()) d) bs) = size_td d"
by (simp add: export_uinfo_def length_fa_ti wf_fd_d)
from wf_fd_norm_tu(1)[rule_format, OF wf_fd_d lbs' ] lbs'
have lnorm2: "length (norm_tu (map_td field_norm (λ_. ()) d) (bs[i:=b])) = size_td d"
by (simp add: export_uinfo_def length_fa_ti wf_fd_d)
from padding [OF lxbs, of b] xbs lbs
show "norm_tu (map_td field_norm (λ_. ()) d) (bs[i := b]) =
norm_tu (map_td field_norm (λ_. ()) d) bs"
apply simp
apply (subst (asm) list_append_eq_split_conv)
apply (simp add: eq1 lnorm1 lnorm2)
apply (simp add: eq1)
done
qed
from lbs
have lbs_drop: "length (drop (size_td d) bs) = size_td_list fs"
by (simp add: x)
from lbs
have lbs_take: "length (take (size_td d) bs) = size_td d"
by (simp add: x)
have lacc: "length (access_ti d v (take (size_td d) bs)) = size_td d"
by (metis lbs_take length_fa_ti size_td_tuple.simps wf_fd_tuple.simps wf_fd_x x)
show ?case
proof (cases "i < size_td d")
case True
note hyp = Cons_typ_desc.hyps(1) [OF wf_desc_x wf_sz_x wf_decs_x wf_comp_x, simplified x, OF wf_fd_x, simplified, OF True lbs_take padding_d]
from hyp lbs
show ?thesis
by (simp add: x True nth_append lacc )
next
case False
from False i_bound have i_bound': "i - size_td d < size_td_list fs" by simp
have padding_fs: "∀bs b.
length bs = size_td_list fs ⟶
norm_tu_list (map_td_list field_norm (λ_. ()) fs) (bs[i - size_td d := b]) =
norm_tu_list (map_td_list field_norm (λ_. ()) fs) bs"
proof (safe)
fix bs::"byte list" and b::"byte"
assume lbs: "length bs = size_td_list fs"
from lbs obtain xbs pfx where xbs: "xbs = pfx @ bs" and lxbs: "length xbs = size_td d + size_td_list fs"
and lpfx: "length pfx = size_td d"
by (metis Ex_list_of_length length_append)
from lpfx
have drop_eq1: "drop (size_td d) xbs = bs"
by (simp add: xbs)
from lpfx False have drop_eq2: "(drop (size_td d) (xbs[i := b])) = bs [i - size_td d := b]"
by (auto simp add: xbs list_update_append)
from lpfx False
have take_eq1: "take (size_td d) (xbs[i := b]) = pfx"
by (simp add: xbs list_update_append)
from lpfx False
have take_eq2: "take (size_td d) xbs = pfx"
by (simp add: xbs)
have leq1: "length (norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) (xbs[i := b]))) = size_td d"
apply (simp add: take_eq1)
using wf_fd_norm_tu(1)[rule_format, OF wf_fd_d lpfx ] lpfx
by (simp add: export_uinfo_def length_fa_ti wf_fd_d)
have leq2: "length (norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) xbs)) = size_td d"
apply (simp add: take_eq2)
using wf_fd_norm_tu(1)[rule_format, OF wf_fd_d lpfx ] lpfx
by (simp add: export_uinfo_def length_fa_ti wf_fd_d)
from padding [OF lxbs, of b, simplified drop_eq1 drop_eq2]
show "norm_tu_list (map_td_list field_norm (λ_. ()) fs) (bs[i - size_td d := b]) =
norm_tu_list (map_td_list field_norm (λ_. ()) fs) bs"
apply -
apply (subst (asm) list_append_eq_split_conv)
apply (simp add: leq1 leq2)
apply simp
done
qed
from False lbs have drop_eq: "drop (size_td d) bs ! (i - size_td d) = bs ! i" by simp
note hyp = Cons_typ_desc.hyps(2) [OF wf_desc_fs wf_sz_fs wf_fields_fs wf_comp_fs wf_fd_fs i_bound' lbs_drop padding_fs]
from hyp
show ?thesis by (simp add: x False nth_append lacc drop_eq)
qed
next
case (DTuple_typ_desc d nm y)
then show ?case by (auto simp add: export_uinfo_def)
qed
lemma is_padding_byte_access_ti:
assumes wf: "wf_desc (t::'a xtyp_info)"
and wf_sz: "wf_size_desc t"
and wf_descs: "wf_field_descs (set (field_descs t))"
and wf_comp: "wf_component_descs t"
and wf_fd: "wf_fd t"
and i_bound: "i < size_td t"
and lbs: "length bs = size_td t"
and is_padding: "is_padding_byte (export_uinfo t) i"
shows "access_ti t v bs ! i = bs ! i"
using is_padding_byte_access_ti'(1) [OF wf wf_sz wf_descs wf_comp wf_fd i_bound lbs] is_padding
by (simp add: is_padding_byte_def export_uinfo_def)
context xmem_type
begin
lemma xmem_type_is_padding_byte_access_ti:
assumes padding: "is_padding_byte (typ_uinfo_t TYPE('a)) i"
and i_bound: "i < size_of TYPE('a)"
and lbs: "length bs = size_of TYPE('a)"
shows "access_ti (typ_info_t TYPE('a)) v bs ! i = bs ! i"
proof -
have wf: "wf_desc (typ_info_t TYPE('a))" by simp
have wf_sz: "wf_size_desc (typ_info_t TYPE('a))" by simp
have wf_descs: "wf_field_descs (set (field_descs (typ_info_t TYPE('a))))"
using local.wf_field_descs by blast
have wf_comp: "wf_component_descs (typ_info_t TYPE('a))"
by (simp add: local.wf_component_descs)
have wf_fd: "wf_fd (typ_info_t TYPE('a))"
using local.wf_desc local.wf_lf wf_fdp_fd(1) wf_lf_fdp by blast
from is_padding_byte_access_ti [OF wf wf_sz wf_descs wf_comp wf_fd
i_bound [simplified size_of_def] lbs [simplified size_of_def]
padding [simplified typ_uinfo_t_def]]
show ?thesis .
qed
end
lemma is_padding_byte_update_ti_id':
fixes t::"'a xtyp_info"
and st::"'a xtyp_info_struct"
and ts::"'a xtyp_info_tuple list"
and x::"'a xtyp_info_tuple"
shows
"⟦ wf_desc t; wf_size_desc t; wf_field_descs (set (field_descs t)); wf_component_descs t; wf_fd t;
i < size_td t; length bs = size_td t;
∀bs b. length bs = size_td t ⟶ norm_tu (map_td field_norm (λ_. ()) t) (bs[i := b]) = norm_tu (export_uinfo t) bs⟧
⟹ update_ti t (bs[i := b]) v = update_ti t bs v"
"⟦ wf_desc_struct st; wf_size_desc_struct st; wf_field_descs (set (field_descs_struct st));
wf_component_descs_struct st; wf_fd_struct st; i < size_td_struct st; length bs = size_td_struct st;
∀bs b. length bs = size_td_struct st ⟶ norm_tu_struct (map_td_struct field_norm (λ_. ()) st) (bs[i := b]) = norm_tu_struct ((map_td_struct field_norm (λ_. ()) st)) bs⟧
⟹ update_ti_struct st (bs[i := b]) v = update_ti_struct st bs v"
"⟦ wf_desc_list ts; wf_size_desc_list ts; wf_field_descs (set (field_descs_list ts));
wf_component_descs_list ts; wf_fd_list ts; i < size_td_list ts; length bs = size_td_list ts;
∀bs b. length bs = size_td_list ts ⟶ norm_tu_list (map_td_list field_norm (λ_. ()) ts) (bs[i := b]) = norm_tu_list ((map_td_list field_norm (λ_. ()) ts)) bs⟧
⟹ update_ti_list ts (bs[i := b]) v = update_ti_list ts bs v"
"⟦ wf_desc_tuple x; wf_size_desc_tuple x; wf_field_descs (set (field_descs_tuple x));
wf_component_descs_tuple x; wf_fd_tuple x; i < size_td_tuple x; length bs = size_td_tuple x;
∀bs b. length bs = size_td_tuple x ⟶ norm_tu_tuple (map_td_tuple field_norm (λ_. ()) x) (bs[i := b]) = norm_tu_tuple ((map_td_tuple field_norm (λ_. ()) x)) bs⟧
⟹ update_ti_tuple x (bs[i := b]) v = update_ti_tuple x bs v"
proof (induct t and st and ts and x arbitrary: bs i v and bs i v and bs i v and bs i v)
case (TypDesc algn st nm)
then show ?case by auto
next
case (TypScalar sz algn d)
from TypScalar obtain
wf_d: "wf_field_desc d" and
field_sz: "field_sz d =sz" and
i_bound: "i < sz" and
lbs: "length bs = sz" and
padding: "⋀bs b. length bs = sz ⟹
field_norm sz algn d (bs[i := b]) = field_norm sz algn d bs"
by simp
interpret wf: wf_field_desc d by (rule wf_d)
show ?case
proof (cases "wf.is_padding_byte i")
case True
then show ?thesis
using field_sz lbs wf.is_padding_byte_upd_eq by auto
next
case False
note not_padding = this
with wf.complement field_sz i_bound have is_value: "wf.is_value_byte i" by blast
from is_value padding have False
by (auto simp add: field_norm_def)
(metis (mono_tags, opaque_lifting) field_sz i_bound list_update_id not_padding padding_base.is_value_byte_upd_neq
wf.access_result_size wf.is_padding_byte_def wf.update_access wf.update_access_unequal)
then show ?thesis by blast
qed
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
obtain d nm y where x: "x = DTuple d nm y" by (cases x) auto
from Cons_typ_desc.prems obtain
wf_desc_d: "wf_desc d" and
wf_fd_x: "wf_fd_tuple (DTuple d nm y)" and
wf_fd_d: "wf_fd d" and
wf_fd_fs: "wf_fd_list fs" and
nm_notin: "nm ∉ dt_snd ` set fs" and
wf_desc_fs: "wf_desc_list fs" and
wf_sz_d: "wf_size_desc d" and
wf_sz_fs: "wf_size_desc_list fs" and
wf_field_d: "wf_field_desc (component_desc d)" and
wf_fields_d: "wf_field_descs (set (field_descs d))" and
wf_fields_fs: "wf_field_descs (set (field_descs_list fs))" and
y: "y = component_desc d" and
wf_comp_d: "wf_component_descs d" and
wf_comp_fs: "wf_component_descs_list fs" and
i_bound:"i < size_td d + size_td_list fs" and
lbs: "length bs = size_td d + size_td_list fs" and
wf_desc_x: "wf_desc_tuple x" and
wf_sz_x: "wf_size_desc_tuple x" and
wf_decs_x: "wf_field_descs (set (field_descs_tuple x))" and
wf_comp_x: "wf_component_descs_tuple x" and
padding: "⋀bs b . length bs = size_td d + size_td_list fs ⟹
norm_tu (map_td field_norm (λ_. ()) d)
(take (size_td d) (bs[i := b])) @
norm_tu_list (map_td_list field_norm (λ_. ()) fs)
(drop (size_td d) (bs[i := b])) =
norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) bs) @
norm_tu_list (map_td_list field_norm (λ_. ()) fs)
(drop (size_td d) bs)"
by (auto simp add: x)
have padding_d: "∀bs. length bs = size_td d ⟶
(∀b. norm_tu (map_td field_norm (λ_. ()) d) (bs[i := b]) =
norm_tu (map_td field_norm (λ_. ()) d) bs)"
proof (safe)
fix bs::"byte list" and b::"byte"
assume lbs: "length bs = size_td d"
from lbs obtain xbs sfx where xbs: "xbs = bs @ sfx" and lxbs: "length xbs = size_td d + size_td_list fs"
by (metis Ex_list_of_length length_append)
from lbs
have eq1: "(take (size_td d) ((bs @ sfx)[i := b])) = bs[i := b]" by (simp add: list_update_append)
from lbs
have lbs': "length (bs[i:=b]) = size_td d" by simp
from wf_fd_norm_tu(1)[rule_format, OF wf_fd_d lbs ] lbs
have lnorm1:"length (norm_tu (map_td field_norm (λ_. ()) d) bs) = size_td d"
by (simp add: export_uinfo_def length_fa_ti wf_fd_d)
from wf_fd_norm_tu(1)[rule_format, OF wf_fd_d lbs' ] lbs'
have lnorm2: "length (norm_tu (map_td field_norm (λ_. ()) d) (bs[i:=b])) = size_td d"
by (simp add: export_uinfo_def length_fa_ti wf_fd_d)
from padding [OF lxbs, of b] xbs lbs
show "norm_tu (map_td field_norm (λ_. ()) d) (bs[i := b]) =
norm_tu (map_td field_norm (λ_. ()) d) bs"
apply simp
apply (subst (asm) list_append_eq_split_conv)
apply (simp add: eq1 lnorm1 lnorm2)
apply (simp add: eq1)
done
qed
from lbs
have lbs_drop: "length (drop (size_td d) bs) = size_td_list fs"
by (simp add: x)
from lbs
have lbs_take: "length (take (size_td d) bs) = size_td d"
by (simp add: x)
have lacc: "length (access_ti d v (take (size_td d) bs)) = size_td d"
by (metis lbs_take length_fa_ti size_td_tuple.simps wf_fd_tuple.simps wf_fd_x x)
show ?case
proof (cases "i < size_td d")
case True
from True lbs
have take_eq: "(take (size_td d) bs)[i := b] = take (size_td d) (bs[i := b])"
by (simp add: take_update_swap)
note hyp = Cons_typ_desc.hyps(1) [OF wf_desc_x wf_sz_x wf_decs_x wf_comp_x, simplified x, OF wf_fd_x, simplified, OF True lbs_take padding_d]
from hyp lbs
show ?thesis
by (simp add: x True nth_append lacc take_eq)
next
case False
from False i_bound have i_bound': "i - size_td d < size_td_list fs" by simp
have padding_fs: "∀bs b.
length bs = size_td_list fs ⟶
norm_tu_list (map_td_list field_norm (λ_. ()) fs) (bs[i - size_td d := b]) =
norm_tu_list (map_td_list field_norm (λ_. ()) fs) bs"
proof (safe)
fix bs::"byte list" and b::"byte"
assume lbs: "length bs = size_td_list fs"
from lbs obtain xbs pfx where xbs: "xbs = pfx @ bs" and lxbs: "length xbs = size_td d + size_td_list fs"
and lpfx: "length pfx = size_td d"
by (metis Ex_list_of_length length_append)
from lpfx
have drop_eq1: "drop (size_td d) xbs = bs"
by (simp add: xbs)
from lpfx False have drop_eq2: "(drop (size_td d) (xbs[i := b])) = bs [i - size_td d := b]"
by (auto simp add: xbs list_update_append)
from lpfx False
have take_eq1: "take (size_td d) (xbs[i := b]) = pfx"
by (simp add: xbs list_update_append)
from lpfx False
have take_eq2: "take (size_td d) xbs = pfx"
by (simp add: xbs)
have leq1: "length (norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) (xbs[i := b]))) = size_td d"
apply (simp add: take_eq1)
using wf_fd_norm_tu(1)[rule_format, OF wf_fd_d lpfx ] lpfx
by (simp add: export_uinfo_def length_fa_ti wf_fd_d)
have leq2: "length (norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) xbs)) = size_td d"
apply (simp add: take_eq2)
using wf_fd_norm_tu(1)[rule_format, OF wf_fd_d lpfx ] lpfx
by (simp add: export_uinfo_def length_fa_ti wf_fd_d)
from padding [OF lxbs, of b, simplified drop_eq1 drop_eq2]
show "norm_tu_list (map_td_list field_norm (λ_. ()) fs) (bs[i - size_td d := b]) =
norm_tu_list (map_td_list field_norm (λ_. ()) fs) bs"
apply -
apply (subst (asm) list_append_eq_split_conv)
apply (simp add: leq1 leq2)
apply simp
done
qed
from False lbs have drop_eq: "((drop (size_td d) bs)[i - size_td d := b]) =
(drop (size_td d) (bs[i := b]))"
by (simp add: drop_update_swap)
from False lbs have take_eq: "take (size_td d) (bs[i := b]) = take (size_td d) bs" by simp
note hyp = Cons_typ_desc.hyps(2) [OF wf_desc_fs wf_sz_fs wf_fields_fs wf_comp_fs wf_fd_fs i_bound' lbs_drop padding_fs]
from hyp
show ?thesis by (simp add: x False nth_append lacc drop_eq take_eq)
qed
next
case (DTuple_typ_desc d nm y)
then show ?case by (auto simp add: export_uinfo_def)
qed
lemma is_padding_byte_update_ti_id:
assumes wf: "wf_desc (t::'a xtyp_info)"
and wf_sz: "wf_size_desc t"
and wf_descs: "wf_field_descs (set (field_descs t))"
and wf_comp: "wf_component_descs t"
and wf_fd: "wf_fd t"
and i_bound: "i < size_td t"
and lbs: "length bs = size_td t"
and is_padding: "is_padding_byte (export_uinfo t) i"
shows "update_ti t (bs[i := b]) v = update_ti t bs v"
using is_padding_byte_update_ti_id'(1) [OF wf wf_sz wf_descs wf_comp wf_fd i_bound lbs] is_padding
by (simp add: is_padding_byte_def export_uinfo_def)
context xmem_type
begin
lemma xmem_type_is_padding_byte_update_ti_id:
assumes padding: "is_padding_byte (typ_uinfo_t TYPE('a)) i"
and i_bound: "i < size_of TYPE('a)"
and lbs: "length bs = size_of TYPE('a)"
shows "update_ti (typ_info_t TYPE('a)) (bs[i:=b]) v = update_ti (typ_info_t TYPE('a)) bs v "
proof -
have wf: "wf_desc (typ_info_t TYPE('a))" by simp
have wf_sz: "wf_size_desc (typ_info_t TYPE('a))" by simp
have wf_descs: "wf_field_descs (set (field_descs (typ_info_t TYPE('a))))"
using local.wf_field_descs by blast
have wf_comp: "wf_component_descs (typ_info_t TYPE('a))"
by (simp add: local.wf_component_descs)
have wf_fd: "wf_fd (typ_info_t TYPE('a))"
using local.wf_desc local.wf_lf wf_fdp_fd(1) wf_lf_fdp by blast
from is_padding_byte_update_ti_id [OF wf wf_sz wf_descs wf_comp wf_fd
i_bound [simplified size_of_def] lbs [simplified size_of_def]
padding [simplified typ_uinfo_t_def]]
show ?thesis .
qed
end
lemma heap_update_fold:
"sz = size_of TYPE('a) ⟹
heap_update_list a (to_bytes (v::'a:: c_type) (heap_list h sz a)) h = heap_update (Ptr a) v h"
by (simp add:heap_update_def)
lemma heap_update_padding_fold:
"sz = size_of TYPE('a) ⟹
heap_update_list a (to_bytes (v::'a:: c_type) bs) h = heap_update_padding (Ptr a) v bs h"
by (simp add:heap_update_padding_def)
context padding_base
begin
thm is_padding_byte_def
thm is_value_byte_def
end
lemma is_value_byte_access_ti_id':
fixes t::"'a xtyp_info"
and st::"'a xtyp_info_struct"
and ts::"'a xtyp_info_tuple list"
and x::"'a xtyp_info_tuple"
shows
"⟦ wf_desc t; wf_size_desc t; wf_field_descs (set (field_descs t)); wf_component_descs t; wf_fd t;
i < size_td t; length bs = size_td t;
∃bs b. length bs = size_td t ∧ norm_tu (map_td field_norm (λ_. ()) t) (bs[i := b]) ≠ norm_tu (export_uinfo t) bs⟧
⟹ access_ti t v (bs[i := b]) = access_ti t v bs"
"⟦ wf_desc_struct st; wf_size_desc_struct st; wf_field_descs (set (field_descs_struct st));
wf_component_descs_struct st; wf_fd_struct st; i < size_td_struct st; length bs = size_td_struct st;
∃bs b. length bs = size_td_struct st ∧ norm_tu_struct (map_td_struct field_norm (λ_. ()) st) (bs[i := b]) ≠ norm_tu_struct ((map_td_struct field_norm (λ_. ()) st)) bs⟧
⟹ access_ti_struct st v (bs[i := b]) = access_ti_struct st v bs"
"⟦ wf_desc_list ts; wf_size_desc_list ts; wf_field_descs (set (field_descs_list ts));
wf_component_descs_list ts; wf_fd_list ts; i < size_td_list ts; length bs = size_td_list ts;
∃bs b. length bs = size_td_list ts ∧ norm_tu_list (map_td_list field_norm (λ_. ()) ts) (bs[i := b]) ≠ norm_tu_list ((map_td_list field_norm (λ_. ()) ts)) bs⟧
⟹ access_ti_list ts v (bs[i := b]) = access_ti_list ts v bs"
"⟦ wf_desc_tuple x; wf_size_desc_tuple x; wf_field_descs (set (field_descs_tuple x));
wf_component_descs_tuple x; wf_fd_tuple x; i < size_td_tuple x; length bs = size_td_tuple x;
∃bs b. length bs = size_td_tuple x ∧ norm_tu_tuple (map_td_tuple field_norm (λ_. ()) x) (bs[i := b]) ≠ norm_tu_tuple ((map_td_tuple field_norm (λ_. ()) x)) bs⟧
⟹ access_ti_tuple x v (bs[i := b]) = access_ti_tuple x v bs"
proof (induct t and st and ts and x arbitrary: bs i and bs i and bs i and bs i )
case (TypDesc algn st nm)
then show ?case by auto
next
case (TypScalar sz algn d)
from TypScalar obtain
wf_d: "wf_field_desc d" and
field_sz: "field_sz d =sz" and
i_bound: "i < sz" and
lbs: "length bs = sz" and
is_val: "∃bs b. length bs = sz ∧
field_norm sz algn d (bs[i := b]) ≠ field_norm sz algn d bs"
by simp
interpret wf: wf_field_desc d by (rule wf_d)
show ?case
proof (cases "wf.is_padding_byte i")
case True
then show ?thesis
using field_sz lbs wf.is_padding_byte_upd_eq
by (metis field_norm_def length_list_update is_val)
next
case False
note not_padding = this
with wf.complement field_sz i_bound have is_value: "wf.is_value_byte i" by blast
from is_value is_val
show ?thesis
apply simp
by (metis field_sz lbs padding_base.is_value_byte_acc_eq)
qed
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
obtain d nm y where x: "x = DTuple d nm y" by (cases x) auto
from Cons_typ_desc.prems obtain
wf_desc_d: "wf_desc d" and
wf_fd_x: "wf_fd_tuple (DTuple d nm y)" and
wf_fd_d: "wf_fd d" and
wf_fd_fs: "wf_fd_list fs" and
nm_notin: "nm ∉ dt_snd ` set fs" and
wf_desc_fs: "wf_desc_list fs" and
wf_sz_d: "wf_size_desc d" and
wf_sz_fs: "wf_size_desc_list fs" and
wf_field_d: "wf_field_desc (component_desc d)" and
wf_fields_d: "wf_field_descs (set (field_descs d))" and
wf_fields_fs: "wf_field_descs (set (field_descs_list fs))" and
y: "y = component_desc d" and
wf_comp_d: "wf_component_descs d" and
wf_comp_fs: "wf_component_descs_list fs" and
i_bound:"i < size_td d + size_td_list fs" and
lbs: "length bs = size_td d + size_td_list fs" and
wf_desc_x: "wf_desc_tuple x" and
wf_sz_x: "wf_size_desc_tuple x" and
wf_decs_x: "wf_field_descs (set (field_descs_tuple x))" and
wf_comp_x: "wf_component_descs_tuple x" and
is_value: "∃bs b. length bs = size_td d + size_td_list fs ∧
norm_tu (map_td field_norm (λ_. ()) d)
(take (size_td d) (bs[i := b])) @
norm_tu_list (map_td_list field_norm (λ_. ()) fs)
(drop (size_td d) (bs[i := b])) ≠
norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) bs) @
norm_tu_list (map_td_list field_norm (λ_. ()) fs)
(drop (size_td d) bs)"
by (auto simp add: x)
from is_value obtain xbs xb where
lxbs: "length xbs = size_td d + size_td_list fs" and
norm_neq: "norm_tu (map_td field_norm (λ_. ()) d)
(take (size_td d) (xbs[i := xb])) @
norm_tu_list (map_td_list field_norm (λ_. ()) fs)
(drop (size_td d) (xbs[i := xb])) ≠
norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) xbs) @
norm_tu_list (map_td_list field_norm (λ_. ()) fs)
(drop (size_td d) xbs)"
by blast
from lxbs have l_take1: "length (take (size_td d) (xbs[i := xb])) = size_td d"
by simp
from wf_fd_norm_tu(1)[rule_format, OF wf_fd_d l_take1]
have l_norm_upd_d: "length (norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) (xbs[i := xb]))) = size_td d"
by (metis access_ti⇩0_def export_uinfo_def fd_cons_length_p wf_fd_consD wf_fd_d)
from lxbs have l_take2: "length (take (size_td d) (xbs)) = size_td d"
by simp
from wf_fd_norm_tu(1)[rule_format, OF wf_fd_d l_take2]
have l_norm_d: "length (norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) xbs)) = size_td d"
by (metis access_ti⇩0_def export_uinfo_def fd_cons_length_p wf_fd_consD wf_fd_d)
from lbs
have lbs_drop: "length (drop (size_td d) bs) = size_td_list fs"
by (simp add: x)
from lbs
have lbs_take: "length (take (size_td d) bs) = size_td d"
by (simp add: x)
have lacc: "length (access_ti d v (take (size_td d) bs)) = size_td d"
by (metis lbs_take length_fa_ti size_td_tuple.simps wf_fd_tuple.simps wf_fd_x x)
show ?case
proof (cases "i < size_td d")
case True
from True lbs
have take_eq: "(take (size_td d) bs)[i := b] = take (size_td d) (bs[i := b])"
by (simp add: take_update_swap)
from True
have drop_eq: "drop (size_td d) (xbs[i := xb]) = drop (size_td d) xbs"
by simp
from lxbs True
have take_xbs_eq: "(take (size_td d) (xbs[i := xb])) = (take (size_td d) xbs)[i := xb]"
by (simp add: take_update_swap)
from norm_neq
have "norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) (xbs[i := xb])) ≠
norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) xbs)"
by (simp add: drop_eq)
with take_xbs_eq
have value_d: "∃bs. length bs = size_td d ∧
(∃b. norm_tu (map_td field_norm (λ_. ()) d) (bs[i := b]) ≠
norm_tu (map_td field_norm (λ_. ()) d) bs)"
apply simp
using l_take2 by blast
note hyp = Cons_typ_desc.hyps(1) [OF wf_desc_x wf_sz_x wf_decs_x wf_comp_x, simplified x, OF wf_fd_x, simplified, OF True lbs_take value_d]
from hyp lbs
show ?thesis
by (simp add: x True nth_append lacc take_eq)
next
case False
from False i_bound have i_bound': "i - size_td d < size_td_list fs" by simp
from False lxbs
have take_xbs: "take (size_td d) (xbs[i := xb]) = take (size_td d) xbs" by simp
from norm_neq
have "norm_tu_list (map_td_list field_norm (λ_. ()) fs) (drop (size_td d) (xbs[i := xb])) ≠
norm_tu_list (map_td_list field_norm (λ_. ()) fs) (drop (size_td d) xbs)"
by (simp add: take_xbs)
then
have value_fs: "∃bs b.
length bs = size_td_list fs ∧
norm_tu_list (map_td_list field_norm (λ_. ()) fs) (bs[i - size_td d := b]) ≠
norm_tu_list (map_td_list field_norm (λ_. ()) fs) bs"
by (metis False drop_update_swap lbs lbs_drop length_drop lxbs not_le)
from False lbs have drop_eq: "((drop (size_td d) bs)[i - size_td d := b]) =
(drop (size_td d) (bs[i := b]))"
by (simp add: drop_update_swap)
from False lbs have take_eq: "take (size_td d) (bs[i := b]) = take (size_td d) bs" by simp
note hyp = Cons_typ_desc.hyps(2) [OF wf_desc_fs wf_sz_fs wf_fields_fs wf_comp_fs wf_fd_fs i_bound' lbs_drop value_fs]
from hyp
show ?thesis by (simp add: x False nth_append lacc drop_eq take_eq)
qed
next
case (DTuple_typ_desc d nm y)
then show ?case by (auto simp add: export_uinfo_def)
qed
lemma is_value_byte_access_ti_id:
assumes wf: "wf_desc t"
assumes wf_sz: "wf_size_desc t"
assumes wf_descs: "wf_field_descs (set (field_descs t))"
assumes wf_comps: "wf_component_descs t"
assumes wf_fd: "wf_fd t"
assumes i_bound: "i < size_td t"
assumes lbs: "length bs = size_td t"
assumes is_value: "is_value_byte (export_uinfo t) i"
shows "access_ti t v (bs[i := b]) = access_ti t v bs"
using is_value_byte_access_ti_id'(1)[OF wf wf_sz wf_descs wf_comps wf_fd i_bound lbs, where v=v and b=b ] is_value
by (simp add: is_value_byte_def export_uinfo_def)
lemma is_value_byte_access_ti_update_ti_cancel':
fixes t::"'a xtyp_info"
and st::"'a xtyp_info_struct"
and ts::"'a xtyp_info_tuple list"
and x::"'a xtyp_info_tuple"
shows
"⟦ wf_desc t; wf_size_desc t; wf_field_descs (set (field_descs t)); wf_component_descs t; wf_fd t;
i < size_td t; length bs = size_td t; length bs' = size_td t;
∃bs b. length bs = size_td t ∧ norm_tu (map_td field_norm (λ_. ()) t) (bs[i := b]) ≠ norm_tu (export_uinfo t) bs⟧
⟹ access_ti t (update_ti t bs v) bs' ! i = bs ! i"
"⟦ wf_desc_struct st; wf_size_desc_struct st; wf_field_descs (set (field_descs_struct st));
wf_component_descs_struct st; wf_fd_struct st; i < size_td_struct st; length bs = size_td_struct st; length bs' = size_td_struct st;
∃bs b. length bs = size_td_struct st ∧ norm_tu_struct (map_td_struct field_norm (λ_. ()) st) (bs[i := b]) ≠ norm_tu_struct ((map_td_struct field_norm (λ_. ()) st)) bs⟧
⟹ access_ti_struct st (update_ti_struct st bs v) bs' ! i = bs ! i"
"⟦ wf_desc_list ts; wf_size_desc_list ts; wf_field_descs (set (field_descs_list ts));
wf_component_descs_list ts; wf_fd_list ts; i < size_td_list ts; length bs = size_td_list ts; length bs' = size_td_list ts;
∃bs b. length bs = size_td_list ts ∧ norm_tu_list (map_td_list field_norm (λ_. ()) ts) (bs[i := b]) ≠ norm_tu_list ((map_td_list field_norm (λ_. ()) ts)) bs⟧
⟹ access_ti_list ts (update_ti_list ts bs v) bs' ! i = bs ! i"
"⟦ wf_desc_tuple x; wf_size_desc_tuple x; wf_field_descs (set (field_descs_tuple x));
wf_component_descs_tuple x; wf_fd_tuple x; i < size_td_tuple x; length bs = size_td_tuple x; length bs' = size_td_tuple x;
∃bs b. length bs = size_td_tuple x ∧ norm_tu_tuple (map_td_tuple field_norm (λ_. ()) x) (bs[i := b]) ≠ norm_tu_tuple ((map_td_tuple field_norm (λ_. ()) x)) bs⟧
⟹ access_ti_tuple x (update_ti_tuple x bs v) bs' ! i = bs ! i"
proof (induct t and st and ts and x arbitrary: bs bs' i v and bs bs' i v and bs bs' i v and bs bs' i v )
case (TypDesc algn st nm)
then show ?case by auto
next
case (TypScalar sz algn d)
from TypScalar obtain
wf_d: "wf_field_desc d" and
field_sz: "field_sz d =sz" and
i_bound: "i < sz" and
lbs: "length bs = sz" and
lbs': "length bs' = sz" and
is_val: "∃bs b. length bs = sz ∧
field_norm sz algn d (bs[i := b]) ≠ field_norm sz algn d bs"
by simp
interpret wf: wf_field_desc d by (rule wf_d)
show ?case
proof (cases "wf.is_padding_byte i")
case True
then show ?thesis
using field_sz lbs wf.is_padding_byte_upd_eq
by (metis field_norm_def length_list_update is_val)
next
case False
note not_padding = this
with wf.complement field_sz i_bound have is_value: "wf.is_value_byte i" by blast
from is_value is_val lbs'
show ?thesis
by (simp add: field_sz lbs wf.is_value_byte_acc_upd_cancel)
qed
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
obtain d nm y where x: "x = DTuple d nm y" by (cases x) auto
from Cons_typ_desc.prems obtain
wf_desc_d: "wf_desc d" and
wf_fd_x: "wf_fd_tuple (DTuple d nm y)" and
wf_fd_d: "wf_fd d" and
wf_fd_fs: "wf_fd_list fs" and
nm_notin: "nm ∉ dt_snd ` set fs" and
wf_desc_fs: "wf_desc_list fs" and
wf_sz_d: "wf_size_desc d" and
wf_sz_fs: "wf_size_desc_list fs" and
wf_field_d: "wf_field_desc (component_desc d)" and
wf_fields_d: "wf_field_descs (set (field_descs d))" and
wf_fields_fs: "wf_field_descs (set (field_descs_list fs))" and
y: "y = component_desc d" and
wf_comp_d: "wf_component_descs d" and
wf_comp_fs: "wf_component_descs_list fs" and
i_bound:"i < size_td d + size_td_list fs" and
lbs: "length bs = size_td d + size_td_list fs" and
lbs': "length bs' = size_td d + size_td_list fs" and
wf_desc_x: "wf_desc_tuple x" and
wf_sz_x: "wf_size_desc_tuple x" and
wf_decs_x: "wf_field_descs (set (field_descs_tuple x))" and
wf_comp_x: "wf_component_descs_tuple x" and
is_value: "∃bs b. length bs = size_td d + size_td_list fs ∧
norm_tu (map_td field_norm (λ_. ()) d)
(take (size_td d) (bs[i := b])) @
norm_tu_list (map_td_list field_norm (λ_. ()) fs)
(drop (size_td d) (bs[i := b])) ≠
norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) bs) @
norm_tu_list (map_td_list field_norm (λ_. ()) fs)
(drop (size_td d) bs)" and
commutes: "fu_commutes (update_ti_t d) (update_ti_list_t fs)"
by (auto simp add: x)
from is_value obtain xbs xb where
lxbs: "length xbs = size_td d + size_td_list fs" and
norm_neq: "norm_tu (map_td field_norm (λ_. ()) d)
(take (size_td d) (xbs[i := xb])) @
norm_tu_list (map_td_list field_norm (λ_. ()) fs)
(drop (size_td d) (xbs[i := xb])) ≠
norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) xbs) @
norm_tu_list (map_td_list field_norm (λ_. ()) fs)
(drop (size_td d) xbs)"
by blast
from lxbs have l_take1: "length (take (size_td d) (xbs[i := xb])) = size_td d"
by simp
from wf_fd_norm_tu(1)[rule_format, OF wf_fd_d l_take1]
have l_norm_upd_d: "length (norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) (xbs[i := xb]))) = size_td d"
by (metis access_ti⇩0_def export_uinfo_def fd_cons_length_p wf_fd_consD wf_fd_d)
from lxbs have l_take2: "length (take (size_td d) (xbs)) = size_td d"
by simp
from wf_fd_norm_tu(1)[rule_format, OF wf_fd_d l_take2]
have l_norm_d: "length (norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) xbs)) = size_td d"
by (metis access_ti⇩0_def export_uinfo_def fd_cons_length_p wf_fd_consD wf_fd_d)
from lbs
have lbs_drop: "length (drop (size_td d) bs) = size_td_list fs"
by (simp add: x)
from lbs'
have lbs'_drop: "length (drop (size_td d) bs') = size_td_list fs"
by (simp add: x)
from lbs
have lbs_take: "length (take (size_td d) bs) = size_td d"
by (simp add: x)
from lbs'
have lbs'_take: "length (take (size_td d) bs') = size_td d"
by (simp add: x)
have lacc: "length (access_ti d v (take (size_td d) bs)) = size_td d"
by (metis lbs_take length_fa_ti size_td_tuple.simps wf_fd_tuple.simps wf_fd_x x)
from lbs lbs'_take
have l_acc_upd:
"length (access_ti d (update_ti d (take (size_td d) bs)
(update_ti_list fs (drop (size_td d) bs) v)) (take (size_td d) bs')) = size_td d"
by (meson length_fa_ti wf_fd_d)
show ?case
proof (cases "i < size_td d")
case True
from True lbs
have take_eq: "(take (size_td d) bs)[i := b] = take (size_td d) (bs[i := b])"
by (simp add: take_update_swap)
from True
have drop_eq: "drop (size_td d) (xbs[i := xb]) = drop (size_td d) xbs"
by simp
from lxbs True
have take_xbs_eq: "(take (size_td d) (xbs[i := xb])) = (take (size_td d) xbs)[i := xb]"
by (simp add: take_update_swap)
from norm_neq
have "norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) (xbs[i := xb])) ≠
norm_tu (map_td field_norm (λ_. ()) d) (take (size_td d) xbs)"
by (simp add: drop_eq)
with take_xbs_eq
have value_d: "∃bs. length bs = size_td d ∧
(∃b. norm_tu (map_td field_norm (λ_. ()) d) (bs[i := b]) ≠
norm_tu (map_td field_norm (λ_. ()) d) bs)"
apply simp
using l_take2 by blast
note hyp = Cons_typ_desc.hyps(1) [OF wf_desc_x wf_sz_x wf_decs_x wf_comp_x, simplified x, OF wf_fd_x, simplified,
OF True lbs_take lbs'_take value_d, where v = "(update_ti_list fs (drop (size_td d) bs) v)"]
from lbs lbs'
show ?thesis
by (simp add: x True nth_append lacc take_eq l_acc_upd hyp)
next
case False
from False i_bound have i_bound': "i - size_td d < size_td_list fs" by simp
from False lxbs
have take_xbs: "take (size_td d) (xbs[i := xb]) = take (size_td d) xbs" by simp
from norm_neq
have "norm_tu_list (map_td_list field_norm (λ_. ()) fs) (drop (size_td d) (xbs[i := xb])) ≠
norm_tu_list (map_td_list field_norm (λ_. ()) fs) (drop (size_td d) xbs)"
by (simp add: take_xbs)
then
have value_fs: "∃bs b.
length bs = size_td_list fs ∧
norm_tu_list (map_td_list field_norm (λ_. ()) fs) (bs[i - size_td d := b]) ≠
norm_tu_list (map_td_list field_norm (λ_. ()) fs) bs"
by (metis False drop_update_swap lbs lbs_drop length_drop lxbs not_le)
from commutes have commute:
"(update_ti d (take (size_td d) bs)
(update_ti_list fs (drop (size_td d) bs) v)) =
(update_ti_list fs (drop (size_td d) bs) (update_ti d (take (size_td d) bs) v))"
apply (simp add: update_ti_t_def update_ti_list_t_def fu_commutes_def)
apply (erule allE [where x=v])
apply (erule allE [where x="(take (size_td d) bs)"])
apply (erule allE [where x="(drop (size_td d) bs)"])
using lbs_take lbs_drop
apply simp
done
from False lbs have drop_eq: "drop (size_td d) bs ! (i - size_td d) = bs ! i"
by (simp add: drop_update_swap)
note hyp = Cons_typ_desc.hyps(2) [OF wf_desc_fs wf_sz_fs wf_fields_fs wf_comp_fs wf_fd_fs i_bound' lbs_drop lbs'_drop value_fs]
from hyp
show ?thesis
apply (simp add: x False nth_append lacc drop_eq l_acc_upd)
apply (simp add: commute)
done
qed
next
case (DTuple_typ_desc d nm y)
then show ?case by (auto simp add: export_uinfo_def)
qed
lemma is_value_byte_access_ti_update_ti_cancel:
assumes wf: "wf_desc t"
assumes wf_sz: "wf_size_desc t"
assumes wf_descs: "wf_field_descs (set (field_descs t))"
assumes wf_comps: "wf_component_descs t"
assumes wf_fd: "wf_fd t"
assumes i_bound: "i < size_td t"
assumes lbs: "length bs = size_td t"
assumes lbs': "length bs'= size_td t"
assumes is_value: "is_value_byte (export_uinfo t) i"
shows "access_ti t (update_ti t bs v) bs' ! i = bs ! i"
using is_value_byte_access_ti_update_ti_cancel'(1) [OF wf wf_sz wf_descs wf_comps wf_fd i_bound lbs lbs'] is_value
by (simp add: export_uinfo_def is_value_byte_def)
lemma field_lookup_is_padding_byte_focus':
fixes t::"('a, 'b) typ_info"
and st::"('a, 'b) typ_info_struct"
and ts::"('a, 'b) typ_info_tuple list"
and x::"('a, 'b) typ_info_tuple"
shows
"⟦field_lookup t f m = Some (s, m + n); n ≤ i; i < n + size_td s; length bs = size_td t;
wf_desc t; wf_size_desc t⟧ ⟹
norm_tu (map_td field_norm (λ_. ()) t) (bs[i := b]) = norm_tu (map_td field_norm (λ_. ()) t) bs
⟷
norm_tu (export_uinfo s) ((take (size_td s) (drop n bs))[i - n := b]) =
norm_tu (export_uinfo s) (take (size_td s) (drop n bs))"
"⟦field_lookup_struct st f m = Some (s, m + n); n ≤ i; i < n + size_td s; length bs = size_td_struct st;
wf_desc_struct st; wf_size_desc_struct st⟧ ⟹
norm_tu_struct (map_td_struct field_norm (λ_. ()) st) (bs[i := b]) = norm_tu_struct (map_td_struct field_norm (λ_. ()) st) bs
⟷
norm_tu (export_uinfo s) ((take (size_td s) (drop n bs))[i - n := b]) =
norm_tu (export_uinfo s) (take (size_td s) (drop n bs))"
"⟦field_lookup_list ts f m = Some (s, m + n); n ≤ i; i < n + size_td s; length bs = size_td_list ts;
wf_desc_list ts; wf_size_desc_list ts⟧ ⟹
norm_tu_list (map_td_list field_norm (λ_. ()) ts) (bs[i := b]) = norm_tu_list (map_td_list field_norm (λ_. ()) ts) bs
⟷
norm_tu (export_uinfo s) ((take (size_td s) (drop n bs))[i - n := b]) =
norm_tu (export_uinfo s) (take (size_td s) (drop n bs))"
"⟦field_lookup_tuple x f m = Some (s, m + n); n ≤ i; i < n + size_td s; length bs = size_td_tuple x;
wf_desc_tuple x; wf_size_desc_tuple x⟧ ⟹
norm_tu_tuple (map_td_tuple field_norm (λ_. ()) x) (bs[i := b]) = norm_tu_tuple (map_td_tuple field_norm (λ_. ()) x) bs
⟷
norm_tu (export_uinfo s) ((take (size_td s) (drop n bs))[i - n := b]) =
norm_tu (export_uinfo s) (take (size_td s) (drop n bs))"
proof (induct t and st and ts and x arbitrary: f m n i s bs and f m n i s bs and f m n i s bs and f m n i s bs)
case (TypDesc algn st nm)
then show ?case by (auto split: if_split_asm)
next
case (TypScalar sz algn d)
then show ?case by auto
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
obtain d nm y where x: "x = DTuple d nm y" by (cases x) auto
from Cons_typ_desc.prems obtain
lbs: "length bs = size_td_tuple x + size_td_list fs" and
wf_desc_x: "wf_desc_tuple (DTuple d nm y)" and
wf_size_desc_x: "wf_size_desc_tuple (DTuple d nm y)" and
wf_size_desc_fs: "wf_size_desc_list fs" and
nm_notin: "nm ∉ dt_snd ` set fs" and
wf_desc_fs: "wf_desc_list fs" and
i_lower: "n ≤ i" and
i_upper: "i < n + size_td s"
by (auto simp add: x)
from lbs
have lbs_drop: "length (drop (size_td_tuple x) bs) = size_td_list fs"
by simp
from lbs
have lbs_take: "length (take (size_td_tuple x) bs) = size_td_tuple (DTuple d nm y)"
by (simp add: x)
from lbs_take
have take_eq1: "((take (size_td d) bs)[i := b]) = (take (size_td d) (bs[i := b]))"
by (simp add: take_update_swap)
from Cons_typ_desc.prems obtain f1 fxs
where f: "f = f1#fxs"
by (cases f) auto
thm Cons_typ_desc.hyps [simplified x]
show ?case
proof (cases "f1 = nm")
case True
show ?thesis
proof (cases "field_lookup d fxs m")
case None
from Cons_typ_desc.prems field_lookup_list_None [OF nm_notin]
have False
by (simp add: True None f x)
thus ?thesis by simp
next
case (Some r)
from Cons_typ_desc.prems have r: "r = (s, m + n)"
by (simp add: x True Some f)
hence fl: "field_lookup_tuple (DTuple d nm y) f m = Some (s, m + n)"
by (simp add: f True Some r)
from td_set_wf_size_desc(4)[OF wf_size_desc_x td_set_tuple_field_lookup_tupleD, OF fl]
have "wf_size_desc s" .
from wf_size_desc_gt(1)[OF this]
have "0 < size_td s" .
with td_set_tuple_offset_size_m [OF td_set_tuple_field_lookup_tupleD, OF fl]
have n_le: "n < size_td d"
by auto
have i_in_d: "i < size_td d"
using ‹size_td s + (m + n - m) ≤ size_td_tuple (DTuple d nm y)› i_upper by auto
have bound: "size_td s + (m + n - m) ≤ size_td_tuple (DTuple d nm y)" by fact
from bound
have take_eq: "(take (size_td s) (drop n (take (size_td d) bs))) =
(take (size_td s) (drop n bs))"
by (simp add: take_drop)
from Cons_typ_desc.hyps(1)[simplified x, OF fl i_lower i_upper lbs_take wf_desc_x wf_size_desc_x] lbs bound
show ?thesis
by (simp add: x True Some r take_eq nth_append i_in_d take_eq1)
qed
next
case False
with Cons_typ_desc.prems
have fl: "field_lookup_list fs (f1 # fxs) (m + size_td d) = Some (s, m + n)"
by (clarsimp simp add: x f False)
hence n_bound: "size_td d ≤ n"
by (meson field_lookup_offset_le(3) nat_add_left_cancel_le)
from fl
have fl: "field_lookup_list fs (f1 # fxs) (m + size_td d) = Some (s, (m + size_td d) + (n - size_td d))"
by (metis Nat.diff_cancel field_lookup_list_offset2 field_lookup_list_offsetD)
from n_bound
have take_eq: "(take (size_td s) (drop (n - size_td d + size_td d) bs)) =
(take (size_td s) (drop n bs))"
by simp
have i_lower': "n - size_td d ≤ i - size_td d"
using diff_le_mono i_lower by blast
have i_upper': "i - size_td d < n - size_td d + size_td s"
using i_lower i_upper by linarith
have i_notin_d: "¬ i < size_td d"
by (meson i_lower leD less_le_trans n_bound)
from i_notin_d lbs_take have take_eq: "take (size_td d) (bs[i := b]) = take (size_td d) bs"
by simp
from i_notin_d lbs i_upper not_le have drop_eq:
"((drop (size_td d) bs)[i - size_td d := b]) = (drop (size_td d) (bs[i := b]))"
by (simp add: drop_update_swap)
from Cons_typ_desc.hyps(2) [OF fl i_lower' i_upper' lbs_drop wf_desc_fs wf_size_desc_fs]
False n_bound
show ?thesis
by (simp add: x f nth_append i_notin_d take_eq drop_eq)
qed
next
case (DTuple_typ_desc d nm y)
then show ?case apply (cases f) by (auto split: if_split_asm)
qed
lemma field_lookup_is_padding_byte_focus:
assumes fl: "field_lookup t f 0 = Some (s, n)"
assumes i_lower: "n ≤ i"
assumes i_upper :"i < n + size_td s"
assumes wf: "wf_desc t"
assumes wf_sz: "wf_size_desc t"
shows "is_padding_byte (export_uinfo t) i = is_padding_byte (export_uinfo s) (i - n)"
proof
assume is_padding: "is_padding_byte (export_uinfo t) i"
show "is_padding_byte (export_uinfo s) (i - n)"
apply (simp add: is_padding_byte_def, safe)
proof -
from i_upper i_lower show "i - n < size_td s" by simp
next
fix bs::"byte list" and b::byte
assume lbs: "length bs = size_td s"
from fl have le: "n + size_td s ≤ size_td t"
by (metis add.commute field_lookup_offset_size')
with lbs i_lower i_upper obtain pfx sfx xbs where
xbs: "xbs = pfx @ bs @ sfx" and
lxbs: "length xbs = size_td t" and
lpfx: "length pfx = n"
by (metis Ex_list_of_length ab_semigroup_add_class.add_ac(1) le_Suc_ex length_append)
have take_eq: "take (size_td s) (drop n xbs) = bs"
using xbs lxbs lbs lpfx le
by simp
from field_lookup_is_padding_byte_focus'(1) [where m = 0, simplified, OF fl i_lower i_upper lxbs wf wf_sz, where b=b]
is_padding lxbs
show "norm_tu (export_uinfo s) (bs[i - n := b]) =
norm_tu (export_uinfo s) bs"
by (simp add: take_eq export_uinfo_def is_padding_byte_def)
qed
next
assume is_padding: "is_padding_byte (export_uinfo s) (i - n)"
from fl i_upper i_lower
have i_t: "i < size_td t"
using field_lookup_offset_size' by fastforce
show "is_padding_byte (export_uinfo t) i"
apply (simp add: is_padding_byte_def, safe)
proof -
from i_t
show sz: "i < size_td t" .
next
fix bs::"byte list" and b::byte
assume lbs: "length bs = size_td t"
from fl i_upper i_lower i_t
have less: "i - n < size_td t"
by simp
from less lbs i_lower i_upper i_t
have sz_s: "size_td s ≤ length (drop n bs)"
by (metis add_le_imp_le_diff field_lookup_offset_size' fl length_drop)
from field_lookup_is_padding_byte_focus'(1) [where m = 0, simplified, OF fl i_lower i_upper lbs wf wf_sz, where b=b]
is_padding sz_s
show "norm_tu (export_uinfo t) (bs[i := b]) =
norm_tu (export_uinfo t) bs"
by (auto simp add: is_padding_byte_def export_uinfo_def)
qed
qed
lemma field_lookup_is_value_byte_focus:
assumes fl: "field_lookup t f 0 = Some (s, n)"
assumes i_lower: "n ≤ i"
assumes i_upper :"i < n + size_td s"
assumes wf: "wf_desc t"
assumes wf_sz: "wf_size_desc t"
shows "is_value_byte (export_uinfo t) i = is_value_byte (export_uinfo s) (i - n)"
proof -
from fl i_upper i_lower
have i_t: "i < size_td t"
using field_lookup_offset_size' by fastforce
from i_lower i_upper
have "i - n < size_td s" by simp
with field_lookup_is_padding_byte_focus [OF fl i_lower i_upper wf wf_sz] complement_tu_padding i_t
show ?thesis
by (simp add: export_uinfo_size)
qed
lemma field_lookup_eq_padding_focus:
assumes fl: "field_lookup t f 0 = Some (s, n)"
assumes lbs: "length bs = size_td t"
assumes lbs': "length bs' = size_td t"
assumes wf: "wf_desc t"
assumes wf_sz: "wf_size_desc t"
assumes eq_padding: "eq_padding (export_uinfo t) bs bs'"
shows "eq_padding (export_uinfo s) (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
proof -
from fl lbs have bound_s: "size_td s ≤ length bs - n"
by (metis add.commute add_diff_cancel_left' diff_le_mono field_lookup_offset_size')
from fl lbs' have bound_s': "size_td s ≤ length bs' - n"
by (metis add.commute add_diff_cancel_left' diff_le_mono field_lookup_offset_size')
from bound_s lbs
have l_take: "length (take (size_td s) (drop n bs)) = size_td s"
by simp
from bound_s' lbs'
have l_take': "length (take (size_td s) (drop n bs')) = size_td s"
by simp
show ?thesis
apply (simp add: eq_padding_def, safe)
proof -
show "size_td s ≤ length bs - n" by (rule bound_s)
next
show "size_td s ≤ length bs' - n" by (rule bound_s')
next
fix i assume is_padding: "is_padding_byte (export_uinfo s) i"
from is_padding have i_s: "i < size_td s"
by (simp add: is_padding_byte_def)
have n_i: "n ≤ i + n" by simp
from i_s have i_n_bound: "i + n < n + size_td s" by simp
show "take (size_td s) (drop n bs) ! i =
take (size_td s) (drop n bs') ! i"
using l_take l_take' is_padding eq_padding lbs lbs'
field_lookup_is_padding_byte_focus [OF fl n_i i_n_bound wf wf_sz, simplified]
by (auto simp add: eq_padding_def add.commute is_padding_byte_def)
qed
qed
lemma field_lookup_eq_padding_focus_eq:
assumes fl: "field_lookup t f 0 = Some (s, n)"
assumes lbs: "length bs = size_td t"
assumes lbs': "length bs' = size_td t"
assumes pfx_eq: "⋀i. i < n ⟹ bs ! i = bs' ! i"
assumes sfx_eq: "⋀i. n + size_td s ≤ i ⟹ i < size_td t ⟹ bs ! i = bs' ! i"
assumes wf: "wf_desc t"
assumes wf_sz: "wf_size_desc t"
shows "eq_padding (export_uinfo t) bs bs' =
eq_padding (export_uinfo s) (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
proof -
from fl lbs have bound_s: "size_td s ≤ length bs - n"
by (metis add.commute add_diff_cancel_left' diff_le_mono field_lookup_offset_size')
from fl lbs' have bound_s': "size_td s ≤ length bs' - n"
by (metis add.commute add_diff_cancel_left' diff_le_mono field_lookup_offset_size')
from bound_s lbs
have l_take: "length (take (size_td s) (drop n bs)) = size_td s"
by simp
from bound_s' lbs'
have l_take': "length (take (size_td s) (drop n bs')) = size_td s"
by simp
show ?thesis
proof
assume eq_padding: "eq_padding (export_uinfo t) bs bs'"
show "eq_padding (export_uinfo s) (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
by (rule field_lookup_eq_padding_focus [OF fl lbs lbs' wf wf_sz eq_padding])
next
assume eq_padding: "eq_padding (export_uinfo s) (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
show "eq_padding (export_uinfo t) bs bs'"
apply (simp add: eq_padding_def, safe)
proof -
show "length bs = size_td t" by (rule lbs)
next
show "length bs' = size_td t" by (rule lbs')
next
fix i
assume is_padding: "is_padding_byte (export_uinfo t) i"
from is_padding have i_t: "i < size_td t"
by (simp add: is_padding_byte_def)
show "bs ! i = bs' ! i"
proof (cases "i < n")
case True
with pfx_eq show ?thesis by simp
next
case False
hence i_lower: "n ≤ i" by simp
show ?thesis
proof (cases "i < n + size_td s")
case True
from field_lookup_is_padding_byte_focus [OF fl i_lower True wf wf_sz, simplified]
eq_padding is_padding True i_lower l_take l_take'
show ?thesis
by (auto simp add: eq_padding_def add.commute is_padding_byte_def)
next
case False
with fl i_t have i_t: "i < size_td t" by simp
with sfx_eq i_lower False show ?thesis by simp
qed
qed
qed
qed
qed
lemma field_lookup_eq_padding_super_update_bs:
assumes fl: "field_lookup t f 0 = Some (s, n)"
assumes lxbs: "length xbs = size_td t"
assumes lbs: "length bs = size_td s"
assumes lbs': "length bs' = size_td s"
assumes wf: "wf_desc t"
assumes wf_sz: "wf_size_desc t"
shows "eq_padding (export_uinfo t) (super_update_bs bs xbs n) (super_update_bs bs' xbs n) =
eq_padding (export_uinfo s) bs bs'"
proof -
from lbs lbs' fl
have pfx_eq: "⋀i. i < n ⟹ (super_update_bs bs xbs n) ! i = (super_update_bs bs' xbs n) ! i"
by (metis (no_types, opaque_lifting) add_leD2 assms(2) field_lookup_offset_size'
length_take less_le_trans min_def nth_append super_update_bs_def)
from lbs lbs' fl
have sfx_eq: "⋀i. n + size_td s ≤ i ⟹ i < size_td t ⟹ (super_update_bs bs xbs n) ! i = (super_update_bs bs' xbs n) ! i"
proof -
fix i :: nat
assume a1: "n + size_td s ≤ i"
have "n ≤ size_td t"
by (meson add_leD2 field_lookup_offset_size' fl)
then show "super_update_bs bs xbs n ! i = super_update_bs bs' xbs n ! i"
using a1 lxbs lbs lbs' by (smt (verit) Many_More.nat_min_simps(1) append.assoc
length_append length_take not_less nth_append super_update_bs_def)
qed
from lxbs lbs
have lsuper: "length (super_update_bs bs xbs n) = size_td t"
by (metis add.commute field_lookup_offset_size' fl length_super_update_bs)
from lxbs lbs'
have lsuper': "length (super_update_bs bs' xbs n) = size_td t"
by (metis add.commute field_lookup_offset_size' fl length_super_update_bs)
from lxbs lbs lsuper
have bs: "(take (size_td s) (drop n (super_update_bs bs xbs n))) = bs"
by (metis (no_types, lifting) append_take_drop_id append_eq_conv_conj
append_take_drop_id length_take super_update_bs_def)
from lxbs lbs' lsuper'
have bs': "(take (size_td s) (drop n (super_update_bs bs' xbs n))) = bs'"
by (metis (no_types, lifting) append_take_drop_id append_eq_conv_conj
append_take_drop_id length_take super_update_bs_def)
from field_lookup_eq_padding_focus_eq [OF fl lsuper lsuper' pfx_eq sfx_eq wf wf_sz]
show ?thesis
by (simp add: bs bs')
qed
lemma field_lookup_eq_upto_padding_focus:
assumes fl: "field_lookup t f 0 = Some (s, n)"
assumes lbs: "length bs = size_td t"
assumes lbs': "length bs' = size_td t"
assumes wf: "wf_desc t"
assumes wf_sz: "wf_size_desc t"
assumes eq_upto_padding: "eq_upto_padding (export_uinfo t) bs bs'"
shows "eq_upto_padding (export_uinfo s) (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
proof -
from fl lbs have bound_s: "size_td s ≤ length bs - n"
by (metis add.commute add_diff_cancel_left' diff_le_mono field_lookup_offset_size')
from fl lbs' have bound_s': "size_td s ≤ length bs' - n"
by (metis add.commute add_diff_cancel_left' diff_le_mono field_lookup_offset_size')
from bound_s lbs
have l_take: "length (take (size_td s) (drop n bs)) = size_td s"
by simp
from bound_s' lbs'
have l_take': "length (take (size_td s) (drop n bs')) = size_td s"
by simp
show ?thesis
apply (simp add: eq_upto_padding_def, safe)
proof -
show "size_td s ≤ length bs - n" by (rule bound_s)
next
show "size_td s ≤ length bs' - n" by (rule bound_s')
next
fix i assume is_value: "is_value_byte (export_uinfo s) i"
from is_value have i_s: "i < size_td s"
by (simp add: is_value_byte_def)
have n_i: "n ≤ i + n" by simp
from i_s have i_n_bound: "i + n < n + size_td s" by simp
show "take (size_td s) (drop n bs) ! i =
take (size_td s) (drop n bs') ! i"
using l_take l_take' is_value eq_upto_padding lbs lbs'
field_lookup_is_value_byte_focus [OF fl n_i i_n_bound wf wf_sz, simplified]
by (auto simp add: eq_upto_padding_def add.commute is_value_byte_def)
qed
qed
lemma field_lookup_eq_upto_padding_focus_eq:
assumes fl: "field_lookup t f 0 = Some (s, n)"
assumes lbs: "length bs = size_td t"
assumes lbs': "length bs' = size_td t"
assumes pfx_eq: "⋀i. i < n ⟹ bs ! i = bs' ! i"
assumes sfx_eq: "⋀i. n + size_td s ≤ i ⟹ i < size_td t ⟹ bs ! i = bs' ! i"
assumes wf: "wf_desc t"
assumes wf_sz: "wf_size_desc t"
shows "eq_upto_padding (export_uinfo t) bs bs' =
eq_upto_padding (export_uinfo s) (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
proof -
from fl lbs have bound_s: "size_td s ≤ length bs - n"
by (metis add.commute add_diff_cancel_left' diff_le_mono field_lookup_offset_size')
from fl lbs' have bound_s': "size_td s ≤ length bs' - n"
by (metis add.commute add_diff_cancel_left' diff_le_mono field_lookup_offset_size')
from bound_s lbs
have l_take: "length (take (size_td s) (drop n bs)) = size_td s"
by simp
from bound_s' lbs'
have l_take': "length (take (size_td s) (drop n bs')) = size_td s"
by simp
show ?thesis
proof
assume eq_upto_padding: "eq_upto_padding (export_uinfo t) bs bs'"
show "eq_upto_padding (export_uinfo s) (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
by (rule field_lookup_eq_upto_padding_focus [OF fl lbs lbs' wf wf_sz eq_upto_padding])
next
assume eq_upto_padding: "eq_upto_padding (export_uinfo s) (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
show "eq_upto_padding (export_uinfo t) bs bs'"
apply (simp add: eq_upto_padding_def, safe)
proof -
show "length bs = size_td t" by (rule lbs)
next
show "length bs' = size_td t" by (rule lbs')
next
fix i
assume is_value: "is_value_byte (export_uinfo t) i"
from is_value have i_t: "i < size_td t"
by (simp add: is_value_byte_def)
show "bs ! i = bs' ! i"
proof (cases "i < n")
case True
with pfx_eq show ?thesis by simp
next
case False
hence i_lower: "n ≤ i" by simp
show ?thesis
proof (cases "i < n + size_td s")
case True
from field_lookup_is_value_byte_focus [OF fl i_lower True wf wf_sz, simplified]
eq_upto_padding is_value True i_lower l_take l_take'
show ?thesis
by (auto simp add: eq_upto_padding_def add.commute )
next
case False
with fl i_t have i_t: "i < size_td t" by simp
with sfx_eq i_lower False show ?thesis by simp
qed
qed
qed
qed
qed
lemma field_lookup_eq_upto_padding_super_update_bs:
assumes fl: "field_lookup t f 0 = Some (s, n)"
assumes lxbs: "length xbs = size_td t"
assumes lbs: "length bs = size_td s"
assumes lbs': "length bs' = size_td s"
assumes wf: "wf_desc t"
assumes wf_sz: "wf_size_desc t"
shows "eq_upto_padding (export_uinfo t) (super_update_bs bs xbs n) (super_update_bs bs' xbs n) =
eq_upto_padding (export_uinfo s) bs bs'"
proof -
from lbs lbs' fl
have pfx_eq: "⋀i. i < n ⟹ (super_update_bs bs xbs n) ! i = (super_update_bs bs' xbs n) ! i"
by (metis (no_types, opaque_lifting) add_leD2 assms(2) field_lookup_offset_size'
length_take less_le_trans min_def nth_append super_update_bs_def)
from lbs lbs' fl
have sfx_eq: "⋀i. n + size_td s ≤ i ⟹ i < size_td t ⟹ (super_update_bs bs xbs n) ! i = (super_update_bs bs' xbs n) ! i"
proof -
fix i :: nat
assume a1: "n + size_td s ≤ i"
have "n ≤ size_td t"
by (meson add_leD2 field_lookup_offset_size' fl)
then show "super_update_bs bs xbs n ! i = super_update_bs bs' xbs n ! i"
using a1 lxbs lbs lbs' by (smt (verit) Many_More.nat_min_simps(1) append.assoc
length_append length_take not_less nth_append super_update_bs_def)
qed
from lxbs lbs
have lsuper: "length (super_update_bs bs xbs n) = size_td t"
by (metis add.commute field_lookup_offset_size' fl length_super_update_bs)
from lxbs lbs'
have lsuper': "length (super_update_bs bs' xbs n) = size_td t"
by (metis add.commute field_lookup_offset_size' fl length_super_update_bs)
from lxbs lbs lsuper
have bs: "(take (size_td s) (drop n (super_update_bs bs xbs n))) = bs"
by (metis (no_types, lifting) append_take_drop_id append_eq_conv_conj
append_take_drop_id length_take super_update_bs_def)
from lxbs lbs' lsuper'
have bs': "(take (size_td s) (drop n (super_update_bs bs' xbs n))) = bs'"
by (metis (no_types, lifting) append_take_drop_id append_eq_conv_conj
append_take_drop_id length_take super_update_bs_def)
from field_lookup_eq_upto_padding_focus_eq [OF fl lsuper lsuper' pfx_eq sfx_eq wf wf_sz]
show ?thesis
by (simp add: bs bs')
qed
lemma field_lookup_wf_size_desc_pres:
fixes t::"('a, 'b) typ_desc"
and st::"('a, 'b) typ_struct"
and ts::"('a, 'b) typ_tuple list"
and x::"('a, 'b) typ_tuple"
shows
"wf_size_desc t ⟹ field_lookup t f n = Some (s, m) ⟹ wf_size_desc s"
"wf_size_desc_struct st ⟹ field_lookup_struct st f n = Some (s, m) ⟹ wf_size_desc s"
"wf_size_desc_list ts ⟹ field_lookup_list ts f n = Some (s, m) ⟹ wf_size_desc s"
"wf_size_desc_tuple x ⟹ field_lookup_tuple x f n = Some (s, m) ⟹ wf_size_desc s"
by (induct t and st and ts and x arbitrary: n s m f and n s m f and n s m f and n s m f)
(auto split: if_split_asm option.splits)
lemma field_lookup_update_ti_super_update_bs_conv:
fixes t::"('a,'b) typ_info"
and st::"('a,'b) typ_info_struct"
and ts::"('a,'b) typ_info_tuple list"
and x::"('a,'b) typ_info_tuple"
shows
"⟦field_lookup t f m = Some (s, m + n); length bs = size_td s; length xbs = size_td t;
wf_fd t; wf_desc t; wf_size_desc t⟧ ⟹
update_ti s bs v =
update_ti t (super_update_bs bs (access_ti t v xbs) n) v"
"⟦field_lookup_struct st f m = Some (s, m + n); length bs = size_td s; length xbs = size_td_struct st;
wf_fd_struct st; wf_desc_struct st; wf_size_desc_struct st⟧ ⟹
update_ti s bs v =
update_ti_struct st (super_update_bs bs (access_ti_struct st v xbs) n) v"
"⟦field_lookup_list ts f m = Some (s, m + n); length bs = size_td s; length xbs = size_td_list ts;
wf_fd_list ts; wf_desc_list ts; wf_size_desc_list ts⟧ ⟹
update_ti s bs v =
update_ti_list ts (super_update_bs bs (access_ti_list ts v xbs) n) v"
"⟦field_lookup_tuple x f m = Some (s, m + n); length bs = size_td s; length xbs = size_td_tuple x;
wf_fd_tuple x; wf_desc_tuple x; wf_size_desc_tuple x⟧ ⟹
update_ti s bs v =
update_ti_tuple x (super_update_bs bs (access_ti_tuple x v xbs) n) v"
proof (induct t and st and ts and x arbitrary: f m n xbs v and f m n xbs v and f m n xbs v and f m n xbs v)
case (TypDesc algn st nm)
then show ?case
by (auto split: if_split_asm)
(metis TypDesc.prems(3) TypDesc.prems(4) access_ti.simps length_fa_ti super_update_bs_same_length)
next
case (TypScalar algn st d)
then show ?case by auto
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
obtain d nm y where x: "x = DTuple d nm y" by (cases x) auto
from Cons_typ_desc.prems obtain
lxbs: "length xbs = size_td_tuple x + size_td_list fs" and
lbs: "length bs = size_td s" and
wf_fd_x: "wf_fd_tuple (DTuple d nm y)" and
wf_desc_x: "wf_desc_tuple (DTuple d nm y)" and
wf_fd_fs: "wf_fd_list fs" and
wf_size_desc_x: "wf_size_desc_tuple (DTuple d nm y)" and
wf_size_desc_fs: "wf_size_desc_list fs" and
nm_notin: "nm ∉ dt_snd ` set fs" and
wf_desc_fs: "wf_desc_list fs" and
commutes: "fu_commutes (update_ti_t d) (update_ti_list_t fs)"
by (auto simp add: x)
from wf_fd_cons_listD [OF wf_fd_fs ]
have fd_cons_fs: "fd_cons_list fs" .
from wf_fd_x have fd_cons_d: "fd_cons d" by (simp add: x wf_fd_consD)
from lxbs
have lxbs_drop: "length (drop (size_td_tuple x) xbs) = size_td_list fs"
by simp
from lxbs
have lxbs_take: "length (take (size_td_tuple x) xbs) = size_td_tuple (DTuple d nm y)"
by (simp add: x)
from lxbs
have ldrop_xbs: "length (drop (size_td d) xbs) = size_td_list fs"
by (simp add: x)
from lxbs wf_fd_x
have eq1: "length (access_ti d v (take (size_td d) xbs)) = size_td d"
by (metis lxbs_take length_fa_ti size_td_tuple.simps wf_fd_tuple.simps x)
from Cons_typ_desc.prems obtain f1 fxs
where f: "f = f1#fxs"
by (cases f) auto
show ?case
proof (cases "f1 = nm")
case True
show ?thesis
proof (cases "field_lookup d fxs m")
case None
from Cons_typ_desc.prems field_lookup_list_None [OF nm_notin]
have False
by (simp add: True None f x)
thus ?thesis by simp
next
case (Some r)
from Cons_typ_desc.prems have r: "r = (s, m + n)"
by (simp add: x True Some f)
hence fl: "field_lookup_tuple (DTuple d nm y) f m = Some (s, m + n)"
by (simp add: f True Some r)
from td_set_wf_size_desc(4)[OF wf_size_desc_x td_set_tuple_field_lookup_tupleD, OF fl]
have "wf_size_desc s" .
from wf_size_desc_gt(1)[OF this]
have "0 < size_td s" .
with td_set_tuple_offset_size_m [OF td_set_tuple_field_lookup_tupleD, OF fl]
have n_le: "n < size_td d"
by auto
have bound: "size_td s + (m + n - m) ≤ size_td_tuple (DTuple d nm y)" by fact
have bound1: "n + length bs ≤ size_td d"
by (metis add.commute bound diff_add_inverse lbs size_td_tuple.simps)
from fd_cons_fs ldrop_xbs
have upd_id: "(update_ti_list fs (access_ti_list fs v (drop (size_td d) xbs)) v) = v"
apply (clarsimp simp add: fd_cons_list_def fd_cons_desc_def update_ti_list_t_def)
apply (simp add: fd_cons_update_access_def fd_cons_length_def)
done
note hyp = Cons_typ_desc.hyps(1)[simplified x, OF fl lbs lxbs_take wf_fd_x wf_desc_x wf_size_desc_x, where v =v]
show ?thesis apply (simp add: x True r hyp)
by (simp add: super_update_bs_append_drop_first eq1 bound1 super_update_bs_append_take_first upd_id)
qed
next
case False
with Cons_typ_desc.prems
have fl1: "field_lookup_list fs (f1 # fxs) (m + size_td d) = Some (s, m + n)"
by (clarsimp simp add: x f False)
hence n_bound: "size_td d ≤ n"
by (meson field_lookup_offset_le(3) nat_add_left_cancel_le)
from fl1
have fl: "field_lookup_list fs (f1 # fxs) (m + size_td d) = Some (s, (m + size_td d) + (n - size_td d))"
by (metis Nat.diff_cancel field_lookup_list_offset2 field_lookup_list_offsetD)
from n_bound
have take_eq: "(take (size_td s) (drop (n - size_td d + size_td d) xbs)) =
(take (size_td s) (drop n xbs))"
by simp
from fd_cons_d lxbs_take eq1
have upd_d_id: "update_ti d (access_ti d v (take (size_td d) xbs)) v = v"
apply (clarsimp simp add: fd_cons_def fd_cons_desc_def update_ti_t_def)
apply (simp add: fd_cons_update_access_def x)
apply (erule allE [where x= "v"])
apply (erule allE [where x= "(take (size_td d) xbs)"])
apply (simp add: eq1)
done
from ldrop_xbs fd_cons_fs
have lacc_fs: "length (access_ti_list fs v (drop (size_td d) xbs)) = size_td_list fs"
by (simp add: fd_cons_list_def fd_cons_desc_def fd_cons_length_def)
from td_set_field_lookup_rev''(3) [rule_format] fl
have "(s, (m + size_td d) + (n - size_td d)) ∈ td_set_list fs (m + size_td d)"
by blast
from td_set_offset_size''(3)[rule_format, OF this, simplified]
have bound: "size_td s + (n - size_td d) ≤ size_td_list fs".
from lacc_fs n_bound bound lbs
have lsuper: "length (super_update_bs bs (access_ti_list fs v (drop (size_td d) xbs)) (n - size_td d)) = size_td_list fs"
by (simp add: super_update_bs_length)
from commutes have
commute: "update_ti d (access_ti d v (take (size_td d) xbs))
(update_ti_list fs (super_update_bs bs (access_ti_list fs v (drop (size_td d) xbs)) (n - size_td d)) v) =
update_ti_list fs (super_update_bs bs (access_ti_list fs v (drop (size_td d) xbs)) (n - size_td d))
(update_ti d (access_ti d v (take (size_td d) xbs)) v)"
apply (simp add: fu_commutes_def)
apply (erule allE [where x = "v"])
apply (erule allE [where x = "access_ti d v (take (size_td d) xbs)"])
apply (erule allE [where x = "super_update_bs bs (access_ti_list fs v (drop (size_td d) xbs)) (n - size_td d)"])
apply (simp add: update_ti_list_t_def update_ti_t_def eq1 lsuper)
done
note hyp = Cons_typ_desc.hyps(2)[simplified x, OF fl lbs lxbs_drop wf_fd_fs wf_desc_fs wf_size_desc_fs, simplified x, simplified]
show ?thesis
apply (simp add: x f eq1 )
apply (simp add: super_update_bs_append_drop_second eq1 n_bound super_update_bs_append_take_second)
apply (simp add: commute)
apply (simp add: hyp)
apply (simp add: upd_d_id)
done
qed
next
case (DTuple_typ_desc d nm y)
then show ?case by (auto split: if_split_asm)
qed
lemma access_ti_super_update_bs_of_wf:
fixes t::"('a, 'b) typ_info"
and st::"('a, 'b) typ_info_struct"
and ts::"('a, 'b) typ_info_tuple list"
and x::"('a, 'b) typ_info_tuple"
shows
"⟦field_lookup t f m = Some (s, m + n); length bs' = size_td s; length bs = size_td t;
wf_fd t; wf_desc t; wf_size_desc t⟧ ⟹
access_ti t (update_ti s (access_ti⇩0 s w) v) (super_update_bs bs' bs n) =
super_update_bs (access_ti s w bs') (access_ti t v bs) n"
"⟦field_lookup_struct st f m = Some (s, m + n); length bs' = size_td s; length bs = size_td_struct st;
wf_fd_struct st; wf_desc_struct st; wf_size_desc_struct st⟧ ⟹
access_ti_struct st (update_ti s (access_ti⇩0 s w) v) (super_update_bs bs' bs n) =
super_update_bs (access_ti s w bs') (access_ti_struct st v bs) n"
"⟦field_lookup_list ts f m = Some (s, m + n); length bs' = size_td s; length bs = size_td_list ts;
wf_fd_list ts; wf_desc_list ts; wf_size_desc_list ts⟧ ⟹
access_ti_list ts (update_ti s (access_ti⇩0 s w) v) (super_update_bs bs' bs n) =
super_update_bs (access_ti s w bs') (access_ti_list ts v bs) n"
"⟦field_lookup_tuple x f m = Some (s, m + n); length bs' = size_td s; length bs = size_td_tuple x;
wf_fd_tuple x; wf_desc_tuple x; wf_size_desc_tuple x⟧ ⟹
access_ti_tuple x (update_ti s (access_ti⇩0 s w) v) (super_update_bs bs' bs n) =
super_update_bs (access_ti s w bs') (access_ti_tuple x v bs) n"
proof (induct t and st and ts and x arbitrary: f m n bs and f m n bs and f m n bs and f m n bs)
case (TypDesc algn st nm)
note fd = wf_fd_field_lookupD[OF TypDesc(2, 5), THEN wf_fd_consD]
have "length bs = size_td s ⟹
access_ti s (update_ti s (access_ti⇩0 s w) v) bs = access_ti s w bs" for bs
using fd
unfolding fd_cons_def fd_cons_desc_def fd_cons_access_update_def fd_cons_update_access_def
by simp (metis access_ti⇩0 fd fd_cons_length_p length_replicate update_ti_update_ti_t)
then show ?case
using TypDesc(2-) length_fa_ti[OF ‹wf_fd (TypDesc algn st nm)›]
by (auto split: if_splits
simp: super_update_bs_same_length TypDesc(1))
next
case (TypScalar sz algn d)
then show ?case by auto
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
obtain d nm y where x: "x = DTuple d nm y" by (cases x) auto
from Cons_typ_desc.prems have
lbs: "length bs = size_td_tuple x + size_td_list fs" and
wf_fd_x: "wf_fd_tuple (DTuple d nm y)" and
wf_desc_x: "wf_desc_tuple (DTuple d nm y)" and
wf_fd_fs: "wf_fd_list fs" and
wf_size_desc_x: "wf_size_desc_tuple (DTuple d nm y)" and
wf_size_desc_fs: "wf_size_desc_list fs" and
nm_notin: "nm ∉ dt_snd ` set fs" and
wf_desc_fs: "wf_desc_list fs" and
bs': "length bs' = size_td s"
by (auto simp add: x)
{ fix bs bs' :: "byte list" and v
assume bs: "length bs = size_td d" and bs': "length bs' = size_td_list fs"
with ‹wf_fd_list (x # fs)› have x_fs:
"access_ti_list fs (update_ti_tuple_t x bs v) bs' = access_ti_list fs v bs'"
by (simp add: fa_fu_ind_def x)
then have "access_ti_list fs (update_ti d bs v) bs' = access_ti_list fs v bs'"
by (simp add: update_ti_tuple_t_def bs x) }
note fs_x = this
from lbs
have lbs_drop: "length (drop (size_td_tuple x) bs) = size_td_list fs"
by simp
from lbs
have lbs_take: "length (take (size_td_tuple x) bs) = size_td_tuple (DTuple d nm y)"
by (simp add: x)
from lbs wf_fd_x
have eq1: "length (access_ti d v (take (size_td d) bs)) = size_td d"
by (metis lbs_take length_fa_ti size_td_tuple.simps wf_fd_tuple.simps x)
from Cons_typ_desc.prems obtain f1 fxs
where f: "f = f1#fxs"
by (cases f) auto
have wf_s: "wf_fd s"
using Cons_typ_desc.prems(1) Cons_typ_desc.prems(4) wf_fd_field_lookup(3) by blast
let ?v = "update_ti s (access_ti⇩0 s w) v"
have len_acc_w[simp]: "length (access_ti⇩0 s w) = size_td s"
using length_fa_ti[OF wf_s] by (simp add: access_ti⇩0_def)
show ?case
proof (cases "f1 = nm")
case True
show ?thesis
proof (cases "field_lookup d fxs m")
case None
from Cons_typ_desc.prems field_lookup_list_None [OF nm_notin]
have False
by (simp add: True None f x)
thus ?thesis by simp
next
case (Some r)
from Cons_typ_desc.prems have r: "r = (s, m + n)"
by (simp add: x True Some f)
hence fl: "field_lookup_tuple (DTuple d nm y) f m = Some (s, m + n)"
by (simp add: f True Some r)
from td_set_wf_size_desc(4)[OF wf_size_desc_x td_set_tuple_field_lookup_tupleD, OF fl]
have "wf_size_desc s" .
from wf_size_desc_gt(1)[OF this]
have "0 < size_td s" .
with td_set_tuple_offset_size_m [OF td_set_tuple_field_lookup_tupleD, OF fl]
have n_le: "n < size_td d"
by auto
have bound: "size_td s + (m + n - m) ≤ size_td_tuple (DTuple d nm y)" by fact
from bound
have take_eq: "(take (size_td s) (drop n (take (size_td d) bs))) =
(take (size_td s) (drop n bs))"
by (simp add: take_drop)
have take_eq1: "take (size_td s) (drop n (take (size_td d) bs)) = take (size_td s) (drop n bs)"
using take_eq by blast
have l_take_s: "length (take (size_td s) (drop n bs)) = size_td s"
using bound lbs_take by auto
have sz_s: "size_td s ≤ length bs - n"
using l_take_s by auto
from fl
have fd_cons_s: "fd_cons s"
using wf_fd_consD wf_fd_field_lookup(4) wf_fd_x by blast
have sz: "size_td s + n ≤ size_td d" "length bs = size_td d + size_td_list fs"
using lbs x bound by auto
with bs' have super_update_bs_simps[simp]:
"take (size_td d) (super_update_bs bs' bs n) =
super_update_bs bs' (take (size_td d) bs) n"
"drop (size_td d) (super_update_bs bs' bs n) = drop (size_td d) bs"
by (auto simp: super_update_bs_def take_drop)
have hyp:
"access_ti d (update_ti s (access_ti⇩0 s w) v)
(super_update_bs bs' (take (size_td d) bs) n) =
super_update_bs (access_ti s w bs') (access_ti d v (take (size_td d) bs)) n"
using Cons_typ_desc.hyps(1) fl lbs_take wf_fd_x wf_desc_x wf_size_desc_x bs'
by (auto simp: x)
have length_take_bs: "length (take (size_td d) bs) = size_td d"
using sz by auto
have fl_d_s: "field_lookup d fxs m = Some (s, m + n)"
using fl by (simp add: True f)
have wf_d: "wf_fd d" "wf_desc d" "wf_size_desc d"
using wf_fd_x wf_desc_x wf_size_desc_x by auto
note length_fa_ti[OF wf_d(1), simp]
show ?thesis using lbs bound fd_cons_length[OF ‹fd_cons s› bs']
apply (simp add: x True Some r eq1 hyp bs' super_update_bs_append1)
apply (subst field_lookup_update_ti_super_update_bs_conv(1)[OF fl_d_s len_acc_w length_take_bs wf_d])
apply (subst fs_x)
apply simp_all
done
qed
next
case False
with Cons_typ_desc.prems
have fl: "field_lookup_list fs (f1 # fxs) (m + size_td d) = Some (s, m + n)"
by (clarsimp simp add: x f False)
hence n_bound: "size_td d ≤ n"
by (meson field_lookup_offset_le(3) nat_add_left_cancel_le)
have fl: "field_lookup_list fs (f1 # fxs) (m + size_td d) =
Some (s, (m + size_td d) + (n - size_td d))"
by (metis Nat.diff_cancel field_lookup_list_offset2 field_lookup_list_offsetD fl)
have hyp:
"access_ti_list fs (update_ti s (access_ti⇩0 s w) v)
(super_update_bs bs' (drop (size_td d) bs) (n - size_td d)) =
super_update_bs (access_ti s w bs')
(access_ti_list fs v (drop (size_td d) bs)) (n - size_td d)"
using Cons_typ_desc.hyps(2) fl bs' lbs_drop wf_fd_fs wf_desc_fs wf_size_desc_fs
by (simp add: x)
have super_update_bs_simps[simp]:
"take (size_td d) (super_update_bs bs' bs n) = take (size_td d) bs"
"drop (size_td d) (super_update_bs bs' bs n) =
super_update_bs bs' (drop (size_td d) bs) (n - size_td d)"
using n_bound lbs x by (simp_all add: super_update_bs_def drop_take)
have fl_x: "field_lookup_list (x # fs) [nm] 0 = Some (d, 0)"
by (simp add: x)
have disj: "disj_fn [nm] f"
using False f by (auto simp: disj_fn_def)
from fa_fu_lookup_disj(3)[rule_format, OF fl_x Cons_typ_desc(3) disj ‹wf_fd_list (x # fs)›]
have acc_upd: "length bs = size_td s ⟹ length bs' = size_td d ⟹
access_ti d (update_ti s bs v) bs' = access_ti d v bs'" for bs bs' v
by (simp add: fa_fu_ind_def update_ti_t_def)
from False n_bound lbs
show ?thesis
by (simp add: x f hyp eq1 nth_append super_update_bs_append2 acc_upd)
qed
next
case (DTuple_typ_desc d nm y)
then show ?case apply (cases f) by (auto split: if_split_asm)
qed
lemma heap_update_list_same:
assumes p_no_overflow: "unat p + length bs ≤ addr_card"
assumes same_pfx: "⋀i. i < length bs ⟹ bs ! i = hp (p + word_of_nat i)"
shows "heap_update_list p bs hp = hp"
using p_no_overflow same_pfx
proof (induct bs arbitrary: p hp)
case Nil
then show ?case by simp
next
case (Cons b bs)
from Cons.prems obtain
no_overflow: "Suc (unat p + length bs) ≤ addr_card" and
same: "(⋀i. i < Suc (length bs) ⟹ (b # bs) ! i = hp (p + word_of_nat i)) "
by clarsimp
from no_overflow have no_overflow': "unat (p + 1) + length bs ≤ addr_card"
by (metis (no_types, opaque_lifting) Suc_leD
add.commute add_Suc_right add_leD1 comm_monoid_add_class.add_0 unatSuc unat_0)
{
fix i
assume bound: "i < length bs"
from same [where i="Suc i", simplified, OF bound]
have "bs ! i = hp (p + (1 + word_of_nat i))" .
then
have "bs ! i = hp (p + 1 + word_of_nat i)"
by (metis group_cancel.add1)
} note same' = this
from same [where i=0] have hp_eq: "hp(p := b) = hp" by simp
note hyp = Cons.hyps [where p="p+1", OF no_overflow' same']
then show ?case by (simp add: hp_eq)
qed
lemma heap_update_list_same_prefix:
assumes p_no_overflow: "unat p + length pfx + length bs ≤ addr_card"
assumes same_pfx: "⋀i. i < length pfx ⟹ pfx ! i = hp (p + word_of_nat i)"
shows "heap_update_list p (pfx @ bs) hp = heap_update_list (p + word_of_nat (length pfx)) bs hp"
using p_no_overflow same_pfx
proof (induct pfx arbitrary: p bs hp)
case Nil
then show ?case by simp
next
case (Cons x pfx)
from Cons.prems obtain
no_overflow: "Suc (unat p + length pfx + length bs) ≤ addr_card" and
same: "(⋀i. i < Suc (length pfx) ⟹ (x # pfx) ! i = hp (p + word_of_nat i))"
by clarsimp
from no_overflow have no_overflow': "unat (p + 1) + length pfx + length bs ≤ addr_card"
by (metis (no_types, opaque_lifting) Suc_leD ab_semigroup_add_class.add_ac(1)
add.commute add_Suc_right add_leD1 comm_monoid_add_class.add_0 unatSuc unat_0)
{
fix i
assume bound: "i < length pfx"
from same [where i="Suc i", simplified, OF bound]
have "pfx ! i = hp (p + (1 + word_of_nat i))" .
then
have "pfx ! i = hp (p + 1 + word_of_nat i)"
by (metis group_cancel.add1)
} note same' = this
have add_eq: "p + 1 + word_of_nat (length pfx) = p + (1 + word_of_nat (length pfx))"
using add.assoc by blast
from same [where i=0] have hp_eq: "hp(p := x) = hp" by simp
note hyp = Cons.hyps [where p="p+1", OF no_overflow' same']
then show ?case by (simp add: hp_eq add_eq)
qed
lemma heap_update_list_same_suffix:
assumes p_no_overflow: "unat p + length sfx + length bs ≤ addr_card"
assumes same_sfx: "⋀i. i < length sfx ⟹ sfx ! i = hp (p + word_of_nat (length bs + i))"
shows "heap_update_list p (bs @ sfx) hp = heap_update_list p bs hp"
using p_no_overflow same_sfx
proof (induct bs arbitrary: p sfx hp)
case Nil
then show ?case by (simp add: heap_update_list_same)
next
case (Cons b bs)
from Cons.prems obtain no_overflow: "Suc (unat p + length sfx + length bs) ≤ addr_card" and
same : "⋀i. i < length sfx ⟹ sfx ! i = hp (p + word_of_nat (Suc (length bs) + i))"
by clarsimp
from no_overflow have no_overflow': "unat (p + 1) + length sfx + length bs ≤ addr_card"
by (metis (no_types, opaque_lifting) Suc_leD ab_semigroup_add_class.add_ac(1)
add.commute add_Suc_right add_leD1 comm_monoid_add_class.add_0 unatSuc unat_0)
{
fix i
assume i_bound: "i < length sfx"
from same [OF i_bound] have prem: "sfx ! i = hp (p + word_of_nat (Suc (length bs) + i))" .
from i_bound no_overflow
have "Suc (i + length bs) < addr_card"
by simp
then
have neq: "p ≠ p + 1 + word_of_nat (length bs + i)"
by (metis (no_types, opaque_lifting) ab_semigroup_add_class.add_ac(1) add.commute add_cancel_right_right
len_of_addr_card not_gr_zero of_nat_Suc unat_of_nat_eq unsigned_0 zero_less_Suc)
from neq [symmetric]
have hp_eq: "(hp(p := b)) (p + 1 + word_of_nat (length bs + i)) = hp (p + 1 + word_of_nat (length bs + i))"
by (rule fun_upd_other)
have add_eq: "(p + 1 + word_of_nat (length bs + i)) = (p + word_of_nat (Suc (length bs) + i))"
by simp
have "sfx ! i = (hp(p := b)) (p + 1 + word_of_nat (length bs + i))"
apply (subst hp_eq)
apply (subst prem )
apply (simp only: add_eq)
done
} note same' = this
note hyp = Cons.hyps [OF no_overflow', where hp="(hp(p := b))", OF same' ]
show ?case apply (simp add: hyp) by (simp add: fun_upd_def)
qed
lemma heap_update_list_same_prefix_suffix:
assumes p_no_overflow: "unat p + length pfx + length bs + length sfx ≤ addr_card"
assumes same_pfx: "⋀i. i < length pfx ⟹ pfx ! i = hp (p + word_of_nat i)"
assumes same_sfx: "⋀i. i < length sfx ⟹ sfx ! i = hp (p + word_of_nat (length pfx + length bs + i))"
shows "heap_update_list p (pfx @ bs @ sfx) hp = heap_update_list (p + word_of_nat (length pfx)) bs hp"
proof -
from p_no_overflow
have no_overflow_pfx: "unat p + length pfx + length (bs @ sfx) ≤ addr_card" by simp
from heap_update_list_same_prefix [where pfx=pfx and bs="bs@sfx", OF no_overflow_pfx same_pfx]
have "heap_update_list p (pfx @ bs @ sfx) hp =
heap_update_list (p + word_of_nat (length pfx)) (bs @ sfx) hp" .
also
from p_no_overflow have "unat p + length pfx ≤ addr_card"
by simp
then
have "unat (p + word_of_nat (length pfx)) ≤ unat p + length pfx"
by (simp add: unat_le_helper)
with p_no_overflow
have no_overflow_sfx: "unat (p + word_of_nat (length pfx)) + length sfx + length bs ≤ addr_card"
by simp
from same_sfx p_no_overflow have same_sfx': "⋀i. i < length sfx ⟹
sfx ! i = hp (p + word_of_nat (length pfx) + word_of_nat (length bs + i))"
apply simp
by (simp add: ab_semigroup_add_class.add_ac(1))
from heap_update_list_same_suffix [where p="p + word_of_nat (length pfx)" and bs=bs and sfx =sfx and hp=hp,
OF no_overflow_sfx same_sfx']
have "heap_update_list (p + word_of_nat (length pfx)) (bs @ sfx) hp =
heap_update_list (p + word_of_nat (length pfx)) bs hp" .
finally show ?thesis .
qed
lemma heap_update_list_super_update_bs_heap_list:
assumes p_no_overflow: "unat p + m ≤ addr_card"
assumes n_m: "n + length bs ≤ m"
shows "heap_update_list (p + word_of_nat n) bs hp = heap_update_list p (super_update_bs bs (heap_list hp m p) n) hp"
proof -
have heap_list_hp: "⋀i. i < m ⟹ (heap_list hp m p) ! i = hp (p + word_of_nat i)"
by (rule heap_list_nth)
obtain pfx sfx where
super: "super_update_bs bs (heap_list hp m p) n = pfx @ bs @ sfx" and
pfx: "pfx = take n (heap_list hp m p)" and
sfx: "sfx = drop (n + length bs) (heap_list hp m p)" and
lpfx: "length pfx = n" and
lsfx: "length sfx = m - n - length bs"
using n_m
by (simp add: super_update_bs_def )
have bounds: "unat p + length pfx + length bs + length sfx ≤ addr_card"
using lpfx p_no_overflow n_m lsfx
by simp
have same_pfx: "⋀i. i < length pfx ⟹ pfx ! i = hp (p + word_of_nat i)"
using heap_list_hp
by (simp add: pfx)
have same_sfx: "⋀i. i < length sfx ⟹ sfx ! i = hp (p + word_of_nat (length pfx + length bs + i))"
using heap_list_hp
by (simp add: sfx lpfx)
from heap_update_list_same_prefix_suffix [OF bounds same_pfx same_sfx]
show ?thesis
by (simp add: super lpfx)
qed
lemma append_take_dropI: "xs = take (length xs) zs ⟹ ys = drop (length xs) zs ⟹ xs @ ys = zs"
by (metis append_take_drop_id)
lemma heap_list_heap_update_list_id:
assumes bound: "n ≤ addr_card"
assumes lbs: "length bs = n"
shows "(heap_list (heap_update_list a bs h) n a) = bs"
using bound lbs
proof (induct n arbitrary: a bs h)
case 0
then show ?case by simp
next
case (Suc n)
then show ?case
apply (cases bs)
apply clarsimp
apply clarsimp
by (metis (no_types, lifting) Suc_le_D Suc_le_eq add_cancel_right_right add_diff_cancel_left'
fun_upd_same heap_update_list_value' linorder_not_less one_neq_zero plus_1_eq_Suc
unat_minus_abs unsigned_1)
qed
lemma heap_update_list_nth_conv:
"length bs ≤ addr_card ⟹
heap_update_list a bs h a' =
(if (unat a' + (if a' < a then addr_card else 0) - unat a) < length bs then
bs ! (unat a' + (if a' < a then addr_card else 0) - unat a)
else
h a')"
proof (induct bs arbitrary: a h)
case Nil
then show ?case by simp
next
case (Cons b bs)
from Cons.prems have bound: "Suc (length bs) ≤ addr_card" by simp
hence bound': "length bs ≤ addr_card" by simp
note hyp = Cons.hyps [OF this, of "a+1" " (h(a := b))"]
show ?case
proof (cases "a' < a")
case True
show ?thesis apply (simp add: hyp True)
using True
by (smt (verit) Nat.add_diff_assoc One_nat_def Suc_diff_Suc add_diff_cancel_left'
cancel_comm_monoid_add_class.diff_cancel diff_add diff_diff_left
diff_right_commute fun_upd_apply le_add_diff len_of_addr_card not_less_eq
not_less_eq_eq nth_Cons_pos of_nat_add order_less_le trans_less_add2
un_ui_le unat_0 unat_sub_if' unsigned_greater_eq unsigned_less word_less_def
word_overflow_unat word_unat.Rep_inverse zero_less_diff)
next
case False
show ?thesis apply (simp add: hyp False)
using False bound'
by (smt (verit) Nat.add_diff_assoc One_nat_def Suc_eq_plus1 Suc_le_eq
add_diff_cancel_left bound cancel_comm_monoid_add_class.diff_cancel
diff_zero fun_upd_def le_eq_less_or_eq len_of_addr_card linorder_not_le nth_Cons_0
nth_Cons_Suc order_less_le plus_1_eq_Suc trans_le_add2 unatSuc2 unat_1
unat_add_lem unat_mono unsigned_0 unsigned_less)
qed
qed
lemma heap_update_list_overwrite_all_nth_conv:
assumes lbs: "length bs = addr_card"
shows "heap_update_list a bs h a' =
bs ! (unat a' + (if a' < a then addr_card else 0) - unat a)"
proof -
from lbs have leq: "length bs ≤ addr_card" by simp
show ?thesis
using lbs
apply (simp add: heap_update_list_nth_conv [OF leq])
by (metis len_of_addr_card linorder_not_less unat_sub_if' unsigned_less word_less_nat_alt)
qed
lemma heap_update_list_overwrite':
assumes bound: "length bs ≤ addr_card"
assumes len_eq: "length bs = length bs'"
shows "(heap_update_list a bs (heap_update_list a bs' h)) = (heap_update_list a bs h)"
apply (rule ext)
using bound len_eq
apply (simp add: heap_update_list_nth_conv )
done
lemma heap_list_tail_addr_card:
assumes len: "length ys = addr_card"
shows "heap_update_list p (xs @ ys) h = heap_update_list (p + word_of_nat (length xs)) ys h"
proof -
from len have len': "length ys ≤ addr_card" by simp
show ?thesis
apply (simp add: heap_update_list_concat_unfold)
apply (rule ext)
apply (simp add: heap_update_list_nth_conv [OF len'])
using len
by (metis len_of_addr_card linorder_not_less unat_sub_if' unsigned_less word_less_nat_alt)
qed
lemma heap_update_list_overwrite:
assumes leq: "length bs = length bs'"
shows "heap_update_list p bs (heap_update_list p bs' h) = heap_update_list p bs h"
proof (cases "length bs ≤ addr_card")
case True
from heap_update_list_overwrite' [OF True leq] show ?thesis by simp
next
case False
from False obtain xs ys where bs: "bs=xs@ys" and lys: "length ys = addr_card"
by (metis append_take_drop_id diff_diff_cancel length_drop linorder_not_less order_less_le)
from False leq obtain xs' ys' where bs': "bs'=xs'@ys'" and lys': "length ys' = addr_card"
by (metis append_take_drop_id diff_diff_cancel length_drop linorder_not_less order_less_le)
from lys have leq_ys: "length ys ≤ addr_card" by simp
from lys' have leq_ys': "length ys' ≤ addr_card" by simp
note eqs = heap_list_tail_addr_card [OF lys, where xs = xs]
heap_list_tail_addr_card [OF lys', where xs = xs']
heap_update_list_overwrite_all_nth_conv [OF lys]
heap_update_list_overwrite_all_nth_conv [OF lys']
show ?thesis
apply (rule ext)
apply (simp add: bs bs' eqs)
done
qed
context xmem_type
begin
lemma xmem_type_is_value_byte_access_ti_update_ti_cancel:
assumes i_bound: "i < size_of TYPE('a)"
assumes lbs: "length bs = size_of TYPE('a)"
assumes lbs': "length bs'= size_of TYPE('a)"
assumes is_value: "is_value_byte (typ_uinfo_t TYPE('a)) i"
shows "access_ti (typ_info_t TYPE('a)) (update_ti (typ_info_t TYPE('a)) bs v) bs' ! i = bs ! i"
using is_value_byte_access_ti_update_ti_cancel [OF _ _ _ _ _ i_bound [simplified size_of_def]
lbs [simplified size_of_def] lbs' [simplified size_of_def] is_value [simplified typ_uinfo_t_def]]
by (simp add: local.wf_component_descs local.wf_field_descs wf_fdp_fd(1) wf_lf_fdp)
lemma xmem_type_is_value_byte_access_ti_id:
assumes i_bound: "i < size_of TYPE('a)"
assumes lbs: "length bs = size_of TYPE('a)"
assumes is_value: "is_value_byte (typ_uinfo_t TYPE('a)) i"
shows "access_ti (typ_info_t TYPE('a)) v (bs[i:=b]) = access_ti (typ_info_t TYPE('a)) v bs"
using is_value_byte_access_ti_id [OF _ _ _ _ _ i_bound [simplified size_of_def]
lbs [simplified size_of_def] is_value [simplified typ_uinfo_t_def]]
by (simp add: local.wf_component_descs local.wf_field_descs wf_fdp_fd(1) wf_lf_fdp)
lemma is_padding_byte_to_lense: "is_padding_byte (typ_uinfo_t TYPE('a)) i
⟹ lense.is_padding_byte i"
by (metis is_padding_byte_def local.lense.complement local.lense.is_padding_byte_def
local.lense.is_value_byte_update_depends local.xmem_type_is_padding_byte_update_ti_id size_of_def typ_uinfo_size)
lemma is_value_byte_to_lense: "is_value_byte (typ_uinfo_t TYPE('a)) i
⟹ lense.is_value_byte i"
using xmem_type_is_padding_byte_access_ti
xmem_type_is_padding_byte_update_ti_id xmem_type_is_value_byte_access_ti_update_ti_cancel
using is_value_byte_def local.lense.is_value_byteI local.size_of_def
xmem_type_is_value_byte_access_ti_id by auto
lemma is_padding_byte_from_lense:
assumes padding: "lense.is_padding_byte i"
shows "is_padding_byte (typ_uinfo_t TYPE('a)) i"
proof -
from padding have i_sz: "i < size_of (TYPE('a))"
using local.lense.is_padding_byte_def by blast
show ?thesis
proof (cases "is_padding_byte (typ_uinfo_t TYPE('a)) i")
case True
then show ?thesis by simp
next
case False
with complement_tu_padding [OF i_sz [simplified size_of_def, simplified typ_uinfo_size [symmetric]]] show ?thesis
using i_sz is_value_byte_to_lense local.lense.complement padding by blast
qed
qed
lemma is_padding_byte_lense_conv: "is_padding_byte (typ_uinfo_t TYPE('a)) i = lense.is_padding_byte i"
using is_padding_byte_from_lense is_padding_byte_to_lense by blast
lemma is_value_byte_from_lense:
assumes is_value: "lense.is_value_byte i"
shows "is_value_byte (typ_uinfo_t TYPE('a)) i"
proof -
from is_value have i_sz: "i < size_of (TYPE('a))"
using local.lense.is_value_byte_def by blast
show ?thesis
proof (cases "is_value_byte (typ_uinfo_t TYPE('a)) i")
case True
then show ?thesis by simp
next
case False
with complement_tu_padding [OF i_sz [simplified size_of_def, simplified typ_uinfo_size [symmetric]]] show ?thesis
using assms i_sz is_padding_byte_to_lense local.lense.complement by blast
qed
qed
lemma is_value_byte_lense_conv: "is_value_byte (typ_uinfo_t TYPE('a)) i = lense.is_value_byte i"
using is_value_byte_from_lense is_value_byte_to_lense by blast
lemma eq_padding_lense_conv: "eq_padding (typ_uinfo_t TYPE('a)) bs bs' = lense.eq_padding bs bs'"
apply (simp add: lense.eq_padding_is_padding_byte_conv eq_padding_def)
by (simp add: is_padding_byte_lense_conv size_of_def)
lemma eq_upto_padding_lense_conv: "eq_upto_padding (typ_uinfo_t TYPE('a)) bs bs' = lense.eq_upto_padding bs bs'"
apply (simp add: lense.eq_upto_padding_is_value_byte_conv eq_upto_padding_def)
by (simp add: is_value_byte_lense_conv size_of_def)
lemma lense_eq_upto_padding_from_bytes_eq:
assumes eq_upto_padding: "lense.eq_upto_padding bs bs'"
shows "((from_bytes bs)::'a) = from_bytes bs'"
using eq_upto_padding
by (metis field_desc.select_convs(2) field_desc_def from_bytes_def local.field_sz_size_of
local.field_update_update_ti local.xmem_type_wf_field_desc.eq_upto_padding_upd
padding_base.eq_upto_padding_length_eq update_ti_t_def)
lemma eq_upto_padding_from_bytes_eq:
assumes eq_upto_padding: "eq_upto_padding (typ_uinfo_t TYPE('a)) bs bs'"
shows "((from_bytes bs)::'a) = from_bytes bs'"
using lense_eq_upto_padding_from_bytes_eq eq_upto_padding_lense_conv eq_upto_padding
by (simp add: typ_uinfo_t_def)
lemma lense_eq_padding_to_bytes_eq:
assumes eq_padding: "lense.eq_padding bs bs'"
shows "(to_bytes (v::'a) bs) = to_bytes v bs'"
proof -
from lense.eq_padding_acc [OF eq_padding]
show ?thesis
by (simp add: to_bytes_def)
qed
lemma eq_padding_to_bytes_eq:
assumes eq_padding: "eq_padding (typ_uinfo_t TYPE('a)) bs bs'"
shows "(to_bytes (v::'a) bs) = to_bytes v bs'"
using lense_eq_padding_to_bytes_eq eq_padding_lense_conv eq_padding
by (simp add: typ_uinfo_t_def)
lemma eq_padding_to_bytes:
"length bs = size_of TYPE('a) ⟹ eq_padding (typ_uinfo_t TYPE('a)) (to_bytes (v::'a) bs) bs"
by (simp add: eq_padding_lense_conv local.lense.field_access_eq_padding1 to_bytes_def)
lemma lense_eq_padding_to_bytes:
"length bs = size_of TYPE('a) ⟹ lense.eq_padding (to_bytes (v::'a) bs) bs"
using eq_padding_to_bytes eq_padding_lense_conv
by simp
lemma heap_list_heap_update_id:
fixes p::"'a ptr"
shows "(heap_list
(heap_update_list (ptr_val p)
(to_bytes (u::'a) (heap_list h (size_of TYPE('a)) (ptr_val p))) h)
(size_of TYPE('a)) (ptr_val p)) =
(to_bytes u (heap_list h (size_of TYPE('a)) (ptr_val p)))"
proof -
have bound: "size_of TYPE('a) ≤ addr_card"
using max_size nless_le by blast
have lbs: "length (to_bytes u (heap_list h (size_of TYPE('a)) (ptr_val p))) = size_of TYPE('a)"
by (simp add: local.lense.access_result_size to_bytes_def)
note eq1 = heap_list_heap_update_list_id [OF bound lbs]
show ?thesis
by (simp add: eq1)
qed
lemma heap_update_collapse:
fixes p::"'a ptr"
shows "heap_update p v (heap_update p u h) = heap_update p v h"
proof -
have lv: "length (to_bytes v (to_bytes u (heap_list h (size_of TYPE('a)) (ptr_val p)))) =
size_of TYPE('a)"
by (simp add: local.lense.access_result_size to_bytes_def)
have lu: "length (to_bytes u (heap_list h (size_of TYPE('a)) (ptr_val p))) = size_of TYPE('a)"
by (simp add: local.lense.access_result_size to_bytes_def)
have leq: "length (to_bytes v (to_bytes u (heap_list h (size_of TYPE('a)) (ptr_val p)))) =
length (to_bytes u (heap_list h (size_of TYPE('a)) (ptr_val p)))"
by (simp add: lv lu)
have eq:
"(to_bytes v (to_bytes u (heap_list h (size_of TYPE('a)) (ptr_val p)))) =
(to_bytes v (heap_list h (size_of TYPE('a)) (ptr_val p)))"
by (metis eq_padding_lense_conv eq_padding_to_bytes_eq heap_list_length
local.lense.field_access_eq_padding1 to_bytes_def)
show ?thesis
apply (simp add: heap_update_def)
apply (simp add: heap_list_heap_update_id [OF ])
apply (subst heap_update_list_overwrite [OF leq])
apply (simp add: eq)
done
qed
lemma heap_update_padding_collapse:
fixes p::"'a ptr"
assumes lbs: "length bs = size_of TYPE('a)"
assumes lbs': "length bs' = size_of TYPE('a)"
shows "heap_update_padding p v bs (heap_update_padding p u bs' h) = heap_update_padding p v bs h"
apply (simp add: heap_update_padding_def)
using lbs lbs' heap_update_list_overwrite
by auto
lemma heap_update_padding_heap_update_collapse:
fixes p::"'a ptr"
assumes lbs: "length bs = size_of TYPE('a)"
shows "heap_update_padding p v bs (heap_update p u h) = heap_update_padding p v bs h"
by (simp add: heap_update_heap_update_padding_conv heap_update_padding_collapse [OF lbs])
lemma to_bytes_from_bytes_id:
"length bs = size_of TYPE('a) ⟹ to_bytes ((from_bytes bs)::'a) bs = bs"
by (metis (no_types, lifting) field_desc.select_convs(2) field_desc_def from_bytes_def lense_eq_padding_to_bytes
local.field_sz_size_of local.field_sz_size_td local.lense.eq_upto_paddingI
local.lense.padding_eq_complement local.lense.update_access local.upd
padding_base.eq_padding_length1 to_bytes_def update_ti_update_ti_t)
lemma to_bytes_heap_list_id:
"to_bytes ((from_bytes (heap_list h (size_of TYPE('a)) a))::'a)
(heap_list h (size_of TYPE('a)) a) =
heap_list h (size_of TYPE('a)) a"
by (simp add: to_bytes_from_bytes_id)
lemma heap_update_id:
fixes p::"'a ptr"
shows "heap_update p (h_val h p) h = h"
by (simp add: heap_update_def h_val_def to_bytes_heap_list_id heap_update_list_id')
context
fixes s f n
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n)"
begin
interpretation flense: padding_lense "access_ti s" "update_ti s" "size_td s"
using field_lookup_padding_lense [OF fl] .
private lemma n_t: "n < size_of TYPE('a)"
using fl
by (metis add_diff_cancel_right' add_leD2 cancel_comm_monoid_add_class.diff_cancel field_lookup_offset_size'
field_lookup_wf_size_desc_gt
local.field_sz_size_of local.field_sz_size_td local.wf_size_desc nat_less_le not_add_less2)
private lemma wf_desc_s: "wf_desc s"
using fl field_lookup_wf_desc_pres(1) local.wf_desc by blast
private lemma wf_size_desc_s: "wf_size_desc s"
using fl field_lookup_wf_size_desc_pres(1) local.wf_size_desc by blast
private lemma wf_field_descs_s: "wf_field_descs (set (field_descs s))"
using fl local.field_lookup_wf_field_descs by blast
private lemma wf_component_descs_s: "wf_component_descs s"
using fl local.field_lookup_wf_component_descs by blast
private lemma wf_fd_s: "wf_fd s"
using fl local.wf_desc local.wf_lf wf_fd_field_lookupD wf_fdp_fd(1) wf_lf_fdp
by blast
lemma xmem_type_field_lookup_is_padding_byte_focus:
assumes i_lower: "n ≤ i"
assumes i_upper :"i < n + size_td s"
shows "is_padding_byte (typ_uinfo_t TYPE('a)) i = is_padding_byte (export_uinfo s) (i - n)"
using field_lookup_is_padding_byte_focus [OF fl i_lower i_upper]
by (simp add: typ_uinfo_t_def)
lemma xmem_type_field_lookup_is_padding_byte_focus_rev1:
assumes is_padding: "is_padding_byte (export_uinfo s) i"
shows "is_padding_byte (typ_uinfo_t TYPE('a)) (i + n)"
proof -
from is_padding have i_s: "i < size_td s"
using is_padding_byte_def by simp
have lower: "n ≤ i + n" by simp
from i_s have upper: "i + n < n + size_td s" by simp
from xmem_type_field_lookup_is_padding_byte_focus [OF lower upper] is_padding
show ?thesis by simp
qed
lemma xmem_type_field_lookup_is_padding_byte_focus_rev2:
assumes is_padding: "is_padding_byte (typ_uinfo_t TYPE('a)) (i + n)"
assumes i_bound: "i < size_td s"
shows "is_padding_byte (export_uinfo s) i"
proof -
have lower: "n ≤ i + n" by simp
from i_bound have upper: "i + n < n + size_td s" by simp
from xmem_type_field_lookup_is_padding_byte_focus [OF lower upper] is_padding
show ?thesis
by simp
qed
lemma xmem_type_field_lookup_lense_is_padding_byte_focus_rev1:
assumes is_padding: "flense.is_padding_byte i"
shows "lense.is_padding_byte (i + n)"
proof -
from is_padding have i_s: "i < size_td s"
using flense.is_padding_byte_def by simp
have lower: "n ≤ i + n" by simp
from i_s have upper: "i + n < n + size_td s" by simp
from field_lookup_is_padding_byte_inner_to_outer [OF fl lower upper] is_padding
show ?thesis by (simp add: size_of_def)
qed
lemma xmem_type_field_lookup_lense_is_padding_byte_focus_rev2:
assumes is_padding: "lense.is_padding_byte (i + n)"
assumes i_bound: "i < size_td s"
shows "flense.is_padding_byte i"
proof -
have lower: "n ≤ i + n" by simp
from i_bound have upper: "i + n < n + size_td s" by simp
from field_lookup_is_padding_byte_outer_to_inner [OF fl lower upper] is_padding
show ?thesis
by (simp add: size_of_def)
qed
lemma xmem_type_field_lookup_is_value_byte_focus:
assumes i_lower: "n ≤ i"
assumes i_upper :"i < n + size_td s"
shows "is_value_byte (typ_uinfo_t TYPE('a)) i = is_value_byte (export_uinfo s) (i - n)"
using field_lookup_is_value_byte_focus [OF fl i_lower i_upper]
by (simp add: typ_uinfo_t_def)
lemma xmem_type_field_lookup_is_value_byte_focus_rev1:
assumes is_value: "is_value_byte (export_uinfo s) i"
shows "is_value_byte (typ_uinfo_t TYPE('a)) (i + n)"
proof -
from is_value have i_s: "i < size_td s"
using is_value_byte_def by simp
have lower: "n ≤ i + n" by simp
from i_s have upper: "i + n < n + size_td s" by simp
from xmem_type_field_lookup_is_value_byte_focus [OF lower upper] is_value
show ?thesis by simp
qed
lemma xmem_type_field_lookup_is_value_byte_focus_rev2:
assumes is_value: "is_value_byte (typ_uinfo_t TYPE('a)) (i + n)"
assumes i_bound: "i < size_td s"
shows "is_value_byte (export_uinfo s) i"
proof -
have lower: "n ≤ i + n" by simp
from i_bound have upper: "i + n < n + size_td s" by simp
from xmem_type_field_lookup_is_value_byte_focus [OF lower upper] is_value
show ?thesis
by simp
qed
lemma xmem_type_field_lookup_lense_is_value_byte_focus_rev1:
assumes is_value: "flense.is_value_byte i"
shows "lense.is_value_byte (i + n)"
proof -
from is_value have i_s: "i < size_td s"
using flense.is_value_byte_def by simp
have lower: "n ≤ i + n" by simp
from i_s have upper: "i + n < n + size_td s" by simp
from field_lookup_is_value_byte_inner_to_outer [OF fl lower upper] is_value
show ?thesis by (simp add: size_of_def)
qed
lemma xmem_type_field_lookup_lense_is_value_byte_focus_rev2:
assumes is_value: "lense.is_value_byte (i + n)"
assumes i_bound: "i < size_td s"
shows "flense.is_value_byte i"
proof -
have lower: "n ≤ i + n" by simp
from i_bound have upper: "i + n < n + size_td s" by simp
from field_lookup_is_value_byte_outer_to_inner [OF fl lower upper] is_value
show ?thesis
by (simp add: size_of_def)
qed
lemma field_lookup_is_padding_byte_access_ti:
assumes i_bound: "i < size_td s"
assumes lbs: "length bs = size_td s"
assumes is_padding: "is_padding_byte (export_uinfo s) i"
shows "access_ti s v bs ! i = bs ! i"
using is_padding_byte_access_ti [OF wf_desc_s wf_size_desc_s wf_field_descs_s
wf_component_descs_s wf_fd_s i_bound lbs is_padding] .
lemma field_lookup_is_padding_byte_update_ti_id:
assumes i_bound: "i < size_td s"
assumes lbs: "length bs = size_td s"
assumes is_padding: "is_padding_byte (export_uinfo s) i"
shows "update_ti s (bs[i := b]) v = update_ti s bs v"
using is_padding_byte_update_ti_id [OF wf_desc_s wf_size_desc_s wf_field_descs_s
wf_component_descs_s wf_fd_s i_bound lbs is_padding] .
lemma field_lookup_is_value_byte_access_ti_update_ti_cancel:
assumes i_bound: "i < size_td s"
assumes lbs: "length bs = size_td s"
assumes lbs': "length bs' = size_td s"
assumes is_value: "is_value_byte (export_uinfo s) i"
shows "access_ti s (update_ti s bs v) bs' ! i = bs ! i"
using is_value_byte_access_ti_update_ti_cancel [OF wf_desc_s wf_size_desc_s wf_field_descs_s
wf_component_descs_s wf_fd_s i_bound lbs lbs' is_value] .
lemma field_lookup_is_value_byte_access_ti_id:
assumes i_bound: "i < size_td s"
assumes lbs: "length bs = size_td s"
assumes is_value: "is_value_byte (export_uinfo s) i"
shows "access_ti s v (bs[i := b]) = access_ti s v bs"
using is_value_byte_access_ti_id [OF wf_desc_s wf_size_desc_s wf_field_descs_s
wf_component_descs_s wf_fd_s i_bound lbs is_value] .
lemma field_lookup_is_padding_byte_to_lense:
assumes is_padding: "is_padding_byte (export_uinfo s) i"
shows "flense.is_padding_byte i"
proof (rule flense.is_padding_byteI)
from is_padding show "i < size_td s"
using is_padding_byte_def by simp
next
fix v::'a and bs::"byte list"
assume i_bound: "i < size_td s"
assume lbs: "length bs = size_td s"
show "access_ti s v bs ! i = bs ! i"
by (rule field_lookup_is_padding_byte_access_ti [OF i_bound lbs is_padding])
next
fix v::'a and bs::"byte list" and b::"byte"
assume i_bound: "i < size_td s"
assume lbs: "length bs = size_td s"
show "update_ti s bs v = update_ti s (bs[i := b]) v"
using field_lookup_is_padding_byte_update_ti_id [OF i_bound lbs is_padding] by simp
qed
lemma field_lookup_is_padding_byte_from_lense:
assumes is_padding: "flense.is_padding_byte i"
shows "is_padding_byte (export_uinfo s) i"
proof -
from is_padding have i_bound: "i < size_td s" by (simp add: flense.is_padding_byte_def)
from xmem_type_field_lookup_lense_is_padding_byte_focus_rev1 [OF is_padding]
have "lense.is_padding_byte (i + n)".
from is_padding_byte_from_lense [OF this]
have "is_padding_byte (typ_uinfo_t TYPE('a)) (i + n)".
with xmem_type_field_lookup_is_padding_byte_focus [where i="i + n"] i_bound
show ?thesis by simp
qed
lemma field_lookup_is_padding_byte_lense_conv:
"is_padding_byte (export_uinfo s) i ⟷ flense.is_padding_byte i"
using field_lookup_is_padding_byte_from_lense field_lookup_is_padding_byte_to_lense
by blast
lemma field_lookup_is_value_byte_from_lense:
assumes is_value: "flense.is_value_byte i"
shows "is_value_byte (export_uinfo s) i"
proof -
from is_value have i_bound: "i < size_td s" by (simp add: flense.is_value_byte_def)
from xmem_type_field_lookup_lense_is_value_byte_focus_rev1 [OF is_value]
have "lense.is_value_byte (i + n)".
from is_value_byte_from_lense [OF this]
have "is_value_byte (typ_uinfo_t TYPE('a)) (i + n)".
with xmem_type_field_lookup_is_value_byte_focus [where i="i + n"] i_bound
show ?thesis by simp
qed
lemma field_lookup_is_value_byte_to_lense:
assumes is_value: "is_value_byte (export_uinfo s) i"
shows "flense.is_value_byte i"
proof (rule flense.is_value_byteI)
from is_value show "i < size_td s"
using is_value_byte_def by simp
next
fix v::'a and bs::"byte list" and bs'::"byte list"
assume i_bound: "i < size_td s"
assume lbs: "length bs = size_td s"
assume lbs': "length bs' = size_td s"
show "access_ti s (update_ti s bs v) bs' ! i = bs ! i"
by (rule field_lookup_is_value_byte_access_ti_update_ti_cancel [OF i_bound lbs lbs' is_value])
next
fix v::'a and bs::"byte list" and b::"byte"
assume i_bound: "i < size_td s"
assume lbs: "length bs = size_td s"
show "access_ti s v bs = access_ti s v (bs[i := b])"
using field_lookup_is_value_byte_access_ti_id [OF i_bound lbs is_value] by simp
qed
lemma field_lookup_is_value_byte_lense_conv:
"is_value_byte (export_uinfo s) i ⟷ flense.is_value_byte i"
using field_lookup_is_value_byte_from_lense field_lookup_is_value_byte_to_lense
by blast
lemma field_lookup_eq_padding_lense_conv: "eq_padding (export_uinfo s) bs bs' ⟷ flense.eq_padding bs bs'"
using field_lookup_is_padding_byte_lense_conv
by (simp add: eq_padding_def flense.eq_padding_is_padding_byte_conv)
lemma field_lookup_eq_upto_padding_lense_conv: "eq_upto_padding (export_uinfo s) bs bs' ⟷ flense.eq_upto_padding bs bs'"
using field_lookup_is_value_byte_lense_conv
by (simp add: eq_upto_padding_def flense.eq_upto_padding_is_value_byte_conv)
lemma xmem_type_field_lookup_eq_padding_focus:
assumes lbs: "length bs = size_of TYPE('a)"
assumes lbs': "length bs' = size_of TYPE('a)"
assumes eq_padding: "eq_padding (typ_uinfo_t TYPE('a)) bs bs'"
shows "eq_padding (export_uinfo s) (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
using field_lookup_eq_padding_focus [OF fl lbs [simplified size_of_def] lbs'[simplified size_of_def] _ _
eq_padding [simplified typ_uinfo_t_def] ]
by (simp add: typ_uinfo_t_def size_of_def)
lemma xmem_type_field_lookup_eq_padding_focus_eq:
assumes lbs: "length bs = size_of TYPE('a)"
assumes lbs': "length bs' = size_of TYPE('a)"
assumes pfx_eq: "⋀i. i < n ⟹ bs ! i = bs' ! i"
assumes sfx_eq: "⋀i. n + size_td s ≤ i ⟹ i < size_of TYPE('a) ⟹ bs ! i = bs' ! i"
shows "eq_padding (typ_uinfo_t TYPE('a)) bs bs' =
eq_padding (export_uinfo s) (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
using field_lookup_eq_padding_focus_eq [OF fl lbs [simplified size_of_def] lbs'[simplified size_of_def] pfx_eq sfx_eq]
by (simp add: typ_uinfo_t_def size_of_def)
lemma xmem_type_field_lookup_lense_eq_padding_focus:
assumes lbs: "length bs = size_of TYPE('a)"
assumes lbs': "length bs' = size_of TYPE('a)"
assumes eq_padding: "lense.eq_padding bs bs'"
shows "flense.eq_padding (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
using xmem_type_field_lookup_eq_padding_focus [OF lbs lbs'] eq_padding
eq_padding_lense_conv field_lookup_eq_padding_lense_conv
by simp
lemma xmem_type_field_lookup_lense_eq_padding_focus_eq:
assumes lbs: "length bs = size_of TYPE('a)"
assumes lbs': "length bs' = size_of TYPE('a)"
assumes pfx_eq: "⋀i. i < n ⟹ bs ! i = bs' ! i"
assumes sfx_eq: "⋀i. n + size_td s ≤ i ⟹ i < size_of TYPE('a) ⟹ bs ! i = bs' ! i"
shows "lense.eq_padding bs bs' =
flense.eq_padding (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
using xmem_type_field_lookup_eq_padding_focus_eq [OF lbs lbs' pfx_eq sfx_eq]
eq_padding_lense_conv field_lookup_eq_padding_lense_conv
by simp
lemma xmem_type_field_lookup_eq_upto_padding_focus:
assumes lbs: "length bs = size_of TYPE('a)"
assumes lbs': "length bs' = size_of TYPE('a)"
assumes eq_upto_padding: "eq_upto_padding (typ_uinfo_t TYPE('a)) bs bs'"
shows "eq_upto_padding (export_uinfo s) (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
using field_lookup_eq_upto_padding_focus [OF fl lbs [simplified size_of_def] lbs'[simplified size_of_def] _ _
eq_upto_padding [simplified typ_uinfo_t_def] ]
by (simp add: typ_uinfo_t_def size_of_def)
lemma xmem_type_field_lookup_eq_upto_padding_focus_eq:
assumes lbs: "length bs = size_of TYPE('a)"
assumes lbs': "length bs' = size_of TYPE('a)"
assumes pfx_eq: "⋀i. i < n ⟹ bs ! i = bs' ! i"
assumes sfx_eq: "⋀i. n + size_td s ≤ i ⟹ i < size_of TYPE('a) ⟹ bs ! i = bs' ! i"
shows "eq_upto_padding (typ_uinfo_t TYPE('a)) bs bs' =
eq_upto_padding (export_uinfo s) (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
using field_lookup_eq_upto_padding_focus_eq [OF fl lbs [simplified size_of_def] lbs'[simplified size_of_def] pfx_eq sfx_eq]
by (simp add: typ_uinfo_t_def size_of_def)
lemma xmem_type_field_lookup_lense_eq_upto_padding_focus:
assumes lbs: "length bs = size_of TYPE('a)"
assumes lbs': "length bs' = size_of TYPE('a)"
assumes eq_upto_padding: "lense.eq_upto_padding bs bs'"
shows "flense.eq_upto_padding (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
using xmem_type_field_lookup_eq_upto_padding_focus [OF lbs lbs'] eq_upto_padding
eq_upto_padding_lense_conv field_lookup_eq_upto_padding_lense_conv
by simp
lemma xmem_type_field_lookup_lense_eq_upto_padding_focus_eq:
assumes lbs: "length bs = size_of TYPE('a)"
assumes lbs': "length bs' = size_of TYPE('a)"
assumes pfx_eq: "⋀i. i < n ⟹ bs ! i = bs' ! i"
assumes sfx_eq: "⋀i. n + size_td s ≤ i ⟹ i < size_of TYPE('a) ⟹ bs ! i = bs' ! i"
shows "lense.eq_upto_padding bs bs' =
flense.eq_upto_padding (take (size_td s) (drop n bs)) (take (size_td s) (drop n bs'))"
using xmem_type_field_lookup_eq_upto_padding_focus_eq [OF lbs lbs' pfx_eq sfx_eq]
eq_upto_padding_lense_conv field_lookup_eq_upto_padding_lense_conv
by simp
lemma xmem_type_field_lookup_eq_padding_super_update_bs:
assumes lxbs: "length xbs = size_of TYPE('a)"
assumes lbs: "length bs = size_td s"
assumes lbs': "length bs' = size_td s"
shows "eq_padding (typ_uinfo_t TYPE('a)) (super_update_bs bs xbs n) (super_update_bs bs' xbs n) ⟷
eq_padding (export_uinfo s) bs bs'"
using field_lookup_eq_padding_super_update_bs [OF fl lxbs [simplified size_of_def] lbs lbs']
by (simp add: typ_uinfo_t_def)
lemma xmem_type_field_lookup_lense_eq_padding_super_update_bs:
assumes lxbs: "length xbs = size_of TYPE('a)"
assumes lbs: "length bs = size_td s"
assumes lbs': "length bs' = size_td s"
shows "lense.eq_padding (super_update_bs bs xbs n) (super_update_bs bs' xbs n) ⟷
flense.eq_padding bs bs'"
using xmem_type_field_lookup_eq_padding_super_update_bs [OF lxbs lbs lbs']
eq_padding_lense_conv field_lookup_eq_padding_lense_conv
by simp
lemma xmem_type_field_lookup_eq_upto_padding_super_update_bs:
assumes lxbs: "length xbs = size_of TYPE('a)"
assumes lbs: "length bs = size_td s"
assumes lbs': "length bs' = size_td s"
shows "eq_upto_padding (typ_uinfo_t TYPE('a)) (super_update_bs bs xbs n) (super_update_bs bs' xbs n) ⟷
eq_upto_padding (export_uinfo s) bs bs'"
using field_lookup_eq_upto_padding_super_update_bs [OF fl lxbs [simplified size_of_def] lbs lbs']
by (simp add: typ_uinfo_t_def)
lemma xmem_type_field_lookup_lense_eq_upto_padding_super_update_bs:
assumes lxbs: "length xbs = size_of TYPE('a)"
assumes lbs: "length bs = size_td s"
assumes lbs': "length bs' = size_td s"
shows "lense.eq_upto_padding (super_update_bs bs xbs n) (super_update_bs bs' xbs n) ⟷
flense.eq_upto_padding bs bs'"
using xmem_type_field_lookup_eq_upto_padding_super_update_bs [OF lxbs lbs lbs']
eq_upto_padding_lense_conv field_lookup_eq_upto_padding_lense_conv
by simp
lemma access_ti_update_ti_lense_eq_upto_padding:
assumes lbs: "length bs = size_td s"
assumes lbs': "length bs' = size_td s"
shows "flense.eq_upto_padding (access_ti s (update_ti s bs v) bs') bs"
by (simp add: flense.value_byte_to_eq_upto_padding_eq lbs lbs' length_fa_ti
flense.is_value_byte_acc_upd_cancel wf_fd_s)
lemma access_ti_update_ti_eq_upto_padding:
assumes lbs: "length bs = size_td s"
assumes lbs': "length bs' = size_td s"
shows "eq_upto_padding (export_uinfo s) (access_ti s (update_ti s bs v) bs') bs"
using access_ti_update_ti_lense_eq_upto_padding [OF lbs lbs']
field_lookup_eq_upto_padding_lense_conv
by simp
lemma access_ti_update_ti_lense_eq_padding:
assumes "flense.eq_padding bs bs'"
shows "access_ti s (update_ti s bs v) bs' = bs"
by (metis (no_types, lifting) access_ti_update_ti_lense_eq_upto_padding assms flense.field_access_eq_padding1
flense.padding_eq_complement padding_base.eq_padding_length1
flense.eq_padding_length2 flense.eq_padding_trans)
lemma access_ti_update_ti_eq_padding:
assumes "eq_padding (export_uinfo s) bs bs'"
shows "access_ti s (update_ti s bs v) bs' = bs"
using access_ti_update_ti_lense_eq_padding assms field_lookup_eq_padding_lense_conv
by simp
lemma
assumes match: "export_uinfo s = typ_uinfo_t TYPE('b::xmem_type)"
assumes lbs: "length bs = size_td s"
shows "access_ti s v bs = to_bytes ((from_bytes (access_ti s v bs))::'b) bs"
proof -
from match
have sz_acc_s: "length (access_ti s v bs) = size_td (typ_info_t TYPE('b))"
by (metis export_size_of flense.access_result_size fold_typ_uinfo_t)
show ?thesis
by (smt (verit, best) field_lookup_eq_padding_lense_conv flense.field_access_eq_padding1
lbs match sz_acc_s xmem_type_class.eq_padding_lense_conv xmem_type_class.field_sz_size_of
xmem_type_class.field_sz_size_td xmem_type_class.lense_eq_padding_to_bytes_eq
xmem_type_class.to_bytes_from_bytes_id)
qed
context
assumes match: "export_uinfo s = typ_uinfo_t TYPE('b::xmem_type)"
begin
lemma field_lookup_lense_eq_padding_fieldtyp_conv:
"flense.eq_padding bs bs' = xmem_type_class.lense.eq_padding TYPE('b) bs bs'"
using field_lookup_eq_padding_lense_conv match xmem_type_class.eq_padding_lense_conv by auto
lemma field_lookup_lense_eq_upto_padding_fieldtyp_conv:
"flense.eq_upto_padding bs bs' = xmem_type_class.lense.eq_upto_padding TYPE('b) bs bs'"
using field_lookup_eq_upto_padding_lense_conv match xmem_type_class.eq_upto_padding_lense_conv by auto
lemma field_lookup_is_value_byte_fieldtyp_conv:
"flense.is_value_byte i = xmem_type_class.lense.is_value_byte TYPE('b) i"
using field_lookup_is_value_byte_lense_conv match xmem_type_class.is_value_byte_lense_conv by auto
lemma field_lookup_is_padding_byte_fieldtyp_conv:
"flense.is_padding_byte i = xmem_type_class.lense.is_padding_byte TYPE('b) i"
using field_lookup_is_padding_byte_lense_conv match xmem_type_class.is_padding_byte_lense_conv by auto
lemma field_lookup_access_ti_to_bytes_field_conv:
assumes eq_upto_padding: "eq_upto_padding (export_uinfo s) (access_ti s v bs) vs"
assumes eq_padding: "eq_padding (export_uinfo s) bs bs'"
shows "access_ti s v bs = to_bytes ((from_bytes vs)::'b) bs'"
proof -
from eq_upto_padding have flense_eq_upto: "flense.eq_upto_padding (access_ti s v bs) vs"
by (simp add: field_lookup_eq_upto_padding_lense_conv)
hence blense_eq_upto: "xmem_type_class.lense.eq_upto_padding TYPE('b) (access_ti s v bs) vs"
by (simp add: field_lookup_lense_eq_upto_padding_fieldtyp_conv)
from eq_padding have flense_eq: "flense.eq_padding bs bs'"
by (simp add: field_lookup_eq_padding_lense_conv)
hence blense_eq: "xmem_type_class.lense.eq_padding TYPE('b) bs bs'"
by (simp add: field_lookup_lense_eq_padding_fieldtyp_conv)
show ?thesis
using flense_eq flense_eq_upto blense_eq blense_eq_upto
apply (simp add: to_bytes_def from_bytes_def c_type_class.to_bytes_def c_type_class.from_bytes_def)
by (smt (verit, ccfv_threshold) c_type_class.to_bytes_def field_lookup_lense_eq_padding_fieldtyp_conv
flense.eq_padding_length1 flense.field_access_eq_padding1 padding_base.eq_upto_padding_length2
update_ti_s_from_bytes xmem_type_class.lense.eq_padding_acc xmem_type_class.lense_eq_upto_padding_from_bytes_eq
xmem_type_class.to_bytes_from_bytes_id)
qed
lemma field_lookup_access_ti_eq_upto_padding:
"length bs = size_td s ⟹
eq_upto_padding (export_uinfo s) (access_ti s v bs) (access_ti s v bs')"
by (metis access_ti_update_ti_eq_upto_padding flense.access_result_size flense.update_access)
lemma field_lookup_access_ti_eq_padding_value:
"length bs = size_td s ⟹ eq_padding (export_uinfo s) (access_ti s v bs) (access_ti s v' bs)"
by (meson eq_padding_sym eq_padding_trans field_lookup_eq_padding_lense_conv flense.field_access_eq_padding1)
lemma field_lookup_access_ti_eq_padding_bytes:
"length bs = size_td s ⟹ eq_padding (export_uinfo s) (access_ti s v bs) bs"
using field_lookup_eq_padding_lense_conv flense.field_access_eq_padding1 by blast
lemma field_lookup_access_ti_to_bytes_field_conv':
assumes eq_upto_padding: "eq_upto_padding (export_uinfo s) (access_ti s v bs) vs"
assumes lbs: "length bs = size_td s"
shows "access_ti s v bs = to_bytes ((from_bytes vs)::'b) bs"
using field_lookup_access_ti_to_bytes_field_conv [OF eq_upto_padding eq_padding_refl] lbs
by simp
lemma field_lookup_update_ti_from_bytes_field_conv:
fixes v::'a and vf::'b
assumes lbs: "length bs = size_td s"
assumes lxbs: "length xbs = size_of TYPE('a)"
shows "update_ti (typ_info_t TYPE('b)) bs vf =
(from_bytes (access_ti s (update_ti s bs v) xbs)) "
proof -
from lbs lxbs
have "eq_upto_padding (export_uinfo s) (access_ti s (update_ti s bs v) xbs) bs"
by (metis access_ti_update_ti_eq_upto_padding access_ti_update_ti_lense_eq_padding
flense.access_result_size flense.eq_padding_refl flense.update_access)
hence "from_bytes (access_ti s (update_ti s bs v) xbs) = (from_bytes bs::'b)"
by (simp add: match xmem_type_class.eq_upto_padding_from_bytes_eq)
moreover have "update_ti (typ_info_t TYPE('b)) bs vf = from_bytes bs"
using lbs
by (metis (mono_tags, lifting) c_type_class.typ_uinfo_size export_size_of export_uinfo_size match
update_ti_s_from_bytes update_ti_update_ti_t)
ultimately show ?thesis by simp
qed
lemma xmem_type_field_lookup_update_ti_super_update_bs_conv:
fixes v::'a
assumes lbs: "length bs = size_td s"
assumes lxbs: "length xbs = size_of TYPE('a)"
shows "update_ti s bs v =
update_ti (typ_info_t TYPE('a)) (super_update_bs bs (access_ti (typ_info_t TYPE('a)) v xbs) n) v"
using field_lookup_update_ti_super_update_bs_conv(1) [where m=0, simplified, OF fl lbs lxbs [simplified size_of_def], where v=v]
by simp
lemma heap_update_list_field_to_root:
fixes p::"'a ptr"
assumes cgrd: "c_guard p"
assumes lbs: "length bs = size_td s"
shows "heap_update_list (&(p→f)) bs hp =
heap_update_list (ptr_val p) (super_update_bs bs (heap_list hp (size_of TYPE('a)) (ptr_val p)) n) hp"
proof -
from fl
have off: "word_of_nat (field_offset TYPE('a) f) = word_of_nat n"
by (simp)
from c_guard_no_wrap' [OF cgrd]
have no_overflow: "unat (ptr_val p) + size_of TYPE('a) ≤ addr_card" .
from lbs fl have n_bound: "n + length bs ≤ size_of TYPE('a)"
by (metis add.commute field_lookup_offset_size size_of_def)
show ?thesis
apply (simp add: field_lvalue_def off )
apply (rule heap_update_list_super_update_bs_heap_list [OF no_overflow n_bound])
done
qed
lemma heap_list_field_to_root:
fixes p::"'a ptr"
shows "heap_list hp (size_td s) &(p→f) =
take (size_td s) ((drop n) (heap_list hp (size_of TYPE('a)) (ptr_val (p::'a ptr))))"
proof -
from fl have off: "(field_offset TYPE('a) f) = n" by simp
from fl
have n_bound: "n ≤ size_of TYPE('a)"
by (meson n_t nat_less_le)
from fl
have s_bound: "size_td s ≤ size_of TYPE('a) - n"
by (metis field_lookup_offset_size nat_move_sub_le size_of_def)
show ?thesis
by (simp add: field_lvalue_def off drop_heap_list_le [OF n_bound] take_heap_list_le [OF s_bound])
qed
lemma heap_list_field_super_update_bs_root_conv:
fixes p::"'a ptr"
shows "super_update_bs (heap_list hp (size_td s) (&(p→f))) (heap_list hp (size_of TYPE('a)) (ptr_val p)) n =
(heap_list hp (size_of TYPE('a)) (ptr_val p))"
proof -
have l: "length (heap_list hp (size_of TYPE('a)) (ptr_val p)) = size_of TYPE('a)"
by simp
from l fl have l_take: "(length (take n (heap_list hp (size_of TYPE('a)) (ptr_val p)))) = n"
by (simp add: le_less n_t)
from l fl n_t
have l_s_take: "length ((take (size_td s) (drop n (heap_list hp (size_of TYPE('a)) (ptr_val p))))) = size_td s"
by (metis heap_list_field_to_root heap_list_length)
have com: "(n + size_td s) = (size_td s + n)"
by simp
show ?thesis
apply (simp add: super_update_bs_def)
apply (subst heap_list_field_to_root)
apply (rule append_take_dropI)
apply (simp only: l_take)
apply (rule append_take_dropI)
apply (simp only: l_s_take l_take)
apply (simp only: l_s_take l_take)
apply (simp)
apply (subst com)
apply (rule refl)
done
qed
lemma heap_update_field_root_conv:
fixes p::"'a ptr"
assumes cgrd: "c_guard p"
shows "heap_update (PTR('b) &(p→f)) v hp =
heap_update p (update_ti s (to_bytes v (heap_list hp (size_of TYPE('b)) (&(p→f)))) (h_val hp p)) hp"
unfolding heap_update_def c_type_class.heap_update_def ptr_val_def
proof -
show "heap_update_list &(p→f) (to_bytes v (heap_list hp (size_of TYPE('b)) &(p→f))) hp =
heap_update_list (ptr_val p)
(to_bytes
(update_ti s (to_bytes v (heap_list hp (size_of TYPE('b)) &(p→f))) (h_val hp p))
(heap_list hp (size_of TYPE('a)) (ptr_val p)))
hp" (is "?lhs = ?rhs")
proof -
define bs where "bs = to_bytes v (heap_list hp (size_of TYPE('b)) (&(p→f)))"
have lbs: "length bs = size_td s"
unfolding bs_def
by (simp add: export_size_of match)
from heap_update_list_field_to_root [OF cgrd lbs]
have eq1:
"heap_update_list (&(p→f)) bs hp =
heap_update_list (ptr_val p) (super_update_bs bs (heap_list hp (size_of TYPE('a)) (ptr_val p)) n) hp"
by simp
have lhl: "length (heap_list hp (size_of TYPE('a)) (ptr_val p)) = size_of TYPE('a)"
by simp
from xmem_type_field_lookup_update_ti_super_update_bs_conv [OF lbs this, where v="h_val hp p"]
have eq2:
"update_ti s bs (h_val hp p) =
update_ti (typ_info_t TYPE('a))
(super_update_bs bs
(access_ti (typ_info_t TYPE('a)) (h_val hp p) (heap_list hp (size_of TYPE('a)) (ptr_val p)))
n)
(h_val hp p)" .
have eq3: "access_ti (typ_info_t TYPE('a)) (h_val hp p) (heap_list hp (size_of TYPE('a)) (ptr_val p)) =
heap_list hp (size_of TYPE('a)) (ptr_val p)"
apply (simp add: h_val_def from_bytes_def update_ti_t_def size_of_def)
using lhl
by (metis local.field_sz_size_of local.field_sz_size_td local.lense.access_result_size
local.lense.eq_padding_neq_is_value_byte local.lense.field_access_eq_padding1
local.lense.is_value_byte_acc_upd_cancel nth_equalityI)
have lsuper: "length (super_update_bs bs (heap_list hp (size_of TYPE('a)) (ptr_val p)) n) = size_of TYPE('a)"
using flense.eq_padding_refl lbs lhl padding_base.eq_padding_length1
xmem_type_field_lookup_lense_eq_padding_super_update_bs by blast
thm field_lookup_eq_padding_super_update_bs
have eq_padding_bs: "eq_padding (export_uinfo s) bs (heap_list hp (size_td s) (&(p→f)))"
apply (simp add: bs_def to_bytes_def c_type_class.to_bytes_def)
by (metis (mono_tags, lifting) c_type_class.to_bytes_def export_size_of heap_list_length match
xmem_type_class.eq_padding_to_bytes)
have l_take_drop: "length (take (size_td s) (drop n (heap_list hp (size_of TYPE('a)) (ptr_val p)))) = size_td s"
by (metis heap_list_field_to_root heap_list_length)
thm heap_list_field_super_update_bs_root_conv
from xmem_type_field_lookup_eq_padding_super_update_bs [OF lhl lbs,
where bs' = "take (size_td s) (drop n (heap_list hp (size_of TYPE('a)) (ptr_val p)))", OF l_take_drop,
simplified heap_list_field_to_root [symmetric], simplified heap_list_field_super_update_bs_root_conv]
eq_padding_bs
have "eq_padding (typ_uinfo_t TYPE('a)) (super_update_bs bs (heap_list hp (size_of TYPE('a)) (ptr_val p)) n)
(heap_list hp (size_of TYPE('a)) (ptr_val p))"
by (simp )
hence eq_padding: "lense.eq_padding (super_update_bs bs (heap_list hp (size_of TYPE('a)) (ptr_val p)) n)
(heap_list hp (size_of TYPE('a)) (ptr_val p))"
by (simp add: eq_padding_lense_conv)
from eq_padding
have eq4:
"(to_bytes
(update_ti (typ_info_t TYPE('a))
(super_update_bs bs (heap_list hp (size_of TYPE('a)) (ptr_val p)) n) (h_val hp p))
(heap_list hp (size_of TYPE('a)) (ptr_val p))) =
(super_update_bs bs (heap_list hp (size_of TYPE('a)) (ptr_val p)) n)"
apply (simp add: to_bytes_def)
by (smt (verit) lhl local.lense.access_result_size local.lense.eq_padding_neq_is_value_byte
local.lense.field_access_eq_padding1 local.lense.is_value_byte_acc_upd_cancel lsuper nth_equalityI)
show ?thesis
unfolding bs_def [symmetric]
apply (simp add: eq1)
apply (simp add: eq2)
apply (simp add: eq3)
apply (simp add: eq4)
done
qed
qed
lemma heap_update_padding_field_root_conv:
fixes p::"'a ptr"
assumes cgrd: "c_guard p"
assumes lbs: "length bs = size_of TYPE ('b)"
shows "heap_update_padding (PTR('b) &(p→f)) v bs hp =
heap_update_padding p (update_ti s (to_bytes v bs) (h_val hp p))
(super_update_bs bs (heap_list hp (size_of TYPE('a)) (ptr_val p)) n) hp"
unfolding heap_update_padding_def c_type_class.heap_update_padding_def ptr_val_def
proof -
show "heap_update_list &(p→f) (to_bytes v bs) hp =
heap_update_list (ptr_val p)
(to_bytes
(update_ti s (to_bytes v bs) (h_val hp p))
(super_update_bs bs (heap_list hp (size_of TYPE('a)) (ptr_val p)) n))
hp" (is "?lhs = ?rhs")
proof -
define bs' where "bs' = to_bytes v bs"
have lbs': "length bs' = size_td s"
unfolding bs'_def
by (simp add: export_size_of lbs match)
from heap_update_list_field_to_root [OF cgrd lbs']
have eq1:
"heap_update_list (&(p→f)) bs' hp =
heap_update_list (ptr_val p) (super_update_bs bs' (heap_list hp (size_of TYPE('a)) (ptr_val p)) n) hp"
by simp
have lhl: "length (heap_list hp (size_of TYPE('a)) (ptr_val p)) = size_of TYPE('a)"
by simp
from xmem_type_field_lookup_update_ti_super_update_bs_conv [OF lbs' this, where v="h_val hp p"]
have eq2:
"update_ti s bs' (h_val hp p) =
update_ti (typ_info_t TYPE('a))
(super_update_bs bs'
(access_ti (typ_info_t TYPE('a)) (h_val hp p) (heap_list hp (size_of TYPE('a)) (ptr_val p)))
n)
(h_val hp p)" .
have eq3: "access_ti (typ_info_t TYPE('a)) (h_val hp p) (heap_list hp (size_of TYPE('a)) (ptr_val p)) =
heap_list hp (size_of TYPE('a)) (ptr_val p)"
apply (simp add: h_val_def from_bytes_def update_ti_t_def size_of_def)
using lhl
by (metis local.field_sz_size_of local.field_sz_size_td local.lense.access_result_size
local.lense.eq_padding_neq_is_value_byte local.lense.field_access_eq_padding1
local.lense.is_value_byte_acc_upd_cancel nth_equalityI)
have lsuper: "length (super_update_bs bs' (heap_list hp (size_of TYPE('a)) (ptr_val p)) n) = size_of TYPE('a)"
using flense.eq_padding_refl lbs' lhl padding_base.eq_padding_length1
xmem_type_field_lookup_lense_eq_padding_super_update_bs by blast
thm field_lookup_eq_padding_super_update_bs
have l_take_drop: "length (take (size_td s) (drop n (heap_list hp (size_of TYPE('a)) (ptr_val p)))) = size_td s"
by (metis heap_list_field_to_root heap_list_length)
have eq4:
"(to_bytes
(update_ti (typ_info_t TYPE('a))
(super_update_bs bs' (heap_list hp (size_of TYPE('a)) (ptr_val p)) n) (h_val hp p))
(super_update_bs bs (heap_list hp (size_of TYPE('a)) (ptr_val p)) n)) =
(super_update_bs bs' (heap_list hp (size_of TYPE('a)) (ptr_val p)) n)"
apply (simp add: to_bytes_def)
by (smt (verit, ccfv_threshold) bs'_def export_size_of field_lookup_lense_eq_padding_fieldtyp_conv
lbs lhl local.lense.access_result_size local.lense.complement local.lense.eq_padding_acc local.lense.is_padding_byte_def local.lense.is_value_byte_def lsuper match mem_type_class.mem_type_simps(2) nth_equalityI wf_type_class.len xmem_type_class.lense_eq_padding_to_bytes xmem_type_field_lookup_lense_eq_padding_super_update_bs)
show ?thesis
unfolding bs'_def [symmetric]
apply (simp add: eq1)
apply (simp add: eq2)
apply (simp add: eq3)
apply (simp add: eq4)
done
qed
qed
lemma heap_update_field_root_conv':
fixes p::"'a ptr"
assumes cgrd: "c_guard p"
shows "heap_update (PTR('b) &(p→f)) v hp =
heap_update p (update_ti s (to_bytes_p v) (h_val hp p)) hp"
proof -
have "eq_upto_padding (export_uinfo s) (to_bytes_p v) (to_bytes v (heap_list hp (size_of TYPE('b)) (&(p→f))))"
apply (simp add: to_bytes_def c_type_class.to_bytes_def to_bytes_p_def c_type_class.to_bytes_p_def)
by (simp add: field_lookup_eq_upto_padding_lense_conv field_lookup_lense_eq_upto_padding_fieldtyp_conv
xmem_type_class.lense.field_access_eq_upto_padding)
hence "update_ti s (to_bytes_p v) (h_val hp p) =
update_ti s (to_bytes v (heap_list hp (size_of TYPE('b)) (&(p→f)))) (h_val hp p)"
by (simp add: field_lookup_eq_upto_padding_lense_conv padding_base.eq_upto_padding_def)
with heap_update_field_root_conv [OF cgrd] show ?thesis by simp
qed
lemma heap_update_padding_field_root_conv':
fixes p::"'a ptr"
assumes cgrd: "c_guard p"
assumes lbs: "length bs = size_of TYPE ('b)"
shows "heap_update_padding (PTR('b) &(p→f)) v bs hp =
heap_update_padding p (update_ti s (to_bytes_p v) (h_val hp p))
(super_update_bs bs (heap_list hp (size_of TYPE('a)) (ptr_val p)) n) hp"
proof -
have "eq_upto_padding (export_uinfo s) (to_bytes_p v) (to_bytes v bs)"
apply (simp add: to_bytes_def c_type_class.to_bytes_def to_bytes_p_def c_type_class.to_bytes_p_def)
by (simp add: field_lookup_eq_upto_padding_lense_conv field_lookup_lense_eq_upto_padding_fieldtyp_conv
xmem_type_class.lense.field_access_eq_upto_padding)
hence "update_ti s (to_bytes_p v) (h_val hp p) =
update_ti s (to_bytes v bs) (h_val hp p)"
by (simp add: field_lookup_eq_upto_padding_lense_conv padding_base.eq_upto_padding_def)
with heap_update_padding_field_root_conv [OF cgrd lbs] show ?thesis by simp
qed
end
end
lemma heap_update_field_root_conv'':
fixes p::"'a ptr"
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (adjust_ti (typ_info_t TYPE('b::xmem_type)) fld (fld_update ∘ (λx _. x)), n)"
assumes fg_cons: "fg_cons fld (fld_update ∘ (λx _. x))"
assumes cgrd: "c_guard p"
shows "heap_update (PTR('b) &(p→f)) v hp =
heap_update p (fld_update (λ_. v) (h_val hp p)) hp"
proof -
have match: "export_uinfo (adjust_ti (typ_info_t TYPE('b)) fld (fld_update ∘ (λx _. x))) = typ_uinfo_t TYPE('b)"
apply (subst c_type_class.typ_uinfo_t_def)
apply (rule export_tag_adjust_ti(1) )
apply (rule fg_cons)
apply (simp)
done
from field_desc_adjust_ti(1) [rule_format, OF fg_cons, of "(typ_info_t TYPE('b))"]
have upd_eq:
"update_ti_t (adjust_ti (typ_info_t TYPE('b)) fld (fld_update ∘ (λx _. x))) bs v =
fld_update (λ_. update_ti_t (typ_info_t TYPE('b)) bs (fld v)) v " for bs v
by (simp add: update_desc_def)
from this [of "(to_bytes_p v)" "h_val hp p"]
have val_conv:
"(update_ti (adjust_ti (typ_info_t TYPE('b)) fld (fld_update ∘ (λx _. x))) (to_bytes_p v) (h_val hp p)) =
(fld_update (λ_. v) (h_val hp p))"
apply (simp add: update_ti_t_def size_of_def c_type_class.size_of_def)
by (metis (mono_tags, opaque_lifting) inv_p length_to_bytes_p update_ti_s_from_bytes update_ti_t_def)
note heap_conv = heap_update_field_root_conv' [OF fl match cgrd, of v hp]
show ?thesis
apply (simp add: heap_conv)
apply (simp add: val_conv)
done
qed
lemma heap_update_field_root_conv_pointless':
fixes p::"'a ptr"
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (adjust_ti (typ_info_t TYPE('b::xmem_type)) fld (fld_update ∘ (λx _. x)), n)"
assumes fg_cons: "fg_cons fld (fld_update ∘ (λx _. x))"
assumes cgrd: "c_guard p"
shows "heap_update (PTR('b) &(p→f)) v =
(λhp. heap_update p (fld_update (λ_. v) (h_val hp p)) hp)"
using heap_update_field_root_conv'' [OF fl fg_cons cgrd]
by (simp add: fun_eq_iff)
lemma heap_update_padding_field_root_conv'':
fixes p::"'a ptr"
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (adjust_ti (typ_info_t TYPE('b::xmem_type)) fld (fld_update ∘ (λx _. x)), n)"
assumes fg_cons: "fg_cons fld (fld_update ∘ (λx _. x))"
assumes cgrd: "c_guard p"
assumes lbs: "length bs = size_of TYPE ('b)"
shows "heap_update_padding (PTR('b) &(p→f)) v bs hp =
heap_update_padding p (fld_update (λ_. v) (h_val hp p))
(super_update_bs bs (heap_list hp (size_of TYPE('a)) (ptr_val p)) n) hp"
proof -
have match: "export_uinfo (adjust_ti (typ_info_t TYPE('b)) fld (fld_update ∘ (λx _. x))) = typ_uinfo_t TYPE('b)"
apply (subst c_type_class.typ_uinfo_t_def)
apply (rule export_tag_adjust_ti(1) )
apply (rule fg_cons)
apply (simp)
done
from field_desc_adjust_ti(1) [rule_format, OF fg_cons, of "(typ_info_t TYPE('b))"]
have upd_eq:
"update_ti_t (adjust_ti (typ_info_t TYPE('b)) fld (fld_update ∘ (λx _. x))) bs v =
fld_update (λ_. update_ti_t (typ_info_t TYPE('b)) bs (fld v)) v " for bs v
by (simp add: update_desc_def)
from this [of "(to_bytes_p v)" "h_val hp p"]
have val_conv:
"(update_ti (adjust_ti (typ_info_t TYPE('b)) fld (fld_update ∘ (λx _. x))) (to_bytes_p v) (h_val hp p)) =
(fld_update (λ_. v) (h_val hp p))"
apply (simp add: update_ti_t_def size_of_def c_type_class.size_of_def)
by (metis (mono_tags, opaque_lifting) inv_p length_to_bytes_p update_ti_s_from_bytes update_ti_t_def)
note heap_conv = heap_update_padding_field_root_conv' [OF fl match cgrd lbs, of v hp]
show ?thesis
apply (simp add: heap_conv)
apply (simp add: val_conv)
done
qed
lemma heap_update_field_root_conv''':
fixes p::"'a ptr"
assumes fl: "field_ti TYPE('a) f = Some s"
assumes cgrd: "c_guard p"
assumes match: "export_uinfo s = typ_uinfo_t TYPE('b::xmem_type)"
shows "heap_update (PTR('b) &(p→f)) v hp =
heap_update p (update_ti s (to_bytes_p v) (h_val hp p)) hp"
proof -
from fl obtain n where fl': "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n)"
by (auto simp add: field_ti_def split: option.splits)
from heap_update_field_root_conv' [OF fl' match cgrd, of v hp]
show ?thesis
by (simp)
qed
lemma heap_update_padding_field_root_conv''':
fixes p::"'a ptr"
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n)"
assumes cgrd: "c_guard p"
assumes match: "export_uinfo s = typ_uinfo_t TYPE('b::xmem_type)"
assumes lbs: "length bs = size_of TYPE ('b)"
shows "heap_update_padding (PTR('b) &(p→f)) v bs hp =
heap_update_padding p (update_ti s (to_bytes_p v) (h_val hp p))
(super_update_bs bs (heap_list hp (size_of TYPE('a)) (ptr_val p)) n) hp"
proof -
from heap_update_padding_field_root_conv' [OF fl match cgrd lbs, of v hp]
show ?thesis
by (simp)
qed
end
lemma length_array_to_bytes:
fixes arr::"('a::array_outer_max_size['b::array_max_count])"
shows "length (to_bytes arr (heap_list h (CARD('b) * size_of TYPE('a)) (ptr_val p))) =
size_of TYPE('a) * CARD('b)"
by (simp add: lense.access_result_size)
lemma take_drop_append_first: "m + n ≤ length xs ⟹ take n (drop m (xs @ ys)) = take n (drop m xs)"
by simp
lemma size_td_list_array:
"size_td_list
(map (λn. DTuple
(adjust_ti (typ_info_t TYPE('a::xmem_type)) (λx. x.[n])
(λx f. Arrays.update f n x))
(replicate n CHR ''1'')
⦇field_access = xto_bytes ∘ (λx. x.[n]),
field_update = (λx f. Arrays.update f n x) ∘ xfrom_bytes,
field_sz = size_of TYPE('a)⦈)
[0..<n]) = n * size_of TYPE('a) "
proof (induct n)
case 0
then show ?case by simp
next
case (Suc n)
then show ?case by (simp add: size_of_def)
qed
lemma length_access_ti_list_array:
fixes arr::"('a::array_outer_max_size['b::array_max_count])"
assumes lxbs: "length xbs = n * size_of TYPE('a)"
shows
"length (access_ti_list
(map (λn. DTuple
(adjust_ti (typ_info_t TYPE('a)) (λx. x.[n])
(λx f. Arrays.update f n x))
(replicate n CHR ''1'')
⦇field_access = xto_bytes ∘ (λx. x.[n]),
field_update = (λx f. Arrays.update f n x) ∘ xfrom_bytes,
field_sz = size_of TYPE('a)⦈)
[0..<n])
arr xbs) = n * size_of TYPE('a)"
using lxbs
proof (induct n arbitrary: xbs)
case 0
then show ?case by simp
next
case (Suc n)
have lxbs': "length xbs =
size_td_list
(map (λn. DTuple
(adjust_ti (typ_info_t TYPE('a)) (λx. x.[n])
(λx f. Arrays.update f n x))
(replicate n CHR ''1'')
⦇field_access = λa. xto_bytes (a.[n]),
field_update = λa b. Arrays.update b n (xfrom_bytes a),
field_sz = size_td (typ_info_t TYPE('a))⦈)
[0..<n] @
[DTuple (adjust_ti (typ_info_t TYPE('a)) (λx. x.[n]) (λx f. Arrays.update f n x))
(replicate n CHR ''1'')
⦇field_access = λa. xto_bytes (a.[n]),
field_update = λa b. Arrays.update b n (xfrom_bytes a),
field_sz = size_td (typ_info_t TYPE('a))⦈])"
apply simp
apply (subst size_td_list_array [simplified size_of_def comp_def])
using Suc.prems
apply (simp add: size_of_def)
done
from Suc.prems
have ltake: "length (take (n * size_td (typ_info_t TYPE('a))) xbs) =
n * size_td (typ_info_t TYPE('a))"
by (auto simp add: size_of_def)
have llast: "length
(access_ti (typ_info_t TYPE('a)) (arr.[n])
(take (size_td (typ_info_t TYPE('a)))
(drop
(size_td_list
(map (λn. DTuple
(adjust_ti (typ_info_t TYPE('a)) (λx. x.[n])
(λx f. Arrays.update f n x))
(replicate n CHR ''1'')
⦇field_access = λa. xto_bytes (a.[n]),
field_update = λa b. Arrays.update b n (xfrom_bytes a),
field_sz = size_td (typ_info_t TYPE('a))⦈)
[0..<n]))
xbs))) =
size_td (typ_info_t TYPE('a))"
by (simp add: lense.access_result_size size_of_def)
show ?case apply (simp add: size_of_def)
apply (subst access_ti_append [OF lxbs'])
apply (subst size_td_list_array [simplified size_of_def comp_def])
apply simp
apply (subst Suc.hyps [simplified size_of_def comp_def, OF ltake])
apply (simp add: llast)
done
qed
lemma take_drop_take: "m + k ≤ n ⟹ n ≤ length xbs ⟹ take m (drop k (take n xbs)) = take m (drop k xbs)"
proof (induct xbs arbitrary: m k n)
case Nil
then show ?case by simp
next
case (Cons x xbs)
then show ?case by (simp add: take_drop)
qed
lemma access_ti_array_index:
fixes arr::"('a::array_outer_max_size['b::array_max_count])"
assumes bound: "i < n"
assumes lxbs: "length xbs = n * size_of TYPE('a)"
assumes bs: "bs = take (size_of TYPE('a)) (drop (i * (size_of TYPE('a))) xbs)"
shows
"access_ti (typ_info_t TYPE('a)) (arr.[i])
(take (size_of TYPE('a)) (drop (i * size_of TYPE('a)) xbs)) =
take (size_of TYPE('a))
(drop (i * size_of TYPE('a)) (access_ti (array_tag_n n) arr xbs))"
using bound lxbs bs
proof (induct n arbitrary: i xbs bs)
case 0
then show ?case by simp
next
case (Suc n)
from Suc.prems obtain
i_bound: "i < Suc n" and
lxbs: "length xbs = size_of TYPE('a) + n * size_of TYPE('a)" and
bs: "bs = take (size_of TYPE('a)) (drop (i * size_of TYPE('a)) xbs)"
by clarsimp
show ?case
proof (cases "i = n")
case True
show ?thesis
apply (simp add: array_tag_n_eq)
apply (subst access_ti_append)
apply (simp add: size_td_list_array)
apply (simp add: size_of_def lxbs)
apply (subst drop_append_miracle)
apply (subst length_access_ti_list_array)
apply (subst size_td_list_array)
using lxbs
apply (simp add: True)
apply (simp add: True)
apply (simp add: True size_td_list_array)
apply (simp add: size_of_def)
by (simp add: lense.access_result_size size_of_def)
next
case False
from False i_bound have i_bound': "i < n" by simp
from lxbs have lxbs': "length (take (n * size_of TYPE('a)) xbs) = n * size_of TYPE('a)" by simp
from bs i_bound' lxbs' lxbs False
have bs':
"bs = take (size_of TYPE('a))
(drop (i * size_of TYPE('a)) (take (n * size_of TYPE('a)) xbs))"
apply (simp)
apply (subst take_drop_take)
using less_le_mult_nat sz_nzero apply blast
apply simp
apply simp
done
show ?thesis
apply (simp add: array_tag_n_eq)
apply (subst access_ti_append)
apply (simp add: size_td_list_array)
apply (simp add: size_of_def lxbs)
apply (subst take_drop_append_first)
apply (subst length_access_ti_list_array)
apply (subst size_td_list_array)
using lxbs apply (simp add: )
using lxbs i_bound False
apply (metis add.commute less_le_mult_nat mem_type_simps(3) not_less_less_Suc_eq)
apply (subst size_td_list_array)
apply (simp add: bs [symmetric])
using Suc.hyps [where xbs="(take (n * size_of TYPE('a)) xbs)", OF i_bound' lxbs' bs', simplified bs'[symmetric]]
apply (simp)
apply (subst array_tag_n_eq)
apply simp
done
qed
qed
lemma access_ti_array_index':
fixes arr::"('a::array_outer_max_size['b::array_max_count])"
assumes bound: "i < CARD('b)"
assumes lbs: "length xbs = (CARD('b) * size_of TYPE('a))"
assumes bs: "bs = take (size_of TYPE('a)) (drop (i * (size_of TYPE('a))) xbs)"
shows
"access_ti (typ_info_t TYPE('a)) (arr.[i]) bs =
take (size_of TYPE('a))
(drop (i * size_of TYPE('a))
(access_ti (typ_info_t TYPE('a['b])) arr xbs))"
apply (simp add: typ_info_array array_tag_def)
using access_ti_array_index [OF bound lbs bs, where arr=arr, simplified bs [symmetric]]
apply simp
done
lemma fold_index_shift: "fold f [n..<n + m] = fold (λi. f (n + i)) [0..<m]"
proof (induct m arbitrary: n)
case 0
then show ?case by simp
next
case (Suc m)
thus ?case by simp
qed
lemma fold_Suc_index_shift: "fold f [1..<Suc n] = fold (λi. f (Suc i)) [0..<n]"
using fold_index_shift [where n=1 and m=n and f = f]
by simp
lemma sum_list_index_shift: "sum_list (map f [n..<n+m]) = sum_list (map (λi. f (n + i)) [0..<m])"
apply (induct m)
apply auto
done
lemma sum_list_Suc_index_shift: "sum_list (map f [1..<Suc n]) = sum_list (map (λi. f (Suc i)) [0..<n])"
using sum_list_index_shift [where n=1 and m=n and f = f]
by simp
lemma upt_Suc_snoc: "[0..<Suc n] = [0..<n] @ [n]"
by (induct n) auto
lemma sum_list_le_prefix:
fixes sz:: "nat ⇒ nat"
assumes lower: "n ≤ m"
assumes le: "m ≤ k"
shows "sum_list (map sz [n..<m]) ≤ sum_list (map sz [n..<k])"
apply (subst upt_add_eq_append' [OF lower le])
apply simp
done
lemma intvl_off_disj':
fixes x :: addr
assumes ylt: "y ≤ off"
and zoff: "unat x + off + z ≤ addr_card"
shows "{x ..+ y} ∩ {x + of_nat off ..+ z} = {}"
proof (cases "unat x + off + z = addr_card")
case True
then show ?thesis
using ylt zoff
apply (simp add: intvl_def)
apply (safe, clarsimp)
proof -
fix k :: nat and ka :: nat
assume a1: "unat x + off + z = addr_card"
assume a2: "y ≤ off"
assume a3: "k < y"
assume a4: "(word_of_nat k::addr_bitsize word) = word_of_nat off + word_of_nat ka"
assume "ka < z"
then have "ka + off < addr_card"
using a1 by linarith
then show False
using a4 a3 a2 by (metis (no_types) add.commute add_lessD1 len_of_addr_card less_le_trans nat_less_le unat_of_nat_eq word_arith_nat_add)
qed
next
case False
with zoff have le: "off + z < addr_card" by simp
show ?thesis
apply (rule intvl_off_disj [OF ylt])
using le by (simp add: addr_card_wb)
qed
lemma heap_update_list_padding_fold_partition:
fixes v:: "nat ⇒ byte list ⇒ byte list"
and sz:: "nat ⇒ nat"
and off:: "nat ⇒ nat"
assumes no_overflow: "unat a + length bs ≤ addr_card"
assumes partition: "bs = concat (map (λi. take (sz i) (drop (off i) bs)) [0..<m])"
assumes lbs: "length bs = sum_list (map sz [0..<m])"
assumes partition_pbs: "pbs = concat (map (λi. take (sz i) (drop (off i) pbs)) [0..<m])"
assumes lpbs: "length pbs = sum_list (map sz [0..<m])"
assumes off_sz: "⋀i. i < m ⟹ off i = sum_list (map sz [0..<i])"
assumes val: "⋀i. i < m ⟹
v i (take (sz i) (drop (off i) pbs)) =
(take (sz i) (drop (off i) bs))"
shows
"heap_update_list a bs h =
fold (λi h. heap_update_list
(a + word_of_nat (off i))
(v i (take (sz i) (drop (off i) pbs)))
h)
[0..<m] h"
using no_overflow partition lbs partition_pbs lpbs off_sz val
proof (induct m arbitrary: a bs pbs h )
case 0
then show ?case by simp
next
case (Suc m)
from Suc.prems obtain
no_overflow: "unat a + length bs ≤ addr_card" and
bs_partition: "bs = concat (map (λi. take (sz i) (drop (off i) bs)) [0..<Suc m])" and
pbs_partition: "pbs = concat (map (λi. take (sz i) (drop (off i) pbs)) [0..<Suc m])" and
lbs: "length bs = sum_list (map sz [0..<Suc m])" and
lpbs: "length pbs = sum_list (map sz [0..<Suc m])" and
off_sz: "⋀i. i < Suc m ⟹ off i = sum_list (map sz [0..<i])" and
val: "⋀i. i < Suc m ⟹
v i (take (sz i) (drop (off i) pbs)) =
take (sz i) (drop (off i) bs)"
by clarsimp
have unroll: "[0..<Suc m] = [0..<m] @ [m]"
by (rule upt_Suc_snoc)
define bs' where "bs' = concat (map (λi. take (sz i) (drop (off i) bs)) [0..<m])"
define bsm where "bsm = take (sz m) (drop (off m) bs)"
define pbs' where "pbs' = concat (map (λi. take (sz i) (drop (off i) pbs)) [0..<m])"
define pbsm where "pbsm = take (sz m) (drop (off m) pbs)"
from bs_partition have bs: "bs = bs' @ bsm"
unfolding bsm_def bs'_def
apply (subst (asm) unroll)
apply simp
done
from pbs_partition have pbs: "pbs = pbs' @ pbsm"
unfolding pbsm_def pbs'_def
apply (subst (asm) unroll)
apply simp
done
from lbs have lbs1: "length bs = sum_list (map sz [0..<m]) + sz m"
apply (subst (asm) unroll)
apply simp
done
from lpbs have lpbs1: "length pbs = sum_list (map sz [0..<m]) + sz m"
apply (subst (asm) unroll)
apply simp
done
have lbsm: "length bsm = sz m"
apply (simp add: bsm_def)
using lbs1 off_sz [of m]
apply simp
done
have lpbsm: "length pbsm = sz m"
apply (simp add: pbsm_def)
using lpbs1 off_sz [of m]
apply simp
done
from lbsm lbs1 have lbs': "length bs' = sum_list (map sz [0..<m])"
apply (subst (asm) bs)
apply simp
done
from lpbsm lpbs1 have lpbs': "length pbs' = sum_list (map sz [0..<m])"
apply (subst (asm) pbs)
apply simp
done
from off_sz have off_sz': "(⋀i. i < m ⟹ off i = sum_list (map sz [0..<i])) " by auto
{
fix i
assume bound: "i < m"
hence bound': "i < Suc m" by simp
from val [OF this]
have v_i: "v i (take (sz i) (drop (off i) pbs)) =
take (sz i) (drop (off i) bs)" .
from off_sz [OF bound'] have off_i: "off i = sum_list (map sz [0..<i])".
from off_sz [of m] have off_m: "off m = sum_list (map sz [0..<m])" by simp
from bound have "Suc i ≤ m" by simp
from sum_list_le_prefix [where n=0, OF _ this]
have *: "sum_list (map sz [0..<Suc i]) ≤ sum_list (map sz [0..<m])" by simp
then have bound_bs': "off i + sz i ≤ length bs'" using off_i lbs' by simp
from * have bound_pbs': "off i + sz i ≤ length pbs'" using off_i lpbs' by simp
have take_eq1: "take (sz i) (drop (off i) bs) = take (sz i) (drop (off i) bs')"
apply (subst bs)
apply (subst take_drop_append_first [OF bound_bs'])
apply simp
done
have take_eq2: "take (sz i) (drop (off i) pbs) = take (sz i) (drop (off i) pbs')"
apply (subst pbs)
apply (subst take_drop_append_first [OF bound_pbs'])
apply simp
done
from v_i
have "v i (take (sz i) (drop (off i) pbs')) =
take (sz i) (drop (off i) bs')"
by (simp add: take_eq1 take_eq2)
} note val' = this
from no_overflow
have no_overflow': "unat a + length bs' ≤ addr_card "
by (simp add: bs)
{
fix i
assume bound: "i < m"
hence bound': "i < Suc m" by simp
from bound have "Suc i ≤ m" by simp
from sum_list_le_prefix [where n=0, OF _ this]
have sum_le: "sum_list (map sz [0..<Suc i]) ≤ sum_list (map sz [0..<m])" by simp
from off_sz [OF bound'] have off_i: "off i = sum_list (map sz [0..<i])".
have "take (sz i) (drop (off i) bs) = take (sz i) (drop (off i) bs')"
apply (subst bs)
using lbs' sum_le off_i
apply simp
done
} note take_drop_eq = this
from take_drop_eq
have map_eq: "map (λi. take (sz i) (drop (off i) bs)) [0..<m] =
map (λi. take (sz i) (drop (off i) bs')) [0..<m]"
by simp
{
fix i
assume bound: "i < m"
hence bound': "i < Suc m" by simp
from bound have "Suc i ≤ m" by simp
from sum_list_le_prefix [where n=0, OF _ this]
have sum_le: "sum_list (map sz [0..<Suc i]) ≤ sum_list (map sz [0..<m])" by simp
from off_sz [OF bound'] have off_i: "off i = sum_list (map sz [0..<i])".
have "take (sz i) (drop (off i) pbs) = take (sz i) (drop (off i) pbs')"
apply (subst pbs)
using lpbs' sum_le off_i
apply simp
done
} note take_drop_eq' = this
from take_drop_eq'
have map_eq': "map (λi. take (sz i) (drop (off i) pbs)) [0..<m] =
map (λi. take (sz i) (drop (off i) pbs')) [0..<m]"
by simp
from bs_partition have bs'_partition: "bs' = concat (map (λi. take (sz i) (drop (off i) bs')) [0..<m])"
apply (subst map_eq [symmetric])
apply (simp add: bs'_def)
done
from pbs_partition have pbs'_partition: "pbs' = concat (map (λi. take (sz i) (drop (off i) pbs')) [0..<m])"
apply (subst map_eq' [symmetric])
apply (simp add: pbs'_def)
done
from lbs' off_sz [of m]
have off_m: "off m = length bs'"
by simp
have vm_eq: " (v m (take (sz m) (drop (length bs') pbs') @
take (sz m - (length pbs' - length bs')) (drop (length bs' - length pbs') pbsm))) = bsm"
by (metis bsm_def drop_append length_drop lessI off_m pbs take_append val)
have fold_pbs':
"(fold
(λi. heap_update_list (a + word_of_nat (off i)) (v i (take (sz i) (drop (off i) pbs))))
[0..<m] h) =
(fold
(λi. heap_update_list (a + word_of_nat (off i)) (v i (take (sz i) (drop (off i) pbs'))))
[0..<m] h)"
apply (rule fold_cong)
using take_drop_eq' by auto
note hyp = Suc.hyps [where a=a and bs=bs' and pbs=pbs' and h=h, OF no_overflow' bs'_partition lbs' pbs'_partition lpbs' off_sz' val']
show ?case
apply (subst unroll)
apply (subst fold_append)
apply (simp only: comp_def)
apply (subst bs)
apply (subst fold_pbs')
apply (subst pbs)
apply (subst heap_update_list_concat_unfold)
apply (subst hyp [ symmetric])
apply assumption
apply (simp add: off_m vm_eq)
done
qed
lemma heap_update_list_fold_partition:
fixes v:: "nat ⇒ byte list ⇒ byte list"
and sz:: "nat ⇒ nat"
and off:: "nat ⇒ nat"
assumes no_overflow: "unat a + length bs ≤ addr_card"
assumes partition: "bs = concat (map (λi. take (sz i) (drop (off i) bs)) [0..<m])"
assumes lbs: "length bs = sum_list (map sz [0..<m])"
assumes off_sz: "⋀i. i < m ⟹ off i = sum_list (map sz [0..<i])"
assumes val: "⋀i. i < m ⟹
v i (take (sz i) (drop (off i) (heap_list h (length bs) a))) =
(take (sz i) (drop (off i) bs))"
shows
"heap_update_list a bs h =
fold (λi h. heap_update_list
(a + word_of_nat (off i))
(v i ((heap_list h (sz i) (a + word_of_nat (off i)))))
h)
[0..<m] h"
using no_overflow partition lbs off_sz val
proof (induct m arbitrary: a bs h )
case 0
then show ?case by simp
next
case (Suc m)
from Suc.prems obtain
no_overflow: "unat a + length bs ≤ addr_card" and
bs_partition: "bs = concat (map (λi. take (sz i) (drop (off i) bs)) [0..<Suc m])" and
lbs: "length bs = sum_list (map sz [0..<Suc m])" and
off_sz: "⋀i. i < Suc m ⟹ off i = sum_list (map sz [0..<i])" and
val: "⋀i. i < Suc m ⟹
v i (take (sz i) (drop (off i) (heap_list h (length bs) a))) =
take (sz i) (drop (off i) bs)"
by clarsimp
have unroll: "[0..<Suc m] = [0..<m] @ [m]"
by (rule upt_Suc_snoc)
define bs' where "bs' = concat (map (λi. take (sz i) (drop (off i) bs)) [0..<m])"
define bsm where "bsm = take (sz m) (drop (off m) bs)"
from bs_partition have bs: "bs = bs' @ bsm"
unfolding bsm_def bs'_def
apply (subst (asm) unroll)
apply simp
done
from lbs have lbs1: "length bs = sum_list (map sz [0..<m]) + sz m"
apply (subst (asm) unroll)
apply simp
done
have lbsm: "length bsm = sz m"
apply (simp add: bsm_def)
using lbs1 off_sz [of m]
apply simp
done
with lbs1 have lbs': "length bs' = sum_list (map sz [0..<m])"
apply (subst (asm) bs)
apply simp
done
from off_sz have off_sz': "(⋀i. i < m ⟹ off i = sum_list (map sz [0..<i])) " by auto
{
fix i
assume bound: "i < m"
hence bound': "i < Suc m" by simp
from val [OF this]
have v_i: "v i (take (sz i) (drop (off i) (heap_list h (length bs) a))) =
take (sz i) (drop (off i) bs)" .
from off_sz [OF bound'] have off_i: "off i = sum_list (map sz [0..<i])".
from off_sz [of m] have off_m: "off m = sum_list (map sz [0..<m])" by simp
from bound have "Suc i ≤ m" by simp
from sum_list_le_prefix [where n=0, OF _ this]
have "sum_list (map sz [0..<Suc i]) ≤ sum_list (map sz [0..<m])" by simp
then have bound_bs': "off i + sz i ≤ length bs'" using off_i lbs' by simp
have take_eq1: "take (sz i) (drop (off i) bs) = take (sz i) (drop (off i) bs')"
apply (subst bs)
apply (subst take_drop_append_first [OF bound_bs'])
apply simp
done
have take_eq2:
"take (sz i) (drop (off i) (heap_list h (length bs) a)) =
take (sz i) (drop (off i) (heap_list h (length bs') a))"
apply (subst lbs1)
apply (subst lbs')
apply (subst heap_list_split2)
using bound_bs' [simplified lbs']
apply simp
done
from v_i
have "v i (take (sz i) (drop (off i) (heap_list h (length bs') a))) =
take (sz i) (drop (off i) bs')"
by (simp add: take_eq1 take_eq2)
} note val' = this
from no_overflow
have no_overflow': "unat a + length bs' ≤ addr_card "
by (simp add: bs)
{
fix i
assume bound: "i < m"
hence bound': "i < Suc m" by simp
from bound have "Suc i ≤ m" by simp
from sum_list_le_prefix [where n=0, OF _ this]
have sum_le: "sum_list (map sz [0..<Suc i]) ≤ sum_list (map sz [0..<m])" by simp
from off_sz [OF bound'] have off_i: "off i = sum_list (map sz [0..<i])".
have "take (sz i) (drop (off i) bs) = take (sz i) (drop (off i) bs')"
apply (subst bs)
using lbs' sum_le off_i
apply simp
done
} note take_drop_eq = this
from take_drop_eq
have map_eq: "map (λi. take (sz i) (drop (off i) bs)) [0..<m] =
map (λi. take (sz i) (drop (off i) bs')) [0..<m]"
by simp
from bs_partition have bs'_partition: "bs' = concat (map (λi. take (sz i) (drop (off i) bs')) [0..<m])"
apply (subst map_eq [symmetric])
apply (simp add: bs'_def)
done
from lbs' off_sz [of m]
have off_m: "off m = length bs'"
by simp
have vm_eq: "v m (heap_list (heap_update_list a bs' h) (sz m) (a + word_of_nat (length bs'))) = bsm"
proof -
from val [of m]
have "v m (take (sz m) (drop (off m) (heap_list h (length bs) a))) = bsm" by (simp add: bsm_def)
moreover
have disj: "{a..+length bs'} ∩ {a + word_of_nat (length bs')..+sz m} = {}"
apply (simp add: lbs')
apply (rule intvl_off_disj')
apply simp
using no_overflow [simplified lbs1]
apply (simp)
done
have "heap_list (heap_update_list a bs' h) (sz m) (a + word_of_nat (length bs')) =
take (sz m) (drop (off m) (heap_list h (length bs) a))"
apply (subst heap_list_update_disjoint_same [OF disj])
apply (subst lbs1 )
apply (subst lbs' )
apply (subst heap_list_take_drop' [OF no_overflow [simplified lbs1]])
apply (simp add: off_m [simplified lbs'])
apply (simp add: off_m [simplified lbs'])
done
ultimately show ?thesis by simp
qed
show ?case
apply (subst unroll)
apply (subst fold_append)
apply (simp only: comp_def)
apply (subst bs)
apply (subst heap_update_list_concat_unfold)
apply (subst Suc.hyps [where a=a and bs=bs' and h=h, OF no_overflow' bs'_partition lbs' off_sz' val', symmetric])
apply assumption
apply (simp add: off_m vm_eq)
done
qed
lemma heap_list_map_partition:
fixes sz:: "nat ⇒ nat"
and off:: "nat ⇒ nat"
assumes no_overflow: "unat a + n ≤ addr_card"
assumes lbs: "n = sum_list (map sz [0..<m])"
assumes off_sz: "⋀i. i < m ⟹ off i = sum_list (map sz [0..<i])"
shows
"heap_list h n a =
concat (map (λi. heap_list h (sz i) (a + word_of_nat (off i))) [0..<m])"
using no_overflow lbs off_sz
proof (induct m arbitrary: n a)
case 0
then show ?case by simp
next
case (Suc m)
from Suc.prems obtain
no_overflow: "unat a + n ≤ addr_card" and
lbs: "n = sum_list (map sz [0..<Suc m])" and
off_sz: "⋀i. i < Suc m ⟹ off i = sum_list (map sz [0..<i])"
by clarsimp
have unroll: "[0..<Suc m] = [0..<m] @ [m]"
by (rule upt_Suc_snoc)
from lbs have lbs1: "n = sum_list (map sz [0..<m]) + sz m"
apply (subst (asm) unroll)
apply simp
done
from no_overflow lbs1
have no_overflow': "unat a + (n - sz m) ≤ addr_card"
by simp
from lbs1
have lbs1': "n - sz m = sum_list (map sz [0..<m])"
by simp
from lbs1 lbs1'
have sz_m: "(n - (n - sz m)) = sz m"
by simp
from heap_list_split [where k="n - sz m" and n = n and h=h and x=a]
have split: "heap_list h n a = heap_list h (n - sz m) a @ heap_list h (sz m) (a + word_of_nat (n - sz m))"
by (simp add: sz_m)
have hyp: "heap_list h (n - sz m) a = concat (map (λi. heap_list h (sz i) (a + word_of_nat (off i))) [0..<m]) "
apply (rule Suc.hyps [OF no_overflow' lbs1'])
using off_sz
by auto
from off_sz [of m] lbs1
have off_m: "(n - sz m) = off m"
by simp
show ?case
apply (subst split)
apply (subst unroll)
apply (simp add: hyp )
apply (simp add: off_m)
done
qed
lemma array_partition:
assumes lbs: "length bs = m * n"
shows "concat (map (λi. take n (drop (i * n) bs)) [0..<m]) = bs"
using lbs
proof (induct m arbitrary: bs n)
case 0
then show ?case by simp
next
case (Suc m)
have lbs: "length bs = Suc m * n" by fact
hence lbs: "length bs = (m * n) + n"
by simp
define bs' where "bs' = take (m * n) bs"
define bs_last where "bs_last = drop (m * n) bs"
from lbs have bs: "bs = bs' @ bs_last"
by (simp add: bs'_def bs_last_def)
from lbs bs
have lbs': "length bs' = m * n"
by (metis add_diff_cancel_left' add_diff_cancel_right' bs_last_def eq_concat_lenD length_drop)
from lbs bs lbs' have lbs_last: "length bs_last = n"
by auto
{
fix i
assume bound: "i < m"
have " take n (drop (i * n) bs) = take n (drop (i * n) bs')"
apply (subst bs)
using lbs' lbs_last bound
apply simp
by (metis Suc_leI mult_Suc mult_le_mono order_refl)
}
then
have map_eq: "(map (λi. take n (drop (i * n) bs)) [0..<m]) = (map (λi. take n (drop (i * n) bs')) [0..<m])"
by simp
note hyp = Suc.hyps [OF lbs']
show ?case
apply simp
apply (simp add: map_eq hyp )
apply (simp add: bs_last_def [symmetric])
using lbs_last
apply (simp add: bs)
done
qed
lemma sum_list_const_fun: "sum_list (map (λ_. n::nat) [0..<m]) = m * n"
by (induct m) auto
lemmas export_uinfo_adjust_ti [simp] = export_tag_adjust_ti(1)[rule_format]
lemma heap_update_list_array:
fixes arr:: "('a::array_outer_max_size['b::array_max_count])"
fixes p:: "('a['b]) ptr"
assumes cgrd: "c_guard p"
shows
"heap_update_list (ptr_val p) (to_bytes arr (heap_list h (size_of TYPE('a['b])) (ptr_val p))) h =
fold
(λi h. heap_update_list (ptr_val (array_ptr_index p False i))
(to_bytes (arr.[i])
(heap_list h (size_of TYPE('a)) (ptr_val (array_ptr_index p False i))))
h)
[0..<CARD('b)] h"
proof -
define xbs where
"xbs= (to_bytes arr (heap_list h (size_of TYPE('a['b])) (ptr_val p)))"
define sz::"nat ⇒ nat" where
"sz = (λ_. size_of TYPE('a))"
define off::"nat ⇒ nat" where
"off = (λi. i * size_of TYPE('a))"
define v::"nat ⇒ byte list ⇒ byte list" where
"v = (λi bs. (to_bytes (arr.[i]) bs))"
have lxbs: "length xbs = CARD('b) * size_of TYPE('a)"
by (simp add: xbs_def)
from c_guard_no_wrap' [OF cgrd] lxbs
have no_overflow: "unat (ptr_val p) + length xbs ≤ addr_card "
by simp
have partition: "xbs = concat (map (λi. take (sz i) (drop (off i) xbs)) [0..<CARD('b)]) "
apply (simp add: sz_def off_def)
apply (rule array_partition [symmetric, OF lxbs])
done
have "sum_list (map sz [0..<CARD('b)]) = CARD('b) * size_of TYPE('a)"
apply (simp add: sz_def)
apply (rule sum_list_const_fun)
done
with lxbs have lxbs_sum: "length xbs = sum_list (map sz [0..<CARD('b)])" by simp
have off_sz: "(⋀i. i < CARD('b) ⟹ off i = sum_list (map sz [0..<i])) "
unfolding off_def sz_def using sum_list_const_fun
by auto
{
fix i
assume i_bound: "i < CARD('b)"
have eq_padding:
"eq_padding (typ_uinfo_t TYPE('a['b]))
xbs
(heap_list h (size_of TYPE('a['b])) (ptr_val p))"
using eq_padding_to_bytes heap_list_length xbs_def by blast
from field_lookup_array [OF i_bound, where i=0, simplified]
have fl: "field_lookup (typ_info_t TYPE('a['b])) [replicate i CHR ''1''] 0 =
Some (adjust_ti (typ_info_t TYPE('a)) (λx. x.[i]) (λx f. Arrays.update f i x), i * size_of TYPE('a))" .
have exp:
"(export_uinfo
(adjust_ti (typ_info_t TYPE('a)) (λx::'a['b]. (x.[i])) (λx f. Arrays.update f i x))) =
typ_uinfo_t TYPE('a)"
apply (subst export_uinfo_adjust_ti)
apply (rule fg_cons_array [OF i_bound] )
apply simp
apply (simp add: typ_uinfo_t_def)
done
from xmem_type_field_lookup_eq_padding_focus [OF fl _ _ eq_padding ]
have
"eq_padding (typ_uinfo_t TYPE('a))
(take (size_of TYPE('a)) (drop (i * size_of TYPE('a)) xbs))
(take (size_of TYPE('a)) (drop (i * size_of TYPE('a)) (heap_list h (size_of TYPE('a['b])) (ptr_val p))))"
using lxbs
by simp (simp add: exp size_of_def)
hence eq1:
"to_bytes (arr.[i]) (take (size_of TYPE('a)) (drop (i * size_of TYPE('a)) xbs)) =
to_bytes (arr.[i]) (take (size_of TYPE('a)) (drop (i * size_of TYPE('a)) (heap_list h (size_of TYPE('a['b])) (ptr_val p))))"
by (meson eq_padding_to_bytes_eq)
have "v i (take (sz i) (drop (off i) (heap_list h (length xbs) (ptr_val p)))) =
take (sz i) (drop (off i) xbs)"
unfolding v_def lxbs sz_def off_def
apply (simp add: xbs_def)
using access_ti_array_index' [OF i_bound lxbs, where arr=arr, OF refl, simplified xbs_def, simplified to_bytes_def [symmetric]]
apply (simp only: xbs_def [symmetric])
apply (subst (asm) eq1)
apply simp
using eq_padding eq_padding_to_bytes_eq by fastforce
} note v_padding = this
{
fix i
assume i_bound: "i < CARD('b)"
have "ptr_val p + word_of_nat i * word_of_nat (size_of TYPE('a))
=
ptr_val (PTR_COERCE('a['b] → 'a) p +⇩p int i)"
by (simp add: CTypesDefs.ptr_add_def)
} note deref_conv = this
note partition = heap_update_list_fold_partition [where a="ptr_val p" and bs=xbs and sz=sz and off=off and v=v
and h=h and
m="CARD('b)", OF no_overflow partition lxbs_sum off_sz v_padding, simplified]
show ?thesis
apply (simp only: xbs_def [symmetric])
apply (subst partition)
apply (rule fold_cong)
apply simp
apply simp
apply (simp add: v_def sz_def off_def array_ptr_index_def deref_conv)
done
qed
lemma heap_update_array:
fixes arr:: "('a::array_outer_max_size['b::array_max_count])"
fixes p:: "('a['b]) ptr"
assumes cgrd: "c_guard p"
shows
"heap_update p arr h =
fold
(λi h. heap_update (array_ptr_index p False i) (arr.[i]) h)
[0..<CARD('b)] h"
using heap_update_list_array [OF cgrd]
by (simp only: heap_update_def)
lemma heap_update_array_pointless:
fixes arr:: "('a::array_outer_max_size['b::array_max_count])"
fixes p:: "('a['b]) ptr"
assumes cgrd: "c_guard p"
shows
"heap_update p arr =
fold
(λi h. heap_update (array_ptr_index p False i) (arr.[i]) h)
[0..<CARD('b)]"
using heap_update_array [OF cgrd]
by (simp add: fun_eq_iff)
lemma heap_update_padding_list_array:
fixes arr:: "('a::array_outer_max_size['b::array_max_count])"
fixes p:: "('a['b]) ptr"
assumes cgrd: "c_guard p"
assumes lbs: "length bs = CARD('b) * size_of TYPE('a)"
shows
"heap_update_list (ptr_val p) (to_bytes arr bs) h =
fold
(λi h. heap_update_list (ptr_val (array_ptr_index p False i))
(to_bytes (arr.[i])
(take (size_of TYPE('a)) (drop (i * size_of TYPE('a)) bs)))
h)
[0..<CARD('b)] h"
proof -
define xbs where
"xbs= (to_bytes arr bs)"
define sz::"nat ⇒ nat" where
"sz = (λ_. size_of TYPE('a))"
define off::"nat ⇒ nat" where
"off = (λi. i * size_of TYPE('a))"
define v::"nat ⇒ byte list ⇒ byte list" where
"v = (λi bs. (to_bytes (arr.[i]) bs))"
have lxbs: "length xbs = CARD('b) * size_of TYPE('a)"
by (simp add: xbs_def lbs)
from c_guard_no_wrap' [OF cgrd] lxbs
have no_overflow: "unat (ptr_val p) + length xbs ≤ addr_card "
by simp
have partition: "xbs = concat (map (λi. take (sz i) (drop (off i) xbs)) [0..<CARD('b)]) "
apply (simp add: sz_def off_def)
apply (rule array_partition [symmetric, OF lxbs])
done
have partition_bs: "bs = concat (map (λi. take (sz i) (drop (off i) bs)) [0..<CARD('b)]) "
apply (simp add: sz_def off_def)
apply (rule array_partition [symmetric, OF lbs])
done
have *: "sum_list (map sz [0..<CARD('b)]) = CARD('b) * size_of TYPE('a)"
apply (simp add: sz_def)
apply (rule sum_list_const_fun)
done
with lxbs have lxbs_sum: "length xbs = sum_list (map sz [0..<CARD('b)])" by simp
from lbs * have lbs_sum: "length bs = sum_list (map sz [0..<CARD('b)])" by simp
have off_sz: "(⋀i. i < CARD('b) ⟹ off i = sum_list (map sz [0..<i])) "
unfolding off_def sz_def using sum_list_const_fun
by auto
have val_eq: "⋀i. i < CARD('b) ⟹ v i (take (sz i) (drop (off i) bs)) = take (sz i) (drop (off i) xbs)"
unfolding off_def sz_def v_def xbs_def
apply (simp add: to_bytes_def)
apply (subst access_ti_array_index' [where xbs=bs, OF _ lbs])
apply auto
done
have val_eq':
"⋀i. i < CARD('b) ⟹ (v i (take (sz i) (drop (off i) bs))) =
(to_bytes (arr.[i]) (take (size_of TYPE('a)) (drop (i * size_of TYPE('a)) bs)))"
unfolding off_def sz_def v_def
by simp
have idx_eq: "⋀i. i < CARD('b) ⟹
(ptr_val p + word_of_nat (off i)) = (ptr_val (array_ptr_index p False i))"
unfolding off_def array_ptr_index_def
by (auto simp add: c_type_class.ptr_add_def)
note partition = heap_update_list_padding_fold_partition [where a="ptr_val p" and bs= xbs and pbs = bs and sz=sz and off=off and v=v and h=h and m="CARD('b)",
OF no_overflow partition lxbs_sum partition_bs lbs_sum off_sz val_eq]
show ?thesis
apply (simp only: xbs_def [symmetric])
apply (subst partition)
apply (assumption)
apply (rule fold_cong)
apply (auto simp add: val_eq' idx_eq)
done
qed
lemma heap_update_padding_array:
fixes arr:: "('a::array_outer_max_size['b::array_max_count])"
fixes p:: "('a['b]) ptr"
assumes cgrd: "c_guard p"
assumes lbs: "length bs = CARD('b) * size_of TYPE('a)"
shows
"heap_update_padding p arr bs h =
fold
(λi h. heap_update_padding (array_ptr_index p False i) (arr.[i]) (take (size_of TYPE('a)) (drop (i * size_of TYPE('a)) bs)) h)
[0..<CARD('b)] h"
using heap_update_padding_list_array [OF cgrd lbs]
by (simp only: heap_update_padding_def)
lemma heap_update_padding_array_pointless:
fixes arr:: "('a::array_outer_max_size['b::array_max_count])"
fixes p:: "('a['b]) ptr"
assumes cgrd: "c_guard p"
assumes lbs: "length bs = CARD('b) * size_of TYPE('a)"
shows
"heap_update_padding p arr bs =
fold
(λi h. heap_update_padding (array_ptr_index p False i) (arr.[i]) (take (size_of TYPE('a)) (drop (i * size_of TYPE('a)) bs)) h)
[0..<CARD('b)]"
using heap_update_padding_array [OF cgrd lbs]
by (simp add: fun_eq_iff)
lemma c_guard_array_ptr_index:
fixes p:: "(('a :: mem_type)['b :: finite]) ptr"
assumes cgrd: "c_guard p"
assumes bound: "n < CARD('b)"
shows "c_guard (array_ptr_index p coerce n)"
using cgrd bound
apply (simp add: array_ptr_index_def c_guard_def)
apply (clarsimp, safe)
subgoal
apply (simp add: ptr_aligned_def)
by (metis ptr_aligned_def ptr_aligned_plus ptr_val_ptr_coerce)
subgoal
supply fun_upd_apply[simp del]
apply (simp add: c_null_guard_def)
apply (simp add: CTypesDefs.ptr_add_def field_simps)
by (auto simp add: intvl_def)
(metis (no_types, opaque_lifting) Abs_fnat_hom_mult add.commute group_cancel.add1 nat_index_bound word_of_nat_plus)
done
lemma heap_update_array_update:
assumes n: "n < CARD('b :: array_max_count)"
assumes size: "CARD('b) * size_of TYPE('a :: array_outer_max_size) < 2 ^ addr_bitsize"
assumes cgrd: "c_guard p"
shows "heap_update p (Arrays.update (arr :: 'a['b]) n v) hp
= heap_update (array_ptr_index p False n) v (heap_update p arr hp)"
proof -
have P: "⋀x k. ⟦ x < CARD('b); k < size_of TYPE('a) ⟧
⟹ unat (of_nat x * of_nat (size_of TYPE('a)) + (of_nat k :: addr))
= x * size_of TYPE('a) + k"
using size
supply unsigned_of_nat [simp del]
apply (cases "size_of TYPE('a)", simp_all)
apply (cases "CARD('b)", simp_all)
apply (subst unat_add_lem[THEN iffD1])
apply (simp add: unat_word_ariths unat_of_nat less_Suc_eq_le)
subgoal premises prems for x k nat nata
proof -
have "Suc x * size_of TYPE('a) < 2 ^ addr_bitsize"
using prems
apply simp
apply (erule order_le_less_trans[rotated], simp add: add_mono)
done
then show ?thesis using prems by simp
qed
apply (subst unat_mult_lem[THEN iffD1])
apply (simp add: unat_of_nat unat_add_lem[THEN iffD1])
apply (rule order_less_le_trans, erule order_le_less_trans[rotated],
rule add_mono, simp+)
apply (simp add: less_Suc_eq_le trans_le_add2)
apply simp
apply (simp add: unat_of_nat unat_add_lem[THEN iffD1])
done
let ?key_upd = "heap_update (array_ptr_index p False n) v"
note commute = fold_commute_apply[where h="?key_upd"
and xs="[Suc n ..< CARD('b)]", where g=f' and f=f' for f']
from cgrd n
have cgrd': "c_guard (array_ptr_index p False n)"
by (rule c_guard_array_ptr_index)
show ?thesis using n
apply (simp add: heap_update_array [OF cgrd] split_upt_on_n[OF n]
)
apply (subst commute)
subgoal for x
apply (rule ext, simp)
apply (rule heap_update_commute, simp_all add: ptr_add_def)
apply (simp add: array_ptr_index_def CTypesDefs.ptr_add_def intvl_def Suc_le_eq)
apply (rule set_eqI, clarsimp)
apply (drule word_unat.Rep_inject[THEN iffD2])
apply (clarsimp simp: P nat_eq_add_iff1)
apply (cases x, simp_all add: less_Suc_eq_le Suc_diff_le)
done
subgoal
apply (subst heap_update_collapse)
apply (simp cong: fold_cong')
done
done
qed
lemma heap_update_array_element'':
fixes p' :: "(('a ::array_outer_max_size)['b::array_max_count]) ptr"
fixes p :: "('a :: array_outer_max_size) ptr"
fixes hp w
assumes p: "p = array_ptr_index p' False n"
assumes n: "n < CARD('b)"
assumes cgrd: "c_guard p'"
assumes size: "CARD('b) * size_of TYPE('a) < 2 ^ addr_bitsize"
shows "heap_update p' (Arrays.update (h_val hp p') n w) hp
= heap_update p w hp"
apply (subst heap_update_array_update[OF n size cgrd])
apply (simp add: heap_update_id p)
done
lemmas heap_update_array_element'
= heap_update_array_element''[simplified array_ptr_index_simps]
lemma (in array_outer_max_size) array_count_size:
"CARD('b :: array_max_count) * size_of TYPE('a ) < 2 ^ addr_bitsize"
using array_outer_max_size_ax[] array_max_count_ax[where 'a='b]
apply (clarsimp dest!: nat_le_Suc_less_imp)
apply (drule(1) mult_mono, simp+)
done
lemmas heap_update_array_element
= heap_update_array_element'[OF refl _ _ array_count_size]
primrec
field_names_u :: "typ_uinfo ⇒ typ_uinfo ⇒
(qualified_field_name) list" and
field_names_struct_u :: "typ_uinfo_struct ⇒ typ_uinfo ⇒
(qualified_field_name) list" and
field_names_list_u :: "typ_uinfo_tuple list ⇒ typ_uinfo ⇒
(qualified_field_name) list" and
field_names_tuple_u :: "typ_uinfo_tuple ⇒ typ_uinfo ⇒
(qualified_field_name) list"
where
tufs0: "field_names_u (TypDesc algn st nm) t = (if t= (TypDesc algn st nm) then
[[]] else field_names_struct_u st t)"
| tufs1: "field_names_struct_u (TypScalar m algn d) t = []"
| tufs2: "field_names_struct_u (TypAggregate xs) t = field_names_list_u xs t"
| tufs3: "field_names_list_u [] t = []"
| tufs4: "field_names_list_u (x#xs) t = field_names_tuple_u x t@field_names_list_u xs t"
| tufs5: "field_names_tuple_u (DTuple s f d) t = map (λfs. f#fs) (field_names_u s t)"
lemma field_names_u_field_names_export_uinfo_conv:
fixes t :: "('a, 'b) typ_info" and
st :: "('a, 'b) typ_info_struct" and
ts :: "('a, 'b) typ_info_tuple list" and
x :: "('a, 'b) typ_info_tuple"
shows
"field_names_u (export_uinfo t) s = field_names t s"
"field_names_struct_u (map_td_struct field_norm (λ_. ()) st) s = field_names_struct st s"
"field_names_list_u (map_td_list field_norm (λ_. ()) ts) s = field_names_list ts s"
"field_names_tuple_u (map_td_tuple field_norm (λ_. ()) x) s = field_names_tuple x s"
by (induct t and st and ts and x ) (auto simp add: export_uinfo_def)
primrec
all_field_names :: "('a, 'b) typ_desc ⇒
(qualified_field_name) list" and
all_field_names_struct :: "('a, 'b) typ_struct ⇒
(qualified_field_name) list" and
all_field_names_list :: "(('a, 'b) typ_desc, field_name, 'b) dt_tuple list ⇒
(qualified_field_name) list" and
all_field_names_tuple :: "(('a, 'b) typ_desc, field_name, 'b) dt_tuple ⇒
(qualified_field_name) list"
where
afs0: "all_field_names (TypDesc algn st nm) =
[[]] @ all_field_names_struct st"
| afs1: "all_field_names_struct (TypScalar m algn d) = []"
| afs2: "all_field_names_struct (TypAggregate xs) = all_field_names_list xs"
| afs3: "all_field_names_list [] = []"
| afs4: "all_field_names_list (x#xs) = all_field_names_tuple x @ all_field_names_list xs"
| afs5: "all_field_names_tuple (DTuple s f d) = map (λfs. f#fs) (all_field_names s)"
lemma field_lookup_all_field_names:
fixes t::"('a, 'b) typ_desc"
and st::"('a, 'b) typ_struct"
and ts::"('a, 'b) typ_tuple list"
and x::"('a, 'b) typ_tuple"
shows
"field_lookup t f m = Some (s, n) ⟹ f ∈ set (all_field_names t)" and
"field_lookup_struct st f m = Some (s, n) ⟹ f ∈ set (all_field_names_struct st)" and
"field_lookup_list ts f m = Some (s, n) ⟹ f ∈ set (all_field_names_list ts)" and
"field_lookup_tuple x f m = Some (s, n) ⟹ f ∈ set (all_field_names_tuple x)"
proof (induct t and st and ts and x arbitrary: f m n s and f m n s and f m n s and f m n s)
case (TypDesc nat typ_struct list)
then show ?case by (auto split: if_split_asm)
next
case (TypScalar nat1 nat2 a)
then show ?case by auto
next
case (TypAggregate list)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc dt_tuple list)
then show ?case by (auto split: option.splits)
next
case (DTuple_typ_desc typ_desc list b)
then show ?case by (auto split: if_split_asm)
(metis imageI list.exhaust_sel)
qed
lemma field_names_subset_all_field_names:
fixes t :: "typ_uinfo" and
st :: "typ_uinfo_struct" and
ts :: "typ_uinfo_tuple list" and
x :: "typ_uinfo_tuple"
shows
"set (field_names_u t s) ⊆ set (all_field_names t)"
"set (field_names_struct_u st s) ⊆ set (all_field_names_struct st)"
"set (field_names_list_u ts s) ⊆ set (all_field_names_list ts)"
"set (field_names_tuple_u x s) ⊆ set (all_field_names_tuple x)"
by (induct t and st and ts and x arbitrary: s and s and s and s) auto
lemma empty_all_field_names:
fixes t :: "typ_uinfo" and
st :: "typ_uinfo_struct" and
ts :: "typ_uinfo_tuple list" and
x :: "typ_uinfo_tuple"
shows
"[] ∈ set (all_field_names t)"
"[] ∉ set (all_field_names_struct st)"
"[] ∉ set (all_field_names_list ts)"
"[] ∉ set (all_field_names_tuple x)"
by (induct t and st and ts and x ) auto
lemma empty_field_names_u:
fixes t :: "typ_uinfo" and
st :: "typ_uinfo_struct" and
ts :: "typ_uinfo_tuple list" and
x :: "typ_uinfo_tuple"
shows
"True"
"[] ∉ set (field_names_struct_u st s)"
"[] ∉ set (field_names_list_u ts s)"
"[] ∉ set (field_names_tuple_u x s)"
by (induct t and st and ts and x ) auto
lemma non_empty_field_names_u:
fixes t :: "typ_uinfo" and
st :: "typ_uinfo_struct" and
ts :: "typ_uinfo_tuple list" and
x :: "typ_uinfo_tuple"
shows
"field_names_u t s ≠ [] ⟹ ∃n. (s, n) ∈ td_set t m"
"(field_names_struct_u st s) ≠ [] ⟹ ∃n. (s, n) ∈ td_set_struct st m"
"(field_names_list_u ts s) ≠ [] ⟹ ∃n. (s, n) ∈ td_set_list ts m"
"(field_names_tuple_u x s) ≠ [] ⟹ ∃n. (s, n) ∈ td_set_tuple x m"
by (induct t and st and ts and x arbitrary: s m and s m and s m and s m) fastforce+
lemma td_set_size:
"(s, n) ∈ td_set t m ⟹ size s ≤ size t"
"(s, n) ∈ td_set_struct st m ⟹ size s ≤ size st"
"(s, n) ∈ td_set_list ts m ⟹ ∃t ∈ set ts. size s ≤ size (dt_fst t)"
"(s, n) ∈ td_set_tuple x m ⟹ size s ≤ size (dt_fst x)"
proof (induct t and st and ts and x arbitrary: s n m and s n m and s n m and s n m)
case (TypDesc nat typ_struct list)
then show ?case by fastforce
next
case (TypScalar nat1 nat2 a)
then show ?case by auto
next
case (TypAggregate list)
then show ?case by (auto simp add: less_Suc_eq less_imp_le td_set_list_size_lte)
next
case Nil_typ_desc
then show ?case by simp
next
case (Cons_typ_desc dt_tuple list)
then show ?case by auto
next
case (DTuple_typ_desc typ_desc list b)
then show ?case by auto
qed
lemma td_set_field_names_nonempty:
"(s, n) ∈ td_set t m ⟹ field_names t (export_uinfo s) ≠ []"
"(s, n) ∈ td_set_struct st m ⟹ field_names_struct st (export_uinfo s) ≠ []"
"(s, n) ∈ td_set_list ts m ⟹ field_names_list ts (export_uinfo s) ≠ []"
"(s, n) ∈ td_set_tuple x m ⟹ field_names_tuple x (export_uinfo s) ≠ []"
by (induct t and st and ts and x arbitrary: n m and n m and n m and n m) auto
lemma sub_typ_field_names_nonempty:
assumes s_t: "s ≤ t"
shows "field_names t (export_uinfo s) ≠ []"
proof -
from s_t obtain n where "(s, n) ∈ td_set t 0"
by (auto simp add: typ_tag_le_def)
from td_set_field_names_nonempty (1) [OF this] show ?thesis.
qed
lemma sub_typ_export_uinfo_mono:
assumes s_t: "s ≤ t"
shows "export_uinfo s ≤ export_uinfo t"
using s_t
by (meson td_set_export_uinfoD typ_tag_le_def)
lemma descriptor_not_in_self: "(TypDesc algn st nm, n) ∉ td_set_struct st m"
proof
assume "(TypDesc algn st nm, n) ∈ td_set_struct st m"
from td_set_size(2) [OF this] show False by simp
qed
lemma field_names_struct_descriptor_empty: "field_names_struct_u st (TypDesc algn st nm) = []"
using descriptor_not_in_self non_empty_field_names_u(2)
by blast
lemma all_field_names_exists_field_names_u:
fixes t :: "typ_uinfo" and
st :: "typ_uinfo_struct" and
ts :: "typ_uinfo_tuple list" and
x :: "typ_uinfo_tuple"
shows
"f ∈ set (all_field_names t) ⟹ ∃s. f ∈ set (field_names_u t s)"
"f ∈ set (all_field_names_struct st) ⟹ ∃s. f ∈ set (field_names_struct_u st s)"
"f ∈ set (all_field_names_list ts) ⟹ ∃s. f ∈ set (field_names_list_u ts s)"
"f ∈ set (all_field_names_tuple x) ⟹ ∃s. f ∈ set (field_names_tuple_u x s)"
proof (induct t and st and ts and x arbitrary: f and f and f and f)
case (TypDesc algn st nm)
then show ?case
proof (cases "f = []")
case True
with TypDesc show ?thesis by auto
next
case False
with TypDesc obtain s where s: "f ∈ set (field_names_struct_u st s)" by auto
with field_names_struct_descriptor_empty have "s ≠ TypDesc algn st nm" by auto
with s False TypDesc show ?thesis by auto
qed
next
case (TypScalar nat1 nat2 a)
then show ?case by auto
next
case (TypAggregate list)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc dt_tuple list)
then show ?case by auto
next
case (DTuple_typ_desc typ_desc list b)
then show ?case
by auto
(meson empty_all_field_names(1) imageI)
qed
theorem all_field_names_union_field_names_u_conv: "set (all_field_names t) = (⋃s. set (field_names_u t s))"
proof
show "set (all_field_names t) ⊆ (⋃s. set (field_names_u t s))"
using all_field_names_exists_field_names_u
by auto
next
show "(⋃s. set (field_names_u t s)) ⊆ set (all_field_names t)"
using field_names_subset_all_field_names(1)
by auto
qed
corollary all_field_names_union_field_names_export_uinfo_conv:
"set (all_field_names (export_uinfo t)) = (⋃s. set (field_names t s))"
proof -
have "(⋃s. set (field_names t s)) = (⋃s. set (field_names_u (export_uinfo t) s))"
by (simp add: field_names_u_field_names_export_uinfo_conv)
with all_field_names_union_field_names_u_conv show ?thesis by metis
qed
lemma filter_same_eq: "(⋀x. x ∈ set xs ⟹ P x = Q x) ⟹ filter P xs = filter Q xs"
by (induct xs) auto
lemma field_lookup_tuple_hd_notin: "n ≠ dt_snd x ⟹ field_lookup_tuple x (n # ns) m = None"
by (cases x) auto
lemma field_lookup_list_hd_notin: "n ∉ dt_snd ` set xs ⟹ field_lookup_list xs (n # ns) m = None"
by (induct xs arbitrary: m)
(auto split: option.splits simp add: field_lookup_tuple_hd_notin)
lemma list_append_eq_split: "xs1 = xs2 ⟹ ys1 = ys2 ⟹ (xs1 @ ys1) = (xs2 @ ys2)"
by simp
lemma field_names_u_filter_all_field_names_conv:
fixes t :: "typ_uinfo" and
st :: "typ_uinfo_struct" and
ts :: "typ_uinfo_tuple list" and
x :: "typ_uinfo_tuple"
shows
"wf_desc t ⟹
(field_names_u t s) = filter (λf. ∃n. field_lookup t f 0 = Some (s, n)) (all_field_names t)"
"wf_desc_struct st ⟹
field_names_struct_u st s = filter (λf. ∃n. field_lookup_struct st f 0 = Some (s, n)) (all_field_names_struct st)"
"wf_desc_list ts ⟹
field_names_list_u ts s = filter (λf. ∃n. field_lookup_list ts f 0 = Some (s, n)) (all_field_names_list ts)"
"wf_desc_tuple x ⟹
field_names_tuple_u x s = filter (λf. ∃n. field_lookup_tuple x f 0 = Some (s, n)) (all_field_names_tuple x)"
proof (induct t and st and ts and x arbitrary: s and s and s and s)
case (TypDesc algn st nm)
then show ?case
apply (clarsimp simp add: empty_all_field_names, safe)
apply (smt (verit, best) descriptor_not_in_self empty_all_field_names(2)
filter_False td_set_struct_field_lookup_structD)
by (metis (no_types, opaque_lifting) field_lookup_struct_empty option.simps(3))
next
case (TypScalar n algn x)
then show ?case by auto
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x xs)
from Cons_typ_desc.prems obtain
wf_x: "wf_desc_tuple x" and
wf_xs: "wf_desc_list xs" and
distinct: "dt_snd x ∉ dt_snd ` set xs" by clarsimp
have eq1:
"filter (λf. ∃n. field_lookup_tuple x f 0 = Some (s, n)) (all_field_names_tuple x) =
filter
(λf. ∃n. (case field_lookup_tuple x f 0 of
None ⇒ field_lookup_list xs f (0 + size_td (dt_fst x))
| Some x ⇒ Some x) =
Some (s, n)) (all_field_names_tuple x)"
apply (rule filter_same_eq)
apply (cases x)
subgoal for nm t' _
using distinct
apply (auto split: option.splits simp add: field_lookup_list_hd_notin)
done
done
have eq2: "filter (λf. ∃n. field_lookup_list xs f 0 = Some (s, n))
(all_field_names_list xs) =
filter
(λf. ∃n. (case field_lookup_tuple x f 0 of
None ⇒ field_lookup_list xs f (0 + size_td (dt_fst x))
| Some x ⇒ Some x) =
Some (s, n))
(all_field_names_list xs)"
apply (rule filter_same_eq)
apply (cases x)
subgoal for nm t' _
using distinct Cons_typ_desc.hyps(2)[OF wf_xs]
by (smt (verit) all_field_names_exists_field_names_u(3) dt_prj_simps(2)
field_lookup_list_None field_lookup_list_offsetD field_lookup_offset'(3)
fl5 hd_Cons_tl mem_Collect_eq option.case(1) option.simps(3) set_filter)
done
show ?case
by (simp add: Cons_typ_desc.hyps(1)[OF wf_x] Cons_typ_desc.hyps(2)[OF wf_xs] eq1 eq2 )
next
case (DTuple_typ_desc t' nm _)
then show ?case
by (auto simp add: filter_map intro: filter_same_eq )
qed
lemma all_field_names_export_uinfo':
fixes t:: "('a, 'b) typ_info"
and st:: "('a, 'b) typ_info_struct"
and ts::"('a, 'b) typ_info_tuple list"
and x::"('a, 'b) typ_info_tuple"
shows
"all_field_names (map_td field_norm (λ_. ()) t) = all_field_names t"
"all_field_names_struct (map_td_struct field_norm (λ_. ()) st) = all_field_names_struct st"
"all_field_names_list (map_td_list field_norm (λ_. ()) ts) = all_field_names_list ts"
"all_field_names_tuple (map_td_tuple field_norm (λ_. ()) x) = all_field_names_tuple x"
by (induct t and st and ts and x) auto
lemma all_field_names_export_uinfo:
"all_field_names (export_uinfo t) = all_field_names t"
by (simp add: export_uinfo_def all_field_names_export_uinfo')
lemma "inj (#)"
by (metis inj_onI list.inject)
lemma distinct_map_cons: "distinct xs ⟹ distinct (map ((#) ys) xs)"
by (induct xs) auto
lemma all_field_names_list_conv: "all_field_names_list xs =
concat (map (λx. map ((#) (dt_snd x)) ((all_field_names o dt_fst) x)) xs)"
apply (induct xs)
apply simp
subgoal for x1 xs
apply (cases x1)
apply auto
done
done
lemma distinct_all_field_names:
fixes t :: "('a, 'b) typ_info" and
st :: "('a, 'b) typ_info_struct" and
ts :: "('a, 'b) typ_info_tuple list" and
x :: "('a, 'b) typ_info_tuple"
shows
"wf_desc t ⟹ distinct (all_field_names t)" and
"wf_desc_struct st ⟹ distinct (all_field_names_struct st)" and
"wf_desc_list ts ⟹ distinct (all_field_names_list ts)" and
"wf_desc_tuple x ⟹ distinct (all_field_names_tuple x)"
proof (induct t and st and ts and x)
case (TypDesc algn st nm)
then show ?case
by auto (metis all_field_names_export_uinfo'(2) empty_all_field_names(2))
next
case (TypScalar n algn x)
then show ?case by auto
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x xs)
then show ?case apply (cases x) by (auto simp add: all_field_names_list_conv)
next
case (DTuple_typ_desc typ_desc list b)
then show ?case
by (auto simp add: distinct_map_cons)
qed
lemma td_set_field_names_u_nonempty:
"(s, n) ∈ td_set t m ⟹ field_names_u t s ≠ []"
"(s, n) ∈ td_set_struct st m ⟹ field_names_struct_u st s ≠ []"
"(s, n) ∈ td_set_list ts m ⟹ field_names_list_u ts s ≠ []"
"(s, n) ∈ td_set_tuple x m ⟹ field_names_tuple_u x s ≠ []"
by (induct t and st and ts and x arbitrary: n m and n m and n m and n m) auto
lemma field_lookup_export_uinfo_Some_rev:
"field_lookup (export_uinfo t) f n = Some (s, k) ⟹ ∃s'. field_lookup t f n = Some (s', k) ∧ s = export_uinfo s'"
by (simp add: export_uinfo_def field_lookup_map map_td_flr_def split: option.splits prod.splits)
lemma wf_desc_export_uinfo_pres:
fixes t :: "('a, 'b) typ_info" and
st :: "('a, 'b) typ_info_struct" and
ts :: "('a, 'b) typ_info_tuple list" and
x :: "('a, 'b) typ_info_tuple"
shows
"wf_desc t ⟹ wf_desc (export_uinfo t)"
"wf_desc_struct st ⟹ wf_desc_struct (map_td_struct field_norm (λ_. ()) st)"
"wf_desc_list ts ⟹ wf_desc_list (map_td_list field_norm (λ_. ()) ts)"
"wf_desc_tuple x ⟹ wf_desc_tuple (map_td_tuple field_norm (λ_. ()) x)"
apply (induct t and st and ts and x )
by (auto simp add: export_uinfo_def)
(metis imageI mat4 wf_desc_list.wfd4 wf_desc_map(3))
primrec
toplevel_field_names :: "('a, 'b) typ_desc ⇒
(field_name) list" and
toplevel_field_names_struct :: "('a, 'b) typ_struct ⇒
(field_name) list" and
toplevel_field_names_list :: "('a, 'b) typ_tuple list ⇒
(field_name) list" and
toplevel_field_names_tuple :: "('a, 'b) typ_tuple ⇒
(field_name) list"
where
"toplevel_field_names (TypDesc algn st nm) = toplevel_field_names_struct st"
| "toplevel_field_names_struct (TypScalar m algn d) = []"
| "toplevel_field_names_struct (TypAggregate xs) = toplevel_field_names_list xs"
| "toplevel_field_names_list [] = []"
| "toplevel_field_names_list (x#xs) = toplevel_field_names_tuple x @ toplevel_field_names_list xs"
| "toplevel_field_names_tuple (DTuple s f d) = [f]"
lemma all_field_names_root: "∃xs. all_field_names t = [[]] @ xs"
by (cases t) simp
lemma toplevel_field_names_all_field_names:
fixes t:: "('a, 'b) typ_desc"
and st:: "('a, 'b) typ_struct"
and ts::"('a, 'b) typ_tuple list"
and x::"('a, 'b) typ_tuple"
shows
"f ∈ set (toplevel_field_names t) ⟹ [f] ∈ set (all_field_names t)"
"f ∈ set (toplevel_field_names_struct st) ⟹ [f] ∈ set (all_field_names_struct st)"
"f ∈ set (toplevel_field_names_list ts) ⟹ [f] ∈ set (all_field_names_list ts)"
"f ∈ set (toplevel_field_names_tuple x) ⟹ [f] ∈ set (all_field_names_tuple x)"
apply (induct t and st and ts and x)
by auto
(metis all_field_names_root append_Cons imageI list.set_intros(1))
lemma append_eq_same_prefixI: "ys = zs ⟹ xs @ ys = xs @ zs"
by simp
lemma toplevel_field_names_field_lookup:
fixes t:: "('a, 'b) typ_info"
and st:: "('a, 'b) typ_info_struct"
and ts::"('a, 'b) typ_info_tuple list"
and x::"('a, 'b) typ_info_tuple"
shows
"f ∈ set (toplevel_field_names t) ⟹ wf_desc t ⟹
∃s n. field_lookup t [f] m = Some (s, m + n)"
"f ∈ set (toplevel_field_names_struct st) ⟹ wf_desc_struct st ⟹
∃s n. field_lookup_struct st [f] m = Some (s, m + n)"
"f ∈ set (toplevel_field_names_list ts) ⟹ wf_desc_list ts ⟹
∃s n. field_lookup_list ts [f] m = Some (s, m + n)"
"f ∈ set (toplevel_field_names_tuple x) ⟹ wf_desc_tuple x ⟹
∃s n. field_lookup_tuple x [f] m = Some (s, m + n)"
proof (induct t and st and ts and x arbitrary: f m and f m and f m and f m)
case (TypDesc algn st nm)
then show ?case by simp
next
case (TypScalar sz algn d)
then show ?case by simp
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
obtain d nm y where x: "x = DTuple d nm y" by (cases x) auto
then show ?case using Cons_typ_desc
by auto
(metis (no_types, opaque_lifting) add.assoc)
next
case (DTuple_typ_desc d nm y)
then show ?case by auto
qed
lemma partition_toplevel_field_names:
fixes t:: "('a, 'b) typ_info"
and st:: "('a, 'b) typ_info_struct"
and ts::"('a, 'b) typ_info_tuple list"
and x::"('a, 'b) typ_info_tuple"
shows
"length bs = size_td t ⟹ aggregate t ⟹ wf_desc t ⟹
concat (map (λf. take (size_td (fst (the (field_lookup t [f] n))))
(drop (snd (the (field_lookup t [f] n)) - n) bs))
(toplevel_field_names t)) = bs"
"length bs = size_td_struct st ⟹ aggregate_struct st ⟹ wf_desc_struct st ⟹
concat (map (λf. take (size_td (fst (the (field_lookup_struct st [f] n))))
(drop (snd (the (field_lookup_struct st [f] n)) - n) bs))
(toplevel_field_names_struct st)) = bs"
"length bs = size_td_list ts ⟹ wf_desc_list ts ⟹
concat (map (λf. take (size_td (fst (the (field_lookup_list ts [f] n))))
(drop (snd (the (field_lookup_list ts [f] n)) - n) bs))
(toplevel_field_names_list ts)) = bs"
"length bs = size_td_tuple x ⟹ wf_desc_tuple x ⟹
concat (map (λf. take (size_td (fst (the (field_lookup_tuple x [f] n))))
(drop (snd (the (field_lookup_tuple x [f] n)) - n) bs))
(toplevel_field_names_tuple x)) = bs"
proof (induct t and st and ts and x arbitrary: bs n and bs n and bs n and bs n)
case (TypDesc algn st nm)
then show ?case by simp
next
case (TypScalar sz algn d)
then show ?case by simp
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
obtain d nm y where x: "x = DTuple d nm y" by (cases x) auto
from Cons_typ_desc.prems obtain
lbs: "length bs = size_td_tuple x + size_td_list fs" and
wf_desc_x: "wf_desc_tuple (DTuple d nm y)" and
nm_notin: "nm ∉ dt_snd ` set fs" and
wf_desc_fs: "wf_desc_list fs"
by (auto simp add: x)
from nm_notin have nm_notin': "nm ∉ set (toplevel_field_names_list fs)"
proof (induct fs)
case Nil
then show ?case by simp
next
case (Cons f1 fs)
then show ?case by (cases f1) auto
qed
from lbs have l_take: "length (take (size_td d) bs) = size_td d"
by (simp add: x)
from lbs have l_drop: "length (drop (size_td d) bs) = size_td_list fs"
by (simp add: x)
from lbs have bs_take_drop: "bs = take (size_td d) bs @ drop (size_td d) bs"
by (simp add: x)
note hyp = Cons_typ_desc.hyps(2) [OF l_drop wf_desc_fs, where n= "(n + size_td d)"]
show ?case
apply (simp add: x)
apply (simp cong: if_cong option.case_cong)
apply (subst (3) bs_take_drop)
apply (rule append_eq_same_prefixI)
apply (subst hyp [symmetric])
apply (rule arg_cong [where f = concat])
apply (rule map_cong [OF refl])
using nm_notin'
apply auto
thm toplevel_field_names_field_lookup(3)[OF _ wf_desc_fs]
apply (frule toplevel_field_names_field_lookup(3) [OF _ wf_desc_fs, where m = "(n + size_td d)" ])
by auto
(metis add.commute)
next
case (DTuple_typ_desc d nm y)
then show ?case by auto
qed
lemma toplevel_field_names_export_uinfo':
fixes t:: "('a, 'b) typ_info"
and st:: "('a, 'b) typ_info_struct"
and ts::"('a, 'b) typ_info_tuple list"
and x::"('a, 'b) typ_info_tuple"
shows
"toplevel_field_names (map_td field_norm (λ_. ()) t) = toplevel_field_names t"
"toplevel_field_names_struct (map_td_struct field_norm (λ_. ()) st) = toplevel_field_names_struct st"
"toplevel_field_names_list (map_td_list field_norm (λ_. ()) ts) = toplevel_field_names_list ts"
"toplevel_field_names_tuple (map_td_tuple field_norm (λ_. ()) x) = toplevel_field_names_tuple x"
by (induct t and st and ts and x) auto
lemma toplevel_field_names_export_uinfo:
"toplevel_field_names (export_uinfo t) = toplevel_field_names t"
using toplevel_field_names_export_uinfo' by (simp add: export_uinfo_def)
lemma (in xmem_type) xmem_type_partition_toplevel_field_names:
assumes aggregate: "aggregate (typ_info_t TYPE('a))"
assumes lbs: "length bs = size_of (TYPE('a))"
shows "concat (map (λf. take (size_td (fst (the (field_lookup (typ_info_t TYPE('a)) [f] 0))))
(drop (snd (the (field_lookup (typ_info_t TYPE('a)) [f] 0))) bs))
(toplevel_field_names (typ_info_t TYPE('a)))) = bs"
using partition_toplevel_field_names(1) [OF lbs [simplified size_of_def] aggregate wf_desc, where n=0]
by simp
lemma toplevel_field_names_sum_list_size:
fixes t:: "('a, 'b) typ_info"
and st:: "('a, 'b) typ_info_struct"
and ts::"('a, 'b) typ_info_tuple list"
and x::"('a, 'b) typ_info_tuple"
shows
"aggregate t ⟹ wf_desc t ⟹
sum_list (map (λf. size_td (fst (the (field_lookup t [f] n)))) (toplevel_field_names t)) =
size_td t"
"aggregate_struct st ⟹ wf_desc_struct st ⟹
sum_list (map (λf. size_td (fst (the (field_lookup_struct st [f] n)))) (toplevel_field_names_struct st)) =
size_td_struct st"
"wf_desc_list ts ⟹
sum_list (map (λf. size_td (fst (the (field_lookup_list ts [f] n)))) (toplevel_field_names_list ts)) =
size_td_list ts"
"wf_desc t ⟹
sum_list (map (λf. size_td (fst (the (field_lookup_tuple x [f] n)))) (toplevel_field_names_tuple x)) =
size_td_tuple x"
proof (induct t and st and ts and x arbitrary: n and n and n and n)
case (TypDesc algn st nm)
then show ?case by simp
next
case (TypScalar sz algn d)
then show ?case by simp
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
obtain d nm y where x: "x = DTuple d nm y" by (cases x) auto
from Cons_typ_desc.prems obtain
wf_desc_x: "wf_desc_tuple (DTuple d nm y)" and
nm_notin: "nm ∉ dt_snd ` set fs" and
wf_desc_fs: "wf_desc_list fs"
by (auto simp add: x)
from nm_notin have nm_notin': "nm ∉ set (toplevel_field_names_list fs)"
proof (induct fs)
case Nil
then show ?case by simp
next
case (Cons f1 fs)
then show ?case by (cases f1) auto
qed
note hyp = Cons_typ_desc.hyps(2) [OF wf_desc_fs, where n= "(n + size_td d)"]
show ?case
apply (simp add: x)
apply (simp cong: if_cong option.case_cong)
using nm_notin' hyp
by (smt (verit, best) map_eq_conv option.simps(4))
next
case (DTuple_typ_desc d nm y)
then show ?case by auto
qed
lemma toplevel_field_names_sum_list_offset:
fixes t:: "('a, 'b) typ_info"
and st:: "('a, 'b) typ_info_struct"
and ts::"('a, 'b) typ_info_tuple list"
and x::"('a, 'b) typ_info_tuple"
shows
"aggregate t ⟹ wf_desc t ⟹ i < length (toplevel_field_names t) ⟹
sum_list (map (λi. size_td (fst (the (field_lookup t [(toplevel_field_names t) ! i] n)))) [0..<i]) =
(snd (the (field_lookup t [(toplevel_field_names t) ! i] n)) - n)"
"aggregate_struct st ⟹ wf_desc_struct st ⟹ i < length (toplevel_field_names_struct st) ⟹
sum_list (map (λi. size_td (fst (the (field_lookup_struct st [(toplevel_field_names_struct st) ! i] n)))) [0..<i]) =
(snd (the (field_lookup_struct st [(toplevel_field_names_struct st) ! i] n)) - n)"
"wf_desc_list ts ⟹ i < length (toplevel_field_names_list ts) ⟹
sum_list (map (λi. size_td (fst (the (field_lookup_list ts [(toplevel_field_names_list ts) ! i] n)))) [0..<i]) =
(snd (the (field_lookup_list ts [(toplevel_field_names_list ts) ! i] n)) - n)"
"wf_desc_tuple x ⟹ i < length (toplevel_field_names_tuple x) ⟹
sum_list (map (λi. size_td (fst (the (field_lookup_tuple x [(toplevel_field_names_tuple x) ! i] n)))) [0..<i]) =
(snd (the (field_lookup_tuple x [(toplevel_field_names_tuple x) ! i] n)) - n)"
proof (induct t and st and ts and x arbitrary: n i and n i and n i and n i)
case (TypDesc algn st nm)
then show ?case by simp
next
case (TypScalar sz algn d)
then show ?case by simp
next
case (TypAggregate ts)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by auto
next
case (Cons_typ_desc x fs)
obtain d nm y where x: "x = DTuple d nm y" by (cases x) auto
from Cons_typ_desc.prems obtain
wf_desc_x: "wf_desc_tuple (DTuple d nm y)" and
nm_notin: "nm ∉ dt_snd ` set fs" and
wf_desc_fs: "wf_desc_list fs" and
i_bound: "i < Suc (length (toplevel_field_names_list fs))"
by (auto simp add: x)
from nm_notin have nm_notin': "nm ∉ set (toplevel_field_names_list fs)"
proof (induct fs)
case Nil
then show ?case by simp
next
case (Cons f1 fs)
then show ?case by (cases f1) auto
qed
note hyp = Cons_typ_desc.hyps(2) [OF wf_desc_fs, where n= "(n + size_td d)"]
from nm_notin' i_bound have nm_eq_conv: "nm = (nm # toplevel_field_names_list fs) ! i ⟷ i = 0 "
apply (cases i)
apply simp
apply (simp)
using nth_mem by blast
show ?case
proof (cases i)
case 0
then show ?thesis by (simp add: x)
next
case (Suc i')
with i_bound have i'_bound: "i' < length (toplevel_field_names_list fs)" by simp
have split: "[0..<Suc i'] = 0 # [1..<Suc i']"
by (simp add: upt_rec)
have sum_eq:
"(∑i←[0..<i']. size_td
(fst (the (case if nm = toplevel_field_names_list fs ! i
then Some (d, n) else None of
None ⇒
field_lookup_list fs
[toplevel_field_names_list fs ! i] (n + size_td d)
| Some x2 ⇒ Some x2)))) =
(∑i←[0..<i']. size_td
(fst (the (field_lookup_list fs [toplevel_field_names_list fs ! i]
(n + size_td d)))))"
apply (rule arg_cong [where f=sum_list])
apply (rule map_cong [OF refl])
using nm_notin' i'_bound
apply auto
done
show ?thesis
apply (simp add: x)
apply (clarsimp cong: if_cong option.case_cong simp add: nm_eq_conv)
apply (subst Suc)
apply (subst split)
apply (simp only: list.map sum_list.Cons)
apply (subst sum_list_Suc_index_shift)
apply (simp add: Suc)
apply (simp cong: if_cong option.case_cong)
apply (subst sum_eq)
apply (subst hyp [OF i'_bound])
using toplevel_field_names_field_lookup(3)
[where f="toplevel_field_names_list fs ! i'" and ts = fs and m="(n + size_td d)", OF _ wf_desc_fs] i'_bound
apply clarsimp
done
qed
next
case (DTuple_typ_desc d nm y)
then show ?case by auto
qed
lemma sum_list_upt_map_nth_conv: "sum_list (map (λi. g (xs ! i)) [0..<length xs]) = sum_list (map g xs)"
proof -
from map_nth have eq1: "map ((!) xs) [0..<length xs] = xs" .
from map_map [where f=g and g="((!) xs)"]
have eq2: "map g (map ((!) xs) [0..<length xs]) = map (g ∘ (!) xs) [0..<length xs]" .
from eq1 eq2
show ?thesis
by (simp add: comp_def)
qed
lemma toplevel_field_names_empty_typ_info: "toplevel_field_names (empty_typ_info algn tn) = []"
by (simp add: empty_typ_info_def)
lemma toplevel_field_names_no_padding_empty_typ_info:
"filter (Not o padding_field_name) (toplevel_field_names (empty_typ_info algn tn)) = []"
by (simp add: empty_typ_info_def)
lemma toplevel_field_names_list_append [simp]:
"toplevel_field_names_list (xs @ ys) = toplevel_field_names_list xs @ toplevel_field_names_list ys"
by (induct xs) auto
lemma toplevel_field_names_extend_ti:
fixes
t :: "'a xtyp_info" and
st :: "'a xtyp_info_struct" and
ts :: "'a xtyp_info_tuple list" and
x :: "'a xtyp_info_tuple"
shows
"toplevel_field_names (extend_ti t s n fn d) = toplevel_field_names t @ [fn]"
"toplevel_field_names_struct (extend_ti_struct st s fn d) = toplevel_field_names_struct st @ [fn]"
"toplevel_field_names_list ts = toplevel_field_names_list ts"
"toplevel_field_names_tuple x = toplevel_field_names_tuple x"
by (induct t and st and ts and x) auto
lemma toplevel_field_names_adjust_ti':
fixes
t :: "'a xtyp_info" and
st :: "'a xtyp_info_struct" and
ts :: "'a xtyp_info_tuple list" and
x :: "'a xtyp_info_tuple"
shows
"toplevel_field_names (map_td (λn algn. update_desc acc upd) (update_desc acc upd) t) =
toplevel_field_names t"
"toplevel_field_names_struct (map_td_struct (λn algn. update_desc acc upd) (update_desc acc upd) st) =
toplevel_field_names_struct st"
"toplevel_field_names_list (map_td_list (λn algn. update_desc acc upd) (update_desc acc upd) ts) =
toplevel_field_names_list ts"
"toplevel_field_names_tuple (map_td_tuple (λn algn. update_desc acc upd) (update_desc acc upd) x) =
toplevel_field_names_tuple x"
by (induct t and st and ts and x) (auto)
lemma toplevel_field_names_adjust_ti:
"toplevel_field_names (adjust_ti t acc upd) = toplevel_field_names t"
by (simp add: toplevel_field_names_adjust_ti' adjust_ti_def)
lemma padding_field_name_pad: "padding_field_name (foldl (@) ''!pad_'' xs)"
by (auto simp add: padding_field_name_def foldl_conv_concat)
lemma toplevel_field_names_no_padding_ti_pad_combine:
"filter (Not o padding_field_name) (toplevel_field_names (ti_pad_combine n t)) =
filter (Not o padding_field_name) (toplevel_field_names t)"
by (simp add: ti_pad_combine_def Let_def toplevel_field_names_extend_ti(1) padding_field_name_pad)
lemma toplevel_field_names_ti_pad_combine:
"(toplevel_field_names (ti_pad_combine n t)) =
toplevel_field_names t @ [foldl (@) ''!pad_'' (CompoundCTypes.field_names_list t)]"
by (simp add: ti_pad_combine_def Let_def toplevel_field_names_extend_ti(1) padding_field_name_pad)
lemma toplevel_field_names_ti_typ_combine:
"toplevel_field_names (ti_typ_combine t_b acc upd algn fn t) = toplevel_field_names t @ [fn]"
by (simp add: ti_typ_combine_def toplevel_field_names_extend_ti)
lemma toplevel_field_names_no_padding_ti_typ_combine:
"¬ padding_field_name fn ⟹
filter (Not o padding_field_name) (toplevel_field_names (ti_typ_combine t_b acc upd algn fn t)) =
filter (Not o padding_field_name) (toplevel_field_names t) @ [fn]"
by (simp add: toplevel_field_names_ti_typ_combine toplevel_field_names_extend_ti)
lemma toplevel_field_names_no_padding_ti_typ_pad_combine:
"¬ padding_field_name fn ⟹
filter (Not o padding_field_name) (toplevel_field_names (ti_typ_pad_combine t_b acc upd algn fn t)) =
filter (Not o padding_field_name) (toplevel_field_names t) @ [fn]"
by (simp add: ti_typ_pad_combine_def toplevel_field_names_ti_typ_combine toplevel_field_names_no_padding_ti_pad_combine Let_def)
lemma toplevel_field_names_ti_typ_pad_combine:
"toplevel_field_names (ti_typ_pad_combine (t_b:: 'b itself) acc upd algn fn t) =
toplevel_field_names t @ (
if 0 < padup (max (2 ^ algn) (align_of TYPE('b::c_type))) (size_td t) then
[foldl (@) ''!pad_'' (CompoundCTypes.field_names_list t), fn]
else
[fn])"
by (simp add: ti_typ_pad_combine_def toplevel_field_names_ti_typ_combine toplevel_field_names_no_padding_ti_pad_combine Let_def
toplevel_field_names_ti_pad_combine)
lemma toplevel_field_names_map_align: "toplevel_field_names (map_align n t) = toplevel_field_names t"
by (cases t) (simp add: map_align_def)
lemma toplevel_field_names_no_padding_final_pad:
"filter (Not o padding_field_name) (toplevel_field_names (final_pad n t))
= filter (Not o padding_field_name) (toplevel_field_names t)"
by (simp add: final_pad_def Let_def toplevel_field_names_map_align toplevel_field_names_no_padding_ti_pad_combine)
lemma toplevel_field_names_final_pad:
"(toplevel_field_names (final_pad n t))
=
toplevel_field_names t @ (
if 0 < padup (2 ^ max n (align_td t)) (size_td t) then
[foldl (@) ''!pad_'' (CompoundCTypes.field_names_list t)]
else [])"
by (simp add: final_pad_def Let_def toplevel_field_names_map_align toplevel_field_names_ti_pad_combine)
lemmas toplevel_field_names_no_padding_combinator_simps =
toplevel_field_names_no_padding_empty_typ_info
toplevel_field_names_no_padding_final_pad
toplevel_field_names_no_padding_ti_typ_pad_combine
toplevel_field_names_no_padding_ti_typ_combine
lemmas toplevel_field_names_combinator_simps =
toplevel_field_names_empty_typ_info
toplevel_field_names_final_pad
toplevel_field_names_ti_typ_pad_combine
toplevel_field_names_ti_typ_combine
lemma fold_filter_out_id:
assumes filter_out_id: "⋀i v. i < length xs ⟹ ¬ P (xs ! i) ⟹ f (xs!i) v = v"
shows"fold f xs = fold f (filter P xs)"
using filter_out_id
apply (induct xs)
apply simp
apply (clarsimp simp add: comp_def fun_eq_iff, safe)
apply (metis Suc_mono nth_Cons_Suc)
by (metis not_less_eq nth_Cons_0 nth_Cons_Suc zero_less_Suc)
context xmem_type
begin
lemma xmem_type_toplevel_field_names_sum_list_size:
assumes aggregate: "aggregate (typ_info_t TYPE('a))"
shows "sum_list
(map (λf. size_td (fst (the (field_lookup (typ_info_t TYPE('a)) [f] n))))
(toplevel_field_names (typ_info_t TYPE('a)))) =
size_of TYPE('a)"
using toplevel_field_names_sum_list_size(1) [OF aggregate wf_desc] by (simp add: size_of_def)
lemma xmem_type_toplevel_field_names_sum_list_offset:
assumes aggregate: "aggregate (typ_info_t TYPE('a))"
assumes i_bound: "i < length (toplevel_field_names (typ_info_t TYPE('a)))"
shows
"sum_list (map (λi. size_td (fst (the (field_lookup (typ_info_t TYPE('a))
[(toplevel_field_names (typ_info_t TYPE('a))) ! i] 0))))
[0..<i]) =
(snd (the (field_lookup (typ_info_t TYPE('a)) [(toplevel_field_names (typ_info_t TYPE('a))) ! i] 0)))"
using toplevel_field_names_sum_list_offset(1) [OF aggregate wf_desc i_bound, where n=0]
by simp
lemma xmem_type_toplevel_field_names_field_lookup:
assumes f: "f ∈ set (toplevel_field_names (typ_info_t TYPE('a)))"
shows "∃s n. field_lookup (typ_info_t TYPE('a)) [f] 0 = Some (s, n)"
using toplevel_field_names_field_lookup(1) [OF f wf_desc, of 0] by simp
lemma (in c_type) field_lookup_typ_uinfo_t_Some:
"field_lookup (typ_info_t TYPE('a)) f m = Some (s, n) ⟹
field_lookup (typ_uinfo_t TYPE('a)) f m = Some (export_uinfo s, n)"
by (simp add: typ_uinfo_t_def field_lookup_export_uinfo_Some)
lemma toplevel_field_names_field_lookup_offset_conv:
assumes f: "f ∈ set (toplevel_field_names (typ_info_t TYPE('a)))"
shows "snd (the (field_lookup (typ_uinfo_t TYPE('a)) [f] 0)) =
snd (the (field_lookup (typ_info_t TYPE('a)) [f] 0))"
using xmem_type_toplevel_field_names_field_lookup [OF f]
by (auto simp add: field_lookup_typ_uinfo_t_Some )
lemma heap_update_list_fold_toplevel_field_names:
fixes p::"'a ptr"
assumes aggregate: "aggregate (typ_info_t TYPE('a))"
assumes cgrd: "c_guard p"
shows
"heap_update_list (ptr_val p) (to_bytes x (heap_list h (size_of TYPE('a)) (ptr_val p))) h =
fold
(λf h. heap_update_list (&(p→[f]))
(access_ti
(fst (the (field_lookup (typ_info_t TYPE('a)) [f] 0)))
x
(heap_list h (size_td (fst (the (field_lookup (typ_info_t TYPE('a)) [f] 0)))) (&(p→[f]))))
h)
(toplevel_field_names (typ_info_t TYPE('a))) h" (is "?LHS = fold ?F ?fs h")
proof -
define fld::"nat ⇒ field_name" where
"fld = (λi. toplevel_field_names (typ_info_t TYPE('a)) ! i)"
define sz:: "nat ⇒ nat" where
"sz = (λi. size_td (fst (the (field_lookup (typ_info_t TYPE('a)) [fld i] 0))))"
define off:: "nat ⇒ nat" where
"off = (λi. snd (the (field_lookup (typ_info_t TYPE('a)) [fld i] 0)))"
define v:: "nat ⇒ byte list ⇒ byte list" where
"v = (λi. (access_ti
(fst (the (field_lookup (typ_info_t TYPE('a)) [fld i] 0)))
x))"
have lbs: "length (to_bytes x (heap_list h (size_of TYPE('a)) (ptr_val p))) = size_of TYPE('a)"
by (simp add: local.lense.access_result_size to_bytes_def)
{
fix i::nat
assume bound: " i < length (toplevel_field_names (typ_info_t TYPE('a)))"
hence "toplevel_field_names (typ_info_t TYPE('a)) ! i ∈ set (toplevel_field_names (typ_info_t TYPE('a)))"
by simp
from toplevel_field_names_field_lookup_offset_conv [OF this]
have "snd (the (field_lookup (typ_uinfo_t TYPE('a))
[toplevel_field_names (typ_info_t TYPE('a)) ! i] 0)) =
snd (the (field_lookup (typ_info_t TYPE('a))
[toplevel_field_names (typ_info_t TYPE('a)) ! i] 0))" .
} note field_lookup_conv = this
have fs: "?fs = map fld [0..<length(toplevel_field_names (typ_info_t TYPE('a)))]"
by (simp add: fld_def map_nth)
from c_guard_no_wrap' [OF cgrd]
have no_overflow: "unat (ptr_val p) + size_of TYPE('a) ≤ addr_card" .
have fold_conv:
"fold ?F ?fs h =
fold
(λi h. heap_update_list (ptr_val p + word_of_nat (off i))
(v i (heap_list h (sz i) (ptr_val p + word_of_nat (off i)))) h)
[0..<length (toplevel_field_names (typ_info_t TYPE('a)))] h"
apply (subst fs)
apply (subst fold_map)
apply (rule fold_cong [OF refl refl])
apply (simp add: fld_def off_def sz_def v_def field_lvalue_def field_offset_def field_offset_untyped_def)
apply (simp add: field_lookup_conv)
done
note partition= heap_update_list_fold_partition [where a= "ptr_val p" and sz=sz and off=off and v=v and h=h
and bs = "to_bytes x (heap_list h (size_of TYPE('a)) (ptr_val p))" and
m = "length (toplevel_field_names (typ_info_t TYPE('a)))"
]
{
fix i
assume i_bound: "i < length (toplevel_field_names (typ_info_t TYPE('a)))"
from i_bound
have f: "toplevel_field_names (typ_info_t TYPE('a)) ! i ∈ set (toplevel_field_names (typ_info_t TYPE('a)))"
by simp
from toplevel_field_names_field_lookup(1) [OF f, where m= 0, OF wf_desc]
obtain s n where
fl: "field_lookup (typ_info_t TYPE('a))
[toplevel_field_names (typ_info_t TYPE('a)) ! i] 0 =
Some (s, n)" by auto
have lh: "length (heap_list h (size_of TYPE('a)) (ptr_val p)) = size_of TYPE('a)" by simp
have "v i (take (sz i)
(drop (off i)
(heap_list h
(length (to_bytes x (heap_list h (size_of TYPE('a)) (ptr_val p))))
(ptr_val p)))) =
take (sz i) (drop (off i) (to_bytes x (heap_list h (size_of TYPE('a)) (ptr_val p))))"
apply (simp add: off_def sz_def v_def fld_def lbs)
apply (simp add: fl)
using mem_type_field_lookup_access_ti_take_drop [OF fl lh, where v=x ]
apply (simp add: to_bytes_def)
done
} note v_focus = this
show ?thesis
apply (subst fold_conv)
apply (rule partition)
subgoal
using no_overflow
by (simp add: local.lense.access_result_size to_bytes_def)
subgoal
apply (subst xmem_type_partition_toplevel_field_names [OF aggregate lbs, symmetric])
apply (subst fs)
apply (subst map_map)
apply (rule arg_cong [where f=concat])
apply (rule map_cong [OF refl])
apply (simp add: fld_def off_def sz_def)
done
subgoal
apply (subst lbs)
apply (subst xmem_type_toplevel_field_names_sum_list_size [OF aggregate, symmetric])
apply (simp add: sz_def)
apply (subst fs)
apply (simp add: fld_def comp_def)
done
subgoal for i
apply (simp add: off_def sz_def)
apply (simp add: fld_def)
using xmem_type_toplevel_field_names_sum_list_offset [OF aggregate, where i = i]
apply simp
done
subgoal for i
by (rule v_focus)
done
qed
lemma heap_update_list_padding_fold_toplevel_field_names:
fixes p::"'a ptr"
assumes aggregate: "aggregate (typ_info_t TYPE('a))"
assumes cgrd: "c_guard p"
assumes lbs: "length bs = size_of TYPE('a)"
shows
"heap_update_list (ptr_val p) (to_bytes x bs) h =
fold
(λf h. heap_update_list (&(p→[f]))
(access_ti
(fst (the (field_lookup (typ_info_t TYPE('a)) [f] 0)))
x
(take (size_td (fst (the (field_lookup (typ_info_t TYPE('a)) [f] 0))))
(drop ((snd (the (field_lookup (typ_info_t TYPE('a)) [f] 0)))) bs)))
h)
(toplevel_field_names (typ_info_t TYPE('a))) h" (is "?LHS = fold ?F ?fs h")
proof -
define fld::"nat ⇒ field_name" where
"fld = (λi. toplevel_field_names (typ_info_t TYPE('a)) ! i)"
define sz:: "nat ⇒ nat" where
"sz = (λi. size_td (fst (the (field_lookup (typ_info_t TYPE('a)) [fld i] 0))))"
define off:: "nat ⇒ nat" where
"off = (λi. snd (the (field_lookup (typ_info_t TYPE('a)) [fld i] 0)))"
define v:: "nat ⇒ byte list ⇒ byte list" where
"v = (λi. (access_ti
(fst (the (field_lookup (typ_info_t TYPE('a)) [fld i] 0)))
x))"
have lbs': "length (to_bytes x bs) = size_of TYPE('a)"
by (simp add: local.lense.access_result_size to_bytes_def)
{
fix i::nat
assume bound: " i < length (toplevel_field_names (typ_info_t TYPE('a)))"
hence "toplevel_field_names (typ_info_t TYPE('a)) ! i ∈ set (toplevel_field_names (typ_info_t TYPE('a)))"
by simp
from toplevel_field_names_field_lookup_offset_conv [OF this]
have "snd (the (field_lookup (typ_uinfo_t TYPE('a))
[toplevel_field_names (typ_info_t TYPE('a)) ! i] 0)) =
snd (the (field_lookup (typ_info_t TYPE('a))
[toplevel_field_names (typ_info_t TYPE('a)) ! i] 0))" .
} note field_lookup_conv = this
have fs: "?fs = map fld [0..<length(toplevel_field_names (typ_info_t TYPE('a)))]"
by (simp add: fld_def map_nth)
from c_guard_no_wrap' [OF cgrd]
have no_overflow: "unat (ptr_val p) + size_of TYPE('a) ≤ addr_card" .
have fold_conv:
"fold ?F ?fs h =
fold
(λi h. heap_update_list (ptr_val p + word_of_nat (off i))
(v i (take (sz i) (drop (off i) bs))) h)
[0..<length (toplevel_field_names (typ_info_t TYPE('a)))] h"
apply (subst fs)
apply (subst fold_map)
apply (rule fold_cong [OF refl refl])
apply (simp add: fld_def off_def sz_def v_def field_lvalue_def field_offset_def field_offset_untyped_def)
apply (simp add: field_lookup_conv)
done
note partition= heap_update_list_padding_fold_partition [where a= "ptr_val p" and sz=sz and off=off and v=v and h=h
and bs = "to_bytes x bs" and pbs = bs and
m = "length (toplevel_field_names (typ_info_t TYPE('a)))"
]
{
fix i
assume i_bound: "i < length (toplevel_field_names (typ_info_t TYPE('a)))"
from i_bound
have f: "toplevel_field_names (typ_info_t TYPE('a)) ! i ∈ set (toplevel_field_names (typ_info_t TYPE('a)))"
by simp
from toplevel_field_names_field_lookup(1) [OF f, where m= 0, OF wf_desc]
obtain s n where
fl: "field_lookup (typ_info_t TYPE('a))
[toplevel_field_names (typ_info_t TYPE('a)) ! i] 0 =
Some (s, n)" by auto
have lh: "length (heap_list h (size_of TYPE('a)) (ptr_val p)) = size_of TYPE('a)" by simp
have "v i (take (sz i) (drop (off i) bs)) =
take (sz i) (drop (off i) (to_bytes x bs))"
apply (simp add: off_def sz_def v_def fld_def lbs)
apply (simp add: fl)
using mem_type_field_lookup_access_ti_take_drop [OF fl lbs, where v=x ]
apply (simp add: to_bytes_def)
done
} note v_focus = this
show ?thesis
apply (subst fold_conv)
apply (rule partition)
subgoal
using no_overflow
by (simp add: local.lense.access_result_size to_bytes_def)
subgoal
apply (subst xmem_type_partition_toplevel_field_names [OF aggregate lbs', symmetric])
apply (subst fs)
apply (subst map_map)
apply (rule arg_cong [where f=concat])
apply (rule map_cong [OF refl])
apply (simp add: fld_def off_def sz_def)
done
subgoal
apply (subst lbs')
apply (subst xmem_type_toplevel_field_names_sum_list_size [OF aggregate, symmetric])
apply (simp add: sz_def)
apply (subst fs)
apply (simp add: fld_def comp_def)
done
subgoal
apply (subst xmem_type_partition_toplevel_field_names [OF aggregate lbs, symmetric])
apply (subst fs)
apply (subst map_map)
apply (rule arg_cong [where f=concat])
apply (rule map_cong [OF refl])
apply (simp add: fld_def off_def sz_def)
done
subgoal
apply (subst lbs)
apply (subst xmem_type_toplevel_field_names_sum_list_size [OF aggregate, symmetric])
apply (simp add: sz_def)
apply (subst fs)
apply (simp add: fld_def comp_def)
done
subgoal for i
apply (simp add: off_def sz_def)
apply (simp add: fld_def)
using xmem_type_toplevel_field_names_sum_list_offset [OF aggregate, where i = i]
apply simp
done
subgoal for i
by (rule v_focus)
done
qed
lemma heap_update_fold_toplevel_field_names:
fixes p::"'a ptr"
assumes aggregate: "aggregate (typ_info_t TYPE('a))"
assumes cgrd: "c_guard p"
shows
"heap_update p x h =
fold
(λf h. heap_update_list (&(p→[f]))
(access_ti
(fst (the (field_lookup (typ_info_t TYPE('a)) [f] 0)))
x
(heap_list h (size_td (fst (the (field_lookup (typ_info_t TYPE('a)) [f] 0)))) (&(p→[f]))))
h)
(toplevel_field_names (typ_info_t TYPE('a))) h" (is "?LHS = fold ?F ?fs h")
using heap_update_list_fold_toplevel_field_names [OF aggregate cgrd]
by (simp only: heap_update_def)
lemma heap_update_padding_fold_toplevel_field_names:
fixes p::"'a ptr"
assumes aggregate: "aggregate (typ_info_t TYPE('a))"
assumes cgrd: "c_guard p"
assumes lbs: "length bs = size_of TYPE('a)"
shows
"heap_update_padding p x bs h =
fold
(λf h. heap_update_list (&(p→[f]))
(access_ti
(fst (the (field_lookup (typ_info_t TYPE('a)) [f] 0)))
x
(take (size_td (fst (the (field_lookup (typ_info_t TYPE('a)) [f] 0))))
(drop ((snd (the (field_lookup (typ_info_t TYPE('a)) [f] 0)))) bs)))
h)
(toplevel_field_names (typ_info_t TYPE('a))) h" (is "?LHS = fold ?F ?fs h")
using heap_update_list_padding_fold_toplevel_field_names [OF aggregate cgrd lbs]
by (simp only: heap_update_padding_def)
lemma heap_update_fold_toplevel_field_names_no_padding:
fixes p::"'a ptr"
assumes aggregate: "aggregate (typ_info_t TYPE('a))"
assumes cgrd: "c_guard p"
shows
"heap_update p x h =
fold
(λf h. heap_update_list (&(p→[f]))
(access_ti
(fst (the (field_lookup (typ_info_t TYPE('a)) [f] 0)))
x
(heap_list h (size_td (fst (the (field_lookup (typ_info_t TYPE('a)) [f] 0)))) (&(p→[f]))))
h)
(filter (Not o padding_field_name) (toplevel_field_names (typ_info_t TYPE('a)))) h" (is "?LHS = fold ?F ?filter_fs h")
proof -
{ fix i
fix h
assume i_bound: "i < length (toplevel_field_names (typ_info_t TYPE('a)))"
assume "¬ (Not ∘ padding_field_name)
(toplevel_field_names (typ_info_t TYPE('a)) ! i)"
hence padding: "padding_field_name (toplevel_field_names (typ_info_t TYPE('a)) ! i)"
by simp
from i_bound obtain m s where
fl: "field_lookup (typ_info_t TYPE('a))
[(toplevel_field_names (typ_info_t TYPE('a)) ! i)] 0 = Some (s, m)"
by (meson nth_mem xmem_type_toplevel_field_names_field_lookup)
from field_lookup_padding_field_name(1) [OF fl padding wf_padding]
have is_padding_tag: "is_padding_tag s" .
have "?F (toplevel_field_names (typ_info_t TYPE('a)) ! i) h = h"
apply (simp add: fl)
using is_padding_tag
by (clarsimp simp add: is_padding_tag_def padding_tag_def padding_desc_def heap_update_list_id')
} note pad = this
have "fold ?F ?filter_fs = fold ?F (toplevel_field_names (typ_info_t TYPE('a)))"
apply (rule fold_filter_out_id [symmetric])
by (rule pad)
with heap_update_fold_toplevel_field_names [OF aggregate cgrd, where x=x and h=h]
show ?thesis
by simp
qed
lemma heap_list_concat_toplevel_field_names:
fixes p::"'a ptr"
assumes aggregate: "aggregate (typ_info_t TYPE('a))"
assumes cgrd: "c_guard p"
shows
"heap_list h (size_of TYPE('a)) (ptr_val p) =
concat (map (λf. heap_list h (size_td (fst (the (field_lookup (typ_info_t TYPE('a)) [f] 0)))) (&(p→[f])))
(toplevel_field_names (typ_info_t TYPE('a))))" (is "?LHS = concat (map ?F ?fs)")
proof -
define fld::"nat ⇒ field_name" where
"fld = (λi. toplevel_field_names (typ_info_t TYPE('a)) ! i)"
define sz:: "nat ⇒ nat" where
"sz = (λi. size_td (fst (the (field_lookup (typ_info_t TYPE('a)) [fld i] 0))))"
define off:: "nat ⇒ nat" where
"off = (λi. snd (the (field_lookup (typ_info_t TYPE('a)) [fld i] 0)))"
have fs: "?fs = map fld [0..<length(toplevel_field_names (typ_info_t TYPE('a)))]"
by (simp add: fld_def map_nth)
from c_guard_no_wrap' [OF cgrd]
have no_overflow: "unat (ptr_val p) + size_of TYPE('a) ≤ addr_card" .
have concat_conv:
"concat (map ?F ?fs) =
concat (map (λi. (heap_list h (sz i) (ptr_val p + word_of_nat (off i))))
[0..<length (toplevel_field_names (typ_info_t TYPE('a)))])"
apply (subst fs)
apply (subst list.map_comp)
apply (rule arg_cong [where f=concat])
apply (rule map_cong [OF refl])
apply (simp add: fld_def off_def sz_def field_lvalue_def field_offset_def field_offset_untyped_def)
by (simp add: toplevel_field_names_field_lookup_offset_conv)
note partition = heap_list_map_partition [where a= "ptr_val p", where sz=sz and off=off and n="size_of TYPE('a)" and
m = "length (toplevel_field_names (typ_info_t TYPE('a)))", OF no_overflow]
show ?thesis
apply (subst concat_conv)
apply (rule partition)
subgoal
apply (subst xmem_type_toplevel_field_names_sum_list_size [OF aggregate, symmetric])
apply (simp add: sz_def)
apply (subst fs)
apply (simp add: fld_def comp_def)
done
subgoal for i
apply (simp add: off_def sz_def)
apply (simp add: fld_def)
using xmem_type_toplevel_field_names_sum_list_offset [OF aggregate, where i = i]
apply simp
done
done
qed
lemma h_val_concat_toplevel_field_names:
fixes p::"'a ptr"
assumes aggregate: "aggregate (typ_info_t TYPE('a))"
assumes cgrd: "c_guard p"
shows
"h_val h p =
from_bytes
(concat (map (λf. heap_list h (size_td (fst (the (field_lookup (typ_info_t TYPE('a)) [f] 0)))) (&(p→[f])))
(toplevel_field_names (typ_info_t TYPE('a)))))"
using heap_list_concat_toplevel_field_names [OF aggregate cgrd]
by (simp add: h_val_def)
end
lemma set_field_names_u_all_field_names_conv:
"set (field_names_u (typ_uinfo_t TYPE('a::mem_type)) t) =
{f. f ∈ set (all_field_names (typ_info_t TYPE('a))) ∧
(∃s. field_ti TYPE('a) f = Some s ∧ export_uinfo s = t)}"
apply standard
subgoal
apply (clarsimp simp add: typ_uinfo_t_def)
apply (rule conjI)
apply (metis (mono_tags, lifting) all_field_names_export_uinfo field_names_subset_all_field_names(1) in_mono)
by (metis field_lookup_field_ti field_names_Some2(1) field_names_u_field_names_export_uinfo_conv(1) wf_desc)
subgoal
apply clarsimp
by (metis all_field_names_exists_field_names_u(1) all_field_names_export_uinfo
field_lookup_field_ti field_names_Some2(1) field_names_u_field_names_export_uinfo_conv(1) fold_typ_uinfo_t option.inject wf_desc)
done
lemma field_names_u_all_field_names_conv:
"field_names_u (typ_uinfo_t TYPE('a::mem_type)) t =
filter (λf. (∃s. field_ti TYPE('a) f = Some s ∧ export_uinfo s = t))
(all_field_names (typ_info_t TYPE('a)))"
using field_names_u_filter_all_field_names_conv(1)
by (smt (verit) all_field_names_exists_field_names_u(1) all_field_names_export_uinfo field_lookup_field_ti
field_lookup_uinfo_Some_rev field_ti_def filter_same_eq fold_typ_uinfo_t
mem_Collect_eq option.sel set_field_names_u_all_field_names_conv set_filter wf_desc_typ_tag)
lemma set_field_names_all_field_names_conv:
"set (field_names (typ_info_t TYPE('a::mem_type)) t) =
{f. f ∈ set (all_field_names (typ_info_t TYPE('a))) ∧
(∃s. field_ti TYPE('a) f = Some s ∧ export_uinfo s = t)}"
using set_field_names_u_all_field_names_conv [of t]
unfolding typ_uinfo_t_def
by (simp add: field_names_u_field_names_export_uinfo_conv(1))
lemma field_names_all_field_names_conv:
"field_names (typ_info_t TYPE('a::mem_type)) t =
filter (λf. ∃s. field_ti TYPE('a) f = Some s ∧ export_uinfo s = t) (all_field_names (typ_info_t TYPE('a)))"
using field_names_u_all_field_names_conv [of t]
unfolding typ_uinfo_t_def
by (simp add: field_names_u_field_names_export_uinfo_conv(1))
lemma field_lookup_qualified_padding_field_name:
fixes
t:: "('a, 'b) typ_info " and
st :: "('a, 'b) typ_info_struct" and
ts :: "('a, 'b) typ_info_tuple list" and
x :: "('a, 'b) typ_info_tuple"
shows
"field_lookup t f n = Some (s, m) ⟹ qualified_padding_field_name f ⟹ wf_padding t ⟹
is_padding_tag s"
"field_lookup_struct st f n = Some (s, m) ⟹ qualified_padding_field_name f ⟹ wf_padding_struct st ⟹
is_padding_tag s"
"field_lookup_list ts f n = Some (s, m) ⟹ qualified_padding_field_name f ⟹ wf_padding_list ts ⟹
is_padding_tag s"
"field_lookup_tuple x f n = Some (s, m) ⟹ qualified_padding_field_name f ⟹ wf_padding_tuple x ⟹
is_padding_tag s"
proof (induct t and st and ts and x arbitrary: f n m and f n m and f n m and f n m)
case (TypDesc nat typ_struct list)
then show ?case by (auto split: if_split_asm option.splits)
next
case (TypScalar nat1 nat2 a)
then show ?case by simp
next
case (TypAggregate list)
then show ?case by auto
next
case Nil_typ_desc
then show ?case by simp
next
case (Cons_typ_desc dt_tuple list)
then show ?case by (auto split: if_split_asm option.splits)
next
case (DTuple_typ_desc typ_desc list b)
then show ?case
apply clarsimp
by (metis field_lookup_empty last_tl list.exhaust_sel option.distinct(1)
option.inject prod.inject qualified_pading_field_name_cons qualified_pading_field_name_single)
qed
lemma all_field_names_empty_typ_info [simp]: "all_field_names (empty_typ_info algn n) = [[]]"
by (simp add: empty_typ_info_def)
lemma all_field_names_no_padding_empty_typ_info [simp]:
"filter (Not o qualified_padding_field_name) (all_field_names (empty_typ_info algn n)) = [[]]"
by (simp)
lemma all_field_names_list_append [simp]:
"all_field_names_list (xs @ ys) = all_field_names_list xs @ all_field_names_list ys"
by (induct xs) auto
lemma all_field_names_extend_ti:
fixes
t :: "'a xtyp_info" and
st :: "'a xtyp_info_struct" and
ts :: "'a xtyp_info_tuple list" and
x :: "'a xtyp_info_tuple"
shows
"all_field_names (extend_ti t s n fn d) = all_field_names t @ (map ((#) fn) (all_field_names s))"
"all_field_names_struct (extend_ti_struct st s fn d) = all_field_names_struct st @ (map ((#) fn) (all_field_names s))"
"all_field_names_list ts = all_field_names_list ts"
"all_field_names_tuple x = all_field_names_tuple x"
by (induct t and st and ts and x) auto
lemma all_field_names_adjust_ti':
fixes
t :: "'a xtyp_info" and
st :: "'a xtyp_info_struct" and
ts :: "'a xtyp_info_tuple list" and
x :: "'a xtyp_info_tuple"
shows
"all_field_names (map_td (λn algn. update_desc acc upd) (update_desc acc upd) t) =
all_field_names t"
"all_field_names_struct (map_td_struct (λn algn. update_desc acc upd) (update_desc acc upd) st) =
all_field_names_struct st"
"all_field_names_list (map_td_list (λn algn. update_desc acc upd) (update_desc acc upd) ts) =
all_field_names_list ts"
"all_field_names_tuple (map_td_tuple (λn algn. update_desc acc upd) (update_desc acc upd) x) =
all_field_names_tuple x"
by (induct t and st and ts and x) (auto)
lemma all_field_names_adjust_ti[simp]:
"all_field_names (adjust_ti t acc upd) = all_field_names t"
by (simp add: all_field_names_adjust_ti' adjust_ti_def)
lemma all_field_names_no_padding_ti_pad_combine:
"filter (Not o qualified_padding_field_name) (all_field_names (ti_pad_combine n t)) =
filter (Not o qualified_padding_field_name) (all_field_names t)"
by (simp add: ti_pad_combine_def Let_def all_field_names_extend_ti(1) padding_field_name_pad)
lemma all_field_names_ti_typ_combine:
"all_field_names (ti_typ_combine (t_b::'b::c_type itself) acc upd algn fn t) =
all_field_names t @ (map ((#) fn) (all_field_names (typ_info_t TYPE('b))))"
by (simp add: ti_typ_combine_def all_field_names_extend_ti)
lemma all_field_names_no_padding_ti_typ_combine:
assumes not_padding: "¬ padding_field_name fn"
shows "filter (Not o qualified_padding_field_name) (all_field_names (ti_typ_combine (t_b::'b::c_type itself) acc upd algn fn t)) =
filter (Not o qualified_padding_field_name) (all_field_names t) @
(map ((#) fn) (filter (Not o qualified_padding_field_name) (all_field_names (typ_info_t TYPE('b)))))"
proof -
from not_padding have eq: "Not ∘ qualified_padding_field_name ∘ (#) fn = Not ∘ qualified_padding_field_name"
apply -
apply (rule ext)
apply (auto simp add: neq_Nil_conv)
done
from not_padding show ?thesis
apply (simp add: all_field_names_ti_typ_combine all_field_names_extend_ti)
apply (simp add: filter_map eq)
done
qed
lemma all_field_names_no_padding_ti_typ_pad_combine:
assumes not_padding: "¬ padding_field_name fn"
shows "filter (Not o qualified_padding_field_name) (all_field_names (ti_typ_pad_combine (t_b::'b::c_type itself) acc upd algn fn t)) =
filter (Not o qualified_padding_field_name) (all_field_names t) @
(map ((#) fn) (filter (Not o qualified_padding_field_name) (all_field_names (typ_info_t TYPE('b)))))"
by (simp add: ti_typ_pad_combine_def Let_def
all_field_names_no_padding_ti_pad_combine all_field_names_no_padding_ti_typ_combine [OF not_padding])
lemma all_field_names_map_align[simp]: "all_field_names (map_align n t) = all_field_names t"
by (cases t) (simp add: map_align_def)
lemma all_field_names_no_padding_final_pad:
"filter (Not o qualified_padding_field_name) (all_field_names (final_pad n t))
= filter (Not o qualified_padding_field_name) (all_field_names t)"
by (simp add: final_pad_def Let_def all_field_names_no_padding_ti_pad_combine)
lemmas all_field_names_filter_no_padding_combinator_simps =
all_field_names_no_padding_empty_typ_info
all_field_names_no_padding_final_pad
all_field_names_no_padding_ti_typ_pad_combine
all_field_names_no_padding_ti_typ_combine
lemma all_field_names_array_tag_n: "all_field_names ((array_tag_n n)::('a::c_type,'b::finite) array xtyp_info) =
[] #
concat (map (λi. (map ((#) (replicate i CHR ''1'')) (all_field_names (typ_info_t TYPE('a))))) [0..<n]) "
apply (induct n)
apply (simp add: atn_base)
apply (auto simp add: atn_rec all_field_names_ti_typ_combine)
done
lemma all_field_names_array:
"all_field_names (typ_info_t TYPE('a::c_type['b::finite])) =
[] #
concat (map (λi. (map ((#) (replicate i CHR ''1'')) (all_field_names (typ_info_t TYPE('a))))) [0..<CARD('b)])"
by (simp add: typ_info_array array_tag_def all_field_names_array_tag_n)
lemma not_padding_field_name_replicate_1[simp]: "padding_field_name (replicate n CHR ''1'') = False"
by (cases n) auto
lemma non_empty_not_padding_field_conv: "(x ≠ [] ⟶ ¬ padding_field_name (last x)) ⟷ ¬ qualified_padding_field_name x"
by (cases x) auto
named_theorems all_field_names_no_padding and set_all_field_names_no_padding
definition all_field_names_no_padding :: "('a, 'b) typ_desc ⇒ qualified_field_name list"
where
"all_field_names_no_padding t = filter (Not o qualified_padding_field_name) (all_field_names t)"
lemma all_field_names_no_padding_combinator_simps:
"all_field_names_no_padding (empty_typ_info algn nm) = [[]]"
"all_field_names_no_padding (final_pad n t) = all_field_names_no_padding t"
"¬ padding_field_name fn ⟹
all_field_names_no_padding (ti_typ_pad_combine (t_b::'b::c_type itself) acc upd algn fn t) =
all_field_names_no_padding t @
map ((#) fn)
(all_field_names_no_padding (typ_info_t TYPE('b::c_type)))"
"¬ padding_field_name fn ⟹
all_field_names_no_padding (ti_typ_combine (t_b::'b::c_type itself) acc upd algn fn t) =
all_field_names_no_padding t @
map ((#) fn)
(all_field_names_no_padding (typ_info_t TYPE('b::c_type)))"
by (simp_all add: all_field_names_no_padding_def all_field_names_filter_no_padding_combinator_simps)
lemma all_field_names_filter_no_padding_array:
"filter (Not o qualified_padding_field_name) (all_field_names (typ_info_t TYPE('a::c_type['b::finite]))) =
[] #
concat (map (λi. (map ((#) (replicate i CHR ''1''))
(filter (Not o qualified_padding_field_name) (all_field_names (typ_info_t TYPE('a)))))) [0..<CARD('b)])"
apply (simp add: all_field_names_array)
apply (simp add: filter_concat)
apply (simp add: comp_def filter_map add: non_empty_not_padding_field_conv )
done
lemma all_field_names_no_padding_array[all_field_names_no_padding]:
"all_field_names_no_padding (typ_info_t TYPE('a::c_type['b::finite])) =
[] #
concat (map (λi. (map ((#) (replicate i CHR ''1''))
(all_field_names_no_padding (typ_info_t TYPE('a))))) [0..<CARD('b)])"
by (simp add: all_field_names_no_padding_def all_field_names_filter_no_padding_array)
lemma set_all_field_names_no_padding_array[set_all_field_names_no_padding]:
"set (all_field_names_no_padding (typ_info_t TYPE('a::c_type['b::finite]))) =
insert []
(⋃x∈{0..<CARD('b)}.
(#) (replicate x CHR ''1'') `
set (all_field_names_no_padding (typ_info_t TYPE('a))))"
by (simp add: all_field_names_no_padding_array)
lemma sub_typ_trans: "t ≤⇩τ s ⟹ s ≤⇩τ w ⟹ t ≤⇩τ w"
by (simp add: sub_typ_def)
lemma sub_typ_trans_rev: "s ≤⇩τ w ⟹ t ≤⇩τ s ⟹ t ≤⇩τ w"
by (simp add: sub_typ_def)
lemma element_typ_le_array_typ: "typ_uinfo_t TYPE('a::mem_type) ≤ typ_uinfo_t TYPE('a['b::finite])"
proof -
have "0 < CARD('b)" by simp
from field_lookup_array [OF this, of 0, simplified]
have "field_lookup (typ_info_t TYPE('a['b])) [[]] 0 =
Some (adjust_ti (typ_info_t TYPE('a)) (λx. x.[0]) (λx f. Arrays.update f 0 x), 0)" .
from td_set_field_lookupD [OF this]
have "(adjust_ti (typ_info_t TYPE('a)) (λx. x.[0]) (λx f. Arrays.update f 0 x), 0)
∈ td_set (typ_info_t TYPE('a['b])) 0".
from td_set_export_uinfoD [OF this]
show ?thesis
by (auto simp add: export_uinfo_adjust_ti typ_uinfo_t_def typ_tag_le_def)
qed
lemma element_typ_subtyp_array_typ: "TYPE ('a::mem_type) ≤⇩τ TYPE('a['b::finite])"
by (simp add: sub_typ_def element_typ_le_array_typ)
lemma field_lookup_sub_typ:
assumes fl: "field_lookup (typ_info_t TYPE('a::c_type)) f 0 = Some (s, m)"
assumes match: "export_uinfo s = export_uinfo (typ_info_t TYPE('b::c_type))"
shows "TYPE('b) ≤⇩τ TYPE('a)"
using match td_set_export_uinfoD [OF td_set_field_lookupD [OF fl]]
by (auto simp add: sub_typ_def typ_tag_le_def typ_uinfo_t_def)
lemma field_lookup_sub_typ':
assumes fl: "field_lookup (typ_info_t TYPE('a::c_type)) f 0 ≡ Some (adjust_ti (typ_info_t TYPE('b::mem_type)) acc upd, n)"
assumes fg_cons: "fg_cons acc upd"
shows "TYPE('b) ≤⇩τ TYPE('a)"
apply (rule field_lookup_sub_typ [of f])
apply (simp add: fl)
using fg_cons
by (simp add: export_uinfo_adjust_ti)
lemma all_field_names_no_padding_word[all_field_names_no_padding]:
"all_field_names_no_padding (typ_info_t (TYPE('a::len8 word))) = [[]]"
by (simp add: all_field_names_no_padding_def)
lemma set_all_field_names_no_padding_word[set_all_field_names_no_padding]:
"set (all_field_names_no_padding (typ_info_t (TYPE('a::len8 word)))) = {[]}"
by (simp add: all_field_names_no_padding_def)
lemma all_field_names_no_padding_ptr[all_field_names_no_padding]:
"all_field_names_no_padding (typ_info_t (TYPE('a::c_type ptr))) = [[]]"
by (simp add: all_field_names_no_padding_def)
lemma set_all_field_names_no_padding_ptr[set_all_field_names_no_padding]:
"set (all_field_names_no_padding (typ_info_t (TYPE('a::c_type ptr)))) = {[]}"
by (simp add: all_field_names_no_padding_def)
definition field_names_no_padding::"('a, 'b) typ_info ⇒ typ_uinfo ⇒ qualified_field_name list"
where "field_names_no_padding t s = filter (Not o qualified_padding_field_name) (field_names t s)"
lemma set_field_names_no_padding_all_field_names_no_padding_conv:
"set (field_names_no_padding (typ_info_t TYPE('a::mem_type)) t) =
{f ∈ set (all_field_names_no_padding (typ_info_t TYPE('a))).
∃s n. field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n) ∧ export_uinfo s = t}"
using set_field_names_all_field_names_conv [where 'a='a and t=t]
by (auto simp add: field_ti_def all_field_names_no_padding_def field_names_no_padding_def split: option.split)
lemma field_names_no_padding_all_field_names_no_padding_conv:
"field_names_no_padding (typ_info_t TYPE('a::mem_type)) t =
filter (λf. ∃s n. field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n) ∧ export_uinfo s = t)
(all_field_names_no_padding (typ_info_t TYPE('a)))"
using field_names_all_field_names_conv [where 'a='a and t=t]
by (auto simp add: field_ti_def all_field_names_no_padding_def field_names_no_padding_def intro: filter_same_eq split: option.split)
lemma subset_all_field_names_no_padding_all_field_names:
"set (all_field_names_no_padding t) ⊆ set (all_field_names t)"
by (simp add: all_field_names_no_padding_def)
lemma all_field_names_typ_uinfo_t_conv:
"all_field_names (typ_info_t (TYPE('a::c_type))) = all_field_names (typ_uinfo_t (TYPE('a::c_type)))"
by (simp add: all_field_names_export_uinfo typ_uinfo_t_def)
lemma all_field_names_no_padding_typ_uinfo_t_conv:
"all_field_names_no_padding (typ_info_t (TYPE('a::c_type))) = all_field_names_no_padding (typ_uinfo_t (TYPE('a::c_type)))"
by (simp add: all_field_names_no_padding_def all_field_names_typ_uinfo_t_conv)
lemma update_ti_to_bytes_p[simp]:
"update_ti (typ_info_t TYPE('a::xmem_type)) (to_bytes_p (v::'a)) w = v"
apply (subst field_lookup_update_ti_from_bytes_field_conv[OF
field_lookup_empty , where xbs="replicate (size_of TYPE('a)) 0" and v=v])
unfolding typ_uinfo_t_def apply (rule refl)
apply (simp add: size_of_def)
apply (simp add: to_bytes_p_def to_bytes_def)
apply (subst field_lookup_update_ti_from_bytes_field_conv[symmetric, where vf=v,
OF field_lookup_empty])
apply (simp_all add: size_of_def typ_uinfo_t_def)
apply (simp add: to_bytes_p_def to_bytes_def)
apply (intro lense.update_access)
done
context mem_type
begin
lemma mem_type_access_ti_super_update_bs:
assumes fl: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, n)"
assumes lbs: "length bs = size_of TYPE('a)"
assumes lbs': "length bs' = size_td s"
shows "access_ti (typ_info_t TYPE('a))
(update_ti s (access_ti⇩0 s w) v) (super_update_bs bs' bs n) =
super_update_bs (access_ti s w bs') (access_ti (typ_info_t TYPE('a)) v bs) n"
proof -
have "field_lookup (typ_info_t TYPE('a)) f 0 = Some (s, 0 + n)" using fl by simp
from access_ti_super_update_bs_of_wf(1)[OF this lbs' lbs[unfolded size_of_def]]
show ?thesis by simp
qed
end
lemma update_ti_undefined[simp]:
assumes "NO_MATCH undefined w" assumes bs: "length bs = size_of TYPE('a)"
shows "update_ti (typ_info_t TYPE('a::xmem_type)) bs w =
update_ti (typ_info_t TYPE('a)) bs undefined"
by (simp add: bs size_of_def upd_rf update_ti_update_ti_t)
section ‹‹heap_upd› and ‹heap_upd_list››
section ‹‹heap_upd››
lemma heap_upd_id: "heap_upd (p::'a::xmem_type ptr) id = id"
by (simp add: heap_upd_def fun_eq_iff xmem_type_class.heap_update_id)
lemma heap_upd_const: "heap_upd p (λ_. x) = heap_update p x"
by (simp add: heap_upd_def[abs_def])
lemma heap_upd_comp: "heap_upd (p::'a::xmem_type ptr) (f ∘ g) = heap_upd p f ∘ heap_upd p g"
by (simp add: heap_upd_def fun_eq_iff h_val_heap_update heap_update_collapse)
lemma hrs_mem_update_heap_upd:
"hrs_mem_update (heap_upd p g) h = hrs_mem_update (heap_update p (g (h_val (hrs_mem h) p))) h"
by (cases h) (simp add: hrs_mem_update_def heap_upd_def hrs_mem_def)
lemma heap_update_eq_heap_upd_list:
fixes p :: "'a::mem_type ptr"
shows "heap_update p x =
heap_upd_list (size_of TYPE('a)) (ptr_val p) (access_ti (typ_info_t TYPE('a)) x)"
by (simp add: heap_update_def fun_eq_iff heap_upd_list_def to_bytes_def)
lemma heap_upd_list_id[simp]: "heap_upd_list n p id = id"
by (simp add: heap_upd_list_def fun_eq_iff heap_update_list_id')
lemma heap_upd_list_access_ti_typ_info_t[simp]:
"sz = size_of TYPE('a) ⟹
heap_upd_list sz p (access_ti (typ_info_t TYPE('a::xmem_type)) v) =
heap_update (PTR('a) p) v"
by (simp add: heap_update_def heap_upd_list_def fun_eq_iff to_bytes_def)
lemma heap_list_heap_upd_list:
"n ≤ addr_card ⟹ length xs = n ⟹ (⋀xs. length xs = n ⟹ length (f xs) = n) ⟹
heap_list (heap_upd_list n p f h) n p = f (heap_list h n p)"
unfolding heap_upd_list_def
by (subst heap_list_heap_update_list_id) simp_all
lemma heap_upd_list_comp:
assumes "n ≤ addr_card" "length xs = n"
assumes f: "⋀xs. length xs = n ⟹ length (f xs) = n"
assumes g: "⋀xs. length xs = n ⟹ length (g xs) = n"
shows "heap_upd_list n p (f ∘ g) = heap_upd_list n p f ∘ heap_upd_list n p g"
using assms
by (simp add: fun_eq_iff heap_upd_list_def heap_list_heap_update_list_id
heap_update_list_overwrite)
lemma heap_update_list_append:
fixes v :: word8
shows "heap_update_list s (xs @ ys) hp =
heap_update_list (s + of_nat (length xs)) ys (heap_update_list s xs hp)"
proof (induct xs arbitrary: ys rule: rev_induct)
case Nil
show ?case by simp
next
case (snoc v' vs')
show ?case
apply (simp add: snoc.hyps field_simps)
apply (rule arg_cong [where f = "heap_update_list (1 + (s + of_nat (length vs'))) ys"])
apply (rule ext)
apply simp
done
qed
lemma heap_update_list_super_update_bs:
"length bs + n ≤ length bs' ⟹ length bs' ≤ addr_card ⟹
heap_update_list (p + of_nat n) bs (heap_update_list p bs' h) =
heap_update_list p (super_update_bs bs bs' n) h"
apply (subst super_update_bs_take_drop[symmetric, of n "length bs" bs'])
unfolding super_update_bs_def heap_update_list_append
apply simp_all
apply (subst heap_update_list_commute)
subgoal
apply (subst (2) add_0_right[symmetric])
unfolding intvl_disj_offset add.assoc
apply (cases "length bs + n = length bs'")
apply simp
apply (intro intvl_disj_left)
apply (simp_all add: addr_card_def card_word unat_of_nat_eq)
done
apply (subst heap_update_list_overwrite)
apply simp_all
done
lemma update_ti_adjust_ti:
fixes t::"'a xtyp_info"
and st::"'a xtyp_info_struct"
and ts::"'a xtyp_info_tuple list"
and x::"'a xtyp_info_tuple"
assumes fg_cons: "fg_cons f g"
shows
"update_ti (adjust_ti t (f::'b ⇒ 'a) (g::'a ⇒ 'b ⇒ 'b)) bs v = g (update_ti t bs (f v)) v "
"update_ti_struct (map_td_struct (λn algn d. update_desc f g d) (update_desc f g) st) bs v = g (update_ti_struct st bs (f v)) v"
"update_ti_list (map_td_list (λn algn d. update_desc f g d) (update_desc f g) ts) bs v = g (update_ti_list ts bs (f v)) v"
"update_ti_tuple (map_td_tuple (λn algn d. update_desc f g d) (update_desc f g) x) bs v = g (update_ti_tuple x bs (f v)) v"
unfolding adjust_ti_def
proof (induct t and st and ts and x arbitrary: v bs and v bs and v bs and v bs)
case (TypDesc nat typ_struct list)
then show ?case by auto
next
case (TypScalar nat1 nat2 a)
then show ?case by (auto simp add: update_desc_def)
next
case (TypAggregate list)
then show ?case by auto
next
case Nil_typ_desc
then show ?case using fg_cons by (auto simp add: fg_cons_def)
next
case (Cons_typ_desc dt_tuple list)
then show ?case apply (cases dt_tuple) using fg_cons by (auto simp add: fg_cons_def)
next
case (DTuple_typ_desc typ_desc list b)
then show ?case by auto
qed
lemma field_ti_field_lookupE:
"⟦ field_ti TYPE('a :: c_type) f = Some t; ⋀n. ⟦field_lookup (typ_info_t TYPE('a)) f 0 = Some (t, n) ⟧ ⟹ P ⟧ ⟹ P"
unfolding field_ti_def
by (clarsimp split: option.splits)
lemma field_ti_append_field_lookup:
"field_ti TYPE('a::wf_type) f = Some u ⟹ field_lookup u g l = Some (v, k) ⟹
field_ti TYPE('a) (f @ g) = Some v"
by (auto simp: field_ti_def field_lookup_append split: option.splits)
lemma field_tiD:
"field_ti TYPE('a::mem_type) f = Some t ⟹
field_lookup (typ_info_t TYPE('a)) f 0 = Some (t, field_offset TYPE('a) f)"
by (metis field_lookup_offset_eq field_ti_field_lookupE)
lemma wf_fd_field_lookup_mem_type: "field_lookup (typ_info_t(TYPE('a::mem_type))) f m = Some (s, n) ⟹ wf_fd s"
apply (erule wf_fd_field_lookupD)
by simp
lemma wf_fd_field_ti_mem_type: "field_ti TYPE('a::mem_type) f = Some s ⟹ wf_fd s"
unfolding field_ti_def
by (auto simp add: wf_fd_field_lookup_mem_type split: option.splits prod.splits)
lemma field_lookup_offset_non_zero:
"NO_MATCH 0 m ⟹ field_lookup t f 0 = Some (t', n) ⟹ field_lookup t f m = Some (t', m + n)"
by (simp add: field_lookup_offset' [where m'=0])
lemma field_lookup_append_Some:
assumes wf: "wf_desc t"
shows "field_lookup t (f@g) n = Some (s, m) ⟹
∃w k. field_lookup t f n = Some (w, k) ∧ field_lookup w g k = Some (s, m)"
using wf
proof (induct n ≡ "length (f @ g)" arbitrary: f g n s m t)
case 0
then show ?case by auto
next
case (Suc n)
show ?case
by (metis Suc.prems(1) Suc.prems(2)
field_lookup_prefix_None''(1) field_lookup_prefix_Some''(1) not_Some_eq_tuple)
qed
section ‹‹merge_ti››
definition merge_ti :: "('a field_desc, 'b) typ_desc ⇒ 'a ⇒ 'a ⇒ 'a" where
"merge_ti t a b = update_ti t (access_ti⇩0 t a) b"
lemma merge_ti_adjust_ti[simp]:
"fg_cons g s ⟹ merge_ti (adjust_ti (typ_info_t TYPE('a::xmem_type)) g s) = (λa. s (g a))"
by (simp add: fun_eq_iff merge_ti_def update_ti_adjust_ti)
lemma is_scene_merge_ti:
assumes t: "field_ti TYPE('a::xmem_type) f = Some t" shows "is_scene (merge_ti t)"
proof -
interpret padding_lense "access_ti t" "update_ti t" "size_td t"
using t[THEN field_tiD] by (rule field_lookup_padding_lense)
show ?thesis
proof
show "merge_ti t (merge_ti t a b) c = merge_ti t a c" for a b c
by (simp_all add: merge_ti_def access_ti⇩0_def) (metis access_update update_access)
qed (simp_all add: merge_ti_def access_ti⇩0_def update_access double_update)
qed
lemma merge_ti_update_ti_disj:
assumes *: "field_ti TYPE('a::xmem_type) f = Some t" "field_ti TYPE('a::xmem_type) g = Some u"
and f_g: "disj_fn f g"
assumes bs: "length bs = size_td u"
shows "merge_ti t x (update_ti u bs y) = update_ti u bs (merge_ti t x y)"
proof -
have eq[simp]: "⋀ts us x. length ts = size_td t ⟹ length us = size_td u ⟹
update_ti t ts (update_ti u us x) = update_ti u us (update_ti t ts x)"
using fu_commutes_lookup_disjD[OF *[THEN field_tiD] f_g]
by (simp add: wf_lf_fdp fu_commutes_def update_ti_t_def split: if_splits)
have [simp]: "wf_fd t" "wf_fd u"
using *[THEN wf_fd_field_ti_mem_type] by auto
show ?thesis
by (simp add: merge_ti_def access_ti⇩0_def length_fa_ti bs)
qed
lemma disjnt_scene_merge_ti:
assumes *: "field_ti TYPE('a) f = Some t" "field_ti TYPE('a::xmem_type) g = Some u"
and f_g: "disj_fn f g"
shows "disjnt_scene (merge_ti t) (merge_ti u)"
apply (clarsimp simp: disjnt_scene_def)
apply (subst (2 3) merge_ti_def)
apply (rule merge_ti_update_ti_disj[OF assms])
apply (simp add: *[THEN wf_fd_field_ti_mem_type] length_fa_ti access_ti⇩0_def)
done
lemma access_ti_merge_ti_sub:
assumes r: "field_ti TYPE('a::xmem_type) r = Some t" and t: "field_lookup t f 0 = Some (v, n)"
and bs: "length bs = size_td v"
shows "access_ti v (merge_ti t x y) bs = access_ti v x bs"
proof -
let ?xbs = "super_update_bs bs (replicate (size_td t) 0) n"
let ?x_y = "update_ti t (access_ti t x (replicate (size_td t) 0)) y"
have wf_t: "wf_fd t" "wf_desc t" "wf_size_desc t"
using wf_fd_field_ti_mem_type[OF r] r
field_lookup_wf_desc_pres(1)[of "typ_info_t TYPE('a)" "r" 0]
field_lookup_wf_size_desc_pres(1)[of "typ_info_t TYPE('a)" "r" 0]
by (auto elim: field_ti_field_lookupE)
have length_xbs: "length ?xbs = size_td t"
using field_lookup_offset_size'[OF t] by (subst length_super_update_bs) (simp_all add: bs)
have n_t: "n ≤ length (replicate (size_td t) 0)"
using field_lookup_offset_size'[OF t] by auto
have eq: "access_ti v x bs =
take (size_td v) (drop n (access_ti t x (super_update_bs bs (replicate (size_td t) 0) n)))"
for x
using field_lookup_access_ti_take_drop[OF t wf_t length_xbs]
unfolding take_drop_super_update_bs[OF bs n_t] .
from wf_fd_consD[OF wf_t(1)]
have eq_ac:
"length bs = size_td t ⟹ length bs' = size_td t ⟹
access_ti t (update_ti t bs v) bs' = access_ti t (update_ti t bs v') bs'"
"length bs = size_td t ⟹ update_ti t (access_ti t v bs) v = v"
for bs bs' v v'
by (auto simp: fd_cons_def fd_cons_desc_def fd_cons_update_access_def
fd_cons_access_update_def update_ti_t_def length_fa_ti wf_t)
have [simp]: "access_ti v ?x_y bs = access_ti v x bs" unfolding eq
by (subst eq_ac(1)[of _ _ _ x]) (simp_all add: wf_t length_fa_ti length_xbs eq_ac)
show ?thesis
by (simp add: merge_ti_def fd_cons_access_update_def access_ti⇩0_def)
qed
lemma access_ti_merge_ti_disj:
assumes f: "field_ti TYPE('a::xmem_type) f = Some t"
assumes g: "field_ti TYPE('a::xmem_type) g = Some u"
and f_g: "disj_fn f g"
and bs: "length bs = size_td u"
shows "access_ti u (merge_ti t x y) bs = access_ti u y bs"
apply (subst is_scene.idem[symmetric, OF is_scene_merge_ti, OF g, of y])
apply (subst disjnt_sceneD[OF disjnt_scene_merge_ti, OF f g f_g])
apply (rule access_ti_merge_ti_sub[OF g field_lookup_empty bs])
done
lemma merge_ti_update_ti_sub:
assumes r: "field_ti TYPE('a::xmem_type) r = Some t"
and t: "field_lookup t f 0 = Some (v, n)"
and bs: "length bs = size_td v"
shows "merge_ti t x (update_ti v bs y) = merge_ti t x y"
proof -
have wf_t: "wf_fd t" "wf_desc t" "wf_size_desc t"
using wf_fd_field_ti_mem_type[OF r] r
field_lookup_wf_desc_pres(1)[of "typ_info_t TYPE('a)" "r" 0]
field_lookup_wf_size_desc_pres(1)[of "typ_info_t TYPE('a)" "r" 0]
by (auto elim: field_ti_field_lookupE)
from wf_fd_consD[OF wf_t(1)]
have eq_uu:
"length bs = size_td t ⟹ length bs' = size_td t ⟹
update_ti t bs (update_ti t bs' v) = update_ti t bs v"
for bs bs' v
by (auto simp: fd_cons_def fd_cons_desc_def fd_cons_double_update_def update_ti_t_def
length_fa_ti wf_t split: if_splits)
from wf_fd_consD[OF wf_t(1)]
have eq_ua:
"length bs = size_td t ⟹ update_ti t (access_ti t v bs) v = v"
for bs v
by (auto simp: fd_cons_def fd_cons_desc_def fd_cons_update_access_def update_ti_t_def
length_fa_ti wf_t split: if_splits)
have n_v_t: "n + size_td v ≤ size_td t"
using field_lookup_offset_size'[OF t] by simp
with fi_fu_consistentD[OF t wf_t(1)] have eq_u_sub:
"length bs' = size_td v ⟹ length bs = size_td t ⟹
update_ti t (super_update_bs bs' bs n) y =
update_ti v bs' (update_ti t bs y)" for bs' y bs
by (simp add: update_ti_t_def)
have "update_ti v bs y =
update_ti v bs (update_ti t (access_ti t y (replicate (size_td t) 0)) y)"
by (subst eq_ua) (simp_all add: bs)
also have "… = update_ti t (super_update_bs bs (access_ti t y (replicate (size_td t) 0)) n) y"
by (subst eq_u_sub) (simp_all add: bs length_fa_ti wf_t)
finally show ?thesis
using bs n_v_t by (simp add: access_ti⇩0_def length_fa_ti wf_t eq_uu merge_ti_def)
qed
lemma merge_ti_merge_ti_sub1:
assumes t: "field_ti TYPE('a::xmem_type) f = Some t"
assumes u: "field_ti TYPE('a) (f @ g) = Some u"
shows "merge_ti t a (merge_ti u a b) = merge_ti t a b"
proof -
obtain n m where n: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (t, n)"
and m: "field_lookup (typ_info_t TYPE('a)) (f@g) 0 = Some (u, m)"
using t u by (auto elim!: field_ti_field_lookupE)
from n field_lookup_append_Some[OF _ m] have u': "field_lookup t g 0 = Some (u, m - n)"
by (simp add: CTypes.field_lookup_offset2)
have [simp]: "fd_cons u"
using fd_cons fd_consistentD m by blast
show ?thesis
by (subst (2) merge_ti_def)
(simp add: merge_ti_update_ti_sub[OF t u'] fd_cons_length_p)
qed
lemma merge_ti_merge_ti_sub2:
assumes t: "field_ti TYPE('a::xmem_type) f = Some t"
assumes u: "field_ti TYPE('a) (f @ g) = Some u"
shows "merge_ti u a (merge_ti t a b) = merge_ti t a b"
proof -
obtain n m where n: "field_lookup (typ_info_t TYPE('a)) f 0 = Some (t, n)"
and m: "field_lookup (typ_info_t TYPE('a)) (f@g) 0 = Some (u, m)"
using t u by (auto elim!: field_ti_field_lookupE)
from n field_lookup_append_Some[OF _ m] have u': "field_lookup t g 0 = Some (u, m - n)"
by (simp add: CTypes.field_lookup_offset2)
have [simp]: "fd_cons u"
using fd_cons fd_consistentD m by blast
interpret u: is_scene "merge_ti u"
using u by (rule is_scene_merge_ti)
have eq: "access_ti⇩0 u a = access_ti⇩0 u (merge_ti t a b)"
by (simp add: access_ti_merge_ti_sub[OF t u'] access_ti⇩0_def)
show ?thesis
apply (subst (1) merge_ti_def)
apply (subst eq)
apply (subst (1) merge_ti_def[symmetric])
apply (rule u.idem)
done
qed
lemma comm_scene_merge_ti_sub:
assumes *: "field_ti TYPE('a::xmem_type) f = Some t" "field_ti TYPE('a) (f @ g) = Some u"
shows "comm_scene (merge_ti t) (merge_ti u)"
by (clarsimp simp: comm_scene_def merge_ti_merge_ti_sub1[OF *] merge_ti_merge_ti_sub2[OF *])
lemma comm_scene_merge_ti:
assumes *: "field_ti TYPE('a::xmem_type) f = Some t" "field_ti TYPE('a) g = Some u"
shows "comm_scene (merge_ti t) (merge_ti u)"
proof cases
assume "disj_fn f g"
from disjnt_scene_merge_ti[OF * this] show ?thesis
by blast
next
assume "¬ disj_fn f g"
with * show ?thesis
by (auto simp: disj_fn_def less_eq_list_def prefix_def intro: comm_scene_merge_ti_sub)
qed
subsection ‹‹merge_ti_list››
definition merge_ti_list where
"merge_ti_list ts a = fold (λt. merge_ti t a) ts"
lemma is_scene_merge_ti_list:
"list_all (λu. ∃f. field_ti TYPE('a::xmem_type) f = Some u) ts ⟹
is_scene (merge_ti_list ts)"
unfolding merge_ti_list_def
apply (intro is_scene_fold')
by (auto simp: list_all_iff pairwise_def is_scene_merge_ti)
(meson comm_scene_merge_ti)
lemma merge_ti_list_nil[simp]: "merge_ti_list [] = (λa. id)"
by (simp add: merge_ti_list_def fun_eq_iff)
lemma merge_ti_list_cons[simp]:
"merge_ti_list (t # ts) a = merge_ti_list ts a ∘ merge_ti t a"
by (simp add: merge_ti_list_def)
lemma merge_ti_list_append[simp]:
"merge_ti_list (ts @ ts') x y = merge_ti_list ts' x (merge_ti_list ts x y)"
by (simp add: merge_ti_list_def)
lemma access_ti_merge_ti_list:
assumes ts: "list_all (λ(f, u). field_ti TYPE('a::xmem_type) f = Some u) ts"
"distinct_prop disj_fn (map fst ts)"
and r_t: "(r, t) ∈ set ts" and v: "field_lookup t f 0 = Some (v, n)"
and bs: "length bs = size_td v"
shows "access_ti v (merge_ti_list (map snd ts) x y) bs = access_ti v x bs"
using ts r_t
proof (induction ts rule: rev_induct)
case (snoc r_t ts)
from this(2,3) have *:
"list_all (λ(f, u). field_ti TYPE('a) f = Some u) ts"
"distinct_prop disj_fn (map fst ts)"
and disj: "∀t∈set ts. disj_fn (fst t) (fst r_t)"
and **: "field_ti TYPE('a) (fst r_t) = Some (snd r_t)"
by (auto simp: distinct_prop_append)
show ?case
proof cases
assume [simp]: "r_t = (r, t)"
with ** have ft_r: "field_ti TYPE('a) r = Some t" by simp
show ?thesis
by (simp add: access_ti_merge_ti_sub[OF ft_r v bs])
next
assume "r_t ≠ (r, t)"
with snoc.prems have r_t: "(r, t) ∈ set ts" by auto
with * have "field_ti TYPE('a) r = Some t"
by (auto simp: list_all_iff)
from field_ti_append_field_lookup[OF this v]
have r_f: "field_ti TYPE('a) (r @ f) = Some v" .
from r_t disj
have "disj_fn (fst r_t) r" by (auto simp: disj_fn_def)
then have disj: "disj_fn (fst r_t) (r @ f)"
by (rule disj_fn_append_right)
from snoc.IH[OF * r_t] show ?thesis
by (simp add: access_ti_merge_ti_disj[OF ** r_f disj bs])
qed
qed simp
lemma merge_ti_list_update_ti:
assumes ts: "list_all (λ(f, u). field_ti TYPE('a::xmem_type) f = Some u) ts" "(f_t, t) ∈ set ts"
and disj: "distinct_prop disj_fn (map fst ts)"
and t: "field_lookup t f 0 = Some (v, n)"
and bs: "length bs = size_td v"
shows "merge_ti_list (map snd ts) x (update_ti v bs y) = merge_ti_list (map snd ts) x y"
using ts disj
proof (induction ts arbitrary: y)
case (Cons u' ts)
then obtain t' f' where ts[simp]: "list_all (λ(f, u). field_ti TYPE('a) f = Some u) ts"
and f': "field_ti TYPE('a) f' = Some t'"
and t': "t = t' ∨ (t ≠ t' ∧ (f_t, t) ∈ set ts)" and u': "u' = (f', t')"
and f'_ts: "∀x∈set ts. disj_fn f' (fst x)"
and [simp]: "distinct_prop disj_fn (map fst ts)"
by auto
from Cons have f_t: "field_ti TYPE('a) f_t = Some t"
by (auto simp: list_all_iff)
show ?case using t'
proof (elim disjE conjE)
assume t_eq: "t = t'"
have "merge_ti t' x (update_ti v bs y) = merge_ti t' x y"
using f' t[unfolded t_eq] bs by (rule merge_ti_update_ti_sub)
then show ?thesis
by (simp add: u')
next
assume ne: "t ≠ t'" and mem: "(f_t, t) ∈ set ts"
with f'_ts have "disj_fn f' f_t" by auto
then have disj: "disj_fn f' (f_t @ f)"
by (rule disj_fn_append_right)
have "merge_ti t' x (update_ti v bs y) = update_ti v bs (merge_ti t' x y)"
using f' field_ti_append_field_lookup[OF f_t t] disj bs by (rule merge_ti_update_ti_disj)
then show ?thesis
by (simp add: Cons mem u')
qed
qed simp
lemma heap_update_eq_fold_subfields:
assumes ts: "list_all (λ(f, u). field_ti TYPE('a::xmem_type) f = Some u) ts"
shows "heap_update p x =
fold (λ(f, u). heap_upd_list (size_td u) &(p→f) (access_ti u x)) ts ∘
heap_upd_list (size_of TYPE('a)) (ptr_val p)
(access_ti (typ_info_t TYPE('a)) (merge_ti_list (map snd ts) y x))"
proof -
have snd_ts: "list_all (λu. ∃f. field_ti TYPE('a::xmem_type) f = Some u) (map snd ts)"
using ts unfolding list.pred_map by (rule list.pred_mono_strong) auto
then interpret merge_ti_list: is_scene "merge_ti_list (map snd ts)"
by (rule is_scene_merge_ti_list)
have "heap_upd_list (size_of TYPE('a)) (ptr_val p)
(access_ti (typ_info_t TYPE('a)) (merge_ti_list (map snd ts) x z)) =
fold (λ(f, u). heap_upd_list (size_td u) &(p→f) (access_ti u x)) ts ∘
heap_upd_list (size_of TYPE('a)) (ptr_val p) (access_ti (typ_info_t TYPE('a)) z)" for z
using ts
proof (induction ts arbitrary: z)
case (Cons t ts)
then obtain f u where ts: "list_all (λa. case a of (f, u) ⇒ field_ti TYPE('a) f = Some u) ts"
and f: "field_ti TYPE('a) f = Some u" and t: "t = (f, u)"
by (cases t) auto
have wf_u: "wf_fd u" using f by (rule wf_fd_field_ti_mem_type)
have sz[arith]: "size_td u + field_offset TYPE('a) f ≤ size_of TYPE('a)"
using f[THEN field_tiD, THEN field_lookup_offset_size'] by (simp add: size_of_def)
interpret padding_lense "access_ti u" "update_ti u" "size_td u"
by (rule field_lookup_padding_lense[OF field_tiD, OF f])
from field_access_eq_padding1[unfolded eq_padding_def]
have access_ti_access_ti:
"length bs = size_td u ⟹ access_ti u v (access_ti u w bs) = access_ti u v bs" for v w bs
by auto
have "heap_upd_list (size_of TYPE('a)) (ptr_val p)
(access_ti (typ_info_t TYPE('a)) (update_ti u (access_ti⇩0 u x) z)) =
heap_upd_list (size_td u) &(p→f) (access_ti u x) ∘
heap_upd_list (size_of TYPE('a)) (ptr_val p) (access_ti (typ_info_t TYPE('a)) z)"
apply (rule ext)
subgoal for h unfolding heap_upd_list_def
apply (simp add: field_lvalue_def)
apply (subst heap_list_update_list)
subgoal by (simp add: lense.access_result_size)
subgoal by (simp add: lense.access_result_size)
apply (subst heap_update_list_super_update_bs)
subgoal by (simp add: lense.access_result_size length_fa_ti wf_u)
subgoal using max_size[where 'a='a, arith] by (simp add: lense.access_result_size)
apply (subst mem_type_field_lookup_access_ti_take_drop[symmetric])
apply (rule f[THEN field_tiD])
apply simp
apply (subst access_ti_access_ti)
apply simp
apply (subst mem_type_access_ti_super_update_bs[symmetric, OF field_tiD, OF f])
apply (simp_all add: super_update_bs_take_drop)
done
done
then show ?case
unfolding fold_Cons t by (simp add: Cons.IH[OF ts] merge_ti_def)
qed simp
then show ?thesis
apply (subst heap_update_eq_heap_upd_list)
apply (subst merge_ti_list.idem[symmetric])
apply (subst merge_ti_list.right[symmetric])
apply (simp del: merge_ti_list.right)
done
qed
end