(**
   Version très simplifiée des idée de: "Java bytecode verification: algorithms
   and formalizations", Xavier Leroy (Journal of Automated Reasoning,
   30(3-4):235-269, 2003).

   Dont voici l'abstract:

   "Bytecode verification is a crucial security component for Java applets, on
   the Web and on embedded devices such as smart cards. This paper reviews the
   various bytecode verification algorithms that have been proposed, recasts
   them in a common framework of dataflow analysis, and surveys the use of proof
   assistants to specify bytecode verification and prove its correctness."

 *)

(* Coq écrira de préférence la syntaxe [foo.(bar)] plutôt que [(bar
   foo)], pour les champs (bar) de records (foo). *)
Set Printing Projections.

Require Omega.
Require Import OrderedType OrderedTypeEx OrderedTypeAlt DecidableType DecidableTypeEx FunInd.
From bcv Require Import LibHypsNaming heritage vmtype vmdefinition.

(** * Valeurs manipulée par la machine défensive,

   Ce module servira à instancier VMDefinition plus bas.
   La définition des types, classes et instruction est fixée dans [vmtype]. *)

Module DefVal <: VMVal.

  Inductive DVal:Set :=
  | Vint (i:nat)
  | Vref (clrf:class_id * heap_idx) (** nom de classe * adresse dans le tas *)
  | Vrefnull
  | Error
  | NonInit.

  Definition Val := DVal.

  (** Calcul du type d'une valeur défensive. *)
  Definition v2t (v:Val): VMType :=
    match v with
      | Vint i => Tint
      | Vref (clid,_) => Tref clid
      | Vrefnull => Trefnull
      | Error => Top
      | NonInit => Top
    end.

  Lemma val_eq_dec : forall v1 v2:Val, {v1=v2}+{v1<>v2}.
  Proof.
    intros v1 v2.
    decide equality.
    decide equality.
    decide equality.
    decide equality.
    decide equality.
  Qed.

End DefVal.

Module D (H:Herit).

(** États défensifs. *)
  Module Def := VMDefinition(DefVal)(H).
  Import DefVal.
  Include Def.
  Ltac rename_dvm h th := fail.

  (* Hypothesis renaming stuff from other files + current file.
     DO NOT REDEFINE IN THIS FILE. Redefine rename_dvm instead. *)
  Ltac rename_hyp h th ::=
    match th with
    | _ => (rename_dvm h th) (* redefine this tactic at will to enrich renaming*)
    | _ => (Def.rename_vmdef h th) (* renaming from Def *)
    | _ => (LibHypsNaming.rename_hyp_neg h th) (* basic generic renaming *)
    end.

  Definition build_flds: ClasseDef -> (Dico.t Val) :=
    Dico.map
      (fun t:VMType =>
         match t with
         | Tint => Vint 0
         | Tref id => Vrefnull (** null = 0 *)
         | Object => Vrefnull (** null = 0 *)
         | Top => Vrefnull (** Should never happen *)
         | Trefnull => Vrefnull (** Should never happen *)
         end).

Function new (clid:class_id) (heap:Heap) : option (heap_idx * Heap) :=
    match Dico.find clid allcl with
    | None => None (** Classe inconnue *)
    | Some cldef =>
      let flds:Obj := {| objclass := clid; objfields := build_flds cldef |} in
      let newhpidx: nat := maxkey heap in
      Some((S newhpidx), Dico.add (S newhpidx) flds heap)
    end.

  (** test *)
  (*
    Definition obj1:Obj := {| objclass:=1; objfields:=Dico.empty _|}.
    Definition heap1:Heap := Dico.empty _ .
    Definition heap2:Heap := Dico.add 1 obj1 heap1.
    Definition heap3:Heap := Dico.add 2 obj1 heap2.
    Eval vm_compute in (maxkey heap3).
    Eval vm_compute in (maxkey heap2). *)
  (* fin test *)

  (** * Fonction d'exécution défensive d'*un* bytecode.

     Pas de vérif d'overflow sur la pile d'opérandes. pas de nb
     négatifs, on ne vérifie que le typage et les underflow. *)
  Definition exec_step (s:State): option State :=
    let frm:Frame := s.(frame) in
    let pc: pc_idx := frm.(pc) in
    let instr_opt := Dico.find pc (frm.(mdef).(instrs)) in
    match instr_opt with
    | None => None
    | Some instr =>
      match instr with
      | ret => Some s
      | Iconst i =>
        Some {| framestack := s.(framestack); heap := s.(heap);
                frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                            pc:= pc + 1;
                            stack:= (Vint i) :: s.(frame).(stack)
                         |}
             |}
      | Iadd =>
        match s.(frame).(stack) with
        | Vint i1 :: Vint i2 :: stack' =>
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef); regs:= s.(frame).(regs);
                              pc:= pc + 1;
                              stack:= (Vint (i1 + i2)) :: stack'
                           |}
               |}
         | nil | _ :: nil => None
         | _ :: _ => None
        end

      | Iload ridx =>
        match Dico.find ridx (s.(frame).(regs)) with
        | Some (Vint i) =>
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef); regs:= s.(frame).(regs);
                              pc:= pc + 1;
                              stack:= Vint i :: s.(frame).(stack)
                           |}
               |}
        | Some _ (** Invalid register content *)
        | None => None (** Bad register number *)
        end

      | Rload clid ridx =>
        match Dico.find ridx (s.(frame).(regs)) with
        | Some (Vref r) =>
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              pc:= pc + 1;
                              stack:= Vref r :: s.(frame).(stack)
                           |}
               |}
        | Some _ (** Invalid register content *)
        | None => None (** Bad register number *)
        end

      | Istore ridx =>
        match s.(frame).(stack) with
        | Vint i :: stack' =>
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ;
                              regs:= Dico.add ridx (Vint i) (s.(frame).(regs));
                              pc:= pc + 1;
                              stack:= stack'
                           |}
               |}
        | nil
        | _ => None (** Stack underflow *)
        end

      | Rstore clid ridx =>
        match s.(frame).(stack) with
        | Vref r :: stack' =>
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ;
                              regs:= Dico.add ridx (Vref r) (s.(frame).(regs));
                              pc:= pc + 1;
                              stack:= stack'
                           |}
               |}
        | nil => None (** Stack underflow *)
        | _ => None
        end

      | Iifle jmp => (** ifeqe *)
        match s.(frame).(stack) with
        | (Vint 0) :: stack' => (** = 0  --> jump *)
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              pc:= jmp;
                              stack:= stack'
                           |}
               |}
        | _ :: stack' => (** <> 0  --> pc+1 *)
          Some {| framestack := s.(framestack); heap := s.(heap);
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              pc:= pc+1;
                              stack:= stack'
                           |}
               |}
        | nil => None (** Stack underflow *)
        end

      | Goto jmp =>
        Some {| framestack := s.(framestack); heap := s.(heap);
                frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                            stack:= s.(frame).(stack);
                            pc:= jmp
                         |}
             |}

      | Getfield cl namefld typ =>
        match s.(frame).(stack) with
        | (Vint hpidx) :: stack' =>
          match Dico.find hpidx s.(heap) with
          | None => None (** adresse inconnue *)
          | Some {|objclass:= objcl; objfields:= flds |} =>
            if Nat.eqb objcl cl then
              match Dico.find namefld flds with
              | None => None (** Champ de classe inconnu ou pas initialisé *)
              | Some v =>
                Some {| framestack := s.(framestack); heap := s.(heap);
                        frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                                    pc:= pc+1;
                                    stack:= v :: stack'
                                 |}
                     |}
              end
            else None
          end
        | nil => None (** Stack underflow *)
        | _ => None
        end

      | Putfield cl namefld typ =>
        match s.(frame).(stack) with
        | (Vint hpidx) :: v :: stack' =>
          match Dico.find hpidx s.(heap) with
          | None => None (** adresse inconnue, objet non alloué *)
          | Some {| objclass:= objcl; objfields:= flds |} =>
            if Nat.eqb objcl cl then
              let newflds := {| objclass:= cl;
                                objfields:=Dico.add namefld v flds |} in
              let newheap := Dico.add hpidx newflds s.(heap) in
              Some {| framestack := s.(framestack);
                      heap := newheap;
                      frame := {| mdef:=s.(frame).(mdef) ;
                                  regs:= s.(frame).(regs);
                                  pc:= pc+1;
                                  stack:= stack'
                               |}
                   |}
            else None
          end
        | nil | _ :: nil => None (** Stack underflow *)
        | _ :: _ => None
        end

      | New clid =>
        match new clid s.(heap) with
        | None => None (** Classe inconnue *)
        | Some (newobj,newhp) =>
          Some {| framestack := s.(framestack); heap := newhp;
                  frame := {| mdef:=s.(frame).(mdef) ; regs:= s.(frame).(regs);
                              stack:= (Vref (clid,newobj)) :: s.(frame).(stack);
                              pc:= pc+1
                           |}
               |}

        end
      end
    end.

  Functional Scheme exec_step_ind := Induction for exec_step Sort Prop.

  (** * Tests *)

  Notation "k --> i , d" := (Dico.add k i d) (at level 55, right associativity).

  Definition prog:MethodDef :=
    {| instrs := (0 --> Iload 1 ,
                  1 --> Istore 2 ,
                  2 --> ret ,
                  Dico.empty ) ;
       argstype :=( Tint :: Tint:: nil);
       restype := Tint |}.

  Definition startstate:State :=
    {|
      framestack := nil;
      heap := Dico.empty;
      frame := {|
                mdef:= prog ;
                regs:= (0 --> Vint 32 , 1-->Vint 11, Dico.empty );
                pc:= 0;
                stack:= nil
              |}
    |}.

  Fixpoint exec_n (s : State) (n:nat) {struct n}: option State :=
    match n with
    | 0 => Some s
    | S n' =>
      match exec_step s with
      | None => None
      | Some s' => exec_n s' n'
      end
    end.
  (*
    Eval simpl in exec_n startstate 1.
    Eval simpl in exec_n startstate 2.
    Eval simpl in exec_n startstate 5.
   *)
  (* Eval simpl in exec_n (fun x y => false) (Dico.empty _) startstate 2. *)

  (** Exemple de preuve très simple sur la fonction d'exécution: la
  pile (hormis la méthode en cours d'exécution) ne change pas au cours
  de exec_step. *)

  Lemma essai : forall s x,
      exec_step s = Some x ->
      x.(framestack) = s.(framestack).
  Proof.
    intros s.
    functional induction exec_step s;intros ;simpl;
      try solve [discriminate | inversion H; subst;simpl;reflexivity] .
  Qed.

End D.


Require Import Framework FileDiskLayer FileDiskRefinement.
Require Import FD_ORS FileDiskNoninterference. (* FileDiskTS. *)

Theorem ss_AD_read:
  forall n inum off u u',
    RDNI_Weak u
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (Read inum off)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (Read inum off)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) Recover)) AD_valid_state
    (AD_related_states u' None) (eq u') (authenticated_disk_reboot_list n).
Proof.
    intros; eapply RDNIW_transfer.
    - apply RDNI_to_RDNIW; apply ss_FD_read.
    - apply read_simulation.
    - apply read_simulation.
    - apply abstract_oracles_exist_wrt_read.
    - apply abstract_oracles_exist_wrt_read.
    - apply ORS_read.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
Qed.

Theorem ss_AD_write:
  forall n inum off u u' v,
    RDNI_Weak u
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (Write inum off v)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (Write inum off v)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) Recover)) AD_valid_state
    (AD_related_states u' None) (eq u') (authenticated_disk_reboot_list n).
Proof.
    intros; eapply RDNIW_transfer.
    - apply RDNI_to_RDNIW; apply ss_FD_write.
    - apply write_simulation.
    - apply write_simulation.
    - apply abstract_oracles_exist_wrt_write.
    - apply abstract_oracles_exist_wrt_write.
    - apply ORS_write.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
Qed.

