Require Import RamifyCoq.sample_mark.env_unionfind_iter.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.subgraph2.
Require Import RamifyCoq.graph.graph_relation.
Require Import RamifyCoq.graph.reachable_computable.
Require Import RamifyCoq.msl_application.Graph.
Require Import RamifyCoq.msl_application.UnionFindGraph.
Require Import RamifyCoq.msl_application.GList.
Require Import RamifyCoq.msl_application.GList_UnionFind.
Require Import RamifyCoq.floyd_ext.share.
Require Import RamifyCoq.sample_mark.spatial_graph_uf_iter.

Local Coercion UGraph_LGraph: Graph >-> LGraph.
Local Coercion LGraph_SGraph: LGraph >-> SGraph.
Local Identity Coercion ULGraph_LGraph: LGraph >-> UnionFindGraph.LGraph.
Local Identity Coercion LGraph_LabeledGraph: UnionFindGraph.LGraph >-> LabeledGraph.
Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Notation vertices_at sh P g:= (@vertices_at _ _ _ _ _ mpred (@SGP pSGG_VST nat unit (sSGG_VST sh)) (SGA_VST sh) P g).
Notation whole_graph sh g := (vertices_at sh (vvalid g) g).
Notation graph sh x g := (@reachable_vertices_at _ _ _ _ _ _ _ _ _ _ (@SGP pSGG_VST nat unit (sSGG_VST sh)) _ x g).
Notation Graph := (@Graph pSGG_VST).
Notation uf_under_bound g := (uf_under_bound id g).
Existing Instances maGraph finGraph liGraph RGF.

Definition find_spec :=
 DECLARE _find
  WITH sh: wshare, g: Graph, x: pointer_val
  PRE [ _x OF (tptr (Tstruct _Node noattr))]
          PROP  (vvalid g x /\ uf_under_bound g)
          LOCAL (temp _x (pointer_val_val x))
          SEP   (whole_graph sh g)
  POST [ tptr (Tstruct _Node noattr) ]
        EX g': Graph, EX rt : pointer_val,
        PROP (uf_equiv g g' /\ uf_root g' x rt /\ uf_under_bound g' /\ rank_unchanged g g')
        LOCAL (temp ret_temp (pointer_val_val rt))
        SEP (whole_graph sh g').

Definition Gprog : funspecs := ltac:(with_library prog [find_spec]).

Lemma false_Cne_eq: forall x y, typed_false tint (force_val (sem_cmp_pp Cne (pointer_val_val x) (pointer_val_val y))) -> x = y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; auto. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. subst; auto.
    + simpl in H. inversion H.
  - simpl in H. inversion H.
Qed.

Lemma true_Cne_neq: forall x y, typed_true tint (force_val (sem_cmp_pp Cne (pointer_val_val x) (pointer_val_val y))) -> x <> y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; [|intro; inversion H0..]. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + simpl in H. inversion H.
    + subst b0. pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. intro; apply H0. inversion H1. reflexivity.
  - intro. inversion H0. auto.
Qed.

Lemma graph_local_facts: forall sh x (g: Graph), vvalid g x -> whole_graph sh g |-- valid_pointer (pointer_val_val x).
Proof.
  intros. eapply derives_trans; [apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g (vvalid g) x (vgamma g x)); auto |].
  simpl vertex_at at 1. unfold binode. entailer!.
Qed.

