Require Import CodeProofDeps.
Require Import Ident.
Require Import Constants.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RmiAux.Layer.
Require Import RmiAux2.Code.rec_granule_measure.

Require Import RmiAux2.LowSpecs.rec_granule_measure.

Local Open Scope Z_scope.

Section CodeProof.

  Context `{real_params: RealParams}.
  Context {memb} `{Hmemx: Mem.MemoryModelX memb}.
  Context `{Hmwd: UseMemWithData memb}.

  Let mem := mwd (cdata RData).

  Context `{Hstencil: Stencil}.
  Context `{make_program_ops: !MakeProgramOps Clight.function type Clight.fundef type}.
  Context `{Hmake_program: !MakeProgram Clight.function type Clight.fundef type}.

  Let L : compatlayer (cdata RData) :=
    _measurement_extend_rec_header ↦ gensem measurement_extend_rec_header_spec
      ⊕ _measurement_extend_rec_regs ↦ gensem measurement_extend_rec_regs_spec
      ⊕ _measurement_extend_rec_pstate ↦ gensem measurement_extend_rec_pstate_spec
      ⊕ _measurement_extend_rec_sysregs ↦ gensem measurement_extend_rec_sysregs_spec
  .

  Local Instance: ExternalCallsOps mem := CompatExternalCalls.compatlayer_extcall_ops L.
  Local Instance: CompilerConfigOps mem := CompatExternalCalls.compatlayer_compiler_config_ops L.

  Section BodyProof.

    Context `{Hwb: WritableBlockOps}.
    Variable (sc: stencil).
    Variables (ge: genv) (STENCIL_MATCHES: stencil_matches sc ge).

    Variable b_measurement_extend_rec_header: block.
    Hypothesis h_measurement_extend_rec_header_s : Genv.find_symbol ge _measurement_extend_rec_header = Some b_measurement_extend_rec_header.
    Hypothesis h_measurement_extend_rec_header_p : Genv.find_funct_ptr ge b_measurement_extend_rec_header
                                                   = Some (External (EF_external _measurement_extend_rec_header
                                                                    (signature_of_type (Tcons Tptr (Tcons Tptr Tnil)) tvoid cc_default))
                                                          (Tcons Tptr (Tcons Tptr Tnil)) tvoid cc_default).
    Local Opaque measurement_extend_rec_header_spec.

    Variable b_measurement_extend_rec_regs: block.
    Hypothesis h_measurement_extend_rec_regs_s : Genv.find_symbol ge _measurement_extend_rec_regs = Some b_measurement_extend_rec_regs.
    Hypothesis h_measurement_extend_rec_regs_p : Genv.find_funct_ptr ge b_measurement_extend_rec_regs
                                                 = Some (External (EF_external _measurement_extend_rec_regs
                                                                  (signature_of_type (Tcons Tptr (Tcons Tptr Tnil)) tvoid cc_default))
                                                        (Tcons Tptr (Tcons Tptr Tnil)) tvoid cc_default).
    Local Opaque measurement_extend_rec_regs_spec.

    Variable b_measurement_extend_rec_pstate: block.
    Hypothesis h_measurement_extend_rec_pstate_s : Genv.find_symbol ge _measurement_extend_rec_pstate = Some b_measurement_extend_rec_pstate.
    Hypothesis h_measurement_extend_rec_pstate_p : Genv.find_funct_ptr ge b_measurement_extend_rec_pstate
                                                   = Some (External (EF_external _measurement_extend_rec_pstate
                                                                    (signature_of_type (Tcons Tptr (Tcons Tptr Tnil)) tvoid cc_default))
                                                          (Tcons Tptr (Tcons Tptr Tnil)) tvoid cc_default).
    Local Opaque measurement_extend_rec_pstate_spec.

    Variable b_measurement_extend_rec_sysregs: block.
    Hypothesis h_measurement_extend_rec_sysregs_s : Genv.find_symbol ge _measurement_extend_rec_sysregs = Some b_measurement_extend_rec_sysregs.
    Hypothesis h_measurement_extend_rec_sysregs_p : Genv.find_funct_ptr ge b_measurement_extend_rec_sysregs
                                                    = Some (External (EF_external _measurement_extend_rec_sysregs
                                                                     (signature_of_type (Tcons Tptr (Tcons Tptr Tnil)) tvoid cc_default))
                                                           (Tcons Tptr (Tcons Tptr Tnil)) tvoid cc_default).
    Local Opaque measurement_extend_rec_sysregs_spec.

    Lemma rec_granule_measure_body_correct:
      forall m d d' env le rd_base rd_offset rec_base rec_offset data_size
             (Henv: env = PTree.empty _)
             (Hinv: high_level_invariant d)
             (HPTrd: PTree.get _rd le = Some (Vptr rd_base (Int.repr rd_offset)))
             (HPTrec: PTree.get _rec le = Some (Vptr rec_base (Int.repr rec_offset)))
             (HPTdata_size: PTree.get _data_size le = Some (Vlong data_size))
             (Hspec: rec_granule_measure_spec0 (rd_base, rd_offset) (rec_base, rec_offset) (VZ64 (Int64.unsigned data_size)) d = Some d'),
           exists le', (exec_stmt ge env le ((m, d): mem) rec_granule_measure_body E0 le' (m, d') Out_normal).
    Proof.
      solve_code_proof Hspec rec_granule_measure_body; eexists; solve_proof_low.
    Qed.

  End BodyProof.

End CodeProof.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.
Require Import RunComplete.Spec.
Require Import RunAux.Spec.
Require Import RunLoop.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition smc_rec_run_spec0 (rec_addr: Z64) (rec_run_addr: Z64) (adt: RData) : option (RData * Z64) :=
    match rec_addr, rec_run_addr with
    | VZ64 _rec_addr, VZ64 _rec_run_addr =>
      rely is_int64 _rec_run_addr;
      when'' _g_rec_run_base, _g_rec_run_ofst == find_granule_spec (VZ64 _rec_run_addr) adt;
      rely is_int _g_rec_run_ofst;
      when _t'8 == is_null_spec (_g_rec_run_base, _g_rec_run_ofst) adt;
      rely is_int _t'8;
      if (_t'8 =? 1) then
        Some (adt, (VZ64 1))
      else
        rely is_int64 _rec_addr;
        when'' _g_rec_base, _g_rec_ofst, adt == find_lock_unused_granule_spec (VZ64 _rec_addr) (VZ64 3) adt;
        rely is_int _g_rec_ofst;
        when _t'7 == is_null_spec (_g_rec_base, _g_rec_ofst) adt;
        rely is_int _t'7;
        if (_t'7 =? 1) then
          Some (adt, (VZ64 1))
        else
          when adt == atomic_granule_get_spec (_g_rec_base, _g_rec_ofst) adt;
          when adt == granule_unlock_spec (_g_rec_base, _g_rec_ofst) adt;
          when adt == ns_granule_map_spec 0 (_g_rec_run_base, _g_rec_run_ofst) adt;
          when _t'6, adt == ns_buffer_read_rec_run_spec 0 adt;
          rely is_int _t'6;
          if (_t'6 =? 0) then
            when adt == ns_buffer_unmap_spec 0 adt;
            when adt == atomic_granule_put_release_spec (_g_rec_base, _g_rec_ofst) adt;
            Some (adt, (VZ64 1))
          else
            when'' _rec_base, _rec_ofst, adt == granule_map_spec (_g_rec_base, _g_rec_ofst) 3 adt;
            rely is_int _rec_ofst;
            when adt == granule_lock_spec (_g_rec_base, _g_rec_ofst) adt;
            when _t'5 == get_rec_runnable_spec (_rec_base, _rec_ofst) adt;
            rely is_int _t'5;
            if (_t'5 =? 0) then
              when adt == granule_unlock_spec (_g_rec_base, _g_rec_ofst) adt;
              when adt == buffer_unmap_spec (_rec_base, _rec_ofst) adt;
              when adt == ns_buffer_unmap_spec 0 adt;
              when adt == atomic_granule_put_release_spec (_g_rec_base, _g_rec_ofst) adt;
              Some (adt, (VZ64 1))
            else
              when _t'4, adt == complete_mmio_emulation_spec (_rec_base, _rec_ofst) adt;
              rely is_int _t'4;
              if (_t'4 =? 0) then
                when adt == granule_unlock_spec (_g_rec_base, _g_rec_ofst) adt;
                when adt == buffer_unmap_spec (_rec_base, _rec_ofst) adt;
                when adt == ns_buffer_unmap_spec 0 adt;
                when adt == atomic_granule_put_release_spec (_g_rec_base, _g_rec_ofst) adt;
                Some (adt, (VZ64 1))
              else
                when adt == complete_hvc_exit_spec (_rec_base, _rec_ofst) adt;
                when adt == reset_last_run_info_spec (_rec_base, _rec_ofst) adt;
                when adt == reset_disposed_info_spec (_rec_base, _rec_ofst) adt;
                when adt == granule_unlock_spec (_g_rec_base, _g_rec_ofst) adt;
                when adt == rec_run_loop_spec (_rec_base, _rec_ofst) adt;
                Some (adt, (VZ64 2))
     end
    .

End SpecLow.


Require Import Platform.AutoSep Platform.Malloc Platform.tests.Echo Platform.Bootstrap.

Module Type S.
  Variable heapSize : nat.
End S.

Module Make(M : S).
Import M.

Section boot.
  Hypothesis heapSizeLowerBound : (3 <= heapSize)%nat.

  Definition size := heapSize + 50 + 0.

  Hypothesis mem_size : goodSize (size * 4)%nat.

  Let heapSizeUpperBound : goodSize (heapSize * 4).
    goodSize.
  Qed.

  Definition bootS := bootS heapSize 0.

  Definition boot := bimport [[ "malloc"!"init" @ [Malloc.initS], "test"!"main" @ [Echo.mainS] ]]
    bmodule "main" {{
      bfunctionNoRet "main"() [bootS]
        Sp <- (heapSize * 4)%nat;;

        Assert [PREonly[_] 0 =?> heapSize];;

        Call "malloc"!"init"(0, heapSize)
        [PREonly[_] mallocHeap 0];;

        Call "test"!"main"()
        [PREonly[_] [| False |] ]
      end
    }}.

  Theorem ok : moduleOk boot.
    vcgen; abstract genesis.
  Qed.

  Definition m0 := link Malloc.m boot.
  Definition m1 := link Echo.m m0.

  Lemma ok0 : moduleOk m0.
    link Malloc.ok ok.
  Qed.

  Lemma ok1 : moduleOk m1.
    link Echo.ok ok0.
  Qed.

  Variable stn : settings.
  Variable prog : program.

  Hypothesis inj : forall l1 l2 w, Labels stn l1 = Some w
    -> Labels stn l2 = Some w
    -> l1 = l2.

  Hypothesis agree : forall l pre bl,
    LabelMap.MapsTo l (pre, bl) (XCAP.Blocks m1)
    -> exists w, Labels stn l = Some w
      /\ prog w = Some bl.

  Hypothesis agreeImp : forall l pre, LabelMap.MapsTo l pre (XCAP.Imports m1)
    -> exists w, Labels stn l = Some w
      /\ prog w = None.

  Hypothesis omitImp : forall l w,
    Labels stn ("sys", l) = Some w
    -> prog w = None.

  Variable w : W.
  Hypothesis at_start : Labels stn ("main", Global "main") = Some w.

  Variable st : state.

  Hypothesis mem_low : forall n, (n < size * 4)%nat -> st.(Mem) n <> None.
  Hypothesis mem_high : forall w, $ (size * 4) <= w -> st.(Mem) w = None.

  Theorem safe : sys_safe stn prog (w, st).
    safety ok1.
  Qed.
End boot.

End Make.


(* *********************************************************************)
(*                                                                     *)
(*            The CertiKOS Certified Kit Operating System              *)
(*                                                                     *)
(*                   The FLINT Group, Yale University                  *)
(*                                                                     *)
(*  Copyright The FLINT Group, Yale University.  All rights reserved.  *)
(*  This file is distributed under the terms of the Yale University    *)
(*  Non-Commercial License Agreement.                                  *)
(*                                                                     *)
(* *********************************************************************)
(* *********************************************************************)
(*                                                                     *)
(*              Layers of VMM: Refinement Proof for MPTNew             *)
(*                                                                     *)
(*          Ronghui Gu <ronghui.gu@yale.edu>                           *)
(*                                                                     *)
(*          Yale Flint Group                                           *)
(*                                                                     *)
(* *********************************************************************)

(** This file provide the contextual refinement proof between MPTBit layer and MPTNew layer*)
Require Import Coqlib.
Require Import Errors.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Op.
Require Import Asm.
Require Import Events.
Require Import Globalenvs.
Require Import Smallstep.
Require Import Values.
Require Import Memory.
Require Import Maps.
Require Import CommonTactic.
Require Import AuxLemma.
Require Import FlatMemory.
Require Import AuxStateDataType.
Require Import Constant.
Require Import GlobIdent.
Require Import RealParams.
Require Import LoadStoreSem2.
Require Import AsmImplLemma.
Require Import GenSem.
Require Import RefinementTactic.
Require Import PrimSemantics.
Require Import XOmega.

Require Import liblayers.logic.PTreeModules.
Require Import liblayers.logic.LayerLogicImpl.
Require Import liblayers.compcertx.Stencil.
Require Import liblayers.compcertx.MakeProgram.
Require Import liblayers.compat.CompatLayers.
Require Import liblayers.compat.CompatGenSem.
Require Import compcert.cfrontend.Ctypes.

Require Import MPTNew.
Require Import AbstractDataType.

Require Import PTNewGenSpec.
Require Import LayerCalculusLemma.

Require Import ObjFlatMem.
Require Import ObjLMM0.
Require Import ObjLMM1.
Require Import ObjContainer.
Require Import ObjCPU.
Require Import ObjVMMFun.
Require Import ObjVMMGetSet.

(** * Notation of the refinement relation*)
Section Refinement.

  Local Open Scope string_scope.
  Local Open Scope error_monad_scope.
  Local Open Scope Z_scope.

  Context `{real_params: RealParams}.

  Notation HDATA := RData.
  Notation LDATA := RData.

  Notation HDATAOps := (cdata (cdata_ops := mptinit_data_ops) HDATA).
  Notation LDATAOps := (cdata (cdata_ops := mptinit_data_ops) LDATA).

  Section WITHMEM.

    Context `{Hstencil: Stencil}.
    Context `{Hmem: Mem.MemoryModel}.
    Context `{Hmwd: UseMemWithData mem}.

    (** Relation between raw data at two layers*)
    Record relate_RData (f: meminj) (hadt: LDATA) (ladt: LDATA) :=
      mkrelate_RData {
          flatmem_re: FlatMem.flatmem_inj (HP hadt) (HP ladt);
          vmxinfo_re: vmxinfo hadt = vmxinfo ladt;
          devout_re: devout hadt = devout ladt;
          ikern_re: ikern ladt = ikern hadt;
          pg_re: pg ladt = pg hadt;
          ihost_re: ihost ladt = ihost hadt;
          AC_re: AC ladt = AC hadt;
          ti_fst_re: (fst (ti ladt)) = (fst (ti hadt));
          ti_snd_re: val_inject f (snd (ti hadt)) (snd (ti ladt));
          LAT_re: LAT ladt = LAT hadt;
          nps_re: nps ladt = nps hadt;
          PT_re:  PT ladt = PT hadt;
          ptp_re: ptpool ladt = ptpool hadt;
          ipt_re: ipt ladt = ipt hadt;
          init_re: init ladt = init hadt;
          pperm_re: pperm ladt = pperm hadt;
          idpde_re: idpde ladt = idpde hadt

        }.

    Inductive match_RData: stencil -> HDATA -> mem -> meminj -> Prop :=
    | MATCH_RDATA: forall habd m f s, match_RData s habd m f.

    Local Hint Resolve MATCH_RDATA.

    Global Instance rel_ops: CompatRelOps HDATAOps LDATAOps :=
      {
        relate_AbData s f d1 d2 := relate_RData f d1 d2;
        match_AbData s d1 m f := match_RData s d1 m f;
        new_glbl := nil
      }.

    (** ** Properties of relations*)
    Section Rel_Property.

      (** Prove that after taking one step, the refinement relation still holds*)
      Lemma relate_incr:
        forall abd abd' f f',
          relate_RData f abd abd'
          -> inject_incr f f'
          -> relate_RData f' abd abd'.
      Proof.
        inversion 1; subst; intros; inv H; constructor; eauto.
      Qed.

      Lemma relate_kernel_mode:
        forall abd abd' f,
          relate_RData f abd abd'
          -> (kernel_mode abd <-> kernel_mode abd').
      Proof.
        inversion 1; simpl; split; congruence.
      Qed.

      Lemma relate_observe:
        forall p abd abd' f,
          relate_RData f abd abd' ->
          observe p abd = observe p abd'.
      Proof.
        inversion 1; simpl; unfold ObservationImpl.observe; congruence.
      Qed.

      Global Instance rel_prf: CompatRel HDATAOps LDATAOps.
      Proof.
        constructor; intros; simpl; trivial.
        eapply relate_incr; eauto.
        eapply relate_kernel_mode; eauto.
        eapply relate_observe; eauto.
      Qed.

    End Rel_Property.

    (** * Proofs the one-step forward simulations for the low level specifications*)
    Section OneStep_Forward_Relation.

      Section FRESH_PRIM.

        Lemma pt_new_spec_kernel_mode:
          forall d d' id q z,
            pt_new_spec id q d = Some (d', z) ->
            kernel_mode d.
        Proof.
          intros. simpl; functional inversion H; eauto.
        Qed.

        Lemma pt_new_spec_ref:
          compatsim (crel HDATA LDATA) (gensem pt_new_spec) pt_new_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit pt_new_exist; eauto 1.
          intros (labd' & HP & HM).
          exploit pt_new_spec_kernel_mode; eauto. intros.
          refine_split; try econstructor; eauto.
          constructor.
        Qed.

        Lemma ptResv_spec_kernel_mode:
          forall d d' i i0 i1 z,
            ptResv_spec i i0 i1 d = Some (d', z) ->
            kernel_mode d.
        Proof.
          intros. simpl; functional inversion H; eauto.
          - functional inversion H2; eauto.
          - functional inversion H1; eauto.
        Qed.

        Lemma ptResv_spec_ref:
          compatsim (crel HDATA LDATA) (gensem ptResv_spec) ptResv_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit ptResv_exist; eauto 1.
          intros (labd' & HP & HM).
          exploit ptResv_spec_kernel_mode; eauto. intros.
          refine_split; try econstructor; eauto. constructor.
        Qed.

        Lemma ptResv2_spec_kernel_mode:
          forall d d' i i0 i1 i2 i3 i4 z,
            ptResv2_spec i i0 i1 i2 i3 i4 d = Some (d', z) ->
            kernel_mode d.
        Proof.
          intros. simpl; functional inversion H; eauto.
          - functional inversion H2; eauto.
          - functional inversion H2; eauto.
          - functional inversion H1; eauto.
        Qed.

        Lemma ptResv2_spec_ref:
          compatsim (crel HDATA LDATA) (gensem ptResv2_spec) ptResv2_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit ptResv2_exist; eauto 1.
          intros (labd' & HP & HM).
          exploit ptResv2_spec_kernel_mode; eauto. intros.
          refine_split; try econstructor; eauto. constructor.
        Qed.

        Lemma pmap_init_spec_kernel_mode:
          forall d d' i,
            pmap_init_spec i d = Some d' ->
            kernel_mode d.
        Proof.
          intros. simpl; functional inversion H; eauto.
        Qed.

        Lemma pmap_init_spec_ref:
          compatsim (crel HDATA LDATA) (gensem pmap_init_spec) pmap_init_spec_low.
        Proof.
          compatsim_simpl (@match_AbData).
          exploit pmap_init_exist; eauto 1.
          intros (labd' & HP & HM).
          exploit pmap_init_spec_kernel_mode; eauto. intros.
          refine_split; try econstructor; eauto. constructor.
        Qed.

        (*Lemma pt_free_spec_ref:
        compatsim (crel HDATA LDATA) (gensem pt_free_spec) pt_free_spec_low.
      Proof.
        compatsim_simpl (@match_AbData).
        exploit pt_free_exist; eauto 1.
        intros [labd' [HP [HM Hkern]]].
        refine_split; try econstructor; eauto. constructor.
      Qed.*)

      End FRESH_PRIM.

      Section PASSTHROUGH_PRIM.

        Global Instance: (LoadStoreProp (hflatmem_store:= flatmem_store) (lflatmem_store:= flatmem_store)).
        Proof.
          accessor_prop_tac.
          - eapply flatmem_store_exists; eauto.
        Qed.

        Lemma passthrough_correct:
          sim (crel HDATA LDATA) mptnew_passthrough mptinit.
        Proof.
          sim_oplus.
          - apply fload_sim.
          - apply fstore_sim.
          - apply flatmem_copy_sim.
          - apply vmxinfo_get_sim.
          - apply device_output_sim.
          - apply pfree_sim.
          - apply setPT_sim.
          - apply ptRead_sim.
          - apply ptReadPDE_sim.
          - apply ptFreePDE0_sim.
          - apply ptRmv0_sim.
          - apply ptin_sim.
          - apply ptout_sim.
          - apply clearCR2_sim.
          - apply container_get_nchildren_sim.
          - apply container_get_quota_sim.
          - apply container_get_usage_sim.
          - apply container_can_consume_sim.
          - apply alloc_sim.
          - apply trapin_sim.
          - apply trapout_sim.
          - apply hostin_sim.
          - apply hostout_sim.
          - apply trap_info_get_sim.
          - apply trap_info_ret_sim.
          - layer_sim_simpl.
            + eapply load_correct2.
            + eapply store_correct2.
        Qed.

      End PASSTHROUGH_PRIM.

    End OneStep_Forward_Relation.

  End WITHMEM.

End Refinement.


Require Import ExtLib.Data.Sum.
Require Import ExtLib.Tactics.
Require Import MirrorCore.RTac.CoreK.

Require Import MirrorCore.Util.Forwardy.

Set Implicit Arguments.
Set Strict Implicit.

Section parameterized.
  Context {typ : Set}.
  Context {expr : Set}.
  Context {RType_typ : RType typ}.
  Context {RTypeOk_typ : RTypeOk}.
  Context {Typ0_Prop : Typ0 _ Prop}.
  Context {Expr_expr : Expr typ expr}.
  Context {ExprUVar_expr : ExprUVar expr}.

  Definition IDTACK : rtacK typ expr :=
    fun ctx sub gl => More_ sub gl.

  (** TODO: Move this **)
  Lemma rtacK_spec_More_
    : forall (ctx : Ctx typ expr) (s : ctx_subst ctx) g,
      rtacK_spec s g (More_ s g).
  Proof.
    red. intros. split; auto. split; auto.
    forward.
    split.
    - reflexivity.
    - intros. eapply Pure_pctxD; eauto.
  Qed.

  Theorem IDTACK_sound : rtacK_sound IDTACK.
  Proof.
    unfold IDTACK, rtacK_sound.
    intros; subst.
    eapply rtacK_spec_More_.
  Qed.

End parameterized.

Typeclasses Opaque IDTACK.
Hint Opaque IDTACK : typeclass_instances.

Arguments IDTACK {typ expr} _ _ _ : rename.


(** Refinement rules for disjoint rules *)
Require Import Coq.Lists.List.
Require Import Fiat.Parsers.Refinement.PreTactics.
Require Import Fiat.Computation.Refinements.General.
Require Import Fiat.Parsers.StringLike.Properties.
Require Import Fiat.Parsers.StringLike.LastCharSuchThat.
Require Import Fiat.Parsers.StringLike.LastChar.
Require Import Fiat.Common.
Require Import Fiat.Common.Equality.
Require Import Fiat.Common.List.Operations.
Require Import Fiat.Parsers.Splitters.RDPList.
Require Import Fiat.Parsers.BaseTypes.
Require Import Fiat.Parsers.ContextFreeGrammar.ValidReflective.
Require Import Fiat.Parsers.Refinement.DisjointLemmas.
Require Import Fiat.Parsers.ParserInterface.
Require Import Fiat.Parsers.StringLike.Core.
Require Import Fiat.Parsers.Refinement.PossibleTerminalsSets.

Set Implicit Arguments.

Local Arguments minus !_ !_.

Definition rev_search_for_condition
           {HSLM : StringLikeMin Ascii.ascii}
           {HSL : StringLike Ascii.ascii}
           (G : pregrammar' Ascii.ascii)
           {pdata : possible_data G}
           str nt (n : nat)
  := is_after_last_char_such_that
       str
       n
       (fun ch => char_in ch (possible_last_terminals_of G nt)).

Global Arguments rev_search_for_condition {_ _} G {_} _ _ _.

Lemma refine_disjoint_rev_search_for'
      {HSLM : StringLikeMin Ascii.ascii}
      {HSL : StringLike Ascii.ascii}
      {HSLP : StringLikeProperties Ascii.ascii}
      (G : pregrammar' Ascii.ascii)
      {apdata : all_possible_data G}
      {pdata : possible_data G}
      {str offset len nt its}
      (H_disjoint : disjoint
                      (possible_last_terminals_of G nt)
                      (possible_terminals_of_production G its))
: refine {splits : list nat
         | split_list_is_complete
             G str offset len
             (NonTerminal nt::its) splits}
         (n <- { n : nat | n <= length (substring offset len str)
                           /\ ((exists n', rev_search_for_condition G (substring offset len str) nt n')
                               -> rev_search_for_condition G (substring offset len str) nt n) };
          ret [n]).
Proof.
  intros ls H.
  computes_to_inv; subst.
  destruct H as [H0 H1].
  apply PickComputes.
  hnf; cbv zeta.
  intros Hlen it' its' Heq n ? H_reachable pit pits.
  inversion Heq; subst it' its'; clear Heq.
  left.
  pose proof (terminals_disjoint_rev_search_for _ H_disjoint pit pits) as H'.
  specialize (H1 (ex_intro _ n H')).
  unfold rev_search_for_condition in H1.
  pose proof (is_after_last_char_such_that_eq_nat_iff H1 H') as H''.
  destruct_head or; destruct_head and; subst;
  rewrite ?Min.min_r, ?Min.min_l by assumption;
  omega.
Qed.

Definition rev_search_for_not_condition
           {HSLM : StringLikeMin Ascii.ascii}
           {HSL : StringLike Ascii.ascii}
           (G : pregrammar' Ascii.ascii)
           {apdata : all_possible_data G}
           {pdata : possible_data G}
           str its n
  := is_after_last_char_such_that
       str
       n
       (fun ch => negb (char_in ch (possible_terminals_of_production G its))).

Global Arguments rev_search_for_not_condition {_ _} G {_ _} _ _ _.

Lemma refine_disjoint_rev_search_for_not'
      {HSLM : StringLikeMin Ascii.ascii}
      {HSL : StringLike Ascii.ascii}
      {HSLP : StringLikeProperties Ascii.ascii}
      {G : pregrammar' Ascii.ascii}
      {apdata : all_possible_data G}
      {pdata : possible_data G}
      {str offset len nt its}
      (H_disjoint : disjoint
                      (possible_last_terminals_of G nt)
                      (possible_terminals_of_production G its))
: refine {splits : list nat
         | split_list_is_complete
             G str offset len
             (NonTerminal nt::its)
             splits}
         (n <- { n : nat | n <= length (substring offset len str)
                           /\ ((exists n', rev_search_for_not_condition G (substring offset len str) its n')
                               -> rev_search_for_not_condition G (substring offset len str) its n) };
          ret [n]).
Proof.
  intros ls H.
  computes_to_inv; subst.
  destruct H as [H0 H1].
  apply PickComputes.
  hnf; cbv zeta.
  intros Hlen it' its' Heq n ? H_reachable pit pits.
  inversion Heq; subst it' its'; clear Heq.
  left.
  pose proof (terminals_disjoint_rev_search_for_not _ H_disjoint pit pits) as H'.
  specialize (H1 (ex_intro _ n H')).
  pose proof (is_after_last_char_such_that_eq_nat_iff H1 H') as H''.
  destruct_head or; destruct_head and; subst;
  rewrite ?Min.min_r by assumption;
  omega.
Qed.

Lemma find_after_last_char_such_that'_short {Char HSLM HSL}
      str P len
: @find_after_last_char_such_that' Char HSLM HSL P len str <= len.
Proof.
  revert str; induction len; simpl; intros; [ omega | ].
  destruct (get len str) eqn:H.
  { edestruct P; try omega.
    rewrite IHlen; omega. }
  { rewrite IHlen; omega. }
Qed.

Lemma find_after_last_char_such_that_short {Char HSLM HSL}
      str P
: @find_after_last_char_such_that Char HSLM HSL str P <= length str.
Proof.
  apply find_after_last_char_such_that'_short.
Qed.

Lemma refine_find_after_last_char_such_that {Char} {HSLM : StringLikeMin Char} {HSL : StringLike Char} {HSLP : StringLikeProperties Char}
      (str : String)
      (P : Char -> bool)
: refine { n : nat | n <= length str
                     /\ ((exists n', is_after_last_char_such_that str n' P)
                         -> is_after_last_char_such_that str n P) }
         (ret (find_after_last_char_such_that str P)).
Proof.
  intros v H.
  computes_to_inv; subst.
  apply PickComputes.
  split; [ apply find_after_last_char_such_that_short | ].
  apply is_after_last_char_such_that__find_after_last_char_such_that.
Qed.

Lemma refine_disjoint_rev_search_for
      {HSLM : StringLikeMin Ascii.ascii}
      {HSL : StringLike Ascii.ascii}
      {HSLP : StringLikeProperties Ascii.ascii}
      {G : pregrammar' Ascii.ascii}
      {apdata : all_possible_data G}
      {pdata : possible_data G}
      {str offset len nt its}
      (H_disjoint : disjoint
                      (possible_last_terminals_of G nt)
                      (possible_terminals_of_production G its))
: refine {splits : list nat
         | split_list_is_complete
             G str offset len
             (NonTerminal nt::its)
             splits}
         (ret [find_after_last_char_such_that (substring offset len str) (fun ch => char_in ch (possible_last_terminals_of G nt))]).
Proof.
  rewrite refine_disjoint_rev_search_for' by eassumption.
  setoid_rewrite refine_find_after_last_char_such_that.
  simplify with monad laws; reflexivity.
Qed.

Lemma refine_disjoint_rev_search_for_not
      {HSLM : StringLikeMin Ascii.ascii}
      {HSL : StringLike Ascii.ascii}
      {HSLP : StringLikeProperties Ascii.ascii}
      {G : pregrammar' Ascii.ascii}
      {apdata : all_possible_data G}
      {pdata : possible_data G}
      {str offset len nt its}
      (H_disjoint : disjoint
                      (possible_last_terminals_of G nt)
                      (possible_terminals_of_production G its))
: refine {splits : list nat
         | split_list_is_complete
             G str offset len
             (NonTerminal nt::its)
             splits}
         (ret [find_after_last_char_such_that (substring offset len str) (fun ch => negb (char_in ch (possible_terminals_of_production G its)))]).
Proof.
  rewrite refine_disjoint_rev_search_for_not' by assumption.
  setoid_rewrite refine_find_after_last_char_such_that.
  simplify with monad laws; reflexivity.
Qed.

Lemma refine_disjoint_rev_search_for_idx
      {HSLM : StringLikeMin Ascii.ascii}
      {HSL : StringLike Ascii.ascii}
      {HSLP : StringLikeProperties Ascii.ascii}
      {G : pregrammar' Ascii.ascii}
      {apdata : all_possible_data G}
      {pdata : possible_data G}
      {str offset len nt its idx}
      (Heq : default_to_production (G := G) idx = NonTerminal nt :: its)
      (H_disjoint : disjoint
                      (possible_last_terminals_of G nt)
                      (possible_terminals_of_production G its))
: refine {splits : list nat
         | split_list_is_complete_idx
             G str offset len
             idx
             splits}
         (ret [find_after_last_char_such_that (substring offset len str) (fun ch => char_in ch (possible_last_terminals_of G nt))]).
Proof.
  unfold split_list_is_complete_idx.
  erewrite <- refine_disjoint_rev_search_for by eassumption.
  rewrite Heq.
  apply refine_pick_pick; intro; trivial.
Qed.

Lemma refine_disjoint_rev_search_for_not_idx
      {HSLM : StringLikeMin Ascii.ascii}
      {HSL : StringLike Ascii.ascii}
      {HSLP : StringLikeProperties Ascii.ascii}
      {G : pregrammar' Ascii.ascii}
      {apdata : all_possible_data G}
      {pdata : possible_data G}
      {str offset len nt its idx}
      (Heq : default_to_production (G := G) idx = NonTerminal nt :: its)
      (H_disjoint : disjoint
                      (possible_last_terminals_of G nt)
                      (possible_terminals_of_production G its))
: refine {splits : list nat
         | split_list_is_complete_idx
             G str offset len
             idx
             splits}
         (ret [find_after_last_char_such_that (substring offset len str) (fun ch => negb (char_in ch (possible_terminals_of_production G its)))]).
Proof.
  unfold split_list_is_complete_idx.
  erewrite <- refine_disjoint_rev_search_for_not by eassumption.
  rewrite Heq.
  apply refine_pick_pick; intro; trivial.
Qed.

Ltac solve_disjoint_side_conditions :=
  idtac;
  lazymatch goal with
  | [ |- Carriers.default_to_production (G := ?G) ?k = ?e ]
    => try cbv delta [G];
       cbv beta iota zeta delta [Carriers.default_to_production Lookup_idx fst snd List.map pregrammar_productions List.length List.nth minus Operations.List.drop];
       try reflexivity
  | [ |- is_true (DisjointLemmas.disjoint _ _) ]
    => vm_compute; try reflexivity
  end.

Ltac pose_disjoint_rev_search_for lem :=
  idtac;
  let G := match goal with |- appcontext[ParserInterface.split_list_is_complete_idx ?G ?str ?offset ?len ?idx] => G end in
  let HSLM := match goal with |- appcontext[@ParserInterface.split_list_is_complete_idx ?Char ?G ?HSLM ?HSL] => HSLM end in
  let HSL := match goal with |- appcontext[@ParserInterface.split_list_is_complete_idx ?Char ?G ?HSLM ?HSL] => HSL end in
  let lem' := constr:(@refine_disjoint_rev_search_for_idx HSLM HSL _ _ _ G) in
  let lem' := constr:(lem' _ _) in
  let lem' := match goal with
              | [ |- appcontext[ParserInterface.split_list_is_complete_idx ?G ?str ?offset ?len ?idx] ]
                => constr:(fun idx' nt its => lem' str offset len nt its idx')
              end in
  pose proof lem' as lem.
Ltac rewrite_once_disjoint_rev_search_for_specialize lem lem' :=
  idtac;
  let G := (lazymatch goal with
             | [ |- appcontext[ParserInterface.split_list_is_complete_idx ?G ?str ?offset ?len ?idx] ]
               => G
             end) in
  match goal with
  | [ |- appcontext[ParserInterface.split_list_is_complete_idx ?G ?str ?offset ?len ?idx] ]
    => pose proof (lem idx) as lem';
       do 2 (lazymatch type of lem' with
              | forall a : ?T, _ => idtac; let x := fresh in evar (x : T); specialize (lem' x); subst x
              end);
       let T := match type of lem' with forall a : ?T, _ => T end in
       let H' := fresh in
       assert (H' : T) by solve_disjoint_side_conditions;
       specialize (lem' H'); clear H';
       let x := match type of lem' with
                | context[possible_last_terminals_of ?G ?ls]
                  => constr:(possible_last_terminals_of G ls)
                end in
       replace_with_vm_compute_in x lem';
       unfold char_in, char_in_characters, possible_characters in lem';
       change (orb false) with (fun bv : bool => bv) in lem';
       cbv beta in lem';
       let T := match type of lem' with forall a : ?T, _ => T end in
       let H' := fresh in
       assert (H' : T) by solve_disjoint_side_conditions;
       specialize (lem' H'); clear H'
  end.
Ltac rewrite_once_disjoint_rev_search_for lem :=
  let lem' := fresh "lem'" in
  rewrite_once_disjoint_rev_search_for_specialize lem lem';
  setoid_rewrite lem'; clear lem'.
Ltac rewrite_disjoint_rev_search_for_no_clear lem :=
  pose_disjoint_rev_search_for lem;
  progress repeat rewrite_once_disjoint_rev_search_for lem.
Ltac rewrite_disjoint_rev_search_for :=
  idtac;
  let lem := fresh "lem" in
  rewrite_disjoint_rev_search_for_no_clear lem;
  clear lem.

Global Arguments possible_data {_}.
Global Arguments all_possible_data {_}.


Require Import bedrock2.Syntax bedrock2.NotationsCustomEntry Coq.Strings.String.
Require Import coqutil.Z.div_mod_to_equations.
Require Import coqutil.Z.Lia.
Require Import coqutil.Word.Interface.
Require Import coqutil.Byte.

Import BinInt String List.ListNotations ZArith.
Local Open Scope Z_scope. Local Open Scope string_scope. Local Open Scope list_scope.

Require bedrock2Examples.lightbulb_spec.
Local Notation patience := lightbulb_spec.patience.

Definition spi_write := func! (b) ~> busy {
    busy = $-1;
    i = $patience; while i { i = i - $1;
      io! busy = MMIOREAD($0x10024048);
      if !(busy >> $31) { i = i^i }
    };
    if !(busy >> $31) {
      output! MMIOWRITE($0x10024048, b);
      busy = (busy ^ busy)
    }
  }.

Definition spi_read := func! () ~> (b, busy) {
    busy = $-1;
    b = $0x5a;
    i = $patience; while i { i = i - $1;
      io! busy = MMIOREAD($0x1002404c);
      if !(busy >> $31) {
        b = busy & $0xff;
        i = i^i;
        busy = i
      }
    }
  }.

Definition spi_xchg := func! (b) ~> (b, busy) {
    unpack! busy = spi_write(b);
    require !busy;
    unpack! b, busy = spi_read()
  }.

Require Import bedrock2.ProgramLogic.
Require Import bedrock2.FE310CSemantics bedrock2.Semantics.
Require Import Coq.Lists.List. Import ListNotations.
Require Import bedrock2.TracePredicate. Import TracePredicateNotations.
Require Import bedrock2.ZnWords.

Import coqutil.Map.Interface.
Import ReversedListNotations.

Section WithParameters.
  Context {word: word.word 32} {mem: map.map word Byte.byte}.
  Context {word_ok: word.ok word} {mem_ok: map.ok mem}.

  Definition mmio_event_abstraction_relation
    (h : lightbulb_spec.OP word)
    (l : mem * string * list word * (mem * list word)) :=
    Logic.or
      (exists a v, h = ("st", a, v) /\ l = (map.empty, "MMIOWRITE", [a; v], (map.empty, [])))
      (exists a v, h = ("ld", a, v) /\ l = (map.empty, "MMIOREAD", [a], (map.empty, [v]))).
  Definition mmio_trace_abstraction_relation := List.Forall2 mmio_event_abstraction_relation.

  Global Instance spec_of_spi_write : spec_of "spi_write" := fun functions => forall t m b,
    word.unsigned b < 2 ^ 8 ->
    WeakestPrecondition.call functions "spi_write" t m [b] (fun T M RETS =>
      M = m /\ exists iol, T = t ;++ iol /\ exists ioh, mmio_trace_abstraction_relation ioh iol /\ exists err, RETS = [err] /\ Logic.or
        (((word.unsigned err <> 0) /\ lightbulb_spec.spi_write_full _ ^* ioh /\ Z.of_nat (length ioh) = patience))
        (word.unsigned err = 0 /\ lightbulb_spec.spi_write word (byte.of_Z (word.unsigned b)) ioh)).

  Global Instance spec_of_spi_read : spec_of "spi_read" := fun functions => forall t m,
    WeakestPrecondition.call functions "spi_read" t m [] (fun T M RETS =>
      M = m /\ exists iol, T = t ;++ iol /\ exists ioh, mmio_trace_abstraction_relation ioh iol /\ exists (b: byte) (err : word), RETS = [word.of_Z (byte.unsigned b); err] /\ Logic.or
        (word.unsigned err <> 0 /\ lightbulb_spec.spi_read_empty _ ^* ioh /\ Z.of_nat (length ioh) = patience)
        (word.unsigned err = 0 /\ lightbulb_spec.spi_read word b ioh)).

  Lemma nonzero_because_high_bit_set (x : word) (H : word.unsigned (word.sru x (word.of_Z 31)) <> 0)
    : word.unsigned x <> 0.
  Proof. ZnWords. Qed.

  Add Ring wring : (Properties.word.ring_theory (word := word))
        (preprocess [autorewrite with rew_word_morphism],
         morphism (Properties.word.ring_morph (word := word)),
         constants [Properties.word_cst]).

  Import coqutil.Tactics.letexists.
  Import Loops.
  Lemma spi_write_ok : program_logic_goal_for_function! spi_write.
  Proof.
    repeat straightline.
    rename H into Hb.

    (* WHY do theese parentheses matter? *)
    refine ((atleastonce ["b"; "busy"; "i"] (fun v T M B BUSY I =>
       b = B /\ v = word.unsigned I /\ word.unsigned I <> 0 /\ M = m /\
       exists tl, T = tl++t /\
       exists th, mmio_trace_abstraction_relation th tl /\
       lightbulb_spec.spi_write_full _ ^* th /\
       Z.of_nat (length th) + word.unsigned I = patience
       )) _ _ _ _ _ _ _);
      cbn [reconstruct map.putmany_of_list HList.tuple.to_list
           HList.hlist.foralls HList.tuple.foralls
           HList.hlist.existss HList.tuple.existss
           HList.hlist.apply  HList.tuple.apply
           HList.hlist
           List.repeat Datatypes.length
           HList.polymorphic_list.repeat HList.polymorphic_list.length
           PrimitivePair.pair._1 PrimitivePair.pair._2] in *.
    { repeat straightline. }
    { eapply (Z.lt_wf 0). }
    { eexists; split; repeat straightline.
      exfalso. ZnWords. }
    { repeat (split; trivial; []).
      subst i. rewrite word.unsigned_of_Z.
      split.
      { discriminate. }
      split; trivial.
      eexists; split.
      { rewrite app_nil_l; trivial. }
      eexists; split.
      { constructor. }
      split.
      { constructor. }
      exact eq_refl. }
    repeat straightline.
    eapply WeakestPreconditionProperties.interact_nomem; repeat straightline.
    letexists; split; [exact eq_refl|]; split; [split; trivial|].
    {
      cbv [isMMIOAddr addr].
      ZnWords. }
    repeat straightline.
    letexists. split.
    { repeat straightline. }
    split; intros.
    { (* CASE if-condition was true (word.unsigned v0 <> 0), i.e. NOP, loop exit depends on whether timeout *)
    repeat straightline. (* <-- does split on a postcondition of the form
                        (word.unsigned br <> 0 -> loop invariant still holds) /\
                        (word.unsigned br =  0 -> code after loop is fine)
                        which corresponds to case distinction over whether loop was exited *)
    { (* SUBCASE loop condition was true (do loop again) *)
      eexists; split.
      { repeat (split; trivial; []). subst t0.
        eexists (_ ;++ cons _ nil); split; [exact eq_refl|].
        eexists; split.
        { refine (List.Forall2_app _ _); try eassumption.
          econstructor; [|constructor].
          right; eexists _, _; repeat split. }
        split.
        { eapply kleene_app; eauto.
          refine (kleene_step _ _ nil _ (kleene_empty _)).
          repeat econstructor.
          ZnWords. }
        { ZnWordsL. } }
        { ZnWords. } }
    { (* SUBCASE loop condition was false (exit loop because of timeout *)
      letexists; split; [solve[repeat straightline]|split]; repeat straightline; try contradiction.
      subst t0.
      eexists (_ ;++ cons _ nil); split.
      { rewrite <-app_assoc; cbn [app]; f_equal. }
      eexists. split.
      { eapply Forall2_app; eauto.
        constructor; [|constructor].
        right; eauto. }
      eexists. split; trivial.
      { left; repeat split; eauto using nonzero_because_high_bit_set.
        { (* copied from above -- trace element for "fifo full" *)
          eapply kleene_app; eauto.
          refine (kleene_step _ _ nil _ (kleene_empty _)).
          repeat econstructor.
          ZnWords. }
        { ZnWordsL. } } }
    }
    (* CASE if-condition was false (word.unsigned v0 = 0), i.e. we'll set i=i^i and exit loop *)
    repeat straightline.
    { subst i.
      rewrite Properties.word.unsigned_xor_nowrap in *; rewrite Z.lxor_nilpotent in *; contradiction. }
    (* evaluate condition then split if *) letexists; split; [solve[repeat straightline]|split].
    1:contradiction.
    repeat straightline.
    eapply WeakestPreconditionProperties.interact_nomem; repeat straightline.
    letexists; letexists; split; [exact eq_refl|]; split; [split; trivial|].
    { cbv [isMMIOAddr]. ZnWords. }
    repeat straightline.
    subst t0.
    eexists (_ ;++ cons _ (cons _ nil)). split.
    { rewrite <-app_assoc. cbn [app]. f_equal. }
    eexists. split.
    { eapply List.Forall2_app; eauto.
      { constructor.
        { left. eexists _, _; repeat split. }
        { right; [|constructor].
          right; eexists _, _; repeat split. } } }
    eexists; split; trivial.
    right.
    subst busy.
    split.
    { f_equal. rewrite Properties.word.unsigned_xor_nowrap; rewrite Z.lxor_nilpotent; reflexivity. }
    cbv [lightbulb_spec.spi_write].
    eexists _, _; split; eauto; []; split; eauto.
    eexists (cons _ nil), (cons _ nil); split; cbn [app]; eauto.
    split; repeat econstructor.
    { ZnWords. }
    { cbv [lightbulb_spec.spi_write_enqueue one].
      repeat f_equal.
      eapply Properties.word.unsigned_inj.
      rewrite byte.unsigned_of_Z; cbv [byte.wrap]; rewrite Z.mod_small; ZnWords. }
  Qed.

  Local Ltac split_if :=
    lazymatch goal with
      |- WeakestPrecondition.cmd _ ?c _ _ _ ?post =>
      let c := eval hnf in c in
          lazymatch c with
          | cmd.cond _ _ _ => letexists; split; [solve[repeat straightline]|split]
          end
    end.

  Lemma spi_read_ok : program_logic_goal_for_function! spi_read.
    repeat straightline.
    refine ((atleastonce ["b"; "busy"; "i"] (fun v T M B BUSY I =>
       v = word.unsigned I /\ word.unsigned I <> 0 /\ M = m /\
       B = word.of_Z (byte.unsigned (byte.of_Z (word.unsigned B))) /\
       exists tl, T = tl++t /\
       exists th, mmio_trace_abstraction_relation th tl /\
       lightbulb_spec.spi_read_empty _ ^* th /\
       Z.of_nat (length th) + word.unsigned I = patience
            ))
            _ _ _ _ _ _ _);
      cbn [reconstruct map.putmany_of_list HList.tuple.to_list
           HList.hlist.foralls HList.tuple.foralls
           HList.hlist.existss HList.tuple.existss
           HList.hlist.apply  HList.tuple.apply
           HList.hlist
           List.repeat Datatypes.length
           HList.polymorphic_list.repeat HList.polymorphic_list.length
           PrimitivePair.pair._1 PrimitivePair.pair._2] in *; repeat straightline.
    { exact (Z.lt_wf 0). }
    { exfalso. ZnWords. }
    { subst i. rewrite word.unsigned_of_Z.
      split; [inversion 1|].
      split; trivial.
      subst b; rewrite byte.unsigned_of_Z; cbv [byte.wrap];
        rewrite Z.mod_small; rewrite word.unsigned_of_Z.
      2: { cbv. split; congruence. }
      split; trivial.
      eexists nil; split; trivial.
      eexists nil; split; try split; solve [constructor]. }
    { eapply WeakestPreconditionProperties.interact_nomem; repeat straightline.
      letexists; split; [exact eq_refl|]; split; [split; trivial|].
    { cbv [isMMIOAddr]. ZnWords. }
      repeat ((split; trivial; []) || straightline || split_if).
      {
        letexists. split; split.
        { subst v'; exact eq_refl. }
        { split; trivial.
          split; trivial.
          split; trivial.
          eexists (x2 ;++ cons _ nil); split; cbn [app]; eauto.
          eexists. split.
          { econstructor; try eassumption; right; eauto. }
          split.
          {
            refine (kleene_app _ (cons _ nil) _ x3 _); eauto.
            refine (kleene_step _ (cons _ nil) nil _ (kleene_empty _)).
            eexists; split.
            { exact eq_refl. }
            { ZnWords. } }
          { ZnWordsL. } }
          { ZnWords. }
          { ZnWords. } }
      { letexists; split; repeat straightline.
        eexists (x2 ;++ cons _ nil); split; cbn [app]; eauto.
        eexists. split.
        { econstructor; try eassumption; right; eauto. }
        eexists (byte.of_Z (word.unsigned x)), _; split.
        { f_equal. eassumption. }
        left; repeat split; eauto using nonzero_because_high_bit_set.
        { refine (kleene_app _ (cons _ nil) _ x3 _); eauto.
          refine (kleene_step _ (cons _ nil) nil _ (kleene_empty _)).
          eexists; split.
          { exact eq_refl. }
          { ZnWords. } }
        { ZnWordsL. } }
      { repeat straightline.
        repeat letexists; split.
        1: split.
        { repeat straightline. }
        2: {
          subst v'.
          subst v.
          subst i.
          rewrite Properties.word.unsigned_xor_nowrap, Z.lxor_nilpotent.
          ZnWords. }
        repeat straightline.
        repeat (split; trivial; []).
        split.
        { subst b.
          (* automatable: multi-word bitwise *)
          change (255) with (Z.ones 8).
          pose proof Properties.word.unsigned_range v0.
          eapply Properties.word.unsigned_inj.
          repeat (
              cbv [byte.wrap word.wrap];
              rewrite ?byte.unsigned_of_Z, ?word.unsigned_of_Z, ?Properties.word.unsigned_and_nowrap,
                      ?Z.land_ones, ?Z.mod_mod, ?Z.mod_small
                by blia;
              change (Z.ones 8 mod 2 ^ 32) with (Z.ones 8)).
          symmetry; eapply Z.mod_small.
          pose proof Z.mod_pos_bound (word.unsigned v0) (2^8) eq_refl.
          clear. Z.div_mod_to_equations. blia. }
        { (* copy-paste from above, trace manipulation *)
          eexists (x2 ;++ cons _ nil); split; cbn [app]; eauto.
          eexists. split.
          { econstructor; try eassumption; right; eauto. }
          subst i.
          rewrite Properties.word.unsigned_xor_nowrap, Z.lxor_nilpotent in H1; contradiction. } }
      { eexists _; split.
        { repeat straightline. }
        split; trivial.
        (* copy-paste from above, trace manipulation *)
        eexists (x2 ;++ cons _ nil); split; cbn [app]; eauto.
        eexists. split.
        { econstructor; try eassumption; right; eauto. }
        eexists (byte.of_Z (word.unsigned b)), _; split.
        { subst b; f_equal.
          (* tag:bitwise *)
          (* automatable: multi-word bitwise *)
          change (255) with (Z.ones 8).
          pose proof Properties.word.unsigned_range v0.
          eapply Properties.word.unsigned_inj.
          repeat (
              cbv [byte.wrap word.wrap];
              rewrite ?byte.unsigned_of_Z, ?word.unsigned_of_Z, ?Properties.word.unsigned_and_nowrap,
                      ?Z.land_ones, ?Z.mod_mod, ?Z.mod_small
                by blia;
              change (Z.ones 8 mod 2 ^ 32) with (Z.ones 8)).
          symmetry; eapply Z.mod_small.
          pose proof Z.mod_pos_bound (word.unsigned v0) (2^8) eq_refl.
          clear. Z.div_mod_to_equations. blia. }
        (* tag:symex *)
        { right; split.
          { subst_words. rewrite Properties.word.unsigned_xor_nowrap, Z.lxor_nilpotent; exact eq_refl. }
          eexists x3, (cons _ nil); split; cbn [app]; eauto.
          split; eauto.
          eexists; split; cbv [one]; trivial.
          split.
          (* tag:bitwise *)
          { ZnWords. }
          subst b.
          (* automatable: multi-word bitwise *)
          change (255) with (Z.ones 8).
          pose proof Properties.word.unsigned_range v0.
          eapply byte.unsigned_inj.
          repeat (
              cbv [byte.wrap word.wrap];
              rewrite ?byte.unsigned_of_Z, ?word.unsigned_of_Z, ?Properties.word.unsigned_and_nowrap,
                      ?Z.land_ones, ?Z.mod_mod, ?Z.mod_small
                by blia;
              change (Z.ones 8 mod 2 ^ 32) with (Z.ones 8)).
          trivial. } } }
  Qed.

  Global Instance spec_of_spi_xchg : spec_of "spi_xchg" := fun functions => forall t m b_out,
    word.unsigned b_out < 2 ^ 8 ->
    WeakestPrecondition.call functions "spi_xchg" t m [b_out] (fun T M RETS =>
      M = m /\ exists iol, T = t ;++ iol /\ exists ioh, mmio_trace_abstraction_relation ioh iol /\ exists (b_in:byte) (err : word), RETS = [word.of_Z (byte.unsigned b_in); err] /\ Logic.or
        (word.unsigned err <> 0 /\ (any +++ lightbulb_spec.spi_timeout _) ioh)
        (word.unsigned err = 0 /\ lightbulb_spec.spi_xchg word (byte.of_Z (word.unsigned b_out)) b_in ioh)).

  Lemma spi_xchg_ok : program_logic_goal_for_function! spi_xchg.
  Proof.
    repeat (
    match goal with
    | |- ?F ?a ?b ?c =>
        match F with WeakestPrecondition.get => idtac end;
        let f := (eval cbv beta delta [WeakestPrecondition.get] in F) in
        change (f a b c); cbv beta
      | H :  _ /\ _ \/ ?Y /\ _, G : not ?X |- _ =>
          constr_eq X Y; let Z := fresh in destruct H as [|[Z ?]]; [|case (G Z)]
      | H :  not ?Y /\ _ \/ _ /\ _, G : ?X |- _ =>
          constr_eq X Y; let Z := fresh in destruct H as [[Z ?]|]; [case (Z G)|]
    end ||

    straightline || straightline_call || split_if || refine (conj _ _) || eauto).

  { eexists. split.
    { exact eq_refl. }
    eexists. split.
    { eauto. }
    eexists. eexists. split.
    { repeat f_equal.
      instantiate (1 := byte.of_Z (word.unsigned b_out)).
      (* automatable: multi-word bitwise *)
      change (255) with (Z.ones 8).
      pose proof Properties.word.unsigned_range b_out.
      eapply Properties.word.unsigned_inj;
      repeat (
      cbv [word.wrap byte.wrap];
      rewrite ?byte.unsigned_of_Z, ?word.unsigned_of_Z, ?Properties.word.unsigned_and_nowrap, ?Z.land_ones, ?Z.mod_mod, ?Z.mod_small by blia;
      change (Z.ones 8 mod 2 ^ 32) with (Z.ones 8));
      rewrite ?Z.mod_small; rewrite ?Z.mod_small; trivial; blia. }
      left; split; eauto.
      eexists nil, x0; repeat split; cbv [any choice lightbulb_spec.spi_timeout]; eauto.
      rewrite app_nil_r; trivial. }

      { destruct H10; intuition eauto.
        { eexists. split.
          { subst a0. subst a.
            rewrite List.app_assoc; trivial. }
            eexists. split.
            { eapply Forall2_app; eauto. }
            eexists _, _; split.
            { subst v; trivial. }
            left; split; eauto.
            eapply concat_app; cbv [any choice lightbulb_spec.spi_timeout]; eauto. }
            eexists.
            subst a0.
            subst a.
            split.
            { rewrite List.app_assoc; trivial. }
            eexists.
            split.
            { eapply Forall2_app; eauto. }
            eexists _, _; split.
            { subst v. eauto. }
            right. split; eauto.
            cbv [lightbulb_spec.spi_xchg].

  assert (Trace__concat_app : forall T (P Q:list T->Prop) x y, P x -> Q y -> (P +++ Q) (y ++ x)). {
    cbv [concat]; eauto. }

    eauto using Trace__concat_app. }
  Qed.
End WithParameters.


Require Import
        Coq.Strings.String
        Coq.Vectors.Vector.

Require Import
        Fiat.Common.SumType
        Fiat.Common.BoundedLookup
        Fiat.Common.ilist
        Fiat.Computation
        Fiat.QueryStructure.Specification.Representation.Notations
        Fiat.QueryStructure.Specification.Representation.Heading
        Fiat.QueryStructure.Specification.Representation.Tuple
        Fiat.Narcissus.BinLib.Core
        Fiat.Narcissus.Common.Specs
        Fiat.Narcissus.Common.WordFacts
        Fiat.Narcissus.Common.ComposeCheckSum
        Fiat.Narcissus.Common.ComposeIf
        Fiat.Narcissus.Common.ComposeOpt
        Fiat.Narcissus.Automation.SolverOpt
        Fiat.Narcissus.Formats.Bool
        Fiat.Narcissus.Formats.Option
        Fiat.Narcissus.Formats.FixListOpt
        Fiat.Narcissus.Stores.EmptyStore
        Fiat.Narcissus.Formats.NatOpt
        Fiat.Narcissus.Formats.Vector
        Fiat.Narcissus.Formats.EnumOpt
        Fiat.Narcissus.Formats.SumTypeOpt
        Fiat.Narcissus.Formats.IPChecksum
        Fiat.Narcissus.Formats.WordOpt.

Require Import Bedrock.Word.

Import Vectors.VectorDef.VectorNotations.
Open Scope string_scope.
Open Scope Tuple_scope.

(* Start Example Derivation. *)

Definition ICMP_Unreachable :=
  @Tuple <"Payload" :: list char >. (* IP Header + first 64 bits of original datagram. *)

Definition ICMP_TimeExceeded :=
  @Tuple <"Payload" :: list char >. (* IP Header + first 64 bits of original datagram. *)

Definition ICMP_ParameterProblem :=
  @Tuple <"Pointer" :: char,
          "Payload" :: list char >. (* IP Header + first 64 bits of original datagram. *)

Definition ICMP_SourceQuench :=
  @Tuple <"Payload" :: list char >. (* IP Header + first 64 bits of original datagram. *)

Definition ICMP_Redirect :=
  @Tuple <"RouterIP" :: word 32, (* IP Address of the router to use *)
          "Payload" :: list char >. (* IP Header + first 64 bits of original datagram. *)

Definition ICMP_Echo :=
  @Tuple <"ID" :: word 16, (* Identifier for sender *)
          "SeqNum" :: word 16, (* Identifier for request *)
          "Payload" :: list char>. (* Optional data to be echoed. *)

Definition ICMP_Timestamp :=
  @Tuple <"ID" :: word 16, (* Identifier for sender *)
          "SeqNum" :: word 16, (* Identifier for request *)
          "Originate" :: word 32, (* Time request sent *)
          "Received" :: word 32, (*  Time request received *)
          "Transmit" :: word 32>. (*  Time reply sent *)

Definition ICMP_AddressMask :=
  @Tuple <"ID" :: word 16, (* Identifier for sender *)
          "SeqNum" :: word 16, (* Identifier for request *)
          "SubnetMask" :: word 32>. (* The subnet mask of interest. *)

Definition ICMP_RouterAdvertisement :=
  @Tuple <"TTL" :: word 16, (* Time to Live for the provided router information. *)
          "RoutersPlusPreferences" :: list (word 32 * word 32)>. (* Pairs of a router's IP address *)
                                                                 (* and its preference level. *)

Definition ICMP_Message_Types :=
    [ ICMP_Echo; (* Echo Reply *)
      ICMP_Unreachable; (* Destiniation unreachable *)
      ICMP_SourceQuench; (* Source Quence *)
      ICMP_Redirect; (* Redirect *)
      ICMP_Echo; (* Echo Request *)
      ICMP_RouterAdvertisement; (* Router Advertisement *)
      (unit : Type) ; (* Router Solicitation *)
      ICMP_TimeExceeded; (* Time Exceeded *)
      ICMP_ParameterProblem; (* Parameter Problem *)
      ICMP_Timestamp; (* Timestamp Request *)
      ICMP_Timestamp; (* Timestamp Reply *)
      ICMP_AddressMask; (* Address Mask Request *)
      ICMP_AddressMask]. (* Address Mask Reply *)

Definition ICMP_Message_Codes :=
  Eval simpl in
    [natToWord 8 0;
     natToWord 8 3;
     natToWord 8 4;
     natToWord 8 5;
     natToWord 8 8;
     natToWord 8 9;
     natToWord 8 10;
     natToWord 8 11;
     natToWord 8 12;
     natToWord 8 13;
     natToWord 8 14;
     natToWord 8 17;
     natToWord 8 18].

Definition ICMP_Message :=
  @Tuple <"Code" :: char, "Message" :: SumType ICMP_Message_Types>.

Definition monoid : Monoid ByteString := ByteStringMonoid.

Definition format_ICMP_Echo_Spec
           (icmp : ICMP_Echo) :=
        format_word icmp!"ID"
  ThenC format_word icmp!"SeqNum"
  ThenC format_list format_word icmp!"Payload"
  DoneC.

Definition format_ICMP_Unreachable_Spec
           (icmp : ICMP_Unreachable) :=
        format_word (wzero 32)
  ThenC format_list format_word icmp!"Payload"
  DoneC.

Definition format_ICMP_SourceQuench_Spec
           (icmp : ICMP_SourceQuench) :=
        format_word (wzero 32)
  ThenC format_list format_word icmp!"Payload"
  DoneC.

Definition format_ICMP_Redirect_Spec
           (icmp : ICMP_Redirect) :=
        format_word icmp!"RouterIP"
  ThenC format_list format_word icmp!"Payload"
  DoneC.

Definition format_ICMP_RouterAdvertisement_Spec
           (icmp : ICMP_RouterAdvertisement) :=
        format_nat 8 (|icmp!"RoutersPlusPreferences"|)
  ThenC format_nat 8 2
  ThenC format_word icmp!"TTL"
  ThenC format_list (fun p => format_word (fst p) ThenC format_word (snd p)) icmp!"RoutersPlusPreferences"
  DoneC.

Definition format_ICMP_RouterSolicitation_Spec
           (icmp : unit) :=
  format_word (wzero 32)
  DoneC.

Definition format_ICMP_TimeExceeded_Spec
           (icmp : ICMP_TimeExceeded) :=
        format_word (wzero 32)
  ThenC format_list format_word icmp!"Payload"
  DoneC.

Definition format_ICMP_ParameterProblem_Spec
           (icmp : ICMP_ParameterProblem) :=
        format_word icmp!"Pointer"
  ThenC format_word (wzero 24)
  ThenC format_list format_word icmp!"Payload"
  DoneC.

Definition format_ICMP_Timestamp_Spec
           (icmp : ICMP_Timestamp) :=
        format_word icmp!"ID"
  ThenC format_word icmp!"SeqNum"
  ThenC format_word icmp!"Originate"
  ThenC format_word icmp!"Received"
  ThenC format_word icmp!"Transmit"
  DoneC.

Definition format_ICMP_AddressMask_Spec
           (icmp : ICMP_AddressMask) :=
        format_word icmp!"ID"
  ThenC format_word icmp!"SeqNum"
  ThenC format_word icmp!"SubnetMask".

Definition format_ICMP_Message_Spec
           (icmp : ICMP_Message) :=
          format_enum ICMP_Message_Codes (SumType_index ICMP_Message_Types icmp!"Message")
    ThenC format_word (icmp!"Code")
    ThenChecksum IPChecksum_Valid OfSize 16
    ThenCarryOn
    format_SumType ICMP_Message_Types
                        (icons format_ICMP_Echo_Spec
                        (icons format_ICMP_Unreachable_Spec
                        (icons format_ICMP_SourceQuench_Spec
                        (icons format_ICMP_Redirect_Spec
                        (icons format_ICMP_Echo_Spec
                        (icons format_ICMP_RouterAdvertisement_Spec
                        (icons format_ICMP_RouterSolicitation_Spec
                        (icons format_ICMP_TimeExceeded_Spec
                        (icons format_ICMP_ParameterProblem_Spec
                        (icons format_ICMP_Timestamp_Spec
                        (icons format_ICMP_Timestamp_Spec
                        (icons format_ICMP_AddressMask_Spec
                        (icons format_ICMP_AddressMask_Spec inil)))))))))))))
    icmp!"Message".