Theorem ss_AD_extend:
  forall n inum u u' v,
    RDNI_Weak u
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (Extend inum v)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (Extend inum v)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) Recover)) AD_valid_state
    (AD_related_states u' None) (eq u') (authenticated_disk_reboot_list n).
Proof.
    intros; eapply RDNIW_transfer.
    - apply RDNI_to_RDNIW; apply ss_FD_extend.
    - apply extend_simulation.
    - apply extend_simulation.
    - apply abstract_oracles_exist_wrt_extend.
    - apply abstract_oracles_exist_wrt_extend.
    - apply ORS_extend.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
Qed.

Theorem ss_AD_change_owner:
  forall n inum u u' v,
    RDNI_Weak u
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (ChangeOwner inum v)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (ChangeOwner inum v)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) Recover)) AD_valid_state
    (AD_related_states u' (Some inum)) (eq u') (authenticated_disk_reboot_list n).
Proof.
    intros; eapply RDNIW_transfer.
    - apply RDNI_to_RDNIW; apply ss_FD_change_owner.
    - apply change_owner_simulation.
    - apply change_owner_simulation.
    - apply abstract_oracles_exist_wrt_change_owner.
    - apply abstract_oracles_exist_wrt_change_owner.
    - apply ORS_change_owner.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
Qed.

Theorem ss_AD_create:
  forall n u u' v,
    RDNI_Weak u
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (Create v)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (Create v)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) Recover)) AD_valid_state
    (AD_related_states u' None) (eq u') (authenticated_disk_reboot_list n).
Proof.
    intros; eapply RDNIW_transfer.
    - apply RDNI_to_RDNIW; apply ss_FD_create.
    - apply create_simulation.
    - apply create_simulation.
    - apply abstract_oracles_exist_wrt_create.
    - apply abstract_oracles_exist_wrt_create.
    - apply ORS_create.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
Qed.

Theorem ss_AD_delete:
  forall n inum u u',
    RDNI_Weak u
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (Delete inum)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (Delete inum)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) Recover)) AD_valid_state
    (AD_related_states u' None) (eq u') (authenticated_disk_reboot_list n).
Proof.
    intros; eapply RDNIW_transfer.
    - apply RDNI_to_RDNIW; apply ss_FD_delete.
    - apply delete_simulation.
    - apply delete_simulation.
    - apply abstract_oracles_exist_wrt_delete.
    - apply abstract_oracles_exist_wrt_delete.
    - apply ORS_delete.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
Qed.

Theorem ss_AD_write_input:
  forall n inum off u u' v1 v2,
    RDNI_Weak u
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (Write inum off v1)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (Write inum off v2)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) Recover)) AD_valid_state
    (AD_related_states u' (Some inum)) (eq u') (authenticated_disk_reboot_list n).
Proof.
    intros; eapply RDNIW_transfer.
    - apply RDNI_to_RDNIW; apply ss_FD_write_input.
    - apply write_simulation.
    - apply write_simulation.
    - apply abstract_oracles_exist_wrt_write.
    - apply abstract_oracles_exist_wrt_write.
    - apply ORS_write_input.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
Qed.

Theorem ss_AD_extend_input:
  forall n inum u u' v1 v2,
    RDNI_Weak u
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (Extend inum v1)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) (Extend inum v2)))
    (FD.refinement.(Simulation.Definitions.compile) (FDOp.(Op) Recover)) AD_valid_state
    (AD_related_states u' (Some inum)) (eq u') (authenticated_disk_reboot_list n).
Proof.
    intros; eapply RDNIW_transfer.
    - apply RDNI_to_RDNIW; apply ss_FD_extend_input.
    - apply extend_simulation.
    - apply extend_simulation.
    - apply abstract_oracles_exist_wrt_extend.
    - apply abstract_oracles_exist_wrt_extend.
    - apply ORS_extend.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
    - unfold exec_compiled_preserves_validity,
    refines_valid, FD_valid_state; intros; eauto.
Qed.


