(* * Copyright 2014, General Dynamics C4 Systems * * This software may be distributed and modified according to the terms of * the GNU General Public License version 2. Note that NO WARRANTY is provided. * See "LICENSE_GPLv2.txt" for details. * * @TAG(GD_GPL) *) theory CSpace_C imports CSpaceAcc_C Machine_C begin context kernel_m begin lemma maskCapRights_cap_cases: "return (maskCapRights R c) = (case c of ArchObjectCap ac \ return (Arch.maskCapRights R ac) | EndpointCap _ _ _ _ _ \ return (capEPCanGrant_update (\_. capEPCanGrant c \ capAllowGrant R) (capEPCanReceive_update (\_. capEPCanReceive c \ capAllowRead R) (capEPCanSend_update (\_. capEPCanSend c \ capAllowWrite R) c))) | NotificationCap _ _ _ _ \ return (capNtfnCanReceive_update (\_. capNtfnCanReceive c \ capAllowRead R) (capNtfnCanSend_update (\_. capNtfnCanSend c \ capAllowWrite R) c)) | _ \ return c)" apply (simp add: maskCapRights_def Let_def split del: if_split) apply (cases c; simp add: isCap_simps split del: if_split) done lemma imp_ignore: "B \ A \ B" by blast lemma wordFromVMRights_spec: "\s. \ \ {s} Call wordFromVMRights_'proc \\ret__unsigned_long = \<^bsup>s\<^esup>vm_rights\" by vcg simp? lemma vmRightsFromWord_spec: "\s. \ \ {s} Call vmRightsFromWord_'proc \\ret__unsigned_long = \<^bsup>s\<^esup>w\" by vcg simp? lemmas vmrights_defs = Kernel_C.VMNoAccess_def Kernel_C.VMReadOnly_def Kernel_C.VMKernelOnly_def Kernel_C.VMReadWrite_def lemma maskVMRights_spec: "\s. \ \ ({s} \ \ \vm_rights && mask 2 = \vm_rights \) Call maskVMRights_'proc \ vmrights_to_H \ret__unsigned_long = maskVMRights (vmrights_to_H \<^bsup>s\<^esup>vm_rights) (cap_rights_to_H (seL4_CapRights_lift \<^bsup>s\<^esup>cap_rights_mask)) \ \ret__unsigned_long && mask 2 = \ret__unsigned_long \" apply vcg apply clarsimp apply (rule conjI) apply ((auto simp: vmrights_to_H_def maskVMRights_def vmrights_defs cap_rights_to_H_def to_bool_def split: bool.split | simp add: mask_def | word_bitwise)+)[1] apply clarsimp apply (subgoal_tac "vm_rights = 0 \ vm_rights = 1 \ vm_rights = 2 \ vm_rights = 3") apply (auto simp: vmrights_to_H_def maskVMRights_def vmrights_defs cap_rights_to_H_def seL4_CapRights_lift_def to_bool_def mask_def split: bool.splits)[1] apply (subst(asm) mask_eq_iff_w2p) apply (simp add: word_size) apply (rule ccontr, clarsimp) apply (drule inc_le, simp, drule(1) order_le_neq_trans [OF _ not_sym])+ apply (drule inc_le, simp) done lemma small_frame_cap_rights [simp]: "cap_get_tag cap = scast cap_small_frame_cap \ cap_small_frame_cap_CL.capFVMRights_CL (cap_small_frame_cap_lift cap) && mask 2 = cap_small_frame_cap_CL.capFVMRights_CL (cap_small_frame_cap_lift cap)" apply (simp add: cap_small_frame_cap_lift_def) by (simp add: cap_lift_def cap_tag_defs mask_def word_bw_assocs) lemma frame_cap_rights [simp]: "cap_get_tag cap = scast cap_frame_cap \ cap_frame_cap_CL.capFVMRights_CL (cap_frame_cap_lift cap) && mask 2 = cap_frame_cap_CL.capFVMRights_CL (cap_frame_cap_lift cap)" apply (simp add: cap_frame_cap_lift_def) by (simp add: cap_lift_def cap_tag_defs mask_def word_bw_assocs) lemma Arch_maskCapRights_ccorres [corres]: "ccorres ccap_relation ret__struct_cap_C_' \ (UNIV \ \ccap_relation (ArchObjectCap arch_cap) \cap\ \ \ccap_rights_relation R \cap_rights_mask\) [] (return (Arch.maskCapRights R arch_cap)) (Call Arch_maskCapRights_'proc)" apply (cinit' (trace) lift: cap_' cap_rights_mask_') apply csymbr apply (unfold ARM_H.maskCapRights_def) apply (simp only: Let_def) apply (case_tac "cap_get_tag cap = scast cap_small_frame_cap") apply (clarsimp simp add: ccorres_cond_iffs cap_get_tag_isCap isCap_simps) apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: cap_get_tag_isCap isCap_simps) apply (clarsimp simp: return_def) apply (unfold ccap_relation_def)[1] apply (simp add: cap_small_frame_cap_lift [THEN iffD1]) apply (clarsimp simp: cap_to_H_def) apply (simp add: map_option_case split: option.splits) apply (clarsimp simp add: cap_to_H_def Let_def split: cap_CL.splits if_split_asm) apply (simp add: cap_small_frame_cap_lift_def) apply (simp add: ccap_rights_relation_def) apply (simp add: cap_small_frame_cap_lift_def) apply (simp add: ccap_rights_relation_def) apply (simp add: pageSize_def) apply (simp add: pageSize_def) apply (clarsimp simp add: cap_get_tag_isCap isCap_simps simp del: not_ex) apply (rule conjI, clarsimp) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_guard_imp) apply (csymbr) apply (case_tac "cap_get_tag cap = scast cap_frame_cap") apply (clarsimp simp add: ccorres_cond_iffs cap_get_tag_isCap isCap_simps simp del: not_ex) apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp: cap_get_tag_isCap isCap_simps simp del: not_ex) apply (clarsimp simp: return_def) apply (unfold ccap_relation_def)[1] apply (simp add: cap_frame_cap_lift [THEN iffD1]) apply (clarsimp simp: cap_to_H_def) apply (simp add: map_option_case split: option.splits) apply (clarsimp simp add: isCap_simps pageSize_def cap_to_H_def Let_def simp del: not_ex split: cap_CL.splits if_split_asm) apply (simp add: cap_frame_cap_lift_def) apply (simp add: ccap_rights_relation_def) apply (simp add: c_valid_cap_def cl_valid_cap_def cap_lift_frame_cap) apply (simp add: cap_frame_cap_lift_def) apply (simp add: ccap_rights_relation_def) apply (simp add: c_valid_cap_def cl_valid_cap_def cap_lift_frame_cap) apply (clarsimp simp add: cap_get_tag_isCap isCap_simps simp del: not_ex)+ apply (simp add: ccorres_cond_iffs) apply (rule ccorres_from_vcg_throws) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp add: return_def simp del: not_ex) apply (cases arch_cap) by (fastforce simp add: cap_get_tag_isCap isCap_simps simp del: not_ex omgwtfbbq)+ lemma to_bool_mask_to_bool_bf: "to_bool (x && mask (Suc 0)) = to_bool_bf (x::word32)" apply (simp add: to_bool_bf_def to_bool_def) apply (rule iffI) prefer 2 apply simp apply (subgoal_tac "x && mask (Suc 0) < 2^(Suc 0)") apply simp apply (drule word_less_cases [where y=2]) apply auto[1] apply (rule and_mask_less') apply simp done lemma to_bool_cap_rights_bf: "to_bool (capAllowRead_CL (seL4_CapRights_lift R)) = to_bool_bf (capAllowRead_CL (seL4_CapRights_lift R))" "to_bool (capAllowWrite_CL (seL4_CapRights_lift R)) = to_bool_bf (capAllowWrite_CL (seL4_CapRights_lift R))" "to_bool (capAllowGrant_CL (seL4_CapRights_lift R)) = to_bool_bf (capAllowGrant_CL (seL4_CapRights_lift R))" by (subst to_bool_bf_to_bool_mask, simp add: seL4_CapRights_lift_def mask_def word_bw_assocs, simp)+ lemma to_bool_ntfn_cap_bf: "cap_lift c = Some (Cap_notification_cap cap) \ to_bool (capNtfnCanSend_CL cap) = to_bool_bf (capNtfnCanSend_CL cap) \ to_bool (capNtfnCanReceive_CL cap) = to_bool_bf (capNtfnCanReceive_CL cap)" apply (simp add:cap_lift_def Let_def split: if_split_asm) apply (subst to_bool_bf_to_bool_mask, clarsimp simp: cap_lift_thread_cap mask_def word_bw_assocs)+ apply simp done lemma to_bool_ep_cap_bf: "cap_lift c = Some (Cap_endpoint_cap cap) \ to_bool (capCanSend_CL cap) = to_bool_bf (capCanSend_CL cap) \ to_bool (capCanReceive_CL cap) = to_bool_bf (capCanReceive_CL cap) \ to_bool (capCanGrant_CL cap) = to_bool_bf (capCanGrant_CL cap)" apply (simp add:cap_lift_def Let_def split: if_split_asm) apply (subst to_bool_bf_to_bool_mask, clarsimp simp: cap_lift_thread_cap mask_def word_bw_assocs)+ apply simp done lemma isArchCap_spec: "\s. \\ {s} Call isArchCap_'proc \\ret__unsigned_long = from_bool (isArchCap_tag (cap_get_tag (cap_' s)))\" apply vcg apply (clarsimp simp: from_bool_def isArchCap_tag_def bool.split) apply (clarsimp simp: word_mod_2p_is_mask[where n=1, simplified] mask_def) apply word_bitwise done lemma maskCapRights_ccorres [corres]: "ccorres ccap_relation ret__struct_cap_C_' \ (UNIV \ \ccap_relation cap \cap\ \ \ccap_rights_relation R \cap_rights\) [] (return (RetypeDecls_H.maskCapRights R cap)) (Call maskCapRights_'proc)" apply (cinit' lift: cap_' cap_rights_') apply csymbr apply (simp add: maskCapRights_cap_cases cap_get_tag_isCap del: Collect_const) apply wpc apply (simp add: Collect_const_mem from_bool_def) apply csymbr apply (simp add: cap_get_tag_isCap isCap_simps del: Collect_const) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (rule allI) apply (rule conseqPre) apply vcg apply clarsimp apply (simp add: cap_get_tag_isCap isCap_simps return_def) apply (simp add: Collect_const_mem from_bool_def) apply csymbr apply (simp add: cap_get_tag_isCap isCap_simps del: Collect_const) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (rule allI) apply (rule conseqPre) apply vcg apply (clarsimp simp: return_def) apply (simp add: Collect_const_mem from_bool_def) apply csymbr apply (simp add: cap_get_tag_isCap isCap_simps del: Collect_const) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (rule allI) apply (rule conseqPre) apply vcg apply clarsimp apply (simp add: cap_get_tag_isCap isCap_simps return_def) apply (rule imp_ignore) apply (rule imp_ignore) apply (rule imp_ignore) apply (rule imp_ignore) apply (rule imp_ignore) apply clarsimp apply (unfold ccap_relation_def)[1] apply (simp add: cap_notification_cap_lift [THEN iffD1]) apply (clarsimp simp: cap_to_H_def) apply (simp add: map_option_case split: option.splits) apply (clarsimp simp add: cap_to_H_def Let_def split: cap_CL.splits if_split_asm) apply (simp add: cap_notification_cap_lift_def) apply (simp add: ccap_rights_relation_def cap_rights_to_H_def to_bool_ntfn_cap_bf to_bool_mask_to_bool_bf to_bool_cap_rights_bf) apply (simp add: Collect_const_mem from_bool_def) apply csymbr apply (simp add: cap_get_tag_isCap isCap_simps ccorres_cond_iffs) apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (rule allI) apply (rule conseqPre) apply vcg apply (clarsimp simp: cap_get_tag_isCap isCap_simps return_def) apply (simp add: Collect_const_mem from_bool_def) apply csymbr apply (simp add: cap_get_tag_isCap isCap_simps ccorres_cond_iffs) apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (rule allI) apply (rule conseqPre) apply vcg apply clarsimp apply (simp add: cap_get_tag_isCap isCap_simps return_def) apply (rule imp_ignore) apply (rule imp_ignore) apply (rule imp_ignore) apply (rule imp_ignore) apply (rule imp_ignore) apply (rule imp_ignore) apply (rule imp_ignore) apply (rule imp_ignore) apply clarsimp apply (unfold ccap_relation_def)[1] apply (simp add: cap_endpoint_cap_lift [THEN iffD1]) apply (clarsimp simp: cap_to_H_def) apply (simp add: map_option_case split: option.splits) apply (clarsimp simp add: cap_to_H_def Let_def split: cap_CL.splits if_split_asm) apply (simp add: cap_endpoint_cap_lift_def) apply (simp add: ccap_rights_relation_def cap_rights_to_H_def to_bool_ep_cap_bf to_bool_mask_to_bool_bf to_bool_cap_rights_bf) apply (simp add: Collect_const_mem from_bool_def) apply csymbr apply (simp add: cap_get_tag_isCap isCap_simps del: Collect_const) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (rule allI) apply (rule conseqPre) apply vcg apply (clarsimp simp: return_def) apply (simp add: Collect_const_mem from_bool_def) apply csymbr apply (simp add: cap_get_tag_isCap isCap_simps ccorres_cond_iffs) apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (rule allI) apply (rule conseqPre) apply vcg apply (clarsimp simp: cap_get_tag_isCap isCap_simps return_def) apply (simp add: Collect_const_mem from_bool_def) apply (subst bind_return [symmetric]) apply (rule ccorres_split_throws) apply ctac apply (rule_tac P=\ and P'="\\ret__struct_cap_C = ret__struct_cap_C\" in ccorres_inst) apply (rule ccorres_from_vcg_throws) apply (clarsimp simp: return_def) apply (rule conseqPre) apply vcg apply clarsimp apply wp apply vcg apply vcg apply (simp add: Collect_const_mem from_bool_def) apply csymbr apply (simp add: cap_get_tag_isCap isCap_simps del: Collect_const) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (rule allI) apply (rule conseqPre) apply vcg apply (clarsimp simp: return_def) apply (simp add: Collect_const_mem from_bool_def) apply csymbr apply (simp add: cap_get_tag_isCap isCap_simps del: Collect_const) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (rule allI) apply (rule conseqPre) apply vcg apply (clarsimp simp: return_def) apply (simp add: Collect_const_mem from_bool_def) apply csymbr apply (simp add: cap_get_tag_isCap isCap_simps del: Collect_const) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (rule allI) apply (rule conseqPre) apply vcg apply clarsimp apply (simp add: cap_get_tag_isCap isCap_simps return_def) apply (simp add: Collect_const_mem from_bool_def) apply csymbr apply (simp add: cap_get_tag_isCap isCap_simps del: Collect_const) apply (simp add: ccorres_cond_iffs) apply (rule ccorres_from_vcg_throws [where P=\ and P'=UNIV]) apply (rule allI) apply (rule conseqPre) apply vcg apply (clarsimp simp: return_def) apply clarsimp done abbreviation "lookupCap_xf \ liftxf errstate lookupCap_ret_C.status_C lookupCap_ret_C.cap_C ret__struct_lookupCap_ret_C_'" lemma ccorres_return_cte_cteCap [corres]: fixes ptr' :: "cstate \ cte_C ptr" assumes r1: "\s s' g. (s, s') \ rf_sr \ (s, xfu g s') \ rf_sr" and xf_xfu: "\s g. xf (xfu g s) = g s" shows "ccorres ccap_relation xf (\s. ctes_of s ptr = Some cte) {s. ptr_val (ptr' s) = ptr} hs (return (cteCap cte)) (Basic (\s. xfu (\_. h_val (hrs_mem (t_hrs_' (globals s))) (Ptr &(ptr' s \[''cap_C'']))) s))" apply (rule ccorres_return) apply (rule conseqPre) apply vcg apply (clarsimp simp: xf_xfu ccap_relation_def) apply rule apply (erule r1) apply (drule (1) rf_sr_ctes_of_clift) apply (clarsimp simp: typ_heap_simps) apply (simp add: c_valid_cte_def) done lemma ccorres_return_cte_mdbnode [corres]: fixes ptr' :: "cstate \ cte_C ptr" assumes r1: "\s s' g. (s, s') \ rf_sr \ (s, xfu g s') \ rf_sr" and xf_xfu: "\s g. xf (xfu g s) = g s" shows "ccorres cmdbnode_relation xf (\s. ctes_of s ptr = Some cte) {s. ptr_val (ptr' s) = ptr} hs (return (cteMDBNode cte)) (Basic (\s. xfu (\_. h_val (hrs_mem (t_hrs_' (globals s))) (Ptr &(ptr' s \[''cteMDBNode_C'']))) s))" apply (rule ccorres_from_vcg) apply (rule allI, rule conseqPre, vcg) apply (clarsimp simp add: return_def xf_xfu) apply (frule (1) rf_sr_ctes_of_clift) apply (clarsimp simp: typ_heap_simps) apply (erule r1) done (* FIXME: MOVE *) lemma heap_update_field_ext: "\field_ti TYPE('a :: packed_type) f = Some t; c_guard p; export_uinfo t = export_uinfo (typ_info_t TYPE('b :: packed_type))\ \ heap_update (Ptr &(p\f) :: 'b ptr) = (\v hp. heap_update p (update_ti t (to_bytes_p v) (h_val hp p)) hp)" apply (rule ext, rule ext) apply (erule (2) heap_update_field) done lemma ccorres_updateCap [corres]: fixes ptr :: "cstate \ cte_C ptr" and val :: "cstate \ cap_C" shows "ccorres dc xfdc \ ({s. ccap_relation cap (val s)} \ {s. ptr s = Ptr dest}) hs (updateCap dest cap) (Basic (\s. globals_update (t_hrs_'_update (hrs_mem_update (heap_update (Ptr &(ptr s\[''cap_C''])) (val s)))) s))" unfolding updateCap_def apply (cinitlift ptr) apply (erule ssubst) apply (rule ccorres_guard_imp2) apply (rule ccorres_pre_getCTE) apply (rule_tac P = "\s. ctes_of s dest = Some rva" in ccorres_from_vcg [where P' = "{s. ccap_relation cap (val s)}"]) apply (rule allI) apply (rule conseqPre) apply vcg apply clarsimp apply (rule fst_setCTE [OF ctes_of_cte_at], assumption) apply (erule bexI [rotated]) apply (clarsimp simp: cte_wp_at_ctes_of) apply (frule (1) rf_sr_ctes_of_clift) apply (clarsimp simp add: rf_sr_def cstate_relation_def Let_def cpspace_relation_def cvariable_array_map_const_add_map_option[where f="tcb_no_ctes_proj"]) apply (simp add:typ_heap_simps) apply (rule conjI) apply (erule (3) cpspace_cte_relation_upd_capI) apply (frule_tac f="ksPSpace" in arg_cong) apply (erule_tac t = s' in ssubst) apply simp apply (simp add: heap_to_user_data_def heap_to_device_data_def) apply (rule conjI) apply (erule (1) setCTE_tcb_case) subgoal by (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps) by clarsimp lemma ccorres_updateMDB_const [corres]: fixes ptr :: "cstate \ cte_C ptr" and val :: "cstate \ mdb_node_C" shows "ccorres dc xfdc (\_. dest \ 0) ({s. cmdbnode_relation m (val s)} \ {s. ptr s = Ptr dest}) hs (updateMDB dest (const m)) (Basic (\s. globals_update (t_hrs_'_update (hrs_mem_update (heap_update (Ptr &(ptr s\[''cteMDBNode_C''])) (val s)))) s))" unfolding updateMDB_def apply (cinitlift ptr) apply (erule ssubst) apply (rule ccorres_gen_asm [where G = \, simplified]) apply (simp only: Let_def) apply simp apply (rule ccorres_guard_imp2) apply (rule ccorres_pre_getCTE) apply (rule_tac P = "\s. ctes_of s dest = Some cte" in ccorres_from_vcg [where P' = "{s. cmdbnode_relation m (val s)}"]) apply (rule allI) apply (rule conseqPre) apply vcg apply clarsimp apply (rule fst_setCTE [OF ctes_of_cte_at], assumption ) apply (erule bexI [rotated]) apply (frule (1) rf_sr_ctes_of_clift) apply (clarsimp simp add: rf_sr_def cstate_relation_def typ_heap_simps Let_def cpspace_relation_def cvariable_array_map_const_add_map_option[where f="tcb_no_ctes_proj"]) apply (rule conjI) apply (erule (3) cspace_cte_relation_upd_mdbI) apply (erule_tac t = s' in ssubst) apply (simp add: heap_to_user_data_def) apply (rule conjI) apply (erule (1) setCTE_tcb_case) apply (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps) apply (clarsimp) done lemma cap_lift_capNtfnBadge_mask_eq: "cap_lift cap = Some (Cap_notification_cap ec) \ capNtfnBadge_CL ec && mask 28 = capNtfnBadge_CL ec" unfolding cap_lift_def by (fastforce simp: Let_def mask_def word_bw_assocs split: if_split_asm) lemma cap_lift_capEPBadge_mask_eq: "cap_lift cap = Some (Cap_endpoint_cap ec) \ capEPBadge_CL ec && mask 28 = capEPBadge_CL ec" unfolding cap_lift_def by (fastforce simp: Let_def mask_def word_bw_assocs split: if_split_asm) lemma revokable_ccorres: "\ccap_relation cap newCap; cmdbnode_relation rva srcMDB; ccap_relation rvb srcCap; ret__unsigned = cap_get_tag newCap \ \ ccorres (\a c. from_bool a = c) newCapIsRevocable_' (\_. capMasterCap cap = capMasterCap rvb \ is_simple_cap' cap) UNIV hs (return (revokable' rvb cap)) (IF ret__unsigned = scast cap_endpoint_cap THEN \ret__unsigned :== CALL cap_endpoint_cap_get_capEPBadge(newCap);; \unsigned_eret_2 :== CALL cap_endpoint_cap_get_capEPBadge(srcCap);; \newCapIsRevocable :== (if \ret__unsigned \ \unsigned_eret_2 then 1 else 0) ELSE IF ret__unsigned = scast cap_notification_cap THEN \ret__unsigned :== CALL cap_notification_cap_get_capNtfnBadge(newCap);; \unsigned_eret_2 :== CALL cap_notification_cap_get_capNtfnBadge(srcCap);; \newCapIsRevocable :== (if \ret__unsigned \ \unsigned_eret_2 then 1 else 0) ELSE IF ret__unsigned = scast cap_irq_handler_cap THEN \ret__unsigned :== CALL cap_get_capType(srcCap);; \newCapIsRevocable :== (if \ret__unsigned = scast cap_irq_control_cap then 1 else 0) ELSE IF ret__unsigned = scast cap_untyped_cap THEN \newCapIsRevocable :== scast true ELSE \newCapIsRevocable :== scast false FI FI FI FI)" unfolding revokable'_fold apply (rule ccorres_gen_asm [where G = \, simplified]) apply (cases cap) apply (simp add: cap_get_tag_isCap isCap_simps ccorres_cond_iffs from_bool_def true_def false_def, rule ccorres_return, vcg, fastforce simp: cap_get_tag_isCap isCap_simps) apply (simp add: cap_get_tag_isCap isCap_simps ccorres_cond_iffs from_bool_def true_def false_def, rule ccorres_return, vcg, fastforce simp: cap_get_tag_isCap isCap_simps) apply (simp add: cap_get_tag_isCap isCap_simps ccorres_cond_iffs from_bool_def true_def false_def) apply (rule ccorres_return, vcg) apply (frule cap_get_tag_NotificationCap [where cap' = srcCap, THEN iffD1]) apply (clarsimp simp: cap_get_tag_isCap isCap_simps is_simple_cap'_def) apply (frule cap_get_tag_NotificationCap [where cap' = newCap, THEN iffD1]) apply (clarsimp simp: cap_get_tag_isCap isCap_simps) apply (fastforce simp: cap_get_tag_isCap isCap_simps) apply (clarsimp simp: cap_get_tag_isCap isCap_simps ccorres_cond_iffs from_bool_def true_def false_def, rule ccorres_return, vcg, fastforce simp: cap_get_tag_isCap isCap_simps) apply (clarsimp simp: cap_get_tag_isCap isCap_simps ccorres_cond_iffs from_bool_def true_def false_def) apply (rule ccorres_return, vcg) apply (frule cap_get_tag_EndpointCap [where cap' = srcCap, THEN iffD1]) apply (clarsimp simp: cap_get_tag_isCap isCap_simps is_simple_cap'_def) apply (frule cap_get_tag_EndpointCap [where cap' = newCap, THEN iffD1]) apply (clarsimp simp: cap_get_tag_isCap isCap_simps is_simple_cap'_def) apply (fastforce simp: cap_get_tag_isCap isCap_simps) by (clarsimp simp: cap_get_tag_isCap isCap_simps ccorres_cond_iffs from_bool_def true_def false_def, rule ccorres_return, vcg, fastforce simp: cap_get_tag_isCap isCap_simps)+ lemma from_bool_mask_simp [simp]: "((from_bool r) :: word32) && mask (Suc 0) = from_bool r" unfolding from_bool_def apply (rule less_mask_eq) apply (clarsimp split: bool.splits) done lemma cteInsert_ccorres_mdb_helper: "\cmdbnode_relation rva srcMDB; from_bool rvc = (newCapIsRevocable :: word32); srcSlot = Ptr src\ \ ccorres cmdbnode_relation newMDB_' (K (is_aligned src 3)) UNIV hs (return (mdbFirstBadged_update (\_. rvc) (mdbRevocable_update (\_. rvc) (mdbPrev_update (\_. src) rva)))) (\newMDB :== CALL mdb_node_set_mdbPrev(srcMDB, ptr_val srcSlot);; \newMDB :== CALL mdb_node_set_mdbRevocable(\newMDB, newCapIsRevocable);; \newMDB :== CALL mdb_node_set_mdbFirstBadged(\newMDB, newCapIsRevocable))" apply (rule ccorres_from_vcg) apply (rule allI) apply (rule conseqPre) apply vcg apply (clarsimp simp: return_def) apply (simp add: cmdbnode_relation_def) done lemma ccorres_updateMDB_set_mdbNext [corres]: "src=src' \ ccorres dc xfdc ((\_. src \ 0 \ (dest\0 \ is_aligned dest 3))) ({s. mdb_node_ptr_' s = Ptr &((Ptr src' :: cte_C ptr)\[''cteMDBNode_C''])} \ {s. v_' s = dest}) [] (updateMDB src (mdbNext_update (\_. dest))) (Call mdb_node_ptr_set_mdbNext_'proc)" unfolding updateMDB_def apply (hypsubst) apply (rule ccorres_gen_asm [where G = \, simplified]) apply (simp only: Let_def) apply simp apply (rule ccorres_guard_imp2) apply (rule ccorres_pre_getCTE [where P = "\cte s. ctes_of s src' = Some cte" and P' = "\_. (\\mdb_node_ptr = Ptr &((Ptr src' :: cte_C ptr)\[''cteMDBNode_C''])\ \ \\v = dest\)"]) apply (rule ccorres_from_spec_modifies_heap) apply (rule mdb_node_ptr_set_mdbNext_spec) apply (rule mdb_node_ptr_set_mdbNext_modifies) apply simp apply clarsimp apply (rule rf_sr_cte_at_valid) apply simp apply (erule ctes_of_cte_at) apply assumption apply clarsimp apply (frule (1) rf_sr_ctes_of_clift) apply (clarsimp simp: typ_heap_simps) apply (rule fst_setCTE [OF ctes_of_cte_at], assumption) apply (erule bexI [rotated]) apply (clarsimp simp add: rf_sr_def cstate_relation_def Let_def cpspace_relation_def cte_wp_at_ctes_of heap_to_user_data_def cvariable_array_map_const_add_map_option[where f="tcb_no_ctes_proj"] typ_heap_simps') apply (rule conjI) apply (erule (2) cspace_cte_relation_upd_mdbI) apply (simp add: cmdbnode_relation_def) subgoal for _ s' by (cases "v_' s' = 0"; simp) apply (erule_tac t = s'a in ssubst) apply simp apply (rule conjI) apply (erule (1) setCTE_tcb_case) subgoal by (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps h_t_valid_clift_Some_iff) apply clarsimp done lemma ccorres_updateMDB_set_mdbPrev [corres]: "src=src' \ ccorres dc xfdc ((\_. src \ 0 \ (dest\0 \is_aligned dest 3)) ) ({s. mdb_node_ptr_' s = Ptr &((Ptr src' :: cte_C ptr)\[''cteMDBNode_C''])} \ {s. v_' s = dest}) [] (updateMDB src (mdbPrev_update (\_. dest))) (Call mdb_node_ptr_set_mdbPrev_'proc)" unfolding updateMDB_def apply (hypsubst) apply (rule ccorres_gen_asm [where G = \, simplified]) apply (simp only: Let_def) apply simp apply (rule ccorres_guard_imp2) apply (rule ccorres_pre_getCTE [where P = "\cte s. ctes_of s src' = Some cte" and P' = "\_. (\\mdb_node_ptr = Ptr &((Ptr src' :: cte_C ptr)\[''cteMDBNode_C''])\ \ \\v = dest\)"]) apply (rule ccorres_from_spec_modifies_heap) apply (rule mdb_node_ptr_set_mdbPrev_spec) apply (rule mdb_node_ptr_set_mdbPrev_modifies) apply simp apply clarsimp apply (rule rf_sr_cte_at_valid) apply simp apply (erule ctes_of_cte_at) apply assumption apply (clarsimp simp: cte_wp_at_ctes_of) apply (frule (1) rf_sr_ctes_of_clift) apply (clarsimp simp: typ_heap_simps) apply (rule fst_setCTE [OF ctes_of_cte_at], assumption) apply (erule bexI [rotated]) apply (clarsimp simp add: rf_sr_def cstate_relation_def Let_def cpspace_relation_def cte_wp_at_ctes_of heap_to_user_data_def cvariable_array_map_const_add_map_option[where f="tcb_no_ctes_proj"] typ_heap_simps') apply (rule conjI) apply (erule (2) cspace_cte_relation_upd_mdbI) apply (simp add: cmdbnode_relation_def) subgoal for _ s' by (cases "v_' s' = 0"; simp) apply (erule_tac t = s'a in ssubst) apply (simp add: carch_state_relation_def cmachine_state_relation_def h_t_valid_clift_Some_iff typ_heap_simps') apply (erule (1) setCTE_tcb_case) apply clarsimp done lemma ccorres_updateMDB_skip: "ccorres dc xfdc (\ and (\_. n = 0)) UNIV hs (updateMDB n f) SKIP" unfolding updateMDB_def apply (rule ccorres_gen_asm) apply simp apply (rule ccorres_return) apply simp apply vcg done definition "is_simple_cap_tag (tag :: word32) \ tag \ scast cap_null_cap \ tag \ scast cap_irq_control_cap \ tag \ scast cap_untyped_cap \ tag \ scast cap_reply_cap \ tag \ scast cap_endpoint_cap \ tag \ scast cap_notification_cap \ tag \ scast cap_thread_cap \ tag \ scast cap_cnode_cap \ tag \ scast cap_zombie_cap \ tag \ scast cap_small_frame_cap \ tag \ scast cap_frame_cap" definition "cteInsert_newCapIsRevocable_if newCap srcCap \ (if (cap_get_tag newCap = scast cap_endpoint_cap) then (if (capEPBadge_CL (cap_endpoint_cap_lift newCap) = capEPBadge_CL (cap_endpoint_cap_lift srcCap)) then 0 else 1) else if (cap_get_tag newCap = scast cap_notification_cap) then (if (capNtfnBadge_CL (cap_notification_cap_lift newCap) = capNtfnBadge_CL (cap_notification_cap_lift srcCap)) then 0 else 1) else if (cap_get_tag newCap = scast cap_irq_handler_cap) then (if cap_get_tag srcCap = scast cap_irq_control_cap then 1 else 0) else if (cap_get_tag newCap = scast cap_untyped_cap) then 1 else 0)" lemma cteInsert_if_helper: assumes cgt: "rv = cap_get_tag newCap" and rul: "\s g. (s \ Q) = (s\ ret__unsigned_' := undefined, unsigned_eret_2_':= undefined \ \ Q')" shows "\ \\<^bsub>/UNIV\<^esub> {s. (cap_get_tag srcCap = cap_get_tag newCap \ is_simple_cap_tag (cap_get_tag newCap)) \ (s\newCapIsRevocable_' := cteInsert_newCapIsRevocable_if newCap srcCap\ \ Q)} (IF rv = scast cap_endpoint_cap THEN \ret__unsigned :== CALL cap_endpoint_cap_get_capEPBadge(newCap);; \unsigned_eret_2 :== CALL cap_endpoint_cap_get_capEPBadge(srcCap);; \newCapIsRevocable :== (if \ret__unsigned \ \unsigned_eret_2 then 1 else 0) ELSE IF rv = scast cap_notification_cap THEN \ret__unsigned :== CALL cap_notification_cap_get_capNtfnBadge(newCap);; \unsigned_eret_2 :== CALL cap_notification_cap_get_capNtfnBadge(srcCap);; \newCapIsRevocable :== (if \ret__unsigned \ \unsigned_eret_2 then 1 else 0) ELSE IF rv = scast cap_irq_handler_cap THEN \ret__unsigned :== CALL cap_get_capType(srcCap);; \newCapIsRevocable :== (if \ret__unsigned = scast cap_irq_control_cap then 1 else 0) ELSE IF rv = scast cap_untyped_cap THEN \newCapIsRevocable :== scast true ELSE \newCapIsRevocable :== scast false FI FI FI FI) Q" unfolding cteInsert_newCapIsRevocable_if_def apply (unfold cgt) apply (rule conseqPre) apply vcg apply (clarsimp simp: true_def false_def is_simple_cap_tag_def cong: if_cong) apply (simp add: cap_tag_defs) apply (intro allI conjI impI) apply (clarsimp simp: rul)+ done lemma forget_Q': "(x \ Q) = (y \ Q) \ (x \ Q) = (y \ Q)" . lemmas cteInsert_if_helper' = cteInsert_if_helper [OF _ forget_Q'] (* Useful: apply (tactic {* let val _ = reset CtacImpl.trace_ceqv; val _ = reset CtacImpl.trace_ctac in all_tac end; *}) *) declare word_neq_0_conv [simp del] schematic_goal ccap_relation_tag_Master: "\ccap. \ ccap_relation cap ccap \ \ cap_get_tag ccap = case_capability ?a ?b ?c ?d ?e ?f ?g (case_arch_capability ?aa ?ab (\dev ptr rghts sz data. if sz = ARMSmallPage then scast cap_small_frame_cap else scast cap_frame_cap) ?ad ?ae) ?h ?i ?j ?k (capMasterCap cap)" by (fastforce simp: ccap_relation_def map_option_Some_eq2 Let_def cap_lift_def cap_to_H_def split: if_split_asm) lemma ccap_relation_is_derived_tag_equal: "\ is_derived' cs p cap cap'; ccap_relation cap ccap; ccap_relation cap' ccap' \ \ cap_get_tag ccap' = cap_get_tag ccap" unfolding badge_derived'_def is_derived'_def by (clarsimp simp: ccap_relation_tag_Master) lemma ccap_relation_Master_tags_eq: "\ capMasterCap cap = capMasterCap cap'; ccap_relation cap ccap; ccap_relation cap' ccap' \ \ cap_get_tag ccap' = cap_get_tag ccap" by (clarsimp simp: ccap_relation_tag_Master) lemma is_simple_cap_get_tag_relation: "ccap_relation cap ccap \ is_simple_cap_tag (cap_get_tag ccap) = is_simple_cap' cap" apply (simp add: is_simple_cap_tag_def is_simple_cap'_def cap_get_tag_isCap) apply (auto simp: isCap_simps) done lemma setUntypedCapAsFull_cte_at_wp [wp]: "\ cte_at' x \ setUntypedCapAsFull rvb cap src \ \_. cte_at' x \" apply (clarsimp simp: setUntypedCapAsFull_def) apply wp done lemma setUntypedCapAsFull_cte_at_wp' [wp]: "\ cte_wp_at' (\_. True) x \ setUntypedCapAsFull rvb cap src \ \_. cte_wp_at' (\_. True) x \" apply (clarsimp simp: setUntypedCapAsFull_def) apply wp done lemma valid_cap_untyped_inv: "valid_cap' (UntypedCap d r n f) s \ n \ 4 \ is_aligned (of_nat f :: word32) 4 \ n \ 30 \ n < word_bits" apply (clarsimp simp:valid_cap'_def capAligned_def) done lemma and_and_mask_simple: "(y && mask n) = mask n \ ((x && y) && mask n) = x && mask n" by (simp add: word_bool_alg.conj.assoc) lemma and_and_mask_simple_not: "(y && mask n) = 0 \ ((x && y) && mask n) = 0" by (simp add: word_bool_alg.conj.assoc) lemma update_freeIndex: "ccorres dc xfdc (valid_objs' and cte_wp_at' (\cte. \i. cteCap cte = UntypedCap d p sz i) srcSlot and (\_. is_aligned (of_nat i' :: word32) 4 \ i' \ 2 ^ sz)) (UNIV \ {s. cap_ptr_' s = Ptr &(cte_Ptr srcSlot\[''cap_C''])} \ {s. v_' s = (of_nat (i') :: word32)>> 4}) [] (updateCap srcSlot (UntypedCap d p sz i')) (Call cap_untyped_cap_ptr_set_capFreeIndex_'proc)" apply (rule ccorres_gen_asm) apply (rule ccorres_guard_imp) prefer 3 apply assumption apply (rule_tac P = "sz \ 29" and G = "cte_wp_at' S srcSlot" for S in ccorres_gen_asm) prefer 2 apply clarsimp apply (rule conjI, assumption) apply (clarsimp simp:cte_wp_at_ctes_of) apply (case_tac cte,clarsimp) apply (drule(1) ctes_of_valid_cap') apply (simp add:valid_cap'_def) apply clarify proof - assume ialign:"is_aligned (of_nat i' :: word32) 4" assume szbound:"sz\ 29" assume ibound:"i'\ 2^sz" note ibound_concrete = order_trans[OF ibound power_increasing[OF szbound], simplified] have ibound_concrete_word: "(of_nat i' :: word32) \ 2 ^ 29" using ibound_concrete by (simp add: word_of_nat_le) have [simp]:"\x. (x::word32) && 0xFFFFFFC0 = x && ~~ mask 6" by (simp add:mask_def) have [simp]:"\x. ((x::word32) && ~~ mask 6) && mask 6 = 0" by (simp add:is_aligned_mask[THEN iffD1,OF is_aligned_neg_mask]) have [simp]:"(0x3FFFFFF::word32) = mask 26" by (simp add:mask_def) have [simp]:"\(n::word32) m. (n && mask 6 || m && ~~ mask 6 >> 6) && mask 26 = (m >> 6) && mask 26" apply (rule word_eqI) apply (simp add:nth_shiftr) apply (simp add:neg_mask_bang word_size) done have terrible_word_stuff: "\x1. to_bool ((cap_C.words_C x1.[Suc 0] >> 5) && 1) = to_bool ((cap_C.words_C x1.[Suc 0] && 0x3F || (of_nat i' >> 4 << 6) && ~~ mask 6 >> 5) && 1) \ cap_C.words_C x1.[Suc 0] && 0x1F = (cap_C.words_C x1.[Suc 0] && 0x3F || (of_nat i' >> 4 << 6) && ~~ mask 6) && 0x1F \ i' = unat ((cap_C.words_C x1.[Suc 0] && 0x3F || (of_nat i' >> 4 << 6) && ~~ mask 6 >> 6) && mask 26 << 4)" apply (rule conjI) apply (clarsimp simp: to_bool_and_1 nth_shiftr neg_mask_bang) apply (clarsimp simp: word_bool_alg.conj_disj_distrib2 mask_def[where n = 5,simplified,symmetric]) apply (rule conjI) apply (subst and_and_mask_simple) apply (simp add: mask_def[where n=5, simplified]) apply (subst and_and_mask_simple_not) apply (simp add: mask_def[where n=5, simplified] mask_def[where n=6, simplified]) apply simp apply (rule inj_onD[OF word_unat.Abs_inj_on[where 'a=32]], simp) apply (cut_tac ialign ibound_concrete_word) apply (simp add: is_aligned_mask) apply word_bitwise apply (simp add: word_size) apply (cut_tac ibound_concrete) apply (simp add: unats_def) apply (simp add: word_unat.Rep[where 'a=32, simplified]) done note option.case_cong_weak [cong] show "ccorresG rf_sr \ dc xfdc (cte_wp_at' (\cte. \i. cteCap cte = capability.UntypedCap d p sz i) srcSlot) (UNIV \ \\cap_ptr = cap_Ptr &(cte_Ptr srcSlot\[''cap_C''])\ \ \\v = (of_nat i' :: word32) >> 4\) [] (updateCap srcSlot (capability.UntypedCap d p sz i')) (Call cap_untyped_cap_ptr_set_capFreeIndex_'proc)" apply (cinit lift: cap_ptr_' v_') apply (rule ccorres_pre_getCTE) apply (rule_tac P = "\s. ctes_of s srcSlot = Some rv \ (\i. cteCap rv = UntypedCap d p sz i)" in ccorres_from_vcg[where P' = UNIV]) apply (rule allI) apply (rule conseqPre) apply vcg apply (clarsimp simp:guard_simps) apply (intro conjI) apply (frule (1) rf_sr_ctes_of_clift) apply (clarsimp simp:typ_heap_simps) apply (frule (1) rf_sr_ctes_of_clift) apply (clarsimp simp:split_def) apply (simp add:hrs_htd_def typ_heap_simps) apply (rule fst_setCTE [OF ctes_of_cte_at], assumption) apply (erule bexI [rotated]) apply (clarsimp simp: cte_wp_at_ctes_of) apply (frule (1) rf_sr_ctes_of_clift) apply (clarsimp simp add: rf_sr_def cstate_relation_def Let_def cvariable_array_map_const_add_map_option[where f="tcb_no_ctes_proj"]) apply (simp add:cpspace_relation_def) apply (clarsimp simp:typ_heap_simps') apply (rule conjI) apply (erule(2) cpspace_cte_relation_upd_capI) apply (simp add:cte_lift_def) apply (simp split:option.splits ) apply (simp add:cap_to_H_def Let_def split:cap_CL.splits if_split_asm) apply (case_tac y) apply (simp add:cap_lift_def Let_def split:if_split_asm) apply (case_tac cte',simp) apply (clarsimp simp:ccap_relation_def cap_lift_def cap_get_tag_def cap_to_H_def) subgoal by (rule terrible_word_stuff) apply (erule_tac t = s' in ssubst) apply clarsimp apply (rule conjI) apply (erule (1) setCTE_tcb_case) subgoal by (simp add: carch_state_relation_def cmachine_state_relation_def typ_heap_simps') apply (clarsimp simp:cte_wp_at_ctes_of) done qed (* FIXME: move *) lemma ccorres_cases: assumes P: " P \ ccorres r xf G G' hs a b" assumes notP: "\P \ ccorres r xf H H' hs a b" shows "ccorres r xf (\s. (P \ G s) \ (\P \ H s)) ({s. P \ s \ G'} \ {s. \P \ s \ H'}) hs a b" apply (cases P, auto simp: P notP) done (* FIXME: move *) lemma word_and_le': "\ b \ c \ \ (a :: word32) && b \ c" apply (metis word_and_le1 order_trans) done (* FIXME: move *) lemma word_and_less': "\ b < c \ \ (a :: word32) && b < c" apply (metis word_and_le1 xtr7) done lemma capBlockSize_CL_maxSize: " \ cap_get_tag c = scast cap_untyped_cap \ \ capBlockSize_CL (cap_untyped_cap_lift c) < 0x20" apply (clarsimp simp: cap_untyped_cap_lift_def) apply (clarsimp simp: cap_lift_def) apply (clarsimp simp: cap_untyped_cap_def cap_null_cap_def) apply (rule word_and_less') apply simp done lemma t2p_shiftr: "\b\ a;a < word_bits \ \ (2::word32) ^ a >> b = 2 ^ (a - b)" apply (subst shiftr_w2p) apply (simp add:word_bits_def) apply (subst shiftr_w2p[where x = "a - b"]) apply (simp add:word_bits_def) apply (simp only:word_bits_def[symmetric]) apply (simp add:shiftr_shiftr) done lemma setUntypedCapAsFull_ccorres [corres]: notes if_split [split del] notes Collect_const [simp del] notes Collect_True [simp] Collect_False [simp] shows "ccorres dc xfdc ((cte_wp_at' (\c. (cteCap c) = srcCap) srcSlot) and valid_mdb' and pspace_aligned' and valid_objs' and (K (isUntypedCap newCap \ (4 \ (capBlockSize newCap)))) and (K (isUntypedCap srcCap \ (4 \ capBlockSize srcCap)))) (UNIV \ {s. ccap_relation srcCap (srcCap_' s)} \ {s. ccap_relation newCap (newCap_' s)} \ {s. srcSlot_' s = Ptr srcSlot}) [] (setUntypedCapAsFull srcCap newCap srcSlot) (Call setUntypedCapAsFull_'proc)" apply (cinit lift: srcCap_' newCap_' srcSlot_') apply (rule ccorres_if_lhs) apply (clarsimp simp: isCap_simps) apply csymbr apply csymbr apply (simp add: if_then_0_else_1 if_then_1_else_0 cap_get_tag_isCap_unfolded_H_cap) apply (rule ccorres_rhs_assoc)+ apply csymbr apply csymbr apply (simp add: cap_get_tag_isCap_unfolded_H_cap ccorres_cond_univ_iff) apply (rule ccorres_rhs_assoc)+ apply csymbr apply csymbr apply csymbr apply (frule cap_get_tag_to_H(9)) apply (simp add: cap_get_tag_isCap_unfolded_H_cap) apply (rotate_tac 1) apply (frule cap_get_tag_to_H(9)) apply (simp add: cap_get_tag_isCap_unfolded_H_cap) apply simp apply (rule ccorres_rhs_assoc)+ apply csymbr apply csymbr apply csymbr apply (simp add: ccorres_cond_univ_iff) apply csymbr+ apply (rule ccorres_move_c_guard_cte) apply (rule ccorres_Guard) apply (rule ccorres_call) apply (rule update_freeIndex [unfolded dc_def]) apply simp apply simp apply simp apply clarsimp apply (csymbr) apply (csymbr) apply (simp add: cap_get_tag_isCap) apply (rule ccorres_Cond_rhs_Seq) apply (rule ccorres_rhs_assoc)+ apply csymbr apply csymbr apply (simp add: cap_get_tag_isCap) apply (rule ccorres_Cond_rhs) apply (rule ccorres_rhs_assoc)+ apply csymbr apply csymbr apply csymbr apply (rule ccorres_cases [where P="capPtr srcCap = capPtr newCap"]) apply (clarsimp simp: cap_get_tag_isCap[symmetric] cap_get_tag_UntypedCap split: if_split_asm) apply (rule ccorres_rhs_assoc)+ apply csymbr apply csymbr apply csymbr apply (clarsimp simp: cap_get_tag_to_H cap_get_tag_UntypedCap split: if_split_asm) apply (rule ccorres_cond_false) apply (rule ccorres_return_Skip [unfolded dc_def]) apply (clarsimp simp: cap_get_tag_isCap[symmetric] cap_get_tag_UntypedCap split: if_split_asm) apply (rule ccorres_cond_false) apply (rule ccorres_return_Skip [unfolded dc_def]) apply (rule ccorres_return_Skip [unfolded dc_def]) apply clarsimp apply (rule ccorres_cond_false) apply (rule ccorres_return_Skip [unfolded dc_def]) apply (clarsimp simp: cap_get_tag_isCap[symmetric] cap_get_tag_UntypedCap) apply (frule(1) cte_wp_at_valid_objs_valid_cap') apply clarsimp apply (intro conjI impI allI) apply (erule cte_wp_at_weakenE') apply (clarsimp simp: cap_get_tag_isCap[symmetric] cap_get_tag_UntypedCap split: if_split_asm) apply clarsimp apply (drule valid_cap_untyped_inv,clarsimp simp:max_free_index_def) apply (rule is_aligned_weaken) apply (rule is_aligned_shiftl_self[unfolded shiftl_t2n,where p = 1,simplified]) apply assumption apply (clarsimp simp: max_free_index_def shiftL_nat valid_cap'_def capAligned_def) apply (simp add:power_minus_is_div unat_power_lower unat_sub word_le_nat_alt t2p_shiftr) apply clarsimp apply (erule cte_wp_at_weakenE', simp) apply clarsimp apply (drule valid_cap_untyped_inv) apply (clarsimp simp:max_free_index_def t2p_shiftr unat_sub word_le_nat_alt) apply (clarsimp simp:field_simps) apply (rule word_less_imp_diff_less) apply (subst (asm) eq_commute, fastforce simp: unat_sub word_le_nat_alt) apply (rule capBlockSize_CL_maxSize) apply (clarsimp simp: cap_get_tag_UntypedCap) apply (clarsimp simp: cap_get_tag_isCap_unfolded_H_cap) apply (clarsimp split: if_split_asm) apply (clarsimp split: if_split_asm) apply (clarsimp split: if_split_asm) apply (clarsimp split: if_split_asm) apply (clarsimp split: if_split_asm) done lemma ccte_lift: "\(s, s') \ rf_sr; cslift s' (cte_Ptr p) = Some cte'; cte_lift cte' = Some y; c_valid_cte cte'\ \ ctes_of s p = Some (cte_to_H (the (cte_lift cte')))" apply (clarsimp simp:rf_sr_def cstate_relation_def Let_def cpspace_relation_def) apply (drule(1) cmap_relation_cs_atD) apply simp apply (clarsimp simp:ccte_relation_def) done lemma cmdb_node_relation_mdbNext: "cmdbnode_relation n n' \ mdbNext_CL (mdb_node_lift n') = mdbNext n" by (simp add:cmdbnode_relation_def) lemma cslift_ptr_safe: "cslift x ptr = Some a \ ptr_safe ptr (hrs_htd (t_hrs_' (globals x)))" apply (rule_tac h = "fst (t_hrs_' (globals x))" in lift_t_ptr_safe[where g = c_guard]) apply (fastforce simp add:typ_heap_simps hrs_htd_def) done thm ccorres_move_c_guard_cte lemma ccorres_move_ptr_safe: "ccorres_underlying rf_sr \ r xf arrel axf A C' hs a c \ ccorres_underlying rf_sr \ r xf arrel axf (A and K (dest = cte_Ptr (ptr_val dest)) and cte_wp_at' (\_. True) (ptr_val dest)) (C' \ \True\) hs a (Guard MemorySafety \ptr_safe (dest) (hrs_htd \t_hrs) \ c)" apply (rule ccorres_guard_imp2) apply (rule ccorres_Guard) apply simp apply (clarsimp simp:cte_wp_at_ctes_of) apply (drule(1) rf_sr_ctes_of_clift) apply (case_tac dest) apply (clarsimp simp:ptr_coerce_def) apply (erule cslift_ptr_safe) done lemma ccorres_move_ptr_safe_Seq: "ccorres_underlying rf_sr \ r xf arrel axf A C' hs a (c;;d) \ ccorres_underlying rf_sr \ r xf arrel axf (A and cte_wp_at' (\_. True) (ptr_val dest) and K (dest = cte_Ptr (ptr_val dest))) (C' \ \True\) hs a (Guard MemorySafety \ptr_safe (dest) (hrs_htd \t_hrs) \ c;;d)" apply (rule ccorres_guard_imp2) apply (rule ccorres_Guard_Seq) apply simp apply (clarsimp simp:cte_wp_at_ctes_of) apply (drule(1) rf_sr_ctes_of_clift) apply clarsimp apply (erule cslift_ptr_safe) done lemmas ccorres_move_guard_ptr_safe = ccorres_move_ptr_safe_Seq ccorres_move_ptr_safe lemma scast_1_32 [simp]: "scast (1 :: 32 signed word) = (1 :: 32 word)" by simp lemma cteInsert_ccorres: "ccorres dc xfdc (cte_wp_at' (\scte. capMasterCap (cteCap scte) = capMasterCap cap \