(*
 * Copyright 2020, Data61, CSIRO (ABN 41 687 119 230)
 *
 * SPDX-License-Identifier: BSD-2-Clause
 *)

theory SimplExport

imports GraphLang CommonOpsLemmas GlobalsSwap ExtraSpecs

begin

lemma field_lvalue_offset_eq:
  "field_lookup (typ_info_t TYPE('a :: c_type)) f 0 = Some v
        \<Longrightarrow> field_lvalue (ptr :: 'a ptr) f = ptr_val ptr + of_nat (snd v)"
  apply (cases v, simp, drule field_lookup_offset_eq)
  apply (simp add: field_lvalue_def)
  done

ML \<open>
fun dest_binT (Type (@{type_name signed}, [t])) = Word_Lib.dest_binT t
  | dest_binT t = Word_Lib.dest_binT t

fun dest_array_type (Type (@{type_name array}, [T, n])) = let
    val (s, _) = dest_Type n
    val s = Long_Name.base_name s
  in if String.isPrefix "tyCopy" s
    then (T, fst (read_int (raw_explode (unprefix "tyCopy" s))))
    else (T, dest_binT n)
  end
  | dest_array_type typ = raise TYPE ("dest_array_type", [typ], [])

fun dest_array_init (Const (@{const_name fupdate}, _) $ n $ f $ arr) = let
    val xs = dest_array_init arr
    val n = HOLogic.dest_number n |> snd
  in nth_map n (curry betapply f) xs end
  | dest_array_init (Const (@{const_name FCP}, T) $ f) = let
    val (_, width) = dest_array_type (range_type T)
  in map (curry betapply f) (map (HOLogic.mk_number @{typ nat})
    (0 upto width - 1))
  end
  | dest_array_init t = raise TERM ("dest_array_init", [t])

val ops = Symtab.make [
    (@{const_name "plus"}, ("Plus", true)),
    (@{const_name "minus"}, ("Minus", true)),
    (@{const_name "times"}, ("Times", true)),
    (@{const_name "modulo_class.modulo"}, ("Modulus", true)),
    (@{const_name "divide_class.divide"}, ("DividedBy", true)),
    (@{const_name "bitAND"}, ("BWAnd", true)),
    (@{const_name "bitOR"}, ("BWOr", true)),
    (@{const_name "bitXOR"}, ("BWXOR", true)),
    (@{const_name "conj"}, ("And", true)),
    (@{const_name "disj"}, ("Or", true)),
    (@{const_name "implies"}, ("Implies", true)),
    (@{const_name "HOL.eq"}, ("Equals", false)),
    (@{const_name "less"}, ("Less", false)),
    (@{const_name "less_eq"}, ("LessEquals", false)),
    (@{const_name "ptr_less"}, ("Less", false)),
    (@{const_name "ptr_le"}, ("LessEquals", false)),
    (@{const_name "word_sless"}, ("SignedLess", false)),
    (@{const_name "word_sle"}, ("SignedLessEquals", false)),
    (@{const_name "Not"}, ("Not", true)),
    (@{const_name "bitNOT"}, ("BWNot", true)),
    (@{const_name "ucast"}, ("WordCast", false)),
    (@{const_name "scast"}, ("WordCastSigned", false)),
    (@{const_name "True"}, ("True", true)),
    (@{const_name "False"}, ("False", true)),
    (@{const_name "If"}, ("IfThenElse", false)),
    (@{const_name "Set.member"}, ("MemDom", false)),
    (@{const_name "shiftl"}, ("ShiftLeft", false)),
    (@{const_name "shiftr"}, ("ShiftRight", false)),
    (@{const_name "sshiftr"}, ("SignedShiftRight", false)),
    (@{const_name "bv_clz"}, ("CountLeadingZeroes", true)),
    (@{const_name "bv_ctz"}, ("CountTrailingZeroes", true)),
    (@{const_name "all_htd_updates"}, ("HTDUpdate", false))
  ] |> Symtab.lookup

fun locals ctxt = Syntax.read_typ ctxt "'a myvars"
  |> Record.get_recT_fields (Proof_Context.theory_of ctxt)
  |> fst
  |> filter_out (fn (s, _) => s = @{const_name "globals"})
  |> Symtab.make |> Symtab.defined

fun local_upds ctxt = Syntax.read_typ ctxt "'a myvars"
  |> Record.get_recT_fields (Proof_Context.theory_of ctxt)
  |> fst
  |> filter_out (fn (s, _) => s = @{const_name "globals"})
  |> map (apfst (suffix Record.updateN))
  |> Symtab.make |> Symtab.defined

fun get_field ctxt s = let
    val xs = space_explode "." s
    val fld = List.last xs
    val tp = rev xs |> tl |> rev |> space_implode "."
    val is_upd = String.isSuffix "_update" fld
    val fld = if is_upd then unsuffix "_update" fld else fld
    val _ = Proof_Context.get_thm ctxt
        (tp ^ "_" ^ fld ^ "_fl_Some")
  in SOME (tp, fld, is_upd) end
    handle ERROR _ => NONE
       | Bind => NONE

val read_const = Proof_Context.read_const {proper = true, strict = true}

fun process_struct ctxt csenv (nm, flds) = let
    val offs = map (ProgramAnalysis.offset csenv (map snd flds))
        (0 upto (length flds - 1))
    val cons = read_const ctxt (nm ^ "." ^ nm)
    val typ = dest_Const cons |> snd |> strip_type |> snd
    val sz = ProgramAnalysis.sizeof csenv (Absyn.StructTy nm)
    val algn = ProgramAnalysis.alignof csenv (Absyn.StructTy nm)
    val accs = map (fst #> prefix (nm ^ ".")
        #> read_const ctxt) flds
  in (nm, (cons, typ, sz, algn, map fst flds ~~ (accs ~~ offs))) end

fun structs ctxt csenv = ProgramAnalysis.get_senv csenv
  |> map (process_struct ctxt csenv)
  |> Symtab.make

fun structs_by_typ ctxt csenv = Symtab.dest (structs ctxt csenv)
  |> map (fn (nm, (cons, typ, sz, algn, flds)) => (fst (dest_Type typ), (nm, cons, sz, algn, flds)))
  |> Symtab.make |> Symtab.lookup

fun cons_fields ctxt csenv = structs ctxt csenv |> Symtab.dest
  |> map (fn (_, (cons, typ, _, _, flds))
    => (fst (dest_Const cons), (fst (dest_Type typ),
           map (snd #> fst #> dest_Const #> fst) flds)))
  |> Symtab.make |> Symtab.lookup

fun enums ctxt csenv = let
    val Absyn.CE ecenv = ProgramAnalysis.cse2ecenv csenv
  in
    #enumenv ecenv |> Symtab.dest
    |> map (fn (s, (n, _)) =>
        (read_const ctxt s
            |> dest_Const |> fst, n))
    |> Symtab.make |> Symtab.lookup
  end

fun thm_to_rew thm
    = ((Thm.concl_of thm |> HOLogic.dest_Trueprop |> HOLogic.dest_eq)
        handle TERM _ => (Thm.concl_of thm |> Logic.dest_equals))
    handle TERM _ => (Thm.concl_of thm |> HOLogic.dest_Trueprop |> HOLogic.dest_imp)

fun cons_field_upds ctxt csenv = let
  val simps = ProgramAnalysis.get_senv csenv
    |> maps (fn (tp, vs) => map (pair tp o fst) vs)
    |> maps (fn (tp, fld) => [Proof_Context.get_thm ctxt
          (tp ^ "." ^ fld ^ ".simps"),
        Proof_Context.get_thm ctxt
          (tp ^ "." ^ fld ^ Record.updateN ^ ".simps")])
  val accups = ProgramAnalysis.get_senv csenv
    |> map (fn (tp, _) => (tp, Proof_Context.get_thms ctxt
          (tp ^ "_accupd_same")))
    |> maps (fn (_, [t]) => [t]
              | (tp, ts) => ts @ Proof_Context.get_thms ctxt
          (tp ^ "_accupd_diff"))
  val rews = map thm_to_rew (simps @ accups)
  in Pattern.rewrite_term (Proof_Context.theory_of ctxt) rews [] end

type export_params = {cons_field_upds: term -> term,
         cons_fields: string -> (string * string list) option,
         const_globals: Termtab.key -> string option,
         enums: string -> int option,
         local_upds: string -> bool,
         locals: string -> bool,
         rw_global_accs: string -> string option,
         rw_global_upds: string -> string option,
         rw_globals_tab: (term * term) Symtab.table,
         structs_by_typ:
         string -> (string * term * int * int * (string * (term * int)) list) option}

fun get_all_export_params ctxt csenv : export_params = let
    (* assuming DefineGlobalsList has already run *)
    val defs = if (can (Proof_Context.get_thms ctxt) "no_global_data_defs")
      then [] else Proof_Context.get_thms ctxt "global_data_defs"
    val rhss = map (Thm.concl_of #> Logic.dest_equals #> snd) defs
    val const_globals = map_filter
      (fn (Const (@{const_name const_global_data}, _) $ nm $ v)
            => SOME (HOLogic.dest_string nm, v)
        | _ => NONE) rhss |> map swap |> Termtab.make |> Termtab.lookup
    val rw_globals = map_filter (fn (Const (@{const_name global_data}, _) $ nm $ get $ set)
        => SOME (HOLogic.dest_string nm, get, set) | _ => NONE) rhss
    val rw_globals_tab = Symtab.make (map (fn x => (#1 x, (#2 x, #3 x))) rw_globals)
    val rw_global_accs = map (fn (nm, c, _) => (fst (dest_Const c), nm)) rw_globals
        |> Symtab.make |> Symtab.lookup
    val rw_global_upds = map (fn (nm, _, c) => (fst (dest_Const c), nm)) rw_globals
        |> Symtab.make |> Symtab.lookup
  in {const_globals = const_globals, rw_globals_tab = rw_globals_tab,
    rw_global_accs = rw_global_accs,
    rw_global_upds = rw_global_upds,
    cons_field_upds = cons_field_upds ctxt csenv,
    enums = enums ctxt csenv,
    cons_fields = cons_fields ctxt csenv,
    structs_by_typ = structs_by_typ ctxt csenv,
    locals = locals ctxt,
    local_upds = local_upds ctxt} end
\<close>

ML \<open>

val machine_word = case @{typ machine_word} of
    @{typ word32} => "Word 32"
  | @{typ word64} => "Word 64"

fun convert_type _ _ @{typ bool} = "Bool"
  | convert_type _ _ (Type (@{type_name word}, [n]))
    = "Word " ^ signed_string_of_int (dest_binT n)
  | convert_type abs ctxt (Type (@{type_name array}, [t, n]))
    = "Array " ^ convert_type abs ctxt t ^ " " ^ (string_of_int (dest_binT n)
        handle TYPE _ => (case n of Type (s, []) => (unprefix "tyCopy" (Long_Name.base_name s)
            handle Fail _ => raise TYPE ("convert_type", [t, n], []))
         | _ => raise TYPE ("convert_type", [t, n], [])))
  | convert_type true ctxt (Type (@{type_name ptr}, [T])) = "Ptr " ^ convert_type true ctxt T
  | convert_type false _ (Type (@{type_name ptr}, _)) = machine_word
  | convert_type _ _ @{typ "machine_word \<Rightarrow> word8"} = "Mem"
  | convert_type _ _ @{typ "machine_word \<Rightarrow> bool"} = "Dom"
  | convert_type _ _ @{typ "machine_word set"} = "Dom"
  | convert_type _ _ @{typ heap_typ_desc} = "HTD"

  | convert_type _ _ @{typ nat} = raise TYPE ("convert_type: nat", [], [])
  | convert_type _ _ @{typ unit} = "UNIT"
  | convert_type _ _ (Type ("fun", [Type (@{type_name word}, [i]), Type (@{type_name word}, [j])]))
    = "WordArray " ^ signed_string_of_int (dest_binT i) ^ " " ^ signed_string_of_int (dest_binT j)
  | convert_type _ _ (Type (@{type_name itself}, _)) = "Type"
  | convert_type _ _ @{typ int} = raise TYPE ("convert_type: int", [], [])
  | convert_type _ ctxt (Type (s, [])) = if Long_Name.base_name s = "machine_state" then "PMS"
    else (Proof_Context.get_thm ctxt
        (Long_Name.base_name s ^ "_td_names"); "Struct " ^ s)
  | convert_type _ _ T = raise TYPE ("convert_type", [T], [])
\<close>

consts
  pseudo_acc :: "'a \<Rightarrow> 'a"

text \<open>

Phase 1 of the conversion, converts accs and upds on SIMPL
state (a record) to accs of named vars, using the pseudo_acc
constant above to guard the accesses and lists of upds with strings.
\<close>

ML \<open>

fun naming localname = Long_Name.base_name localname
    |> unsuffix "_'" |> suffix "#v"

fun mk_pseudo_acc s T = Const (@{const_name pseudo_acc}, T --> T)
    $ Free (s, T)

fun dest_global_mem_acc_addr (params : export_params) t = let
    val acc = case head_of t of Const (c, _) => #rw_global_accs params c
        | _ => NONE
    val const = #const_globals params t
    val T = fastype_of t
  in case (const, acc) of
      (SOME _, _) => NONE
    | (NONE, SOME nm) => SOME (TermsTypes.mk_global_addr_ptr (nm, T))
    | (NONE, NONE) => NONE
  end

fun dest_ptr_type (Type (@{type_name ptr}, [a])) = a
  | dest_ptr_type T = raise TYPE ("dest_ptr_type", [T], [])

fun mk_memacc p = let
    val T = fastype_of p
  in Const (@{const_name h_val}, @{typ heap_mem} --> T --> dest_ptr_type T)
    $ mk_pseudo_acc "Mem" @{typ heap_mem} $ p end

fun mk_fun_app f x = let
    val fT = fastype_of f
  in Const (@{const_name "fun_app"}, fT --> fastype_of x --> range_type fT) $ f $ x end

val ghost_assns = mk_pseudo_acc "GhostAssertions" @{typ "ghost_assertions"}

val int_to_ghost_key = @{term "word_of_int :: int \<Rightarrow> 50 word"}

fun convert_fetch_phase1 _ (@{term hrs_mem} $ _) = mk_pseudo_acc "Mem" @{typ heap_mem}
  | convert_fetch_phase1 _ (@{term hrs_htd} $ _) = mk_pseudo_acc "HTD" @{typ heap_typ_desc}
  | convert_fetch_phase1 _ (Const (@{const_name ghost_assertion_data_get}, _) $ k $ _ $ _)
    = mk_fun_app ghost_assns (int_to_ghost_key $ k)
  | convert_fetch_phase1 params (Abs (s, T, t))
    = Abs (s, T, convert_fetch_phase1 params t)
  | convert_fetch_phase1 params t = if not (is_Const (head_of t)) then t
  else let
    val (f, xs) = strip_comb t
    val (c, _) = dest_Const f
    val T = fastype_of t
  in case (#locals params c, dest_global_mem_acc_addr params t, #enums params c) of
    (true, _, _) => (case xs of [Free ("s", _)] => mk_pseudo_acc (naming c) T
        | [Free ("rv", _)] => mk_pseudo_acc ("rv#space#" ^ naming c) T
        | _ => raise TERM ("convert_fetch_phase1: acc?", [t])
    )
  | (_, SOME p, _) => mk_memacc p
  | (_, _, SOME n) => HOLogic.mk_number T n
  | _ => list_comb (f, map (convert_fetch_phase1 params) xs)
  end

fun mk_memupd1 ptr v m = if dest_ptr_type (fastype_of ptr) = fastype_of v
    then Const (@{const_name heap_update}, fastype_of ptr --> fastype_of v
            --> @{typ "heap_mem \<Rightarrow> heap_mem"})
        $ ptr $ v $ m
    else raise TERM ("mk_memupd1: types disagree", [ptr, v])

fun mk_memupd2 ptr v = mk_memupd1 ptr v (mk_pseudo_acc "Mem" @{typ heap_mem})

fun mk_fun_upd f x v = Const (@{const_name fun_upd},
    fastype_of f --> fastype_of x --> fastype_of v --> fastype_of f) $ f $ x $ v

fun convert_upd_phase1 ctxt params (t as (Const (@{const_name globals_update}, _)
    $ (Const (c, _) $ f) $ s)) = (case (Envir.beta_eta_contract f,
            String.isPrefix NameGeneration.ghost_state_name
            (Long_Name.base_name c), #rw_global_upds params c) of
        (Const (@{const_name hrs_mem_update}, _)
            $ (Const (@{const_name heap_update}, _) $ p $ v), _, _)
        => [("Mem", convert_fetch_phase1 params (mk_memupd2 p v))]
        | (Const (@{const_name hrs_htd_update}, _) $ g, _, _)
        => [("HTD", (convert_fetch_phase1 params
            (betapply (g, mk_pseudo_acc "HTD" @{typ heap_typ_desc}))))]
        | (Const (@{const_name ghost_assertion_data_set}, _) $ k $ v $ _, _, _)
        => [("GhostAssertions", mk_fun_upd ghost_assns (int_to_ghost_key $ k)
            (convert_fetch_phase1 params v))]
        | (_, true, _) => ((Syntax.pretty_term ctxt f |> Pretty.writeln); [])
        | (_, _, SOME nm) => let
    val acc = the (Symtab.lookup (#rw_globals_tab params) nm) |> fst
    val v = convert_fetch_phase1 params (betapply (f, acc $ s))
    val ptr = TermsTypes.mk_global_addr_ptr (nm, fastype_of v)
  in [("Mem", mk_memupd2 ptr v)] end
    | _ => raise TERM ("convert_upd", [t]))
  | convert_upd_phase1 _ params (t as (Const (c, _) $ f $ s)) = let
    val c' = unsuffix Record.updateN c
    val cT' = fastype_of s --> fastype_of (f $ s)
    val _ = (#local_upds params c) orelse raise TERM ("convert_upd_phase1: nonlocal", [t])
    val v = betapply (f, Const (c', cT') $ s)
  in [(naming c', convert_fetch_phase1 params v)] end
  | convert_upd_phase1 _ _ t = raise TERM ("convert_upd_phase1", [t])
\<close>

text \<open>Phase 2 eliminates compound types, so we access and
update only words from memory and local values.\<close>

ML \<open>
fun ptr_simp ctxt = ctxt addsimps @{thms CTypesDefs.ptr_add_def size_of_def size_td_array
        field_lvalue_offset_eq align_td_array' word_of_int scast_def[symmetric]
        ucast_def[symmetric]
        sint_sbintrunc' word_smod_numerals word_sdiv_numerals sdiv_int_def smod_int_def}
  |> Simplifier.rewrite

val trace_ptr_simp = false

fun ptr_simp_term ctxt s pat t = let
    val rew_thm = pat |> Thm.cterm_of ctxt |> ptr_simp ctxt
    val rew = rew_thm |> Thm.concl_of |> Logic.varify_global |> Logic.dest_equals
    val _ = (not (fst rew aconv snd rew))
        orelse raise TERM ("ptr_simp_term: " ^ s, [fst rew])
    val _ = if not trace_ptr_simp then () else
        (Thm.pretty_thm ctxt rew_thm |> Pretty.writeln;
         Syntax.pretty_term ctxt t |> Pretty.writeln)
  in Pattern.rewrite_term (Proof_Context.theory_of ctxt) [rew] [] t end

fun convert_ghost_key ctxt k = let
    val procs = Term.add_const_names k []
      |> filter (String.isSuffix HoarePackage.proc_deco)
    val proc_defs = map (suffix "_def" #> Proof_Context.get_thm ctxt) procs
    val conv = Simplifier.rewrite (ctxt addsimps proc_defs)
      (Thm.cterm_of ctxt k)

    val n = Thm.rhs_of conv |> Thm.term_of
    val _ = HOLogic.dest_number n

  in n end

fun dest_arrayT (Type (@{type_name array}, [elT, nT])) = let
  in (elT, dest_binT nT) end
  | dest_arrayT T = raise TYPE ("dest_arrayT", [T], [])

fun dest_nat (@{term Suc} $ n) = dest_nat n + 1
  | dest_nat (@{term "0 :: nat"}) = 0
  | dest_nat n = HOLogic.dest_number n |> snd

fun get_c_type_size ctxt T = let
    val TT = Logic.mk_type T
    val size_of = Const (@{const_name size_of}, type_of TT --> @{typ nat}) $ TT
  in (ptr_simp_term ctxt "c_type_size" size_of size_of |> dest_nat) end

val ptr_to_typ = Logic.mk_type o dest_ptr_type o fastype_of

fun mk_arr_idx arr i = let
    val arrT = fastype_of arr
    val elT = case arrT of Type (@{type_name "array"}, [elT, _])
        => elT | _ => raise TYPE ("mk_arr_idx", [arrT], [arr])
  in Const (@{const_name "Arrays.index"}, arrT --> @{typ nat} --> elT)
    $ arr $ i
  end

fun get_ptr_val (Const (@{const_name "Ptr"}, _) $ x) = x
  | get_ptr_val p = Const (@{const_name ptr_val},
        fastype_of p --> @{typ machine_word}) $ p

fun mk_ptr_offs opt_T p offs = let
    val pT = fastype_of p
    val T = case opt_T of NONE => pT
      | SOME T => Type (@{type_name ptr}, [T])
  in Const (@{const_name Ptr}, @{typ machine_word} --> T)
       $ (@{term "(+) :: machine_word \<Rightarrow> _"}
            $ get_ptr_val p $ offs)
  end

fun get_acc_type [] T = T
  | get_acc_type accs _ = (List.last accs $ @{term x})
      |> fastype_of

val normalise_ring_ops = let
    fun gather_plus (Const (@{const_name "plus"}, _) $ a $ b)
        = gather_plus a @ gather_plus b
      | gather_plus x = [x]
    fun gather_times (Const (@{const_name "times"}, _) $ a $ b)
        = gather_times a @ gather_times b
      | gather_times x = [x]
    fun fold_op _ [x] = x
      | fold_op oper (x :: xs) = oper $ x $ (fold_op oper xs)
      | fold_op _ [] = error "fold_op: shouldn't get empty list"
    fun inner (x as (Const (@{const_name "plus"}, _) $ _ $ _))
      = gather_plus x |> map inner
          |> sort Term_Ord.fast_term_ord
          |> fold_op (head_of x)
      | inner (x as (Const (@{const_name "times"}, _) $ _ $ _))
      = gather_times x |> map inner
          |> sort Term_Ord.fast_term_ord
          |> fold_op (head_of x)
      | inner (f $ x) = inner f $ inner x
      | inner x = x
  in inner end

fun dest_mem_acc_addr (Const (@{const_name h_val}, _) $ _ $ p)
        = SOME p
  | dest_mem_acc_addr _ = NONE

fun narrow_mem_upd ctxt (params : export_params) p v = let
    val T = fastype_of v
    fun mk_offs T = mk_ptr_offs (SOME T) p
    fun mk_offs2 T = mk_offs T o HOLogic.mk_number @{typ machine_word}
    val sterm = Syntax.pretty_term ctxt #> Pretty.string_of
    val styp = Syntax.pretty_typ ctxt #> Pretty.string_of
  in if (dest_mem_acc_addr v = SOME p) then []
    else if #structs_by_typ params (fst (dest_Type T)) <> NONE
    then let
      val (_, _, _, _, flds) = the (#structs_by_typ params (fst (dest_Type T)))
      val fld_writes = map (fn (_, (acc, offs))
          => (mk_offs2 (fastype_of (acc $ v)) offs,
              #cons_field_upds params (acc $ v))) flds
    in maps (uncurry (narrow_mem_upd ctxt params)) fld_writes end
    else if fst (dest_Type T) = @{type_name array}
    then let
        val (elT, n) = dest_arrayT T
        val elT_size = get_c_type_size ctxt elT
      in case v of (Const (@{const_name Arrays.update}, _) $ arr $ i $ x)
          => narrow_mem_upd ctxt params (mk_offs elT (@{term "(*) :: machine_word => _"}
                  $ HOLogic.mk_number @{typ machine_word} elT_size
                      $ (@{term "of_nat :: nat \<Rightarrow> machine_word"} $ i)))
              x @ narrow_mem_upd ctxt params p arr
      | _ => let
          val addrs = map (fn i => (mk_offs2 elT (i * elT_size)))
              (0 upto (n - 1))
          val elems = dest_array_init v
              handle TERM _ => map
                    (fn i => mk_arr_idx v (HOLogic.mk_number @{typ nat} i))
                    (0 upto (n - 1))
          val _ = (if n < 16 then () else
            warning ("expanding " ^ string_of_int n ^ ": "
                ^ sterm p ^ styp (fastype_of p) ^ ": " ^ sterm v))
      in maps (uncurry (narrow_mem_upd ctxt params)) (addrs ~~ elems) end
    end
    else if fst (dest_Type T) <> @{type_name word}
        andalso fst (dest_Type T) <> @{type_name ptr}
    then raise TERM ("narrow_mem_upd failed to narrow:", [p, v])
    else [(p, v)]
  end

fun triv_mem_upd ctxt p v = case dest_mem_acc_addr v of
      NONE => false
    | SOME p' => p aconv p' orelse let
      val t = @{term "(-) :: machine_word \<Rightarrow> _"} $ get_ptr_val p $ get_ptr_val p'
      val thm = ptr_simp ctxt (Thm.cterm_of ctxt t)
      val t' = Thm.rhs_of thm |> Thm.term_of
    in t' = @{term "0 :: machine_word"}
        orelse (Thm.pretty_thm ctxt thm |> Pretty.writeln; false)
    end

fun narrow_mem_acc _ _ [] p = p
  | narrow_mem_acc ctxt params accs p = let
    fun get_offs (Const (@{const_name Arrays.index}, idxT) $ i) = let
        val (elT, _) = dest_arrayT (domain_type idxT)
        val elT_size = get_c_type_size ctxt elT
      in @{term "(*) :: machine_word \<Rightarrow> _"} $ HOLogic.mk_number @{typ machine_word} elT_size
              $ (@{term "of_nat :: nat \<Rightarrow> machine_word"} $ i) end
      | get_offs (Const (s, T)) = let
        val struct_typ = domain_type T |> dest_Type |> fst
        val (_, _, _, _, flds) = the (#structs_by_typ params struct_typ)
        val matches = filter (fn (_, (c, _)) => c = Const (s, T)) flds
        val _ = (length matches = 1)
            orelse raise TERM ("narrow_mem_acc: get_offs: ", [Const (s, T)])
        val offs = snd (snd (hd matches))
      in HOLogic.mk_number @{typ machine_word} offs end
      | get_offs t = raise TERM ("narrow_mem_acc: get_offs: ", [t])
    val T' = get_acc_type accs (@{typ nat} (* doesn't matter *))
    val offs = foldr1 (fn (x, y) => @{term "(+) :: machine_word \<Rightarrow> _"} $ x $ y)
        (map get_offs accs)
    in mk_ptr_offs (SOME T') p offs end

fun try_norm_index ctxt i = let
    val i' = ptr_simp_term ctxt "idx_simp" i i
  in dest_nat i'; i' end handle TERM _ => i

fun mk_acc_array i xs = let
    val n = length xs
    val _ = warning ("expanding acc array, width " ^ string_of_int n)
    val i = @{term "of_nat :: nat \<Rightarrow> machine_word"} $ i
    fun inner [(x, _)] = x
      | inner ((x, j) :: xs) = let
        val y = inner xs
        val T = fastype_of x
      in Const (@{const_name "If"}, HOLogic.boolT --> T --> T --> T)
        $ HOLogic.mk_eq (i, HOLogic.mk_number @{typ machine_word} j) $ x $ y end
      | inner [] = error "mk_acc_array: empty"
  in inner (xs ~~ (0 upto (n - 1))) end

fun phase2_convert_global ctxt params accs
    ((idx as Const (@{const_name Arrays.index}, _)) $ i $ t)
    = phase2_convert_global ctxt params ((idx $ try_norm_index ctxt i) :: accs) t
  | phase2_convert_global ctxt params accs (Const acc $ t)
    = phase2_convert_global ctxt params (Const acc :: accs) t
  | phase2_convert_global ctxt params accs t = case #const_globals params t
  of SOME nm => let
    val known_offs = forall (fn Const (@{const_name Arrays.index}, _) $ i
          => (try dest_nat i) <> NONE
        | _ => true) accs
    val (c, _) = dest_Const t
    val c_def = Proof_Context.get_thm ctxt (c ^ "_def")
    val def_body = safe_mk_meta_eq c_def |> Thm.rhs_of |> Thm.term_of
        |> Envir.beta_eta_contract
    val p = TermsTypes.mk_global_addr_ptr (nm, fastype_of t)
    val t' = if known_offs then def_body else mk_memacc p
    val t_thm = if known_offs then SOME c_def else NONE
  in SOME (t', t_thm) end
    | _ => NONE

fun convert_fetch_ph2 ctxt params ((Const (@{const_name Arrays.index}, _) $ i) :: accs)
            (t as (Const (@{const_name fupdate}, _) $ _ $ _ $ _)) = let
        val xs = dest_array_init (#cons_field_upds (params : export_params) t)
      in case (try dest_nat i) of
        SOME i => convert_fetch_ph2 ctxt params accs (nth xs i)
      | NONE => mk_acc_array (convert_fetch_ph2 ctxt params [] i)
            (map (convert_fetch_ph2 ctxt params accs) xs)
      end
  | convert_fetch_ph2 ctxt params ((Const (@{const_name Arrays.index}, _) $ i) :: accs)
            (t as (Const (@{const_name FCP}, _) $ _)) = let
        val xs = dest_array_init (#cons_field_upds params t)
      in case (try dest_nat i) of
        SOME i => convert_fetch_ph2 ctxt params accs (nth xs i)
      | NONE => mk_acc_array (convert_fetch_ph2 ctxt params [] i)
            (map (convert_fetch_ph2 ctxt params accs) xs)
      end
  | convert_fetch_ph2 ctxt params accs ((idx as Const (@{const_name Arrays.index}, _)) $ arr $ i) = let
        val i' = convert_fetch_ph2 ctxt params accs i
        val i'' = try_norm_index ctxt i'
      in convert_fetch_ph2 ctxt params (idx $ i'' :: accs) arr end
  | convert_fetch_ph2 ctxt params ((idx as Const (@{const_name Arrays.index}, _)) $ i :: accs)
        (Const (@{const_name Arrays.update}, _) $ arr' $ i' $ v)
     = let
         val eq = HOLogic.mk_eq (i, i')
         val eq = ptr_simp_term ctxt "idx_eq_simp" eq eq handle TERM _ => eq
         val x = convert_fetch_ph2 ctxt params accs v
         val y = convert_fetch_ph2 ctxt params (idx $ i :: accs) arr'
         val T = fastype_of x
      in case eq of @{term True} => x | @{term False} => y
        | _ => Const (@{const_name If}, HOLogic.boolT --> T --> T --> T)
            $ convert_fetch_ph2 ctxt params [] eq $ x $ y end
  | convert_fetch_ph2 ctxt params accs (Const (@{const_name h_val}, _) $ _ $ p)
    = let
      val p = convert_fetch_ph2 ctxt params [] p
      val p = narrow_mem_acc ctxt params accs p
    in mk_memacc p end
  | convert_fetch_ph2 ctxt params [] (Const (@{const_name heap_update}, _) $ p $ v $ m)
    = let
      val xs = narrow_mem_upd ctxt params p v
        |> map (apply2 (convert_fetch_ph2 ctxt params []))
        |> filter_out (uncurry (triv_mem_upd ctxt))
      val m = convert_fetch_ph2 ctxt params [] m
    in fold (uncurry mk_memupd1) xs m end
  | convert_fetch_ph2 _ _ [] (t as (Const (@{const_name pseudo_acc}, _) $ _)) = t
  | convert_fetch_ph2 ctxt params accs (Const (@{const_name pseudo_acc}, _) $ Free (s, T)) = let
    val T = get_acc_type accs T
    fun canon s [] = mk_pseudo_acc s T
      | canon s (Const (@{const_name Arrays.index}, idxT) $ i :: accs) = (case
            (try dest_nat i)
        of SOME i => canon (s ^ "." ^ string_of_int i) accs
          | NONE => let val (_, n) = dest_arrayT (domain_type idxT)
          in mk_acc_array (convert_fetch_ph2 ctxt params [] i)
            (map (fn j => canon (s ^ "." ^ string_of_int j) accs)
              (0 upto (n - 1))) end)
      | canon s (Const (acc_nm, _) :: accs)
        = canon (s ^ "." ^ Long_Name.base_name acc_nm) accs
      | canon _ (t :: _) = raise TERM ("convert_fetch_ph2: canon: ", [t])
  in canon s accs end
  | convert_fetch_ph2 _ _ [] (t as (Free ("symbol_table", _) $ _))
      = t
  | convert_fetch_ph2 _ _ [] (t as Free ("domain", _))
      = t
  | convert_fetch_ph2 ctxt params accs t = let
    val (f, xs) = strip_comb t
    val (c, _) = dest_Const f
    val cnv = phase2_convert_global ctxt params accs f
        |> Option.map (fst #> convert_fetch_phase1 params)
  in if (get_field ctxt c |> Option.map #3) = SOME false
    then case xs of [x] => convert_fetch_ph2 ctxt params (f :: accs) x
        | _ => raise TERM ("convert_fetch_ph2: expected single", f :: xs)
  else if cnv <> NONE then convert_fetch_ph2 ctxt params accs (the cnv)
  else if (get_field ctxt c <> NONE orelse #cons_fields params c <> NONE)
  then let
    val _ = (accs <> []) orelse raise TERM ("convert_fetch_ph2: no accs", [t])
    val t' = hd accs $ t
    val t'' = #cons_field_upds params t'
  in if t'' aconv t' then raise TERM ("convert_fetch_ph2: irreducible upd:", [t'])
    else convert_fetch_ph2 ctxt params (tl accs) t'' end
  else list_comb (f, map (convert_fetch_ph2 ctxt params []) xs) end

fun convert_upd_ph2_worker ctxt params s v T accs =
  if #structs_by_typ params (fst (dest_Type T)) <> NONE
  then let
    val (_, _, _, _, flds) = the (#structs_by_typ params (fst (dest_Type T)))
  in maps (fn (fld_nm, (acc, _)) => convert_upd_ph2_worker ctxt params (s ^ "." ^ fld_nm)
    v (range_type (fastype_of acc)) (accs @ [acc])) flds end
  else if fst (dest_Type T) = @{type_name array}
  then let
    val (elT, n) = dest_arrayT T
  in maps (fn i => convert_upd_ph2_worker ctxt params (s ^ "." ^ string_of_int i)
    v elT (accs @ [Const (@{const_name Arrays.index}, T --> @{typ nat} --> elT)
        $ HOLogic.mk_number @{typ nat} i])) (0 upto (n - 1))
  end
  else [(s, convert_fetch_ph2 ctxt params accs v)]

fun convert_upd_ph2 ctxt params (s, v)
    = convert_upd_ph2_worker ctxt params s v (fastype_of v) []
(*      |> tap (map (snd #> Syntax.pretty_term ctxt #> Pretty.writeln)) *)
\<close>

text \<open>The final conversion reduces Isabelle terms to strings\<close>

ML \<open>
val space_pad = space_implode " "

fun space_pad_list xs = space_pad (string_of_int (length xs) :: xs)

fun s_st ctxt = Syntax.read_term ctxt "s :: globals myvars"
fun rv_st ctxt = Syntax.read_term ctxt "rv :: globals myvars"

fun convert_op ctxt params nm tp xs = "Op " ^ nm ^ " " ^ tp
    ^ " " ^ space_pad_list (map (convert_ph3 ctxt params) xs)

and convert_ph3 ctxt params (Const (@{const_name Collect}, _) $ S $ x)
    = convert_ph3 ctxt params (betapply (S, x))
  | convert_ph3 ctxt params (Const (@{const_name Lattices.inf}, _) $ S $ T $ x)
    = convert_op ctxt params "And" "Bool" [betapply (S, x), betapply (T, x)]
  | convert_ph3 ctxt params (Const (@{const_name Ptr}, _) $ p) = convert_ph3 ctxt params p
  | convert_ph3 ctxt params (Const (@{const_name ptr_val}, _) $ p) = convert_ph3 ctxt params p
  | convert_ph3 ctxt params (t as (Const (@{const_name CTypesDefs.ptr_add}, T) $ _ $ _))
    = convert_ph3 ctxt params (ptr_simp_term ctxt "ptr_add"
        (head_of t $ Free ("p", domain_type T) $ Free ("n", @{typ int})) t)
  | convert_ph3 ctxt params (t as (Const (@{const_name field_lvalue}, T) $ _ $ s))
    = convert_ph3 ctxt params (ptr_simp_term ctxt "field_lvalue"
        (head_of t $ Free ("p", domain_type T) $ s) t)
  | convert_ph3 ctxt params (Const (@{const_name store_word64}, _) $ p $ w $ m)
        = convert_op ctxt params "MemUpdate" "Mem" [m, p, w]
  | convert_ph3 ctxt params (Const (@{const_name store_word32}, _) $ p $ w $ m)
        = convert_op ctxt params "MemUpdate" "Mem" [m, p, w]
  | convert_ph3 ctxt params (Const (@{const_name store_word8}, _) $ p $ w $ m)
        = convert_op ctxt params "MemUpdate" "Mem" [m, p, w]
  | convert_ph3 ctxt params (Const (@{const_name heap_update}, _) $ p $ v $ m)
        = convert_op ctxt params "MemUpdate" "Mem" [m, p, v]
  | convert_ph3 ctxt params (t as (Const (@{const_name h_val}, _) $ m $ p))
        = convert_op ctxt params "MemAcc" (convert_type false ctxt (fastype_of t)) [m, p]
  | convert_ph3 ctxt params (Const (@{const_name load_word64}, _) $ p $ m)
        = convert_op ctxt params "MemAcc" "Word 64" [m, p]
  | convert_ph3 ctxt params (Const (@{const_name load_word32}, _) $ p $ m)
        = convert_op ctxt params "MemAcc" "Word 32" [m, p]
  | convert_ph3 ctxt params (Const (@{const_name load_word8}, _) $ p $ m)
        = convert_op ctxt params "MemAcc" "Word 8" [m, p]
  | convert_ph3 ctxt params (Const (@{const_name fun_upd}, _) $ f $ x $ v)
        = convert_op ctxt params "WordArrayUpdate"
            (convert_type false ctxt (fastype_of f)) [f, x, v]
  | convert_ph3 ctxt params (Const (@{const_name fun_app}, _) $ f $ x)
        = convert_op ctxt params "WordArrayAccess"
            (convert_type false ctxt (fastype_of (f $ x))) [f, x]
  | convert_ph3 ctxt params ((le as Const (@{const_name less_eq}, _))
        $ (Const (@{const_name insert}, _) $ p $ S) $ D)
        = convert_op ctxt params "And" "Bool" [HOLogic.mk_mem (p, D), le $ S $ D]
  | convert_ph3 ctxt params (Const (@{const_name less_eq}, _)
        $ Const (@{const_name bot_class.bot}, _) $ _) = convert_ph3 ctxt params @{term True}
  | convert_ph3 ctxt params (Const (@{const_name htd_safe}, _) $ _ $ _)
        = convert_ph3 ctxt params @{term True}
  | convert_ph3 ctxt params (Const (@{const_name uminus}, T) $ v)
        = let val T = domain_type T
          in convert_ph3 ctxt params (Const (@{const_name minus}, T --> T --> T)
                $ Const (@{const_name zero_class.zero}, T) $ v) end
  | convert_ph3 ctxt params (Const (@{const_name h_t_valid}, _) $ htd
            $ Const (@{const_name c_guard}, _) $ p)
        = convert_op ctxt params "PValid" "Bool" [htd, ptr_to_typ p, p]
  | convert_ph3 ctxt params (Const (@{const_name array_assertion}, _) $ p $ n $ htd)
        = convert_op ctxt params "PArrayValid" "Bool"
            [htd, ptr_to_typ p, p, @{term "of_nat :: nat => machine_word"} $ n]
  | convert_ph3 ctxt params (Const (@{const_name ptr_add_assertion'}, assT)
            $ p $ n $ str $ htd)
        = convert_ph3 ctxt params let val T = dest_ptr_type (fastype_of p)
            val ass' = (Const (@{const_name ptr_add_assertion}, assT)) $ p $ n $ str $ htd
            val ass'' = Pattern.rewrite_term (Proof_Context.theory_of ctxt)
              (map thm_to_rew @{thms ptr_add_assertion_uintD ptr_add_assertion_sintD
                                     if_True if_False}) [] ass'
          in if T = @{typ unit} orelse T = @{typ word8}
            then @{term True} else ass'' end
  | convert_ph3 ctxt params (Const (@{const_name ptr_inverse_safe}, _) $ p $ htd)
        = convert_op ctxt params "PGlobalValid" "Bool" [htd, ptr_to_typ p, p]
  | convert_ph3 ctxt params (Const (@{const_name ptr_safe}, _) $ p $ htd)
        = convert_op ctxt params "PWeakValid" "Bool" [htd, ptr_to_typ p, p]
  | convert_ph3 ctxt params (Const (@{const_name globals_list_distinct}, _) $
        (Const (@{const_name image}, _) $ Const (@{const_name fst}, _)
            $ (Const (@{const_name s_footprint}, _) $ _)) $ _ $ _)
        = convert_ph3 ctxt params @{term True}
  | convert_ph3 ctxt params (Const (@{const_name c_guard}, _) $ p)
        = convert_op ctxt params "PAlignValid" "Bool" [ptr_to_typ p, p]
  | convert_ph3 ctxt params (Const (@{const_name bot}, _) $ _)
        = convert_ph3 ctxt params @{term False}
  | convert_ph3 ctxt params (Const (@{const_name top_class.top}, _) $ _)
        = convert_ph3 ctxt params @{term True}
  | convert_ph3 ctxt params (Const (@{const_name insert}, _) $ v $ S $ x)
        = convert_op ctxt params "Or" "Bool" [HOLogic.mk_eq (v, x), betapply (S, x)]
  | convert_ph3 _ _ (Free ("symbol_table", _) $ s)
        = "Symbol " ^ HOLogic.dest_string s ^ " " ^ machine_word
  | convert_ph3 ctxt params (Const (@{const_name of_nat}, T) $ (Const (@{const_name unat}, _) $ x))
        = let
            val t1 = fastype_of x
            val t2 = range_type T
          in if t1 = t2 then convert_ph3 ctxt params x
            else convert_ph3 ctxt params (Const (@{const_name ucast}, t1 --> t2) $ x)
          end
  | convert_ph3 ctxt params (t as (Const (@{const_name of_nat}, _) $ _))
        = convert_ph3 ctxt params (ptr_simp_term ctxt "of_nat" t t)
  | convert_ph3 ctxt params (t as (Const (@{const_name power}, _) $ x $ y))
        = (case try HOLogic.dest_number x of
            SOME ((typ as Type (@{type_name word}, _)), 2) => convert_ph3 ctxt params
                (Const (@{const_name shiftl}, typ --> @{typ nat} --> typ)
                    $ HOLogic.mk_number typ 1 $ y)
        | _ => convert_ph3 ctxt params (ptr_simp_term ctxt "power" t t))
  | convert_ph3 ctxt params (Const (@{const_name ptr_coerce}, _) $ p)
        = convert_ph3 ctxt params p
  | convert_ph3 ctxt params (t as (Const (@{const_name word_of_int}, _) $ _))
    = if head_of t = int_to_ghost_key then convert_ph3 ctxt params (convert_ghost_key ctxt t)
     else let
        val thy = Proof_Context.theory_of ctxt
        val t' = Pattern.rewrite_term thy (map (Thm.concl_of #> HOLogic.dest_Trueprop
            #> HOLogic.dest_eq) @{thms word_uint.Rep_inverse word_sint.Rep_inverse}) [] t
      in if t' aconv t then convert_ph3 ctxt params (ptr_simp_term ctxt "word_of_int" t t)
        else convert_ph3 ctxt params t' end
  | convert_ph3 ctxt params (t as (Const (@{const_name sdiv}, _) $ _ $ _))
    = convert_ph3 ctxt params (ptr_simp_term ctxt "sdiv" t t)
  | convert_ph3 ctxt _ (t as (Const (@{const_name numeral}, _) $ _))
    = let
    val n = HOLogic.dest_number t |> snd
        handle TERM _ => raise TERM ("convert_ph3", [t])
    val _ = (fastype_of t <> @{typ int}) orelse raise TERM ("convert_ph3: int", [t])
  in "Num " ^ signed_string_of_int n ^ " " ^ convert_type false ctxt (fastype_of t) end
  | convert_ph3 ctxt _ (Const (@{const_name Pure.type}, Type (_, [T])))
    = "Type " ^ convert_type true ctxt T
  | convert_ph3 ctxt _ (Const (@{const_name pseudo_acc}, _) $ Free (s, T))
    = "Var " ^ s ^ " " ^ convert_type false ctxt T
  | convert_ph3 ctxt params t = let
    val (f, xs) = strip_comb t
    val (c, _) = dest_Const f
    val xs = if member (op =) [@{const_name shiftl},
        @{const_name shiftr}, @{const_name sshiftr}] c
      then case xs of
        [x, y] => [x, Const (@{const_name of_nat}, @{typ nat} --> fastype_of x) $ y]
        | _ => raise TERM ("convert_ph3: shift", [t])
      else xs
  in case ops c of
    (SOME (nm, _)) => convert_op ctxt params nm (convert_type false ctxt (fastype_of t)) xs
  | NONE => ("Num " ^ signed_string_of_int (snd (HOLogic.dest_number t))
        ^ " " ^ convert_type false ctxt (fastype_of t)
    handle TERM _ => raise TERM ("convert_ph3", [t]))
  end

fun htd_simp ctxt = ctxt addsimps @{thms fold_all_htd_updates
        unat_less_2p_word_bits[simplified word_bits_conv]}
  |> Simplifier.add_cong @{thm if_cong} |> Simplifier.rewrite

fun simp_htd ctxt t = let
    val rew_thm = Thm.cterm_of ctxt t |> htd_simp ctxt
  in Thm.term_of (Thm.rhs_of rew_thm) end

fun convert_upd_ph3 ctxt params (s, v) =
  let
    val nm = if s = "HTD" then "HTD HTD"
        else s ^ " " ^ convert_type false ctxt (fastype_of v)
    val v = if s = "HTD" then simp_htd ctxt v else v
    val v = convert_ph3 ctxt params v
  in (nm, v) end
    handle TERM (s, ts) => raise TERM ("convert_upd_ph3: " ^ s, v :: ts)
\<close>

ML \<open>
fun convert_fetch ctxt params t =
    Envir.beta_eta_contract t
    |> convert_fetch_phase1 params
    |> convert_fetch_ph2 ctxt params []
    |> convert_ph3 ctxt params

fun tracet (s, t) = ((Syntax.pretty_term @{context} t |> Pretty.writeln); (s, t))

fun convert_param_upds ctxt params (t as (Const (c, _) $ _ $ s))
    = if #local_upds params c orelse c = @{const_name globals_update}
      then convert_param_upds ctxt params s
        @ (Envir.beta_eta_contract t
(*        |> tap (Syntax.pretty_term ctxt #> Pretty.writeln) *)
        |> convert_upd_phase1 ctxt params
(*        |> map tracet *)
(*        |> map (apsnd (Syntax.check_term ctxt)) *)
        |> maps (convert_upd_ph2 ctxt params)
(*        |> map (apsnd (Syntax.check_term ctxt)) *)
        |> map (convert_upd_ph3 ctxt params)
        )
      else raise TERM ("convert_param_upds", [t])
  | convert_param_upds ctxt _ t = (if t = s_st ctxt then []
    else raise TERM ("convert_param_upds", [t]))

\<close>

ML \<open>

val all_c_params = ["Mem Mem", "HTD HTD", "PMS PMS",
                    "GhostAssertions WordArray 50 " ^ ParseGraph.ptr_size_str]
val all_c_in_params = map (prefix "Var ") all_c_params
val all_asm_params = ["Mem Mem", "PMS PMS"]
val all_asm_in_params = map (prefix "Var ") all_asm_params

fun asm_spec_name_to_fn_name _ specname = let
    val name = space_implode "_" (space_explode " " specname)
  in "asm_instruction'" ^ name end

fun mk_safe f ctxt params s = (
    Proof_Context.get_thm ctxt (s ^ "_body_def");
    Proof_Context.get_thm ctxt (s ^ "_impl");
  f ctxt params s) handle ERROR _ => false

fun mk_set_int s t = let
    val T = fastype_of s
  in Const (@{const_name Lattices.inf}, T --> T --> T) $ s $ t end

val reduce_set_mem_eqs = @{thms mem_Collect_eq Int_iff Un_iff empty_iff iffI[OF TrueI UNIV_I]}
      |> map (mk_meta_eq #> Thm.concl_of #> Logic.dest_equals)

fun reduce_set_mem ctxt x S = let
    val t = HOLogic.mk_mem (x, S)
    val t' = Pattern.rewrite_term (Proof_Context.theory_of ctxt)
    reduce_set_mem_eqs [] t
  in if t aconv t' then Pretty.writeln (Syntax.pretty_term ctxt (HOLogic.mk_prod (t, t')))
     else (); t'
  end

fun is_spec_body_const @{const_name Spec} = true
  | is_spec_body_const @{const_name guarded_spec_body} = true
  | is_spec_body_const _ = false

fun has_reads body = exists_Const (fn (s, T) =>
    snd (strip_type T) = @{typ heap_raw_state}
        orelse is_spec_body_const s) body

fun has_reads_globals (params : export_params) body = exists_Const (fn (s, T) =>
    snd (strip_type T) = @{typ heap_raw_state}
  orelse is_spec_body_const s
  orelse #rw_global_accs params s <> NONE
  orelse #const_globals params (Const (s, T)) <> NONE
  ) body

fun get_reads_calls ctxt params globals name = let
    val thm = Proof_Context.get_thm ctxt (name ^ "_body_def")
        |> simplify (put_simpset HOL_basic_ss ctxt addsimps @{thms call_def block_def})
    fun calls (Const (@{const_name com.Call}, _) $ proc) = [proc]
      | calls (f $ x) = calls f @ calls x
      | calls (Abs (_, _, t)) = calls t
      | calls _ = []
    val reads = (if globals then has_reads_globals params else has_reads)
        (Thm.concl_of thm)
    val call_to_name = dest_Const #> fst #> Long_Name.base_name
        #> unsuffix "_'proc"
  in (reads, calls (Thm.concl_of thm) |> map call_to_name) end

fun is_no_read ctxt params globals s = let
    fun inner stack s = if member (op =) stack s then true else let
        val (reads, calls) = get_reads_calls ctxt params globals s
      in not reads andalso forall I (map (inner (s :: stack)) calls) end
  in inner [] s end

fun is_no_write ctxt s = let
    val thm = Proof_Context.get_thm ctxt (s ^ "_modifies")
    val mex = exists_Const (fn (s, _) => s = @{const_name mex}) (Thm.concl_of thm)
  in not mex end

fun synthetic_updates ctxt params pref (Const (c, T)) = let
    val s = s_st ctxt
    val sT = fastype_of s
    val xT = range_type T
    val upd = Const (suffix Record.updateN c, (xT --> xT) --> sT --> sT)
        $ Abs ("v", xT, Bound 0) $ s
      |> Syntax.check_term ctxt
    val upds = convert_param_upds ctxt params upd
  in map (apfst (prefix pref)) upds end
  | synthetic_updates _ _ _ t = raise TERM ("synthetic_updates", [t])

fun is_no_read_globals ctxt params = is_no_read ctxt params true

fun get_global_valid_assertion ctxt (params : export_params) t = let
    val tnames = Term.add_const_names t []
    val globs = map_filter (#rw_global_accs params) tnames
        @ map_filter (#rw_global_upds params) tnames
    fun assert nm = let
        val T = Symtab.lookup (#rw_globals_tab params) nm
            |> the |> fst |> fastype_of |> range_type
        val p = TermsTypes.mk_global_addr_ptr (nm, T)
      in convert_op ctxt params "PGlobalValid" "Bool"
          [mk_pseudo_acc "HTD" @{typ heap_typ_desc}, ptr_to_typ p, p]
      end
    val globs = sort_distinct fast_string_ord globs
      |> map assert
    fun conj (x, y) = "Op And Bool 2 " ^ x ^ " " ^ y
  in case globs of [] => NONE
    | _ => SOME (foldr1 conj globs)
  end

fun emit outfile s = TextIO.output (outfile, s ^ "\n")

fun add_global_valid_assertion outfile ctxt params t n =
  case get_global_valid_assertion ctxt params t of NONE =>
        (n + 1, string_of_int n)
      | SOME ass => (emit outfile (string_of_int (n + 1) ^ " Cond " ^ string_of_int n ^ " Err " ^ ass);
        (n + 2, string_of_int (n + 1)))

fun emit_body ctxt outfile params (Const (@{const_name Seq}, _) $ a $ b) n c e = let
    val (n, nm) = emit_body ctxt outfile params b n c e
        handle TERM (s, ts) => raise TERM (s, b :: ts)
            | Empty => raise TERM ("emit_body: got Empty", [b])
    val (n, nm) = emit_body ctxt outfile params a n nm e
        handle TERM (s, ts) => raise TERM (s, a :: ts)
            | Empty => raise TERM ("emit_body: got Empty", [a])
  in (n, nm) end
  | emit_body ctxt outfile params (Const (@{const_name Catch}, _) $ a $ b) n c e = (case b of
    Const (@{const_name com.Skip}, _) => emit_body ctxt outfile params a n c (c, c)
  | Const (@{const_name ccatchbrk}, _) $ _ => emit_body ctxt outfile params a n c (fst e, c)
  | t => raise TERM ("emit_body ctxt params (Catch)", [t])
  )
  | emit_body ctxt outfile params (Const (@{const_name creturn}, _) $ _ $ upd $ f) n _ (r, b) =
    emit_body ctxt outfile params (@{term com.Basic} $ Abs ("s", dummyT, betapplys (upd,
        [Abs ("_", dummyT, betapply (f, Bound 1)), Bound 0]))) n r (r, b)
  | emit_body _ _ _ (Const (@{const_name creturn_void}, _) $ _) n _ (r, _) = (n, r)
  | emit_body _ _ _ (Const (@{const_name cbreak}, _) $ _) n _ (_, b) = (n, b)
  | emit_body _ _ _ (Const (@{const_name com.Skip}, _)) n c _ = (n, c)
  | emit_body ctxt outfile params (Const (@{const_name com.Cond}, _) $ S $ a $ b) n c e = let
    val (n, nm_a) = emit_body ctxt outfile params a n c e
    val (n, nm_b) = emit_body ctxt outfile params b n c e
    val s = convert_fetch ctxt params (reduce_set_mem ctxt (s_st ctxt) S)
  in
    emit outfile (string_of_int n ^ " Cond " ^ nm_a ^ " " ^ nm_b ^ " " ^ s);
    add_global_valid_assertion outfile ctxt params S n
  end
  | emit_body ctxt outfile params (Const (@{const_name Guard}, T) $ F $ G $
            (Const (@{const_name Guard}, _) $ _ $ G' $ a)) n c e
        = emit_body ctxt outfile params (Const (@{const_name Guard}, T) $ F
            $ (mk_set_int G G') $ a) n c e
  | emit_body ctxt outfile params (Const (@{const_name Guard}, _) $ _ $ G $ a) n c e = let
    val (n, nm) = emit_body ctxt outfile params a n c e
    val thy = Proof_Context.theory_of ctxt
    val G = Pattern.rewrite_term thy
      (@{thms guard_arith_simps meta_eq_to_obj_eq[OF ptr_arr_retyps_def]}
        |> map (Thm.concl_of #> HOLogic.dest_Trueprop #> HOLogic.dest_eq)) [] G
    val s = convert_fetch ctxt params (reduce_set_mem ctxt (s_st ctxt) G)
  in
    emit outfile (string_of_int n ^ " Cond " ^ nm ^ " Err " ^ s);
    add_global_valid_assertion outfile ctxt params G n
  end
  | emit_body _ _ _ (Const (@{const_name com.Basic}, _) $ Abs (_, _, Bound 0)) n c _
    = (n, c)
  | emit_body ctxt outfile params (Const (@{const_name com.Basic}, _) $ f) n c _ = let
    val upds = convert_param_upds ctxt params (betapply (f, s_st ctxt))
      |> filter_out (fn (s, v) => v = "Var " ^ s)
      |> map (fn (s, v) => s ^ " " ^ v)

  in
    emit outfile (string_of_int n ^ " Basic " ^ c ^ " " ^ space_pad_list upds);
    add_global_valid_assertion outfile ctxt params f n
  end
  | emit_body ctxt outfile params (Const (@{const_name Spec}, _)
        $ (Const (@{const_name asm_spec}, _) $ _ $ _ $ vol $ spec $ lhs $ vs))
    n c _ = let
    val spec = HOLogic.dest_string spec
    val lhss = convert_param_upds ctxt params
      (betapplys (lhs, [@{term "0 :: machine_word"}, s_st ctxt]))
    val args = HOLogic.dest_list (betapply (vs, s_st ctxt))
      |> map (convert_fetch ctxt params)
    val args = args @ all_asm_in_params
    val outs = map fst lhss @ all_asm_params
    val _ = HOLogic.mk_prod
  in emit outfile (string_of_int n ^ " Call " ^ c ^ " " ^ asm_spec_name_to_fn_name vol spec
    ^ " " ^ space_pad_list args ^ " " ^ space_pad_list outs);
     add_global_valid_assertion outfile ctxt params (HOLogic.mk_prod (lhs, vs)) n
  end
  | emit_body ctxt outfile params (Const (@{const_name call}, _) $ f $ Const (p, _)
        $ _ $ r2) n c e = let
    val proc_info = Hoare.get_data ctxt |> #proc_info
    val ret_vals = Symtab.lookup proc_info (Long_Name.base_name p)
        |> the |> #params
        |> filter (fn (v, _) => v = HoarePackage.Out)
        |> maps (snd #> read_const ctxt
         #> synthetic_updates ctxt params "rv#space#")
        |> map fst

    val p_short = unsuffix "_'proc" (Long_Name.base_name p)
    val no_read = mk_safe is_no_read_globals ctxt params p_short
    val no_write = mk_safe (K o is_no_write) ctxt params p_short
    (* writes implicitly require reads, really *)
    val no_read = no_read andalso no_write

    val args = ((convert_param_upds ctxt params (betapply (f, s_st ctxt))
            |> map snd (* discard the local names of the updated variables *))
        @ (if no_read then [] else all_c_in_params))
      handle TERM (s, ts) => raise TERM ("emit_body call: " ^ s, f :: ts)

    val out = ret_vals @ (if no_write then [] else all_c_params)

    val (n, nm_save) = emit_body ctxt outfile params (betapplys (r2, [@{term i}, rv_st ctxt])) n c e

  in emit outfile (string_of_int n ^ " Call " ^ nm_save ^ " " ^ (unsuffix "_'proc" p)
    ^ " " ^ space_pad_list args ^ " " ^ space_pad_list out);
     add_global_valid_assertion outfile ctxt params f n
  end
  | emit_body _ _ _ (Const (@{const_name lvar_nondet_init}, _) $ _ $ _) n c _
    = (n, c)
  | emit_body ctxt outfile params (Const (@{const_name whileAnno}, _) $ C $ _ $ _ $ bd) n c e = let
    fun sn i = string_of_int (n + i)
    val lc = "loop#" ^ sn 0 ^ "#count" ^ " " ^ machine_word
    val (n', nm) = emit_body ctxt outfile params bd (n + 4) (sn 0) e
    val cond = convert_fetch ctxt params (reduce_set_mem ctxt (s_st ctxt) C)
    val err_cond = case get_global_valid_assertion ctxt params C
        of NONE => "Op True Bool 0"
        | SOME s => s
  in emit outfile (sn 0 ^ " Basic " ^ sn 1 ^ " 1 " ^ lc
      ^ " Op Plus " ^ machine_word ^ " 2 Var " ^ lc ^ " Num 1 " ^ machine_word);
    emit outfile (sn 1 ^ " Cond " ^ sn 2 ^ " Err " ^ err_cond);
    emit outfile (sn 2 ^ " Cond " ^ nm ^ " " ^ c ^ " " ^ cond);
    emit outfile (sn 3 ^ " Basic " ^ sn 1 ^ " 1 " ^ lc ^ " Num 0 " ^ machine_word);
    (n', sn 3)
  end
  | emit_body _ _ _ t _ _ _ = raise TERM ("emit_body", [t])

fun emit_func_body ctxt outfile eparams name = let
    val proc_info = Hoare.get_data ctxt |> #proc_info
    val params = Symtab.lookup proc_info (name ^ "_'proc")
        |> the |> #params
        |> map (apsnd (read_const ctxt
                #> synthetic_updates ctxt eparams ""
                #> map fst))

    val no_read = mk_safe is_no_read_globals ctxt eparams name
    val no_write = mk_safe (K o is_no_write) ctxt eparams name
    (* writes implicitly require reads, really *)
    val no_read = no_read andalso no_write

    val inputs = (filter (fn p => fst p = HoarePackage.In) params
      |> maps snd) @ (if no_read then [] else all_c_params)

    val outputs = (filter (fn p => fst p = HoarePackage.Out) params
      |> maps snd) @ (if no_write then [] else all_c_params)

    val body = Get_Body_Refines.get ctxt name
      |> simplify (put_simpset HOL_basic_ss ctxt
                addsimps @{thms switch.simps fst_conv snd_conv
                                insert_iff empty_iff
                                ptr_add_assertion_def if_True if_False
                                bv_clz_def[symmetric] bv_ctz_def[symmetric]
                 })
      |> Thm.concl_of |> HOLogic.dest_Trueprop
      |> (fn t => (case t of Const (@{const_name simple_simpl_refines}, _) $ _ $ lhs $ _ => lhs
            | _ => raise Option))
        handle Option => @{term "Spec S"}
         | THM _ => @{term "Spec S"}

    val full_nm = read_const ctxt (name ^ "_'proc")
        |> dest_Const |> fst |> unsuffix "_'proc"
  in emit outfile "";
    emit outfile ("Function " ^ full_nm ^ " " ^ space_pad_list inputs
                ^ " " ^ space_pad_list outputs);
    if (try (head_of #> dest_Const #> fst #> is_spec_body_const) body)
        = SOME true
    then ()
    else (emit outfile ("1 Basic Ret 0");
          emit_body ctxt outfile eparams body 2 "1" ("ErrExc", "ErrExc")
            |> snd |> prefix "EntryPoint " |> emit outfile
          handle TERM (s, ts) => raise TERM ("emit_func_body: " ^ name ^ ": " ^ s, body :: @{term True} :: ts)
            | TYPE (s, Ts, ts) => raise TYPE ("emit_func_body: " ^ name ^ ": " ^ s, Ts, body :: @{term True} :: ts)
            | Empty => raise TERM ("emit_func_body: Empty", [body]))
  end

fun emit_struct ctxt outfile csenv (nm, flds) = let
    val offs = map (ProgramAnalysis.offset csenv (map snd flds))
        (0 upto (length flds - 1))
    val full_nm = read_const ctxt (nm ^ "." ^ nm)
        |> dest_Const |> snd |> strip_type |> snd |> dest_Type |> fst
    val thy = Proof_Context.theory_of ctxt
    val sz = ProgramAnalysis.sizeof csenv (Absyn.StructTy nm)
    val algn = ProgramAnalysis.alignof csenv (Absyn.StructTy nm)
    fun emit_fld ((fld_nm, fld_ty), offs) = emit outfile (space_pad
        ["StructField", fld_nm, convert_type false ctxt
            (CalculateState.ctype_to_typ (thy, fld_ty)), string_of_int offs])
  in emit outfile (space_pad ["Struct", full_nm, string_of_int sz,
    string_of_int algn]); app emit_fld (flds ~~ offs) end

fun scan_func_body_asm_instructions ctxt name = let
    val body = Proof_Context.get_thm ctxt (name ^ "_body_def")
    fun has_lhs lhs = betapplys (lhs, [Bound 0, Bound 1]) <> Bound 1
    fun nm_args vs = betapply (vs, s_st ctxt) |> HOLogic.dest_list |> length
    fun gather (Const (@{const_name asm_spec}, _) $ _ $ _ $ vol $ nm $ lhs $ vs) xs
        = (asm_spec_name_to_fn_name vol (HOLogic.dest_string nm),
            has_lhs lhs, nm_args vs) :: xs
      | gather (f $ x) xs = gather f (gather x xs)
      | gather _ xs = xs
  in gather (Thm.concl_of body) [] end
        handle ERROR _ => []

fun emit_asm_protoes ctxt outfile fs = let
    val asm_info = maps (scan_func_body_asm_instructions ctxt) fs
      |> sort_distinct (fn ((s, _, _), (t, _, _)) => fast_string_ord (s, t))
    fun mk_args n = (map (fn i => "arg" ^ string_of_int i ^ " " ^ machine_word) (1 upto n))
    fun mk_rets has_lhs = (if has_lhs then ["ret1 " ^ machine_word] else [])
    fun emit_it (nm, has_lhs, nm_args) = emit outfile
      ("Function " ^ nm
              ^ " " ^ space_pad_list (mk_args nm_args @ all_asm_params)
              ^ " " ^ space_pad_list (mk_rets has_lhs @ all_asm_params)
    )
  in app emit_it asm_info end

fun emit_C_everything ctxt csenv outfile = let
    val fs = ProgramAnalysis.get_functions csenv
    val structs = ProgramAnalysis.get_senv csenv
    val params = get_all_export_params ctxt csenv
  in app (emit_struct ctxt outfile csenv) structs;
     app (emit_func_body ctxt outfile params) fs;
     emit_asm_protoes ctxt outfile fs end
\<close>

ML \<open>
fun openOut_relative thy = ParseGraph.filename_relative thy #> TextIO.openOut;

fun emit_C_everything_relative ctxt csenv fname = let
    val thy = Proof_Context.theory_of ctxt
    val outfile = openOut_relative thy fname
  in emit_C_everything ctxt csenv outfile; TextIO.closeOut outfile end
\<close>

end


theory WeakestPrecondition
imports "../IrisCore/Invariant" Notation LanguageDefs
begin

named_theorems heap_inG_axiom
named_theorems proph_inG_axiom
named_theorems inv_inG_axiom

context
fixes get_inv :: "gname \<Rightarrow> 'res :: ucamera \<Rightarrow> inv option"
  and put_inv
  and get_heap :: "gname \<Rightarrow> 'res \<Rightarrow> heap_lang_heap option"
  and put_heap
  and get_prophm :: "gname \<Rightarrow> 'res \<Rightarrow> (proph_id, val\<times>val) proph_mapGS option"
  and put_prophm
assumes inv_inG: "inG get_inv put_inv"
  and heap_inG: "inG get_heap put_heap"
  and prophm_inG: "inG get_prophm put_prophm"
begin

abbreviation fancy_upd ("\<Turnstile>{_,_}=>_") where "fancy_upd \<equiv> ViewShift.fancy_upd put_inv"
abbreviation wand_fupd ("_={_,_}=\<^emph>_") where "wand_fupd \<equiv> ViewShift.wand_fupd put_inv"
abbreviation linear_fupd ("\<Turnstile>{_}=>_") where "linear_fupd \<equiv> ViewShift.linear_fupd put_inv"
abbreviation wand_linear_fupd ("_={_}=\<^emph>_") where "wand_linear_fupd \<equiv> ViewShift.wand_linear_fupd put_inv"
abbreviation fancy_step ("\<Turnstile>{_}[_]\<triangleright>=>_") where "fancy_step \<equiv> ViewShift.fancy_step put_inv"
abbreviation fancy_wand_step ("_={_}[_]\<triangleright>=\<^emph>_") where "fancy_wand_step \<equiv> ViewShift.fancy_wand_step put_inv"
abbreviation fancy_linear_wand_step ("_={_}\<triangleright>=\<^emph>_") where
  "fancy_linear_wand_step \<equiv> ViewShift.fancy_linear_wand_step put_inv"
abbreviation state_interp where "state_interp \<equiv> LanguageDefs.state_interp put_prophm put_heap"
abbreviation points_to where "points_to \<equiv> AuthHeap.points_to put_heap"
abbreviation points_to_disc where "points_to_disc \<equiv> AuthHeap.points_to_disc put_heap"
abbreviation points_to_own where "points_to_own \<equiv> AuthHeap.points_to_own put_heap"
abbreviation points_to_full where "points_to_full \<equiv> AuthHeap.points_to_full put_heap"

notation points_to ("_ \<mapsto>{_} _" 60)
notation points_to_disc (infix "\<mapsto>\<box>" 60)
notation points_to_own ("_\<mapsto>{#_}_" 60)
notation points_to_full (infix "\<mapsto>\<^sub>u" 60)

subsection \<open>Weakest Preconditions\<close>

lift_definition wp_pre :: "stuckness \<Rightarrow> ((mask \<Rightarrow> expr \<Rightarrow> (val \<Rightarrow> 'res upred_f) \<Rightarrow> 'res upred_f) -c>
  (mask \<Rightarrow> expr \<Rightarrow> (val \<Rightarrow> 'res upred_f) \<Rightarrow> 'res upred_f))" is
  "\<lambda>s wp_arg E e1 \<Phi>. (case HeapLang.to_val e1 of Some v \<Rightarrow> \<Turnstile>{E}=> (\<Phi> v)
    | None \<Rightarrow> (\<forall>\<^sub>u \<sigma>1 \<kappa> \<kappa>s.
      ((state_interp \<sigma>1 (\<kappa>@\<kappa>s)) ={E,Set.empty}=\<^emph>
        ((\<upharpoonleft>(case s of NotStuck \<Rightarrow> reducible e1 \<sigma>1 | _ \<Rightarrow> True)) \<^emph>
        (\<forall>\<^sub>u e2 \<sigma>2 efs. ((\<upharpoonleft>(prim_step e1 \<sigma>1 \<kappa> e2 \<sigma>2 efs))
          ={Set.empty}\<triangleright>=\<^emph> (\<Turnstile>{Set.empty,E}=> ((state_interp \<sigma>2 \<kappa>s) \<^emph>
            (wp_arg E e2 \<Phi>) \<^emph> ([\<^emph>\<^sub>l:] efs (\<lambda>ef. wp_arg UNIV ef (\<lambda>_. upred_emp)))))))))))"
apply (auto simp: contractive_alt_def contr_contr_alt n_equiv_fun_def split: option.splits nat.splits)
apply (auto simp: ofe_refl less_Suc_eq_le ofe_mono intro!: upred_ne_rule contractiveE[OF upred_later_contr])
apply (simp_all add: n_equiv_fun_def ofe_mono)
using inv_inG by simp_all

definition wp :: "stuckness \<Rightarrow> mask \<Rightarrow> expr \<Rightarrow> (val \<Rightarrow> 'res upred_f) \<Rightarrow> 'res upred_f" where
  "wp s \<equiv> fixpoint (wp_pre s)"

lemma wp_unfold: "wp s E e P \<stileturn>\<turnstile> Rep_contr (wp_pre s) (wp s) E e P"
  unfolding wp_def using upred_eq_entails fixpoint_unfold[of "wp_pre s", unfolded ofe_eq_fun_def]
  by blast

abbreviation WP :: "expr \<Rightarrow> (val \<Rightarrow> 'res upred_f) \<Rightarrow> 'res upred_f" ("WP _ {{ _ }}") where
  "WP e {{ \<Phi> }} \<equiv> wp NotStuck UNIV e \<Phi>"

abbreviation hoare :: "'res upred_f \<Rightarrow> expr \<Rightarrow> (val \<Rightarrow> 'res upred_f) \<Rightarrow> bool" ("{{ _ }} _ {{ _ }}") where
  "{{ P }} e {{ \<Phi> }} \<equiv> P \<turnstile> WP e {{ \<Phi> }}"

abbreviation texan :: "'res upred_f \<Rightarrow> expr \<Rightarrow> (val \<Rightarrow> 'res upred_f) \<Rightarrow> 'res upred_f" ("{{{ _ }}} _ {{{ _ }}}") where
  "{{{ P }}} e {{{ Q }}} \<equiv> \<box>(\<forall>\<^sub>u \<Phi>. P -\<^emph> (\<triangleright>(\<forall>\<^sub>u v. Q v -\<^emph> \<Phi> v)) -\<^emph> WP e {{ \<Phi> }})"

abbreviation texan2 :: "'res upred_f \<Rightarrow> expr \<Rightarrow> stuckness \<Rightarrow> mask \<Rightarrow> (val \<Rightarrow> 'res upred_f) \<Rightarrow> 'res upred_f"
  ("{{{ _ }}} _ @ _ ; _ {{{ _ }}}") where
  "{{{ P }}} e @ s; E {{{ Q }}} \<equiv> \<box>(\<forall>\<^sub>u \<Phi>. P -\<^emph> (\<triangleright>(\<forall>\<^sub>u v. Q v -\<^emph> \<Phi> v)) -\<^emph> wp s E e \<Phi>)"

lemma texan_to_wp: "{{{ P }}} e @ s; E {{{ Q }}} \<turnstile> (P -\<^emph> wp s E e Q)"
apply (rule upred_entails_trans[OF upred_persisE])
apply (rule upred_entails_trans[OF upred_forall_inst[of _ Q]])
apply (rule upred_wandI)
apply (iApply rule: upred_wand_apply)
by (rule upred_true_wand)

lemma "{{{ P }}} e {{{ Q }}} \<Longrightarrow> {{ P }} e {{ Q }}"
  apply (rule upred_wand_holdsE[unfolded upred_holds_entails])
  unfolding upred_holds_entails using texan_to_wp upred_entails_trans by blast

text \<open>
  First we show that some basic properties of wp hold for inputs in the domain, then we
  always assume that all values lie in the domain.
\<close>

lemma wp_value_fupd: "wp s E (of_val v) P \<stileturn>\<turnstile> \<Turnstile>{E}=> P v"
  apply (rule upred_entail_eq_trans[OF wp_unfold])
  by (simp add: wp_pre.rep_eq)

lemma wp_value: "P v \<turnstile> wp s E (Val v) P"
  apply (rule upred_entails_trans[OF _ upred_entail_eqR[OF wp_unfold]])
  by (auto simp: wp_pre.rep_eq fupd_intro[OF inv_inG] upred_wand_holdsE)

lemma wp_fupd_helper: "\<forall>\<^sub>u v. (upred_emp ={E}=\<^emph> upred_emp)"
  apply (subst upred_holds_entails)
  apply (rule upred_forallI)
  using fupd_intro[OF inv_inG] upred_holds_entails by auto

lemma wp_strong_mono:
assumes "s1 \<le> s2"
shows "\<forall>\<^sub>uE1 E2 e P Q. (\<upharpoonleft>(E1 \<subseteq> E2)) \<longrightarrow>\<^sub>u (wp s1 E1 e P -\<^emph> (\<forall>\<^sub>u v. (P v ={E2}=\<^emph> Q v)) -\<^emph> wp s2 E2 e Q)"
  (is "upred_holds ?goal")
  apply (rule loebI)
  apply (auto intro!: upred_forallI upred_implI_pure upred_wandI)
  subgoal for E1 E2 e P Q
  apply (rule upred_entails_trans[OF _ upred_entail_eqR[OF wp_unfold]])
  apply (move_sepL "wp s1 E1 e P")
  apply (rule upred_entails_substE[OF upred_entail_eqL[OF wp_unfold]])
  unfolding wp_pre.rep_eq
  apply (cases "HeapLang.to_val e")
  apply auto
  apply (auto intro!: upred_forallI upred_wandI)
    subgoal for \<sigma>1 \<kappa> \<kappa>s
    apply (rule add_holds[OF fupd_mask_subseteq[OF inv_inG]], assumption)
    apply (rule upred_entails_trans[OF _ fupd_mask_trans[OF inv_inG, of E2 E1]])
    apply (rule fupd_frame_mono[OF inv_inG])
    apply (move_sepL "\<forall>\<^sub>u (x::state). ?P x")
    apply (rule upred_entails_substE[OF upred_forall_inst[of _ \<sigma>1]])
    apply (rule upred_entails_substE[OF upred_forall_inst[of _ \<kappa>]])
    apply (rule upred_entails_substE[OF upred_forall_inst[of _ \<kappa>s]])
    apply iApply_wand
    apply (rule upred_entails_trans[OF _ fupd_mask_trans[OF inv_inG, of E1 "{}"]])
    apply (rule fupd_frame_mono[OF inv_inG])
    apply (simp add: upred_sep_assoc_eq)
    apply (rule upred_entails_trans[OF upred_sep_comm2R])
    apply (rule upred_pure_impl)
    apply (rule upred_entails_trans[OF _ fupd_empty[OF inv_inG]])
    apply (rule upred_entails_trans[OF _ upred_entails_eq[OF upred_sep_comm]])
    apply (rule upred_sep_pure)
    apply (auto intro!: upred_forallI upred_wandI upred_pure_impl)
    subgoal for e2 \<sigma>2 efs
      apply (rule upred_entails_substE[OF upred_forall_inst[of _ e2]])
      apply (rule upred_entails_substE[OF upred_forall_inst[of _ \<sigma>2]])
      apply (rule upred_entails_substE[OF upred_forall_inst[of _ efs]])
      apply simp
      apply (rule upred_entails_substE[OF upred_true_wand])
      apply (rule upred_entails_trans[OF upred_sep_comm3L])
      apply (rule upred_entails_trans[OF upred_sep_comm3M])
      apply (rule upred_entails_trans[OF upred_sep_comm2R])
      apply (rule upred_entails_substE[OF upred_entail_eqL[OF upred_persis_later]])
      apply (rule upred_entails_trans[OF upred_sep_comm2R])
      apply (rule upred_entails_trans[OF upred_sep_comm3M])
      apply (rule upred_entails_trans[OF upred_sep_comm3L])
      apply (rule fupd_frame_mono[OF inv_inG])
      apply (rule upred_entails_trans[OF upred_sep_comm3L])
      apply (rule upred_entails_trans[OF upred_sep_comm3M])
      apply (rule upred_entails_substE[OF upred_entail_eqR[OF upred_later_sep], unfolded upred_sep_assoc_eq])
      apply (rule upred_later_mono_extR)
      apply (simp add: upred_sep_assoc_eq)
      apply (rule upred_entails_trans[OF upred_sep_comm3M])
      apply (rule upred_entails_trans[OF upred_sep_comm3L])
      apply (rule fupd_frame_mono[OF inv_inG])
      apply (rule upred_entails_trans[OF _ fupd_mask_trans[OF inv_inG, of "{}" E1]])
      apply (rule fupd_frame_mono[OF inv_inG])
      apply (simp add: upred_sep_assoc_eq)
      apply (rule upred_entails_trans[OF _ fupd_mono[OF inv_inG upred_entails_eq[OF upred_sep_comm2L]]])
      apply (rule upred_entails_trans[OF _ fupd_mono[OF inv_inG upred_sep_comm2R]])
      apply (rule upred_entails_trans[OF _ upred_wand_holdsE[OF fupd_frame_r[OF inv_inG]]])
      apply (rule upred_entails_trans[OF upred_sep_comm3M])
      apply (rule upred_entails_trans[OF upred_sep_comm2R])
      apply (rule upred_frame)
      apply (rule upred_entails_trans[OF upred_sep_comm3M])
      apply (rule upred_entails_trans[OF upred_sep_comm2R])
      apply (auto simp: upred_true_sep intro!: fupd_frame_mono[OF inv_inG])
      apply (rule split_frame[of _ "(\<box> ?goal) \<^emph> _ \<^emph> _"  "(\<box> ?goal) \<^emph> [\<^emph>\<^sub>l:] efs \<lambda>x. wp s1 UNIV x (\<lambda>_. upred_emp)"])
      apply (rule can_be_split_sepR)
      apply (rule can_be_split_sepL)
      apply (rule can_be_split_sepL)
      apply (rule persistent_dupl', pers_solver)
      apply (rule can_be_split_refl)
      subgoal
        apply (rule upred_entails_trans[OF upred_entails_eq[OF upred_sep_comm2L]])
        apply (rule upred_entails_trans[OF upred_sep_comm2R])
        apply (rule upred_entails_substE[OF upred_persisE])
        apply (rule upred_entails_substE[OF upred_forall_inst[of _ E1]])
        apply (rule upred_entails_substE[OF upred_forall_inst[of _ E2]])
        apply (rule upred_entails_substE[OF upred_forall_inst[of _ e2]])
        apply (rule upred_entails_substE[OF upred_forall_inst[of _ P]])
        apply (rule upred_entails_substE[OF upred_forall_inst[of _ Q]])
        by (auto intro!: upred_entails_substE[OF upred_entail_eqL[OF upred_emp_impl]]
          upred_entails_substE[OF upred_wand_apply, unfolded upred_sep_assoc_eq]
          upred_entails_trans[OF upred_wand_apply, unfolded upred_sep_assoc_eq])
      apply (rule upred_wandE)
      apply (rule upred_entails_trans[OF _ upred_wand_holdsE[OF sep_emp_map_list_entails']])
      apply (rule upred_persis_mono)
      apply (rule upred_entails_trans[OF upred_forall_inst[of _ UNIV]])
      apply (rule upred_entails_trans[OF upred_forall_inst[of _ UNIV]])
      apply (rule upred_forallI)
      subgoal for x
      apply (rule upred_entails_trans[OF upred_forall_inst[of _ x]])
      apply (rule upred_entails_trans[OF upred_forall_inst[of _ "(\<lambda>_. upred_emp)"]])
      apply (rule upred_entails_trans[OF upred_forall_inst[of _ "(\<lambda>_. upred_emp)"]])
      apply (auto intro!: upred_entails_trans[OF upred_entail_eqL[OF upred_emp_impl]])
      apply (rule upred_wandI)
      apply (subst upred_sep_comm)
      apply (rule upred_entails_trans[OF upred_wand_apply])
      apply (rule add_holds[OF wp_fupd_helper])
      apply (subst upred_sep_comm)
      by (auto intro: upred_entails_trans[OF upred_wand_apply])
      done
    apply (rule upred_pureI)
    using assms
    apply (cases s1; cases s2)
    by auto
  subgoal for v
    apply (iForallL v)
    apply (rule upred_wandE)
    apply (rule upred_entails_trans[OF _ fupd_ext[OF inv_inG]])
  by (auto intro!: upred_entails_trans[OF upred_weakeningR] upred_wand_holdsE[OF fupd_mask_mono[OF inv_inG]])
  done
done

lemma wp_strong_monoI: "\<lbrakk>s1 \<le> s2; E1 \<subseteq> E2\<rbrakk> \<Longrightarrow> wp s1 E1 e P \<turnstile> ((\<forall>\<^sub>u v. ((P v) ={E2}=\<^emph> Q v)) -\<^emph> wp s2 E2 e Q)"
proof -
assume assms: "s1 \<le> s2" "E1 \<subseteq> E2"
from wp_strong_mono[OF assms(1), to_entailment] have
  "upred_emp \<turnstile> ((\<upharpoonleft>(E1 \<subseteq> E2)) \<longrightarrow>\<^sub>u (wp s1 E1 e P -\<^emph> (\<forall>\<^sub>uv. ((P v)={E2,E2}=\<^emph>Q v)) -\<^emph> wp s2 E2 e Q))"
  by (auto dest!: upred_entails_trans[OF _ upred_forall_inst])
with assms(2) show ?thesis
by (smt (verit, best) add_holds entails_impl_true upred_holds_entails upred_wand_apply)
qed

lemma fupd_wp: "\<Turnstile>{E}=> (wp s E e P) \<turnstile> wp s E e P"
  apply (rule upred_entails_trans[OF _ upred_entail_eqR[OF wp_unfold]])
  apply(rule upred_entails_trans[OF fupd_mono[OF inv_inG upred_entail_eqL[OF wp_unfold]]])
  unfolding wp_pre.rep_eq
  apply (cases "HeapLang.to_val e")
  apply auto
  apply (auto intro!: upred_forallI)
  subgoal for \<sigma>1 \<kappa> \<kappa>s
    apply (rule upred_wandI)
    apply (rule upred_entails_trans[OF _ fupd_mask_trans[OF inv_inG, of E E]])
    apply (rule upred_entails_trans[OF upred_entails_eq[OF upred_sep_comm]])
    apply (rule fupd_frame_mono[OF inv_inG])
    apply (rule upred_entails_substE[OF upred_forall_inst[of _ \<sigma>1]])
    apply (rule upred_entails_substE[OF upred_forall_inst[of _ \<kappa>]])
    apply (rule upred_entails_substE[OF upred_forall_inst[of _ \<kappa>s]])
    by (auto intro: upred_entails_trans[OF upred_wand_apply])
  by (simp add: fupd_mask_trans[OF inv_inG])

lemma wp_fupd: "wp s E e (\<lambda>v. \<Turnstile>{E}=> P v) \<turnstile> wp s E e P"
  apply (rule add_holds[OF wp_strong_mono[of s s, simplified]])
  apply (rule upred_entails_substE[OF upred_forall_inst[of _ E]])
  apply (rule upred_entails_substE[OF upred_forall_inst[of _ E]])
  apply (rule upred_entails_substE[OF upred_forall_inst[of _ e]])
  apply (rule upred_entails_substE[OF upred_forall_inst[of _ "(\<lambda>v. \<Turnstile>{E}=> P v)"]])
  apply (rule upred_entails_substE[OF upred_forall_inst[of _ P]])
  apply (auto intro!: upred_entails_substE[OF upred_entail_eqL[OF upred_emp_impl]]
    upred_entails_trans[OF upred_wand_apply])
  apply (simp add: emp_rule)
  by (rule upred_true_wand)

lemma wp_mono:
assumes "(\<And>v. P v \<turnstile> Q v)"
shows "wp s E e P \<turnstile> wp s E e Q"
  apply (rule add_holds[OF wp_strong_mono[of s s, simplified]])
  apply (rule upred_entails_substE[OF upred_forall_inst[of _ E]])
  apply (rule upred_entails_substE[OF upred_forall_inst[of _ E]])
  apply (rule upred_entails_substE[OF upred_forall_inst[of _ e]])
  apply (rule upred_entails_substE[OF upred_forall_inst[of _ P]])
  apply (rule upred_entails_substE[OF upred_forall_inst[of _ Q]])
  apply (auto intro!: upred_entails_substE[OF upred_entail_eqL[OF upred_emp_impl]]
    upred_entails_trans[OF upred_wand_apply])
  apply (rule add_holds[OF upred_holds_forall[OF fupd_intro'[OF inv_inG assms, of _ E]], of _ id, simplified])
  apply (subst upred_sep_comm)
  by (rule upred_wand_apply)

lemma wp_mono':
assumes "(\<And>v. P v \<turnstile> Q v)"
shows "R \<^emph> wp s E e P \<turnstile> wp s E e Q"
  using wp_mono[OF assms] assms upred_entails_trans upred_weakeningR wp_mono
  by blast

lemma wp_atomic:
assumes "atomic (stuckness_to_atomicity s) e"
shows "\<Turnstile>{E1,E2}=> wp s E2 e (\<lambda>v. \<Turnstile>{E2,E1}=> P v) \<turnstile> wp s E1 e P"
  apply (rule upred_entails_trans[OF _ upred_entail_eqR[OF wp_unfold]])
  apply (rule upred_entails_trans[OF fupd_mono[OF inv_inG upred_entail_eqL[OF wp_unfold]]])
  unfolding wp_pre.rep_eq
  apply (cases "HeapLang.to_val e")
  apply simp_all
  prefer 2 apply (rule upred_entails_trans[OF fupd_mask_trans[OF inv_inG]])+ apply simp
  apply iForallR+
  apply (rule upred_wandI)
  apply (check_moveL "\<Turnstile>{?E1,?E2}=>?P", rule elim_modal_entails'[OF elim_modal_fupd[OF inv_inG]])
  subgoal for \<sigma>1 \<kappa> \<kappa>s apply (iForallL \<sigma>1, iForallL \<kappa>,iForallL \<kappa>s)
  apply iApply_wand
  apply (rule fupd_mono[OF inv_inG])
  apply iPureL
  apply iForallR+ subgoal for e2 \<sigma>2 efs apply (iForallL e2, iForallL \<sigma>2, iForallL efs)
  apply (rule upred_wandI, iPureL)
  apply (iApply_step "?P" rule: step_fupdN_wand[OF inv_inG, of 1 "{}" "{}"])
  apply (rule upred_entails_trans[OF upred_true_wand])
  apply (rule framing_emp, frame_solver, iris_simp, rule upred_wandI, iris_simp, rule upred_entails_refl)
  apply (rule fupd_mono[OF inv_inG], rule upred_later_mono, rule fupd_mono[OF inv_inG])
  apply (rule elim_modal_entails[OF elim_modal_fupd[OF inv_inG]])
  apply (cases s, auto)
    subgoal
    apply (iApply rule: upred_entail_eqL[OF wp_unfold])
    apply (entails_substR rule: fupd_mono[OF inv_inG upred_sep_mono[OF upred_entails_refl
        upred_sep_mono[OF upred_entail_eqR[OF wp_unfold] upred_entails_refl]], unfolded upred_sep_assoc_eq])
    unfolding wp_pre.rep_eq
    apply (cases "HeapLang.to_val e2", auto)
    prefer 2
    apply (check_moveL "\<Turnstile>{?E1,?E2}=>?P")
    apply (rule elim_modal_entails'[OF elim_modal_fupd[OF inv_inG]])+
    apply (rule upred_entails_trans[OF _ fupd_intro[OF inv_inG, to_entailment]])
    apply (rule framing, log_prog_solver log_prog_rule: inv_inG)+
    apply (rule framing_emp, log_prog_solver)
    apply iris_simp
    apply (rule upred_entails_trans[OF _ fupd_intro[OF inv_inG, to_entailment]])
    apply iris_simp
    apply (iForallL \<sigma>2, iForallL "[]::observation list",iForallL \<kappa>s)
    apply iApply_wand
    apply (check_moveL "\<Turnstile>{?E1,?E2}=>?P", rule elim_modal_entails'[OF elim_modal_fupd[OF inv_inG]], iris_simp)
    apply (rule upred_entails_trans[OF upred_weakeningL])
    apply (subst reducible_def)
    apply iPureL using atomicE[OF assms, of \<sigma>1 \<kappa> e2 \<sigma>2 efs]
    by (auto simp: stuckness_to_atomicity_def irreducible_def)
  using atomicE[OF assms, of \<sigma>1 \<kappa> e2 \<sigma>2 efs]
  apply (auto simp: stuckness_to_atomicity_def dest!: to_val_cases)
  apply (iApply rule: upred_entail_eqL[OF wp_value_fupd])
  apply (rule elim_modal_entails'[OF elim_modal_fupd[OF inv_inG]], rule fupd_frame_mono[OF inv_inG])
  apply (move_sepR "wp ?m ?E ?e ?p", entails_substR rule: wp_value)
  by iris_simp
  done done

lemma wp_bind: "wp s E e (\<lambda>v. wp s E (lang_ctxt K (of_val v)) P) \<turnstile> wp s E (lang_ctxt K e) P" sorry
lemma wp_bind': "wp s E e (\<lambda>v. wp s E (C (of_val v)) P) \<turnstile> wp s E (C e) P" sorry
lemma wp_bind_inv: "wp s E (lang_ctxt K e) P \<turnstile> wp s E e (\<lambda>v. wp s E (lang_ctxt K (of_val v)) P)" sorry
lemma wp_stuck_mono:
  assumes "s1 \<le> s2"
  shows "wp s1 E e P \<turnstile> wp s2 E e P"
  apply (entails_substL rule: wp_strong_monoI[OF assms subset_refl, where ?Q = P])
  apply (entails_substL rule: upred_entails_trans[OF upred_wandL[OF upred_forall_mono[OF
      fupd_intro[OF inv_inG, simplified upred_holds_entails]]]])
  apply iris_simp
  by (rule upred_true_wand)

lemma wp_stuck_weaken: "wp s E e P \<turnstile> wp MaybeStuck E e P" using wp_stuck_mono[of s MaybeStuck] by simp
lemma wp_frame_simp: "wp s E e (\<lambda>v. Q v) \<^emph> P \<turnstile> wp s E e (\<lambda>v. Q v \<^emph> P)" sorry

lemma wp_frame_step:
assumes "HeapLang.to_val e = None" "E2\<subseteq>E1"
shows "(\<Turnstile>{E1}[E2]\<triangleright>=> Q) \<^emph> wp s E2 e (\<lambda>v. P v) \<turnstile> wp s E1 e (\<lambda>v. P v \<^emph> Q)"
  sorry

lemma wp_frame_step':
assumes "HeapLang.to_val e = None"
shows "(\<triangleright>Q) \<^emph> wp s E e (\<lambda>v. P v) \<turnstile> wp s E e (\<lambda>v. P v \<^emph> Q)"
  sorry

lemma wp_lift_step_fupdN:
assumes "HeapLang.to_val e1 = None"
shows "(\<forall>\<^sub>u \<sigma>1 \<kappa> \<kappa>s. ((state_interp \<sigma>1 (\<kappa>@\<kappa>s)) ={E,Set.empty}=\<^emph>
  ((\<upharpoonleft>(case s of NotStuck \<Rightarrow> red e1 \<sigma>1 | _ \<Rightarrow> True)) \<^emph>
  (\<forall>\<^sub>u e2 \<sigma>2 efs. ((\<upharpoonleft>(prim_step e1 \<sigma>1 \<kappa> e2 \<sigma>2 efs)) ={Set.empty}\<triangleright>=\<^emph>
    (\<Turnstile>{Set.empty,E}=> ((state_interp \<sigma>2 \<kappa>s) \<^emph>
      (wp s E e2 \<Phi>) \<^emph> ([\<^emph>\<^sub>l:] efs (\<lambda>ef. wp s UNIV ef (\<lambda>_. upred_emp))))))))))
   \<turnstile> wp s E e1 \<Phi>" sorry

lemma wp_pure': "\<lbrakk>pure_exec b n e1 e2; b; P \<turnstile> wp s E (fill K e2) Q\<rbrakk> \<Longrightarrow>
  P \<turnstile> wp s E (fill K e1) Q" sorry

lemma wp_pure: "\<lbrakk>pure_exec b n e1 e2; b; P \<turnstile> wp s E e2 Q\<rbrakk> \<Longrightarrow>
  P \<turnstile> wp s E e1 Q" by (rule wp_pure'[where K = "[]", unfolded fill_def, simplified])

lemma wp_pure_step_later: "\<lbrakk>pure_exec b n e1 e2; b\<rbrakk> \<Longrightarrow>
  (upred_later^^n) (wp s E e2 \<Phi>) \<turnstile> wp s E e1 \<Phi>"
sorry

lemma wp_let_bind: "Q \<turnstile> wp s E e (\<lambda>v. wp s E (let: x := (of_val v) in e2 endlet) P) \<Longrightarrow>
  Q \<turnstile> wp s E (let: x := e in e2 endlet) P" sorry (* Would follow from wp_bind *)

lemma wp_let_bind': "Q \<turnstile> wp s E e (\<lambda>v. wp s E (let: x := C (of_val v) in e2 endlet) P) \<Longrightarrow>
  Q \<turnstile> wp s E (let: x := C e in e2 endlet) P" sorry

lemma elim_modal_fupd_wp_atomic: "atomic (stuckness_to_atomicity s) e \<Longrightarrow>
  elim_modal (\<Turnstile>{E1,E2}=>P) P (wp s E1 e Q) (wp s E2 e (\<lambda>v. \<Turnstile>{E2,E1}=> Q v))"
  unfolding elim_modal_def
  apply (entails_substL rule: upred_wand_holdsE[OF fupd_frame_r[OF inv_inG]])
  apply (entails_substL rule: fupd_mono[OF inv_inG upred_wand_apply])
  by (rule wp_atomic, assumption)

lemma wp_is_except_zero [iez_rule,log_prog_rule]: "is_except_zero (wp s E e P)"
  unfolding is_except_zero_def
  apply (rule upred_entails_trans[OF _ fupd_wp])
  apply (rule upred_entails_trans[OF _ is_except_zero_fupd[OF inv_inG, unfolded is_except_zero_def]])
  by (auto intro: upred_entails_trans[OF _ except_zero_mono[OF upred_wand_holdsE[OF fupd_intro[OF inv_inG]]]])

lemma wp_load: "P \<^emph> (l\<mapsto>{p}v) \<turnstile> Q v \<Longrightarrow> P \<^emph> (l\<mapsto>{p}v) \<turnstile> wp s E (Load #[l]) Q"
  sorry

lemma wp_pure_let: "\<lbrakk>pure_exec b n e1 (Val v); b; P \<turnstile> wp s E (subst' x v e2) Q\<rbrakk> \<Longrightarrow>
  P \<turnstile> wp s E (let: x := e1 in e2 endlet) Q"
  sorry

lemma wp_cmpxchg_fail: "\<lbrakk>v\<noteq>v1; vals_compare_safe v v1; P \<^emph> (l\<mapsto>{p}v) \<turnstile> wp s E (#[(v,False)]) Q\<rbrakk>
  \<Longrightarrow> P \<^emph> (l\<mapsto>{p}v) \<turnstile> wp s E (CmpXchg (Val #[l]) v1 v2) Q"
  sorry

lemma wp_cmpxchg_success: "\<lbrakk>v=v1; vals_compare_safe v v1; P \<^emph> (l\<mapsto>{p}v2) \<turnstile> wp s E (#[(v,True)]) Q\<rbrakk>
  \<Longrightarrow> P \<^emph> (l\<mapsto>{p}v) \<turnstile> wp s E (CmpXchg (Val #[l]) v1 v2) Q"
  sorry

lemma wp_alloc: "wp s E (Alloc (Val v)) (\<lambda>lv. (\<exists>\<^sub>u l. ((\<upharpoonleft>(lv=#[l])) \<^emph> (l\<mapsto>\<^sub>uv))))"
sorry

lemma wp_alloc': "(\<And>l. P\<^emph>(l\<mapsto>\<^sub>uv) \<turnstile> wp s E #[l] \<Phi>) \<Longrightarrow> P \<turnstile> wp s E (Alloc (Val v)) \<Phi>"
sorry

lemma wp_store_texan: "{{{ \<triangleright>(l\<mapsto>\<^sub>uv') }}} #[l] \<leftarrow> (Val v) @ s; E {{{ \<lambda>_. l\<mapsto>\<^sub>u v }}}"
sorry

lemma wp_store: "\<triangleright>(l\<mapsto>\<^sub>uv') \<turnstile> wp s E (Store #[l] v) (\<lambda>_. l\<mapsto>\<^sub>uv)"
  by (rule upred_wandE[OF upred_entails_trans[OF wp_store_texan[to_entailment] texan_to_wp], unfolded emp_rule])

lemma wp_store':
  assumes "P\<^emph>(l\<mapsto>\<^sub>uv) \<turnstile> \<triangleright>wp s E (#[()]) \<Phi>"
  shows "P\<^emph>(l\<mapsto>\<^sub>uv') \<turnstile> wp s E (Store #[l] v) \<Phi>"
proof -
  have aux: "((\<upharpoonleft>(\<kappa>=[]))-\<^emph> Q UnitE (state_upd_heap (fmupd l (Some v)) \<sigma>1) []) \<turnstile>
    (\<forall>\<^sub>ue2 \<sigma>2 efs. ((\<upharpoonleft>(\<kappa> = [] \<and> e2 = UnitE \<and> \<sigma>2 = state_upd_heap (fmupd l (Some v)) \<sigma>1 \<and> efs = [])) -\<^emph> (Q e2 \<sigma>2 efs)))"
    for \<kappa> Q \<sigma>1 apply iForallR+ apply (rule upred_wandI) apply iPureL by (simp add: upred_true_wand)
  have aux2: "Q \<turnstile> R \<^emph> S \<Longrightarrow> Q \<turnstile> R \<^emph> \<Turnstile>{E,{}}=>\<Turnstile>{{},E}=>S" for Q R S :: "'res upred_f"
    by (meson empty_subsetI fupd_mask_intro_subseteq[OF inv_inG] upred_entails_substI)
  have aux3: "\<Rrightarrow>\<^sub>b (heap_interp put_heap (heap (state_upd_heap (fmupd l (Some v)) \<sigma>1)) \<^emph> (l\<mapsto>\<^sub>uv))" for \<sigma>1
    unfolding upred_holds_entails heap_interp_def[OF heap_inG] points_to_def[OF heap_inG]
    own_heap_auth_def[OF heap_inG]
    apply (rule upred_entails_trans[OF _ upd_mono[OF upred_entail_eqL[OF inG.own_op[OF heap_inG]]]])
    apply (rule inG.own_alloc[OF heap_inG, to_entailment])
    by (auto simp: valid_def constr_heap_def prod_n_valid_def \<epsilon>_n_valid map_view_auth_def map_view_frag_def
      view_both_valid map_view_rel_def valid_dfrac_own[unfolded valid_def] d_equiv state_upd_heap_def
      op_prod_def \<epsilon>_left_id)
  show ?thesis
  apply (entails_substR rule: upred_entail_eqR[OF wp_unfold])
  apply (auto simp: wp_pre.rep_eq)
  apply iForallR+
  apply (rule upred_wandI)
  unfolding state_interp_def[OF prophm_inG heap_inG]
  apply (iApply rule: points_to_lookup[OF heap_inG])
  apply iPureL
  apply (frule store_red[where ?v=v])
  apply (cases s, auto, iris_simp)
  subgoal for \<sigma>1 \<kappa> \<kappa>s
    unfolding prim_step_store apply simp
    apply (entails_substR rule: fupd_mono[OF inv_inG aux])
    apply (cases "\<kappa>=[]", iris_simp iris_simp: state_upd_proph)
    prefer 2
    apply (metis (no_types, opaque_lifting) add_holds empty_subsetI fupd_mask_subseteq inv_inG fupd_mono upred_emp_entailed upred_entails_trans upred_true_sep')
    apply (entails_substR rule: fupd_mono[OF inv_inG upred_true_wand'])
    apply (rule add_holds[OF aux3])
    apply (check_moveL "\<Rrightarrow>\<^sub>b ?P", rule elim_modal_entails'[OF elim_modal_upd[OF inv_inG]])
    apply (rule upred_entails_trans[OF _ fupd_mono[OF inv_inG fupd_intro[OF inv_inG, to_entailment]]])
    apply (rule upred_entails_trans[OF _ frameE[where ?Q = "\<triangleright>wp NotStuck E UnitE \<Phi>"]])
    prefer 2
    apply (rule fupd_frameR[OF inv_inG])+ apply (rule frame_later)
    apply (rule fupd_frameR[OF inv_inG])+ apply (rule frame_rev, rule frame_refl)
    apply (rule upred_entails_substI[OF fupd_mono[OF inv_inG fupd_intro[OF inv_inG, to_entailment]]])
    apply (rule aux2)
    apply (move_sepR "\<triangleright>?p")
    apply (move_sepR "proph_map_interp ?put \<kappa>s ?p")
    apply iFrame_single
    apply (iDrop "heap_interp ?put (heap \<sigma>1)")
    apply (iDrop "l\<mapsto>\<^sub>uv'")
    apply (iApply rule: assms)
    by iFrame_single+
  subgoal for \<sigma>1 \<kappa> \<kappa>s
  unfolding prim_step_store apply simp
  apply (entails_substR rule: fupd_mono[OF inv_inG aux])
  apply (cases "\<kappa>=[]", iris_simp iris_simp: state_upd_proph)
  prefer 2
  apply (metis (no_types, opaque_lifting) inv_inG add_holds empty_subsetI fupd_mask_subseteq fupd_mono upred_emp_entailed upred_entails_trans upred_true_sep')
  apply (entails_substR rule: fupd_mono[OF inv_inG upred_true_wand'])
  apply (rule add_holds[OF aux3])
  apply (check_moveL "\<Rrightarrow>\<^sub>b ?P", rule elim_modal_entails'[OF elim_modal_upd[OF inv_inG]])
  apply (rule upred_entails_trans[OF _ fupd_mono[OF inv_inG fupd_intro[OF inv_inG, to_entailment]]])
  apply (rule upred_entails_trans[OF _ frameE[where ?Q = "\<triangleright>wp MaybeStuck E UnitE \<Phi>"]])
  prefer 2
  apply (rule fupd_frameR[OF inv_inG])+ apply (rule frame_later)
  apply (rule fupd_frameR[OF inv_inG])+ apply (rule frame_rev, rule frame_refl)
  apply (rule upred_entails_substI[OF fupd_mono[OF inv_inG fupd_intro[OF inv_inG, to_entailment]]])
  apply (rule aux2)
  apply (move_sepR "\<triangleright>?p")
  apply (move_sepR "proph_map_interp ?put \<kappa>s ?p")
  apply iFrame_single
  apply (iDrop "heap_interp ?put (heap \<sigma>1)")
  apply (iDrop "l\<mapsto>\<^sub>uv'")
  apply (iApply rule: assms)
  by iFrame_single+
  done
qed

lemma wp_frame': "(\<And>x. can_be_split (Q x) (Q' x) P) \<Longrightarrow> (wp s E e Q') \<^emph> P \<turnstile> wp s E e Q"
sorry

lemma wp_frame [frame_rule,log_prog_rule]: "(\<And>x. frame (P x) (Q x) R) \<Longrightarrow> frame (wp s E e P) (wp s E e Q) R"
  unfolding frame_def by (smt (verit) upred_entails_trans wp_frame_simp wp_mono)
end

text \<open>Because fupds often appear with schematic variables which make matching difficult, we just
  try the different elimination methods.\<close>

method fupd_elimL =
  check_moveL "fancy_upd ?p ?E1 ?E2 ?P",
    (rule elim_modal_entails'[OF elim_modal_fupd[OF inv_inG_axiom]]
    | rule fupd_mono[OF inv_inG_axiom] | rule elim_modal_entails[OF elim_modal_fupd[OF inv_inG_axiom]]
    | (rule elim_modal_entails[OF elim_modal_fupd_wp_atomic[OF inv_inG_axiom heap_inG_axiom proph_inG_axiom]],
        log_prog_solver)
    | (rule elim_modal_entails'[OF elim_modal_fupd_wp_atomic[OF inv_inG_axiom heap_inG_axiom proph_inG_axiom]],
        log_prog_solver));
  iris_simp

method iMod uses rule = iMod_raw fupd_elimL rule: rule
method iMod_wand for lhs_pat pat :: "'a::ucamera upred_f" =
  iMod_raw_wand lhs_pat pat later_elim fupd_elimL
method iMod_step for pat :: "'a::ucamera upred_f" uses rule =
  iMod_raw_step pat later_elim fupd_elimL rule: rule

method lift_modL for trm :: "'res::ucamera upred_f" methods m =
  match (trm) in "fancy_upd _ _ _ P" for P :: "'res upred_f" \<Rightarrow>
    \<open>apply_prefer \<open>entails_substL rule: fupd_mono[OF inv_inG_axiom]\<close>, lift_modL P m\<close>
  \<bar> "wp _ _ _ _ _ _ (\<lambda>x. Q x)" for Q :: "val \<Rightarrow> 'res upred_f" \<Rightarrow>
    \<open>apply_prefer \<open>entails_substL rule: wp_mono\<close>, lift_modL "Q v" m\<close>
  \<bar> "_" \<Rightarrow> \<open>rule upred_entails_trans, m, (rule upred_entails_refl)?\<close>

method lift_splitL for pat :: "'res::ucamera upred_f" =
  match conclusion in "hyps\<turnstile>_" for hyps :: "'res upred_f" \<Rightarrow>
    \<open>lift_modL hyps \<open>rule upred_entail_eqL[OF can_be_splitE], split_pat pat\<close>\<close>,
  (check_not_headL upred_emp) (* If splitting has not found any of the terms in the pattern*)

method lift_frame for pat :: "'res::ucamera upred_f" =
 rule upred_entails_trans[OF _ frameE], apply_first \<open>split_pat pat\<close>

method iFrame for pat :: "'res::ucamera upred_f" =
  iris_simp, lift_splitL pat, lift_frame pat, iris_simp, move_sep_all_both pat,
  (rule upred_frame upred_emp_left | rule upred_entails_refl | rule upred_weakeningR)+, iris_simp

method frame_single =
  rule upred_entails_refl | rule upred_weakeningR | rule upred_weakeningL
| (rule framing, log_prog_solver)
| (rule framing_emp, log_prog_solver)

method frame_logic_programming for pat :: "'res::ucamera upred_f" =
  match (pat) in "rest\<^emph>_" for rest :: "'res upred_f" \<Rightarrow> \<open>frame_single, (frame_logic_programming rest)?\<close>
  \<bar> _ \<Rightarrow> \<open>frame_single\<close>

method iFrame2 for pat :: "'res::ucamera upred_f" =
  iris_simp, split_move pat, frame_logic_programming pat, iris_simp

method iFrame3 for pat :: "'res::ucamera upred_f" =
  iris_simp, split_move_ord pat, frame_logic_programming pat, iris_simp

method iWP uses rule = iris_simp,
  ((entails_substR rule: fupd_intro[OF inv_inG_axiom] | entails_substR rule: upred_laterI
    | entails_substR rule: except_zeroI | entails_substR rule: updI)+)?,
  iApply rule: rule[OF inv_inG_axiom heap_inG_axiom proph_inG_axiom, simplified], iris_simp
end


(*
 * Copyright 2022, Proofcraft Pty Ltd
 *
 * SPDX-License-Identifier: GPL-2.0-only
 *)

chapter "Platform Definitions"

theory Platform
imports
  "Lib.Lib"
  "Word_Lib.WordSetup"
  "Lib.Defs"
  Setup_Locale
  Kernel_Config
begin

context Arch begin global_naming AARCH64

type_synonym irq_len = 9 (* match IRQ_CNODE_SLOT_BITS in seL4 config *)
type_synonym irq = "irq_len word"
type_synonym paddr = machine_word

abbreviation (input) "toPAddr \<equiv> id"
abbreviation (input) "fromPAddr \<equiv> id"

(* For address space layout with hypervisor enabled see:
   seL4/include/arch/arm/arch/64/mode/hardware.h
   FIXME AARCH64 include diagram here after C revisions are done
*)

(* NOTE: a number of these constants appear in the Haskell, but are shadowed
   here due to more convenient formulation.
   Examples: kernelELFBase, kernelELFBaseOffset, kernelELFAddressBase, pptrBase
   Ideally and in future, we should converge on a single authoritative source
   of these constants.
*)

(* The canonical bit is the highest bit that can be set in a virtual address and still accepted
   by the hardware. Any bit higher than that will be overwritten by sign extension, zero extension,
   or result in a fault.
   For AArch64 with hyp, addresses >= 2^48 are invalid, and sign-extension is not used by the
   hardware. *)
definition canonical_bit :: nat where
  "canonical_bit = 47"

definition kdevBase :: machine_word where
  "kdevBase = 0x000000FFFFE00000"

definition kernelELFBase :: machine_word where
  "kernelELFBase = 2^39 + physBase"

definition kernelELFPAddrBase :: machine_word where
  "kernelELFPAddrBase = physBase"

definition kernelELFBaseOffset :: machine_word where
  "kernelELFBaseOffset = kernelELFBase - kernelELFPAddrBase"

definition pptrBase :: machine_word where
  "pptrBase = 0x8000000000" (* 2^39 *)

definition pptrUserTop :: machine_word where
  "pptrUserTop \<equiv> mask (if config_ARM_PA_SIZE_BITS_40 then 40 else 44)"

lemma "pptrUserTop = (if config_ARM_PA_SIZE_BITS_40 then 0xFFFFFFFFFF else 0xFFFFFFFFFFF)" (* Sanity check with C *)
  by (simp add: pptrUserTop_def mask_def)

definition pptrTop :: machine_word where
  "pptrTop = 2^40 - 2^30" (* FIXME AARCH64: see also seL4/seL4#957 *)

definition paddrBase :: machine_word where
  "paddrBase \<equiv> 0"

definition pptrBaseOffset :: machine_word where
  "pptrBaseOffset = pptrBase - paddrBase"

definition paddrTop :: machine_word where
  "paddrTop = pptrTop - pptrBaseOffset"

definition ptrFromPAddr :: "paddr \<Rightarrow> machine_word" where
  "ptrFromPAddr paddr \<equiv> paddr + pptrBaseOffset"

definition addrFromPPtr :: "machine_word \<Rightarrow> paddr" where
  "addrFromPPtr pptr \<equiv> pptr - pptrBaseOffset"

definition addrFromKPPtr :: "machine_word \<Rightarrow> paddr" where
  "addrFromKPPtr pptr \<equiv> pptr - kernelELFBaseOffset"

definition minIRQ :: "irq" where
  "minIRQ \<equiv> 0"

definition maxIRQ :: "irq" where
  "maxIRQ \<equiv> 383"

definition irqVGICMaintenance :: irq where
  "irqVGICMaintenance \<equiv> 25"

definition irqVTimerEvent :: irq where
  "irqVTimerEvent \<equiv> 27"

definition pageColourBits :: nat where
  "pageColourBits \<equiv> undefined" \<comment> \<open>not implemented on this platform\<close>

end
end