(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

theory Proof_SI
imports
  CreateObjects_SI
  CreateIRQCaps_SI
  DuplicateCaps_SI
  InitVSpace_SI
  InitTCB_SI
  InitCSpace_SI
  InitIRQ_SI
  StartThreads_SI
begin

lemma parse_bootinfo_sep:
  "\<lbrace>\<guillemotleft>((\<And>* (cptr, cap) \<in> set (zip [ustart .e. uend - 1] untyped_caps). (si_cnode_id, unat cptr) \<mapsto>c cap) \<and>*
      (\<And>* cptr \<in> set [fstart .e. fend - 1]. (si_cnode_id, unat cptr) \<mapsto>c NullCap)  \<and>*
      (\<And>* obj_id\<in>(\<Union>cap\<in>set untyped_caps. cap_free_ids cap). obj_id \<mapsto>o Untyped) \<and>* R)
     and K (bi_untypes bootinfo = (ustart, uend) \<and>
            bi_free_slots bootinfo = (fstart, fend) \<and>
            unat ustart < 2 ^ si_cnode_size \<and>
            unat (uend - 1) < 2 ^ si_cnode_size \<and>
            unat fstart < 2 ^ si_cnode_size \<and>
            unat (fend - 1) < 2 ^ si_cnode_size \<and>
            uend \<noteq> 0 \<and>
            fend \<noteq> 0 \<and>
            list_all is_full_untyped_cap untyped_caps \<and>
            length untyped_caps = unat uend - unat ustart) \<guillemotright>\<rbrace>
    parse_bootinfo bootinfo
   \<lbrace>\<lambda>rv.
    \<guillemotleft>((\<And>* (cptr, cap) \<in> set (zip (fst rv) untyped_caps). (si_cnode_id, unat cptr) \<mapsto>c cap) \<and>*
      (\<And>* cptr \<in> set (snd rv). (si_cnode_id, unat cptr) \<mapsto>c NullCap)  \<and>*
      (\<And>* obj_id\<in>(\<Union>cap\<in>set untyped_caps. cap_free_ids cap). obj_id \<mapsto>o Untyped) \<and>* R) and
     K (rv = ([fst (bi_untypes bootinfo) .e. snd (bi_untypes bootinfo) - 1],
              [fst (bi_free_slots bootinfo) .e. snd (bi_free_slots bootinfo) - 1]))\<guillemotright> \<rbrace>"
  apply (clarsimp simp: parse_bootinfo_def)
  apply (cases bootinfo, clarsimp)
  apply wp
  apply (clarsimp simp: zip_map1 comp_def split_beta')
  done

(* This isn't actually all the combinations, but enough of them for what I needed. *)
lemma object_types_distinct:
 "tcb_at x s     \<Longrightarrow> \<not> cnode_at x s"
 "table_at x s   \<Longrightarrow> \<not> cnode_at x s"
 "table_at x s   \<Longrightarrow> \<not> tcb_at x s"
 "capless_at x s \<Longrightarrow> \<not> cnode_at x s"
 "capless_at x s \<Longrightarrow> \<not> tcb_at x s"
 "capless_at x s \<Longrightarrow> \<not> table_at x s"
 "capless_at x s \<Longrightarrow> \<not> pt_at x s"
 "capless_at x s \<Longrightarrow> \<not> pd_at x s"
 "capless_at x s \<Longrightarrow> \<not> asidpool_at x s"
  by (clarsimp simp: object_at_def is_tcb_def is_cnode_def is_pd_def is_pt_def
                     is_ep_def is_ntfn_def is_asidpool_def is_frame_def
                     is_untyped_def | rule conjI |
      clarsimp split: cdl_object.splits)+

lemma real_objects_some_type:
  "well_formed spec \<Longrightarrow>
   {obj_id. real_object_at obj_id spec \<and>
       \<not> cnode_at obj_id spec \<and>
       \<not> tcb_at obj_id spec \<and>
       \<not> pt_at obj_id spec \<and>
       \<not> pd_at obj_id spec \<and>
       \<not> untyped_at obj_id spec \<and>
       \<not> ep_at obj_id spec \<and>
       \<not> ntfn_at obj_id spec \<and>
       \<not> frame_at obj_id spec} = {}"
  apply (clarsimp simp: object_at_def is_tcb_def is_cnode_def is_pd_def is_pt_def
                        is_ep_def is_ntfn_def is_asidpool_def is_frame_def is_untyped_def)
  apply (clarsimp split: cdl_object.splits)
  apply (drule_tac obj_id=x in well_formed_asidpool_at)
  apply (clarsimp simp: real_object_at_def object_at_def is_asidpool_def irq_nodes_def is_irq_node_def
                 split: cdl_object.splits)
  by metis

lemma capdl_objects_by_parts:
  "well_formed spec \<Longrightarrow>
   (sep_map_set_conj P {obj_id. real_object_at obj_id spec}) =
   (sep_map_set_conj P {obj_id. cnode_at obj_id spec} \<and>*
    sep_map_set_conj P {obj_id. tcb_at obj_id spec} \<and>*
    sep_map_set_conj P {obj_id. table_at obj_id spec} \<and>*
    sep_map_set_conj P {obj_id. capless_at obj_id spec})"
  apply (rule sym)
  apply (subst (5) sep_map_set_conj_restrict [where t = "(\<lambda>obj. cnode_at obj spec)"], simp)
  apply (subst (6) sep_map_set_conj_restrict [where t = "(\<lambda>obj. tcb_at obj spec)"], simp)
  apply (subst (7) sep_map_set_conj_restrict [where t = "(\<lambda>obj. table_at obj spec)"], simp)
  apply (subst (8) sep_map_set_conj_restrict [where t = "(\<lambda>obj. capless_at obj spec)"], simp)
  apply (clarsimp simp: object_types_distinct real_object_not_irq_node real_objects_some_type
                  cong: rev_conj_cong)
  done

lemma objects_empty_by_parts:
  "well_formed spec \<Longrightarrow>
   (objects_empty spec t {obj_id. real_object_at obj_id spec}) =
   (objects_empty spec t {obj_id. cnode_at obj_id spec} \<and>*
    objects_empty spec t {obj_id. tcb_at obj_id spec} \<and>*
    objects_empty spec t {obj_id. table_at obj_id spec} \<and>*
    objects_empty spec t {obj_id. capless_at obj_id spec})"
  by (clarsimp simp: objects_empty_def capdl_objects_by_parts)

lemma objects_initialised_by_parts:
  "well_formed spec \<Longrightarrow>
   (objects_initialised spec t {obj_id. real_object_at obj_id spec}) =
   (objects_initialised spec t {obj_id. cnode_at obj_id spec} \<and>*
    objects_initialised spec t {obj_id. tcb_at obj_id spec} \<and>*
    objects_initialised spec t {obj_id. table_at obj_id spec} \<and>*
    objects_initialised spec t {obj_id. capless_at obj_id spec})"
  by (clarsimp simp: objects_initialised_def capdl_objects_by_parts)

lemma object_empty_object_initialised_capless:
  "capless_at obj_id spec \<Longrightarrow>
   object_empty spec t obj_id = object_initialised spec t obj_id"
  apply (rule ext)
  apply (clarsimp simp: object_empty_def object_initialised_def)
  apply (clarsimp simp: object_initialised_general_def object_default_state_def2)
  apply (fastforce simp: object_at_def update_slots_def
                         object_default_state_def2 spec2s_def
                         is_ep_def is_ntfn_def is_asidpool_def
                         is_frame_def is_untyped_def cdl_frame.splits
                  split: cdl_object.splits)
  done

lemma objects_empty_objects_initialised_capless:
  "objects_empty spec t {obj_id. capless_at obj_id spec} =
   objects_initialised spec t {obj_id. capless_at obj_id spec}"
  apply (clarsimp simp: objects_empty_def objects_initialised_def)
  apply (rule sep.prod.cong, simp)
  apply (clarsimp simp: object_empty_object_initialised_capless)
  done

lemma valid_case_prod':
  "(\<And>x y. \<lbrace>P x y\<rbrace> f x y \<lbrace>Q\<rbrace>) \<Longrightarrow> \<lbrace>P (fst v) (snd v)\<rbrace> case v of (x, y) \<Rightarrow> f x y \<lbrace>Q\<rbrace>"
  by (clarsimp split: prod.splits)

lemma le_list_all:
  "\<lbrakk>unat start < 2 ^ si_cnode_size; unat (end - 1) < 2 ^ si_cnode_size\<rbrakk>
   \<Longrightarrow> list_all (\<lambda>n. (n::32 word) < 2 ^ si_cnode_size) [start .e. end - 1]"
  apply (clarsimp simp: list_all_iff)
  apply (subst word_arith_power_alt)
  apply simp
  by (metis (no_types) dual_order.strict_trans2 unat_less_2_si_cnode_size)

lemma list_all_drop:
  "list_all P xs \<Longrightarrow> list_all P (drop n xs)"
  by (fastforce simp: list_all_iff dest: in_set_dropD)

lemma dom_map_of_zip':
  "length xs \<le> length ys \<Longrightarrow> dom (map_of (zip xs ys)) = set xs"
  apply (subst zip_take_length [symmetric])
  apply (subst dom_map_of_zip, simp+)
  done

(* FIXME: MOVE (Lib) *)
lemma in_zip_map: "p \<in> set xs \<Longrightarrow> length xs \<le> length ys \<Longrightarrow> map_of (zip xs ys) p \<noteq> None"
  using dom_map_of_zip' by blast

lemma map_of_list_allE:
  "map_of (zip ys xs) p = Some v \<Longrightarrow> distinct ys \<Longrightarrow> list_all P xs \<Longrightarrow> P v"
  apply (induct ys arbitrary: xs; clarsimp)
  by (meson in_set_zipE list_all_spec map_of_SomeD)

lemma card_eq_lengthI:
  "set xs = ys \<Longrightarrow> distinct xs \<Longrightarrow> length xs = card ys"
  by (induct xs arbitrary: ys; fastforce)

lemma length_filter_card:
  "\<lbrakk>s_list = sorted_list_of_set s; finite s\<rbrakk>
   \<Longrightarrow> length (filter P s_list) = card {x \<in> s. P x}"
  by (fastforce intro: card_eq_lengthI)


lemma sys_init_explicit:
  "\<lbrakk>well_formed spec;
   set obj_ids = dom (cdl_objects spec); distinct obj_ids;
   real_ids = [obj_id \<leftarrow> obj_ids. real_object_at obj_id spec];
   length obj_ids + length [obj\<leftarrow>obj_ids. cnode_or_tcb_at obj spec] +
   card (\<Union>(set ` get_frame_caps spec ` {obj. pd_at obj spec})) \<le> unat fend - unat fstart;
   length untyped_caps = unat uend - unat ustart;
   distinct_sets (map cap_free_ids untyped_caps);
   list_all is_full_untyped_cap untyped_caps;
   list_all well_formed_untyped_cap untyped_caps;
   list_all (\<lambda>c. \<not> is_device_cap c) untyped_caps;
   bi_untypes bootinfo = (ustart, uend);
   bi_free_slots bootinfo = (fstart, fend);
   unat ustart < 2 ^ si_cnode_size;
   unat (uend - 1) < 2 ^ si_cnode_size;
   unat fstart < 2 ^ si_cnode_size;
   unat (fend - 1) < 2 ^ si_cnode_size;
   uend \<noteq> 0; fend \<noteq> 0;
   [ustart .e. uend - 1] = untyped_cptrs;
   [fstart .e. fend - 1] = free_cptrs;
   (map_of (zip [obj\<leftarrow>obj_ids . cnode_or_tcb_at obj spec] (drop (length obj_ids) [fstart .e. fend - 1]))) = dup_caps
   \<rbrakk> \<Longrightarrow>
   \<lbrace>\<guillemotleft>(\<And>* (cptr, cap) \<in> set (zip untyped_cptrs untyped_caps). (si_cnode_id, unat cptr) \<mapsto>c cap) \<and>*
     (\<And>* cptr \<in> set free_cptrs. (si_cnode_id, unat cptr) \<mapsto>c NullCap)  \<and>*
     (\<And>* obj_id\<in>(\<Union>cap\<in>set untyped_caps. cap_free_ids cap). obj_id \<mapsto>o Untyped) \<and>*
    si_objects \<and>*
    si_irq_nodes spec \<and>*
    (SETSEPCONJ pd_id | pd_at pd_id spec.
      frame_duplicates_empty (make_frame_cap_map obj_ids (drop (length obj_ids) free_cptrs) spec)
                             pd_id spec) \<and>*
    R\<guillemotright>\<rbrace>
   init_system spec bootinfo obj_ids
  \<lbrace>\<lambda>_ s. \<exists>t.
    \<guillemotleft>objects_initialised spec t {obj_id. real_object_at obj_id spec} \<and>*
     irqs_initialised spec t (used_irqs spec) \<and>*
    (\<And>* cptr\<in>set (take (card (dom (cdl_objects spec))) free_cptrs). (si_cnode_id, unat cptr) \<mapsto>c NullCap) \<and>*
     si_caps_at t dup_caps spec False {obj_id. cnode_or_tcb_at obj_id spec} \<and>*
     si_objects \<and>*
     si_objects_extra_caps (dom (cdl_objects spec))
                            (free_cptrs :: 32 word list)
                            (untyped_cptrs :: 32 word list) spec \<and>*
    (SETSEPCONJ pd_id | pd_at pd_id spec.
      frame_duplicates_copied (make_frame_cap_map obj_ids (drop (length obj_ids) free_cptrs) spec)
                              pd_id spec t) \<and>*
    R\<guillemotright> s \<and>
    inj_on t (dom (cdl_objects spec)) \<and> dom t = set obj_ids\<rbrace>"
  supply [[unify_search_bound = 1000]]
  apply clarsimp
  apply (frule (1) le_list_all [where start = ustart])
  apply (frule (1) le_list_all [where start = fstart])
  apply (frule well_formed_objects_card)
  apply (insert distinct_card [symmetric, where xs ="[obj\<leftarrow>obj_ids . cnode_or_tcb_at obj spec]"], simp)
  apply (frule distinct_card [symmetric])
  apply (clarsimp simp: init_system_def, wp valid_case_prod')
            apply (rule hoare_vcg_ex_lift, rename_tac t, rule_tac t=t in start_threads_sep [sep_wandise], simp)
           apply (rule hoare_vcg_ex_lift, rename_tac t, rule_tac t=t and
                                                  free_cptrs="[fstart .e. fend - 1]" in init_cspace_sep [sep_wandise])
          apply (rule hoare_vcg_ex_lift, rename_tac t, rule_tac t=t in init_tcbs_sep [sep_wandise])
         apply (rule hoare_vcg_ex_lift, rename_tac t, rule_tac t=t in init_vspace_sep [sep_wandise])
        apply (rule hoare_vcg_ex_lift, rename_tac t, rule_tac t=t in init_pd_asids_sep [sep_wandise])
       apply (rule hoare_vcg_ex_lift, rename_tac t, rule_tac t=t and dev=False in init_irqs_sep [sep_wandise])
      apply (rule hoare_vcg_ex_lift, rename_tac t, rule_tac t=t and dev=False and
                                             untyped_cptrs = "[ustart .e. uend - 1]" and
                                             free_cptrs_orig = "[fstart .e. fend - 1]" in duplicate_caps_sep [sep_wandise])
     apply (rule create_irq_caps_sep [where dev = False,sep_wandise,
            where free_cptrs_orig = "[fstart .e. fend - 1]"
              and untyped_cptrs = "[ustart .e. uend - 1]"
              and orig_caps = "map_of (zip [obj\<leftarrow>obj_ids. real_object_at obj spec]
                                           [fstart .e. fend - 1])"
              and spec = spec])
    apply (wp sep_wp: create_objects_sep [where untyped_caps = untyped_caps and dev = False])
   apply (wp sep_wp: parse_bootinfo_sep [where fstart = fstart
                                           and fend = fend
                                           and ustart = ustart
                                           and uend = uend
                                           and untyped_caps = untyped_caps])
  apply (subst objects_initialised_by_parts, assumption)
  apply (subst objects_empty_by_parts, assumption)+
  apply (subst objects_empty_objects_initialised_capless)+
  apply (clarsimp simp: linorder_not_le)
  apply (intro conjI allI impI pred_conjI | sep_cancel+)+
         apply fastforce
        apply (clarsimp simp: less_diff_conv)
        apply (rule list_all_drop, erule (1) le_list_all)
       apply clarsimp
       apply (subgoal_tac "map_of (zip (filter (\<lambda>obj. real_object_at obj spec) obj_ids) free_cptrs)
                                  p \<noteq> None")
        apply clarsimp
        apply (erule map_of_list_allE)
         apply (fastforce intro!: List.distinct_filter)
        apply (fastforce intro!: le_list_all)
       apply (rule in_zip_map)
        apply clarsimp
        apply (fastforce dest!: real_object_not_irq_node(3))
       apply (insert length_filter_le[where xs = obj_ids and P="\<lambda>obj. real_object_at obj spec"],
              fastforce)[1]
      apply (erule (1) le_list_all)
     apply (rule list_all_drop, erule (1) le_list_all)
    apply simp
   apply (subst dom_map_of_zip')
    apply (insert length_filter_le [where xs = obj_ids and P="\<lambda>obj. real_object_at obj spec"],
           fastforce)[1]
   apply simp
  apply (erule (1) le_list_all)
  done

(**************************************************
 * The top level lemma for system initialisation. *
 **************************************************)
(* FIXME, make the acquiring of the object_ids part of sys_init, not a parameter. *)

lemma sys_init:
  "\<lbrakk>well_formed spec; obj_ids = sorted_list_of_set (dom (cdl_objects spec))\<rbrakk> \<Longrightarrow>
   \<lbrace>\<guillemotleft>valid_boot_info bootinfo spec \<and>* R\<guillemotright>\<rbrace>
    init_system spec bootinfo obj_ids
   \<lbrace>\<lambda>_ s. \<exists>t.
    \<guillemotleft>objects_initialised spec t {obj_id. real_object_at obj_id spec} \<and>*
     irqs_initialised spec t (used_irqs spec) \<and>*
     si_final_objects spec t \<and>*
     (EXS map. (SETSEPCONJ pd_id | pd_at pd_id spec. frame_duplicates_copied map pd_id spec t)) \<and>*
     R\<guillemotright> s \<and>
     inj_on t (set obj_ids) \<and> dom t = set obj_ids\<rbrace>"
  apply (insert distinct_card [where xs = "[obj\<leftarrow>obj_ids . cnode_or_tcb_at obj spec]"], simp)
  apply (clarsimp simp: valid_boot_info_def si_final_objects_def
                        sep_conj_exists sep_conj_assoc)
  apply (subst ex_conj_increase)+
  apply (rule hoare_ex_pre)+
  apply (rule hoare_grab_asm)+
  apply (rule hoare_chain)
    apply (rule sys_init_explicit[where obj_ids="sorted_list_of_set (dom (cdl_objects spec))" and R=R],
          (assumption|simp add: unat_less_2_si_cnode_size' length_filter_card)+)
   apply sep_solve
  apply clarsimp
  apply (rule_tac x=t in exI)
  apply (clarsimp)
  apply (clarsimp simp: si_objects_extra_caps_def si_caps_at_def
                        sep_conj_exists sep_conj_assoc)
  apply (rule_tac x="(map_of (zip [obj \<leftarrow> obj_ids. cnode_or_tcb_at obj spec]
                                  (drop (length obj_ids) [fstart .e. fend - 1])))" in exI)
  apply (rule_tac x="[x .e. xa - 1]" in exI)
  apply (rule_tac x="[fstart .e. fend - 1]" in exI)
  apply (rule_tac x=untyped_capsa in exI)
  apply (rule_tac x=all_available_ids in exI)
  apply (rule_tac x="make_frame_cap_map obj_ids (drop (card (dom (cdl_objects spec)))
                                                      [fstart .e. fend - 1]) spec" in exI)
  apply (clarsimp simp: sep_conj_ac)
  done

definition injective :: "('a \<Rightarrow> 'b option) \<Rightarrow> bool"
where "injective f \<equiv> inj_on f (dom f)"

lemma sys_init_paper:
  "\<lbrakk>well_formed spec; obj_ids = sorted_list_of_set (dom (cdl_objects spec))\<rbrakk> \<Longrightarrow>
   \<lbrace>\<guillemotleft>valid_boot_info bootinfo spec \<and>* R\<guillemotright>\<rbrace>
   init_system spec bootinfo obj_ids
   \<lbrace>\<lambda>_ s. \<exists>\<phi>.
    \<guillemotleft>objects_initialised spec \<phi> {obj_id. real_object_at obj_id spec} \<and>*
     irqs_initialised spec \<phi> (used_irqs spec) \<and>*
     si_final_objects spec \<phi> \<and>*
     (EXS map. (SETSEPCONJ pd_id | pd_at pd_id spec. frame_duplicates_copied map pd_id spec \<phi>)) \<and>*
     R\<guillemotright> s \<and>
     injective \<phi> \<and> dom \<phi> = set obj_ids\<rbrace>"
  apply (rule hoare_strengthen_post)
   apply (fact sys_init)
  apply (fastforce simp: injective_def)
  done

end