  (***************************************************************)
  (*   This file is part of the static analyses developement -   *)
  (*   specification of kildall's algorithm, and proof it is a   *)
  (*   bytecode verifier -                                       *)
  (*							         *)
  (*   File : machine_types.v				         *)
  (*   Authors : S. Coupet-Grimal, W. Delobel 		         *)
  (*   Content : Type verification                               *)
  (***************************************************************)

Section machine_types.

  Require Export machine.
  Require Export typing.
  Require Export inst_types.

  Notation configuration := (list frame).
  Notation Get_function := (get_function_by_name functions).
  Notation Get_constr := (get_constr_by_name constructors).
  Notation Frm := (mkframe).

  (* initial function state = [(Types argsuments_types); bot;...; bot] *)
  Definition ss_init (fcn : function) :=
    (constant_list (fcn_size fcn) Bot_T)[0<-(Types (rev (fcn_args fcn)))].

  (* result of type analysis algorithm run on the initial function state *)
  Definition Kildall_Types (fcn : function) (Hin : In fcn functions) :=
    Kildall_types fcn (lrs_functions fcn Hin) (ss_init fcn).

  (* every function in the list functions passed type verification *)
  Hypothesis Passed_Kildall : forall (fcn : function) (Hin : In fcn functions),
    ~ Top_T INv (Kildall_Types fcn Hin).

  (* definition of a well-typed frame : type of the elements in the stack are those computed by Kildall_types *)
  Definition welltyped_frame (f : frame) : Prop :=
    forall (fcn : function) (Hget : Get_function (frm_fun f) = Some fcn)
      (C : (frm_pc f) < (fcn_size fcn)),
      stack_typing (frm_stack f) ((Kildall_Types fcn (get_some_in_functions fcn (frm_fun f) functions Hget))[frm_pc f|C]).

  (* extention of well-typedness to configurations *)
  Inductive welltyped_configuration : configuration -> Prop :=
    welltyped_conf : forall (M : configuration) , wellformed_configuration M ->
      (* top frame well typed *)
      (forall (f : frame), element_at_list M 0 = Some f -> welltyped_frame f) /\
      (* stack i @ args i-1 well typed *)
      (forall (i : nat) (fi fpi : frame),
        element_at_list M i = Some fi -> element_at_list M (S i) = Some fpi ->
        welltyped_frame (Frm (frm_fun fpi) (frm_pc fpi) ((frm_args fi)++(frm_stack fpi)) (frm_args fpi))) ->
      welltyped_configuration M.

  (* type verifications algorithm produces a function state ss for which, for all p<|ss|, Wti ss p holds *)

  Lemma Wti_Kildall : forall (fcn : function) (Hin : In fcn functions) (p : nat) (C : p < (fcn_size fcn)),
    Wti fcn (Kildall_Types fcn Hin) p C.
  Proof.
    intros fcn Hin p C.
(*    apply (top_free_to_wti Sigma (fcn_size fcn)
      (Succs ((fcn_size fcn)) (fcn_bytecode fcn) (lrs_functions fcn Hin))
      (Step fcn) (Wti fcn) r (Top_T) f (Step_Succs_same_length fcn (lrs_functions fcn Hin))
      eq_Sigma_dec r_is_semilattice wfr (Succs_equiv (fcn_size fcn) (fcn_bytecode fcn) (lrs_functions fcn Hin))
      (Step_equiv fcn) (monotone_Step fcn)).*)
    generalize (monotone_step_imp_kildall_dfa Sigma (fcn_size fcn)
      (Succs ((fcn_size fcn)) (fcn_bytecode fcn) (lrs_functions fcn Hin))
      (Step fcn) r f (Step_Succs_same_length fcn (lrs_functions fcn Hin))
      eq_Sigma_dec r_is_semilattice wfr
      (Succs_equiv (fcn_size fcn) (fcn_bytecode fcn) (lrs_functions fcn Hin))
      (Step_equiv fcn) (monotone_Step fcn) (ss_init fcn)).
    unfold Is_data_flow_analyser;  unfold Kildall_Types.
    intro is_dfa; elim is_dfa; clear is_dfa; intros dfa1 H.
    elim H; clear H; intros dfa2 H; clear H.
    apply (stable_imp_Wti fcn (lrs_functions fcn Hin)).
    apply (Passed_Kildall fcn Hin).
    apply dfa1.
  Qed.

  (* state of the entry point is left unchanged by algorithm Kildall_types *)
  Lemma Kildall_Types_0 : forall (fcn : function) (Hin : In fcn functions),
    (Kildall_Types fcn Hin)[0|nonvoidfcn fcn Hin] =
    (ss_init fcn)[0|nonvoidfcn fcn Hin].
  Proof.
    intros fcn Hin.
    generalize (monotone_step_imp_kildall_dfa Sigma (fcn_size fcn)
      (Succs ((fcn_size fcn)) (fcn_bytecode fcn) (lrs_functions fcn Hin))
      (Step fcn) r f (Step_Succs_same_length fcn (lrs_functions fcn Hin))
      eq_Sigma_dec r_is_semilattice wfr
      (Succs_equiv (fcn_size fcn) (fcn_bytecode fcn) (lrs_functions fcn Hin))
      (Step_equiv fcn) (monotone_Step fcn) (ss_init fcn)).
    unfold Is_data_flow_analyser.
    intro is_dfa; elim is_dfa; clear is_dfa; intros dfa1 H.
    elim H; clear H; intros dfa2 dfa3.
    cut (r ((ss_init fcn)[0|nonvoidfcn fcn Hin])
      ((Kildall_Types fcn Hin)[0|nonvoidfcn fcn Hin])).
    intro Hr.
    CaseEq ((Kildall_Types fcn Hin)[0|nonvoidfcn fcn Hin]).
  (* case (Kildall_Types fcn)[0] = Top_T : contradiction  with passed_kildall *)
    intro case; elim (Passed_Kildall fcn Hin); rewrite <- case; apply element_at_belong.
  (* case (Kildall_Types fcn)[0] = Bot_T, impossible with Hr and definition of ss_init *)
    intro case; generalize Hr; clear Hr; rewrite case.
    intro Hr; destruct ((ss_init fcn)[0|nonvoidfcn fcn Hin]); inversion Hr.
    trivial.
    intros l case.
    generalize Hr; clear Hr; rewrite case.
    unfold ss_init.
    rewrite element_at_in_replaced.
    intro Hr; inversion Hr.
    trivial.
    unfold Kildall_Types; generalize dfa2; unfold Vector_pointwise; apply vector_pointwise_to_element.
  Qed.

  Lemma red_return_keeps_welltyped : forall (M0 : configuration) (f g : frame) (fcn : function)
    (v0 : value) (l : list value),
    Get_function (frm_fun f) = Some fcn ->
    (fcn_bytecode fcn)[frm_pc f|_] = Some (i_return (fcn_size fcn)) ->
    frm_stack f = v0 :: l -> wellformed_configuration (f :: g :: M0) ->
    reduction (f :: g :: M0)
    (mkframe (frm_fun g) (S (frm_pc g)) (v0 :: frm_stack g) (frm_args g) :: M0) ->
    welltyped_frame f ->  (forall (i : nat) (fi fpi : frame),
      element_at_list (f :: g :: M0) i = Some fi ->
      element_at_list (f :: g :: M0) (S i) = Some fpi ->
      welltyped_frame
      (mkframe (frm_fun fpi) (frm_pc fpi)
        (frm_args fi ++ frm_stack fpi)(frm_args fpi))) ->
    welltyped_configuration
    (mkframe (frm_fun g) (S (frm_pc g)) (v0 :: frm_stack g) (frm_args g) :: M0).
  Proof.
    intros M0 f g fcn v0 l Hfcn case_instr Hstack Hwf Hred Hwttop Hwtvirtual.
    constructor.
  (* M' is well-formed : *)
    apply (reduction_keeps_wellformed (f::g::M0)); trivial.
    cut (element_at_list (f :: g :: M0) 0 = Some f); [intro H1 | simpl; trivial].
    cut (element_at_list (f :: g :: M0) (S 0) = Some g); [intro H1' | simpl; trivial].
    split.
  (* top frame of M is well-typed : *)
    intros f' Hf' fcn' Hfcn' C.
    inversion Hf'; subst f'; trivial.
    cut (frm_pc g < fcn_size fcn'); [intro C' | generalize C; auto with arith].
    generalize (Hwtvirtual 0 f g H1 H1' fcn' Hfcn' C'); simpl.
    generalize (Passed_Kildall fcn' (get_some_in_functions fcn' (frm_fun g) functions Hfcn')); intro notop'.
    generalize (Wti_Kildall fcn' (get_some_in_functions fcn' (frm_fun g) functions Hfcn') (frm_pc g) C').
    unfold Wti.
    CaseEq ((Kildall_Types fcn' (get_some_in_functions fcn' (frm_fun g) functions Hfcn'))[frm_pc g|C']).
    (* case (Kildall_Types fcn')[pcg] = Top_T *)
    intro case; elim notop'; rewrite <- case; apply element_at_belong.
  (* case (Kildall_Types fcn')[pcg] = Bot_T *)
    unfold stack_typing; simpl.
    intros case dd F; inversion F.
  (* case (Kildall_Types fcn')[pcg] = Types l' *)
    intros l' casel'.
    cut ((fcn_bytecode fcn')[frm_pc g|C'] =
      i_call (fcn'.(fcn_size)) ((frm_fun f)) (length (frm_args f))).
    intro Hcall; rewrite Hcall; simpl. (* frame g created frame f *)
    CaseEq (split_k_elements (length (frm_args f)) l'); [idtac | intros dd F; inversion F].
    intros p casesplit; destruct p as [lk lr].
    rewrite Hfcn; simpl.
    elim (eq_list_name_dec (rev lk) (fcn_args fcn)); [intro caseeq | intros dd F; inversion F].
    CaseEq (element_at_unsafe (Kildall_Types fcn'
      (get_some_in_functions  fcn' (frm_fun g) functions Hfcn')) (S (frm_pc g)));
    [intros s casegS | intros dd F; inversion F].
    destruct s.
    intro F; inversion F.
    intro F; inversion F.
    elim (eq_list_name_dec  ((fcn_ret fcn) :: lr) l0); intros caseeq' F; [clear F | inversion F].
    rewrite (element_at_unsafe_to_safe Sigma (fcn_size fcn')
      (Kildall_Types fcn' (get_some_in_functions  fcn' (frm_fun g) functions Hfcn'))
      (S (frm_pc g)) C (Types l0) casegS).
    subst l0; simpl.
    generalize (split_k_elements_ok name (length (frm_args f)) l' lk lr casesplit); intro; subst l'.
    intro surtype.
    assert (H_return_type : tree_typing v0 (fcn_ret fcn)).
    (* return type *)
    cut (frm_pc f < fcn_size fcn); [intro Cf | generalize case_instr; apply element_at_unsafe_some].
    generalize (Hwttop fcn Hfcn Cf). (* frame f is well-typed *)
    rewrite Hstack.
    generalize (Wti_Kildall fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn) (frm_pc f) Cf).
    unfold Wti.
    generalize (Passed_Kildall fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn)); intros notopf.
    CaseEq ((Kildall_Types fcn (get_some_in_functions fcn (frm_fun f) functions Hfcn))[frm_pc f|Cf]).
    intros h F; inversion F.
    unfold stack_typing; simpl; intros case dd F; inversion F.
    intros l2 casef.
    cut ((fcn_bytecode fcn)[frm_pc f|Cf] = i_return (fcn_size fcn));
      [intro case_f_pc | generalize case_instr; apply element_at_unsafe_to_safe].
    rewrite case_f_pc; simpl.
    destruct l2; simpl.
    intro F; inversion F.
    elim (eq_name_dec n (fcn_ret fcn)); intros caseeqf F; [clear F | inversion F] .
    subst n; intro h; inversion h.
    constructor 2 with const; trivial.
    constructor.
    assert (H_stack_g : tree_list_typing (frm_stack g) lr).
    (* stack g : *)
    generalize surtype; apply sub_list_typing_right.
    symmetry; apply (split_k_elements_length name (length (frm_args f)) (lk ++ lr) lk lr); assumption.
    apply cons_list_typing; trivial.
    (* from call *)
    cut (element_at_list (f :: g :: M0) 0 = Some f); [intro Hfin | simpl; trivial].
    elim (Hwf 0 f g fcn fcn' Hfin); clear Hwf; intros dd Hwf.
    elim (Hwf Hfcn); clear dd Hwf; intros dd Hwf.
    apply element_at_unsafe_to_safe.
    apply Hwf; simpl; trivial.
    (* Part 2 : virtual frames in M' are well-typed *)
    intros i fi fpi Hfi Hfpi.
    destruct i.
  (* i = 0 *)
    simpl in Hwttop; simpl in Hwtvirtual.
    cut (element_at_list (f :: g :: M0) 1 = Some g); [intro Hgin | simpl; trivial].
    cut (element_at_list (f :: g :: M0) 2 = Some fpi);
      [intro Hfpiin | simpl; simpl in Hfpi; rewrite Hfpi; trivial].
    generalize (Hwtvirtual 1 g fpi Hgin Hfpiin).
    inversion Hfi.
    cut (frm_args g = frm_args fi); [intro h; rewrite h; trivial | inversion Hfi; trivial].
  (* i > 0 *)
    apply (Hwtvirtual (S (S i)) fi fpi).
    simpl; simpl in Hfi.
    rewrite Hfi; simpl; trivial.
    simpl; simpl in Hfpi.
    rewrite Hfpi; simpl; trivial.
  Qed.

  Lemma red_load_keeps_welltyped : forall (M0 : configuration) (f : frame) (fcn : function)
    (j : nat) (vj : value),
    Get_function (frm_fun f) = Some fcn ->
    (fcn_bytecode fcn)[frm_pc f|_] = Some (i_load (fcn_size fcn) j) ->
    element_at_list (rev_lin (frm_stack f)) j = Some vj ->
    wellformed_configuration (f :: M0) ->
    reduction (f :: M0)
    (mkframe (frm_fun f) (S (frm_pc f)) (vj :: frm_stack f) (frm_args f) :: M0) ->
    welltyped_frame f -> (forall (i : nat) (fi fpi : frame),
      element_at_list (f :: M0) i = Some fi ->
      element_at_list (f :: M0) (S i) = Some fpi ->
      welltyped_frame
      (mkframe (frm_fun fpi) (frm_pc fpi)
        (frm_args fi ++ frm_stack fpi) (frm_args fpi))) ->
    welltyped_configuration
    (mkframe (frm_fun f) (S (frm_pc f)) (vj :: frm_stack f) (frm_args f) :: M0).
  Proof.
    intros M0 f fcn j vj Hfcn case_instr Hvj Hwf Hred Hwttop Hwtvirtual.
    split.
  (* M' is well-formed *)
    apply (reduction_keeps_wellformed (f::M0)); trivial.
    split.
  (* top frame well-typed *)
    generalize Hwttop; unfold welltyped_frame; simpl.
    clear Hwttop; intros Hwttop f' Hf' fcn' Hfcn' C.
    inversion Hf'; subst f'; clear Hf'.
    cut (frm_pc f < fcn_size fcn'); [intro C' | generalize C; auto with arith].
    generalize (Hwttop fcn' Hfcn' C'); clear Hwttop.
    generalize (Wti_Kildall fcn' (get_some_in_functions  fcn' (frm_fun f) functions Hfcn') (frm_pc f) C').
    unfold Wti.
    generalize (Passed_Kildall fcn' (get_some_in_functions  fcn' (frm_fun f) functions Hfcn'));
      intros notop'.
    CaseEq ((Kildall_Types fcn' (get_some_in_functions fcn' (frm_fun f) functions Hfcn'))[frm_pc f|C']).
  (* (Kidall_Types fcn')[pc f] = Top_T *)
    intros case F; inversion F.
  (* (Kidall_Types fcn')[pc f] = Bot_T *)
    unfold stack_typing; simpl; intros case dd F; inversion F.
  (* (Kidall_Types fcn')[pc f] = Types l *)
    intros l case.
    cut ((fcn_bytecode fcn')[frm_pc f|C'] = i_load (fcn_size fcn') j).
    intro case_load; rewrite case_load; simpl.
    CaseEq (element_at_unsafe (Kildall_Types fcn'
      (get_some_in_functions  fcn' (frm_fun f) functions Hfcn')) (S (frm_pc f)));
    [intros s caseS; destruct s | intros dd F; inversion F].
    intro F; inversion F.
    intro F; inversion F.
    CaseEq (element_at_list (rev l) j); [intros tj casetj | intros dd F; inversion F].
    elim (eq_list_name_dec  (tj :: l) l0); intros case' F; [clear F | inversion F].
    rewrite (element_at_unsafe_to_safe Sigma (fcn_size fcn')
      (Kildall_Types fcn' (get_some_in_functions  fcn' (frm_fun f) functions Hfcn'))
      (S (frm_pc f)) C (Types l0) caseS).
    subst l0; simpl.
    intro h; apply cons_list_typing; [idtac | assumption].
    apply (element_at_list_typing j (rev (frm_stack f)) (rev l)).
    rewrite <- rev_lin_is_rev; rewrite <- rev_lin_is_rev.
    apply rev_list_typing.
    assumption.
    assumption.
    rewrite <- rev_lin_is_rev; assumption.
    apply element_at_unsafe_to_safe.
    simpl in Hfcn'; rewrite Hfcn' in Hfcn; inversion Hfcn; subst fcn'; assumption.
    (* Part 2 : virtual frames from M' are well-typed *)
    intros i fi fpi Hfi Hfpi.
    destruct i.
    cut (element_at_list (f :: M0) 0 = Some f); [intro Hf | simpl; trivial].
    cut (element_at_list (f :: M0) 1 = Some fpi).
    intro Hfpi'; generalize (Hwtvirtual 0 f fpi Hf Hfpi').
    replace (frm_args f) with (frm_args fi).
    trivial.
    simpl in Hfi.
    inversion Hfi.
    simpl; trivial.
    simpl; simpl in Hfpi.
    rewrite Hfpi.
    trivial.
    cut (element_at_list (f :: M0) (S i) = Some fi).
    cut (element_at_list (f :: M0) (S (S i)) = Some fpi).
    intros Hfpi' Hfi'.
    apply (Hwtvirtual (S i) fi fpi Hfi' Hfpi').
    simpl; simpl in Hfpi.
    assumption.
    simpl; simpl in Hfi; assumption.
  Qed.

  Lemma red_call_keeps_welltyped : forall (M0 : configuration) (f : frame) (fcn gcn : function)
    (gnm : name) (gar : nat) (vargs l : list value),
    Get_function (frm_fun f) = Some fcn->
    (fcn_bytecode fcn)[frm_pc f|_] = Some (i_call (fcn_size fcn) gnm gar) ->
    Get_function gnm = Some gcn -> split_k_elements gar (frm_stack f) = Some (vargs, l)->
    wellformed_configuration (f :: M0)->
    reduction (f :: M0)
    (mkframe gnm 0 vargs vargs :: mkframe (frm_fun f) (frm_pc f) l (frm_args f) :: M0) ->
    welltyped_frame f -> (forall (i : nat) (fi fpi : frame),
      element_at_list (f :: M0) i = Some fi ->
      element_at_list (f :: M0) (S i) = Some fpi ->
      welltyped_frame (mkframe (frm_fun fpi) (frm_pc fpi)
        (frm_args fi ++ frm_stack fpi) (frm_args fpi))) ->
    welltyped_configuration (mkframe gnm 0 vargs vargs
      :: mkframe (frm_fun f) (frm_pc f) l (frm_args f) :: M0).
  Proof.
    intros M0 f fcn gcn gnm gar vargs l Hfcn case_instr Hgcn case_split_stack Hwf Hred Hwttop Hwtvirtual.
    constructor.
  (* M' is well-formed : *)
    apply (reduction_keeps_wellformed (f::M0)); trivial.
    split.
  (* top frame of M' is well-typed : *)
    unfold welltyped_frame.
    simpl; intros f' Hf' fcn' Hfcn' C.
    inversion Hf'; subst f'; clear Hf'; simpl.
    rewrite (element_at_irrel Sigma (fcn_size fcn')
      (Kildall_Types fcn' (get_some_in_functions  fcn' gnm functions Hfcn'))
      0 C (nonvoidfcn fcn' (get_some_in_functions  fcn' gnm functions Hfcn'))).
    rewrite (Kildall_Types_0 fcn' (get_some_in_functions  fcn' gnm functions Hfcn')).
    unfold ss_init.
    rewrite element_at_in_replaced.
    unfold welltyped_frame in Hwttop.
    cut (frm_pc f < fcn_size fcn); [intro Cf | generalize case_instr; apply element_at_unsafe_some].
    generalize (Hwttop fcn Hfcn Cf).
    generalize (Wti_Kildall fcn (get_some_in_functions fcn (frm_fun f) functions Hfcn) (frm_pc f) Cf).
    unfold Wti.
    CaseEq ((Kildall_Types fcn (get_some_in_functions fcn (frm_fun f) functions Hfcn))[frm_pc f|Cf]).
  (* case (Kildall_Types)fcn [pc f] = Top_T *)
    intros dd F; inversion F.
  (* case (Kildall_Types)fcn [pc f] = Bot_T *)
    generalize (Passed_Kildall fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn)); intros P1 case.
    unfold stack_typing; simpl; intros dd F; inversion F.
  (* case (Kildall_Types)fcn [pc f] = Types l0 *)
    intros l0 case.
    replace ((fcn_bytecode fcn)[frm_pc f|Cf]) with (i_call (fcn_size fcn) gnm gar).
    CaseEq (split_k_elements gar l0);
    [intros p case_split; destruct p as [lk lr]| intros dd F; inversion F].
    simpl in Hfcn'; (rewrite Hfcn').
    elim (eq_list_name_dec  (rev lk) (fcn_args fcn')); intros case' F; [clear F | inversion F].
    cut (l0 = lk ++ lr); [intro Hl0 | generalize case_split; apply split_k_elements_ok].
    subst l0.
    cut (frm_stack f = vargs ++ l); [intro Hstack | generalize case_split_stack; apply split_k_elements_ok].
    rewrite Hstack.
    unfold stack_typing.
    rewrite <- case'.
    rewrite rev_involutive.
    apply sub_list_typing_left.
    cut (length lk = gar);
      [intro dd; rewrite dd; clear dd | generalize case_split; apply split_k_elements_length].
    generalize case_split_stack; apply split_k_elements_length.
    symmetry; generalize case_instr; apply element_at_unsafe_to_safe.
    (* part 2 : virtual frames from M' are well-typed *)
    intros i fi fpi.
    destruct i; simpl.
  (* i = 0 *)
    intros Hfi Hfpi; inversion Hfi; inversion Hfpi.
    subst fi fpi.
    simpl.
    rewrite <- (split_k_elements_ok value gar (frm_stack f) vargs l case_split_stack).
    apply Hwttop; destruct f; simpl; trivial.
  (* i > 0 *)
    intros Hfi Hfpi.
    destruct i.
    replace (frm_args fi) with (frm_args f).
    apply (Hwtvirtual 0 f fpi).
    simpl; trivial.
    simpl; destruct (element_at_list M0 0); trivial.
    inversion Hfi; simpl; trivial.
    generalize (Hwtvirtual (S i) fi fpi); simpl.
    destruct (element_at_list M0 i).
    destruct (element_at_list M0 (S i)).
    intro h; apply (h Hfi Hfpi).
    intro h; apply (h Hfi Hfpi).
    destruct (element_at_list M0 (S i)).
    intro h; apply (h Hfi Hfpi).
    intro h; apply (h Hfi Hfpi).
  Qed.

  Lemma red_build_keeps_welltyped : forall (M0 : configuration) (f : frame) (fcn : function)
    (c : constr) (cnm : name) (car : nat) (vargs l : list value),
    Get_function (frm_fun f) = Some fcn ->
    (fcn_bytecode fcn)[frm_pc f|_] = Some (i_build (fcn_size fcn) cnm car) ->
    Get_constr cnm = Some c -> split_k_elements car (frm_stack f) = Some (vargs, l) ->
    wellformed_configuration (f :: M0) ->
    reduction (f :: M0)
    (mkframe (frm_fun f) (S (frm_pc f))
      (Node cnm (rev_lin vargs) :: l) (frm_args f) :: M0) ->
    welltyped_frame f -> (forall (i : nat) (fi fpi : frame),
      element_at_list (f :: M0) i = Some fi ->
      element_at_list (f :: M0) (S i) = Some fpi ->
      welltyped_frame (mkframe (frm_fun fpi) (frm_pc fpi)
        (frm_args fi ++ frm_stack fpi) (frm_args fpi))) ->
    welltyped_configuration
    (mkframe (frm_fun f) (S (frm_pc f))
      (Node cnm (rev_lin vargs) :: l) (frm_args f) :: M0).
  Proof.
    intros M0 f fcn c cnm car vargs l Hfcn case_instr Hc case_split_stack Hwf Hred Hwttop Hwtvirtual.
    constructor.
  (* M' is well-formed : *)
    apply (reduction_keeps_wellformed (f::M0)); trivial.
    split.
  (* top frame of M' well-typed : *)
    unfold welltyped_frame; simpl; intros f' Hf' fcn' Hfcn' C.
    (inversion Hf'; subst f'; clear Hf').
    (simpl in Hfcn'; rewrite Hfcn' in Hfcn; inversion Hfcn; subst fcn').
    simpl in C.
    cut (frm_pc f < fcn_size fcn); [intro C' | generalize C; auto with arith].
    cut (element_at_list (f :: M0) 0 = Some f); [intro Hf | trivial].
    generalize (Hwttop fcn Hfcn' C').
    generalize (Wti_Kildall fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn') (frm_pc f) C').
    unfold Wti.
    CaseEq ((Kildall_Types fcn (get_some_in_functions fcn (frm_fun f) functions Hfcn'))[frm_pc f|C']).
  (* (Kildall_Types fcn)[pc f] = Top_T *)
    intros dd F; inversion F.
  (* (Kildall_Types fcn)[pc f] = Bot_T *)
    generalize (Passed_Kildall fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn'));
      intros P1 case.
    unfold stack_typing; simpl; intros dd F; inversion F.
  (* (Kildall_Types fcn)[pc f] = Types l0 *)
    intros l0 case.
    replace ((fcn_bytecode fcn)[frm_pc f|C']) with (i_build (fcn_size fcn) cnm car).
    CaseEq (split_k_elements car l0);
    [intros p case_split; destruct p | intros dd F; inversion F].
    rewrite Hc.
    elim (eq_list_name_dec  (rev l1) (cons_args c)); [intro case_eq | intros dd F; inversion F].
    CaseEq (element_at_unsafe
      (Kildall_Types fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn')) (S (frm_pc f)));
    [intros s case_ss | intros dd F; inversion F].
    cut (((Kildall_Types fcn (get_some_in_functions fcn (frm_fun f) functions Hfcn'))[S (frm_pc f)|C]) = s);
    [intro case' | generalize case_ss; apply element_at_unsafe_to_safe].
    (simpl; rewrite case').
    destruct s.
    intro F; inversion F.
    intro F; inversion F.
    elim (eq_list_name_dec  (cons_ret c :: l2) l3); intros case_c F; [clear F | inversion F].
    subst l3.
    unfold stack_typing.
    intro Htype.
    cut (frm_stack f = vargs ++ l); [intro Hstack | generalize case_split_stack; apply split_k_elements_ok].
    cut (l0 = l1 ++ l2); [intro Hl0 | generalize case_split; apply split_k_elements_ok].
    cut (length l1 = car);
      [intro Hlength | generalize case_split; apply split_k_elements_length].
    cut (length vargs = length l1);
      [intro Hlength2 | rewrite Hlength; generalize case_split_stack; apply split_k_elements_length].
    apply cons_list_typing.
  (* built tree's type is ok *)
    apply args_to_tree_typing; trivial.
    rewrite <- case_eq.
    cut (tree_list_typing vargs l1); [rewrite <- rev_lin_is_rev; apply rev_list_typing | generalize Htype].
    rewrite Hstack; rewrite Hl0.
    apply sub_list_typing_left; trivial.

  (* remaining part of the stack's typing ok *)
    generalize Htype.
    rewrite Hstack; rewrite Hl0.
    apply sub_list_typing_right; trivial.
  (* instruction *)
    symmetry; generalize case_instr; apply element_at_unsafe_to_safe.
    (* part 2  : virtual frames from M' are well-typed *)
    intros i fi fpi.
    subst.
    intros Hfi Hfpi.
    destruct i.
  (* i = 0 *)
    cut (element_at_list (f :: M0) 0 = Some f); [intro Hf | simpl; trivial].
    cut (element_at_list (f :: M0) 1 = Some fpi).
    intro Hfpi'; generalize (Hwtvirtual 0 f fpi Hf Hfpi').
    replace (frm_args f) with (frm_args fi).
    trivial.
    simpl in Hfi.
    inversion Hfi.
    simpl; trivial.
    simpl; simpl in Hfpi.
    rewrite Hfpi.
    trivial.
  (* i > 0 *)
    cut (element_at_list (f :: M0) (S i) = Some fi).
    cut (element_at_list (f :: M0) (S (S i)) = Some fpi).
    intros Hfpi' Hfi'.
    apply (Hwtvirtual (S i) fi fpi Hfi' Hfpi').
    simpl; simpl in Hfpi.
    assumption.
    simpl; simpl in Hfi; assumption.
  Qed.

  Lemma red_branch_then_keeps_welltyped : forall (M0 : configuration) (f : frame) (fcn : function)
    (cnm : name) (j : nat) (l : list value) (vf : list value) (Cj : j < fcn_size fcn),
    Get_function (frm_fun f) = Some fcn ->
    (fcn_bytecode fcn)[frm_pc f|_] = Some (i_branch (fcn_size fcn) cnm j Cj) ->
    frm_stack f = Node cnm vf :: l -> wellformed_configuration (f :: M0) ->
    reduction (f :: M0) (mkframe (frm_fun f) (S (frm_pc f))
      (push_list vf l) (frm_args f) :: M0) ->
    welltyped_frame f -> (forall (i : nat) (fi fpi : frame),
      element_at_list (f :: M0) i = Some fi ->
      element_at_list (f :: M0) (S i) = Some fpi ->
      welltyped_frame (mkframe (frm_fun fpi) (frm_pc fpi)
        (frm_args fi ++ frm_stack fpi) (frm_args fpi))) ->
    welltyped_configuration
    (mkframe (frm_fun f) (S (frm_pc f)) (push_list vf l) (frm_args f) :: M0).
  Proof.
    intros M0 f fcn cnm j l vf Cj Hfcn case_instr Hstack Hwf Hred Hwttop Hwtvirtual.
    constructor.
  (* M' is well-formed : *)
    apply (reduction_keeps_wellformed (f::M0)); trivial.
    split.
  (* top frame of M' is well-typed : *)
    simpl.
    unfold welltyped_frame; intros f' Hf' fcn' Hfcn' C.
    (inversion Hf'; subst f'; clear Hf').
    simpl in Hfcn'.
    rewrite Hfcn' in Hfcn; inversion Hfcn; subst fcn'.
    simpl in C.
    cut (frm_pc f < fcn_size fcn); [intro C' | generalize C; auto with arith].
    cut (element_at_list (f :: M0) 0 = Some f); [intro Hf | trivial].
    generalize (Hwttop fcn Hfcn' C').
    generalize (Wti_Kildall fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn') (frm_pc f) C').
    unfold Wti.
    CaseEq ((Kildall_Types fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn')) [frm_pc f|C']).
  (* Kildall_Types fcn) [pc f] = Top_T *)
    intros dd F; inversion F.
  (* Kildall_Types fcn) [pc f] = Bot_T *)
    generalize (Passed_Kildall fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn'));
      intros P1 case.
    unfold stack_typing; simpl; intros dd F; inversion F.
  (* Kildall_Types fcn) [pc f] = Types l0 *)
    intros l0 case.
    replace ((fcn_bytecode fcn)[frm_pc f|C']) with (i_branch (fcn_size fcn) cnm j Cj).
    intro h; elim h; clear h.
    elim (eq_Sigma_dec  (Types l0)
      ((Kildall_Types fcn (get_some_in_functions fcn (frm_fun f) functions Hfcn'))[j|Cj])); intros case_ssj F;
    [clear F | inversion F].
    CaseEq (Get_constr cnm); [intros c Hc | intros dd F; inversion F].
    destruct l0; [intro F; inversion F | idtac].
    elim (eq_name_dec (cons_ret c) n); [intro case_n |intros dd F; inversion F].
    CaseEq (element_at_unsafe (Kildall_Types fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn'))
      (S (frm_pc f))); [intros s case_ss_s | intros dd F; inversion F].
    cut ((Kildall_Types fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn'))[S (frm_pc f)|C] = s);
    [intro Hss | generalize case_ss_s; apply element_at_unsafe_to_safe].
    simpl; rewrite Hss.
    destruct s.
    intro F; inversion F.
    intro F; inversion F.
    elim (eq_list_name_dec  (rev (cons_args c) ++ l0) l1); intros case' F; [clear F | inversion F].
    rewrite Hstack.
    intro Htype; assert (H : (tree_typing (Node cnm vf) n) /\ tree_list_typing l l0).
    (* Prooving H : *)
    inversion Htype.
    split; trivial.
    unfold tree_typing; constructor 2 with const; subst; trivial.
    constructor.
    (* H proved *)
    subst l1.
    elim H; clear H; intros Htype1 Htype2.
    rewrite push_list_is_app_rev.
    cut (tree_list_typing (rev vf) (rev (cons_args c))).
    intro dd; generalize dd Htype2.
    unfold stack_typing.
    apply app_list_typing.
    subst n.
    cut (tree_list_typing vf (cons_args c));
      [rewrite <- rev_lin_is_rev; rewrite <- rev_lin_is_rev; apply rev_list_typing
        | generalize Htype1; apply tree_to_args_typing].
    assumption.
    symmetry; generalize case_instr; apply element_at_unsafe_to_safe.
    (* part 2 : virtual frames from M' are well-typed *)
    intros i fi fpi Hfi Hfpi.
    destruct i.
  (* i = 0 : *)
    cut (element_at_list (f :: M0) 0 = Some f); [intro Hf | simpl; trivial].
    cut (element_at_list (f :: M0) 1 = Some fpi).
    intro Hfpi'; generalize (Hwtvirtual 0 f fpi Hf Hfpi').
    replace (frm_args f) with (frm_args fi).
    trivial.
    simpl in Hfi.
    inversion Hfi.
    simpl; trivial.
    simpl; simpl in Hfpi.
    rewrite Hfpi.
    trivial.
  (* i > 0 *)
    cut (element_at_list (f :: M0) (S i) = Some fi).
    cut (element_at_list (f :: M0) (S (S i)) = Some fpi).
    intros Hfpi' Hfi'.
    apply (Hwtvirtual (S i) fi fpi Hfi' Hfpi').
    simpl; simpl in Hfpi.
    assumption.
    simpl; simpl in Hfi; assumption.
  Qed.

  Lemma red_branch_else_keeps_welltyped : forall (M0 : configuration) (f : frame) (fcn : function)
    (cnm dnm : name) (j : nat) (l : list value) (vf : list value) (Cj : j < fcn_size fcn),
    Get_function (frm_fun f) = Some fcn ->
    (fcn_bytecode fcn)[frm_pc f|_] = Some (i_branch (fcn_size fcn) cnm j Cj) ->
    frm_stack f = Node dnm vf :: l -> dnm <> cnm -> wellformed_configuration (f :: M0) ->
    reduction (f :: M0) (mkframe (frm_fun f) j (frm_stack f) (frm_args f) :: M0) ->
    welltyped_frame f -> (forall (i : nat) (fi fpi : frame),
      element_at_list (f :: M0) i = Some fi ->
      element_at_list (f :: M0) (S i) = Some fpi ->
      welltyped_frame (mkframe (frm_fun fpi) (frm_pc fpi)
        (frm_args fi ++ frm_stack fpi) (frm_args fpi))) ->
    welltyped_configuration (mkframe (frm_fun f) j (frm_stack f) (frm_args f) :: M0).
  Proof.
    intros M0 f fcn cnm dnm j l vf Cj Hfcn case_instr Hstack neq_cnm_dnm Hwf Hred Hwttop Hwtvirtual.
    constructor.
  (* M' is well-formed : *)
    apply (reduction_keeps_wellformed (f::M0)); trivial.
    split.
  (* top frame of M' well-typed : *)
    unfold welltyped_frame; intros f' Hf' fcn' Hfcn' C.
    simpl.
    (simpl in Hf'; inversion Hf'; subst f'; clear Hf'; simpl in Hfcn').
    rewrite Hfcn' in Hfcn; inversion Hfcn; subst fcn'.
    simpl in C.
    cut (frm_pc f < fcn_size fcn); [intro C' | generalize case_instr; apply element_at_unsafe_some].
    cut (element_at_list (f :: M0) 0 = Some f); [intro Hf | trivial].
    generalize (Hwttop fcn Hfcn' C'); clear Hf.
    generalize (Wti_Kildall fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn') (frm_pc f) C').
    unfold Wti.
    CaseEq ((Kildall_Types fcn (get_some_in_functions fcn (frm_fun f) functions Hfcn'))[frm_pc f|C']).
  (* (Kildall_Types fcn)[pc f] = Top_T *)
    intros dd F; inversion F.
  (* (Kildall_Types fcn)[pc f] = Bot_T *)
    generalize (Passed_Kildall fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn'));
      intros P1 case.
    unfold stack_typing; simpl; intros dd F; inversion F.
  (* (Kildall_Types fcn)[pc f] = Types l0 *)
    intros l0 case.
    replace ((fcn_bytecode fcn)[frm_pc f|C']) with (i_branch (fcn_size fcn) cnm j Cj).
    intro h; elim h; clear h.
    elim (eq_Sigma_dec  (Types l0)
      ((Kildall_Types fcn (get_some_in_functions fcn (frm_fun f) functions Hfcn'))[j|Cj]));
    intros case_ssj F; [clear F | inversion F].
    CaseEq (Get_constr cnm); [intros c Hc | intros dd F ; inversion F].
    destruct l0; [intro F; inversion F| idtac].
    elim (eq_name_dec (cons_ret c) n); intro case_n; [idtac | intro F; inversion F].
    CaseEq (element_at_unsafe (Kildall_Types fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn'))
      (S (frm_pc f))); [intros s case_ss_s | intros dd F; inversion F].
    destruct s.
    intro F; inversion F.
    intro F; inversion F.
    elim (eq_list_name_dec  (rev (cons_args c) ++ l0) l1); intros case' F; [clear F | inversion F].
    simpl; rewrite (element_at_irrel Sigma (fcn_size fcn)
      (Kildall_Types fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn')) j C Cj).
    rewrite <- case_ssj.
    trivial.
    symmetry; generalize case_instr; apply element_at_unsafe_to_safe.
    (* part 2 : virtual frames from M' are well-typed *)
    intros i fi fpi Hfi Hfpi.
    destruct i.
  (* i = 0 *)
    cut (element_at_list (f :: M0) 0 = Some f); [intro Hf | simpl; trivial].
    cut (element_at_list (f :: M0) 1 = Some fpi).
    intro Hfpi'; generalize (Hwtvirtual 0 f fpi Hf Hfpi').
    replace (frm_args f) with (frm_args fi).
    trivial.
    simpl in Hfi.
    inversion Hfi.
    simpl; trivial.
    simpl; simpl in Hfpi.
    rewrite Hfpi.
    trivial.
  (* i > 0 *)
    cut (element_at_list (f :: M0) (S i) = Some fi).
    cut (element_at_list (f :: M0) (S (S i)) = Some fpi).
    intros Hfpi' Hfi'.
    apply (Hwtvirtual (S i) fi fpi Hfi' Hfpi').
    simpl; simpl in Hfpi.
    assumption.
    simpl; simpl in Hfi; assumption.
  Qed.

  (* well-typedness is invariant  *)
  Lemma reduction_keeps_welltyped : Invariant welltyped_configuration.
  Proof.
    intros M M' Hwt Hred.
    InversionRed Hred; inversion Hwt; subst; generalize H; elim H0;
      clear H H0; intros Hwttop Hwtvirtual Hwf.
  (* return *)
    cut (Some f = Some f); [intro Hf | trivial].
    generalize (Hwttop f Hf); clear Hwttop; intro Hwttop.
    apply (red_return_keeps_welltyped M0 f g fcn v0 l Hfcn); trivial.
  (* stop *)
    constructor.
    apply wellformed_epsilon.
    split.
    intros f0 Hf0; inversion Hf0.
    intros i fi fpi Hfi; inversion Hfi.
  (* load *)
    cut (Some f = Some f); [intro Hf | trivial].
    generalize (Hwttop f Hf); clear Hwttop; intro Hwttop.
    apply (red_load_keeps_welltyped M0 f fcn j vj Hfcn); trivial.
  (* call *)
    cut (Some f = Some f); [intro Hf | trivial].
    generalize (Hwttop f Hf); clear Hwttop; intro Hwttop.
    apply (red_call_keeps_welltyped M0 f fcn gcn gnm gar vargs l Hfcn); trivial.
  (* build *)
    cut (Some f = Some f); [intro Hf | trivial].
    generalize (Hwttop f Hf); clear Hwttop; intro Hwttop.
    rewrite <- rev_lin_is_rev.
    apply (red_build_keeps_welltyped M0 f fcn c cnm car vargs l Hfcn); trivial.
    rewrite rev_lin_is_rev; trivial.
  (* BranchThen *)
    cut (Some f = Some f); [intro Hf | trivial].
    generalize (Hwttop f Hf); clear Hwttop; intro Hwttop.
    apply (red_branch_then_keeps_welltyped M0 f fcn cnm j l vf Cj Hfcn); trivial.
  (* BranchElse *)
    cut (Some f = Some f); [intro Hf | trivial].
    generalize (Hwttop f Hf); clear Hwttop; intro Hwttop.
    apply (red_branch_else_keeps_welltyped M0 f fcn cnm dnm j l vf Cj Hfcn); trivial.
  Qed.

  (* init configuration is well-typed provided arguments given to fexec are of correct types *)
  Lemma welltyped_init_configuration : forall (fexec : name) (argsexec : list value) (fcnexec : function),
    Get_function fexec = Some fcnexec ->
    tree_list_typing argsexec (rev_lin (fcn_args fcnexec)) ->
    welltyped_configuration (Init_configuration fexec argsexec).
  Proof.
    intros fexec argsexec fcnexec Hget Htyping; constructor.
    apply wellformed_init_configuration.
    rewrite Hget; intro F; inversion F.
    split; simpl.
    intros f Hf; inversion Hf; subst f; clear Hf.
    unfold welltyped_frame; simpl; intros fcn Hfcn C.
    cut (fcn=fcnexec); [intro; subst fcnexec; clear Hget| rewrite Hget in Hfcn; inversion Hfcn; trivial].
    rewrite (element_at_irrel Sigma (fcn_size fcn)
      (Kildall_Types fcn (get_some_in_functions  fcn fexec functions Hfcn))
      0 C (nonvoidfcn fcn (get_some_in_functions  fcn fexec functions Hfcn))).
    generalize (Passed_Kildall fcn (get_some_in_functions  fcn fexec functions Hfcn)); intros notop.

    CaseEq ((Kildall_Types fcn (get_some_in_functions fcn fexec functions Hfcn))
      [0|nonvoidfcn fcn (get_some_in_functions fcn fexec functions Hfcn)]).
    intro case; apply notop; rewrite <- case; apply element_at_belong.
    rewrite (Kildall_Types_0 fcn (get_some_in_functions  fcn fexec functions Hfcn)).
    unfold ss_init.
    rewrite element_at_in_replaced.
    intro case; inversion case.
    intro l.
    rewrite (Kildall_Types_0 fcn (get_some_in_functions  fcn fexec functions Hfcn)).
    unfold ss_init.
    rewrite element_at_in_replaced.
    intro case; inversion case.
    rewrite <- rev_lin_is_rev; assumption.
    intros i fi fpi Hfi Hfpi; destruct i; simpl; inversion Hfpi.
  Qed.

  (* each configuration in a correct execution is well-typed *)
  Lemma welltyped_execution : forall (fexec : name) (argsexec : list value) (fcnexec : function)
    (Hin : In fcnexec functions) (L : list configuration),
    Get_function fexec = Some fcnexec ->
    tree_list_typing argsexec (rev_lin (fcn_args fcnexec)) ->
    execution fexec argsexec L ->
    forall  (M : configuration), In M L -> welltyped_configuration M.
  Proof.
    intros fexec argsexec fcnexec Hin L Hget Htyping; apply reduction_to_execution.
    apply welltyped_init_configuration with fcnexec; trivial.
    apply reduction_keeps_welltyped.
  Qed.

  (* progress : any well-typed configuration is either a result, reducts, or empty. *)
  Lemma reduction_progress : forall (M : configuration) (Hwt : welltyped_configuration M),
    sumor (sum {v : value | config_result M v} {M' : configuration | reduction M M'}) (M = nil).
  Proof.
    intros M Hwt.
    destruct M; simpl; [right; trivial | left].
    cut (wellformed_configuration (f::M)); [intro Hwf | inversion Hwt; auto].

    cut (welltyped_frame f /\ (forall (i : nat) (fi fpi : frame),
      element_at_list (f::M) i = Some fi ->
      element_at_list (f::M) (S i) = Some fpi ->
      welltyped_frame (mkframe ((frm_fun fpi)) ((frm_pc fpi))
        ((frm_args fi)++(frm_stack fpi)) (frm_args fpi))));
    [intro Hwtalt | inversion Hwt; split; auto].
    elim Hwtalt; clear Hwtalt; intros Hwtf Hwtvirtual.
    clear Hwt.
    unfold welltyped_frame in Hwtf.
    unfold wellformed_configuration in Hwf.
    destruct f as [fnm pc stack args]; (simpl in *).
    CaseEq (Get_function fnm).
    intros fcn case.

    cut (Some (Frm fnm pc stack args) = Some (Frm fnm pc stack args)); [intro Hf | trivial].
    generalize (Hwf 0 (Frm fnm pc stack args) (Frm fnm pc stack args) fcn fcn Hf); clear Hwf Hf; intro Hwf.
    elim Hwf; clear Hwf; intros dd Hwf.
    elim (Hwf case); simpl; intros Cpc H; clear Hwf.

    generalize (Hwtf fcn case Cpc); clear Hwtf.
    generalize (Wti_Kildall fcn (get_some_in_functions  fcn fnm functions case) pc Cpc).
    generalize (Passed_Kildall fcn (get_some_in_functions  fcn fnm functions case)); intro notop.
    unfold Wti.
    CaseEq ((Kildall_Types fcn (get_some_in_functions fcn fnm functions case))[pc|Cpc]); simpl.
    intros casess F; inversion F.
    intros casess ddd F; inversion F.
    intros l case_ss.
    CaseEq ((fcn_bytecode fcn)[pc|Cpc]).
  (* return *)
    intro case_i; destruct l.
    intro F; inversion F.
    elim (eq_name_dec n (fcn_ret fcn)); intros case_n ddd; [clear ddd | inversion ddd].
    destruct stack; simpl.
    intro F; cut (False); [intro F'; inversion F' | inversion F].
    destruct M.
  (* Real Result *)
    intro; left.
    exists v.
    apply (config_is_result (Frm fnm pc (v :: stack) args :: nil) v stack (Frm fnm pc (v :: stack) args) fcn); auto.
    simpl.
    apply element_at_to_unsafe with Cpc; auto.
  (* Return *)
    intro Htype; right.
    exists ((Frm (frm_fun f) (S (frm_pc f)) (v::(frm_stack f)) (frm_args f))::M).
    apply (red_return  M (Frm fnm pc (v::stack) args) f fcn v stack); simpl; auto.
    apply element_at_to_unsafe with Cpc; trivial.
  (* stop *)
    intros case_bc ddd Htype; right.
    clear ddd.
    exists (nil (A:=frame)).
    apply red_stop with fcn; auto.
    simpl; apply element_at_to_unsafe with Cpc; auto.

  (* load *)
    intros j case_bc.
    CaseEq (element_at_unsafe (Kildall_Types fcn (get_some_in_functions  fcn fnm functions case)) (S pc)).
    intros s case_s; destruct s; simpl.
    intro h; inversion h.
    intro h; inversion h.
    CaseEq (element_at_list (rev l) j).
    intros vj case_vj.
    elim (eq_list_name_dec  (vj :: l) l0); intros case_eq ddd; [clear ddd | inversion ddd].
    intro Htype; right.
    CaseEq (element_at_list (rev stack) j).
    intros v case_v.
    exists ((Frm (frm_fun (Frm fnm pc stack args)) (S (frm_pc (Frm fnm pc stack args))) (v::(frm_stack (Frm fnm pc stack args))) (frm_args (Frm fnm pc stack args))) :: M).
    apply (red_load M (Frm fnm pc stack args) fcn j v); simpl; auto.
    apply element_at_to_unsafe with Cpc.
    assumption.
    rewrite rev_lin_is_rev; assumption.
    intro F.
    cut (tree_list_typing (rev stack) (rev l)); [intro Hrev | generalize Htype; rewrite <- rev_lin_is_rev; rewrite <- rev_lin_is_rev; apply rev_list_typing].
    cut (length (rev stack) = length (rev l)); [intro Hlength | generalize Hrev; apply list_typing_length].
    cut (j < length (rev l)).
    intro Hn; rewrite <- Hlength in Hn.
    cut (~ j < length (rev stack)).
    intro Hn2.
    elim Hn2; assumption.
    cut (j >= length (rev stack)); auto with arith.
    apply element_at_list_none; assumption.
    apply element_at_list_some with vj; assumption.

    intros ddd F; inversion F.
    intros ddd F; inversion F.

  (* call *)
    intros gnm ar case_bc.
    CaseEq (split_k_elements ar l).
    intros p Hsplit; destruct p as [lar l'].
    CaseEq (Get_function gnm).
    intros gcn Hget.
    elim (eq_list_name_dec (rev lar) (fcn_args gcn)); intro case_eq.
    CaseEq (element_at_unsafe (Kildall_Types fcn (get_some_in_functions  fcn fnm functions case)) (S pc)).
    intros s case_s; destruct s.
    intro F; inversion F.
    intro F; inversion F.
    elim (eq_list_name_dec  ((fcn_ret gcn) :: l') l0); intros case_l0 ddd ; [clear ddd | inversion ddd].
    intro Htype.
    subst; (simpl in *).
    right.
    CaseEq (split_k_elements ar stack).
    intros p Hsplitstack; destruct p as [args' stack'].
    exists ((Frm gnm 0 args' args')::(Frm fnm pc stack' args)::M).
    apply (red_call M (Frm fnm pc stack args) fcn gcn gnm ar); simpl; auto.
    apply element_at_to_unsafe with Cpc; assumption.
    intro F; cut (length stack = length l); [intro Hlength | generalize Htype; apply list_typing_length].
    cut (length stack < ar); [intro Hlstack | generalize F; apply split_k_elements_none].
    cut (~length stack < ar); [intro Hlstack2; elim Hlstack2; assumption |idtac].
    cut (ar <= length stack); [auto with arith | generalize Hsplit; rewrite Hlength; apply split_k_elements_some].
    intros ddd F; inversion F.
    intro F; inversion F.
    intros ddd F; inversion F.
    intros ddd F; inversion F.

  (* build *)
    intros cnm ar case_bc.
    CaseEq (split_k_elements ar l).
    intros p Hsplit; destruct p as [lk lr].
    CaseEq (Get_constr cnm).
    intros c case_c.
    elim (eq_list_name_dec  (rev lk) (cons_args c)); intro case_eq.
    CaseEq (element_at_unsafe (Kildall_Types fcn (get_some_in_functions  fcn fnm functions case)) (S pc)).
    intros s case_ss_spc; destruct s.
    intro F; inversion F.
    intro F; inversion F.
    elim (eq_list_name_dec  (cons_ret c :: lr) l0); intros case_eq2 F Htype.
    clear F.
    right.
    CaseEq (split_k_elements ar stack).
    intros p case_split; destruct p as [argsc stack'].
    exists ((Frm (frm_fun (Frm fnm pc stack args)) (S (frm_pc (Frm fnm pc stack args)))
      ((Node cnm (rev argsc)) :: stack') (frm_args (Frm fnm pc stack args)))::M).
    apply (red_build M (Frm fnm pc stack args) fcn c cnm ar argsc stack'); simpl; trivial.
    apply element_at_to_unsafe with Cpc; trivial.
    intro F.
    cut (length stack = length l); [intro Hlength | generalize Htype; apply list_typing_length].
    cut (length stack < ar); [intro Hlstack | generalize F; apply split_k_elements_none].
    cut (~length stack < ar); [intro Hlstack2; elim Hlstack2; assumption |idtac].
    cut (ar <= length stack); [auto with arith | generalize Hsplit; rewrite Hlength; apply split_k_elements_some].
    inversion F.
    intros ddd F; inversion F.
    intro F; inversion F.
    intros ddd F; inversion F.
    intros ddd F; inversion F.
  (* branch *)
    intros cnm j Cj case_bc.
    destruct (eq_Sigma_dec  (Types l) ((Kildall_Types fcn (get_some_in_functions fcn fnm functions case))[j|Cj])).
    intro h; elim h; intro h'; clear h' h.
    CaseEq (Get_constr cnm).
    intros c case_c.
    destruct l.
    intro F; inversion F.
    elim (eq_name_dec (cons_ret c) n); intro case_n.
    CaseEq (element_at_unsafe (Kildall_Types fcn (get_some_in_functions  fcn fnm functions case)) (S pc)).
    intros s case_ss_spc; destruct s.
    intro F; inversion F.
    intro F; inversion F.
    elim (eq_list_name_dec  (rev (cons_args c) ++ l) l0); intros case_eq F Htype; [clear F | inversion F].
    right.
    destruct stack.
    assert (H0 : False).
    inversion Htype.
    inversion H0.
    destruct v.
    (* case v leaf : *)
    assert (H0 : False).
    inversion Htype.
    inversion H0.
    (* case v node : *)

    elim (eq_name_dec n0 cnm); intro case_eq2.
    subst n0.
    exists ((Frm (frm_fun (Frm fnm pc (Node cnm l1 :: stack) args)) (S (frm_pc (Frm fnm pc (Node cnm l1 :: stack) args)))
      ((rev l1) ++ stack) (frm_args (Frm fnm pc ((Node cnm l1) :: stack) args)))::M).
    rewrite <- push_list_is_app_rev.
    apply (red_branch_then M (Frm fnm pc (Node cnm l1 :: stack) args) fcn cnm j stack l1 Cj); simpl; trivial.
    apply element_at_to_unsafe with Cpc; trivial.
    exists ((Frm (frm_fun (Frm fnm pc (Node n0 l1 :: stack) args)) j (frm_stack (Frm fnm pc (Node n0 l1 :: stack) args))
      (frm_args (Frm fnm pc (Node n0 l1 :: stack) args))) :: M).
    apply (red_branch_else M (Frm fnm pc (Node n0 l1 :: stack) args) fcn cnm n0 j stack l1 Cj); simpl; trivial.
    apply element_at_to_unsafe with Cpc; trivial.
    intros ddd F; inversion F.
    intro F; inversion F.
    intros ddd F; inversion F.
    intro F; elim F; clear F; intro F; inversion F.
    cut (Some (mkframe fnm pc stack args) = Some (mkframe fnm pc stack args)); [intro Hf | trivial].
    cut (function); [intro fcn | apply (mkfunction fnm nil fnm 0 vector_nil)].
    elim (Hwf 0 (mkframe fnm pc stack args) (mkframe fnm pc stack args) fcn fcn Hf).
    simpl; intros H ddd F.
    elim H; assumption.
    subst.
    elim H0; intros H1 H2.
    apply H1; trivial.
    subst; elim H0; intros H1 H2; apply H2; trivial.
  Qed.

  Lemma nonempty_progress : forall (f : frame) (M : configuration) (MWellTyped : welltyped_configuration (f::M)),
    {v : value | config_result (f::M) v} + {M' : configuration | reduction (f::M) M'}.
  Proof.
    intros f M  fMWellTyped.
    elim (reduction_progress (f::M) fMWellTyped).
    trivial.
    intro H; inversion H.
  Qed.

  Lemma nonempty_progress' : forall (M : configuration) (MWellTyped : welltyped_configuration M),
    M <> nil -> {v : value | config_result M v} + {M' : configuration | reduction M M'}.
  Proof.
    intros  M  MWellTyped MNotEmpty.
    elim (reduction_progress M MWellTyped).
    trivial.
    intro H; elim MNotEmpty; trivial.
  Qed.

  Fact eq_configuration_nil_dec : forall (M : configuration), {M = nil} + {M <> nil}.
  Proof.
    intro M; destruct M; [left | right]; trivial.
    intro H; inversion H.
  Qed.

  Inductive config_wrap : Set :=
    | config_wrap_error : config_wrap
    | config_wrap_result : value -> config_wrap
    | config_wrap_wt_list : forall (M : configuration) (WTM : welltyped_configuration M), config_wrap.

  Definition fonctionnal_reduction (WM : config_wrap) : config_wrap :=
    match WM with
      | config_wrap_wt_list M WTM =>
        match eq_configuration_nil_dec M with
          | left _ => config_wrap_error
          | right MNotEmpty =>
            match nonempty_progress' M WTM MNotEmpty with
              | inl H =>
                match H with
                  | exist v Hred => config_wrap_result v
                end
              | inr H =>
                match H with
                  | exist Mred Hred =>
                    config_wrap_wt_list Mred
                    (reduction_keeps_welltyped M Mred WTM Hred)
                end
            end
        end
      | x => x
    end.

  (* length of frame args is the arity of the function evaluated in the frame for each frame in the configuration *)
  Definition frames_args_length (M : configuration) : Prop := forall (f : frame) (fcn : function),
    In f M -> Get_function (frm_fun f) = Some fcn -> length (frm_args f) = length (fcn_args fcn).

  (* frame_args_length is invariant on well-typed configurations*)
  Lemma reduction_length : Invariant (fun (M : configuration) => welltyped_configuration M /\ frames_args_length M).
  Proof.
    intros M M' Hwtfal Hred.
    elim Hwtfal; clear Hwtfal; intros Hwt Hfal.
    split.
    apply (reduction_keeps_welltyped M M'); trivial.
    (InversionRed Hred; intros f' fcn' Hin' Hget').
    Focus 1.
  (* return *)
    (elim Hin'; clear Hin'; intro Hin').
    subst.
    (simpl in *).
    apply (Hfal g fcn'); trivial.
    right; left; trivial.
    apply (Hfal f' fcn'); trivial.
    right; right; trivial.
    Focus 1.
  (* stop *)
    subst.
    (inversion Hin').
    Focus 1.
  (* load *)
    (elim Hin'; clear Hin'; intro Hin').
    (subst; simpl in *).
    apply (Hfal f fcn'); trivial.
    left; trivial.
    apply (Hfal f' fcn'); trivial.
    right; trivial.
    Focus 1.
  (* call *)
    (elim Hin'; clear Hin'; intro Hin').
    (subst; simpl in *).
    cut (frm_pc f < fcn_size fcn); [intro C | generalize case_instr; apply element_at_unsafe_some].
    generalize (Wti_Kildall fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn) (frm_pc f) C).
    inversion Hwt; subst.
    generalize H; elim H0; clear H H0; intros Hwttop Hwtvirtual Hwf.
    cut (element_at_list (f::M0) 0 = Some f); [intro Hf | trivial].
    generalize (Hwttop f Hf fcn Hfcn C); trivial.
    unfold Wti.
    CaseEq ((Kildall_Types fcn (get_some_in_functions  fcn (frm_fun f) functions Hfcn))[frm_pc f|C]).
    intros case Hs F; inversion F.
    intros case Hs; inversion Hs.
    intros l0 case Hs.
    replace ((fcn_bytecode fcn)[frm_pc f|C]) with (i_call (fcn_size fcn) gnm gar).
    CaseEq (split_k_elements gar l0).
    intros p Hsplit; destruct p.
    destruct (Get_function gnm).
    elim (eq_list_name_dec  (rev l1) (fcn_args f0)); intro caseeq.
    intro dd; clear dd.
    inversion Hget'; subst.
    rewrite <- caseeq.
    rewrite rev_length.
    replace (length l1) with gar.
    generalize case_split_stack; apply split_k_elements_length.
    symmetry; generalize Hsplit; apply split_k_elements_length.
    intro F; inversion F.
    intro F; inversion F.
    intros dd F; inversion F.
    symmetry; generalize case_instr; apply element_at_unsafe_to_safe.
    (elim Hin'; clear Hin'; intro Hin').
    (subst; simpl in *).
    apply (Hfal f fcn'); trivial.
    left; trivial.
    apply (Hfal f' fcn'); trivial.
    right; assumption.
    Focus 1.
  (* build *)
    (elim Hin'; clear Hin'; intro Hin').
    (subst; simpl in *).
    apply (Hfal f fcn'); trivial.
    left; trivial.
    apply (Hfal f' fcn'); trivial.
    right; trivial.
  (* branch then *)
    (elim Hin'; clear Hin'; intro Hin').
    (subst; simpl in *).
    apply (Hfal f fcn'); trivial.
    left; trivial.
    apply (Hfal f' fcn'); trivial.
    right; trivial.
  (* branch else *)
    (elim Hin'; clear Hin'; intro Hin').
    (subst; simpl in *).
    apply (Hfal f fcn'); trivial.
    left; trivial.
    apply (Hfal f' fcn'); trivial.
    right; trivial.
  Qed.

  Lemma execution_length : forall (fexec : name) (argsexec : list value) (fcnexec : function) (L : list configuration),
    Get_function fexec = Some fcnexec ->
    tree_list_typing argsexec (rev_lin (fcn_args fcnexec)) ->
    execution fexec argsexec L ->
    forall  (M : configuration), In M L -> frames_args_length M.
  Proof.
    intros fexec argsexec fcnexec L Hget Htyping Hexec M Hin.
    cut (welltyped_configuration M /\ frames_args_length M); [intro H; elim H; trivial | generalize Hexec M Hin; clear Hexec Hin M].
    apply (reduction_to_execution (fun (M : configuration) => welltyped_configuration M /\ frames_args_length M)); trivial.
    split.
    apply welltyped_init_configuration with fcnexec; trivial.
    intros f fcn Hin Hfcn.
    elim Hin; clear Hin; intro Hin.
    subst f; (simpl in *).
    rewrite Hget in Hfcn; inversion Hfcn; subst fcn.
    rewrite <- (lists.rev_length _ (fcn_args fcnexec)).
    generalize Htyping; rewrite <- rev_lin_is_rev; apply list_typing_length.
    inversion Hin.
    apply reduction_length.
  Qed.

End machine_types.


(** * Performance Criterion: fast alpha-equivalence check (Õ(term size)) *)
Require Import Coq.ZArith.ZArith.

Fixpoint biga (n : nat) (f : Prop -> Prop)
:= match n with
   | 0 => f True
   | S n => biga n (fun x => forall a : Prop, f (a -> x))
   end.
Fixpoint bigb (n : nat) (f : Prop -> Prop)
:= match n with
   | 0 => f True
   | S n => bigb n (fun x => forall b : Prop, f (b -> x))
   end.

Definition goal n := biga n (fun x => x) = bigb n (fun x => x).

Ltac check n :=
  let ty := (eval cbv in (goal (Z.to_nat n))) in
  let lhs := lazymatch ty with ?x = _ => x end in
  time let v := constr:(@eq_refl Prop lhs : ty) in idtac.

(* overhead to build the term is pretty big, though... *)
Goal True.
  check 7000%Z. (* Tactic call ran for 0.006 secs (0.006u,0.s) (success) *)
  Optimize Heap.
  check 8000%Z. (* Tactic call ran for 0.007 secs (0.007u,0.s) (success) *)
  Optimize Heap.
  check 9000%Z. (* Tactic call ran for 0.008 secs (0.008u,0.s) (success) *)
Abort.


From Coq Require Import
     String List ZArith
     extraction.ExtrOcamlIntConv.
Import ListNotations.

From ExtLib Require Import
     Structures.Monad.
Import MonadNotation.
Local Open Scope monad.

From SimpleIO Require Import SimpleIO.

From advent Require Import lib.

Inductive nanobot : Type := Nanobot (x y z r : Z).

Parameter read_nanobot' :
  forall r : Type, (int -> int -> int -> int -> r) -> IO r.
Extract Constant read_nanobot' => "
  fun f k ->
    k (Scanf.scanf ""pos=<%d,%d,%d>, r=%d "" f)".

Definition read_nanobot : IO (option nanobot) :=
  catch_eof (read_nanobot' _ (fun x y z r =>
                   Nanobot (z_of_int x) (z_of_int y) (z_of_int z)
                         (z_of_int r))).

Definition range_lt : nanobot -> nanobot -> bool :=
  fun '(Nanobot _ _ _ r1) '(Nanobot _ _ _ r2) =>
    (r1 <? r2)%Z.

Fixpoint find_max_range'
         (ns0 : list nanobot) (ns : list nanobot) : list nanobot :=
  match ns with
  | [] => ns0
  | n :: ns =>
    let ns0 :=
        match ns0 with
        | [] => [n]
        | n0 :: _ => if range_lt n0 n then [n] else ns0
        end
    in find_max_range' ns0 ns
  end.

Definition find_max_range : list nanobot -> list nanobot :=
  find_max_range' [].

(* [in_range n0 n1]: nanobot [n1] is within range of nanobot [n0]. *)
Definition in_range : nanobot -> nanobot -> bool :=
  fun '(Nanobot x0 y0 z0 r0) '(Nanobot x1 y1 z1 _) =>
    (Z.abs (x0 - x1) + Z.abs (y0 - y1) + Z.abs (z0 - z1) <=? r0)%Z.

Section main.

Context {m : Type -> Type} `{Monad m} `{MonadError m}
        `{FoldRead nanobot m} `{MonadO nat m}.

Definition main : m unit :=
  ps <- read_all;;
  match find_max_range ps with
  | [] => error "no nanobots"
  | _ :: _ :: _ => error "no unique max-range nanobot"
  | [n0] =>
    print (length (filter (in_range n0) ps))
  end.

End main.

Instance MonadI_nanobot_IO : MonadI nanobot IO := {
  read := read_nanobot;
}.

Definition exe : io_unit := IO.unsafe_run main.
Extraction "day23_1.ml" exe.


Require Import NArith.
Require Import PArith.
Require Import ZArith.
Require Import Lia.
Require Import EquivDec.

From sflib Require Import sflib.

Require Import PromisingArch.lib.Basic.
Require Import PromisingArch.lib.Order.
Require Import PromisingArch.lib.Lang.

Set Implicit Arguments.

Inductive rmw_instrT :=
| rmw_instr_skip
| rmw_instr_assign (lhs:Id.t) (rhs:exprT)
| rmw_instr_load (ord:OrdR.t) (res:Id.t) (eloc:exprT)
| rmw_instr_store (ord:OrdW.t) (eloc:exprT) (eval:exprT)
| rmw_instr_fadd (ordr:OrdR.t) (ordw:OrdW.t) (res:Id.t) (eloc:exprT) (eadd:exprT)
| rmw_instr_dmb (rr rw wr ww:bool)
.
#[export]
Hint Constructors rmw_instrT: core.

Definition regs_of_rmw_instr (i: rmw_instrT): IdSet.t :=
  match i with
  | rmw_instr_assign lhs rhs => IdSet.add lhs (regs_of_expr rhs)
  | rmw_instr_load _ res eloc => IdSet.add res (regs_of_expr eloc)
  | rmw_instr_store _ eloc eval => IdSet.union (regs_of_expr eloc) (regs_of_expr eval)
  | rmw_instr_fadd _ _ res eloc eadd => IdSet.add res (IdSet.union (regs_of_expr eloc) (regs_of_expr eadd))
  | _ => IdSet.empty
  end.

Inductive rmw_stmtT :=
| rmw_stmt_instr (i:rmw_instrT)
| rmw_stmt_if (cond:exprT) (s1 s2:list rmw_stmtT)
| rmw_stmt_dowhile (s:list rmw_stmtT) (cond:exprT)
.
#[export]
Hint Constructors rmw_stmtT: core.
Coercion rmw_stmt_instr: rmw_instrT >-> rmw_stmtT.

Definition rmw_program := IdMap.t (list rmw_stmtT).

Module RMWEvent.
  Variant t A `{_: orderC A} :=
  | internal
  | control (ctrl:A)
  | read (ord:OrdR.t) (vloc:ValA.t (A:=A)) (res:ValA.t (A:=A))
  | write (ord:OrdW.t) (vloc:ValA.t (A:=A)) (vval:ValA.t (A:=A))
  | fadd (ordr:OrdR.t) (ordw:OrdW.t) (vloc vold vnew: ValA.t (A:=A))
  | dmb (rr rw wr ww:bool)
  .
End RMWEvent.

Module RMWState.
Section RMWState.
  Context A `{_: orderC A}.

  Inductive t := mk {
    stmts: list rmw_stmtT;
    rmap: RMap.t (A:=A);
  }.

  Definition init (stmts:list rmw_stmtT): t := mk stmts (RMap.init (A:=A)).

  Definition is_terminal (st:t): Prop :=
    st.(stmts) = [].
  #[local]
  Hint Unfold is_terminal: core.

  Inductive step: forall (e:RMWEvent.t (A:=A)) (st1 st2:t), Prop :=
  | step_skip
      stmts rmap:
      step RMWEvent.internal
           (mk ((rmw_stmt_instr rmw_instr_skip)::stmts) rmap)
           (mk stmts rmap)
  | step_assign
      lhs rhs stmts rmap rmap'
      (RMAP: rmap' = RMap.add lhs (sem_expr rmap rhs) rmap):
      step RMWEvent.internal
           (mk ((rmw_stmt_instr (rmw_instr_assign lhs rhs))::stmts) rmap)
           (mk stmts rmap')
  | step_load
      o res eloc stmts rmap vloc vres rmap'
      (LOC: vloc = sem_expr rmap eloc)
      (RMAP: rmap' = RMap.add res vres rmap):
      step (RMWEvent.read o vloc vres)
           (mk ((rmw_stmt_instr (rmw_instr_load o res eloc))::stmts) rmap)
           (mk stmts rmap')
  | step_store
      o eloc eval stmts rmap vloc vval
      (LOC: vloc = sem_expr rmap eloc)
      (VAL: vval = sem_expr rmap eval):
      step (RMWEvent.write o vloc vval)
           (mk ((rmw_stmt_instr (rmw_instr_store o eloc eval))::stmts) rmap)
           (mk stmts rmap)
  | step_fadd
      or ow res eloc eadd stmts rmap vloc vold vnew rmap'
      (LOC: vloc = sem_expr rmap eloc)
      (NEW: vnew = sem_op2 op_add vold (sem_expr rmap eadd))
      (RMAP: rmap' = RMap.add res vold rmap):
      step (RMWEvent.fadd or ow vloc vold vnew)
           (mk ((rmw_stmt_instr (rmw_instr_fadd or ow res eloc eadd))::stmts) rmap)
           (mk stmts rmap')
  | step_dmb
      rr rw wr ww stmts rmap:
      step (RMWEvent.dmb rr rw wr ww)
           (mk ((rmw_stmt_instr (rmw_instr_dmb rr rw wr ww))::stmts) rmap)
           (mk stmts rmap)
  | step_if
      cond vcond s1 s2 stmts rmap stmts'
      (COND: vcond = sem_expr rmap cond)
      (STMTS: stmts' = (if vcond.(ValA.val) <> 0%Z then s1 else s2) ++ stmts):
      step (RMWEvent.control vcond.(ValA.annot))
           (mk ((rmw_stmt_if cond s1 s2)::stmts) rmap)
           (mk stmts' rmap)
  | step_dowhile
      s cond stmts rmap stmts'
      (STMTS: stmts' = s ++ [rmw_stmt_if cond ((rmw_stmt_dowhile s cond) :: stmts) stmts]):
      step RMWEvent.internal
           (mk ((rmw_stmt_dowhile s cond)::stmts) rmap)
           (mk stmts' rmap)
  .
  #[local]
  Hint Constructors step: core.
End RMWState.
End RMWState.


Require Export Estado.
Require Export DefBasicas.
Require Export Semantica.
Require Import Tacticas.
Require Import ValidStateLemmas.
Require Import SameEnvLemmas.

Require Import Classical.

Lemma VerifyOldAppIsInvariant : forall (s s':System) (sValid:validstate s) (a:idApp),
  pre_verifyOldApp a s -> post_verifyOldApp a s s' -> validstate s'.
Proof.
  intros.
  unfold validstate.
  unfold pre_verifyOldApp in H.
  unfold post_verifyOldApp in H0.
  destruct_conj H.
  destruct_conj H0.
  split.

  unfold allCmpDifferent.
  intros.
  apply (inAppS'InAppS a1 s) in H11;auto.
  apply (inAppS'InAppS a2 s) in H13;auto.
  apply (inAppSameCmpId s sValid c1 c2 a1 a2);auto.
  split.

  unfold notRepeatedCmps.
  intros.
  apply (inAppS'InAppS a1 s) in H11;auto.
  apply (inAppS'InAppS a2 s) in H13;auto.
  apply (inAppSameCmp s sValid c a1 a2);auto.
  split.

  unfold notCPrunning.
  rewrite <-H7.
  destructVS sValid.
  auto. split.

  apply (delTmpRunS' s);auto. split.

  apply (cmpRunAppInsS' s);auto. split.

  apply (resContAppInstS' s);auto. split.

  unfold statesConsistency.
  rewrite <- H5, <- H6.
  assert (sv2 := sValid). destructVS sValid.
  intros.
  destructSC statesConsistencyVS a0.
  repeat (split;intros; auto).

- apply permsSC in H11.
  destruct H11 as [lPerm H11].
  destruct H2 as [H2 H13]; destruct_conj H13.
  apply H14 in H11.
  destruct H11 as [lPerm' [H11 H17]].
  exists lPerm'; auto.
- destruct H11 as [lPerm' H11]. destruct H2.
  apply H2 in H11.
  destruct H11 as [lPerm [H11 _]].
  apply <- permsSC . exists lPerm;auto.
- apply grantedPermGroupsSC in H11.
  destruct H11 as [lGroup H11].
  destruct H0 as [H0 H13]; destruct_conj H13.
  apply H14 in H11.
  destruct H11 as [lGroup' [H11 _]].
  exists lGroup'; auto.
- destruct H11 as [lGroup' H11].
  destruct H0 as [H0 H13]; destruct_conj H13.
  apply H0 in H11.
  destruct H11 as [lGroup [H11 _]].
  apply <- grantedPermGroupsSC.
  exists lGroup; auto.
- assert (sv2 := sValid). destructVS sValid. split.
  unfold notDupApp.
  rewrite <- H5, <- H6.
  intros. auto. split.

  unfold notDupSysApp.
  rewrite <- H5.
  intros; auto. split.

  unfold notDupPerm.
  apply (notDupPermS' s);auto.
  split.

  unfold allMapsCorrect in *.
  destruct H2 as [H2 H13]; destruct_conj H13.
  destruct H0 as [H0 H16]; destruct_conj H16.
  rewrite <-H5, <-H7, <-H8, <-H9, <- H10.
  destruct_conj allMapsCorrectVS.
  repeat (split;auto). split.

  unfold grantedPermsExist.
  intros. destruct H2 as [H2 [H14 H15]].
  apply H2 in H11.
  destruct H11 as [lPerm [H11 H16]].
  apply (permExistsSpermExistsS' s);auto.
  apply H16 in H13.
  apply (grantedPermsExistVS a0 p lPerm); auto.

  unfold noDupSentIntents.
  rewrite <- H12.
  auto.
Qed.


Require Export LogRelIE.PseudoType.
Require Import LogRelIE.LemmasPseudoType.
Require Import StlcIso.SpecSyntax.
Require Import StlcIso.SpecEvaluation.
Require Import StlcIso.SpecTyping.
Require Import StlcIso.Size.
Require Import StlcEqui.SpecSyntax.
Require Import StlcEqui.SpecTyping.
Require Import StlcEqui.SpecEvaluation.
Require Import StlcEqui.Inst.
Require Import StlcEqui.Size.
Require Import UValIE.UVal.

Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Arith.Wf_nat.
Require Import Coq.micromega.Lia.

Inductive Direction : Set :=
| dir_lt
| dir_gt.

Definition World := nat.
Definition lev : World → nat := fun w => w.
Definition later : World → World := pred.
Fixpoint lateri (i : nat) : World → World :=
  match i with
    | 0 => fun x => x
    | S i => fun w => pred (lateri i w)
  end.

Definition PTRel := PTy → I.Tm → E.Tm → Prop.
Definition PCRel := PTy → I.PCtx → E.PCtx → Prop.

(* Intuitively: observing termination takes a step in addition to the actual evaluation steps *)
Definition Observe (n : nat) (T : nat → Prop) : Prop :=
  match n with
    | 0 => False
    | S n' => T n'
  end.

Lemma lt_le {w w' w''} (fw : w' < w) (fw' : w'' ≤ w') : w'' < w.
Proof.
  lia.
Defined.

Definition prod_rel (R₁ R₂ : I.Tm → E.Tm → Prop) : I.Tm → E.Tm → Prop :=
  fun ts tu =>
    match ts , tu with
      | I.pair ts₁ ts₂ , E.pair tu₁ tu₂ => R₁ ts₁ tu₁ ∧ R₂ ts₂ tu₂
      | _              , _              => False
    end.
Definition sum_rel (R₁ R₂ : I.Tm → E.Tm → Prop) : I.Tm → E.Tm → Prop :=
  fun ts tu =>
    match ts , tu with
      | I.inl ts' , E.inl tu' => R₁ ts' tu'
      | I.inr ts' , E.inr tu' => R₂ ts' tu'
      | _         , _         => False
    end.
(* Definition arr_rel (R₁ R₂ : F.Tm → I.Tm → Prop) : F.Tm → I.Tm → Prop := *)
(*   fun tsb tub => *)
(*     ∀ ts' tu', *)
(*       R₁ ts' tu' → *)
(*       R₂ (tsb [beta1 ts']) (tub [beta1 tu']). *)

(* Arguments prod_rel R₁ R₂ !ts !tu. *)
Arguments sum_rel R₁ R₂ !ts !tu.
(* Arguments arr_rel R₁ R₂ !ts !tu. *)

Section LogicalRelation.

  Variable (d: Direction).

  Definition Obs (w : World) (ts : I.Tm) (tu : E.Tm) :=
    match d with
      | dir_lt => Observe (lev w) (I.TermHor ts) → E.Terminating tu
      | dir_gt => Observe (lev w) (TermHor tu) → I.Terminating ts
    end.

  Definition contrel' (w : World) (vr' : ∀ w' : World, w' ≤ w → PTRel) : PCRel :=
   fun τ Cs Cu => ∀ w' (fw : w' ≤ w) ts tu, vr' w' fw τ ts tu → Obs w' (I.pctx_app ts Cs) (E.pctx_app tu Cu).

  Definition termrel' (w : World) (vr' : ∀ w' : World, w' ≤ w → PTRel) : PTRel :=
    fun τ ts tu => ∀ Cs Cu,
        I.ECtx Cs → E.ECtx Cu → contrel' w vr' τ Cs Cu →
        Obs w (I.pctx_app ts Cs) (E.pctx_app tu Cu).

  Definition is_inl (t t': I.Tm) : Prop := t = I.inl t'.

  Fixpoint has_n_folds (n : nat) (t : I.Tm) (t' : I.Tm) :=
    match n with
    | 0 => t = t'
    | S n => exists t2, t = I.fold_ t2 /\ has_n_folds n t2 t'
    end.

  (* ERROR: in the case for ptrec, we need to allow fold_s for the StlcIso term! *)
  Definition valrel' (w : World) (ind : ∀ (w' : World), w' < w → PTRel) : PTRel :=
    fun τ ts tu =>
      OfType τ ts tu ∧
      let latervr : PTRel := fun τ ts tu => ∀ w' (fw : w' < w), ind w' fw τ ts tu in
      let laterlatervr : ∀ w' (fw : w' < w) w'' (fw' : w'' ≤ w'), PTRel := fun w' fw w'' fw' => ind w'' (lt_le fw fw') in
      let vrunit : I.Tm → E.Tm → Prop := fun ts tu => ts = I.unit ∧ tu = E.unit in
      let vrbool : I.Tm → E.Tm → Prop := fun ts tu => (ts = I.true ∧ tu = E.true) ∨ (ts = I.false ∧ tu = E.false) in
      let vrprod : PTy → PTy → I.Tm → E.Tm → Prop :=
          fun τ₁ τ₂ =>
            prod_rel (latervr τ₁) (latervr τ₂) in
      let vrsum : PTy → PTy → I.Tm → E.Tm → Prop :=
          fun τ₁ τ₂ =>
            sum_rel (latervr τ₁) (latervr τ₂) in
      let vrarr : PTy → PTy → I.Tm → E.Tm → Prop :=
          fun τ₁ τ₂ ts tu =>
            exists ts' tu' τ₁' τ₂',
              ts = I.abs τ₁' ts' /\
              tu = E.abs τ₂' tu' /\
            ∀ w' (fw : w' < w) vs vu,
              (d = dir_gt -> E.size vu <= w') ->
              ind w' fw τ₁ vs vu ->
              termrel' w' (laterlatervr w' fw) τ₂ (ts' [beta1 vs]) (tu' [beta1 vu])
      in
      exists ts2, has_n_folds (LMC_pty τ) ts ts2 /\ I.Value ts /\
      match pUnfoldn (LMC_pty τ) τ with
      | ptunit => vrunit ts2 tu
      | ptbool => vrbool ts2 tu
      | ptprod τ₁ τ₂ => vrprod τ₁ τ₂ ts2 tu
      | ptsum τ₁ τ₂ => vrsum τ₁ τ₂ ts2 tu
      | ptarr τ₁ τ₂ => vrarr τ₁ τ₂ ts2 tu
      | ptrec _ => False
      | ptvar _ => False
      | pEmulDV n p τ' => match n with
                         | 0 => ts2 = I.unit ∧ p = imprecise
                         | S n' => (ts2 = unkUVal n ∧ p = imprecise) ∨
                                  exists ts',
                                  match unfoldn (LMC τ') τ' with
                                   | tunit => is_inl ts2 ts' ∧ vrunit ts' tu
                                   | tbool => is_inl ts2 ts' ∧ vrbool ts' tu
                                   | tprod τ₁ τ₂ => is_inl ts2 ts' ∧ vrprod (pEmulDV n' p τ₁) (pEmulDV n' p τ₂) ts' tu
                                   | tarr τ₁ τ₂ => is_inl ts2 ts' ∧ vrarr (pEmulDV n' p τ₁) (pEmulDV n' p τ₂) ts' tu
                                   | tsum τ₁ τ₂ => is_inl ts2 ts' ∧ vrsum (pEmulDV n' p τ₁) (pEmulDV n' p τ₂) ts' tu
                                   | trec τ'' => False
                                   | tvar _ => False
                                   end
                       end
      end.

  Definition valrel (w : World) (τ : PTy)(t₁ : I.Tm) (t₂ : E.Tm) : Prop :=
    Fix lt_wf (fun w => PTRel) valrel' w τ t₁ t₂.

  Lemma valrel_def_funext w (ind₁ ind₂ : ∀ w', w' < w → PTRel) :
    (∀ w' (fw : w' < w), ind₁ w' fw = ind₂ w' fw) →
    valrel' w ind₁ = valrel' w ind₂.
  Proof.
    intros.
    enough (ind₁ = ind₂) as -> by auto.
    extensionality w'.
    extensionality fw.
    trivial.
  Qed.

  Lemma valrel_fixp : ∀ w, valrel w = valrel' w (fun w _ => valrel w).
  Proof.
    refine (Fix_eq lt_wf (fun w => PTRel) valrel' valrel_def_funext).
  Qed.

  Definition contrel (w : World) : PCRel :=
    contrel' w (fun w fw => valrel w).

  Definition termrel (w : World) : PTRel :=
    termrel' w (fun w fw => valrel w).

  Lemma termrel_fixp :
    ∀ w, termrel w = termrel' w (fun w _ => valrel' w (fun w _ => valrel w)).
  Proof.
    unfold termrel.
    intros w.
    f_equal.
    (* Should we avoid functional extensionality? *)
    extensionality w'.
    extensionality fw.
    apply valrel_fixp.
  Qed.

  Definition envrel (w : World) (Γ : PEnv) (γs : Sub I.Tm) (γu : Sub E.Tm) : Prop :=
    ∀ i τ, ⟪ i : τ p∈ Γ ⟫ → valrel w τ (γs i) (γu i).

  Definition OpenLRN (n : nat) (Γ : PEnv) (ts : I.Tm) (tu : E.Tm) (τ : PTy) : Prop :=
    ⟪ repEmulCtx Γ i⊢ ts : repEmul τ ⟫ ∧
    ⟪ isToEqCtx Γ e⊢ tu : isToEq τ ⟫ ∧
    (* ⟨ pdom Γ ⊢ tu ⟩ ∧ *)
    ∀ w, lev w ≤ n → ∀ γs γu, envrel w Γ γs γu → termrel w τ (ts [ γs ]) (tu [ γu ]).

  Definition OpenLR (Γ : PEnv) (ts : I.Tm) (tu : E.Tm) (τ : PTy) : Prop :=
    ∀ n, OpenLRN n Γ ts tu τ.

  Definition OpenLRCtxN (n : nat) (Cs : I.PCtx) (Cu : E.PCtx) (Γ' : PEnv) (τ' : PTy) (Γ : PEnv) (τ : PTy) : Prop :=
    ⟪ i⊢ Cs : repEmulCtx Γ' , repEmul τ' → repEmulCtx Γ , repEmul τ ⟫ ∧
    ⟪ e⊢ Cu : isToEqCtx Γ' , isToEq τ' → isToEqCtx Γ , isToEq τ ⟫ ∧
    ∀ ts tu, OpenLRN n Γ' ts tu τ' -> OpenLRN n Γ (I.pctx_app ts Cs) (E.pctx_app tu Cu) τ.

  Definition OpenLRCtx (Cs : I.PCtx) (Cu : E.PCtx) (Γ' : PEnv) (τ' : PTy) (Γ : PEnv) (τ : PTy) : Prop :=
    ⟪ i⊢ Cs : repEmulCtx Γ' , repEmul τ' → repEmulCtx Γ' , repEmul τ ⟫ ∧
    ⟪ e⊢ Cu : isToEqCtx Γ' , isToEq τ' → isToEqCtx Γ' , isToEq τ ⟫ ∧
    ∀ ts tu, OpenLR Γ' ts tu τ' → OpenLR Γ (I.pctx_app ts Cs) (E.pctx_app tu Cu) τ.

End LogicalRelation.

Arguments termrel d w τ t₁ t₂ : simpl never.
Arguments valrel d w τ t₁ t₂ : simpl never.
Arguments valrel' d w ind !τ !t₁ !t₂ /.

Notation "⟪ Γ ⊩ ts ⟦ d , n ⟧ tu : τ ⟫" := (OpenLRN d n Γ ts tu τ)
  (at level 0, ts at level 98,
   d at level 98, n at level 98,
   tu at level 98,
   Γ at level 98, τ at level 98,
   format "⟪ Γ ⊩  ts ⟦ d , n ⟧ tu  :  τ  ⟫").

Notation "⟪ Γ ⊩ ts ⟦ d ⟧ tu : τ ⟫" := (OpenLR d Γ ts tu τ)
  (at level 0, ts at level 98,
   d at level 98, tu at level 98,
   Γ at level 98, τ at level 98,
   format "⟪ Γ ⊩  ts ⟦ d ⟧ tu  :  τ  ⟫").

Notation "⟪ ⊩ Cs ⟦ d , n ⟧ Cu : Γ₀ , τ₀ → Γ , τ ⟫" := (OpenLRCtxN d n Cs Cu Γ₀ τ₀ Γ τ)
  (at level 0, Cs at level 98,
   d at level 98, n at level 98,
   Cu at level 98,
   Γ₀ at level 98, τ₀ at level 98,
   Γ at level 98, τ at level 98,
   format "⟪  ⊩  Cs ⟦ d , n ⟧ Cu  :  Γ₀ ,  τ₀  →  Γ ,  τ  ⟫").

Notation "⟪ ⊩ Cs ⟦ d ⟧ Cu : Γ₀ , τ₀ → Γ , τ ⟫" := (OpenLRCtx d Cs Cu Γ₀ τ₀ Γ τ)
  (at level 0, Cs at level 98,
   d at level 98, Cu at level 98,
   Γ₀ at level 98, τ₀ at level 98,
   Γ at level 98, τ at level 98,
   format "⟪  ⊩  Cs ⟦ d ⟧ Cu  :  Γ₀ ,  τ₀  →  Γ ,  τ  ⟫").

Section TermRelZero.
  Definition termreli₀ d dfc w τ ts tu :=
    (∃ vs vu, clos_refl_trans_1n I.Tm I.eval ts vs ∧ tu -->* vu ∧
              valrel d w τ vs vu) ∨
    (forall Cs Cu, I.ECtx Cs → E.ECtx Cu → Obs d (lateri dfc w) (I.pctx_app ts Cs) (E.pctx_app tu Cu)).

  Arguments termreli₀ d dfc w τ ts tu : simpl never.

  Definition termrel₀ d w τ ts tu :=
    termreli₀ d 0 w τ ts tu.

  Arguments termrel₀ d w τ ts tu : simpl never.

End TermRelZero.

Section TermRelZeroNoDiv.
  Definition termrelnd₀ d w τ ts tu :=
    match d with
    | dir_lt => forall vs, I.Value vs -> clos_refl_trans_1n I.Tm I.eval ts vs ->
                     ∃ vu, E.Value vu /\ tu -->* vu ∧ valrel d w τ vs vu
    | dir_gt => forall vu, E.Value vu -> tu -->* vu ->
                     ∃ vs, I.Value vs /\ clos_refl_trans_1n I.Tm I.eval ts vs ∧ valrel d w τ vs vu
    end.

  Arguments termrelnd₀ d w τ ts tu : simpl never.
End TermRelZeroNoDiv.


(*
 This is the definition of formal syntax for Dan Grossman's Thesis,
  "SAFE PROGRAMMING AT THE C LEVEL OF ABSTRACTION".

  The trivial subset of the language.
*)

Require Import List.
Export ListNotations.
Require Import ZArith.
Require Import Init.Datatypes.
Require Import CpdtTactics.

Require Export FormalSyntax.
Require Export DynamicSemanticsTypeSubstitution.
Require Export DynamicSemanticsHeapObjects.
Require Export DynamicSemantics.
Require Export DynamicSemanticsTypeSubstitution.
Require Export StaticSemanticsKindingAndContextWellFormedness.
Require Export StaticSemantics.
Require Export TypeSafetyProof.
Require Export TypeSafety.

Fixpoint EmptySubsetTau (tau : Tau) :=
  match tau with
    | _ => False
  end.

Fixpoint EmptySubsetSt (s : St) :=
  match s with
    | _ => False
  end.

Fixpoint EmptySubsetE (e : E) :=
  match e with
    | _ => False
  end.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal29.

From lfind Require Import LFind.
Lemma lfind_state  (n:natural) (x:lst) (IHx:@eq lst (rev (rev x)) x):@eq lst (rev (append (rev x) (Cons n Nil))) (Cons n x).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal29_rev_involutive_70_rev_append/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : natural -> string -> natural.
Extract Constant print => "Extract.print".
Definition collect_data  (n:natural) (x:lst) :=
 let lfind_var := "n:" ++ "(" ++ show n ++ ")"++ "|" ++"x:" ++ "(" ++ show x ++ ")"
 in let lfind_v := print n lfind_var
 in lfind_state lfind_v  x.
QuickChick collect_data.
Success.


(* (C) 2021 Digamma.ai *)

Require Export StructTact.StructTactics.
Require Export VST.floyd.proofauto.
Require Export VST.floyd.library.
Require Export Clight.demo.

Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

(* Define some notation for integers *)
Delimit Scope IntScope with int.
Infix "<" := Int.lt : IntScope.
Notation "0" := Int.zero : IntScope.
Delimit Scope Int64Scope with int64.
Infix "<" := Int64.lt : Int64Scope.

Open Scope int.

Definition S32Min := Int.repr Int.min_signed.
Definition S32Max := Int.repr Int.max_signed.
Definition U32Min := 0.
Definition U32Max := Int.repr Int.max_unsigned.

Definition reg_struct (reg : val) ref_obj_id s32_min_value s32_max_value
           u32_min_value u32_max_value smin_value64 smax_value64
           umin_value64 umax_value64 :=
           (Vint ref_obj_id,
            (Vint s32_min_value,
             (Vint s32_max_value,
              (Vint u32_min_value,
               (Vint u32_max_value,
                (Vlong smin_value64,
                 (Vlong smax_value64,
                  (Vlong umin_value64,
                   Vlong umax_value64)))))))).

Open Scope int64.
Open Scope bool.
(* int64 -> int32 *)

Definition int64_to_32 i := Int.repr (Int64.unsigned i).
Definition int32_to_64 i := Int64.repr (Int.unsigned i).

(* The three functions below are correctly specified and needed for the correctness proof *)

Definition Sbounds s :=
   (int32_to_64 S32Min < s) && (s < int32_to_64 S32Max).

Definition Ubounds s :=
   (int32_to_64 U32Min < s) && (s < int32_to_64 U32Max).

Definition __reg64_bound_s32_spec : (ident * funspec) :=
    DECLARE ___reg64_bound_s32
    WITH a : int64
    PRE [tlong]
      PROP ()
      PARAMS (Vlong a)
      GLOBALS ()
      SEP ()
    POST [tbool]
      PROP ()
      LOCAL (temp ret_temp (Val.of_bool (Sbounds a)))
      SEP ().

Definition __reg64_bound_u32_spec : (ident * funspec) :=
    DECLARE ___reg64_bound_u32
    WITH a : int64
    PRE [tulong]
      PROP ()
      PARAMS (Vlong a)
      GLOBALS ()
      SEP ()
    POST [tbool]
      PROP ()
      LOCAL (temp ret_temp (Val.of_bool (Ubounds a)))
      SEP ().

Definition __mark_reg32_unbounded_spec : (ident * funspec) :=
    DECLARE ___mark_reg32_unbounded
    WITH reg : val,
         ref_obj_id : int,
         s32_min_value : int,
         s32_max_value : int,
         u32_min_value : int,
         u32_max_value : int,
         smin_value64 : int64,
         smax_value64 : int64,
         umin_value64 : int64,
         umax_value64 : int64
    PRE [tptr (Tstruct _bpf_reg_state noattr)]
      PROP ()
      PARAMS (reg)
      GLOBALS ()
      SEP (data_at Tsh (Tstruct _bpf_reg_state noattr)
                   (reg_struct reg ref_obj_id
                               s32_min_value s32_max_value
                               u32_min_value u32_max_value
                               smin_value64 smax_value64
                               umin_value64 umax_value64) reg)
    POST [tvoid]
      PROP ()
      LOCAL ()
      SEP (data_at Tsh (Tstruct _bpf_reg_state noattr)
                   (reg_struct reg ref_obj_id
                               S32Min S32Max
                               U32Min U32Max
                               smin_value64 smax_value64
                               umin_value64 umax_value64) reg).

(* We assume that these functions do nothing *)

Definition __reg_deduce_bounds_spec : (ident * funspec) :=
    DECLARE ___reg_deduce_bounds
    WITH reg : val
    PRE [tptr (Tstruct _bpf_reg_state noattr)]
      PROP ()
      PARAMS (reg)
      GLOBALS ()
      SEP ()
    POST [tvoid]
      PROP ()
      LOCAL ()
      SEP ().

Definition __reg_bound_offset_spec : (ident * funspec) :=
    DECLARE ___reg_bound_offset
    WITH reg : val
    PRE [tptr (Tstruct _bpf_reg_state noattr)]
      PROP ()
      PARAMS (reg)
      GLOBALS ()
      SEP ()
    POST [tvoid]
      PROP ()
      LOCAL ()
      SEP ().

Definition __update_reg_bounds_spec : (ident * funspec) :=
    DECLARE ___update_reg_bounds
    WITH reg : val
    PRE [tptr (Tstruct _bpf_reg_state noattr)]
      PROP ()
      PARAMS (reg)
      GLOBALS ()
      SEP ()
    POST [tvoid]
      PROP ()
      LOCAL ()
      SEP ().

Open Scope int64.

(* This is the main function spec *)

Open Scope bool.

Definition post_reg_struct reg ref_obj_id
  smin_value64 smax_value64 umin_value64 umax_value64 :=
  (reg_struct reg ref_obj_id
              (if (Sbounds smin_value64 && Sbounds smax_value64)
               then (int64_to_32 smin_value64)
               else S32Min)
              (if (Sbounds smin_value64 && Sbounds smax_value64)
               then (int64_to_32 smax_value64)
               else S32Max)
              (if (Ubounds umin_value64 && Ubounds umax_value64)
               then (int64_to_32 umin_value64)
               else U32Min)
              (if (Ubounds umin_value64 && Ubounds umax_value64)
               then (int64_to_32 umax_value64)
               else U32Max)
              smin_value64 smax_value64 umin_value64 umax_value64).

Definition __reg_combine_64_into_32_spec : funspec :=
    WITH reg : val,
         ref_obj_id : int,
         s32_min_value : int,
         s32_max_value : int,
         u32_min_value : int,
         u32_max_value : int,
         smin_value64 : int64,
         smax_value64 : int64,
         umin_value64 : int64,
         umax_value64 : int64
    PRE [tptr (Tstruct _bpf_reg_state noattr)]
      PROP ()
      PARAMS (reg)
      GLOBALS ()
      SEP (data_at Tsh (Tstruct _bpf_reg_state noattr)
                   ((reg_struct reg ref_obj_id
                               s32_min_value s32_max_value
                               u32_min_value u32_max_value
                               smin_value64 smax_value64
                               umin_value64 umax_value64)) reg)
    POST [tvoid]
      EX s32_min_value' s32_max_value' u32_min_value' u32_max_value',
      PROP ((s32_min_value' = (int64_to_32 smin_value64)
             /\ s32_max_value' = (int64_to_32 smax_value64))
              \/ (s32_min_value' = S32Min /\ s32_max_value' = S32Max);

            (u32_min_value' = (int64_to_32 umin_value64)
             /\ u32_max_value' = (int64_to_32 umax_value64))
              \/ (u32_min_value' = U32Min /\ u32_max_value' = U32Max))
      LOCAL ()
      SEP (data_at Tsh (Tstruct _bpf_reg_state noattr)
                   (reg_struct reg ref_obj_id
                               s32_min_value' s32_max_value'
                               u32_min_value' u32_max_value'
                               smin_value64 smax_value64
                               umin_value64 umax_value64) reg).

(* Small proof automation step *)
Ltac forward_H H := repeat forward; erewrite H; entailer!.