Lemma body_find: semax_body Vprog Gprog f_find find_spec.
Proof.
  start_function.
  destruct H. remember (vgamma g x) as rpa eqn:?H. destruct rpa as [r pa]. symmetry in H1.
  (* tmp = x *)
  Opaque pointer_val_val. forward. Transparent pointer_val_val.
  (* p = x -> parent; *)
  localize [data_at sh node_type (vgamma2cdata (vgamma g x)) (pointer_val_val x)].
  rewrite H1. simpl vgamma2cdata. forward. 1: entailer!; destruct pa; simpl; auto.
  unlocalize [whole_graph sh g].
  1: rewrite H1; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g (vvalid g) x (r, pa)); auto.
  forward_while (EX p: pointer_val, EX ppa: pointer_val,
                 PROP (reachable g x p /\ vgamma g p = (vlabel g p, ppa))
                 LOCAL (temp _p (pointer_val_val ppa); temp _tmp (pointer_val_val p); temp _x (pointer_val_val x))
                 SEP (vertices_at sh (vvalid g) g)).
  - Exists x pa. entailer!. split; [apply reachable_refl | f_equal; simpl in H1; inversion H1]; auto.
  - entailer!. destruct H2. apply reachable_foot_valid in H2. pose proof (valid_parent _ _ _ _ H2 H6). apply denote_tc_test_eq_split; apply graph_local_facts; auto.
  - destruct H2. apply true_Cne_neq in HRE.
    Opaque pointer_val_val. forward. Transparent pointer_val_val. remember (vgamma g ppa) as rpa eqn:?H. destruct rpa as [mr mgpa]. symmetry in H4.
    assert (H_VALID_PPA: vvalid g ppa) by (apply (valid_parent _ p (vlabel g p)); [apply reachable_foot_valid in H2 |]; auto).
    localize [data_at sh node_type (vgamma2cdata (vgamma g ppa)) (pointer_val_val ppa)].
    rewrite H4. simpl vgamma2cdata. forward. 1: entailer!; destruct mgpa; simpl; auto.
    unlocalize [whole_graph sh g].
    1: rewrite H4; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g (vvalid g) ppa (mr, mgpa)); auto.
    Exists (ppa, mgpa). simpl fst. simpl snd. assert (mr = vlabel g ppa) by (simpl in H4; inversion H4; auto). rewrite <- H5. entailer !.
    apply reachable_edge with p; auto. apply (vgamma_not_edge g p (vlabel g p)); auto. apply reachable_foot_valid in H2; auto.
  - destruct H2. apply false_Cne_eq in HRE. subst ppa. assert (uf_root g x p) by (split; intros; auto; apply (parent_loop g p (vlabel g p) y); auto).
    forward_while (EX g': Graph, EX tmp: pointer_val, EX xv: pointer_val,
                   PROP (uf_equiv g g' /\ uf_root g' xv p /\ uf_under_bound g' /\ rank_unchanged g g')
                   LOCAL (temp _p (pointer_val_val p); temp _tmp (pointer_val_val tmp); temp _x (pointer_val_val xv))
                   SEP (whole_graph sh g')).
    + Exists g p x. entailer !. split; [apply (uf_equiv_refl _  (liGraph g)) | repeat intro; auto].
    + entailer!. apply denote_tc_test_eq_split; apply graph_local_facts.
      * destruct H5 as [_ [[? _] _]]. apply reachable_head_valid in H5; assumption.
      * destruct H5 as [[? _] _]. rewrite <- H5. apply reachable_foot_valid in H2; assumption.
    + destruct H5 as [? [? [? ?]]]. apply true_Cne_neq in HRE. remember (vgamma g' xv) as rpa eqn:?H. destruct rpa as [xr xpa]. symmetry in H9.
      assert (H_VALID_XV: vvalid g' xv) by (destruct H6 as [? _]; apply reachable_head_valid in H6; auto).
      localize [data_at sh node_type (vgamma2cdata (vgamma g' xv)) (pointer_val_val xv)].
      rewrite H9. simpl vgamma2cdata. forward. 1: entailer!; destruct xpa; simpl; auto.
      unlocalize [whole_graph sh g'].
      1: rewrite H9; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g' (vvalid g') xv (xr, xpa)); auto.
      assert (weak_valid g' p) by (right; destruct H5; rewrite <- H5; apply reachable_foot_valid in H2; auto).
      assert (vvalid g' xv) by (destruct H6; apply reachable_head_valid in H6; auto).
      assert (~ reachable g' p xv) by (intro; destruct H6 as [_ ?]; specialize (H6 _ H12); auto).
      assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g' xv p H10 H11 H12)) (Graph_gen_redirect_parent g' xv p H10 H11 H12) =
              vertices_at sh (vvalid g') (Graph_gen_redirect_parent g' xv p H10 H11 H12)). {
        apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
      assert (H_P_NOT_NULL: p <> null) by (apply reachable_foot_valid in H2; intro; subst p; apply (valid_not_null g null H2); simpl; auto).
      localize [data_at sh node_type (Vint (Int.repr (Z.of_nat xr)), pointer_val_val xpa) (pointer_val_val xv)].
      forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g' xv p H10 H11 H12)].
      1: rewrite H13; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
      Opaque pointer_val_val. forward. Transparent pointer_val_val.
      Exists (((Graph_gen_redirect_parent g' xv p H10 H11 H12), xpa), xpa). simpl fst. simpl snd. entailer !. split; [|split].
      * apply (graph_gen_redirect_parent_equiv' g g' xv p); auto.
      * apply (uf_root_gen_dst_preserve g' (liGraph g')); auto.
        -- apply (vgamma_not_reachable _ _ xr); auto. pose proof (uf_root_not_eq_root_vgamma g' _ _ _ _ H9 H6 HRE). auto.
        -- apply (vgamma_uf_root g' xv xr xpa p); auto.
      * apply uf_under_bound_redirect_parent; auto.
    + destruct H5 as [? [? ?]]. forward. Exists g' p. entailer !. split; [|auto]. rewrite <- (uf_equiv_root_the_same g g' x p); auto.
Qed. (* Original: 118.49 secs; VST 2.*: 3.12 secs *)


Require Import Poulet4.P4light.Syntax.Typed.
Require Import Poulet4.P4light.Syntax.Syntax.
Require Import Poulet4.P4light.Syntax.Value.
Require Import Poulet4.P4light.Semantics.Semantics.
Require Import Poulet4.P4light.Syntax.P4defs.
Require Import Poulet4.P4light.Syntax.P4Notations.
Require Import Poulet4.P4light.Architecture.V1ModelTarget.
Require Import ProD3.core.SvalRefine.
Require Import ProD3.core.Members.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Import ListNotations.
Open Scope list_scope.
Open Scope string_scope.

(* A simplified switch model to demonstrate bloom filter application. *)

Section Switch.

Context {tags_t: Type} {tags_t_inhabitant : Inhabitant tags_t}.

Notation ident := string.
Notation path := (list ident).
Notation Val := (@ValueBase bool).
Notation Expression := (@Expression tags_t).
Notation P4Type := (@P4Type tags_t).
Notation extern_state := (@extern_state tags_t Expression).

Instance target : @Target tags_t Expression := V1Model.

Variable ge : genv.
Variable M : P4Type.

Definition standard_metadata_t : P4Type :=
  TypStruct
    [(!"ingress_port", TypBit 9); (!"egress_spec", TypBit 9); (!"egress_port", TypBit 9);
    (!"instance_type", TypBit 32); (!"packet_length", TypBit 32); (!"enq_timestamp", TypBit 32);
    (!"enq_qdepth", TypBit 19); (!"deq_timedelta", TypBit 32); (!"deq_qdepth", TypBit 19);
    (!"ingress_global_timestamp", TypBit 48); (!"egress_global_timestamp", TypBit 48);
    (!"mcast_grp", TypBit 16); (!"egress_rid", TypBit 16); (!"checksum_error", TypBit 1);
    (!"parser_error", TypError); (!"priority", TypBit 3)].

Inductive port :=
  | port_int
  | port_ext.

Definition port_to_Z (p : port) :=
  match p with
  | port_int => 0
  | port_ext => 1
  end.

Definition port_to_sval (p : port) :=
  ValBaseBit (P4Arith.to_loptbool 9 (port_to_Z p)).

Definition out_port_to_Z (p : option port) :=
  match p with
  | Some p => port_to_Z p
  | None => 511
  end.

Definition out_port_to_sval (p : option port) :=
  ValBaseBit (P4Arith.to_loptbool 9 (out_port_to_Z p)).

Inductive process_packet : extern_state -> (Z * port) -> extern_state -> option (Z * port) -> Prop :=
  | process_packet_intro : forall es data in_port es' data' out_port meta' std_meta' class_name inst_path targs fd m',
      PathMap.get ["main"; "ig"] (ge_inst ge) = Some {|iclass:=class_name; ipath:=inst_path; itargs:=targs|} ->
      PathMap.get ([class_name; "apply"]) (ge_func ge) = Some fd ->
      0 <= data < Z.pow 2 16 ->
      let hdr := ValBaseStruct [("myHeader",
        ValBaseHeader [("data", ValBaseBit (P4Arith.to_loptbool 16 data))] (Some true))] in
      let meta := force ValBaseNull (uninit_sval_of_typ None M) in
      let std_meta := update "ingress_port" (port_to_sval in_port) (force ValBaseNull (uninit_sval_of_typ None standard_metadata_t)) in
      0 <= data' < Z.pow 2 16 ->
      let hdr' := ValBaseStruct [("myHeader",
        ValBaseHeader [("data", ValBaseBit (P4Arith.to_loptbool 16 data'))] (Some true))] in
      Members.get "egress_spec" std_meta' = out_port_to_sval out_port ->
      exec_func ge read_ndetbit inst_path (PathMap.empty, es) fd nil [hdr; meta; std_meta]
          (m', es') [hdr'; meta'; std_meta'] (SReturn ValBaseNull) ->
      process_packet es (data, in_port) es' (option_map (pair data') out_port).

Inductive process_packets : extern_state -> list (Z * port) -> extern_state -> list (option (Z * port)) -> Prop :=
  | process_packets_nil : forall es,
      process_packets es [] es []
  | process_packets_cons : forall es1 p p' es2 ps ps' es3,
      process_packet es1 p es2 p' ->
      process_packets es2 ps es3 ps' ->
      process_packets es1 (p :: ps) es3 (p' :: ps').

End Switch.


From Coq Require Import String List ZArith.
From compcert Require Import Coqlib Integers Floats AST Ctypes Cop Clight Clightdefs.
Import Clightdefs.ClightNotations.
Local Open Scope Z_scope.
Local Open Scope string_scope.
Local Open Scope clight_scope.

Module Info.
  Definition version := "3.11".
  Definition build_number := "".
  Definition build_tag := "".
  Definition build_branch := "".
  Definition arch := "x86".
  Definition model := "64".
  Definition abi := "standard".
  Definition bitsize := 64.
  Definition big_endian := false.
  Definition source_file := "prims.c".
  Definition normalized := true.
End Info.

Definition _Coq_Numbers_BinNums_Zneg_arg_0 : ident := $"Coq_Numbers_BinNums_Zneg_arg_0".
Definition _Coq_Numbers_BinNums_Zneg_args : ident := $"Coq_Numbers_BinNums_Zneg_args".
Definition _Coq_Numbers_BinNums_Zpos_arg_0 : ident := $"Coq_Numbers_BinNums_Zpos_arg_0".
Definition _Coq_Numbers_BinNums_Zpos_args : ident := $"Coq_Numbers_BinNums_Zpos_args".
Definition _Coq_Numbers_BinNums_xI_arg_0 : ident := $"Coq_Numbers_BinNums_xI_arg_0".
Definition _Coq_Numbers_BinNums_xI_args : ident := $"Coq_Numbers_BinNums_xI_args".
Definition _Coq_Numbers_BinNums_xO_arg_0 : ident := $"Coq_Numbers_BinNums_xO_arg_0".
Definition _Coq_Numbers_BinNums_xO_args : ident := $"Coq_Numbers_BinNums_xO_args".
Definition ___builtin_ais_annot : ident := $"__builtin_ais_annot".
Definition ___builtin_annot : ident := $"__builtin_annot".
Definition ___builtin_annot_intval : ident := $"__builtin_annot_intval".
Definition ___builtin_bswap : ident := $"__builtin_bswap".
Definition ___builtin_bswap16 : ident := $"__builtin_bswap16".
Definition ___builtin_bswap32 : ident := $"__builtin_bswap32".
Definition ___builtin_bswap64 : ident := $"__builtin_bswap64".
Definition ___builtin_clz : ident := $"__builtin_clz".
Definition ___builtin_clzl : ident := $"__builtin_clzl".
Definition ___builtin_clzll : ident := $"__builtin_clzll".
Definition ___builtin_ctz : ident := $"__builtin_ctz".
Definition ___builtin_ctzl : ident := $"__builtin_ctzl".
Definition ___builtin_ctzll : ident := $"__builtin_ctzll".
Definition ___builtin_debug : ident := $"__builtin_debug".
Definition ___builtin_expect : ident := $"__builtin_expect".
Definition ___builtin_fabs : ident := $"__builtin_fabs".
Definition ___builtin_fabsf : ident := $"__builtin_fabsf".
Definition ___builtin_fmadd : ident := $"__builtin_fmadd".
Definition ___builtin_fmax : ident := $"__builtin_fmax".
Definition ___builtin_fmin : ident := $"__builtin_fmin".
Definition ___builtin_fmsub : ident := $"__builtin_fmsub".
Definition ___builtin_fnmadd : ident := $"__builtin_fnmadd".
Definition ___builtin_fnmsub : ident := $"__builtin_fnmsub".
Definition ___builtin_fsqrt : ident := $"__builtin_fsqrt".
Definition ___builtin_membar : ident := $"__builtin_membar".
Definition ___builtin_memcpy_aligned : ident := $"__builtin_memcpy_aligned".
Definition ___builtin_read16_reversed : ident := $"__builtin_read16_reversed".
Definition ___builtin_read32_reversed : ident := $"__builtin_read32_reversed".
Definition ___builtin_sel : ident := $"__builtin_sel".
Definition ___builtin_sqrt : ident := $"__builtin_sqrt".
Definition ___builtin_unreachable : ident := $"__builtin_unreachable".
Definition ___builtin_va_arg : ident := $"__builtin_va_arg".
Definition ___builtin_va_copy : ident := $"__builtin_va_copy".
Definition ___builtin_va_end : ident := $"__builtin_va_end".
Definition ___builtin_va_start : ident := $"__builtin_va_start".
Definition ___builtin_write16_reversed : ident := $"__builtin_write16_reversed".
Definition ___builtin_write32_reversed : ident := $"__builtin_write32_reversed".
Definition ___compcert_i64_dtos : ident := $"__compcert_i64_dtos".
Definition ___compcert_i64_dtou : ident := $"__compcert_i64_dtou".
Definition ___compcert_i64_sar : ident := $"__compcert_i64_sar".
Definition ___compcert_i64_sdiv : ident := $"__compcert_i64_sdiv".
Definition ___compcert_i64_shl : ident := $"__compcert_i64_shl".
Definition ___compcert_i64_shr : ident := $"__compcert_i64_shr".
Definition ___compcert_i64_smod : ident := $"__compcert_i64_smod".
Definition ___compcert_i64_smulh : ident := $"__compcert_i64_smulh".
Definition ___compcert_i64_stod : ident := $"__compcert_i64_stod".
Definition ___compcert_i64_stof : ident := $"__compcert_i64_stof".
Definition ___compcert_i64_udiv : ident := $"__compcert_i64_udiv".
Definition ___compcert_i64_umod : ident := $"__compcert_i64_umod".
Definition ___compcert_i64_umulh : ident := $"__compcert_i64_umulh".
Definition ___compcert_i64_utod : ident := $"__compcert_i64_utod".
Definition ___compcert_i64_utof : ident := $"__compcert_i64_utof".
Definition ___compcert_va_composite : ident := $"__compcert_va_composite".
Definition ___compcert_va_float64 : ident := $"__compcert_va_float64".
Definition ___compcert_va_int32 : ident := $"__compcert_va_int32".
Definition ___compcert_va_int64 : ident := $"__compcert_va_int64".
Definition _alloc : ident := $"alloc".
Definition _alloc_make_Coq_Numbers_BinNums_Z_Zpos : ident := $"alloc_make_Coq_Numbers_BinNums_Z_Zpos".
Definition _alloc_make_Coq_Numbers_BinNums_positive_xI : ident := $"alloc_make_Coq_Numbers_BinNums_positive_xI".
Definition _alloc_make_Coq_Numbers_BinNums_positive_xO : ident := $"alloc_make_Coq_Numbers_BinNums_positive_xO".
Definition _args : ident := $"args".
Definition _bit : ident := $"bit".
Definition _get_Coq_Numbers_BinNums_Z_tag : ident := $"get_Coq_Numbers_BinNums_Z_tag".
Definition _get_Coq_Numbers_BinNums_Zneg_args : ident := $"get_Coq_Numbers_BinNums_Zneg_args".
Definition _get_Coq_Numbers_BinNums_Zpos_args : ident := $"get_Coq_Numbers_BinNums_Zpos_args".
Definition _get_Coq_Numbers_BinNums_positive_tag : ident := $"get_Coq_Numbers_BinNums_positive_tag".
Definition _get_Coq_Numbers_BinNums_xI_args : ident := $"get_Coq_Numbers_BinNums_xI_args".
Definition _get_Coq_Numbers_BinNums_xO_args : ident := $"get_Coq_Numbers_BinNums_xO_args".
Definition _heap : ident := $"heap".
Definition _i : ident := $"i".
Definition _limit : ident := $"limit".
Definition _main : ident := $"main".
Definition _make_Coq_Numbers_BinNums_Z_Z0 : ident := $"make_Coq_Numbers_BinNums_Z_Z0".
Definition _make_Coq_Numbers_BinNums_positive_xH : ident := $"make_Coq_Numbers_BinNums_positive_xH".
Definition _p : ident := $"p".
Definition _t : ident := $"t".
Definition _temp : ident := $"temp".
Definition _thread_info : ident := $"thread_info".
Definition _tinfo : ident := $"tinfo".
Definition _uint63_add : ident := $"uint63_add".
Definition _uint63_from_Z : ident := $"uint63_from_Z".
Definition _uint63_from_positive : ident := $"uint63_from_positive".
Definition _uint63_mul : ident := $"uint63_mul".
Definition _uint63_to_Z : ident := $"uint63_to_Z".
Definition _x : ident := $"x".
Definition _y : ident := $"y".
Definition _z : ident := $"z".
Definition _t'1 : ident := 128%positive.
Definition _t'2 : ident := 129%positive.
Definition _t'3 : ident := 130%positive.
Definition _t'4 : ident := 131%positive.
Definition _t'5 : ident := 132%positive.
Definition _t'6 : ident := 133%positive.
Definition _t'7 : ident := 134%positive.

Definition f_uint63_from_positive := {|
  fn_return := tlong;
  fn_callconv := cc_default;
  fn_params := ((_p, tlong) :: nil);
  fn_vars := nil;
  fn_temps := ((_t'5, tlong) ::
               (_t'4, (tptr (Tstruct _Coq_Numbers_BinNums_xO_args noattr))) ::
               (_t'3, tlong) ::
               (_t'2, (tptr (Tstruct _Coq_Numbers_BinNums_xI_args noattr))) ::
               (_t'1, tuint) :: (_t'7, tulong) :: (_t'6, tulong) :: nil);
  fn_body :=
(Ssequence
  (Scall (Some _t'1)
    (Evar _get_Coq_Numbers_BinNums_positive_tag (Tfunction
                                                  (Tcons tulong Tnil) tuint
                                                  cc_default))
    ((Etempvar _p tlong) :: nil))
  (Sswitch (Etempvar _t'1 tuint)
    (LScons (Some 0)
      (Ssequence
        (Ssequence
          (Scall (Some _t'2)
            (Evar _get_Coq_Numbers_BinNums_xI_args (Tfunction
                                                     (Tcons tulong Tnil)
                                                     (tptr (Tstruct _Coq_Numbers_BinNums_xI_args noattr))
                                                     cc_default))
            ((Etempvar _p tlong) :: nil))
          (Ssequence
            (Sset _t'7
              (Efield
                (Ederef
                  (Etempvar _t'2 (tptr (Tstruct _Coq_Numbers_BinNums_xI_args noattr)))
                  (Tstruct _Coq_Numbers_BinNums_xI_args noattr))
                _Coq_Numbers_BinNums_xI_arg_0 tulong))
            (Scall (Some _t'3)
              (Evar _uint63_from_positive (Tfunction (Tcons tlong Tnil) tlong
                                            cc_default))
              ((Etempvar _t'7 tulong) :: nil))))
        (Sreturn (Some (Ebinop Oadd
                         (Ebinop Oshl
                           (Ebinop Oadd
                             (Ebinop Omul (Econst_int (Int.repr 2) tint)
                               (Ebinop Oshr (Etempvar _t'3 tlong)
                                 (Econst_int (Int.repr 1) tint) tlong) tlong)
                             (Econst_int (Int.repr 1) tint) tlong)
                           (Econst_int (Int.repr 1) tint) tlong)
                         (Econst_int (Int.repr 1) tint) tlong))))
      (LScons (Some 1)
        (Ssequence
          (Ssequence
            (Scall (Some _t'4)
              (Evar _get_Coq_Numbers_BinNums_xO_args (Tfunction
                                                       (Tcons tulong Tnil)
                                                       (tptr (Tstruct _Coq_Numbers_BinNums_xO_args noattr))
                                                       cc_default))
              ((Etempvar _p tlong) :: nil))
            (Ssequence
              (Sset _t'6
                (Efield
                  (Ederef
                    (Etempvar _t'4 (tptr (Tstruct _Coq_Numbers_BinNums_xO_args noattr)))
                    (Tstruct _Coq_Numbers_BinNums_xO_args noattr))
                  _Coq_Numbers_BinNums_xO_arg_0 tulong))
              (Scall (Some _t'5)
                (Evar _uint63_from_positive (Tfunction (Tcons tlong Tnil)
                                              tlong cc_default))
                ((Etempvar _t'6 tulong) :: nil))))
          (Sreturn (Some (Ebinop Oadd
                           (Ebinop Oshl
                             (Ebinop Omul (Econst_int (Int.repr 2) tint)
                               (Ebinop Oshr (Etempvar _t'5 tlong)
                                 (Econst_int (Int.repr 1) tint) tlong) tlong)
                             (Econst_int (Int.repr 1) tint) tlong)
                           (Econst_int (Int.repr 1) tint) tlong))))
        (LScons (Some 2)
          (Sreturn (Some (Ebinop Oadd
                           (Ebinop Oshl (Econst_int (Int.repr 1) tint)
                             (Econst_int (Int.repr 1) tint) tint)
                           (Econst_int (Int.repr 1) tint) tint)))
          LSnil)))))
|}.

Definition f_uint63_from_Z := {|
  fn_return := tlong;
  fn_callconv := cc_default;
  fn_params := ((_z, tlong) :: nil);
  fn_vars := nil;
  fn_temps := ((_t'5, tlong) ::
               (_t'4, (tptr (Tstruct _Coq_Numbers_BinNums_Zneg_args noattr))) ::
               (_t'3, tlong) ::
               (_t'2, (tptr (Tstruct _Coq_Numbers_BinNums_Zpos_args noattr))) ::
               (_t'1, tuint) :: (_t'7, tulong) :: (_t'6, tulong) :: nil);
  fn_body :=
(Ssequence
  (Scall (Some _t'1)
    (Evar _get_Coq_Numbers_BinNums_Z_tag (Tfunction (Tcons tulong Tnil) tuint
                                           cc_default))
    ((Etempvar _z tlong) :: nil))
  (Sswitch (Etempvar _t'1 tuint)
    (LScons (Some 0)
      (Sreturn (Some (Econst_int (Int.repr 0) tint)))
      (LScons (Some 1)
        (Ssequence
          (Ssequence
            (Scall (Some _t'2)
              (Evar _get_Coq_Numbers_BinNums_Zpos_args (Tfunction
                                                         (Tcons tulong Tnil)
                                                         (tptr (Tstruct _Coq_Numbers_BinNums_Zpos_args noattr))
                                                         cc_default))
              ((Etempvar _z tlong) :: nil))
            (Ssequence
              (Sset _t'7
                (Efield
                  (Ederef
                    (Etempvar _t'2 (tptr (Tstruct _Coq_Numbers_BinNums_Zpos_args noattr)))
                    (Tstruct _Coq_Numbers_BinNums_Zpos_args noattr))
                  _Coq_Numbers_BinNums_Zpos_arg_0 tulong))
              (Scall (Some _t'3)
                (Evar _uint63_from_positive (Tfunction (Tcons tlong Tnil)
                                              tlong cc_default))
                ((Etempvar _t'7 tulong) :: nil))))
          (Sreturn (Some (Etempvar _t'3 tlong))))
        (LScons (Some 2)
          (Ssequence
            (Ssequence
              (Scall (Some _t'4)
                (Evar _get_Coq_Numbers_BinNums_Zneg_args (Tfunction
                                                           (Tcons tulong
                                                             Tnil)
                                                           (tptr (Tstruct _Coq_Numbers_BinNums_Zneg_args noattr))
                                                           cc_default))
                ((Etempvar _z tlong) :: nil))
              (Ssequence
                (Sset _t'6
                  (Efield
                    (Ederef
                      (Etempvar _t'4 (tptr (Tstruct _Coq_Numbers_BinNums_Zneg_args noattr)))
                      (Tstruct _Coq_Numbers_BinNums_Zneg_args noattr))
                    _Coq_Numbers_BinNums_Zneg_arg_0 tulong))
                (Scall (Some _t'5)
                  (Evar _uint63_from_positive (Tfunction (Tcons tlong Tnil)
                                                tlong cc_default))
                  ((Etempvar _t'6 tulong) :: nil))))
            (Sreturn (Some (Eunop Oneg (Etempvar _t'5 tlong) tlong))))
          LSnil)))))
|}.

Definition f_uint63_to_Z := {|
  fn_return := tlong;
  fn_callconv := cc_default;
  fn_params := ((_tinfo, (tptr (Tstruct _thread_info noattr))) ::
                (_t, tlong) :: nil);
  fn_vars := nil;
  fn_temps := ((_temp, tlong) :: (_i, tuint) :: (_bit, tbool) ::
               (_t'5, tulong) :: (_t'4, tulong) :: (_t'3, tulong) ::
               (_t'2, tulong) :: (_t'1, tulong) :: nil);
  fn_body :=
(Ssequence
  (Sifthenelse (Ebinop Oeq (Etempvar _t tlong) (Econst_int (Int.repr 1) tint)
                 tint)
    (Ssequence
      (Scall (Some _t'1)
        (Evar _make_Coq_Numbers_BinNums_Z_Z0 (Tfunction Tnil tulong
                                               cc_default)) nil)
      (Sreturn (Some (Etempvar _t'1 tulong))))
    Sskip)
  (Ssequence
    (Sset _temp (Ecast (Econst_int (Int.repr 0) tint) tlong))
    (Ssequence
      (Ssequence
        (Sset _i
          (Ecast
            (Ebinop Osub
              (Ebinop Omul (Esizeof tlong tulong)
                (Econst_int (Int.repr 8) tint) tulong)
              (Econst_int (Int.repr 1) tint) tulong) tuint))
        (Sloop
          (Ssequence
            (Sifthenelse (Ebinop Ogt (Etempvar _i tuint)
                           (Econst_int (Int.repr 0) tint) tint)
              Sskip
              Sbreak)
            (Ssequence
              (Sset _bit
                (Ecast
                  (Ebinop Oshr
                    (Ebinop Oand (Etempvar _t tlong)
                      (Ebinop Oshl (Econst_int (Int.repr 1) tint)
                        (Etempvar _i tuint) tint) tlong) (Etempvar _i tuint)
                    tlong) tbool))
              (Sifthenelse (Etempvar _bit tbool)
                (Sifthenelse (Etempvar _temp tlong)
                  (Ssequence
                    (Scall (Some _t'2)
                      (Evar _alloc_make_Coq_Numbers_BinNums_positive_xI
                      (Tfunction
                        (Tcons (tptr (Tstruct _thread_info noattr))
                          (Tcons tulong Tnil)) tulong cc_default))
                      ((Etempvar _tinfo (tptr (Tstruct _thread_info noattr))) ::
                       (Etempvar _temp tlong) :: nil))
                    (Sset _temp (Etempvar _t'2 tulong)))
                  (Ssequence
                    (Scall (Some _t'3)
                      (Evar _make_Coq_Numbers_BinNums_positive_xH (Tfunction
                                                                    Tnil
                                                                    tulong
                                                                    cc_default))
                      nil)
                    (Sset _temp (Etempvar _t'3 tulong))))
                (Sifthenelse (Etempvar _temp tlong)
                  (Ssequence
                    (Scall (Some _t'4)
                      (Evar _alloc_make_Coq_Numbers_BinNums_positive_xO
                      (Tfunction
                        (Tcons (tptr (Tstruct _thread_info noattr))
                          (Tcons tulong Tnil)) tulong cc_default))
                      ((Etempvar _tinfo (tptr (Tstruct _thread_info noattr))) ::
                       (Etempvar _temp tlong) :: nil))
                    (Sset _temp (Etempvar _t'4 tulong)))
                  Sskip))))
          (Sset _i
            (Ebinop Osub (Etempvar _i tuint) (Econst_int (Int.repr 1) tint)
              tuint))))
      (Ssequence
        (Scall (Some _t'5)
          (Evar _alloc_make_Coq_Numbers_BinNums_Z_Zpos (Tfunction
                                                         (Tcons
                                                           (tptr (Tstruct _thread_info noattr))
                                                           (Tcons tulong
                                                             Tnil)) tulong
                                                         cc_default))
          ((Etempvar _tinfo (tptr (Tstruct _thread_info noattr))) ::
           (Etempvar _temp tlong) :: nil))
        (Sreturn (Some (Etempvar _t'5 tulong)))))))
|}.

Definition f_uint63_add := {|
  fn_return := tlong;
  fn_callconv := cc_default;
  fn_params := ((_x, tlong) :: (_y, tlong) :: nil);
  fn_vars := nil;
  fn_temps := nil;
  fn_body :=
(Sreturn (Some (Ebinop Oadd
                 (Ebinop Oshl
                   (Ebinop Oadd
                     (Ebinop Oshr (Etempvar _x tlong)
                       (Econst_int (Int.repr 1) tint) tlong)
                     (Ebinop Oshr (Etempvar _y tlong)
                       (Econst_int (Int.repr 1) tint) tlong) tlong)
                   (Econst_int (Int.repr 1) tint) tlong)
                 (Econst_int (Int.repr 1) tint) tlong)))
|}.

Definition f_uint63_mul := {|
  fn_return := tlong;
  fn_callconv := cc_default;
  fn_params := ((_x, tlong) :: (_y, tlong) :: nil);
  fn_vars := nil;
  fn_temps := nil;
  fn_body :=
(Sreturn (Some (Ebinop Oadd
                 (Ebinop Oshl
                   (Ebinop Omul
                     (Ebinop Oshr (Etempvar _x tlong)
                       (Econst_int (Int.repr 1) tint) tlong)
                     (Ebinop Oshr (Etempvar _y tlong)
                       (Econst_int (Int.repr 1) tint) tlong) tlong)
                   (Econst_int (Int.repr 1) tint) tlong)
                 (Econst_int (Int.repr 1) tint) tlong)))
|}.

Definition composites : list composite_definition :=
(Composite _thread_info Struct
   (Member_plain _alloc (tptr tulong) :: Member_plain _limit (tptr tulong) ::
    Member_plain _heap (tptr (Tstruct _heap noattr)) ::
    Member_plain _args (tarray tulong 1024) :: nil)
   noattr ::
 Composite _Coq_Numbers_BinNums_xI_args Struct
   (Member_plain _Coq_Numbers_BinNums_xI_arg_0 tulong :: nil)
   noattr ::
 Composite _Coq_Numbers_BinNums_xO_args Struct
   (Member_plain _Coq_Numbers_BinNums_xO_arg_0 tulong :: nil)
   noattr ::
 Composite _Coq_Numbers_BinNums_Zpos_args Struct
   (Member_plain _Coq_Numbers_BinNums_Zpos_arg_0 tulong :: nil)
   noattr ::
 Composite _Coq_Numbers_BinNums_Zneg_args Struct
   (Member_plain _Coq_Numbers_BinNums_Zneg_arg_0 tulong :: nil)
   noattr :: nil).

Definition global_definitions : list (ident * globdef fundef type) :=
((___compcert_va_int32,
   Gfun(External (EF_runtime "__compcert_va_int32"
                   (mksignature (AST.Tlong :: nil) AST.Tint cc_default))
     (Tcons (tptr tvoid) Tnil) tuint cc_default)) ::
 (___compcert_va_int64,
   Gfun(External (EF_runtime "__compcert_va_int64"
                   (mksignature (AST.Tlong :: nil) AST.Tlong cc_default))
     (Tcons (tptr tvoid) Tnil) tulong cc_default)) ::
 (___compcert_va_float64,
   Gfun(External (EF_runtime "__compcert_va_float64"
                   (mksignature (AST.Tlong :: nil) AST.Tfloat cc_default))
     (Tcons (tptr tvoid) Tnil) tdouble cc_default)) ::
 (___compcert_va_composite,
   Gfun(External (EF_runtime "__compcert_va_composite"
                   (mksignature (AST.Tlong :: AST.Tlong :: nil) AST.Tlong
                     cc_default)) (Tcons (tptr tvoid) (Tcons tulong Tnil))
     (tptr tvoid) cc_default)) ::
 (___compcert_i64_dtos,
   Gfun(External (EF_runtime "__compcert_i64_dtos"
                   (mksignature (AST.Tfloat :: nil) AST.Tlong cc_default))
     (Tcons tdouble Tnil) tlong cc_default)) ::
 (___compcert_i64_dtou,
   Gfun(External (EF_runtime "__compcert_i64_dtou"
                   (mksignature (AST.Tfloat :: nil) AST.Tlong cc_default))
     (Tcons tdouble Tnil) tulong cc_default)) ::
 (___compcert_i64_stod,
   Gfun(External (EF_runtime "__compcert_i64_stod"
                   (mksignature (AST.Tlong :: nil) AST.Tfloat cc_default))
     (Tcons tlong Tnil) tdouble cc_default)) ::
 (___compcert_i64_utod,
   Gfun(External (EF_runtime "__compcert_i64_utod"
                   (mksignature (AST.Tlong :: nil) AST.Tfloat cc_default))
     (Tcons tulong Tnil) tdouble cc_default)) ::
 (___compcert_i64_stof,
   Gfun(External (EF_runtime "__compcert_i64_stof"
                   (mksignature (AST.Tlong :: nil) AST.Tsingle cc_default))
     (Tcons tlong Tnil) tfloat cc_default)) ::
 (___compcert_i64_utof,
   Gfun(External (EF_runtime "__compcert_i64_utof"
                   (mksignature (AST.Tlong :: nil) AST.Tsingle cc_default))
     (Tcons tulong Tnil) tfloat cc_default)) ::
 (___compcert_i64_sdiv,
   Gfun(External (EF_runtime "__compcert_i64_sdiv"
                   (mksignature (AST.Tlong :: AST.Tlong :: nil) AST.Tlong
                     cc_default)) (Tcons tlong (Tcons tlong Tnil)) tlong
     cc_default)) ::
 (___compcert_i64_udiv,
   Gfun(External (EF_runtime "__compcert_i64_udiv"
                   (mksignature (AST.Tlong :: AST.Tlong :: nil) AST.Tlong
                     cc_default)) (Tcons tulong (Tcons tulong Tnil)) tulong
     cc_default)) ::
 (___compcert_i64_smod,
   Gfun(External (EF_runtime "__compcert_i64_smod"
                   (mksignature (AST.Tlong :: AST.Tlong :: nil) AST.Tlong
                     cc_default)) (Tcons tlong (Tcons tlong Tnil)) tlong
     cc_default)) ::
 (___compcert_i64_umod,
   Gfun(External (EF_runtime "__compcert_i64_umod"
                   (mksignature (AST.Tlong :: AST.Tlong :: nil) AST.Tlong
                     cc_default)) (Tcons tulong (Tcons tulong Tnil)) tulong
     cc_default)) ::
 (___compcert_i64_shl,
   Gfun(External (EF_runtime "__compcert_i64_shl"
                   (mksignature (AST.Tlong :: AST.Tint :: nil) AST.Tlong
                     cc_default)) (Tcons tlong (Tcons tint Tnil)) tlong
     cc_default)) ::
 (___compcert_i64_shr,
   Gfun(External (EF_runtime "__compcert_i64_shr"
                   (mksignature (AST.Tlong :: AST.Tint :: nil) AST.Tlong
                     cc_default)) (Tcons tulong (Tcons tint Tnil)) tulong
     cc_default)) ::
 (___compcert_i64_sar,
   Gfun(External (EF_runtime "__compcert_i64_sar"
                   (mksignature (AST.Tlong :: AST.Tint :: nil) AST.Tlong
                     cc_default)) (Tcons tlong (Tcons tint Tnil)) tlong
     cc_default)) ::
 (___compcert_i64_smulh,
   Gfun(External (EF_runtime "__compcert_i64_smulh"
                   (mksignature (AST.Tlong :: AST.Tlong :: nil) AST.Tlong
                     cc_default)) (Tcons tlong (Tcons tlong Tnil)) tlong
     cc_default)) ::
 (___compcert_i64_umulh,
   Gfun(External (EF_runtime "__compcert_i64_umulh"
                   (mksignature (AST.Tlong :: AST.Tlong :: nil) AST.Tlong
                     cc_default)) (Tcons tulong (Tcons tulong Tnil)) tulong
     cc_default)) ::
 (___builtin_ais_annot,
   Gfun(External (EF_builtin "__builtin_ais_annot"
                   (mksignature (AST.Tlong :: nil) AST.Tvoid
                     {|cc_vararg:=(Some 1); cc_unproto:=false; cc_structret:=false|}))
     (Tcons (tptr tschar) Tnil) tvoid
     {|cc_vararg:=(Some 1); cc_unproto:=false; cc_structret:=false|})) ::
 (___builtin_bswap64,
   Gfun(External (EF_builtin "__builtin_bswap64"
                   (mksignature (AST.Tlong :: nil) AST.Tlong cc_default))
     (Tcons tulong Tnil) tulong cc_default)) ::
 (___builtin_bswap,
   Gfun(External (EF_builtin "__builtin_bswap"
                   (mksignature (AST.Tint :: nil) AST.Tint cc_default))
     (Tcons tuint Tnil) tuint cc_default)) ::
 (___builtin_bswap32,
   Gfun(External (EF_builtin "__builtin_bswap32"
                   (mksignature (AST.Tint :: nil) AST.Tint cc_default))
     (Tcons tuint Tnil) tuint cc_default)) ::
 (___builtin_bswap16,
   Gfun(External (EF_builtin "__builtin_bswap16"
                   (mksignature (AST.Tint :: nil) AST.Tint16unsigned
                     cc_default)) (Tcons tushort Tnil) tushort cc_default)) ::
 (___builtin_clz,
   Gfun(External (EF_builtin "__builtin_clz"
                   (mksignature (AST.Tint :: nil) AST.Tint cc_default))
     (Tcons tuint Tnil) tint cc_default)) ::
 (___builtin_clzl,
   Gfun(External (EF_builtin "__builtin_clzl"
                   (mksignature (AST.Tlong :: nil) AST.Tint cc_default))
     (Tcons tulong Tnil) tint cc_default)) ::
 (___builtin_clzll,
   Gfun(External (EF_builtin "__builtin_clzll"
                   (mksignature (AST.Tlong :: nil) AST.Tint cc_default))
     (Tcons tulong Tnil) tint cc_default)) ::
 (___builtin_ctz,
   Gfun(External (EF_builtin "__builtin_ctz"
                   (mksignature (AST.Tint :: nil) AST.Tint cc_default))
     (Tcons tuint Tnil) tint cc_default)) ::
 (___builtin_ctzl,
   Gfun(External (EF_builtin "__builtin_ctzl"
                   (mksignature (AST.Tlong :: nil) AST.Tint cc_default))
     (Tcons tulong Tnil) tint cc_default)) ::
 (___builtin_ctzll,
   Gfun(External (EF_builtin "__builtin_ctzll"
                   (mksignature (AST.Tlong :: nil) AST.Tint cc_default))
     (Tcons tulong Tnil) tint cc_default)) ::
 (___builtin_fabs,
   Gfun(External (EF_builtin "__builtin_fabs"
                   (mksignature (AST.Tfloat :: nil) AST.Tfloat cc_default))
     (Tcons tdouble Tnil) tdouble cc_default)) ::
 (___builtin_fabsf,
   Gfun(External (EF_builtin "__builtin_fabsf"
                   (mksignature (AST.Tsingle :: nil) AST.Tsingle cc_default))
     (Tcons tfloat Tnil) tfloat cc_default)) ::
 (___builtin_fsqrt,
   Gfun(External (EF_builtin "__builtin_fsqrt"
                   (mksignature (AST.Tfloat :: nil) AST.Tfloat cc_default))
     (Tcons tdouble Tnil) tdouble cc_default)) ::
 (___builtin_sqrt,
   Gfun(External (EF_builtin "__builtin_sqrt"
                   (mksignature (AST.Tfloat :: nil) AST.Tfloat cc_default))
     (Tcons tdouble Tnil) tdouble cc_default)) ::
 (___builtin_memcpy_aligned,
   Gfun(External (EF_builtin "__builtin_memcpy_aligned"
                   (mksignature
                     (AST.Tlong :: AST.Tlong :: AST.Tlong :: AST.Tlong ::
                      nil) AST.Tvoid cc_default))
     (Tcons (tptr tvoid)
       (Tcons (tptr tvoid) (Tcons tulong (Tcons tulong Tnil)))) tvoid
     cc_default)) ::
 (___builtin_sel,
   Gfun(External (EF_builtin "__builtin_sel"
                   (mksignature (AST.Tint :: nil) AST.Tvoid
                     {|cc_vararg:=(Some 1); cc_unproto:=false; cc_structret:=false|}))
     (Tcons tbool Tnil) tvoid
     {|cc_vararg:=(Some 1); cc_unproto:=false; cc_structret:=false|})) ::
 (___builtin_annot,
   Gfun(External (EF_builtin "__builtin_annot"
                   (mksignature (AST.Tlong :: nil) AST.Tvoid
                     {|cc_vararg:=(Some 1); cc_unproto:=false; cc_structret:=false|}))
     (Tcons (tptr tschar) Tnil) tvoid
     {|cc_vararg:=(Some 1); cc_unproto:=false; cc_structret:=false|})) ::
 (___builtin_annot_intval,
   Gfun(External (EF_builtin "__builtin_annot_intval"
                   (mksignature (AST.Tlong :: AST.Tint :: nil) AST.Tint
                     cc_default)) (Tcons (tptr tschar) (Tcons tint Tnil))
     tint cc_default)) ::
 (___builtin_membar,
   Gfun(External (EF_builtin "__builtin_membar"
                   (mksignature nil AST.Tvoid cc_default)) Tnil tvoid
     cc_default)) ::
 (___builtin_va_start,
   Gfun(External (EF_builtin "__builtin_va_start"
                   (mksignature (AST.Tlong :: nil) AST.Tvoid cc_default))
     (Tcons (tptr tvoid) Tnil) tvoid cc_default)) ::
 (___builtin_va_arg,
   Gfun(External (EF_builtin "__builtin_va_arg"
                   (mksignature (AST.Tlong :: AST.Tint :: nil) AST.Tvoid
                     cc_default)) (Tcons (tptr tvoid) (Tcons tuint Tnil))
     tvoid cc_default)) ::
 (___builtin_va_copy,
   Gfun(External (EF_builtin "__builtin_va_copy"
                   (mksignature (AST.Tlong :: AST.Tlong :: nil) AST.Tvoid
                     cc_default))
     (Tcons (tptr tvoid) (Tcons (tptr tvoid) Tnil)) tvoid cc_default)) ::
 (___builtin_va_end,
   Gfun(External (EF_builtin "__builtin_va_end"
                   (mksignature (AST.Tlong :: nil) AST.Tvoid cc_default))
     (Tcons (tptr tvoid) Tnil) tvoid cc_default)) ::
 (___builtin_unreachable,
   Gfun(External (EF_builtin "__builtin_unreachable"
                   (mksignature nil AST.Tvoid cc_default)) Tnil tvoid
     cc_default)) ::
 (___builtin_expect,
   Gfun(External (EF_builtin "__builtin_expect"
                   (mksignature (AST.Tlong :: AST.Tlong :: nil) AST.Tlong
                     cc_default)) (Tcons tlong (Tcons tlong Tnil)) tlong
     cc_default)) ::
 (___builtin_fmax,
   Gfun(External (EF_builtin "__builtin_fmax"
                   (mksignature (AST.Tfloat :: AST.Tfloat :: nil) AST.Tfloat
                     cc_default)) (Tcons tdouble (Tcons tdouble Tnil))
     tdouble cc_default)) ::
 (___builtin_fmin,
   Gfun(External (EF_builtin "__builtin_fmin"
                   (mksignature (AST.Tfloat :: AST.Tfloat :: nil) AST.Tfloat
                     cc_default)) (Tcons tdouble (Tcons tdouble Tnil))
     tdouble cc_default)) ::
 (___builtin_fmadd,
   Gfun(External (EF_builtin "__builtin_fmadd"
                   (mksignature
                     (AST.Tfloat :: AST.Tfloat :: AST.Tfloat :: nil)
                     AST.Tfloat cc_default))
     (Tcons tdouble (Tcons tdouble (Tcons tdouble Tnil))) tdouble
     cc_default)) ::
 (___builtin_fmsub,
   Gfun(External (EF_builtin "__builtin_fmsub"
                   (mksignature
                     (AST.Tfloat :: AST.Tfloat :: AST.Tfloat :: nil)
                     AST.Tfloat cc_default))
     (Tcons tdouble (Tcons tdouble (Tcons tdouble Tnil))) tdouble
     cc_default)) ::
 (___builtin_fnmadd,
   Gfun(External (EF_builtin "__builtin_fnmadd"
                   (mksignature
                     (AST.Tfloat :: AST.Tfloat :: AST.Tfloat :: nil)
                     AST.Tfloat cc_default))
     (Tcons tdouble (Tcons tdouble (Tcons tdouble Tnil))) tdouble
     cc_default)) ::
 (___builtin_fnmsub,
   Gfun(External (EF_builtin "__builtin_fnmsub"
                   (mksignature
                     (AST.Tfloat :: AST.Tfloat :: AST.Tfloat :: nil)
                     AST.Tfloat cc_default))
     (Tcons tdouble (Tcons tdouble (Tcons tdouble Tnil))) tdouble
     cc_default)) ::
 (___builtin_read16_reversed,
   Gfun(External (EF_builtin "__builtin_read16_reversed"
                   (mksignature (AST.Tlong :: nil) AST.Tint16unsigned
                     cc_default)) (Tcons (tptr tushort) Tnil) tushort
     cc_default)) ::
 (___builtin_read32_reversed,
   Gfun(External (EF_builtin "__builtin_read32_reversed"
                   (mksignature (AST.Tlong :: nil) AST.Tint cc_default))
     (Tcons (tptr tuint) Tnil) tuint cc_default)) ::
 (___builtin_write16_reversed,
   Gfun(External (EF_builtin "__builtin_write16_reversed"
                   (mksignature (AST.Tlong :: AST.Tint :: nil) AST.Tvoid
                     cc_default)) (Tcons (tptr tushort) (Tcons tushort Tnil))
     tvoid cc_default)) ::
 (___builtin_write32_reversed,
   Gfun(External (EF_builtin "__builtin_write32_reversed"
                   (mksignature (AST.Tlong :: AST.Tint :: nil) AST.Tvoid
                     cc_default)) (Tcons (tptr tuint) (Tcons tuint Tnil))
     tvoid cc_default)) ::
 (___builtin_debug,
   Gfun(External (EF_external "__builtin_debug"
                   (mksignature (AST.Tint :: nil) AST.Tvoid
                     {|cc_vararg:=(Some 1); cc_unproto:=false; cc_structret:=false|}))
     (Tcons tint Tnil) tvoid
     {|cc_vararg:=(Some 1); cc_unproto:=false; cc_structret:=false|})) ::
 (_alloc_make_Coq_Numbers_BinNums_positive_xI,
   Gfun(External (EF_external "alloc_make_Coq_Numbers_BinNums_positive_xI"
                   (mksignature (AST.Tlong :: AST.Tlong :: nil) AST.Tlong
                     cc_default))
     (Tcons (tptr (Tstruct _thread_info noattr)) (Tcons tulong Tnil)) tulong
     cc_default)) ::
 (_alloc_make_Coq_Numbers_BinNums_positive_xO,
   Gfun(External (EF_external "alloc_make_Coq_Numbers_BinNums_positive_xO"
                   (mksignature (AST.Tlong :: AST.Tlong :: nil) AST.Tlong
                     cc_default))
     (Tcons (tptr (Tstruct _thread_info noattr)) (Tcons tulong Tnil)) tulong
     cc_default)) ::
 (_make_Coq_Numbers_BinNums_positive_xH,
   Gfun(External (EF_external "make_Coq_Numbers_BinNums_positive_xH"
                   (mksignature nil AST.Tlong cc_default)) Tnil tulong
     cc_default)) ::
 (_make_Coq_Numbers_BinNums_Z_Z0,
   Gfun(External (EF_external "make_Coq_Numbers_BinNums_Z_Z0"
                   (mksignature nil AST.Tlong cc_default)) Tnil tulong
     cc_default)) ::
 (_alloc_make_Coq_Numbers_BinNums_Z_Zpos,
   Gfun(External (EF_external "alloc_make_Coq_Numbers_BinNums_Z_Zpos"
                   (mksignature (AST.Tlong :: AST.Tlong :: nil) AST.Tlong
                     cc_default))
     (Tcons (tptr (Tstruct _thread_info noattr)) (Tcons tulong Tnil)) tulong
     cc_default)) ::
 (_get_Coq_Numbers_BinNums_positive_tag,
   Gfun(External (EF_external "get_Coq_Numbers_BinNums_positive_tag"
                   (mksignature (AST.Tlong :: nil) AST.Tint cc_default))
     (Tcons tulong Tnil) tuint cc_default)) ::
 (_get_Coq_Numbers_BinNums_Z_tag,
   Gfun(External (EF_external "get_Coq_Numbers_BinNums_Z_tag"
                   (mksignature (AST.Tlong :: nil) AST.Tint cc_default))
     (Tcons tulong Tnil) tuint cc_default)) ::
 (_get_Coq_Numbers_BinNums_xI_args,
   Gfun(External (EF_external "get_Coq_Numbers_BinNums_xI_args"
                   (mksignature (AST.Tlong :: nil) AST.Tlong cc_default))
     (Tcons tulong Tnil) (tptr (Tstruct _Coq_Numbers_BinNums_xI_args noattr))
     cc_default)) ::
 (_get_Coq_Numbers_BinNums_xO_args,
   Gfun(External (EF_external "get_Coq_Numbers_BinNums_xO_args"
                   (mksignature (AST.Tlong :: nil) AST.Tlong cc_default))
     (Tcons tulong Tnil) (tptr (Tstruct _Coq_Numbers_BinNums_xO_args noattr))
     cc_default)) ::
 (_get_Coq_Numbers_BinNums_Zpos_args,
   Gfun(External (EF_external "get_Coq_Numbers_BinNums_Zpos_args"
                   (mksignature (AST.Tlong :: nil) AST.Tlong cc_default))
     (Tcons tulong Tnil)
     (tptr (Tstruct _Coq_Numbers_BinNums_Zpos_args noattr)) cc_default)) ::
 (_get_Coq_Numbers_BinNums_Zneg_args,
   Gfun(External (EF_external "get_Coq_Numbers_BinNums_Zneg_args"
                   (mksignature (AST.Tlong :: nil) AST.Tlong cc_default))
     (Tcons tulong Tnil)
     (tptr (Tstruct _Coq_Numbers_BinNums_Zneg_args noattr)) cc_default)) ::
 (_uint63_from_positive, Gfun(Internal f_uint63_from_positive)) ::
 (_uint63_from_Z, Gfun(Internal f_uint63_from_Z)) ::
 (_uint63_to_Z, Gfun(Internal f_uint63_to_Z)) ::
 (_uint63_add, Gfun(Internal f_uint63_add)) ::
 (_uint63_mul, Gfun(Internal f_uint63_mul)) :: nil).

Definition public_idents : list ident :=
(_uint63_mul :: _uint63_add :: _uint63_to_Z :: _uint63_from_Z ::
 _uint63_from_positive :: _get_Coq_Numbers_BinNums_Zneg_args ::
 _get_Coq_Numbers_BinNums_Zpos_args :: _get_Coq_Numbers_BinNums_xO_args ::
 _get_Coq_Numbers_BinNums_xI_args :: _get_Coq_Numbers_BinNums_Z_tag ::
 _get_Coq_Numbers_BinNums_positive_tag ::
 _alloc_make_Coq_Numbers_BinNums_Z_Zpos :: _make_Coq_Numbers_BinNums_Z_Z0 ::
 _make_Coq_Numbers_BinNums_positive_xH ::
 _alloc_make_Coq_Numbers_BinNums_positive_xO ::
 _alloc_make_Coq_Numbers_BinNums_positive_xI :: ___builtin_debug ::
 ___builtin_write32_reversed :: ___builtin_write16_reversed ::
 ___builtin_read32_reversed :: ___builtin_read16_reversed ::
 ___builtin_fnmsub :: ___builtin_fnmadd :: ___builtin_fmsub ::
 ___builtin_fmadd :: ___builtin_fmin :: ___builtin_fmax ::
 ___builtin_expect :: ___builtin_unreachable :: ___builtin_va_end ::
 ___builtin_va_copy :: ___builtin_va_arg :: ___builtin_va_start ::
 ___builtin_membar :: ___builtin_annot_intval :: ___builtin_annot ::
 ___builtin_sel :: ___builtin_memcpy_aligned :: ___builtin_sqrt ::
 ___builtin_fsqrt :: ___builtin_fabsf :: ___builtin_fabs ::
 ___builtin_ctzll :: ___builtin_ctzl :: ___builtin_ctz :: ___builtin_clzll ::
 ___builtin_clzl :: ___builtin_clz :: ___builtin_bswap16 ::
 ___builtin_bswap32 :: ___builtin_bswap :: ___builtin_bswap64 ::
 ___builtin_ais_annot :: ___compcert_i64_umulh :: ___compcert_i64_smulh ::
 ___compcert_i64_sar :: ___compcert_i64_shr :: ___compcert_i64_shl ::
 ___compcert_i64_umod :: ___compcert_i64_smod :: ___compcert_i64_udiv ::
 ___compcert_i64_sdiv :: ___compcert_i64_utof :: ___compcert_i64_stof ::
 ___compcert_i64_utod :: ___compcert_i64_stod :: ___compcert_i64_dtou ::
 ___compcert_i64_dtos :: ___compcert_va_composite ::
 ___compcert_va_float64 :: ___compcert_va_int64 :: ___compcert_va_int32 ::
 nil).

Definition prog : Clight.program :=
  mkprogram composites global_definitions public_idents _main Logic.I.


From iris.proofmode Require Import proofmode.
From iris.algebra Require Import vector list.
From lrust.typing Require Export type.
From lrust.typing Require Import own programs cont.
From iris.prelude Require Import options.

Section fn.
  Context `{!typeGS Σ} {A : Type} {n : nat}.

  Record fn_params := FP { fp_E : lft → elctx; fp_tys : vec type n; fp_ty : type }.

  Definition FP_wf E (tys : vec type n) `{!ListTyWf tys} ty `{!TyWf ty} :=
    FP (λ ϝ, E ϝ ++ tyl_wf_E tys ++ tyl_outlives_E tys ϝ ++
                    ty_wf_E ty ++ ty_outlives_E ty ϝ)
       tys ty.

  (* The other alternative for defining the fn type would be to state
     that the value applied to its parameters is a typed body whose type
     is the return type.
     That would be slightly simpler, but, unfortunately, we are no longer
     able to prove that this is contractive. *)
  Program Definition fn (fp : A → fn_params) : type :=
    {| st_own tid vl := tc_opaque (∃ fb kb xb e H,
         ⌜vl = [@RecV fb (kb::xb) e H]⌝ ∗ ⌜length xb = n⌝ ∗
         ▷ ∀ (x : A) (ϝ : lft) (k : val) (xl : vec val (length xb)),
            □ typed_body ((fp x).(fp_E) ϝ) [ϝ ⊑ₗ []]
                         [k◁cont([ϝ ⊑ₗ []], λ v : vec _ 1, [(v!!!0%fin:val) ◁ box (fp x).(fp_ty)])]
                         (zip_with (TCtx_hasty ∘ of_val) xl
                                   (box <$> (vec_to_list (fp x).(fp_tys))))
                         (subst_v (fb::kb::xb) (RecV fb (kb::xb) e:::k:::xl) e))%I |}.
  Next Obligation.
    iIntros (fp tid vl) "H". iDestruct "H" as (fb kb xb e ?) "[% _]". by subst.
  Qed.
  Next Obligation.
    unfold tc_opaque. apply _.
  Qed.

  (* FIXME : This definition is less restrictive than the one used in
     Rust. In Rust, the type of parameters are taken into account for
     well-formedness, and all the liftime constrains relating a
     generalized liftime are ignored. For simplicity, we ignore all of
     them, but this is not very faithful. *)
  Global Instance fn_wf fp : TyWf (fn fp) :=
    { ty_lfts := []; ty_wf_E := [] }.

  Global Instance fn_send fp : Send (fn fp).
  Proof. iIntros (tid1 tid2 vl). done. Qed.

  Definition fn_params_rel (ty_rel : relation type) : relation fn_params :=
    λ fp1 fp2,
      Forall2 ty_rel fp2.(fp_tys) fp1.(fp_tys) ∧ ty_rel fp1.(fp_ty) fp2.(fp_ty) ∧
      pointwise_relation lft eq fp1.(fp_E) fp2.(fp_E).

  Global Instance fp_tys_proper R :
    Proper (flip (fn_params_rel R) ==> (Forall2 R : relation (vec _ _))) fp_tys.
  Proof. intros ?? HR. apply HR. Qed.
  Global Instance fp_tys_proper_flip R :
    Proper (fn_params_rel R ==> flip (Forall2 R : relation (vec _ _))) fp_tys.
  Proof. intros ?? HR. apply HR. Qed.

  Global Instance fp_ty_proper R :
    Proper (fn_params_rel R ==> R) fp_ty.
  Proof. intros ?? HR. apply HR. Qed.

  Global Instance fp_E_proper R :
    Proper (fn_params_rel R ==> eq ==> eq) fp_E.
  Proof. intros ?? HR ??->. apply HR. Qed.

  Global Instance FP_proper R :
    Proper (pointwise_relation lft eq ==>
            flip (Forall2 R : relation (vec _ _)) ==> R ==>
            fn_params_rel R) FP.
  Proof. by split; [|split]. Qed.

  Global Instance fn_type_contractive n' :
    Proper (pointwise_relation A (fn_params_rel (type_dist2_later n')) ==>
            type_dist2 n') fn.
  Proof.
    intros fp1 fp2 Hfp. apply ty_of_st_type_ne. destruct n'; first done.
    constructor; unfold ty_own; simpl.
    (* TODO: 'f_equiv' is slow here because reflexivity is slow. *)
    (* The clean way to do this would be to have a metric on type contexts. Oh well. *)
    intros tid vl. unfold typed_body.
    do 12 f_equiv. f_contractive.
    do 18 ((eapply fp_E_proper; try reflexivity) || exact: Hfp || f_equiv).
    - rewrite !cctx_interp_singleton /=. do 5 f_equiv.
      rewrite !tctx_interp_singleton /tctx_elt_interp /=.
      do 5 f_equiv. apply type_dist2_dist. apply Hfp.
    - rewrite /tctx_interp !big_sepL_zip_with /=. do 4 f_equiv.
      cut (∀ n tid p i, Proper (dist n ==> dist n)
        (λ (l : list type),
            match l !! i with
            | Some ty => tctx_elt_interp tid (p ◁ ty) | None => emp
            end)%I).
      { intros Hprop. apply Hprop, list_fmap_ne; last first.
        - symmetry. eapply Forall2_impl; first apply Hfp. intros.
          apply dist_later_dist, type_dist2_dist_later. done.
        - apply _. }
      clear. intros n tid p i x y. rewrite list_dist_lookup=>/(_ i).
      case _ : (x !! i)=>[tyx|]; case  _ : (y !! i)=>[tyy|];
        inversion_clear 1; [solve_proper|done].
  Qed.

  Global Instance fn_ne n' :
    Proper (pointwise_relation A (fn_params_rel (dist n')) ==> dist n') fn.
  Proof.
    intros ?? Hfp. apply dist_later_dist, type_dist2_dist_later.
    apply fn_type_contractive=>u. split; last split.
    - eapply Forall2_impl; first apply Hfp. intros. simpl.
      apply type_dist_dist2. done.
    - apply type_dist_dist2. apply Hfp.
    - apply Hfp.
  Qed.
End fn.

Global Arguments fn_params {_ _} _.

(* We use recursive notation for binders as well, to allow patterns
   like '(a, b) to be used. In practice, only one binder is ever used,
   but using recursive binders is the only way to make Coq accept
   patterns. *)
(* FIXME : because of a bug in Coq, such patterns only work for
   printing. Once on 8.6pl1, this should work.  *)
Notation "'fn(∀' x .. x' ',' E ';' T1 ',' .. ',' TN ')' '→' R" :=
  (fn (λ x, (.. (λ x',
      FP_wf E%EL (Vector.cons T1%T .. (Vector.cons TN%T Vector.nil) ..) R%T)..)))
  (at level 99, R at level 200, x binder, x' binder,
   format "'fn(∀'  x .. x' ','  E ';'  T1 ','  .. ','  TN ')'  '→'  R") : lrust_type_scope.
Notation "'fn(∀' x .. x' ',' E ')' '→' R" :=
  (fn (λ x, (.. (λ x', FP_wf E%EL Vector.nil R%T)..)))
  (at level 99, R at level 200, x binder, x' binder,
   format "'fn(∀'  x .. x' ','  E ')'  '→'  R") : lrust_type_scope.
Notation "'fn(' E ';' T1 ',' .. ',' TN ')' '→' R" :=
  (fn (λ _:(), FP_wf E%EL (Vector.cons T1%T .. (Vector.cons TN%T Vector.nil) ..) R%T))
  (at level 99, R at level 200,
   format "'fn(' E ';'  T1 ','  .. ','  TN ')'  '→'  R") : lrust_type_scope.
Notation "'fn(' E ')' '→' R" :=
  (fn (λ _:(), FP_wf E%EL Vector.nil R%T))
  (at level 99, R at level 200,
   format "'fn(' E ')'  '→'  R") : lrust_type_scope.

Global Instance elctx_empty : Empty (lft → elctx) := λ ϝ, [].

Section typing.
  Context `{!typeGS Σ}.

  Lemma fn_subtype {A n} E0 L0 (fp fp' : A → fn_params n) :
    (∀ x ϝ, let EE := E0 ++ (fp' x).(fp_E) ϝ in
            elctx_sat EE L0 ((fp x).(fp_E) ϝ) ∧
            Forall2 (subtype EE L0) (fp' x).(fp_tys) (fp x).(fp_tys) ∧
            subtype EE L0 (fp x).(fp_ty) (fp' x).(fp_ty)) →
    subtype E0 L0 (fn fp) (fn fp').
  Proof.
    intros Hcons. apply subtype_simple_type=>//= qmax qL. iIntros "HL0".
    (* We massage things so that we can throw away HL0 before going under the box. *)
    iAssert (∀ x ϝ, let EE := E0 ++ (fp' x).(fp_E) ϝ in □ (elctx_interp EE -∗
                 elctx_interp ((fp x).(fp_E) ϝ) ∗
                 ([∗ list] tys ∈ (zip (fp' x).(fp_tys) (fp x).(fp_tys)), type_incl (tys.1) (tys.2)) ∗
                 type_incl (fp x).(fp_ty) (fp' x).(fp_ty)))%I as "#Hcons".
    { iIntros (x ϝ). destruct (Hcons x ϝ) as (HE &Htys &Hty). clear Hcons.
      iDestruct (HE with "HL0") as "#HE".
      iDestruct (subtype_Forall2_llctx_noend with "HL0") as "#Htys"; first done.
      iDestruct (Hty with "HL0") as "#Hty".
      iClear "∗". iIntros "!> #HEE".
      iSplit; last iSplit.
      - by iApply "HE".
      - by iApply "Htys".
      - by iApply "Hty". }
    iClear "∗". clear Hcons. iIntros "!> #HE0 * Hf".
    iDestruct "Hf" as (fb kb xb e ?) "[% [% #Hf]]". subst.
    iExists fb, kb, xb, e, _. iSplit; first done. iSplit; first done. iNext.
    rewrite /typed_body. iIntros (x ϝ k xl) "!> * #LFT #HE' Htl HL HC HT".
    iDestruct ("Hcons" with "[$]") as "#(HE & Htys & Hty)".
    iApply ("Hf" with "LFT HE Htl HL [HC] [HT]").
    - unfold cctx_interp. iIntros (elt) "Helt".
      iDestruct "Helt" as %->%elem_of_list_singleton. iIntros (ret) "Htl HL HT".
      unfold cctx_elt_interp.
      iApply ("HC" $! (_ ◁cont(_, _)) with "[%] Htl HL [> -]").
      { by apply elem_of_list_singleton. }
      rewrite /tctx_interp !big_sepL_singleton /=.
      iDestruct "HT" as (v) "[HP Hown]". iExists v. iFrame "HP".
      iDestruct (box_type_incl with "[$Hty]") as "(_ & #Hincl & _)".
      by iApply "Hincl".
    - iClear "Hf". rewrite /tctx_interp
         -{2}(fst_zip (fp x).(fp_tys) (fp' x).(fp_tys)) ?vec_to_list_length //
         -{2}(snd_zip (fp x).(fp_tys) (fp' x).(fp_tys)) ?vec_to_list_length //
         !zip_with_fmap_r !(zip_with_zip (λ _ _, (_ ∘ _) _ _)) !big_sepL_fmap.
      iApply (big_sepL_impl with "HT"). iIntros "!>".
      iIntros (i [p [ty1' ty2']]) "#Hzip H /=".
      iDestruct "H" as (v) "[? Hown]". iExists v. iFrame.
      rewrite !lookup_zip_with.
      iDestruct "Hzip" as %(? & ? & ([? ?] & (? & Hty'1 &
        (? & Hty'2 & [=->->])%bind_Some)%bind_Some & [=->->->])%bind_Some)%bind_Some.
      iDestruct (big_sepL_lookup with "Htys") as "#Hty'".
      { rewrite lookup_zip_with /=. erewrite Hty'2. simpl. by erewrite Hty'1. }
      iDestruct (box_type_incl with "[$Hty']") as "(_ & #Hincl & _)".
      by iApply "Hincl".
  Qed.

  (* This proper and the next can probably not be inferred, but oh well. *)
  Global Instance fn_subtype' {A n} E0 L0 :
    Proper (pointwise_relation A (fn_params_rel (n:=n) (subtype E0 L0)) ==>
            subtype E0 L0) fn.
  Proof.
    intros fp1 fp2 Hfp. apply fn_subtype=>x ϝ. destruct (Hfp x) as (Htys & Hty & HE).
    split; last split.
    - rewrite (HE ϝ). solve_typing.
    - eapply Forall2_impl; first eapply Htys. intros ??.
      eapply subtype_weaken; last done. by apply submseteq_inserts_r.
    - eapply subtype_weaken, Hty; last done. by apply submseteq_inserts_r.
  Qed.

  Global Instance fn_eqtype' {A n} E0 L0 :
    Proper (pointwise_relation A (fn_params_rel (n:=n) (eqtype E0 L0)) ==>
            eqtype E0 L0) fn.
  Proof.
    intros fp1 fp2 Hfp. split; eapply fn_subtype=>x ϝ; destruct (Hfp x) as (Htys & Hty & HE); (split; last split).
    - rewrite (HE ϝ). solve_typing.
    - eapply Forall2_impl; first eapply Htys. intros t1 t2 Ht.
      eapply subtype_weaken; last apply Ht; last done. by apply submseteq_inserts_r.
    - eapply subtype_weaken; last apply Hty; last done. by apply submseteq_inserts_r.
    - rewrite (HE ϝ). solve_typing.
    - symmetry in Htys. eapply Forall2_impl; first eapply Htys. intros t1 t2 Ht.
      eapply subtype_weaken; last apply Ht; last done. by apply submseteq_inserts_r.
    - eapply subtype_weaken; last apply Hty; last done. by apply submseteq_inserts_r.
  Qed.

  Lemma fn_subtype_specialize {A B n} (σ : A → B) E0 L0 fp :
    subtype E0 L0 (fn (n:=n) fp) (fn (fp ∘ σ)).
  Proof.
    apply subtype_simple_type=>//= qmax qL.
    iIntros "_ !> _ * Hf". iDestruct "Hf" as (fb kb xb e ?) "[% [% #Hf]]". subst.
    iExists fb, kb, xb, e, _. iSplit; first done. iSplit; first done.
    rewrite /typed_body. iNext. iIntros "*". iApply "Hf".
  Qed.

  (* In principle, proving this hard-coded to an empty L would be sufficient --
     but then we would have to require elctx_sat as an Iris assumption. *)
  Lemma type_call_iris' E L (κs : list lft) {A} x (ps : list path) qκs qmax qL tid
        p (k : expr) (fp : A → fn_params (length ps)) :
    (∀ ϝ, elctx_sat (((λ κ, ϝ ⊑ₑ κ) <$> κs) ++ E) L ((fp x).(fp_E) ϝ)) →
    AsVal k →
    lft_ctx -∗ elctx_interp E -∗ na_own tid ⊤ -∗ llctx_interp_noend qmax L qL -∗
    qκs.[lft_intersect_list κs] -∗
    tctx_elt_interp tid (p ◁ fn fp) -∗
    ([∗ list] y ∈ zip_with TCtx_hasty ps (box <$> vec_to_list (fp x).(fp_tys)),
                   tctx_elt_interp tid y) -∗
    (∀ ret, na_own tid top -∗ llctx_interp_noend qmax L qL -∗ qκs.[lft_intersect_list κs] -∗
             (box (fp x).(fp_ty)).(ty_own) tid [ret] -∗
             WP k [of_val ret] {{ _, cont_postcondition }}) -∗
    WP (call: p ps → k) {{ _, cont_postcondition }}.
  Proof.
    iIntros (HE [k' <-]) "#LFT #HE Htl HL Hκs Hf Hargs Hk".
    wp_apply (wp_hasty with "Hf"). iIntros (v) "% Hf".
    iApply (wp_app_vec _ _ (_::_) ((λ v, ⌜v = (λ: ["_r"], k' ["_r"])%V⌝):::
               vmap (λ ty (v : val), tctx_elt_interp tid (v ◁ box ty)) (fp x).(fp_tys))%I
            with "[Hargs]").
    - rewrite /=. iSplitR "Hargs".
      { simpl. iApply wp_value. by unlock. }
      remember (fp_tys (fp x)) as tys. clear dependent k' p HE fp x.
      iInduction ps as [|p ps] "IH" forall (tys); first by simpl.
      simpl in tys. inv_vec tys=>ty tys. simpl.
      iDestruct "Hargs" as "[HT Hargs]". iSplitL "HT".
      + iApply (wp_hasty with "HT"). iIntros (?). rewrite tctx_hasty_val. iIntros "? $".
      + iApply "IH". done.
    - simpl. change (@length expr ps) with (length ps).
      iIntros (vl'). inv_vec vl'=>kv vl; csimpl.
      iIntros "[-> Hvl]". iDestruct "Hf" as (fb kb xb e ?) "[EQ [EQl #Hf]]".
      iDestruct "EQ" as %[=->]. iDestruct "EQl" as %EQl.
      revert vl fp HE. rewrite /= -EQl=>vl fp HE. wp_rec.
      iMod (lft_create with "LFT") as (ϝ_inner) "[Htk #Hend]"; first done.
      set (ϝ := ϝ_inner ⊓ lft_intersect_list κs).
      iSpecialize ("Hf" $! x ϝ _ vl). iDestruct (HE ϝ with "HL") as "#HE'".
      destruct (Qp_lower_bound qκs 1) as (q0 & q'1 & q'2 & -> & Hsum1).
      rewrite Hsum1. assert (q0 < 1)%Qp as Hq0.
      { apply Qp_lt_sum. eauto. }
      clear Hsum1.
      iDestruct "Htk" as "[Htk1 Htk2]".
      iDestruct "Hκs" as "[Hκs1 Hκs2]".
      iApply ("Hf" $! _ q0 with "LFT [] Htl [Hκs1 Htk1 Htk2] [Hk HL Hκs2]").
      + iApply "HE'". iFrame "HE".
        iIntros "{$# Hf Hend HE' LFT HE %}". subst ϝ.
        iApply big_sepL_forall.
        iIntros (i [κ1 κ2] [κ [Hpair Helem]]%elem_of_list_lookup_2%elem_of_list_fmap).
        injection Hpair as -> ->. iPureIntro. simpl.
        eapply lft_incl_syn_trans; first by apply lft_intersect_incl_syn_r.
        apply lft_intersect_list_elem_of_incl_syn.
        done.
      + iSplitL; last done. iExists ϝ. rewrite left_id. iSplit; first done.
        rewrite decide_False; last first.
        { apply Qp_lt_nge. done. }
        subst ϝ. rewrite -!lft_tok_sep. iFrame. iIntros "[Htk1 _]".
        rewrite -lft_dead_or. rewrite -bi.or_intro_l. iApply "Hend". iFrame.
      + iIntros (y) "IN {Hend}". iDestruct "IN" as %->%elem_of_list_singleton.
        iIntros (args) "Htl [Hϝ _] [Hret _]". inv_vec args=>r.
        iDestruct "Hϝ" as  (κ') "(EQ & Htk & _)". iDestruct "EQ" as %EQ.
        rewrite /= left_id in EQ. subst κ' ϝ.
        rewrite decide_False; last first.
        { apply Qp_lt_nge. done. }
        rewrite -lft_tok_sep. iDestruct "Htk" as "[_ Hκs1]". wp_rec.
        iApply ("Hk" with "Htl HL [$Hκs1 $Hκs2]"). rewrite tctx_hasty_val. done.
      + rewrite /tctx_interp vec_to_list_map !zip_with_fmap_r
                (zip_with_zip (λ v ty, (v, _))) zip_with_zip !big_sepL_fmap.
        iApply (big_sepL_mono' with "Hvl"); last done. by iIntros (i [v ty']).
  Qed.

  Lemma type_call_iris E (κs : list lft) {A} x (ps : list path) qκs tid
        f (k : expr) (fp : A → fn_params (length ps)) :
    (∀ ϝ, elctx_sat (((λ κ, ϝ ⊑ₑ κ) <$> κs) ++ E) [] ((fp x).(fp_E) ϝ)) →
    AsVal k →
    lft_ctx -∗ elctx_interp E -∗ na_own tid ⊤ -∗
    qκs.[lft_intersect_list κs] -∗
    (fn fp).(ty_own) tid [f] -∗
    ([∗ list] y ∈ zip_with TCtx_hasty ps (box <$> vec_to_list (fp x).(fp_tys)),
                   tctx_elt_interp tid y) -∗
    (∀ ret, na_own tid top -∗ qκs.[lft_intersect_list κs] -∗
             (box (fp x).(fp_ty)).(ty_own) tid [ret] -∗
             WP k [of_val ret] {{ _, cont_postcondition }}) -∗
    WP (call: f ps → k) {{ _, cont_postcondition }}.
  Proof.
    iIntros (HE Hk') "#LFT #HE Htl Hκs Hf Hargs Hk". rewrite -tctx_hasty_val.
    iApply (type_call_iris' with "LFT HE Htl [] Hκs Hf Hargs [Hk]"); [done..| |].
    - instantiate (1 := 1%Qp). instantiate (1 := 1%Qp). by rewrite /llctx_interp_noend.
    - iIntros "* Htl _". iApply "Hk". done.
  Qed.

  Lemma type_call' E L (κs : list lft) T p (ps : list path)
                   {A} (fp : A → fn_params (length ps)) (k : val) x :
    Forall (lctx_lft_alive E L) κs →
    (∀ ϝ, elctx_sat (((λ κ, ϝ ⊑ₑ κ) <$> κs) ++ E) L ((fp x).(fp_E) ϝ)) →
    ⊢ typed_body E L [k ◁cont(L, λ v : vec _ 1, ((v!!!0%fin:val) ◁ box (fp x).(fp_ty)) :: T)]
               ((p ◁ fn fp) ::
                zip_with TCtx_hasty ps (box <$> vec_to_list (fp x).(fp_tys)) ++
                T)
               (call: p ps → k).
  Proof.
    iIntros (Hκs HE tid qmax) "#LFT #HE Htl HL HC (Hf & Hargs & HT)".
    iMod (lctx_lft_alive_tok_list _ _ κs with "HE HL") as (q) "(Hκs & HL & Hclose)"; [done..|].
    iApply (type_call_iris' with "LFT HE Htl HL Hκs Hf Hargs"); [done|].
    iIntros (r) "Htl HL Hκs Hret". iMod ("Hclose" with "Hκs HL") as "HL".
    iSpecialize ("HC" with "[]"); first by (iPureIntro; apply elem_of_list_singleton).
    iApply ("HC" $! [#r] with "Htl HL").
    rewrite tctx_interp_cons tctx_hasty_val. iFrame.
  Qed.

  (* Specialized type_call':  Adapted for use by solve_typing.
     κs is still expected to be given manually. *)
  Lemma type_call {A} κs x E L C T T' T'' p (ps : list path)
                        (fp : A → fn_params (length ps)) k :
    p ◁ fn fp ∈ T →
    Forall (lctx_lft_alive E L) κs →
    (∀ ϝ, elctx_sat (((λ κ, ϝ ⊑ₑ κ) <$> κs) ++ E) L ((fp x).(fp_E) ϝ)) →
    tctx_extract_ctx E L (zip_with TCtx_hasty ps
                                   (box <$> vec_to_list (fp x).(fp_tys))) T T' →
    k ◁cont(L, T'') ∈ C →
    (∀ ret : val, tctx_incl E L ((ret ◁ box (fp x).(fp_ty))::T') (T'' [# ret])) →
    ⊢ typed_body E L C T (call: p ps → k).
  Proof.
    intros Hfn HL HE HTT' HC HT'T''.
    rewrite -typed_body_mono /flip; last done; first by eapply type_call'.
    - etrans.
      + eapply (incl_cctx_incl _ [_]); by intros ? ->%elem_of_list_singleton.
      + apply cctx_incl_cons; first done. intros args. by inv_vec args.
    - etrans; last by apply (tctx_incl_frame_l [_]).
      apply copy_elem_of_tctx_incl; last done. apply _.
  Qed.

  Lemma type_letcall {A} x E L C T T' p (ps : list path)
                        (fp : A → fn_params (length ps)) b e :
    Closed (b :b: []) e → Closed [] p → Forall (Closed []) ps →
    p ◁ fn fp ∈ T →
    Forall (lctx_lft_alive E L) (L.*1) →
    (∀ ϝ, elctx_sat (((λ κ, ϝ ⊑ₑ κ) <$> (L.*1)) ++ E) L ((fp x).(fp_E) ϝ)) →
    tctx_extract_ctx E L (zip_with TCtx_hasty ps
                                   (box <$> vec_to_list (fp x).(fp_tys))) T T' →
    (∀ ret : val, typed_body E L C ((ret ◁ box (fp x).(fp_ty))::T') (subst' b ret e)) -∗
    typed_body E L C T (letcall: b := p ps in e).
  Proof.
    iIntros (?? Hpsc ????) "He".
    iApply (type_cont_norec [_] _ (λ r, ((r!!!0%fin:val) ◁ box (fp x).(fp_ty)) :: T')).
    - (* TODO : make [solve_closed] work here. *)
      eapply is_closed_weaken; first done. set_solver+.
    - (* TODO : make [solve_closed] work here. *)
      rewrite /Closed /= !andb_True. split.
      + by eapply is_closed_weaken, list_subseteq_nil.
      + eapply Is_true_eq_left, forallb_forall, List.Forall_forall, Forall_impl=>//.
        intros. eapply Is_true_eq_true, is_closed_weaken=>//. set_solver+.
    - iIntros (k).
      (* TODO : make [simpl_subst] work here. *)
      change (subst' "_k" k (p ((λ: ["_r"], "_k" ["_r"])%E :: ps))) with
             ((subst "_k" k p) ((λ: ["_r"], k ["_r"])%E :: map (subst "_k" k) ps)).
      rewrite is_closed_nil_subst //.
      assert (map (subst "_k" k) ps = ps) as ->.
      { clear -Hpsc. induction Hpsc=>//=. rewrite is_closed_nil_subst //. congruence. }
      iApply type_call; try done.
      + constructor.
      + done.
    - simpl. iIntros (k ret). inv_vec ret=>ret. rewrite /subst_v /=.
      rewrite ->(is_closed_subst []); last set_solver+; last first.
      { apply subst'_is_closed; last done. apply is_closed_of_val. }
      (iApply typed_body_mono; last by iApply "He"); [|done..].
      apply incl_cctx_incl. set_solver+.
  Qed.

  Lemma type_rec {A} E L fb (argsb : list binder) ef e n
        (fp : A → fn_params n) T `{!CopyC T, !SendC T, !Closed _ e} :
    IntoVal ef (fnrec: fb argsb := e) →
    n = length argsb →
    □ (∀ x ϝ (f : val) k (args : vec val (length argsb)),
          typed_body ((fp x).(fp_E) ϝ) [ϝ ⊑ₗ []]
                     [k ◁cont([ϝ ⊑ₗ []], λ v : vec _ 1, [(v!!!0%fin:val) ◁ box (fp x).(fp_ty)])]
                     ((f ◁ fn fp) ::
                        zip_with (TCtx_hasty ∘ of_val) args
                                 (box <$> vec_to_list (fp x).(fp_tys)) ++ T)
                     (subst_v (fb :: BNamed "return" :: argsb) (f ::: k ::: args) e)) -∗
    typed_instruction_ty E L T ef (fn fp).
  Proof.
    iIntros (<- ->) "#Hbody /=". iIntros (tid qmax) "#LFT _ $ $ #HT". iApply wp_value.
    rewrite tctx_interp_singleton. iLöb as "IH". iExists _. iSplit.
    { simpl. rewrite decide_True_pi. done. }
    iExists fb, _, argsb, e, _. iSplit; first done. iSplit; first done. iNext.
    iIntros (x ϝ k args) "!>". iIntros (tid' qmax') "_ HE Htl HL HC HT'".
    iApply ("Hbody" with "LFT HE Htl HL HC").
    rewrite tctx_interp_cons tctx_interp_app. iFrame "HT' IH".
    by iApply sendc_change_tid.
  Qed.

  Lemma type_fn {A} E L (argsb : list binder) ef e n
        (fp : A → fn_params n) T `{!CopyC T, !SendC T, !Closed _ e} :
    IntoVal ef (fn: argsb := e) →
    n = length argsb →
    □ (∀ x ϝ k (args : vec val (length argsb)),
        typed_body ((fp x).(fp_E) ϝ)
                   [ϝ ⊑ₗ []]
                   [k ◁cont([ϝ ⊑ₗ []], λ v : vec _ 1, [(v!!!0%fin:val) ◁ box (fp x).(fp_ty)])]
                   (zip_with (TCtx_hasty ∘ of_val) args
                             (box <$> vec_to_list (fp x).(fp_tys)) ++ T)
                   (subst_v (BNamed "return" :: argsb) (k ::: args) e)) -∗
    typed_instruction_ty E L T ef (fn fp).
  Proof.
    iIntros (??) "#He". iApply type_rec; try done. iIntros "!> *".
    iApply typed_body_mono; last iApply "He"; try done.
    eapply contains_tctx_incl. by constructor.
  Qed.
End typing.

Global Hint Resolve fn_subtype : lrust_typing.