(****************************************************************************)
(*                                                                          *)
(*                                                                          *)
(*              Solange Coupet-Grimal & Catherine Nouvet                    *)
(*                                                                          *)
(*                                                                          *)
(*       Laboratoire d'Informatique Fondamentale de Marseille               *)
(*               CMI-Technopole de Chateau-Gombert                          *)
(*                   39, Rue F. Joliot Curie                                *)
(*                   13453 MARSEILLE Cedex 13                               *)
(*           Contact :Solange.Coupet@cmi.univ-mrs.fr                        *)
(*                                                                          *)
(*                                                                          *)
(*                                Coq V7.0                                  *)
(*                             Septembre 2002                               *)
(*                                                                          *)
(****************************************************************************)
(*                           nogreyaccnblackn.v                             *)
(****************************************************************************)

Section invariant5.

Require Export accnotfree.
Require Export noedgeblacktowhite.

Lemma nogrey_accn_imp_blackn_init :
 forall s : state, init_state s -> nogrey_accn_imp_blackn s.

unfold nogrey_accn_imp_blackn in |- *.
intros s init H_col n2 acces_s_n2.
elim init; clear init.
intros ctls H_mark_col.
elim H_mark_col; clear H_mark_col.
intros mark heap; elim mark; clear mark.
intros mksrt mark; elim acces_s_n2; auto.
intros n m acces_s_m mksm hsmn.
absurd (hp s m n = false); auto.
rewrite hsmn; discriminate.
Qed.

Lemma nogrey_accn_imp_blackn_addedge :
 forall s t : state,
 nogrey_accn_imp_blackn s -> add_edge s t -> nogrey_accn_imp_blackn t.

unfold nogrey_accn_imp_blackn in |- *.
intros s t H_s addedge H_col n2 acces_t_n2.
apply (add_blacks_blackt s t); auto.
apply H_s.
intro n1; apply (add_notgreyt_notgreys s t); auto.
apply (add_accest_access s t); assumption.
Qed.

Lemma nogrey_accn_imp_blackn_removeedge :
 forall s t : state,
 nogrey_accn_imp_blackn s -> remove_edge s t -> nogrey_accn_imp_blackn t.

unfold nogrey_accn_imp_blackn in |- *.
intros s t H_s removeedge H_col n2 acces_t_n2.
apply (remove_blacks_blackt s t); auto.
apply H_s.
intro n1; apply (remove_notgreyt_notgreys s t); auto.
apply (remove_accest_access s t); assumption.
Qed.

Lemma nogrey_accn_imp_blackn_alloc :
 forall s t : state,
 nogrey_accn_imp_blackn s -> alloc s t -> nogrey_accn_imp_blackn t.

unfold nogrey_accn_imp_blackn in |- *.
intros s t H_s alloc H_col n2 acces_t_n2.
elim alloc; clear alloc.
intros ctls ctlt n mksn H_fils mark add; elim mark; clear mark.
intros mark mktn; elim (eq_dec_node n n2).
intro neqn2; rewrite <- neqn2; assumption.
intro ndifn2; rewrite <- (mark n2); auto.
apply H_s.
intro n1; apply (alloc_notgreyt_notgreys s t); auto.
apply (alloc_add_free_to_rt s t) with (n := n); auto.
unfold update_color in |- *; auto.
apply (alloc_accest_access s t n); auto.
unfold update_color in |- *; auto.
Qed.

Lemma nogrey_accn_imp_blackn_gccall :
 forall s t : state,
 rt_grey_or_black s ->
 no_edge_black_to_white_bis s ->
 acc_imp_notfree s ->
 nogrey_accn_imp_blackn s -> gc_call s t -> nogrey_accn_imp_blackn t.

unfold nogrey_accn_imp_blackn in |- *.
intros s t inv1_s inv2_s inv3_s H_s gccall H_col n2 acces_t_n2.
elim gccall; clear gccall.
intros ctls ctlt heap mark init; elim init; clear init.
intros mktrt H_mark_col; absurd (mk t rt = grey); auto.
intros ctls ctlt heap H_sons; apply (ind t); auto.
apply (rt_grey_or_black_gccall s t); auto.
apply (call_exist_grey s t); assumption.
apply (no_edge_black_to_white_gccall s t); auto.
apply (call_exist_grey s t); auto.
apply (acc_imp_notfree_gccall s t); auto.
apply (call_exist_grey s t); auto.
intros ctls ctlt heap H_col2 m mksm mark.
apply (updatecolor_blacks_blackt s t) with (m := m); auto.
apply H_s; auto.
rewrite heap; assumption.
Qed.

Lemma nogrey_accn_imp_blackn_marknode :
 forall s t : state,
 rt_grey_or_black s ->
 no_edge_black_to_white_bis s ->
 acc_imp_notfree s ->
 nogrey_accn_imp_blackn s -> mark_node s t -> nogrey_accn_imp_blackn t.

unfold nogrey_accn_imp_blackn in |- *.
intros s t inv1_s inv2_s inv3_s H_s marknode H_col n2 acces_t_n2.
apply (ind t); auto.
apply (rt_grey_or_black_marknode s t); assumption.
apply (no_edge_black_to_white_marknode s t); assumption.
apply (acc_imp_notfree_marknode s t); assumption.
Qed.

Lemma nogrey_accn_imp_blackn_gcstop :
 forall s t : state,
 nogrey_accn_imp_blackn s -> gc_stop s t -> nogrey_accn_imp_blackn t.

unfold nogrey_accn_imp_blackn in |- *.
intros s t H_s gcstop H_col n2 acces_t_n2.
apply (gcstop_blacks_blackt s t); auto.
apply H_s.
intro n1; apply (gcstop_notgreyt_notgreys s t); auto.
apply (gcstop_accest_access s t); auto.
Qed.

Lemma nogrey_accn_imp_blackn_gcfree :
 forall s t : state,
 nogrey_accn_imp_blackn s -> gc_free s t -> nogrey_accn_imp_blackn t.

unfold nogrey_accn_imp_blackn in |- *.
intros s t H_s gcfree H_col n2 acces_t_n2.
apply (gcfree_blacks_blackt s t); auto.
apply H_s.
elim gcfree; clear gcfree.
intros ctls ctlt H_col2 heap m mksm mark n1; auto.
apply (gcfree_accest_access s t); assumption.
Qed.

Lemma nogrey_accn_imp_blackn_gcfree1 :
 forall s t : state,
 sweep_no_greys s ->
 nogrey_accn_imp_blackn s -> gc_free1 s t -> nogrey_accn_imp_blackn t.

unfold nogrey_accn_imp_blackn in |- *; unfold sweep_no_greys in |- *.
intros s t inv4_s H_s gcfree1 H_col n2 acces_t_n2.
apply (gcfree1_blacks_blackt s t); auto.
apply H_s.
intro n1; apply inv4_s.
elim gcfree1; clear gcfree1; auto.
apply (gcfree1_accest_access s t); assumption.
Qed.

Lemma nogrey_accn_imp_blackn_gcend :
 forall s t : state,
 nogrey_accn_imp_blackn s -> gc_end s t -> nogrey_accn_imp_blackn t.

unfold nogrey_accn_imp_blackn in |- *.
intros s t H_s gcend H_col n2 acces_t_n2.
apply (gcend_blacks_blackt s t); auto.
apply H_s.
intro n1; apply (gcend_notgreyt_notgreys s t); auto.
apply (gcend_accest_access s t); auto.
Qed.

End invariant5.

Hint Immediate nogrey_accn_imp_blackn_addedge.
Hint Immediate nogrey_accn_imp_blackn_removeedge.
Hint Immediate nogrey_accn_imp_blackn_alloc.
Hint Immediate nogrey_accn_imp_blackn_gccall.
Hint Immediate nogrey_accn_imp_blackn_marknode.
Hint Immediate nogrey_accn_imp_blackn_gcstop.
Hint Immediate nogrey_accn_imp_blackn_gcfree.
Hint Immediate nogrey_accn_imp_blackn_gcfree1.
Hint Immediate nogrey_accn_imp_blackn_gcend.
Hint Immediate imp1.


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, Collège de France and Inria Paris            *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

Require Import Coqlib Maps Errors.
Require Import AST Integers Floats Values Memory Globalenvs Events Smallstep.
Require Import Cminor.
Require Import Unityping.
Require Import sflib.

Local Open Scope string_scope.
Local Open Scope error_monad_scope.

(** * Type inference algorithm *)

Definition type_constant (c: constant) : typ :=
  match c with
  | Ointconst _ => Tint
  | Ofloatconst _ => Tfloat
  | Osingleconst _ => Tsingle
  | Olongconst _ => Tlong
  | Oaddrsymbol _ _ => Tptr
  | Oaddrstack _ => Tptr
  end.

Definition type_unop (op: unary_operation) : typ * typ :=
  match op with
  | Ocast8unsigned | Ocast8signed | Ocast16unsigned | Ocast16signed
  | Onegint | Onotint => (Tint, Tint)
  | Onegf | Oabsf => (Tfloat, Tfloat)
  | Onegfs | Oabsfs => (Tsingle, Tsingle)
  | Osingleoffloat => (Tfloat, Tsingle)
  | Ofloatofsingle => (Tsingle, Tfloat)
  | Ointoffloat | Ointuoffloat => (Tfloat, Tint)
  | Ofloatofint | Ofloatofintu => (Tint, Tfloat)
  | Ointofsingle | Ointuofsingle => (Tsingle, Tint)
  | Osingleofint | Osingleofintu => (Tint, Tsingle)
  | Onegl | Onotl => (Tlong, Tlong)
  | Ointoflong => (Tlong, Tint)
  | Olongofint | Olongofintu => (Tint, Tlong)
  | Olongoffloat | Olonguoffloat => (Tfloat, Tlong)
  | Ofloatoflong | Ofloatoflongu => (Tlong, Tfloat)
  | Olongofsingle | Olonguofsingle => (Tsingle, Tlong)
  | Osingleoflong | Osingleoflongu => (Tlong, Tsingle)
  end.

Definition type_binop (op: binary_operation) : typ * typ * typ :=
  match op with
  | Oadd  | Osub  | Omul  | Odiv  | Odivu  | Omod  | Omodu
  | Oand  | Oor   | Oxor  | Oshl  | Oshr   | Oshru => (Tint, Tint, Tint)
  | Oaddf | Osubf | Omulf | Odivf  => (Tfloat, Tfloat, Tfloat)
  | Oaddfs| Osubfs| Omulfs| Odivfs => (Tsingle, Tsingle, Tsingle)
  | Oaddl | Osubl | Omull | Odivl | Odivlu | Omodl | Omodlu
  | Oandl | Oorl  | Oxorl => (Tlong, Tlong, Tlong)
  | Oshll | Oshrl | Oshrlu => (Tlong, Tint, Tlong)
  | Ocmp _ | Ocmpu _ => (Tint, Tint, Tint)
  | Ocmpf _ => (Tfloat, Tfloat, Tint)
  | Ocmpfs _ => (Tsingle, Tsingle, Tint)
  | Ocmpl _ | Ocmplu _ => (Tlong, Tlong, Tint)
  end.

Module RTLtypes <: TYPE_ALGEBRA.

Definition t := typ.
Definition eq := typ_eq.
Definition default := Tint.

End RTLtypes.

Module S := UniSolver(RTLtypes).

Definition expect (e: S.typenv) (t1 t2: typ) : res S.typenv :=
  if typ_eq t1 t2 then OK e else Error (msg "type mismatch").

Fixpoint type_expr (e: S.typenv) (a: expr) (t: typ) : res S.typenv :=
  match a with
  | Evar id => S.set e id t
  | Econst c => expect e (type_constant c) t
  | Eunop op a1 =>
      let '(targ1, tres) := type_unop op in
      do e1 <- type_expr e a1 targ1;
      expect e1 tres t
  | Ebinop op a1 a2 =>
      let '(targ1, targ2, tres) := type_binop op in
      do e1 <- type_expr e a1 targ1;
      do e2 <- type_expr e1 a2 targ2;
      expect e2 tres t
  | Eload chunk a1 =>
      do e1 <- type_expr e a1 Tptr;
      expect e1 (type_of_chunk chunk) t
  end.

Fixpoint type_exprlist (e: S.typenv) (al: list expr) (tl: list typ) : res S.typenv :=
  match al, tl with
  | nil, nil => OK e
  | a :: al, t :: tl => do e1 <- type_expr e a t; type_exprlist e1 al tl
  | _, _ => Error (msg "arity mismatch")
  end.

Definition type_assign (e: S.typenv) (id: ident) (a: expr) : res S.typenv :=
  match a with
  | Evar id' =>
      do (changed, e1) <- S.move e id id'; OK e1
  | Econst c =>
      S.set e id (type_constant c)
  | Eunop op a1 =>
      let '(targ1, tres) := type_unop op in
      do e1 <- type_expr e a1 targ1;
      S.set e1 id tres
  | Ebinop op a1 a2 =>
      let '(targ1, targ2, tres) := type_binop op in
      do e1 <- type_expr e a1 targ1;
      do e2 <- type_expr e1 a2 targ2;
      S.set e2 id tres
  | Eload chunk a1 =>
      do e1 <- type_expr e a1 Tptr;
      S.set e1 id (type_of_chunk chunk)
  end.

Definition opt_set (e: S.typenv) (optid: option ident) (ty: typ) : res S.typenv :=
  match optid with
  | None => OK e
  | Some id => S.set e id ty
  end.

Fixpoint type_stmt (tret: option typ) (e: S.typenv) (s: stmt) : res S.typenv :=
  match s with
  | Sskip => OK e
  | Sassign id a => type_assign e id a
  | Sstore chunk a1 a2 =>
      do e1 <- type_expr e a1 Tptr; type_expr e1 a2 (type_of_chunk chunk)
  | Scall optid sg fn args =>
      do e1 <- type_expr e fn Tptr;
      do e2 <- type_exprlist e1 args sg.(sig_args);
      opt_set e2 optid (proj_sig_res sg)
  | Stailcall sg fn args =>
      assertion (opt_typ_eq sg.(sig_res) tret);
      do e1 <- type_expr e fn Tptr;
      type_exprlist e1 args sg.(sig_args)
  | Sbuiltin optid ef args =>
      let sg := ef_sig ef in
      do e1 <- type_exprlist e args sg.(sig_args);
      opt_set e1 optid (proj_sig_res sg)
  | Sseq s1 s2 =>
      do e1 <- type_stmt tret e s1; type_stmt tret e1 s2
  | Sifthenelse a s1 s2 =>
      do e1 <- type_expr e a Tint;
      do e2 <- type_stmt tret e1 s1;
      type_stmt tret e2 s2
  | Sloop s1 =>
      type_stmt tret e s1
  | Sblock s1 =>
      type_stmt tret e s1
  | Sexit n =>
      OK e
  | Sswitch sz a tbl dfl =>
      type_expr e a (if sz then Tlong else Tint)
  | Sreturn opta =>
      match opta, tret with
      | None, _ => OK e
      | Some a, Some t => type_expr e a t
      | _, _ => Error (msg "inconsistent return")
      end
  | Slabel lbl s1 =>
      type_stmt tret e s1
  | Sgoto lbl =>
      OK e
  end.

Definition typenv := ident -> typ.

Definition type_function (f: function) : res typenv :=
  do e1 <- S.set_list S.initial f.(fn_params) f.(fn_sig).(sig_args);
  do e2 <- type_stmt f.(fn_sig).(sig_res) e1 f.(fn_body);
  S.solve e2.

(** * Relational specification of the type system *)

Section SPEC.

Variable env: ident -> typ.
Variable tret: option typ.

Inductive wt_expr: expr -> typ -> Prop :=
  | wt_Evar: forall id,
      wt_expr (Evar id) (env id)
  | wt_Econst: forall c,
      wt_expr (Econst c) (type_constant c)
  | wt_Eunop: forall op a1 targ1 tres,
      type_unop op = (targ1, tres) ->
      wt_expr a1 targ1 ->
      wt_expr (Eunop op a1) tres
  | wt_Ebinop: forall op a1 a2 targ1 targ2 tres,
      type_binop op = (targ1, targ2, tres) ->
      wt_expr a1 targ1 -> wt_expr a2 targ2 ->
      wt_expr (Ebinop op a1 a2) tres
  | wt_Eload: forall chunk a1,
      wt_expr a1 Tptr ->
      wt_expr (Eload chunk a1) (type_of_chunk chunk).

Definition wt_opt_assign (optid: option ident) (optty: option typ) : Prop :=
  match optid with
  | Some id => match optty with Some ty => ty | None => Tint end = env id
  | _ => True
  end.

Inductive wt_stmt: stmt -> Prop :=
  | wt_Sskip:
      wt_stmt Sskip
  | wt_Sassign: forall id a,
      wt_expr a (env id) ->
      wt_stmt (Sassign id a)
  | wt_Sstore: forall chunk a1 a2,
      wt_expr a1 Tptr -> wt_expr a2 (type_of_chunk chunk) ->
      wt_stmt (Sstore chunk a1 a2)
  | wt_Scall: forall optid sg a1 al,
      wt_expr a1 Tptr -> list_forall2 wt_expr al sg.(sig_args) ->
      wt_opt_assign optid sg.(sig_res) ->
      wt_stmt (Scall optid sg a1 al)
  | wt_Stailcall: forall sg a1 al,
      wt_expr a1 Tptr -> list_forall2 wt_expr al sg.(sig_args) ->
      sg.(sig_res) = tret ->
      wt_stmt (Stailcall sg a1 al)
  | wt_Sbuiltin: forall optid ef al,
      list_forall2 wt_expr al (ef_sig ef).(sig_args) ->
      wt_opt_assign optid (ef_sig ef).(sig_res) ->
      wt_stmt (Sbuiltin optid ef al)
  | wt_Sseq: forall s1 s2,
      wt_stmt s1 -> wt_stmt s2 ->
      wt_stmt (Sseq s1 s2)
  | wt_Sifthenelse: forall a s1 s2,
      wt_expr a Tint -> wt_stmt s1 -> wt_stmt s2 ->
      wt_stmt (Sifthenelse a s1 s2)
  | wt_Sloop: forall s1,
      wt_stmt s1 ->
      wt_stmt (Sloop s1)
  | wt_Sblock: forall s1,
      wt_stmt s1 ->
      wt_stmt (Sblock s1)
  | wt_Sexit: forall n,
      wt_stmt (Sexit n)
  | wt_Sswitch: forall (sz: bool) a tbl dfl,
      wt_expr a (if sz then Tlong else Tint) ->
      wt_stmt (Sswitch sz a tbl dfl)
  | wt_Sreturn_none:
      wt_stmt (Sreturn None)
  | wt_Sreturn_some: forall a t,
      tret = Some t -> wt_expr a t ->
      wt_stmt (Sreturn (Some a))
  | wt_Slabel: forall lbl s1,
      wt_stmt s1 ->
      wt_stmt (Slabel lbl s1)
  | wt_Sgoto: forall lbl,
      wt_stmt (Sgoto lbl).

End SPEC.

Inductive wt_function (env: typenv) (f: function) : Prop :=
  wt_function_intro:
    type_function f = OK env ->     (**r to ensure uniqueness of [env] *)
    List.map env f.(fn_params) = f.(fn_sig).(sig_args) ->
    wt_stmt env f.(fn_sig).(sig_res) f.(fn_body) ->
    wt_function env f.

Inductive wt_fundef: fundef -> Prop :=
  | wt_fundef_internal: forall env f,
      wt_function env f ->
      wt_fundef (Internal f)
  | wt_fundef_external: forall ef,
      wt_fundef (External ef).

Definition wt_program (p: program): Prop :=
  forall i f, In (i, Gfun f) (prog_defs p) -> wt_fundef f.

(** * Soundness of type inference *)

Lemma expect_incr: forall te e t1 t2 e',
  expect e t1 t2 = OK e' -> S.satisf te e' -> S.satisf te e.
Proof.
  unfold expect; intros. destruct (typ_eq t1 t2); inv H; auto.
Qed.
Hint Resolve expect_incr: ty.

Lemma expect_sound: forall e t1 t2 e',
  expect e t1 t2 = OK e' -> t1 = t2.
Proof.
  unfold expect; intros. destruct (typ_eq t1 t2); inv H; auto.
Qed.

Lemma type_expr_incr: forall te a t e e',
  type_expr e a t = OK e' -> S.satisf te e' -> S.satisf te e.
Proof.
  induction a; simpl; intros until e'; intros T SAT; try (monadInv T); eauto with ty.
- destruct (type_unop u) as [targ1 tres]; monadInv T; eauto with ty.
- destruct (type_binop b) as [[targ1 targ2] tres]; monadInv T; eauto with ty.
Qed.
Hint Resolve type_expr_incr: ty.

Lemma type_expr_sound: forall te a t e e',
    type_expr e a t = OK e' -> S.satisf te e' -> wt_expr te a t.
Proof.
  induction a; simpl; intros until e'; intros T SAT; try (monadInv T).
- erewrite <- S.set_sound by eauto. constructor.
- erewrite <- expect_sound by eauto. constructor.
- destruct (type_unop u) as [targ1 tres] eqn:TU; monadInv T.
  erewrite <- expect_sound by eauto. econstructor; eauto with ty.
- destruct (type_binop b) as [[targ1 targ2] tres] eqn:TB; monadInv T.
  erewrite <- expect_sound by eauto. econstructor; eauto with ty.
- erewrite <- expect_sound by eauto. econstructor; eauto with ty.
Qed.

Lemma type_exprlist_incr: forall te al tl e e',
  type_exprlist e al tl = OK e' -> S.satisf te e' -> S.satisf te e.
Proof.
  induction al; destruct tl; simpl; intros until e'; intros T SAT; monadInv T; eauto with ty.
Qed.
Hint Resolve type_exprlist_incr: ty.

Lemma type_exprlist_sound: forall te al tl e e',
    type_exprlist e al tl = OK e' -> S.satisf te e' -> list_forall2 (wt_expr te) al tl.
Proof.
  induction al; destruct tl; simpl; intros until e'; intros T SAT; monadInv T.
- constructor.
- constructor; eauto using type_expr_sound with ty.
Qed.

Lemma type_assign_incr: forall te id a e e',
    type_assign e id a = OK e' -> S.satisf te e' -> S.satisf te e.
Proof.
  induction a; simpl; intros until e'; intros T SAT; try (monadInv T); eauto with ty.
- destruct (type_unop u) as [targ1 tres]; monadInv T; eauto with ty.
- destruct (type_binop b) as [[targ1 targ2] tres]; monadInv T; eauto with ty.
Qed.
Hint Resolve type_assign_incr: ty.

Lemma type_assign_sound: forall te id a e e',
    type_assign e id a = OK e' -> S.satisf te e' -> wt_expr te a (te id).
Proof.
  induction a; simpl; intros until e'; intros T SAT; try (monadInv T).
- erewrite S.move_sound by eauto. constructor.
- erewrite S.set_sound by eauto. constructor.
- destruct (type_unop u) as [targ1 tres] eqn:TU; monadInv T.
  erewrite S.set_sound by eauto. econstructor; eauto using type_expr_sound with ty.
- destruct (type_binop b) as [[targ1 targ2] tres] eqn:TB; monadInv T.
  erewrite S.set_sound by eauto. econstructor; eauto using type_expr_sound with ty.
- erewrite S.set_sound by eauto. econstructor; eauto using type_expr_sound with ty.
Qed.

Lemma opt_set_incr: forall te optid optty e e',
    opt_set e optid optty = OK e' -> S.satisf te e' -> S.satisf te e.
Proof.
  unfold opt_set; intros. destruct optid, optty; try (monadInv H); eauto with ty.
Qed.
Hint Resolve opt_set_incr: ty.

Lemma opt_set_sound: forall te optid sg e e',
    opt_set e optid (proj_sig_res sg) = OK e' -> S.satisf te e' ->
    wt_opt_assign te optid sg.(sig_res).
Proof.
  unfold opt_set; intros; red. destruct optid.
- erewrite S.set_sound by eauto. auto.
- inv H. auto.
Qed.

Lemma type_stmt_incr: forall te tret s e e',
    type_stmt tret e s = OK e' -> S.satisf te e' -> S.satisf te e.
Proof.
  induction s; simpl; intros e1 e2 T SAT; try (monadInv T); eauto with ty.
- destruct tret, o; try (monadInv T); eauto with ty.
Qed.
Hint Resolve type_stmt_incr: ty.

Lemma type_stmt_sound: forall te tret s e e',
    type_stmt tret e s = OK e' -> S.satisf te e' -> wt_stmt te tret s.
Proof.
  induction s; simpl; intros e1 e2 T SAT; try (monadInv T).
- constructor.
- constructor; eauto using type_assign_sound.
- constructor; eauto using type_expr_sound with ty.
- constructor; eauto using type_expr_sound, type_exprlist_sound, opt_set_sound with ty.
- constructor; eauto using type_expr_sound, type_exprlist_sound with ty.
- constructor; eauto using type_exprlist_sound, opt_set_sound with ty.
- constructor; eauto with ty.
- constructor; eauto using type_expr_sound with ty.
- constructor; eauto.
- constructor; eauto.
- constructor.
- constructor; eauto using type_expr_sound with ty.
- destruct tret, o; try (monadInv T); econstructor; eauto using type_expr_sound with ty.
- constructor; eauto.
- constructor.
Qed.

Theorem type_function_sound: forall f env,
  type_function f = OK env -> wt_function env f.
Proof.
  intros. generalize H; unfold type_function; intros T; monadInv T.
  assert (S.satisf env x0) by (apply S.solve_sound; auto).
  constructor; eauto using S.set_list_sound, type_stmt_sound with ty.
Qed.

(** * Semantic soundness of the type system *)

Definition wt_env (env: typenv) (e: Cminor.env) : Prop :=
  forall id v, e!id = Some v -> Val.has_type v (env id).

Definition def_env (f: function) (e: Cminor.env) : Prop :=
  forall id, In id f.(fn_params) \/ In id f.(fn_vars) -> exists v, e!id = Some v.

Inductive wt_cont_call: cont -> option typ -> Prop :=
  | wt_cont_Kstop: forall ty,
      wt_cont_call Kstop ty
  | wt_cont_Kcall: forall optid f sp e k tret env
        (WT_FN: wt_function env f)
        (WT_CONT: wt_cont env f.(fn_sig).(sig_res) k)
        (WT_ENV: wt_env env e)
        (DEF_ENV: def_env f e)
        (WT_DEST: wt_opt_assign env optid tret),
      wt_cont_call (Kcall optid f sp e k) tret

with wt_cont: typenv -> option typ -> cont -> Prop :=
  | wt_cont_Kseq: forall env tret s k,
      wt_stmt env tret s ->
      wt_cont env tret k ->
      wt_cont env tret (Kseq s k)
  | wt_cont_Kblock: forall env tret k,
      wt_cont env tret k ->
      wt_cont env tret (Kblock k)
  | wt_cont_other: forall env tret k,
      wt_cont_call k tret ->
      wt_cont env tret k.

Inductive wt_state: state -> Prop :=
  | wt_normal_state: forall f s k sp e m env
        (WT_FN: wt_function env f)
        (WT_STMT: wt_stmt env f.(fn_sig).(sig_res) s)
        (WT_CONT: wt_cont env f.(fn_sig).(sig_res) k)
        (WT_ENV: wt_env env e)
        (DEF_ENV: def_env f e),
      wt_state (State f s k sp e m)
  | wt_call_state: forall fptr sg args k m
        (* (WT_FD: wt_fundef f) *)
        (WT_ARGS: Val.has_type_list args sg.(sig_args))
        (WT_CONT: wt_cont_call k sg.(sig_res)),
      wt_state (Callstate fptr sg args k m)
  | wt_return_state: forall v k m tret
        (WT_RES: Val.has_type v (match tret with None => Tint | Some t => t end))
        (WT_CONT: wt_cont_call k tret),
      wt_state (Returnstate v k m).

Lemma wt_is_call_cont:
  forall env tret k, wt_cont env tret k -> is_call_cont k -> wt_cont_call k tret.
Proof.
  destruct 1; intros ICC; contradiction || auto.
Qed.

Lemma call_cont_wt:
  forall env tret k, wt_cont env tret k -> wt_cont_call (call_cont k) tret.
Proof.
  induction 1; simpl; auto. inversion H; subst; auto.
Qed.

Lemma wt_env_assign: forall env id e v,
  wt_env env e -> Val.has_type v (env id) -> wt_env env (PTree.set id v e).
Proof.
  intros; red; intros. rewrite PTree.gsspec in H1; destruct (peq id0 id).
- congruence.
- auto.
Qed.

Lemma def_env_assign: forall f e id v,
  def_env f e -> def_env f (PTree.set id v e).
Proof.
  intros; red; intros i IN. rewrite PTree.gsspec. destruct (peq i id).
  exists v; auto.
  auto.
Qed.

Lemma wt_env_set_params: forall env il vl,
  Val.has_type_list vl (map env il) -> wt_env env (set_params vl il).
Proof.
  induction il as [ | i il]; destruct vl as [ | vl]; simpl; intros; try contradiction.
- red; intros. rewrite PTree.gempty in H0; discriminate.
- destruct H. apply wt_env_assign; auto.
Qed.

Lemma def_set_params: forall id il vl,
  In id il -> exists v, PTree.get id (set_params vl il) = Some v.
Proof.
  induction il as [ | i il]; simpl; intros.
- contradiction.
- destruct vl as [ | v vl]; rewrite PTree.gsspec; destruct (peq id i).
  econstructor; eauto.
  apply IHil; intuition congruence.
  econstructor; eauto.
  apply IHil; intuition congruence.
Qed.

Lemma wt_env_set_locals: forall env il e,
  wt_env env e -> wt_env env (set_locals il e).
Proof.
  induction il as [ | i il]; simpl; intros.
- auto.
- apply wt_env_assign; auto. exact I.
Qed.

Lemma def_set_locals: forall id il e,
  (exists v, PTree.get id e = Some v) \/ In id il ->
  exists v, PTree.get id (set_locals il e) = Some v.
Proof.
  induction il as [ | i il]; simpl; intros.
- tauto.
- rewrite PTree.gsspec; destruct (peq id i).
  econstructor; eauto.
  apply IHil; intuition congruence.
Qed.

Lemma wt_find_label: forall env tret lbl s k,
  wt_stmt env tret s -> wt_cont env tret k ->
  match find_label lbl s k with
  | Some (s', k') => wt_stmt env tret s' /\ wt_cont env tret k'
  | None => True
  end.
Proof.
  induction s; intros k WS WK; simpl; auto.
- inv WS. assert (wt_cont env tret (Kseq s2 k)) by (constructor; auto).
  specialize (IHs1 _ H1 H). destruct (find_label lbl s1 (Kseq s2 k)).
  auto. apply IHs2; auto.
- inv WS. specialize (IHs1 _ H3 WK). destruct (find_label lbl s1 k).
  auto. apply IHs2; auto.
- inversion WS; subst. apply IHs; auto. constructor; auto.
- inv WS. apply IHs; auto. constructor; auto.
- inv WS. destruct (ident_eq lbl l). auto. apply IHs; auto.
Qed.

Section SUBJECT_REDUCTION.

Variable p: program.

Hypothesis wt_p: wt_program p.

Variable se: Senv.t.
Variable ge: genv.

Hypothesis CONTAINED: forall fptr f
    (FINDF: Genv.find_funct ge fptr = Some f),
    exists i, In (i, Gfun f) (prog_defs p).

Ltac VHT :=
  match goal with
  | [ |- Val.has_type (if Archi.ptr64 then _ else _) _] => unfold Val.has_type; destruct Archi.ptr64 eqn:?; VHT
  | [ |- Val.has_type (match ?v with _ => _ end) _] => destruct v; VHT
  | [ |- Val.has_type (Vptr _ _) Tptr ] => apply Val.Vptr_has_type
  | [ |- Val.has_type _ _ ] => exact I
  | [ |- Val.has_type (?f _ _ _ _ _) _ ] => unfold f; VHT
  | [ |- Val.has_type (?f _ _ _ _) _ ] => unfold f; VHT
  | [ |- Val.has_type (?f _ _) _ ] => unfold f; VHT
  | [ |- Val.has_type (?f _ _ _) _ ] => unfold f; VHT
  | [ |- Val.has_type (?f _) _ ] => unfold f; VHT
  | [ |- True ] => exact I
  | [ |- ?x = ?x ] => reflexivity
  | _ => idtac
  end.

Ltac VHT' :=
  match goal with
  | [ H: None = Some _ |- _ ] => discriminate
  | [ H: Some _ = Some _ |- _ ] => inv H; VHT
  | [ H: match ?x with _ => _ end = Some _ |- _ ] => destruct x; VHT'
  | [ H: ?f _ _ _ _ = Some _ |- _ ] => unfold f in H; VHT'
  | [ H: ?f _ _ _ = Some _ |- _ ] => unfold f in H; VHT'
  | [ H: ?f _ _ = Some _ |- _ ] => unfold f in H; VHT'
  | [ H: ?f _ = Some _ |- _ ] => unfold f in H; VHT'
  | _ => idtac
  end.

Lemma type_constant_sound: forall sp cst v,
  eval_constant ge sp cst = Some v ->
  Val.has_type v (type_constant cst).
Proof.
  intros until v; intros EV. destruct cst; simpl in *; inv EV; VHT.
Qed.

Lemma type_unop_sound: forall op v1 v,
  eval_unop op v1 = Some v -> Val.has_type v (snd (type_unop op)).
Proof.
  unfold eval_unop; intros op v1 v EV; destruct op; simpl; VHT'.
Qed.

Lemma type_binop_sound: forall op v1 v2 m v,
  eval_binop op v1 v2 m = Some v -> Val.has_type v (snd (type_binop op)).
Proof.
  unfold eval_binop; intros op v1 v2 m v EV; destruct op; simpl; VHT';
  destruct (eq_block b b0); VHT.
Qed.

Lemma wt_eval_expr: forall env sp e m a v,
  eval_expr ge sp e m a v ->
  forall t,
  wt_expr env a t ->
  wt_env env e ->
  Val.has_type v t.
Proof.
  induction 1; intros t WT ENV.
- inv WT. apply ENV; auto.
- inv WT. eapply type_constant_sound; eauto.
- inv WT. replace t with (snd (type_unop op)) by (rewrite H3; auto). eapply type_unop_sound; eauto.
- inv WT. replace t with (snd (type_binop op)) by (rewrite H5; auto). eapply type_binop_sound; eauto.
- inv WT. destruct vaddr; try discriminate. eapply Mem.load_type; eauto.
Qed.

Lemma wt_eval_exprlist: forall env sp e m al vl,
  eval_exprlist ge sp e m al vl ->
  forall tl,
  list_forall2 (wt_expr env) al tl ->
  wt_env env e ->
  Val.has_type_list vl tl.
Proof.
  induction 1; intros tl WT ENV; inv WT; simpl.
- auto.
- split. eapply wt_eval_expr; eauto. eauto.
Qed.

Lemma wt_find_funct: forall v fd,
  Genv.find_funct ge v = Some fd -> wt_fundef fd.
Proof.
  intros. exploit CONTAINED; eauto. i; des. eapply wt_p; eauto.
Qed.

Lemma subject_reduction:
  forall st1 t st2, step se ge st1 t st2 ->
  forall (WT: wt_state st1), wt_state st2.
Proof.
  destruct 1; intros; inv WT.
- inv WT_CONT. econstructor; eauto. inv H.
- inv WT_CONT. econstructor; eauto. inv H.
- econstructor; eauto using wt_is_call_cont. exact I.
- inv WT_STMT. econstructor; eauto using wt_Sskip.
  apply wt_env_assign; auto. eapply wt_eval_expr; eauto.
  apply def_env_assign; auto.
- econstructor; eauto using wt_Sskip.
- inv WT_STMT. econstructor; eauto.
  (* eapply wt_find_funct; eauto. *)
  eapply wt_eval_exprlist; eauto.
  econstructor; eauto.
- inv WT_STMT. econstructor; eauto.
  (* eapply wt_find_funct; eauto. *)
  eapply wt_eval_exprlist; eauto.
  rewrite H9; eapply call_cont_wt; eauto.
- inv WT_STMT. exploit external_call_well_typed; eauto. intros TRES.
  econstructor; eauto using wt_Sskip.
  unfold proj_sig_res in TRES; red in H5.
  destruct optid. rewrite H5 in TRES. apply wt_env_assign; auto. assumption.
  destruct optid. apply def_env_assign; auto. assumption.
- inv WT_STMT. econstructor; eauto. econstructor; eauto.
- inv WT_STMT. destruct b; econstructor; eauto.
- inv WT_STMT. econstructor; eauto. econstructor; eauto. constructor; auto.
- inv WT_STMT. econstructor; eauto. econstructor; eauto.
- inv WT_CONT. econstructor; eauto. inv H.
- inv WT_CONT. econstructor; eauto using wt_Sskip. inv H.
- inv WT_CONT. econstructor; eauto using wt_Sexit. inv H.
- econstructor; eauto using wt_Sexit.
- inv WT_STMT. econstructor; eauto using call_cont_wt. exact I.
- inv WT_STMT. econstructor; eauto using call_cont_wt.
  rewrite H2. eapply wt_eval_expr; eauto.
- inv WT_STMT. econstructor; eauto.
- inversion WT_FN; subst.
  assert (WT_CK: wt_cont env (sig_res (fn_sig f)) (call_cont k)).
  { constructor. eapply call_cont_wt; eauto. }
  generalize (wt_find_label _ _ lbl _ _ H2 WT_CK).
  rewrite H. intros [WT_STMT' WT_CONT']. econstructor; eauto.
- exploit wt_find_funct; eauto. intro WT_FD.
  inv WT_FD. inversion H1; subst. econstructor; eauto.
  constructor; auto.
  apply wt_env_set_locals. apply wt_env_set_params. rewrite H2; auto.
  red; intros. apply def_set_locals. destruct H4; auto. left; apply def_set_params; auto.
- exploit external_call_well_typed; eauto. unfold proj_sig_res. simpl in *. intros.
  econstructor; eauto.
- inv WT_CONT. econstructor; eauto using wt_Sskip.
  red in WT_DEST.
  destruct optid. rewrite WT_DEST in WT_RES. apply wt_env_assign; auto. assumption.
  destruct optid. apply def_env_assign; auto. assumption.
Qed.

Lemma subject_reduction_star:
  forall st1 t st2, star step se ge st1 t st2 ->
  forall (WT: wt_state st1), wt_state st2.
Proof.
  induction 1; eauto using subject_reduction.
Qed.

Lemma wt_initial_state:
  forall S, initial_state p S -> wt_state S.
Proof.
  intros. inv H. constructor. ss. ss. econs; eauto.
Qed.

End SUBJECT_REDUCTION.

(** * Safe expressions *)

(** Function parameters and declared local variables are always defined
  throughout the execution of a function.  The following [known_idents]
  data structure represents the set of those variables, with efficient membership. *)

Definition known_idents := PTree.t unit.

Definition is_known (ki: known_idents) (id: ident) :=
  match ki!id with Some _ => true | None => false end.

Definition known_id (f: function) : known_idents :=
  let add (ki: known_idents) (id: ident) := PTree.set id tt ki in
  List.fold_left add f.(fn_vars)
      (List.fold_left add f.(fn_params) (PTree.empty unit)).

(** A Cminor expression is safe if it always evaluates to a value,
    never causing a run-time error. *)

Definition safe_unop (op: unary_operation) : bool :=
  match op with
  | Ointoffloat | Ointuoffloat | Ofloatofint | Ofloatofintu => false
  | Ointofsingle | Ointuofsingle | Osingleofint | Osingleofintu => false
  | Olongoffloat | Olonguoffloat | Ofloatoflong | Ofloatoflongu => false
  | Olongofsingle | Olonguofsingle | Osingleoflong | Osingleoflongu => false
  | _ => true
  end.

Definition safe_binop (op: binary_operation) : bool :=
  match op with
  | Odiv | Odivu | Omod | Omodu => false
  | Odivl | Odivlu | Omodl | Omodlu => false
  | Ocmpl _ | Ocmplu _ => false
  | _ => true
  end.

Fixpoint safe_expr (ki: known_idents) (a: expr) : bool :=
  match a with
  | Evar v => is_known ki v
  | Econst c => true
  | Eunop op e1 => safe_unop op && safe_expr ki e1
  | Ebinop op e1 e2 => safe_binop op && safe_expr ki e1 && safe_expr ki e2
  | Eload chunk e => false
  end.

(** Soundness of [known_id]. *)

Lemma known_id_sound_1:
  forall f id x, (known_id f)!id = Some x -> In id f.(fn_params) \/ In id f.(fn_vars).
Proof.
  unfold known_id.
  set (add := fun (ki: known_idents) (id: ident) => PTree.set id tt ki).
  intros.
  assert (REC: forall l ki, (fold_left add l ki)!id = Some x -> In id l \/ ki!id = Some x).
  { induction l as [ | i l ]; simpl; intros.
    - auto.
    - apply IHl in H0. destruct H0; auto. unfold add in H0; rewrite PTree.gsspec in H0.
      destruct (peq id i); auto. }
  apply REC in H. destruct H; auto. apply REC in H. destruct H; auto.
  rewrite PTree.gempty in H; discriminate.
Qed.

Lemma known_id_sound_2:
  forall f id, is_known (known_id f) id = true -> In id f.(fn_params) \/ In id f.(fn_vars).
Proof.
  unfold is_known; intros. destruct (known_id f)!id eqn:E; try discriminate.
  eapply known_id_sound_1; eauto.
Qed.

(** Expressions that satisfy [safe_expr] always evaluate to a value. *)

Lemma eval_safe_expr:
  forall ge f sp e m a,
  def_env f e ->
  safe_expr (known_id f) a = true ->
  exists v, eval_expr ge sp e m a v.
Proof.
  induction a; simpl; intros.
  - apply known_id_sound_2 in H0.
    destruct (H i H0) as [v E].
    exists v; constructor; auto.
  - destruct (eval_constant ge sp c) as [v|] eqn:E.
    exists v; constructor; auto.
    destruct c; try discriminate.
  - InvBooleans. destruct IHa as [v1 E1]; auto.
    destruct (eval_unop u v1) as [v|] eqn:E.
    exists v; econstructor; eauto.
    destruct u; discriminate.
  - InvBooleans.
    destruct IHa1 as [v1 E1]; auto.
    destruct IHa2 as [v2 E2]; auto.
    destruct (eval_binop b v1 v2 m) as [v|] eqn:E.
    exists v; econstructor; eauto.
    destruct b; discriminate.
  - discriminate.
Qed.


(** Definitions of various kinds of Lemmas about _fibrations_, leading up to a theorem characterizing their composites. *)

Require Import UniMath.Foundations.Sets.
Require Import UniMath.MoreFoundations.PartA.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Isos.
Require Import UniMath.CategoryTheory.Core.NaturalTransformations.
Require Import UniMath.CategoryTheory.Core.Univalence. (* only coercions *)
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.MonoEpiIso.
Require Import UniMath.CategoryTheory.categories.HSET.Univalence.
Require Import UniMath.CategoryTheory.limits.pullbacks.
Require Import UniMath.CategoryTheory.Adjunctions.Core.
Require Import UniMath.CategoryTheory.Equivalences.Core.
Require Import UniMath.CategoryTheory.FunctorCategory.
Require Import UniMath.CategoryTheory.opp_precat.
Require Import UniMath.CategoryTheory.Presheaf.
Local Open Scope cat.

Require Import UniMath.CategoryTheory.DisplayedCats.Core.
Require Import UniMath.CategoryTheory.DisplayedCats.Constructions.
Require Import UniMath.CategoryTheory.DisplayedCats.Fibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.Fiber.

Require Import UniMath.Foundations.All.

Require Import UniMath.CategoryTheory.DisplayedCats.MoreFibrations.Prefibrations.
Require Import UniMath.CategoryTheory.DisplayedCats.MoreFibrations.CartesiannessOfComposites.

Local Open Scope type_scope.
Local Open Scope mor_disp_scope.

Definition precleaving_comp_is_precart
    {C : category} {D : disp_cat C} (lift : precleaving D)
  := forall (c c' c'' : C) (f' : c'' --> c') (f : c' --> c) (d : D c),
    is_precartesian ((lift _ _ f' (object_of_precartesian_lift (lift _ _ f d))) ;; (lift _ _ f d)).

Definition precleaving_is_cleaving
    {C : category} {D : disp_cat C} (lift : precleaving D)
:= forall (c c' : C) (f: c' --> c) (d : D c), is_cartesian (lift _ _ f d).

Lemma transportf_cancel
      {X : UU} (P : X → UU) {x x' : X} (e : x = x') (y0 y1 : P x):
      transportf P e y0 = transportf P e y1 -> y0 = y1.
Proof.
  induction e.
  apply idfun.
Defined.

Definition assoc_eq {C} {D : disp_cat C}
    {x y z w} {f} {g} {h} {xx : D x} {yy : D y} {zz : D z} {ww : D w}
    (ff ff' : xx -->[f] yy) (gg gg' : yy -->[g] zz) (hh hh' : zz -->[h] ww)
  : ff ;; (gg ;; hh) = ff' ;; (gg' ;; hh') -> (ff ;; gg) ;; hh = (ff' ;; gg') ;; hh'.
Proof.
  intro H.
  eapply pathscomp0.
  - apply assoc_disp_var.
  - eapply pathscomp0.
    + apply maponpaths.
      exact H.
    + apply pathsinv0.
      apply assoc_disp_var.
Qed.

Definition assoc_eq_var {C} {D : disp_cat C}
    {x y z w} {f} {g} {h} {xx : D x} {yy : D y} {zz : D z} {ww : D w}
    (ff ff' : xx -->[f] yy) (gg gg' : yy -->[g] zz) (hh hh' : zz -->[h] ww)
  : (ff ;; gg) ;; hh = (ff' ;; gg') ;; hh' -> ff ;; (gg ;; hh) = ff' ;; (gg' ;; hh').
Proof.
  intro H.
  eapply pathscomp0.
  - apply assoc_disp.
  - eapply pathscomp0.
    + apply maponpaths.
      exact H.
    + apply pathsinv0.
      apply assoc_disp.
Qed.

Definition prefibration_w_precart_closed_implies_fibration
    {C : category} {D : disp_cat C} (lift : precleaving D)
  : precleaving_comp_is_precart lift -> precleaving_is_cleaving lift.
Proof.
  unfold precleaving_comp_is_precart, precleaving_is_cleaving.
  intros liftclosed c c' f d.
  unfold is_cartesian.
  intros c'' g d'' hh.
  apply iscontraprop1.
  - apply invproofirrelevance.
    unfold isProofIrrelevant.
    intros [gg0 comm0] [gg1 comm1].
    apply subtypePairEquality.
    + intro gg.
      apply homsets_disp.
    + eapply transportf_cancel.
      eapply pathscomp0.
      * apply pathsinv0.
        use precartesian_factorisation_commutes.
        3: { use precartesian_lift_is_precartesian. apply lift. }
      * eapply pathscomp0.
        2: { use precartesian_factorisation_commutes.
          3: { use precartesian_lift_is_precartesian. apply lift. } }
        -- apply maponpaths_2.
           eapply precartesian_factorisation_unique.
           ++ apply liftclosed.
           ++ apply assoc_eq_var.
              eapply pathscomp0.
              ** apply maponpaths_2.
                 apply precartesian_factorisation_commutes.
              ** eapply pathscomp0.
                 --- eapply pathscomp0.
                     +++ apply mor_disp_transportf_postwhisker.
                     +++ eapply pathscomp0.
                         *** apply maponpaths.
                             exact (comm0 @ ! comm1).
                         *** apply pathsinv0.
                             apply mor_disp_transportf_postwhisker.
                 --- apply pathsinv0.
                     apply maponpaths_2.
                     apply precartesian_factorisation_commutes.
  - use tpair.
    + apply (transportf _ (id_left _)).
      eapply comp_disp.
      2: { apply lift. }
      eapply precartesian_factorisation.
      * apply liftclosed.
      * exact hh.
    + simpl.
      eapply pathscomp0.
      * eapply pathscomp0.
        -- apply mor_disp_transportf_postwhisker.
        -- eapply pathscomp0.
          ++ apply maponpaths.
             apply assoc_disp_var.
          ++ eapply pathscomp0.
             ** apply transport_f_f.
             ** apply maponpaths_2.
                apply homset_property.
      * apply transportf_transpose_left.
        apply precartesian_factorisation_commutes.
Defined.


(*
 * Copyright (c) 2017-present,
 * Programming Research Laboratory (ROPAS), Seoul National University, Korea
 * This software is distributed under the term of the BSD-3 clause license.
 *)
(** * Proof generation *)

Set Implicit Arguments.

Require Import hpattern vgtac.
Require Import Global.
Require DomCon SemCon SemSen SemSenLocal SemInsenLocal.
Require GamSen DenSenLocal DenInsenLocal.
Require ExtSenLocal ExtInsenLocal ExtFin.
Require CorSen CorSenLocal CorInsenLocal CorFin.
Require Import UserProofType.

Module Make (Import PInput : PINPUT).

Module Sen := SemSen.Make PInput.
Module GSen := GamSen.Make PInput.
Module ESenLocal := ExtSenLocal.Make PInput.
Module EInsenLocal := ExtInsenLocal.Make PInput.
Module EFin := ExtFin.Make PInput.
Module CSen := CorSen.Make PInput.
Module CSenLocal := CorSenLocal.Make PInput.
Module CInsenLocal := CorInsenLocal.Make PInput.
Module CFin := CorFin.Make PInput.

Definition extends (g : G.t) (amap : access_map)
           (s : Table.t Mem.t) (sen_s : Sen.state_t) : Prop :=
  exists senl_s,
    exists insenl_s,
      EFin.extends g s insenl_s
      /\ EInsenLocal.extends g amap insenl_s senl_s
      /\ ESenLocal.extends g amap senl_s sen_s.

Theorem correctness :
  forall (g : G.t) (Hg : G.wf g)
         (locs : PowLoc.t) (fis_mem : Mem.t) (amap : access_map)
         (orig_inputof inputof outputof : Table.t Mem.t)
         (Hvalid :
            valid g amap orig_inputof inputof outputof = true),
  exists s', (forall s (Hsem : SemCon.Sem g s), GSen.State_g s s')
             /\ extends g amap orig_inputof s'.
Proof.
i.
exploit CFin.correctness; eauto
; destruct 1 as [insen_s [Hinsen_post [Hinsen_amap Hinsen_ext]]].
exploit CInsenLocal.correctness; eauto
; destruct 1 as [senl_s [Hsenl_post [Hsenl_amap Hsenl_ext]]].
exploit CSenLocal.correctness; eauto
; destruct 1 as [sen_s [Hsen_post Hsen_ext]].
exists sen_s; split.
- apply CSen.correctness.
  eauto.
- exists senl_s; exists insen_s; repeat split; by auto.
Qed.

End Make.


From Coq Require Import ssreflect.
From stdpp Require Import gmap fin_maps list countable.
From cap_machine Require Export addr_reg.

(* Definitions: capabilities, machine words, machine instructions *)

Inductive Perm: Type :=
| O
| RO
| RW
| RWL
| RX
| E
| RWX
| RWLX
| URW
| URWL
| URWX
| URWLX.

Inductive Locality: Type :=
| Global
| Local
| Directed.

Definition Cap: Type :=
  (Perm * Locality) * Addr * Addr * Addr.

Definition Word := (Z + Cap)%type.

Inductive instr: Type :=
| Jmp (r: RegName)
| Jnz (r1 r2: RegName)
| Mov (dst: RegName) (src: Z + RegName)
| Load (dst src: RegName)
| Store (dst: RegName) (src: Z + RegName)
| Lt (dst: RegName) (r1 r2: Z + RegName)
| Add (dst: RegName) (r1 r2: Z + RegName)
| Sub (dst: RegName) (r1 r2: Z + RegName)
| Lea (dst: RegName) (r: Z + RegName)
| Restrict (dst: RegName) (r: Z + RegName)
| Subseg (dst: RegName) (r1 r2: Z + RegName)
| IsPtr (dst r: RegName)
| GetL (dst r: RegName)
| GetP (dst r: RegName)
| GetB (dst r: RegName)
| GetE (dst r: RegName)
| GetA (dst r: RegName)
| Fail
| Halt
(* Load value at src + offs into dst *)
| LoadU (dst src: RegName) (offs: Z + RegName)
(* Load value in src to dst + offs *)
| StoreU (dst: RegName) (offs src: Z + RegName)
(* Promote the uninitialized capability in dst *)
| PromoteU (dst: RegName).

(* Registers and memory: maps from register names/addresses to words *)

Notation Reg := (gmap RegName Word).
Notation Mem := (gmap Addr Word).

(* Auxiliary definitions for localities *)

Definition isLocal (l: Locality): bool :=
  match l with
  | Local | Directed => true
  | _ => false
  end.

Definition isLocalWord (w : Word): bool :=
  match w with
  | inl _ => false
  | inr ((_,l),_,_,_) => isLocal l
  end.

Lemma isLocalWord_cap_isLocal (c0:Cap):
  isLocalWord (inr c0) = true →
  ∃ p g b e a, c0 = (p,g,b,e,a) ∧ isLocal g = true.
Proof.
  intros. destruct c0, p, p, p.
  cbv in H. destruct l; try congruence.
  eexists _, _, _, _, _. split; eauto.
  eexists _, _, _, _, _. split; eauto.
Qed.

Definition isGlobal (l: Locality): bool :=
  match l with
  | Global => true
  | _ => false
  end.

Definition isGlobalWord (w : Word): bool :=
  match w with
  | inl _ => false
  | inr ((_,l),_,_,_) => isGlobal l
  end.

Lemma isGlobalWord_cap_isGlobal (w0:Word):
  isGlobalWord w0 = true →
  ∃ p g b e a, w0 = inr (p,g,b,e,a) ∧ isGlobal g = true.
Proof.
  intros. destruct w0;[done|].
  destruct c, p, p, p.
  cbv in H. destruct l; try done.
  eexists _, _, _, _, _. split; eauto.
Qed.

(* EqDecision instances *)

Instance perm_eq_dec : EqDecision Perm.
Proof. solve_decision. Defined.
Instance local_eq_dec : EqDecision Locality.
Proof. solve_decision. Defined.
Instance cap_eq_dec : EqDecision Cap.
Proof. solve_decision. Defined.
Instance word_eq_dec : EqDecision Word.
Proof. solve_decision. Defined.
Instance instr_eq_dec : EqDecision instr.
Proof. solve_decision. Defined.

(* Auxiliary definitions to work on permissions *)

Definition isU (p: Perm) :=
  match p with
  | URW | URWL | URWX | URWLX => true
  | _ => false
  end.

Definition pwl p : bool :=
  match p with
  | RWLX | RWL => true
  | _ => false
  end.

Definition pwlU p : bool :=
  match p with
  | RWLX | RWL | URWLX | URWL => true
  | _ => false
  end.

Definition executeAllowed (p: Perm): bool :=
  match p with
  | RWX | RWLX | RX | E => true
  | _ => false
  end.

(* Uninitialized capabilities are neither read nor write allowed *)
Definition readAllowed (p: Perm): bool :=
  match p with
  | RWX | RWLX | RX | RW | RWL | RO => true
  | _ => false
  end.

Definition writeAllowed (p: Perm): bool :=
  match p with
  | RWX | RWLX | RW | RWL => true
  | _ => false
  end.

Definition promote_perm (p: Perm): Perm :=
  match p with
  | URW => RW
  | URWL => RWL
  | URWX => RWX
  | URWLX => RWLX
  | _ => p
  end.

Lemma writeA_implies_readA p :
  writeAllowed p = true → readAllowed p = true.
Proof. destruct p; auto. Qed.

Lemma pwl_implies_RWL_RWLX p :
  pwl p = true → p = RWL ∨ p = RWLX.
Proof.
  intros. destruct p; try by exfalso.
  by left. by right.
Qed.

Definition canReadUpTo (w: Word): Addr :=
  match w with
  | inl _ => za
  | inr ((p, g), b, e, a) => match p with
                            | O => za
                            | RO | RW | RWL | RX | RWX | RWLX | E => e
                            | URW | URWL | URWX | URWLX => a
                            end
  end.

Definition canStore (p: Perm) (a: Addr) (w: Word): bool :=
  match w with
  | inl _ => true
  | inr ((_, g), _, _, _) => match g with
                            | Global => true
                            | Local => pwl p
                            | Directed => pwl p && leb_addr (canReadUpTo w) a
                            end
  end.

Definition canStoreU (p: Perm) (a: Addr) (w: Word): bool :=
  match w with
  | inl _ => true
  | inr ((_, g), _, _, _) => match g with
                            | Global => true
                            | Local => pwlU p
                            | Directed => pwlU p && leb_addr (canReadUpTo w) a
                            end
  end.

Definition isPerm p p' := @bool_decide _ (perm_eq_dec p p').

Lemma isPerm_refl p : isPerm p p = true.
Proof. destruct p; auto. Qed.
Lemma isPerm_ne p p' : p ≠ p' → isPerm p p' = false.
Proof. intros Hne. destruct p,p'; auto; congruence. Qed.

Definition isPermWord (w : Word) (p : Perm): bool :=
  match w with
  | inl _ => false
  | inr ((p',_),_,_,_) => isPerm p p'
  end.

Lemma isPermWord_cap_isPerm (w0:Word) p:
  isPermWord w0 p = true →
  ∃ p' g b e a, w0 = inr (p',g,b,e,a) ∧ isPerm p p' = true.
Proof.
  intros. destruct w0;[done|].
  destruct c,p0,p0,p0.
  cbv in H. destruct p; try done;
  eexists _, _, _, _, _; split; eauto.
Qed.

(* perm-flows-to: the locality and permission lattice.
   "x flows to y" if x is lower than y in the lattice.
  *)

Definition LocalityFlowsTo (l1 l2: Locality): bool :=
  match l1 with
  | Directed => true
  | Local => match l2 with
            | Directed => false
            | _ => true
            end
  | Global => match l2 with
             | Global => true
             | _ => false
             end
  end.

(* Sanity check *)
Lemma LocalityFlowsToTransitive:
  transitive _ LocalityFlowsTo.
Proof.
  red; intros; destruct x; destruct y; destruct z; try congruence; auto.
Qed.

(* Sanity check 2 *)
Lemma LocalityFlowsToReflexive:
  forall g, LocalityFlowsTo g g.
Proof.
  intros; destruct g; auto.
Qed.

Definition PermFlowsTo (p1 p2: Perm): bool :=
  match p1 with
  | O => true
  | E => match p2 with
        | E | RX | RWX | RWLX => true
        | _ => false
        end
  | RX => match p2 with
         | RX | RWX | RWLX => true
         | _ => false
         end
  | RWX => match p2 with
          | RWX | RWLX => true
          | _ => false
          end
  | RWLX => match p2 with
           | RWLX => true
           | _ => false
           end
  | RO => match p2 with
         | E | O | URW | URWL | URWX | URWLX => false
         | _ => true
         end
  | RW => match p2 with
         | RW | RWX | RWL | RWLX => true
         | _ => false
         end
  | RWL => match p2 with
          | RWL | RWLX => true
          | _ => false
          end
  | URW => match p2 with
          | URW | URWL | URWX | URWLX | RW | RWX | RWL | RWLX => true
          | _ => false
          end
  | URWL => match p2 with
           | URWL | RWL | RWLX | URWLX => true
           | _ => false
           end
  | URWX => match p2 with
           | URWX | RWX | RWLX | URWLX => true
           | _ => false
           end
  | URWLX => match p2 with
            | URWLX | RWLX => true
            | _ => false
            end
  end.

(* Sanity check *)
Lemma PermFlowsToTransitive:
  transitive _ PermFlowsTo.
Proof.
  red; intros; destruct x; destruct y; destruct z; try congruence; auto.
Qed.

(* Sanity check 2 *)
Lemma PermFlowsToReflexive:
  forall p, PermFlowsTo p p.
Proof.
  intros; destruct p; auto.
Qed.

Definition PermPairFlowsTo (pg1 pg2: Perm * Locality): bool :=
  PermFlowsTo (fst pg1) (fst pg2) && LocalityFlowsTo (snd pg1) (snd pg2).

(* perm-flows-to as a predicate *)
Definition PermFlows : Perm → Perm → Prop :=
  λ p1 p2, PermFlowsTo p1 p2 = true.

Lemma PermFlows_refl : ∀ p, PermFlows p p.
Proof.
  rewrite /PermFlows /PermFlowsTo.
  destruct p; auto.
Qed.

Lemma PermFlows_trans P1 P2 P3 :
  PermFlows P1 P2 → PermFlows P2 P3 → PermFlows P1 P3.
Proof.
  intros Hp1 Hp2. rewrite /PermFlows /PermFlowsTo.
  destruct P1,P3,P2; simpl; auto; contradiction.
Qed.

Lemma readAllowed_nonO p p' :
  PermFlows p p' → readAllowed p = true → p' ≠ O.
Proof.
  intros Hfl' Hra. destruct p'; auto. destruct p; inversion Hfl'. inversion Hra.
Qed.

Lemma writeAllowed_nonO p p' :
  PermFlows p p' → writeAllowed p = true → p' ≠ O.
Proof.
  intros Hfl' Hra. apply writeA_implies_readA in Hra. by apply (readAllowed_nonO p p').
Qed.

Lemma PCPerm_nonO p p' :
  PermFlows p p' → p = RX ∨ p = RWX ∨ p = RWLX → p' ≠ O.
Proof.
  intros Hfl Hvpc. destruct p'; auto. destruct p; inversion Hfl.
  destruct Hvpc as [Hcontr | [Hcontr | Hcontr]]; inversion Hcontr.
Qed.

(* Helper definitions for capabilities *)

(* Turn E into RX into PC after a jump *)
Definition updatePcPerm (w: Word): Word :=
  match w with
  | inr ((E, g), b, e, a) => inr ((RX, g), b, e, a)
  | _ => w
  end.

Lemma updatePcPerm_cap_non_E p g b e a :
  p ≠ E →
  updatePcPerm (inr (p, g, b, e, a)) = inr (p, g, b, e, a).
Proof.
  intros HnE. cbn. destruct p; auto. contradiction.
Qed.

Definition nonZero (w: Word): bool :=
  match w with
  | inr _ => true
  | inl n => Zneq_bool n 0
  end.

Definition cap_size (w : Word) : Z :=
  match w with
  | inr (_,_,b,e,_) => (e - b)%Z
  | _ => 0%Z
  end.

Definition is_cap (w: Word): bool :=
  match w with
  | inr _ => true
  | inl _ => false
  end.

(* Bound checking *)

Definition withinBounds (c: Cap): bool :=
  match c with
  | (_, b, e, a) => (b <=? a)%a && (a <? e)%a
  end.

Lemma withinBounds_true_iff p g b e a :
  withinBounds (p, g, b, e, a) = true ↔ (b <= a)%a ∧ (a < e)%a.
Proof.
  unfold withinBounds.
  rewrite /le_addr /lt_addr /leb_addr /ltb_addr.
  rewrite andb_true_iff Z.leb_le Z.ltb_lt. auto.
Qed.

Lemma withinBounds_le_addr p l b e a:
  withinBounds (p, l, b, e, a) = true →
  (b <= a)%a ∧ (a < e)%a.
Proof. rewrite withinBounds_true_iff //. Qed.

Lemma isWithinBounds_bounds_alt p g b e (a0 a1 a2 : Addr) :
  withinBounds (p,g,b,e,a0) = true →
  withinBounds (p,g,b,e,a2) = true →
  (a0 ≤ a1)%Z ∧ (a1 ≤ a2)%Z →
  withinBounds (p,g,b,e,a1) = true.
Proof. rewrite !withinBounds_true_iff. solve_addr. Qed.

Lemma isWithinBounds_bounds_alt' p g b e (a0 a1 a2 : Addr) :
  withinBounds (p,g,b,e,a0) = true →
  withinBounds (p,g,b,e,a2) = true →
  (a0 ≤ a1)%Z ∧ (a1 < a2)%Z →
  withinBounds (p,g,b,e,a1) = true.
Proof. rewrite !withinBounds_true_iff. solve_addr. Qed.

Lemma le_addr_withinBounds p l b e a:
  (b <= a)%a → (a < e)%a →
  withinBounds (p, l, b, e, a) = true .
Proof. rewrite withinBounds_true_iff //. Qed.

(* isCorrectPC: valid capabilities for PC *)

Inductive isCorrectPC: Word → Prop :=
| isCorrectPC_intro:
    forall p g (b e a : Addr),
      (b <= a < e)%a →
      p = RX \/ p = RWX \/ p = RWLX →
      isCorrectPC (inr ((p, g), b, e, a)).

Lemma isCorrectPC_dec:
  forall w, { isCorrectPC w } + { not (isCorrectPC w) }.
Proof.
  destruct w.
  - right. red; intros H. inversion H.
  - destruct c as ((((p & g) & b) & e) & a).
    case_eq (match p with RX | RWX | RWLX => true | _ => false end); intros.
    + destruct (Addr_le_dec b a).
      * destruct (Addr_lt_dec a e).
        { left. econstructor; simpl; eauto. by auto.
          destruct p; naive_solver. }
        { right. red; intro HH. inversion HH; subst. solve_addr. }
      * right. red; intros HH; inversion HH; subst. solve_addr.
    + right. red; intros HH; inversion HH; subst. naive_solver.
Qed.

Definition isCorrectPCb (w: Word): bool :=
  match w with
  | inl _ => false
  | inr (p, g, b, e, a) =>
    (b <=? a)%a && (a <? e)%a &&
    (isPerm p RX || isPerm p RWX || isPerm p RWLX)
  end.

Lemma isCorrectPCb_isCorrectPC w :
  isCorrectPCb w = true ↔ isCorrectPC w.
Proof.
  rewrite /isCorrectPCb. destruct w.
  { split; try congruence. inversion 1. }
  { destruct c as [[[[? ?] ?] ?] ?]. rewrite /leb_addr /ltb_addr.
    rewrite !andb_true_iff !orb_true_iff !Z.leb_le !Z.ltb_lt.
    rewrite /isPerm !bool_decide_eq_true.
    split.
    { intros [? ?]. constructor. solve_addr. naive_solver. }
    { inversion 1; subst. split. solve_addr. naive_solver. } }
Qed.

Lemma isCorrectPCb_nisCorrectPC w :
  isCorrectPCb w = false ↔ ¬ isCorrectPC w.
Proof.
  destruct (isCorrectPCb w) eqn:HH.
  { apply isCorrectPCb_isCorrectPC in HH. split; congruence. }
  { split; auto. intros _. intros ?%isCorrectPCb_isCorrectPC. congruence. }
Qed.

Lemma isCorrectPC_ra_wb pc_p pc_g pc_b pc_e pc_a :
  isCorrectPC (inr ((pc_p,pc_g),pc_b,pc_e,pc_a)) →
  readAllowed pc_p && ((pc_b <=? pc_a)%a && (pc_a <? pc_e)%a).
Proof.
  intros. inversion H; subst.
  - destruct H2. apply andb_prop_intro. split.
    + destruct H6,pc_p; inversion H1; try inversion H2; auto; try congruence.
    + apply andb_prop_intro.
      split; apply Is_true_eq_left; [apply Z.leb_le | apply Z.ltb_lt]; lia.
Qed.

Lemma not_isCorrectPC_perm p g b e a :
  p ≠ RX ∧ p ≠ RWX ∧ p ≠ RWLX → ¬ isCorrectPC (inr ((p,g),b,e,a)).
Proof.
  intros (Hrx & Hrwx & Hrwlx).
  intros Hvpc. inversion Hvpc;
    destruct H5 as [Hrx' | [Hrwx' | Hrwlx']]; contradiction.
Qed.

Lemma not_isCorrectPC_bounds p g b e a :
 ¬ (b <= a < e)%a → ¬ isCorrectPC (inr ((p,g),b,e,a)).
Proof.
  intros Hbounds.
  intros Hvpc. inversion Hvpc.
  by exfalso.
Qed.

Lemma isCorrectPC_bounds p g b e (a0 a1 a2 : Addr) :
  isCorrectPC (inr (p, g, b, e, a0)) →
  isCorrectPC (inr (p, g, b, e, a2)) →
  (a0 ≤ a1 < a2)%Z → isCorrectPC (inr (p, g, b, e, a1)).
Proof.
  intros Hvpc0 Hvpc2 [Hle Hlt].
  inversion Hvpc0.
  - subst; econstructor; auto.
    inversion Hvpc2; subst.
    + destruct H1 as [Hb He]. destruct H2 as [Hb2 He2]. split.
      { apply Z.le_trans with a0; auto. }
      { apply Z.lt_trans with a2; auto. }
Qed.

Lemma isCorrectPC_bounds_alt p g b e (a0 a1 a2 : Addr) :
  isCorrectPC (inr (p, g, b, e, a0))
  → isCorrectPC (inr (p, g, b, e, a2))
  → (a0 ≤ a1)%Z ∧ (a1 ≤ a2)%Z
  → isCorrectPC (inr (p, g, b, e, a1)).
Proof.
  intros Hvpc0 Hvpc2 [Hle0 Hle2].
  apply Z.lt_eq_cases in Hle2 as [Hlt2 | Heq2].
  - apply isCorrectPC_bounds with a0 a2; auto.
  - apply z_of_eq in Heq2. rewrite Heq2. auto.
Qed.

Lemma isCorrectPC_withinBounds p g p' g' b e a :
  isCorrectPC (inr (p, g, b, e, a)) →
  withinBounds (p', g', b, e, a) = true.
Proof.
  intros HH. inversion HH; subst.
  rewrite /withinBounds !andb_true_iff Z.leb_le Z.ltb_lt. auto.
Qed.

Lemma correctPC_nonO p p' g b e a :
  PermFlows p p' → isCorrectPC (inr (p,g,b,e,a)) → p' ≠ O.
Proof.
  intros Hfl HcPC. inversion HcPC. by apply (PCPerm_nonO p p').
Qed.

Lemma in_range_is_correctPC p l b e a b' e' :
  isCorrectPC (inr ((p,l),b,e,a)) →
  (b' <= b)%a ∧ (e <= e')%a →
  (b' <= a)%a ∧ (a < e')%a.
Proof.
  intros Hvpc [Hb He].
  inversion Hvpc; simplify_eq. solve_addr.
Qed.

(* Helper tactics *)

Ltac destruct_pair_l c n :=
  match eval compute in n with
  | 0 => idtac
  | _ => let sndn := fresh c in
        destruct c as (c,sndn); destruct_pair_l c (pred n)
  end.

Ltac destruct_cap c :=
  destruct_pair_l c 4.

(* Useful instances *)

Instance perm_countable : Countable Perm.
Proof.
  set encode := fun p => match p with
    | O => 1
    | RO => 2
    | RW => 3
    | RWL => 4
    | RX => 5
    | E => 6
    | RWX => 7
    | RWLX => 8
    | URW => 9
    | URWL => 10
    | URWX => 11
    | URWLX => 12
    end%positive.
  set decode := fun n => match n with
    | 1 => Some O
    | 2 => Some RO
    | 3 => Some RW
    | 4 => Some RWL
    | 5 => Some RX
    | 6 => Some E
    | 7 => Some RWX
    | 8 => Some RWLX
    | 9 => Some URW
    | 10 => Some URWL
    | 11 => Some URWX
    | 12 => Some URWLX
    | _ => None
    end%positive.
  eapply (Build_Countable _ _ encode decode).
  intro p. destruct p; reflexivity.
Defined.

Instance locality_countable : Countable Locality.
Proof.
  set encode := fun l => match l with
    | Local => 1
    | Global => 2
    | Directed => 3
    end%positive.
  set decode := fun n => match n with
    | 1 => Some Local
    | 2 => Some Global
    | 3 => Some Directed
    | _ => None
    end%positive.
  eapply (Build_Countable _ _ encode decode).
  intro l. destruct l; reflexivity.
Defined.

Instance cap_countable : Countable Cap.
Proof.
  (* NB: this relies on the fact that cap_eq_dec has been Defined, because the
  eq decision we have for Cap has to match the one used in the conclusion of the
  lemma... *)
  apply prod_countable.
Defined.

Instance word_countable : Countable Word.
Proof. apply sum_countable. Defined.

Instance instr_countable : Countable instr.
Proof.
  set (enc := fun e =>
      match e with
      | Jmp r => GenNode 0 [GenLeaf (inl r)]
      | Jnz r1 r2 => GenNode 1 [GenLeaf (inl r1); GenLeaf (inl r2)]
      | Mov dst src => GenNode 2 [GenLeaf (inl dst); GenLeaf (inr src)]
      | Load dst src => GenNode 3 [GenLeaf (inl dst); GenLeaf (inl src)]
      | Store dst src => GenNode 4 [GenLeaf (inl dst); GenLeaf (inr src)]
      | Lt dst r1 r2 => GenNode 5 [GenLeaf (inl dst); GenLeaf (inr r1); GenLeaf (inr r2)]
      | Add dst r1 r2 => GenNode 6 [GenLeaf (inl dst); GenLeaf (inr r1); GenLeaf (inr r2)]
      | Sub dst r1 r2 => GenNode 7 [GenLeaf (inl dst); GenLeaf (inr r1); GenLeaf (inr r2)]
      | Lea dst r => GenNode 8 [GenLeaf (inl dst); GenLeaf (inr r)]
      | Restrict dst r => GenNode 9 [GenLeaf (inl dst); GenLeaf (inr r)]
      | Subseg dst r1 r2 => GenNode 10 [GenLeaf (inl dst); GenLeaf (inr r1); GenLeaf (inr r2)]
      | IsPtr dst r => GenNode 11 [GenLeaf (inl dst); GenLeaf (inl r)]
      | GetL dst r => GenNode 12 [GenLeaf (inl dst); GenLeaf (inl r)]
      | GetP dst r => GenNode 13 [GenLeaf (inl dst); GenLeaf (inl r)]
      | GetB dst r => GenNode 14 [GenLeaf (inl dst); GenLeaf (inl r)]
      | GetE dst r => GenNode 15 [GenLeaf (inl dst); GenLeaf (inl r)]
      | GetA dst r => GenNode 16 [GenLeaf (inl dst); GenLeaf (inl r)]
      | Fail => GenNode 17 []
      | Halt => GenNode 18 []
      | LoadU dst src offs => GenNode 19 [GenLeaf (inl dst); GenLeaf (inl src); GenLeaf (inr offs)]
      | StoreU dst offs src => GenNode 20 [GenLeaf (inl dst); GenLeaf (inr offs); GenLeaf (inr src)]
      | PromoteU dst => GenNode 21 [GenLeaf (inl dst)]
      end).
  set (dec := fun e =>
      match e with
      | GenNode 0 [GenLeaf (inl r)] => Jmp r
      | GenNode 1 [GenLeaf (inl r1); GenLeaf (inl r2)] => Jnz r1 r2
      | GenNode 2 [GenLeaf (inl dst); GenLeaf (inr src)] => Mov dst src
      | GenNode 3 [GenLeaf (inl dst); GenLeaf (inl src)] => Load dst src
      | GenNode 4 [GenLeaf (inl dst); GenLeaf (inr src)] => Store dst src
      | GenNode 5 [GenLeaf (inl dst); GenLeaf (inr r1); GenLeaf (inr r2)] => Lt dst r1 r2
      | GenNode 6 [GenLeaf (inl dst); GenLeaf (inr r1); GenLeaf (inr r2)] => Add dst r1 r2
      | GenNode 7 [GenLeaf (inl dst); GenLeaf (inr r1); GenLeaf (inr r2)] => Sub dst r1 r2
      | GenNode 8 [GenLeaf (inl dst); GenLeaf (inr r)] => Lea dst r
      | GenNode 9 [GenLeaf (inl dst); GenLeaf (inr r)] => Restrict dst r
      | GenNode 10 [GenLeaf (inl dst); GenLeaf (inr r1); GenLeaf (inr r2)] => Subseg dst r1 r2
      | GenNode 11 [GenLeaf (inl dst); GenLeaf (inl r)] => IsPtr dst r
      | GenNode 12 [GenLeaf (inl dst); GenLeaf (inl r)] => GetL dst r
      | GenNode 13 [GenLeaf (inl dst); GenLeaf (inl r)] => GetP dst r
      | GenNode 14 [GenLeaf (inl dst); GenLeaf (inl r)] => GetB dst r
      | GenNode 15 [GenLeaf (inl dst); GenLeaf (inl r)] => GetE dst r
      | GenNode 16 [GenLeaf (inl dst); GenLeaf (inl r)] => GetA dst r
      | GenNode 17 [] => Fail
      | GenNode 18 [] => Halt
      | GenNode 19 [GenLeaf (inl dst); GenLeaf (inl src); GenLeaf (inr offs)] => LoadU dst src offs
      | GenNode 20 [GenLeaf (inl dst); GenLeaf (inr offs); GenLeaf (inr src)] => StoreU dst offs src
      | GenNode 21 [GenLeaf (inl dst)] => PromoteU dst
      | _ => Fail (* dummy *)
      end).
  refine (inj_countable' enc dec _).
  intros i. destruct i; simpl; done.
Defined.


Set Implicit Arguments.

Require Import ADT.
Require Import RepInv.

Module Make (Import E : ADT) (Import M : RepInv E).

  Require Import PostOk.
  Module Import PostOkMake := Make E M.
  Require Import VerifCondOk.
  Module Import VerifCondOkMake := Make E M.
  Import CompileStmtSpecMake.
  Import InvMake.
  Import Semantics.
  Import SemanticsMake.
  Import InvMake2.

  Section TopSection.

    Require Import AutoSep.

    Variable vars : list string.

    Variable temp_size : nat.

    Variable imports : LabelMap.t assert.

    Variable imports_global : importsGlobal imports.

    Variable modName : string.

    Require Import Syntax.

    Variable rv_postcond : W -> vals -> Prop.

    Notation do_compile := (CompileStmtImplMake.compile vars temp_size rv_postcond imports_global modName).

    Variable s k : Stmt.

    Require Import Wrap.
    Definition compile : cmd imports modName.
      refine (
          Wrap imports imports_global modName
               (do_compile s k)
               (fun _ => postcond vars temp_size k rv_postcond)
               (verifCond vars temp_size s k rv_postcond)
               _ _).
      eapply post_ok.
      eapply verifCond_ok.
    Defined.

  End TopSection.

End Make.