diff options
27 files changed, 40784 insertions, 1 deletions
diff --git a/.travis.yml b/.travis.yml index cc2c9a0c5..71d5315a4 100644 --- a/.travis.yml +++ b/.travis.yml @@ -122,6 +122,13 @@ jobs: env: COQ_VERSION="8.7.2" COQ_PACKAGE="coq-8.7.2" PPA="ppa:jgross-h/many-coq-versions" script: PREV=3 CUR=4 ./etc/ci/travis.sh build-selected-test build-selected-bench + - stage: standalone-ocaml + env: COQ_VERSION="8.8.0" COQ_PACKAGE="coq-8.8.0" PPA="ppa:jgross-h/many-coq-versions" + script: PREV=4 CUR=5 ./etc/ci/travis.sh standalone-ocaml + - stage: standalone-ocaml + env: COQ_VERSION="8.7.2" COQ_PACKAGE="coq-8.7.2" PPA="ppa:jgross-h/many-coq-versions" + script: PREV=4 CUR=5 ./etc/ci/travis.sh standalone-ocaml + # - stage: selected-test selected-bench # env: COQ_VERSION="8.8.0" COQ_PACKAGE="coq-8.8.0" PPA="ppa:jgross-h/many-coq-versions" # allow_failure: true @@ -7,6 +7,9 @@ TIMECMD?= STDTIME?=/usr/bin/time -f "$* (real: %e, user: %U, sys: %S, mem: %M ko)" TIMER=$(if $(TIMED), $(STDTIME), $(TIMECMD)) +GHC?=ghc +GHCFLAGS?= # -XStrict + PROFILE?= VERBOSE?= SHOW := $(if $(VERBOSE),@true "",@echo "") @@ -21,6 +24,7 @@ INSTALLDEFAULTROOT := Crypto curves-proofs no-curves-proofs no-curves-proofs-non-specific \ selected-specific selected-specific-display nonautogenerated-specific nonautogenerated-specific-display nonautogenerated-c build-selected-test selected-test build-selected-bench selected-bench selected-c \ build-test test build-bench bench c \ + standalone standalone-haskell standalone-ocaml \ regenerate-curves SORT_COQPROJECT = sed 's,[^/]*/,~&,g' | env LC_COLLATE=C sort | sed 's,~,,g' | uniq @@ -66,7 +70,10 @@ UNMADE_C_FILES := \ src/Specific/X25519/C32/fesub.c src/Specific/X25519/C32/feadd.c src/Specific/X25519/C32/fecarry.c \ src/Specific/X25519/C32/fesub.h src/Specific/X25519/C32/feadd.h src/Specific/X25519/C32/fecarry.h # files that are treated specially -SPECIAL_VOFILES := src/Specific/%Display.vo +SPECIAL_VOFILES := \ + src/Specific/%Display.vo \ + src/Experiments/NewPipeline/ExtractionOCaml/%.vo \ + src/Experiments/NewPipeline/ExtractionHaskell/%.vo SPECIFIC_GENERATED_VOFILES := src/Specific/solinas%.vo src/Specific/montgomery%.vo # add files to this list to prevent them from being built as final # targets by the "lite" target @@ -78,6 +85,8 @@ LITE_UNMADE_VOFILES := src/Curves/Weierstrass/AffineProofs.vo \ src/Specific/NISTP256/AMD128/fe%.vo \ src/Specific/X25519/C64/ladderstep.vo \ src/Specific/X25519/C32/fe%.vo \ + src/Experiments/NewPipeline/Toplevel2.vo \ + src/Experiments/NewPipeline/SlowPrimeSynthesisExamples.vo \ $(SPECIFIC_GENERATED_VOFILES) NOBIGMEM_UNMADE_VOFILES := \ src/Curves/Weierstrass/AffineProofs.vo \ @@ -447,6 +456,31 @@ build-bench: $(MEASURE_BINARIES) build-selected-bench: $(SELECTED_MEASURE_BINARIES) +STANDALONE := \ + unsaturated_solinas \ + saturated_solinas + +$(STANDALONE:%=src/Experiments/NewPipeline/ExtractionOCaml/%.ml) : %.ml : %.v src/Experiments/NewPipeline/StandaloneOCamlMain.vo + $(SHOW)'COQC $< > $@' + $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< > $@.tmp + $(HIDE)sed s'/\r\n/\n/g' $@.tmp > $@ && rm -f $@.tmp + +$(STANDALONE:%=src/Experiments/NewPipeline/ExtractionHaskell/%.hs) : %.hs : %.v src/Experiments/NewPipeline/StandaloneHaskellMain.vo src/Experiments/NewPipeline/haskell.sed + $(SHOW)'COQC $< > $@' + $(HIDE)$(TIMER) $(COQC) $(COQDEBUG) $(COQFLAGS) $(COQLIBS) $< > $@.tmp + $(HIDE)sed s'/\r\n/\n/g' $@.tmp | sed -f src/Experiments/NewPipeline/haskell.sed > $@ && rm -f $@.tmp + +$(STANDALONE:%=src/Experiments/NewPipeline/ExtractionOCaml/%) : % : %.ml + $(TIMER) ocamlopt -o $@ $< + +$(STANDALONE:%=src/Experiments/NewPipeline/ExtractionHaskell/%) : % : %.hs + $(TIMER) $(GHC) $(GHCFLAGS) -o $@ $< + +standalone: standalone-haskell standalone-ocaml + +standalone-haskell: $(STANDALONE:%=src/Experiments/NewPipeline/ExtractionHaskell/%) +standalone-ocaml: $(STANDALONE:%=src/Experiments/NewPipeline/ExtractionOCaml/%) + clean:: rm -f Makefile.coq remake_curves.log src/Specific/.autgenerated-deps diff --git a/_CoqProject b/_CoqProject index 271f7585f..51eca87d1 100644 --- a/_CoqProject +++ b/_CoqProject @@ -242,6 +242,26 @@ src/Curves/Weierstrass/Jacobian.v src/Curves/Weierstrass/Projective.v src/Experiments/PartialEvaluationWithLetIn.v src/Experiments/SimplyTypedArithmetic.v +src/Experiments/NewPipeline/AbstractInterpretation.v +src/Experiments/NewPipeline/AbstractInterpretationProofs.v +src/Experiments/NewPipeline/Arithmetic.v +src/Experiments/NewPipeline/CLI.v +src/Experiments/NewPipeline/CStringification.v +src/Experiments/NewPipeline/CompilersTestCases.v +src/Experiments/NewPipeline/GENERATEDIdentifiersWithoutTypes.v +src/Experiments/NewPipeline/Language.v +src/Experiments/NewPipeline/MiscCompilerPasses.v +src/Experiments/NewPipeline/Rewriter.v +src/Experiments/NewPipeline/SlowPrimeSynthesisExamples.v +src/Experiments/NewPipeline/StandaloneHaskellMain.v +src/Experiments/NewPipeline/StandaloneOCamlMain.v +src/Experiments/NewPipeline/Toplevel1.v +src/Experiments/NewPipeline/Toplevel2.v +src/Experiments/NewPipeline/UnderLets.v +src/Experiments/NewPipeline/ExtractionHaskell/saturated_solinas.v +src/Experiments/NewPipeline/ExtractionHaskell/unsaturated_solinas.v +src/Experiments/NewPipeline/ExtractionOCaml/saturated_solinas.v +src/Experiments/NewPipeline/ExtractionOCaml/unsaturated_solinas.v src/LegacyArithmetic/ArchitectureToZLike.v src/LegacyArithmetic/ArchitectureToZLikeProofs.v src/LegacyArithmetic/BarretReduction.v diff --git a/src/Experiments/NewPipeline/AbstractInterpretation.v b/src/Experiments/NewPipeline/AbstractInterpretation.v new file mode 100644 index 000000000..eada46692 --- /dev/null +++ b/src/Experiments/NewPipeline/AbstractInterpretation.v @@ -0,0 +1,1090 @@ +Require Import Coq.ZArith.ZArith. +Require Import Crypto.Util.ListUtil Coq.Lists.List Crypto.Util.ListUtil.FoldBool. +Require Import Crypto.Util.ZRange. +Require Import Crypto.Util.ZRange.Operations. +Require Import Crypto.Util.Option. +Require Import Crypto.Util.ZUtil.Tactics.LtbToLt. +Require Import Crypto.Util.LetIn. +Require Import Crypto.Experiments.NewPipeline.Language. +Require Import Crypto.Experiments.NewPipeline.UnderLets. +Import ListNotations. Local Open Scope bool_scope. Local Open Scope Z_scope. + +Module Compilers. + Export Language.Compilers. + Export UnderLets.Compilers. + Import invert_expr. + + Module ZRange. + Module type. + Local Notation binterp := base.interp. + Local Notation tinterp_gen := type.interp. + Local Notation einterp := (type.interp base.interp). + Module base. + (** turn a [base.type] into a [Set] describing the type of + bounds on that primitive; Z is a range, nat and bool are exact values *) + Fixpoint interp (t : base.type) : Set + := match t with + | base.type.Z => zrange + | base.type.unit as t + | base.type.nat as t + | base.type.bool as t + => base.interp t + | base.type.prod A B => interp A * interp B + | base.type.list A => list (interp A) + end%type. + Definition is_neg {t} : interp t -> bool + := match t with + | base.type.Z => fun r => (lower r <? 0) && (upper r <=? 0) + | _ => fun _ => false + end. + Fixpoint is_tighter_than {t} : interp t -> interp t -> bool + := match t with + | base.type.Z => is_tighter_than_bool + | base.type.nat => Nat.eqb + | base.type.unit => fun _ _ => true + | base.type.bool => bool_eq + | base.type.prod A B + => fun '(a, b) '(a', b') + => @is_tighter_than A a a' && @is_tighter_than B b b' + | base.type.list A + => fold_andb_map (@is_tighter_than A) + end%bool. + Fixpoint is_bounded_by {t} : interp t -> binterp t -> bool + := match t with + | base.type.Z => fun r z => (lower r <=? z) && (z <=? upper r) + | base.type.nat => Nat.eqb + | base.type.unit => fun _ _ => true + | base.type.bool => bool_eq + | base.type.prod A B + => fun '(a, b) '(a', b') + => @is_bounded_by A a a' && @is_bounded_by B b b' + | base.type.list A + => fold_andb_map (@is_bounded_by A) + end. + Module option. + (** turn a [base.type] into a [Set] describing the type + of optional bounds on that primitive; bounds on a [Z] + may be either a range, or [None], generally indicating + that the [Z] is unbounded. *) + Fixpoint interp (t : base.type) : Set + := match t with + | base.type.Z => option zrange + | base.type.unit => unit + | base.type.nat as t + | base.type.bool as t + => option (base.interp t) + | base.type.prod A B => interp A * interp B + | base.type.list A => option (list (interp A)) + end%type. + Fixpoint None {t} : interp t + := match t with + | base.type.unit => tt + | base.type.list _ + | base.type.Z + | base.type.nat + | base.type.bool + => Datatypes.None + | base.type.prod A B + => (@None A, @None B) + end. + Fixpoint Some {t} : base.interp t -> interp t + := match t with + | base.type.Z + | base.type.nat + | base.type.bool + => Datatypes.Some + | base.type.list A + => fun ls => Datatypes.Some (List.map (@Some A) ls) + | base.type.prod A B + => fun '(a, b) + => (@Some A a, @Some B b) + | _ => fun _ => tt + end. + (** Keep data about list length and nat value, but not zrange *) + Fixpoint strip_ranges {t} : interp t -> interp t + := match t with + | base.type.Z => fun _ => Datatypes.None + | base.type.nat + | base.type.bool + | base.type.unit + => fun x => x + | base.type.list A + => fun ls => ls <- ls; Datatypes.Some (List.map (@strip_ranges A) ls) + | base.type.prod A B + => fun '(a, b) + => (@strip_ranges A a, @strip_ranges B b) + end%option. + Definition is_neg {t} : interp t -> bool + := match t with + | base.type.Z + => fun v => match v with + | Datatypes.Some v => @is_neg base.type.Z v + | Datatypes.None => false + end + | t => fun _ => false + end. + Fixpoint is_tighter_than {t} : interp t -> interp t -> bool + := match t with + | base.type.Z as t + | base.type.nat as t + | base.type.bool as t + => fun r1 r2 + => match r1, r2 with + | _, Datatypes.None => true + | Datatypes.None, Datatypes.Some _ => false + | Datatypes.Some r1, Datatypes.Some r2 => base.is_tighter_than (t:=t) r1 r2 + end + | base.type.prod A B + => fun '(a, b) '(a', b') + => @is_tighter_than A a a' && @is_tighter_than B b b' + | base.type.list A + => fun ls1 ls2 + => match ls1, ls2 with + | Datatypes.None, Datatypes.None => true + | Datatypes.Some _, Datatypes.None => true + | Datatypes.None, Datatypes.Some _ => false + | Datatypes.Some ls1, Datatypes.Some ls2 => fold_andb_map (@is_tighter_than A) ls1 ls2 + end + | _ => fun 'tt 'tt => true + end. + Fixpoint is_bounded_by {t} : interp t -> binterp t -> bool + := match t with + | base.type.Z as t + | base.type.nat as t + | base.type.bool as t + => fun r + => match r with + | Datatypes.Some r => @base.is_bounded_by t r + | Datatypes.None => fun _ => true + end + | base.type.prod A B + => fun '(a, b) '(a', b') + => @is_bounded_by A a a' && @is_bounded_by B b b' + | base.type.list A + => fun ls1 ls2 + => match ls1 with + | Datatypes.None => true + | Datatypes.Some ls1 => fold_andb_map (@is_bounded_by A) ls1 ls2 + end + | _ => fun 'tt _ => true + end. + + Lemma is_bounded_by_Some {t} r val + : is_bounded_by (@Some t r) val = base.is_bounded_by r val. + Proof. + induction t; + repeat first [ reflexivity + | progress cbn in * + | progress destruct_head'_prod + | progress destruct_head' base.type.base + | rewrite fold_andb_map_map1 + | match goal with H : _ |- _ => rewrite H end + | match goal with H : _ |- _ => setoid_rewrite H end ]. + Qed. + + Lemma is_tighter_than_is_bounded_by {t} r1 r2 val + (Htight : @is_tighter_than t r1 r2 = true) + (Hbounds : is_bounded_by r1 val = true) + : is_bounded_by r2 val = true. + Proof. + induction t; + repeat first [ progress destruct_head'_prod + | progress destruct_head'_and + | progress destruct_head'_unit + | progress cbn in * + | progress destruct_head' option + | solve [ eauto with nocore ] + | progress cbv [is_tighter_than_bool] in * + | progress rewrite ?Bool.andb_true_iff in * + | discriminate + | apply conj + | Z.ltb_to_lt; omega + | progress break_innermost_match_hyps + | progress subst + | rewrite NPeano.Nat.eqb_refl + | reflexivity + | match goal with + | [ H : Nat.eqb _ _ = true |- _ ] => apply beq_nat_true in H + | [ H : bool_eq _ _ = true |- _ ] => apply bool_eq_ok in H + | [ |- bool_eq ?x ?x = true ] => destruct x; reflexivity + end ]. + { lazymatch goal with + | [ r1 : list (interp t), r2 : list (interp t), val : list (binterp t) |- _ ] + => revert r1 r2 val Htight Hbounds IHt + end; intros r1 r2 val; revert r1 r2 val. + induction r1, r2, val; cbn; auto with nocore; try congruence; []. + rewrite !Bool.andb_true_iff; intros; destruct_head'_and; split; eauto with nocore. } + Qed. + + Lemma is_tighter_than_Some_is_bounded_by {t} r1 r2 val + (Htight : @is_tighter_than t r1 (Some r2) = true) + (Hbounds : is_bounded_by r1 val = true) + : base.is_bounded_by r2 val = true. + Proof. + rewrite <- is_bounded_by_Some. + eapply is_tighter_than_is_bounded_by; eassumption. + Qed. + End option. + End base. + + (** turn a [type] into a [Set] describing the type of bounds on + that type; this lifts [base.interp] from + [type.base] to [type] *) + Definition interp (t : type base.type) + := type.interp base.interp t. + Fixpoint is_tighter_than {t} : interp t -> interp t -> bool + := match t with + | type.base x => @base.is_tighter_than x + | type.arrow s d => fun _ _ => false + end. + Fixpoint is_bounded_by {t} : interp t -> einterp t -> bool + := match t return interp t -> einterp t -> bool with + | type.base x => @base.is_bounded_by x + | type.arrow s d => fun _ _ => false + end. + Module option. + (** turn a [type] into a [Set] describing the type of optional + bounds on that base type; bounds on a [Z] may be either a + range, or [None], generally indicating that the [Z] is + unbounded. This lifts [base.option.interp] from + [base.type] to [type] *) + Definition interp (t : type base.type) + := tinterp_gen base.option.interp t. + Fixpoint None {t : type base.type} : interp t + := match t with + | type.base x => @base.option.None x + | type.arrow s d => fun _ => @None d + end. + Fixpoint Some {t : type base.type} : type.interp t -> interp t + := match t with + | type.base x =>@base.option.Some x + | type.arrow s d => fun _ _ => @None d + end. + Fixpoint strip_ranges {t : type base.type} : interp t -> interp t + := match t with + | type.base x =>@base.option.strip_ranges x + | type.arrow s d => fun f x => @strip_ranges d (f x) + end. + Fixpoint is_tighter_than {t} : interp t -> interp t -> bool + := match t with + | type.base x => @base.option.is_tighter_than x + | type.arrow s d => fun _ _ => false + end. + Fixpoint is_bounded_by {t} : interp t -> einterp t -> bool + := match t with + | type.base x => @base.option.is_bounded_by x + | type.arrow s d => fun _ _ => false + end. + + Lemma is_bounded_by_Some {t} r val + : is_bounded_by (@Some t r) val = type.is_bounded_by r val. + Proof. + induction t; [ apply base.option.is_bounded_by_Some | reflexivity ]. + Qed. + + Lemma is_tighter_than_is_bounded_by {t} r1 r2 val + (Htight : @is_tighter_than t r1 r2 = true) + (Hbounds : is_bounded_by r1 val = true) + : is_bounded_by r2 val = true. + Proof. + induction t; cbn in *; + eauto using base.option.is_tighter_than_is_bounded_by. + Qed. + + Lemma is_tighter_than_Some_is_bounded_by {t} r1 r2 val + (Htight : @is_tighter_than t r1 (Some r2) = true) + (Hbounds : is_bounded_by r1 val = true) + : type.is_bounded_by r2 val = true. + Proof. + rewrite <- is_bounded_by_Some. + eapply is_tighter_than_is_bounded_by; eassumption. + Qed. + End option. + End type. + + Module ident. + Module option. + Local Open Scope zrange_scope. + + Fixpoint of_literal {t} : base.interp t -> type.base.option.interp t + := match t with + | base.type.Z => fun z => Some r[z~>z]%zrange + | base.type.nat + | base.type.bool + => fun n => Some n + | base.type.unit + => fun _ => tt + | base.type.prod A B + => fun '(a, b) => (@of_literal A a, @of_literal B b) + | base.type.list A + => fun ls => Some (List.map (@of_literal A) ls) + end. + Fixpoint to_literal {t} : type.base.option.interp t -> option (base.interp t) + := match t with + | base.type.Z => fun r => r <- r; if r.(lower) =? r.(upper) then Some r.(lower) else None + | base.type.nat + | base.type.bool + => fun v => v + | base.type.unit + => fun _ => Some tt + | base.type.prod A B + => fun '(a, b) => a <- @to_literal A a; b <- @to_literal B b; Some (a, b) + | base.type.list A + => fun ls => ls <- ls; fold_right (fun x xs => x <- x; xs <- xs; Some (x :: xs)) + (Some nil) + (List.map (@to_literal A) ls) + end%option%Z. + Local Notation rSome v + := (ZRange.type.base.option.Some (t:=base.reify_norm_type_of v) v) + (only parsing). + (** do bounds analysis on identifiers; take in optional bounds + on arguments, return optional bounds on outputs. *) + Definition interp {t} (idc : ident t) : type.option.interp t + := match idc in ident.ident t return type.option.interp t with + | ident.Literal _ v => of_literal v + | ident.Nat_succ as idc + | ident.Nat_pred as idc + => option_map (ident.interp idc) + | ident.Z_of_nat as idc + => option_map (fun n => r[Z.of_nat n~>Z.of_nat n]%zrange) + | ident.List_length _ + => option_map (@List.length _) + | ident.Nat_max as idc + | ident.Nat_mul as idc + | ident.Nat_add as idc + | ident.Nat_sub as idc + | ident.List_seq as idc + => fun x y => x <- x; y <- y; rSome (ident.interp idc x y) + | ident.List_repeat _ + => fun x y => y <- y; Some (repeat x y) + | ident.List_combine _ _ + => fun x y => x <- x; y <- y; Some (List.combine x y) + | ident.List_flat_map _ _ + => fun f ls + => (ls <- ls; + let fls := List.map f ls in + List.fold_right + (fun ls1 ls2 => ls1 <- ls1; ls2 <- ls2; Some (ls1 ++ ls2)) + (Some nil) + fls) + | ident.List_partition _ + => fun f ls + => match ls with + | Some ls + => list_rect + _ + (Some nil, Some nil) + (fun x tl partition_tl + => let '(g, d) := partition_tl in + ((fx <- f x; + if fx then (g <- g; Some (x::g)) else g), + (fx <- f x; + if fx then d else (d <- d; Some (x::d))))) + ls + | None => (None, None) + end + | ident.Z_eqb as idc + | ident.Z_leb as idc + | ident.Z_cc_m as idc + | ident.Z_pow as idc + | ident.Z_modulo as idc + => fun x y => match to_literal x, to_literal y with + | Some x, Some y => of_literal (ident.interp idc x y) + | _, _ => ZRange.type.base.option.None + end + | ident.bool_rect _ + => fun t f b + => match b with + | Some b => if b then t tt else f tt + | None => ZRange.type.base.option.None + end + | ident.nat_rect _ + => fun O_case S_case n + => match n with + | Some n + => nat_rect + _ + (O_case tt) + (fun n' rec => S_case (Some n') rec) + n + | None => ZRange.type.base.option.None + end + | ident.list_rect _ _ + => fun N C ls + => match ls with + | Some ls + => list_rect + _ + (N tt) + (fun x xs rec => C x (Some xs) rec) + ls + | None => ZRange.type.base.option.None + end + | ident.list_case _ _ + => fun N C ls + => match ls with + | Some ls + => list_case + _ + (N tt) + (fun x xs => C x (Some xs)) + ls + | None => ZRange.type.base.option.None + end + | ident.List_fold_right _ _ + => fun f v ls + => match ls with + | Some ls + => fold_right f v ls + | None => ZRange.type.base.option.None + end + | ident.List_nth_default _ + => fun d ls n + => match ls, n with + | Some ls, Some n + => nth_default d ls n + | _, _ => ZRange.type.base.option.None + end + | ident.List_update_nth _ + => fun n f ls => ls <- ls; n <- n; Some (update_nth n f ls) + | ident.Z_mul_split as idc + | ident.Z_add_get_carry as idc + | ident.Z_sub_get_borrow as idc + => fun x y z => match to_literal x, to_literal y, to_literal z with + | Some x, Some y, Some z => of_literal (ident.interp idc x y z) + | _, _, _ => ZRange.type.base.option.None + end + | ident.Z_add_with_get_carry as idc + | ident.Z_sub_with_get_borrow as idc + | ident.Z_rshi as idc + => fun x y z w => match to_literal x, to_literal y, to_literal z, to_literal w with + | Some x, Some y, Some z, Some w => of_literal (ident.interp idc x y z w) + | _, _, _, _ => ZRange.type.base.option.None + end + | ident.nil t => Some nil + | ident.cons t => fun x => option_map (cons x) + | ident.pair A B => pair + | ident.fst A B => fst + | ident.snd A B => snd + | ident.pair_rect A B P => fun f '(a, b) => f a b + | ident.List_map _ _ + => fun f ls => ls <- ls; Some (List.map f ls) + | ident.List_app _ + => fun ls1 ls2 => ls1 <- ls1; ls2 <- ls2; Some (List.app ls1 ls2) + | ident.List_rev _ => option_map (@List.rev _) + | ident.Z_opp as idc + | ident.Z_shiftr _ as idc + | ident.Z_shiftl _ as idc + | ident.Z_cc_m_concrete _ as idc + => fun x => x <- x; Some (ZRange.two_corners (ident.interp idc) x) + | ident.Z_add as idc + | ident.Z_mul as idc + | ident.Z_sub as idc + | ident.Z_div as idc + | ident.Z_rshi_concrete _ _ as idc + => fun x y => x <- x; y <- y; Some (ZRange.four_corners (ident.interp idc) x y) + | ident.Z_add_with_carry as idc + => fun x y z => x <- x; y <- y; z <- z; Some (ZRange.eight_corners (ident.interp idc) x y z) + | ident.Z_land mask + => option_map (ZRange.land_bounds r[mask~>mask]) + | ident.Z_mul_split_concrete split_at + => fun x y + => match x, y with + | Some x, Some y + => ZRange.type.base.option.Some + (t:=base.type.Z*base.type.Z) + (ZRange.split_bounds (ZRange.four_corners Z.mul x y) split_at) + | _, _ => ZRange.type.base.option.None + end + | ident.Z_add_get_carry_concrete split_at + => fun x y + => match x, y with + | Some x, Some y + => ZRange.type.base.option.Some + (t:=base.type.Z*base.type.Z) + (ZRange.split_bounds (ZRange.four_corners Z.add x y) split_at) + | _, _ => ZRange.type.base.option.None + end + | ident.Z_add_with_get_carry_concrete split_at + => fun x y z + => match x, y, z with + | Some x, Some y, Some z + => ZRange.type.base.option.Some + (t:=base.type.Z*base.type.Z) + (ZRange.split_bounds + (ZRange.eight_corners (fun x y z => (x + y + z)%Z) x y z) + split_at) + | _, _, _ => ZRange.type.base.option.None + end + | ident.Z_sub_get_borrow_concrete split_at + => fun x y + => match x, y with + | Some x, Some y + => ZRange.type.base.option.Some + (t:=base.type.Z*base.type.Z) + (let b := ZRange.split_bounds (ZRange.four_corners BinInt.Z.sub x y) split_at in + (* N.B. sub_get_borrow returns - ((x - y) / split_at) as the borrow, so we need to negate *) + (fst b, ZRange.opp (snd b))) + | _, _ => ZRange.type.base.option.None + end + | ident.Z_sub_with_get_borrow_concrete split_at + => fun x y z + => match x, y, z with + | Some x, Some y, Some z + => ZRange.type.base.option.Some + (t:=base.type.Z*base.type.Z) + (let b := ZRange.split_bounds (ZRange.eight_corners (fun x y z => (y - z - x)%Z) x y z) split_at in + (* N.B. sub_get_borrow returns - ((x - y) / split_at) as the borrow, so we need to negate *) + (fst b, ZRange.opp (snd b))) + | _, _, _ => ZRange.type.base.option.None + end + | ident.Z_zselect + => fun _ y z => y <- y; z <- z; Some (ZRange.union y z) + | ident.Z_add_modulo + => fun x y m + => (x <- x; + y <- y; + m <- m; + Some (ZRange.union + (ZRange.four_corners Z.add x y) + (ZRange.eight_corners (fun x y m => Z.max 0 (x + y - m)) + x y m))) + | ident.Z_neg_snd (** TODO(jadep): This is only here for demonstration purposes; remove it once you no longer need it as a template *) + => fun '(a, b) => (a, option_map ZRange.opp b) + | ident.Z_cast range + => fun r : option zrange + => Some match r with + | Some r => ZRange.intersection r range + | None => range + end + | ident.Z_cast2 (r1, r2) + => fun '((r1', r2') : option zrange * option zrange) + => (Some match r1' with + | Some r => ZRange.intersection r r1 + | None => r1 + end, + Some match r2' with + | Some r => ZRange.intersection r r2 + | None => r2 + end) + (** TODO(jadep): fill in fancy bounds analysis rules *) + | ident.fancy_add log2wordmax _ + | ident.fancy_sub log2wordmax _ + => let wordmax := 2^log2wordmax in + let r := r[0~>wordmax-1] in + fun args + => if ZRange.type.base.option.is_tighter_than args (Some r, Some r) + then (Some r, Some r[0~>1]) + else ZRange.type.base.option.None + | ident.fancy_addc log2wordmax _ + | ident.fancy_subb log2wordmax _ + => let wordmax := 2^log2wordmax in + let r := r[0~>wordmax-1] in + fun args + => if ZRange.type.base.option.is_tighter_than args (Some r, Some r, Some r) + then (Some r, Some r[0~>1]) + else ZRange.type.base.option.None + | ident.fancy_mulll log2wordmax + | ident.fancy_mullh log2wordmax + | ident.fancy_mulhl log2wordmax + | ident.fancy_mulhh log2wordmax + => let wordmax := 2^log2wordmax in + let r := r[0~>wordmax-1] in + fun args + => if ZRange.type.base.option.is_tighter_than args (Some r, Some r) + then Some r + else ZRange.type.base.option.None + | ident.fancy_rshi _ _ as idc + => fun '(x, y) => x <- x; y <- y; Some (ZRange.four_corners (fun x y => ident.interp idc (x, y)) x y) + | ident.fancy_selm _ + | ident.fancy_selc + | ident.fancy_sell + => fun '(_, y, z) => y <- y; z <- z; Some (ZRange.union y z) + | ident.fancy_addm + => fun '(x, y, m) + => (x <- x; + y <- y; + m <- m; + Some (ZRange.union + (ZRange.four_corners Z.add x y) + (ZRange.eight_corners (fun x y m => Z.max 0 (x + y - m)) + x y m))) + end%option. + End option. + End ident. + End ZRange. + + (** XXX TODO: Do we still need to do UnderLets here? *) + Module partial. + Import UnderLets. + Section with_var. + Context {base_type : Type}. + Local Notation type := (type base_type). + Let type_base (x : base_type) : type := type.base x. + Local Coercion type_base : base_type >-> type. + Context {ident : type -> Type} + {var : type -> Type}. + Local Notation expr := (@expr base_type ident). + Local Notation UnderLets := (@UnderLets base_type ident var). + Context (abstract_domain' : base_type -> Type) + (annotate : forall (is_let_bound : bool) t, abstract_domain' t -> @expr var t -> UnderLets (@expr var t)) + (bottom' : forall A, abstract_domain' A) + (abstract_interp_ident : forall t, ident t -> type.interp abstract_domain' t). + + Definition abstract_domain (t : type) + := type.interp abstract_domain' t. + + Fixpoint value (t : type) + := (abstract_domain t + * match t return Type (* COQBUG(https://github.com/coq/coq/issues/7727) *) with + | type.base t + => @expr var t + | type.arrow s d + => value s -> UnderLets (value d) + end)%type. + + Definition value_with_lets (t : type) + := UnderLets (value t). + + Context (interp_ident : forall t, ident t -> value_with_lets t). + + Definition lazy_abstract_domain (t : type) + := type.interp (fun t => unit -> abstract_domain' t) t. + + Fixpoint force_abstract_domain {t} : lazy_abstract_domain t -> abstract_domain t + := match t with + | type.base t => fun st => st tt + | type.arrow s d + => fun f x => @force_abstract_domain d (f (@thunk_abstract_domain s x)) + end + with thunk_abstract_domain {t} : abstract_domain t -> lazy_abstract_domain t + := match t with + | type.base t => fun st 'tt => st + | type.arrow s d + => fun f x => @thunk_abstract_domain d (f (@force_abstract_domain s x)) + end. + + Fixpoint bottom {t} : abstract_domain t + := match t with + | type.base t => bottom' t + | type.arrow s d => fun _ => @bottom d + end. + + Fixpoint bottom_for_each_lhs_of_arrow {t} : type.for_each_lhs_of_arrow abstract_domain t + := match t return type.for_each_lhs_of_arrow abstract_domain t with + | type.base t => tt + | type.arrow s d => (bottom, @bottom_for_each_lhs_of_arrow d) + end. + + Definition state_of_value {t} : value t -> abstract_domain t + := match t return value t -> abstract_domain t with + | type.base t => fun '(st, v) => st + | type.arrow s d => fun '(st, v) => st + end. + + Fixpoint reify (is_let_bound : bool) {t} : value t -> type.for_each_lhs_of_arrow abstract_domain t -> UnderLets (@expr var t) + := match t return value t -> type.for_each_lhs_of_arrow abstract_domain t -> UnderLets (@expr var t) with + | type.base t + => fun '(st, v) 'tt + => annotate is_let_bound t st v + | type.arrow s d + => fun '(f_st, f_e) '(sv, dv) + => Base + (λ x , (UnderLets.to_expr + (fx <-- f_e (@reflect _ (expr.Var x) sv); + @reify false _ fx dv))) + end%core%expr + with reflect {t} : @expr var t -> abstract_domain t -> value t + := match t return @expr var t -> abstract_domain t -> value t with + | type.base t + => fun e st => (st, e) + | type.arrow s d + => fun e absf + => (absf, + (fun v + => let stv := state_of_value v in + (rv <-- (@reify false s v bottom_for_each_lhs_of_arrow); + Base (@reflect d (e @ rv) (absf stv))%expr))) + end%under_lets. + + (* N.B. Because the [App] case only looks at the second argument + of arrow-values, we are free to set the state of [Abs] + nodes to [bottom], because for any [Abs] nodes which are + actually applied (here and in places where we don't + rewrite), we just drop it. *) + Fixpoint interp {t} (e : @expr value_with_lets t) : value_with_lets t + := match e in expr.expr t return value_with_lets t with + | expr.Ident t idc => interp_ident _ idc (* Base (reflect (###idc) (abstract_interp_ident _ idc))*) + | expr.Var t v => v + | expr.Abs s d f => Base (bottom, fun x => @interp d (f (Base x))) + | expr.App s d f x + => (x' <-- @interp s x; + f' <-- @interp (s -> d)%etype f; + snd f' x') + | expr.LetIn (type.arrow _ _) B x f + => (x' <-- @interp _ x; + @interp _ (f (Base x'))) + | expr.LetIn (type.base A) B x f + => (x' <-- @interp _ x; + x'' <-- reify true (* this forces a let-binder here *) x' tt; + @interp _ (f (Base (reflect x'' (state_of_value x'))))) + end%under_lets. + + Definition eval_with_bound' {t} (e : @expr value_with_lets t) + (st : type.for_each_lhs_of_arrow abstract_domain t) + : expr t + := UnderLets.to_expr (e' <-- interp e; reify false e' st). + + Definition eval' {t} (e : @expr value_with_lets t) : expr t + := eval_with_bound' e bottom_for_each_lhs_of_arrow. + + Definition eta_expand_with_bound' {t} (e : @expr var t) + (st : type.for_each_lhs_of_arrow abstract_domain t) + : expr t + := UnderLets.to_expr (reify false (reflect e bottom) st). + + Section extract. + Context (ident_extract : forall t, ident t -> lazy_abstract_domain t). + + Fixpoint extract' {t} (e : @expr lazy_abstract_domain t) + : lazy_abstract_domain t + := match e in expr.expr t return lazy_abstract_domain t with + | expr.Ident t idc => ident_extract t idc + | expr.Var t v => v + | expr.Abs s d f + => fun v => @extract' d (f v) + | expr.App s d f x + => let f' := @extract' _ f in + let x' := @extract' _ x in + f' x' + | expr.LetIn A B x f + => let x' := @extract' A x in + @extract' B (f x') + end. + + Definition extract_gen {t} (e : @expr lazy_abstract_domain t) (bound : type.for_each_lhs_of_arrow abstract_domain t) + : abstract_domain' (type.final_codomain t) + := type.app_curried (extract' e) (type.map_for_each_lhs_of_arrow (@thunk_abstract_domain) bound) tt. + End extract. + End with_var. + + Module ident. + Section with_var. + Local Notation type := (type base.type). + Let type_base (x : base.type) : type := type.base x. + Local Coercion type_base : base.type >-> type. + Context {var : type -> Type}. + Local Notation expr := (@expr base.type ident). + Local Notation UnderLets := (@UnderLets base.type ident var). + Context (abstract_domain' : base.type -> Type). + Local Notation abstract_domain := (@abstract_domain base.type abstract_domain'). + Context (annotate_ident : forall t, abstract_domain' t -> option (ident (t -> t))) + (bottom' : forall A, abstract_domain' A) + (abstract_interp_ident : forall t, ident t -> type.interp abstract_domain' t) + (update_literal_with_state : forall A : base.type.base, abstract_domain' A -> base.interp A -> base.interp A) + (extract_list_state : forall A, abstract_domain' (base.type.list A) -> option (list (abstract_domain' A))) + (is_annotation : forall t, ident t -> bool) + (*(do_again : forall t : base.type, @expr var t -> UnderLets (@expr var t))*). + + (** TODO: Is it okay to commute annotations? *) + Definition update_annotation {t} (st : abstract_domain' t) (e : @expr var t) : @expr var t + := match e with + | (#cst' @ e') + => if is_annotation _ cst' + then match type.try_transport base.try_make_transport_cps ident _ (t -> t) cst', type.try_transport base.try_make_transport_cps _ _ _ e' with + | Some cst'', Some e'' + => match annotate_ident _ (abstract_interp_ident _ cst'' st) with + | Some cst''' => ###cst''' @ e'' + | None => e + end%expr + | _, _ => e + end + else match annotate_ident _ st with + | Some cst => ###cst @ e + | None => e + end%expr + | _ => match annotate_ident _ st with + | Some cst => ###cst @ e + | None => e + end%expr + end%expr_pat. + + Definition annotate_with_ident (is_let_bound : bool) {t} + (st : abstract_domain' t) (e : @expr var t) + : UnderLets (@expr var t) + := let cst_e := update_annotation st e (*match annotate_ident _ st with + | Some cst => ###cst @ e + | None => e + end%expr*) in + if is_let_bound + then UnderLet cst_e (fun v => Base ($v)%expr) + else Base cst_e. + + Definition annotate_base (is_let_bound : bool) {t : base.type.base} + (st : abstract_domain' t) (e : @expr var t) + : UnderLets (@expr var t) + := match invert_Literal e with + | Some v => Base ##(update_literal_with_state _ st v) + | None => annotate_with_ident is_let_bound st e + end%expr. + + Fixpoint annotate (is_let_bound : bool) {t : base.type} : abstract_domain' t -> @expr var t -> UnderLets (@expr var t) + := match t return abstract_domain' t -> @expr var t -> UnderLets (@expr var t) with + | base.type.type_base t => annotate_base is_let_bound + | base.type.prod A B + => fun st e + => match invert_pair e with + | Some (x, y) + => let stx := abstract_interp_ident _ ident.fst st in + let sty := abstract_interp_ident _ ident.snd st in + (x' <-- @annotate is_let_bound A stx x; + y' <-- @annotate is_let_bound B sty y; + Base (x', y')%expr) + | None => annotate_with_ident is_let_bound st e + end + | base.type.list A + => fun st e + => match extract_list_state _ st, reflect_list e with + | Some ls_st, Some ls_e + => (retv <---- (List.map + (fun '(st', e') => @annotate is_let_bound A st' e') + (List.combine ls_st ls_e)); + Base (reify_list retv)) + | Some ls_st, None + => (retv <---- (List.map + (fun '(n, st') + => let e' := (#ident.List_nth_default @ DefaultValue.expr.base.default @ e @ ##(n:nat))%expr in + @annotate is_let_bound A st' e') + (List.combine (List.seq 0 (List.length ls_st)) ls_st)); + Base (reify_list retv)) + | None, _ => annotate_with_ident is_let_bound st e + end + end%under_lets. + + Local Notation value_with_lets := (@value_with_lets base.type ident var abstract_domain'). + Local Notation reify := (@reify base.type ident var abstract_domain' annotate bottom'). + Local Notation reflect := (@reflect base.type ident var abstract_domain' annotate bottom'). + + (** We manually rewrite with the rule for [nth_default], as the eliminator for eta-expanding lists in the input *) + Definition interp_ident {t} (idc : ident t) : value_with_lets t + := match idc in ident t return value_with_lets t with + | ident.List_nth_default T as idc + => let default := reflect (###idc) (abstract_interp_ident _ idc) in + Base + (fst default, + (fun default_arg + => default <-- snd default default_arg; + Base + (fst default, + (fun ls_arg + => default <-- snd default ls_arg; + Base + (fst default, + (fun n_arg + => default <-- snd default n_arg; + ls' <-- @reify false (base.type.list T) ls_arg tt; + Base + (fst default, + match reflect_list ls', invert_Literal (snd n_arg) with + | Some ls, Some n + => nth_default (snd default_arg) ls n + | _, _ => snd default + end))))))) + | idc => Base (reflect (###idc) (abstract_interp_ident _ idc)) + end%core%under_lets%expr. + + Definition eval_with_bound {t} (e : @expr value_with_lets t) + (st : type.for_each_lhs_of_arrow abstract_domain t) + : @expr var t + := @eval_with_bound' base.type ident var abstract_domain' annotate bottom' (@interp_ident) t e st. + + Definition eval {t} (e : @expr value_with_lets t) : @expr var t + := @eval' base.type ident var abstract_domain' annotate bottom' (@interp_ident) t e. + + Definition eta_expand_with_bound {t} (e : @expr var t) + (st : type.for_each_lhs_of_arrow abstract_domain t) + : @expr var t + := @eta_expand_with_bound' base.type ident var abstract_domain' annotate bottom' t e st. + + Section extract. + Local Notation lazy_abstract_domain := (@lazy_abstract_domain base.type abstract_domain'). + Local Notation thunk_abstract_domain := (@thunk_abstract_domain base.type abstract_domain'). + Local Notation bottom := (@bottom base.type abstract_domain' bottom'). + Definition ident_extract {t} (idc : ident t) : lazy_abstract_domain t + := match idc in ident.ident t return lazy_abstract_domain t with + | ident.Literal _ _ as idc + | ident.nil _ as idc + | ident.cons _ as idc + | ident.pair _ _ as idc + => thunk_abstract_domain (abstract_interp_ident _ idc) + | ident.Z_cast _ as idc + | ident.Z_cast2 _ as idc + => (* fast-path for cast: don't bother with the abstract state of the argument *) + fun _ 'tt => abstract_interp_ident _ idc (bottom' _) + | _ => thunk_abstract_domain bottom + end. + + Definition extract {t} (e : @expr _ t) (bound : type.for_each_lhs_of_arrow abstract_domain t) : abstract_domain' (type.final_codomain t) + := @extract_gen base.type ident abstract_domain' (@ident_extract) t e bound. + End extract. + End with_var. + End ident. + + Section specialized. + Local Notation abstract_domain' := ZRange.type.base.option.interp. + Local Notation abstract_domain := (@partial.abstract_domain base.type abstract_domain'). + Notation expr := (@expr base.type ident). + Notation Expr := (@expr.Expr base.type ident). + Local Notation type := (type base.type). + Let type_base (x : base.type) : type := type.base x. + Local Coercion type_base : base.type >-> type. + Definition annotate_ident t : abstract_domain' t -> option (ident (t -> t)) + := match t return abstract_domain' t -> option (ident (t -> t)) with + | base.type.Z + => fun st => st' <- st; Some (ident.Z_cast st') + | base.type.Z * base.type.Z + => fun '(sta, stb) => sta' <- sta; stb' <- stb; Some (ident.Z_cast2 (sta', stb')) + | _ => fun _ => None + end%option%etype. + Definition is_annotation t (idc : ident t) : bool + := match idc with + | ident.Z_cast _ + | ident.Z_cast2 _ + => true + | _ => false + end. + Definition bottom' T : abstract_domain' T + := ZRange.type.base.option.None. + Definition abstract_interp_ident t (idc : ident t) : type.interp abstract_domain' t + := ZRange.ident.option.interp idc. + Definition update_Z_literal_with_state : abstract_domain' base.type.Z -> Z -> Z + := fun r n + => match r with + | Some r => if ZRange.type.base.is_bounded_by (t:=base.type.Z) r n + then n + else ident.cast_outside_of_range r n + | None => n + end. + Definition update_literal_with_state (t : base.type.base) : abstract_domain' t -> base.interp t -> base.interp t + := match t with + | base.type.Z => update_Z_literal_with_state + | base.type.unit + | base.type.bool + | base.type.nat + => fun _ => id + end. + Definition extract_list_state A (st : abstract_domain' (base.type.list A)) : option (list (abstract_domain' A)) + := st. + + Definition eval {var} {t} (e : @expr _ t) : expr t + := (@partial.ident.eval) + var abstract_domain' annotate_ident bottom' abstract_interp_ident update_literal_with_state extract_list_state is_annotation t e. + Definition eval_with_bound {var} {t} (e : @expr _ t) (bound : type.for_each_lhs_of_arrow abstract_domain t) : expr t + := (@partial.ident.eval_with_bound) + var abstract_domain' annotate_ident bottom' abstract_interp_ident update_literal_with_state extract_list_state is_annotation t e bound. + Definition eta_expand_with_bound {var} {t} (e : @expr _ t) (bound : type.for_each_lhs_of_arrow abstract_domain t) : expr t + := (@partial.ident.eta_expand_with_bound) + var abstract_domain' annotate_ident bottom' abstract_interp_ident update_literal_with_state extract_list_state is_annotation t e bound. + Definition Eval {t} (e : Expr t) : Expr t + := fun var => eval (e _). + Definition EvalWithBound {t} (e : Expr t) (bound : type.for_each_lhs_of_arrow abstract_domain t) : Expr t + := fun var => eval_with_bound (e _) bound. + Definition EtaExpandWithBound {t} (e : Expr t) (bound : type.for_each_lhs_of_arrow abstract_domain t) : Expr t + := fun var => eta_expand_with_bound (e _) bound. + Definition EtaExpandWithListInfoFromBound {t} (e : Expr t) (bound : type.for_each_lhs_of_arrow abstract_domain t) : Expr t + := EtaExpandWithBound e (type.map_for_each_lhs_of_arrow (@ZRange.type.option.strip_ranges) bound). + Definition extract {t} (e : expr t) (bound : type.for_each_lhs_of_arrow abstract_domain t) : abstract_domain' (type.final_codomain t) + := @partial.ident.extract abstract_domain' bottom' abstract_interp_ident t e bound. + Definition Extract {t} (e : Expr t) (bound : type.for_each_lhs_of_arrow abstract_domain t) : abstract_domain' (type.final_codomain t) + := @partial.ident.extract abstract_domain' bottom' abstract_interp_ident t (e _) bound. + End specialized. + End partial. + + Import defaults. + + Module RelaxZRange. + Module ident. + Section relax. + Context (relax_zrange : zrange -> option zrange). + + Definition relax {t} (idc : ident t) : option (ident t) + := match idc in ident.ident t return option (ident t) with + | ident.Z_cast range + => (r <- relax_zrange range; + Some (ident.Z_cast r)) + | ident.Z_cast2 (r1, r2) + => (r1 <- relax_zrange r1; + r2 <- relax_zrange r2; + Some (ident.Z_cast2 (r1, r2))) + | _ => None + end%option. + End relax. + End ident. + + Module expr. + Section relax. + Context (relax_zrange : zrange -> option zrange). + Section with_var. + Context {var : type -> Type}. + + Fixpoint relax {t} (e : @expr var t) : @expr var t + := match e with + | expr.Var _ _ as e + | expr.Ident _ _ as e + => e + | expr.Abs s d f => expr.Abs (fun v => @relax d (f v)) + | expr.LetIn tx tC ex eC => expr.LetIn (@relax tx ex) (fun v => @relax tC (eC v)) + | expr.App s d f x + => let f' := @relax _ f in + let x' := @relax _ x in + match s, d return expr (s -> d) -> expr s -> expr d with + | type.base base.type.Z, type.base base.type.Z + | type.base (base.type.Z * base.type.Z)%etype, type.base (base.type.Z * base.type.Z)%etype + => fun f x + => match option_map (ident.relax relax_zrange) + (invert_Ident f) with + | Some (Some idc) => expr.App (expr.Ident idc) x + | _ => expr.App f x + end + | _, _ => expr.App + end f' x' + end. + End with_var. + + Definition Relax {t} (e : Expr t) : Expr t + := fun var => relax (e _). + End relax. + End expr. + End RelaxZRange. + + Definition PartialEvaluateWithBounds {t} (e : Expr t) + (bound : type.for_each_lhs_of_arrow ZRange.type.option.interp t) + : Expr t + := partial.EvalWithBound e bound. + Definition PartialEvaluateWithListInfoFromBounds {t} (e : Expr t) + (bound : type.for_each_lhs_of_arrow ZRange.type.option.interp t) + : Expr t + := partial.EtaExpandWithListInfoFromBound e bound. + + Definition CheckPartialEvaluateWithBounds + (relax_zrange : zrange -> option zrange) + {t} (E : Expr t) + (b_in : type.for_each_lhs_of_arrow ZRange.type.option.interp t) + (b_out : ZRange.type.base.option.interp (type.final_codomain t)) + : Expr t + (ZRange.type.base.option.interp (type.final_codomain t) * Expr t) + := let b_computed := partial.Extract E b_in in + if ZRange.type.base.option.is_tighter_than b_computed b_out + then @inl (Expr t) _ (RelaxZRange.expr.Relax relax_zrange E) + else @inr _ (ZRange.type.base.option.interp (type.final_codomain t) * Expr t) (b_computed, E). + + Definition CheckedPartialEvaluateWithBounds + (relax_zrange : zrange -> option zrange) + {t} (E : Expr t) + (b_in : type.for_each_lhs_of_arrow ZRange.type.option.interp t) + (b_out : ZRange.type.base.option.interp (type.final_codomain t)) + : Expr t + (ZRange.type.base.option.interp (type.final_codomain t) * Expr t) + := let E := PartialEvaluateWithBounds E b_in in + dlet_nd e := GeneralizeVar.ToFlat E in + let E := GeneralizeVar.FromFlat e in + CheckPartialEvaluateWithBounds relax_zrange E b_in b_out. +End Compilers. diff --git a/src/Experiments/NewPipeline/AbstractInterpretationProofs.v b/src/Experiments/NewPipeline/AbstractInterpretationProofs.v new file mode 100644 index 000000000..560f89199 --- /dev/null +++ b/src/Experiments/NewPipeline/AbstractInterpretationProofs.v @@ -0,0 +1,43 @@ +Require Import Crypto.Util.ZRange. +Require Import Crypto.Util.Sum. +Require Import Crypto.Util.LetIn. +Require Import Crypto.Util.Tactics.BreakMatch. +Require Import Crypto.Experiments.NewPipeline.Language. +Require Import Crypto.Experiments.NewPipeline.AbstractInterpretation. +Local Open Scope Z_scope. + +Module Compilers. + Export Language.Compilers. + Export UnderLets.Compilers. + Export AbstractInterpretation.Compilers. + Import invert_expr. + Import defaults. + + Axiom admit_pf : False. + Local Notation admit := (match admit_pf with end). + + Theorem CheckedPartialEvaluateWithBounds_Correct + (relax_zrange : zrange -> option zrange) + (Hrelax : forall r r' z, is_tighter_than_bool z r = true + -> relax_zrange r = Some r' + -> is_tighter_than_bool z r' = true) + {t} (E : Expr t) + (b_in : type.for_each_lhs_of_arrow ZRange.type.option.interp t) + (b_out : ZRange.type.base.option.interp (type.final_codomain t)) + rv (Hrv : CheckedPartialEvaluateWithBounds relax_zrange E b_in b_out = inl rv) + : forall arg + (Harg : type.andb_bool_for_each_lhs_of_arrow (@ZRange.type.option.is_bounded_by) b_in arg = true), + ZRange.type.base.option.is_bounded_by b_out (type.app_curried (Interp rv) arg) = true + /\ forall cast_outside_of_range, type.app_curried (expr.Interp (@ident.gen_interp cast_outside_of_range) rv) arg + = type.app_curried (Interp E) arg. + Proof. + cbv [CheckedPartialEvaluateWithBounds CheckPartialEvaluateWithBounds Let_In] in *; + break_innermost_match_hyps; inversion_sum; subst. + intros arg Harg. + split. + { eapply ZRange.type.base.option.is_tighter_than_is_bounded_by; [ eassumption | ]. + revert Harg. + exact admit. (* boundedness *) } + { exact admit. (* correctness of interp *) } + Qed. +End Compilers. diff --git a/src/Experiments/NewPipeline/Arithmetic.v b/src/Experiments/NewPipeline/Arithmetic.v new file mode 100644 index 000000000..d7fdf0306 --- /dev/null +++ b/src/Experiments/NewPipeline/Arithmetic.v @@ -0,0 +1,1962 @@ +(* Following http://adam.chlipala.net/theses/andreser.pdf chapter 3 *) +Require Import Coq.ZArith.ZArith Coq.micromega.Lia Crypto.Algebra.Nsatz. +Require Import Coq.derive.Derive. +Require Import Crypto.Util.Tactics.UniquePose Crypto.Util.Decidable. +Require Import Crypto.Util.Tuple Crypto.Util.Prod Crypto.Util.LetIn. +Require Import Crypto.Util.ListUtil Coq.Lists.List Crypto.Util.NatUtil. +Require Import QArith.QArith_base QArith.Qround Crypto.Util.QUtil. +Require Import Crypto.Algebra.Ring Crypto.Util.Decidable.Bool2Prop. +Require Import Crypto.Arithmetic.BarrettReduction.Generalized. +Require Import Crypto.Arithmetic.MontgomeryReduction.Definition. +Require Import Crypto.Arithmetic.MontgomeryReduction.Proofs. +Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo. +Require Import Crypto.Util.ZRange. +Require Import Crypto.Util.ZRange.Operations. +Require Import Crypto.Util.Tactics.RunTacticAsConstr. +Require Import Crypto.Util.Tactics.Head. +Require Import Crypto.Util.Option. +Require Import Crypto.Util.OptionList. +Require Import Crypto.Util.Sum. +Require Import Crypto.Util.ZUtil. +Require Import Crypto.Util.ZUtil.Modulo Crypto.Util.ZUtil.Div Crypto.Util.ZUtil.Hints.Core. +Require Import Crypto.Util.ZUtil.Hints.PullPush. +Require Import Crypto.Util.ZUtil.AddGetCarry Crypto.Util.ZUtil.MulSplit. +Require Import Crypto.Util.ZUtil.Tactics.LtbToLt. +Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo. +Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem. +Require Import Crypto.Util.Tactics.SpecializeBy. +Require Import Crypto.Util.Tactics.SplitInContext. +Require Import Crypto.Util.Tactics.SubstEvars. +Require Import Crypto.Util.Notations. +Require Import Crypto.Util.ZUtil.Definitions. +Require Import Crypto.Util.ZUtil.CC Crypto.Util.ZUtil.Rshi. +Require Import Crypto.Util.ZUtil.Zselect Crypto.Util.ZUtil.AddModulo. +Require Import Crypto.Util.ZUtil.AddGetCarry Crypto.Util.ZUtil.MulSplit. +Require Import Crypto.Util.ZUtil Crypto.Util.ZUtil.Hints.Core. +Require Import Crypto.Util.ZUtil.Modulo Crypto.Util.ZUtil.Div. +Require Import Crypto.Util.ZUtil.Hints.PullPush. +Require Import Crypto.Util.ZUtil.EquivModulo. +Require Import Crypto.Util.Tactics.DebugPrint. +Require Import Crypto.Util.CPSNotations. +Require Import Crypto.Util.Equality. +Import ListNotations. Local Open Scope Z_scope. + +Module Associational. + Definition eval (p:list (Z*Z)) : Z := + fold_right (fun x y => x + y) 0%Z (map (fun t => fst t * snd t) p). + + Lemma eval_nil : eval nil = 0. + Proof. trivial. Qed. + Lemma eval_cons p q : eval (p::q) = fst p * snd p + eval q. + Proof. trivial. Qed. + Lemma eval_app p q: eval (p++q) = eval p + eval q. + Proof. induction p; rewrite <-?List.app_comm_cons; + rewrite ?eval_nil, ?eval_cons; nsatz. Qed. + + Hint Rewrite eval_nil eval_cons eval_app : push_eval. + Local Ltac push := autorewrite with + push_eval push_map push_partition push_flat_map + push_fold_right push_nth_default cancel_pair. + + Lemma eval_map_mul (a x:Z) (p:list (Z*Z)) + : eval (List.map (fun t => (a*fst t, x*snd t)) p) = a*x*eval p. + Proof. induction p; push; nsatz. Qed. + Hint Rewrite eval_map_mul : push_eval. + + Definition mul (p q:list (Z*Z)) : list (Z*Z) := + flat_map (fun t => + map (fun t' => + (fst t * fst t', snd t * snd t')) + q) p. + Lemma eval_mul p q : eval (mul p q) = eval p * eval q. + Proof. induction p; cbv [mul]; push; nsatz. Qed. + Hint Rewrite eval_mul : push_eval. + + Definition negate_snd (p:list (Z*Z)) : list (Z*Z) := + map (fun cx => (fst cx, -snd cx)) p. + Lemma eval_negate_snd p : eval (negate_snd p) = - eval p. + Proof. induction p; cbv [negate_snd]; push; nsatz. Qed. + Hint Rewrite eval_negate_snd : push_eval. + + Example base10_2digit_mul (a0:Z) (a1:Z) (b0:Z) (b1:Z) : + {ab| eval ab = eval [(10,a1);(1,a0)] * eval [(10,b1);(1,b0)]}. + eexists ?[ab]. + (* Goal: eval ?ab = eval [(10,a1);(1,a0)] * eval [(10,b1);(1,b0)] *) + rewrite <-eval_mul. + (* Goal: eval ?ab = eval (mul [(10,a1);(1,a0)] [(10,b1);(1,b0)]) *) + cbv -[Z.mul eval]; cbn -[eval]. + (* Goal: eval ?ab = eval [(100,(a1*b1));(10,a1*b0);(10,a0*b1);(1,a0*b0)]%RT *) + trivial. Defined. + + Definition split (s:Z) (p:list (Z*Z)) : list (Z*Z) * list (Z*Z) + := let hi_lo := partition (fun t => fst t mod s =? 0) p in + (snd hi_lo, map (fun t => (fst t / s, snd t)) (fst hi_lo)). + Lemma eval_split s p (s_nz:s<>0) : + eval (fst (split s p)) + s * eval (snd (split s p)) = eval p. + Proof. cbv [Let_In split]; induction p; + repeat match goal with + | |- context[?a/?b] => + unique pose proof (Z_div_exact_full_2 a b ltac:(trivial) ltac:(trivial)) + | _ => progress push + | _ => progress break_match + | _ => progress nsatz end. Qed. + + Lemma reduction_rule a b s c (modulus_nz:s-c<>0) : + (a + s * b) mod (s - c) = (a + c * b) mod (s - c). + Proof. replace (a + s * b) with ((a + c*b) + b*(s-c)) by nsatz. + rewrite Z.add_mod,Z_mod_mult,Z.add_0_r,Z.mod_mod;trivial. Qed. + + Definition reduce (s:Z) (c:list _) (p:list _) : list (Z*Z) := + let lo_hi := split s p in fst lo_hi ++ mul c (snd lo_hi). + + Lemma eval_reduce s c p (s_nz:s<>0) (modulus_nz:s-eval c<>0) : + eval (reduce s c p) mod (s - eval c) = eval p mod (s - eval c). + Proof. cbv [reduce]; push. + rewrite <-reduction_rule, eval_split; trivial. Qed. + Hint Rewrite eval_reduce : push_eval. + + Definition bind_snd (p : list (Z*Z)) := + map (fun t => dlet_nd t2 := snd t in (fst t, t2)) p. + + Lemma bind_snd_correct p : bind_snd p = p. + Proof. + cbv [bind_snd]; induction p as [| [? ?] ]; + push; [|rewrite IHp]; reflexivity. + Qed. + + Lemma eval_rev p : eval (rev p) = eval p. + Proof. induction p; cbn [rev]; push; lia. Qed. + + Section Carries. + Definition carryterm (w fw:Z) (t:Z * Z) := + if (Z.eqb (fst t) w) + then dlet_nd t2 := snd t in + dlet_nd d2 := t2 / fw in + dlet_nd m2 := t2 mod fw in + [(w * fw, d2);(w,m2)] + else [t]. + + Lemma eval_carryterm w fw (t:Z * Z) (fw_nonzero:fw<>0): + eval (carryterm w fw t) = eval [t]. + Proof using Type*. + cbv [carryterm Let_In]; break_match; push; [|trivial]. + pose proof (Z.div_mod (snd t) fw fw_nonzero). + rewrite Z.eqb_eq in *. + nsatz. + Qed. Hint Rewrite eval_carryterm using auto : push_eval. + + Definition carry (w fw:Z) (p:list (Z * Z)):= + flat_map (carryterm w fw) p. + + Lemma eval_carry w fw p (fw_nonzero:fw<>0): + eval (carry w fw p) = eval p. + Proof using Type*. cbv [carry]; induction p; push; nsatz. Qed. + Hint Rewrite eval_carry using auto : push_eval. + End Carries. +End Associational. + +Module Positional. Section Positional. + Context (weight : nat -> Z) + (weight_0 : weight 0%nat = 1) + (weight_nz : forall i, weight i <> 0). + + Definition to_associational (n:nat) (xs:list Z) : list (Z*Z) + := combine (map weight (List.seq 0 n)) xs. + Definition eval n x := Associational.eval (@to_associational n x). + Lemma eval_to_associational n x : + Associational.eval (@to_associational n x) = eval n x. + Proof. trivial. Qed. + Hint Rewrite @eval_to_associational : push_eval. + Lemma eval_nil n : eval n [] = 0. + Proof. cbv [eval to_associational]. rewrite combine_nil_r. reflexivity. Qed. + Hint Rewrite eval_nil : push_eval. + Lemma eval0 p : eval 0 p = 0. + Proof. cbv [eval to_associational]. reflexivity. Qed. + Hint Rewrite eval0 : push_eval. + + Lemma eval_snoc n m x y : n = length x -> m = S n -> eval m (x ++ [y]) = eval n x + weight n * y. + Proof. + cbv [eval to_associational]; intros; subst n m. + rewrite seq_snoc, map_app. + rewrite combine_app_samelength by distr_length. + autorewrite with push_eval. simpl. + autorewrite with push_eval cancel_pair; ring. + Qed. + + (* SKIP over this: zeros, add_to_nth *) + Local Ltac push := autorewrite with push_eval push_map distr_length + push_flat_map push_fold_right push_nth_default cancel_pair natsimplify. + Definition zeros n : list Z := repeat 0 n. + Lemma length_zeros n : length (zeros n) = n. Proof. cbv [zeros]; distr_length. Qed. + Hint Rewrite length_zeros : distr_length. + Lemma eval_zeros n : eval n (zeros n) = 0. + Proof. + cbv [eval Associational.eval to_associational zeros]. + rewrite <- (seq_length n 0) at 2. + generalize dependent (List.seq 0 n); intro xs. + induction xs; simpl; nsatz. Qed. + Definition add_to_nth i x (ls : list Z) : list Z + := ListUtil.update_nth i (fun y => x + y) ls. + Lemma length_add_to_nth i x ls : length (add_to_nth i x ls) = length ls. + Proof. cbv [add_to_nth]; distr_length. Qed. + Hint Rewrite length_add_to_nth : distr_length. + Lemma eval_add_to_nth (n:nat) (i:nat) (x:Z) (xs:list Z) (H:(i<length xs)%nat) + (Hn : length xs = n) (* N.B. We really only need [i < Nat.min n (length xs)] *) : + eval n (add_to_nth i x xs) = weight i * x + eval n xs. + Proof. + subst n. + cbv [eval to_associational add_to_nth]. + rewrite ListUtil.combine_update_nth_r at 1. + rewrite <-(update_nth_id i (List.combine _ _)) at 2. + rewrite <-!(ListUtil.splice_nth_equiv_update_nth_update _ _ + (weight 0, 0)) by (push; lia); cbv [ListUtil.splice_nth id]. + repeat match goal with + | _ => progress push + | _ => progress break_match + | _ => progress (apply Zminus_eq; ring_simplify) + | _ => rewrite <-ListUtil.map_nth_default_always + end; lia. Qed. + Hint Rewrite @eval_add_to_nth eval_zeros : push_eval. + + Definition place (t:Z*Z) (i:nat) : nat * Z := + nat_rect + (fun _ => (nat * Z)%type) + (O, fst t * snd t) + (fun i' place_i' + => let i := S i' in + if (fst t mod weight i =? 0) + then (i, let c := fst t / weight i in c * snd t) + else place_i') + i. + + Lemma place_in_range (t:Z*Z) (n:nat) : (fst (place t n) < S n)%nat. + Proof. induction n; cbv [place nat_rect] in *; break_match; autorewrite with cancel_pair; try omega. Qed. + Lemma weight_place t i : weight (fst (place t i)) * snd (place t i) = fst t * snd t. + Proof. induction i; cbv [place nat_rect] in *; break_match; push; + repeat match goal with |- context[?a/?b] => + unique pose proof (Z_div_exact_full_2 a b ltac:(auto) ltac:(auto)) + end; nsatz. Qed. + Hint Rewrite weight_place : push_eval. + + Definition from_associational n (p:list (Z*Z)) := + List.fold_right (fun t ls => + dlet_nd p := place t (pred n) in + add_to_nth (fst p) (snd p) ls ) (zeros n) p. + Lemma eval_from_associational n p (n_nz:n<>O \/ p = nil) : + eval n (from_associational n p) = Associational.eval p. + Proof. destruct n_nz; [ induction p | subst p ]; + cbv [from_associational Let_In] in *; push; try + pose proof place_in_range a (pred n); try omega; try nsatz; + apply fold_right_invariant; cbv [zeros add_to_nth]; + intros; rewrite ?map_length, ?List.repeat_length, ?seq_length, ?length_update_nth; + try omega. Qed. + Hint Rewrite @eval_from_associational : push_eval. + Lemma length_from_associational n p : length (from_associational n p) = n. + Proof. cbv [from_associational Let_In]. apply fold_right_invariant; intros; distr_length. Qed. + Hint Rewrite length_from_associational : distr_length. + + Section mulmod. + Context (s:Z) (s_nz:s <> 0) + (c:list (Z*Z)) + (m_nz:s - Associational.eval c <> 0). + Definition mulmod (n:nat) (a b:list Z) : list Z + := let a_a := to_associational n a in + let b_a := to_associational n b in + let ab_a := Associational.mul a_a b_a in + let abm_a := Associational.reduce s c ab_a in + from_associational n abm_a. + Lemma eval_mulmod n (f g:list Z) + (Hf : length f = n) (Hg : length g = n) : + eval n (mulmod n f g) mod (s - Associational.eval c) + = (eval n f * eval n g) mod (s - Associational.eval c). + Proof. cbv [mulmod]; push; trivial. + destruct f, g; simpl in *; [ right; subst n | left; try omega.. ]. + clear; cbv -[Associational.reduce]. + induction c as [|?? IHc]; simpl; trivial. Qed. + End mulmod. + Hint Rewrite @eval_mulmod : push_eval. + + Definition add (n:nat) (a b:list Z) : list Z + := let a_a := to_associational n a in + let b_a := to_associational n b in + from_associational n (a_a ++ b_a). + Lemma eval_add n (f g:list Z) + (Hf : length f = n) (Hg : length g = n) : + eval n (add n f g) = (eval n f + eval n g). + Proof. cbv [add]; push; trivial. destruct n; auto. Qed. + Hint Rewrite @eval_add : push_eval. + Lemma length_add n f g + (Hf : length f = n) (Hg : length g = n) : + length (add n f g) = n. + Proof. clear -Hf Hf; cbv [add]; distr_length. Qed. + Hint Rewrite @length_add : distr_length. + + Section Carries. + Definition carry n m (index:nat) (p:list Z) : list Z := + from_associational + m (@Associational.carry (weight index) + (weight (S index) / weight index) + (to_associational n p)). + + Lemma length_carry n m index p : length (carry n m index p) = m. + Proof. cbv [carry]; distr_length. Qed. + Lemma eval_carry n m i p: (n <> 0%nat) -> (m <> 0%nat) -> + weight (S i) / weight i <> 0 -> + eval m (carry n m i p) = eval n p. + Proof. + cbv [carry]; intros; push; [|tauto]. + rewrite @Associational.eval_carry by eauto. + apply eval_to_associational. + Qed. Hint Rewrite @eval_carry : push_eval. + + Definition carry_reduce n (s:Z) (c:list (Z * Z)) + (index:nat) (p : list Z) := + from_associational + n (Associational.reduce + s c (to_associational (S n) (@carry n (S n) index p))). + + Lemma eval_carry_reduce n s c index p : + (s <> 0) -> (s - Associational.eval c <> 0) -> (n <> 0%nat) -> + (weight (S index) / weight index <> 0) -> + eval n (carry_reduce n s c index p) mod (s - Associational.eval c) + = eval n p mod (s - Associational.eval c). + Proof. cbv [carry_reduce]; intros; push; auto. Qed. + Hint Rewrite @eval_carry_reduce : push_eval. + Lemma length_carry_reduce n s c index p + : length p = n -> length (carry_reduce n s c index p) = n. + Proof. cbv [carry_reduce]; distr_length. Qed. + Hint Rewrite @length_carry_reduce : distr_length. + + (* N.B. It is important to reverse [idxs] here, because fold_right is + written such that the first terms in the list are actually used + last in the computation. For example, running: + + `Eval cbv - [Z.add] in (fun a b c d => fold_right Z.add d [a;b;c]).` + + will produce [fun a b c d => (a + (b + (c + d)))].*) + Definition chained_carries n s c p (idxs : list nat) := + fold_right (fun a b => carry_reduce n s c a b) p (rev idxs). + + Lemma eval_chained_carries n s c p idxs : + (s <> 0) -> (s - Associational.eval c <> 0) -> (n <> 0%nat) -> + (forall i, In i idxs -> weight (S i) / weight i <> 0) -> + eval n (chained_carries n s c p idxs) mod (s - Associational.eval c) + = eval n p mod (s - Associational.eval c). + Proof using Type*. + cbv [chained_carries]; intros; push. + apply fold_right_invariant; [|intro; rewrite <-in_rev]; + destruct n; intros; push; auto. + Qed. Hint Rewrite @eval_chained_carries : push_eval. + Lemma length_chained_carries n s c p idxs + : length p = n -> length (@chained_carries n s c p idxs) = n. + Proof. + intros; cbv [chained_carries]; induction (rev idxs) as [|x xs IHxs]; + cbn [fold_right]; distr_length. + Qed. Hint Rewrite @length_chained_carries : distr_length. + + (* carries without modular reduction; useful for converting between bases *) + Definition chained_carries_no_reduce n p (idxs : list nat) := + fold_right (fun a b => carry n n a b) p (rev idxs). + Lemma eval_chained_carries_no_reduce n p idxs: + (forall i, In i idxs -> weight (S i) / weight i <> 0) -> + eval n (chained_carries_no_reduce n p idxs) = eval n p. + Proof. + cbv [chained_carries_no_reduce]; intros. + destruct n; [push;reflexivity|]. + apply fold_right_invariant; [|intro; rewrite <-in_rev]; + intros; push; auto. + Qed. Hint Rewrite @eval_chained_carries_no_reduce : push_eval. + + (* Reverse of [eval]; translate from Z to basesystem by putting + everything in first digit and then carrying. *) + Definition encode n s c (x : Z) : list Z := + chained_carries n s c (from_associational n [(1,x)]) (seq 0 n). + Lemma eval_encode n s c x : + (s <> 0) -> (s - Associational.eval c <> 0) -> (n <> 0%nat) -> + (forall i, In i (seq 0 n) -> weight (S i) / weight i <> 0) -> + eval n (encode n s c x) mod (s - Associational.eval c) + = x mod (s - Associational.eval c). + Proof using Type*. cbv [encode]; intros; push; auto; f_equal; omega. Qed. + Lemma length_encode n s c x + : length (encode n s c x) = n. + Proof. cbv [encode]; repeat distr_length. Qed. + + End Carries. + Hint Rewrite @eval_encode : push_eval. + Hint Rewrite @length_encode : distr_length. + + Section sub. + Context (n:nat) + (s:Z) (s_nz:s <> 0) + (c:list (Z * Z)) + (m_nz:s - Associational.eval c <> 0) + (coef:Z). + + Definition negate_snd (a:list Z) : list Z + := let A := to_associational n a in + let negA := Associational.negate_snd A in + from_associational n negA. + + Definition scmul (x:Z) (a:list Z) : list Z + := let A := to_associational n a in + let R := Associational.mul A [(1, x)] in + from_associational n R. + + Definition balance : list Z + := scmul coef (encode n s c (s - Associational.eval c)). + + Definition sub (a b:list Z) : list Z + := let ca := add n balance a in + let _b := negate_snd b in + add n ca _b. + Lemma eval_sub a b + : (forall i, In i (seq 0 n) -> weight (S i) / weight i <> 0) -> + (List.length a = n) -> (List.length b = n) -> + eval n (sub a b) mod (s - Associational.eval c) + = (eval n a - eval n b) mod (s - Associational.eval c). + Proof. + destruct (zerop n); subst; try reflexivity. + intros; cbv [sub balance scmul negate_snd]; push; repeat distr_length; + eauto with omega. + push_Zmod; push; pull_Zmod; push_Zmod; pull_Zmod; distr_length; eauto. + Qed. + Hint Rewrite eval_sub : push_eval. + Lemma length_sub a b + : length a = n -> length b = n -> + length (sub a b) = n. + Proof. intros; cbv [sub balance scmul negate_snd]; repeat distr_length. Qed. + Hint Rewrite length_sub : distr_length. + Definition opp (a:list Z) : list Z + := sub (zeros n) a. + Lemma eval_opp + (a:list Z) + : (length a = n) -> + (forall i, In i (seq 0 n) -> weight (S i) / weight i <> 0) -> + eval n (opp a) mod (s - Associational.eval c) + = (- eval n a) mod (s - Associational.eval c). + Proof. intros; cbv [opp]; push; distr_length; auto. Qed. + Lemma length_opp a + : length a = n -> length (opp a) = n. + Proof. cbv [opp]; intros; repeat distr_length. Qed. + End sub. + Hint Rewrite @eval_opp @eval_sub : push_eval. + Hint Rewrite @length_sub @length_opp : distr_length. +End Positional. +(* Hint Rewrite disappears after the end of a section *) +Hint Rewrite length_zeros length_add_to_nth length_from_associational @length_add @length_carry_reduce @length_chained_carries @length_encode @length_sub @length_opp : distr_length. +End Positional. + +Record weight_properties {weight : nat -> Z} := + { + weight_0 : weight 0%nat = 1; + weight_positive : forall i, 0 < weight i; + weight_multiples : forall i, weight (S i) mod weight i = 0; + weight_divides : forall i : nat, 0 < weight (S i) / weight i; + }. +Hint Resolve weight_0 weight_positive weight_multiples weight_divides. + +Section mod_ops. + Import Positional. + Local Coercion Z.of_nat : nat >-> Z. + Local Coercion QArith_base.inject_Z : Z >-> Q. + (* Design constraints: + - inputs must be [Z] (b/c reification does not support Q) + - internal structure must not match on the arguments (b/c reification does not support [positive]) *) + Context (limbwidth_num limbwidth_den : Z) + (limbwidth_good : 0 < limbwidth_den <= limbwidth_num) + (s : Z) + (c : list (Z*Z)) + (n : nat) + (len_c : nat) + (idxs : list nat) + (len_idxs : nat) + (m_nz:s - Associational.eval c <> 0) (s_nz:s <> 0) + (Hn_nz : n <> 0%nat) + (Hc : length c = len_c) + (Hidxs : length idxs = len_idxs). + Definition weight (i : nat) + := 2^(-(-(limbwidth_num * i) / limbwidth_den)). + + Local Ltac Q_cbv := + cbv [Qceiling inject_Z Qle Qfloor Qdiv Qnum Qden Qmult Qinv Qopp]. + + Local Lemma weight_ZQ_correct i + (limbwidth := (limbwidth_num / limbwidth_den)%Q) + : weight i = 2^Qceiling(limbwidth*i). + Proof. + clear -limbwidth_good. + cbv [limbwidth weight]; Q_cbv. + destruct limbwidth_num, limbwidth_den, i; try reflexivity; + repeat rewrite ?Pos.mul_1_l, ?Pos.mul_1_r, ?Z.mul_0_l, ?Zdiv_0_l, ?Zdiv_0_r, ?Z.mul_1_l, ?Z.mul_1_r, <- ?Z.opp_eq_mul_m1, ?Pos2Z.opp_pos; + try reflexivity; try lia. + Qed. + + Local Ltac t_weight_with lem := + clear -limbwidth_good; + intros; rewrite !weight_ZQ_correct; + apply lem; + try omega; Q_cbv; destruct limbwidth_den; cbn; try lia. + + Definition wprops : @weight_properties weight. + Proof. + constructor. + { cbv [weight Z.of_nat]; autorewrite with zsimplify_fast; reflexivity. } + { intros; apply Z.gt_lt. t_weight_with (@pow_ceil_mul_nat_pos 2). } + { t_weight_with (@pow_ceil_mul_nat_multiples 2). } + { intros; apply Z.gt_lt. t_weight_with (@pow_ceil_mul_nat_divide 2). } + Defined. + Local Hint Immediate (weight_0 wprops). + Local Hint Immediate (weight_positive wprops). + Local Hint Immediate (weight_multiples wprops). + Local Hint Immediate (weight_divides wprops). + Local Hint Resolve Z.positive_is_nonzero Z.lt_gt. + + Local Lemma weight_1_gt_1 : weight 1 > 1. + Proof. + clear -limbwidth_good. + cut (1 < weight 1); [ lia | ]. + cbv [weight Z.of_nat]; autorewrite with zsimplify_fast. + apply Z.pow_gt_1; [ omega | ]. + Z.div_mod_to_quot_rem; nia. + Qed. + + Derive carry_mulmod + SuchThat (forall (f g : list Z) + (Hf : length f = n) + (Hg : length g = n), + (eval weight n (carry_mulmod f g)) mod (s - Associational.eval c) + = (eval weight n f * eval weight n g) mod (s - Associational.eval c)) + As eval_carry_mulmod. + Proof. + intros. + rewrite <-eval_mulmod with (s:=s) (c:=c) by auto. + etransitivity; + [ | rewrite <- @eval_chained_carries with (s:=s) (c:=c) (idxs:=idxs) + by auto; reflexivity ]. + eapply f_equal2; [|trivial]. eapply f_equal. + subst carry_mulmod; reflexivity. + Qed. + + Derive carrymod + SuchThat (forall (f : list Z) + (Hf : length f = n), + (eval weight n (carrymod f)) mod (s - Associational.eval c) + = (eval weight n f) mod (s - Associational.eval c)) + As eval_carrymod. + Proof. + intros. + etransitivity; + [ | rewrite <- @eval_chained_carries with (s:=s) (c:=c) (idxs:=idxs) + by auto; reflexivity ]. + eapply f_equal2; [|trivial]. eapply f_equal. + subst carrymod; reflexivity. + Qed. + + Derive addmod + SuchThat (forall (f g : list Z) + (Hf : length f = n) + (Hg : length g = n), + (eval weight n (addmod f g)) mod (s - Associational.eval c) + = (eval weight n f + eval weight n g) mod (s - Associational.eval c)) + As eval_addmod. + Proof. + intros. + rewrite <-eval_add by auto. + eapply f_equal2; [|trivial]. eapply f_equal. + subst addmod; reflexivity. + Qed. + + Derive submod + SuchThat (forall (coef:Z) + (f g : list Z) + (Hf : length f = n) + (Hg : length g = n), + (eval weight n (submod coef f g)) mod (s - Associational.eval c) + = (eval weight n f - eval weight n g) mod (s - Associational.eval c)) + As eval_submod. + Proof. + intros. + rewrite <-eval_sub with (coef:=coef) by auto. + eapply f_equal2; [|trivial]. eapply f_equal. + subst submod; reflexivity. + Qed. + + Derive oppmod + SuchThat (forall (coef:Z) + (f: list Z) + (Hf : length f = n), + (eval weight n (oppmod coef f)) mod (s - Associational.eval c) + = (- eval weight n f) mod (s - Associational.eval c)) + As eval_oppmod. + Proof. + intros. + rewrite <-eval_opp with (coef:=coef) by auto. + eapply f_equal2; [|trivial]. eapply f_equal. + subst oppmod; reflexivity. + Qed. + + Derive encodemod + SuchThat (forall (f:Z), + (eval weight n (encodemod f)) mod (s - Associational.eval c) + = f mod (s - Associational.eval c)) + As eval_encodemod. + Proof. + intros. + etransitivity. + 2:rewrite <-@eval_encode with (weight:=weight) (n:=n) by auto; reflexivity. + eapply f_equal2; [|trivial]. eapply f_equal. + subst encodemod; reflexivity. + Qed. +End mod_ops. + +Module Saturated. + Hint Resolve weight_positive weight_0 weight_multiples weight_divides. + Hint Resolve Z.positive_is_nonzero Z.lt_gt Nat2Z.is_nonneg. + + Section Weight. + Context weight {wprops : @weight_properties weight}. + + Lemma weight_multiples_full' j : forall i, weight (i+j) mod weight i = 0. + Proof. + induction j; intros; + repeat match goal with + | _ => rewrite Nat.add_succ_r + | _ => rewrite IHj + | |- context [weight (S ?x) mod weight _] => + rewrite (Z.div_mod (weight (S x)) (weight x)), weight_multiples by auto + | _ => progress autorewrite with push_Zmod natsimplify zsimplify_fast + | _ => reflexivity + end. + Qed. + + Lemma weight_multiples_full j i : (i <= j)%nat -> weight j mod weight i = 0. + Proof. + intros; replace j with (i + (j - i))%nat by omega. + apply weight_multiples_full'. + Qed. + + Lemma weight_divides_full j i : (i <= j)%nat -> 0 < weight j / weight i. + Proof. auto using Z.gt_lt, Z.div_positive_gt_0, weight_multiples_full. Qed. + + Lemma weight_div_mod j i : (i <= j)%nat -> weight j = weight i * (weight j / weight i). + Proof. intros. apply Z.div_exact; auto using weight_multiples_full. Qed. + End Weight. + + Module Associational. + Section Associational. + + Definition sat_multerm s (t t' : (Z * Z)) : list (Z * Z) := + dlet_nd xy := Z.mul_split s (snd t) (snd t') in + [(fst t * fst t', fst xy); (fst t * fst t' * s, snd xy)]. + + Definition sat_mul s (p q : list (Z * Z)) : list (Z * Z) := + flat_map (fun t => flat_map (fun t' => sat_multerm s t t') q) p. + + Lemma eval_map_sat_multerm s a q (s_nonzero:s<>0): + Associational.eval (flat_map (sat_multerm s a) q) = fst a * snd a * Associational.eval q. + Proof. + cbv [sat_multerm Let_In]; induction q; + repeat match goal with + | _ => progress autorewrite with cancel_pair push_eval to_div_mod in * + | _ => progress simpl flat_map + | _ => rewrite IHq + | _ => rewrite Z.mod_eq by assumption + | _ => ring_simplify; omega + end. + Qed. + Hint Rewrite eval_map_sat_multerm using (omega || assumption) : push_eval. + + Lemma eval_sat_mul s p q (s_nonzero:s<>0): + Associational.eval (sat_mul s p q) = Associational.eval p * Associational.eval q. + Proof. + cbv [sat_mul]; induction p; [reflexivity|]. + repeat match goal with + | _ => progress (autorewrite with push_flat_map push_eval in * ) + | _ => rewrite IHp + | _ => ring_simplify; omega + end. + Qed. + Hint Rewrite eval_sat_mul : push_eval. + + Definition sat_multerm_const s (t t' : (Z * Z)) : list (Z * Z) := + if snd t =? 1 + then [(fst t * fst t', snd t')] + else if snd t =? -1 + then [(fst t * fst t', - snd t')] + else if snd t =? 0 + then nil + else dlet_nd xy := Z.mul_split s (snd t) (snd t') in + [(fst t * fst t', fst xy); (fst t * fst t' * s, snd xy)]. + + Definition sat_mul_const s (p q : list (Z * Z)) : list (Z * Z) := + flat_map (fun t => flat_map (fun t' => sat_multerm_const s t t') q) p. + + Lemma eval_map_sat_multerm_const s a q (s_nonzero:s<>0): + Associational.eval (flat_map (sat_multerm_const s a) q) = fst a * snd a * Associational.eval q. + Proof. + cbv [sat_multerm_const Let_In]; induction q; + repeat match goal with + | _ => progress autorewrite with cancel_pair push_eval to_div_mod in * + | _ => progress simpl flat_map + | H : _ = 1 |- _ => rewrite H + | H : _ = -1 |- _ => rewrite H + | H : _ = 0 |- _ => rewrite H + | _ => progress break_match; Z.ltb_to_lt + | _ => rewrite IHq + | _ => rewrite Z.mod_eq by assumption + | _ => ring_simplify; omega + end. + Qed. + Hint Rewrite eval_map_sat_multerm_const using (omega || assumption) : push_eval. + + Lemma eval_sat_mul_const s p q (s_nonzero:s<>0): + Associational.eval (sat_mul_const s p q) = Associational.eval p * Associational.eval q. + Proof. + cbv [sat_mul_const]; induction p; [reflexivity|]. + repeat match goal with + | _ => progress (autorewrite with push_flat_map push_eval in * ) + | _ => rewrite IHp + | _ => ring_simplify; omega + end. + Qed. + Hint Rewrite eval_sat_mul_const : push_eval. + End Associational. + End Associational. + + Section DivMod. + Lemma mod_step a b c d: 0 < a -> 0 < b -> + c mod a + a * ((c / a + d) mod b) = (a * d + c) mod (a * b). + Proof. + intros; rewrite Z.rem_mul_r by omega. push_Zmod. + autorewrite with zsimplify pull_Zmod. repeat (f_equal; try ring). + Qed. + + Lemma div_step a b c d : 0 < a -> 0 < b -> + (c / a + d) / b = (a * d + c) / (a * b). + Proof. intros; Z.div_mod_to_quot_rem; nia. Qed. + + Lemma add_mod_div_multiple a b n m: + n > 0 -> + 0 <= m / n -> + m mod n = 0 -> + (a / n + b) mod (m / n) = (a + n * b) mod m / n. + Proof. + intros. rewrite <-!Z.div_add' by auto using Z.positive_is_nonzero. + rewrite Z.mod_pull_div, Z.mul_div_eq' by auto using Z.gt_lt. + repeat (f_equal; try omega). + Qed. + + Lemma add_mod_l_multiple a b n m: + 0 < n / m -> m <> 0 -> n mod m = 0 -> + (a mod n + b) mod m = (a + b) mod m. + Proof. + intros. + rewrite (proj2 (Z.div_exact n m ltac:(auto))) by auto. + rewrite Z.rem_mul_r by auto. + push_Zmod. autorewrite with zsimplify. + pull_Zmod. reflexivity. + Qed. + + Definition is_div_mod {T} (evalf : T -> Z) dm y n := + evalf (fst dm) = y mod n /\ snd dm = y / n. + + Lemma is_div_mod_step {T} evalf1 evalf2 dm1 dm2 y1 y2 n1 n2 x : + n1 > 0 -> + 0 < n2 / n1 -> + n2 mod n1 = 0 -> + evalf2 (fst dm2) = evalf1 (fst dm1) + n1 * ((snd dm1 + x) mod (n2 / n1)) -> + snd dm2 = (snd dm1 + x) / (n2 / n1) -> + y2 = y1 + n1 * x -> + @is_div_mod T evalf1 dm1 y1 n1 -> + @is_div_mod T evalf2 dm2 y2 n2. + Proof. + intros; subst y2; cbv [is_div_mod] in *. + repeat match goal with + | H: _ /\ _ |- _ => destruct H + | H: ?LHS = _ |- _ => match LHS with context [dm2] => rewrite H end + | H: ?LHS = _ |- _ => match LHS with context [dm1] => rewrite H end + | _ => rewrite mod_step by omega + | _ => rewrite div_step by omega + | _ => rewrite Z.mul_div_eq_full by omega + end. + split; f_equal; omega. + Qed. + + Lemma is_div_mod_result_equal {T} evalf dm y1 y2 n : + y1 = y2 -> + @is_div_mod T evalf dm y1 n -> + @is_div_mod T evalf dm y2 n. + Proof. congruence. Qed. + End DivMod. +End Saturated. + +Module Columns. + Import Saturated. + Section Columns. + Context weight {wprops : @weight_properties weight}. + + Definition eval n (x : list (list Z)) : Z := Positional.eval weight n (map sum x). + + Lemma eval_nil n : eval n [] = 0. + Proof. cbv [eval]; simpl. apply Positional.eval_nil. Qed. + Hint Rewrite eval_nil : push_eval. + Lemma eval_snoc n x y : n = length x -> eval (S n) (x ++ [y]) = eval n x + weight n * sum y. + Proof. + cbv [eval]; intros; subst. rewrite map_app. simpl map. + apply Positional.eval_snoc; distr_length. + Qed. Hint Rewrite eval_snoc using (solve [distr_length]) : push_eval. + + Hint Rewrite <- Z.div_add' using omega : pull_Zdiv. + + Ltac cases := + match goal with + | |- _ /\ _ => split + | H: _ /\ _ |- _ => destruct H + | H: _ \/ _ |- _ => destruct H + | _ => progress break_match; try discriminate + end. + + Section Flatten. + Section flatten_column. + Context (fw : Z). (* maximum size of the result *) + + (* Outputs (sum, carry) *) + Definition flatten_column (digit: list Z) : (Z * Z) := + list_rect (fun _ => (Z * Z)%type) (0,0) + (fun xx tl flatten_column_tl => + list_rect + (fun _ => (Z * Z)%type) (xx mod fw, xx / fw) + (fun yy tl' _ => + list_rect + (fun _ => (Z * Z)%type) (dlet_nd x := xx in dlet_nd y := yy in Z.add_get_carry_full fw x y) + (fun _ _ _ => + dlet_nd x := xx in + dlet_nd rec := flatten_column_tl in (* recursively get the sum and carry *) + dlet_nd sum_carry := Z.add_get_carry_full fw x (fst rec) in (* add the new value to the sum *) + dlet_nd carry' := snd sum_carry + snd rec in (* add the two carries together *) + (fst sum_carry, carry')) + tl') + tl) + digit. + End flatten_column. + + Definition flatten_step (digit:list Z) (acc_carry:list Z * Z) : list Z * Z := + dlet sum_carry := flatten_column (weight (S (length (fst acc_carry))) / weight (length (fst acc_carry))) (snd acc_carry::digit) in + (fst acc_carry ++ fst sum_carry :: nil, snd sum_carry). + + Definition flatten (xs : list (list Z)) : list Z * Z := + fold_right (fun a b => flatten_step a b) (nil,0) (rev xs). + + Ltac push_fast := + repeat match goal with + | _ => progress cbv [Let_In] + | |- context [list_rect _ _ _ ?ls] => rewrite single_list_rect_to_match; destruct ls + | _ => progress (unfold flatten_step in *; fold flatten_step in * ) + | _ => rewrite Nat.add_1_r + | _ => rewrite Z.mul_div_eq_full by (auto; omega) + | _ => rewrite weight_multiples + | _ => reflexivity + | _ => solve [repeat (f_equal; try ring)] + | _ => congruence + | _ => progress cases + end. + Ltac push := + repeat match goal with + | _ => progress push_fast + | _ => progress autorewrite with cancel_pair to_div_mod + | _ => progress autorewrite with push_sum push_fold_right push_nth_default in * + | _ => progress autorewrite with pull_Zmod pull_Zdiv zsimplify_fast + | _ => progress autorewrite with list distr_length push_eval + end. + + Lemma flatten_column_mod fw (xs : list Z) : + fst (flatten_column fw xs) = sum xs mod fw. + Proof. + induction xs; simpl flatten_column; cbv [Let_In]; + repeat match goal with + | _ => rewrite IHxs + | _ => progress push + end. + Qed. Hint Rewrite flatten_column_mod : to_div_mod. + + Lemma flatten_column_div fw (xs : list Z) (fw_nz : fw <> 0) : + snd (flatten_column fw xs) = sum xs / fw. + Proof. + induction xs; simpl flatten_column; cbv [Let_In]; + repeat match goal with + | _ => rewrite IHxs + | _ => rewrite Z.mul_div_eq_full by omega + | _ => progress push + end. + Qed. Hint Rewrite flatten_column_div using auto with zarith : to_div_mod. + + Hint Rewrite Positional.eval_nil : push_eval. + Hint Resolve Z.gt_lt. + + Lemma length_flatten_step digit state : + length (fst (flatten_step digit state)) = S (length (fst state)). + Proof. cbv [flatten_step]; push. Qed. + Hint Rewrite length_flatten_step : distr_length. + Lemma length_flatten inp : length (fst (flatten inp)) = length inp. + Proof. cbv [flatten]. induction inp using rev_ind; push. Qed. + Hint Rewrite length_flatten : distr_length. + + Lemma flatten_div_mod n inp : + length inp = n -> + (Positional.eval weight n (fst (flatten inp)) + = (eval n inp) mod (weight n)) + /\ (snd (flatten inp) = eval n inp / weight n). + Proof. + (* to make the invariant take the right form, we make everything depend on output length, not input length *) + intro. subst n. rewrite <-(length_flatten inp). cbv [flatten]. + induction inp using rev_ind; intros; [push|]. + repeat match goal with + | _ => rewrite Nat.add_1_r + | _ => progress (fold (flatten inp) in * ) + | _ => erewrite Positional.eval_snoc by (distr_length; reflexivity) + | H: _ = _ mod (weight _) |- _ => rewrite H + | H: _ = _ / (weight _) |- _ => rewrite H + | _ => progress rewrite ?mod_step, ?div_step by auto + | _ => progress autorewrite with cancel_pair to_div_mod push_sum list push_fold_right push_eval + | _ => progress (distr_length; push_fast) + end. + Qed. + + Lemma flatten_mod {n} inp : + length inp = n -> + (Positional.eval weight n (fst (flatten inp)) = (eval n inp) mod (weight n)). + Proof. apply flatten_div_mod. Qed. + Hint Rewrite @flatten_mod : push_eval. + + Lemma flatten_div {n} inp : + length inp = n -> snd (flatten inp) = eval n inp / weight n. + Proof. apply flatten_div_mod. Qed. + Hint Rewrite @flatten_div : push_eval. + + Lemma flatten_snoc x inp : flatten (inp ++ [x]) = flatten_step x (flatten inp). + Proof. cbv [flatten]. rewrite rev_unit. reflexivity. Qed. + + Lemma flatten_partitions inp: + forall n i, length inp = n -> (i < n)%nat -> + nth_default 0 (fst (flatten inp)) i = ((eval n inp) mod (weight (S i))) / weight i. + Proof. + induction inp using rev_ind; intros; destruct n; distr_length. + rewrite flatten_snoc. + push; distr_length; + [rewrite IHinp with (n:=n) by omega; rewrite weight_div_mod with (j:=n) (i:=S i) by (eauto; omega); push_Zmod; push |]. + repeat match goal with + | _ => progress replace (length inp) with n by omega + | _ => progress replace i with n by omega + | _ => progress push + | _ => erewrite flatten_div by eauto + | _ => rewrite <-Z.div_add' by auto + | _ => rewrite Z.mul_div_eq' by auto + | _ => rewrite Z.mod_pull_div by auto using Z.lt_le_incl + | _ => progress autorewrite with push_nth_default natsimplify + end. + Qed. + End Flatten. + + Section FromAssociational. + (* nils *) + Definition nils n : list (list Z) := repeat nil n. + Lemma length_nils n : length (nils n) = n. Proof. cbv [nils]. distr_length. Qed. + Hint Rewrite length_nils : distr_length. + Lemma eval_nils n : eval n (nils n) = 0. + Proof. + erewrite <-Positional.eval_zeros by eauto. + cbv [eval nils]; rewrite List.map_repeat; reflexivity. + Qed. Hint Rewrite eval_nils : push_eval. + + (* cons_to_nth *) + Definition cons_to_nth i x (xs : list (list Z)) : list (list Z) := + ListUtil.update_nth i (fun y => cons x y) xs. + Lemma length_cons_to_nth i x xs : length (cons_to_nth i x xs) = length xs. + Proof. cbv [cons_to_nth]. distr_length. Qed. + Hint Rewrite length_cons_to_nth : distr_length. + Lemma cons_to_nth_add_to_nth xs : forall i x, + map sum (cons_to_nth i x xs) = Positional.add_to_nth i x (map sum xs). + Proof. + cbv [cons_to_nth]; induction xs as [|? ? IHxs]; + intros i x; destruct i; simpl; rewrite ?IHxs; reflexivity. + Qed. + Lemma eval_cons_to_nth n i x xs : (i < length xs)%nat -> length xs = n -> + eval n (cons_to_nth i x xs) = weight i * x + eval n xs. + Proof using Type. + cbv [eval]; intros. rewrite cons_to_nth_add_to_nth. + apply Positional.eval_add_to_nth; distr_length. + Qed. Hint Rewrite eval_cons_to_nth using (solve [distr_length]) : push_eval. + + Hint Rewrite Positional.eval_zeros : push_eval. + Hint Rewrite Positional.length_from_associational : distr_length. + Hint Rewrite Positional.eval_add_to_nth using (solve [distr_length]): push_eval. + + (* from_associational *) + Definition from_associational n (p:list (Z*Z)) : list (list Z) := + List.fold_right (fun t ls => + dlet_nd p := Positional.place weight t (pred n) in + cons_to_nth (fst p) (snd p) ls ) (nils n) p. + Lemma length_from_associational n p : length (from_associational n p) = n. + Proof. cbv [from_associational Let_In]. apply fold_right_invariant; intros; distr_length. Qed. + Hint Rewrite length_from_associational: distr_length. + Lemma eval_from_associational n p (n_nonzero:n<>0%nat\/p=nil): + eval n (from_associational n p) = Associational.eval p. + Proof. + erewrite <-Positional.eval_from_associational by eauto. + induction p; [ autorewrite with push_eval; solve [auto] |]. + cbv [from_associational Positional.from_associational]; autorewrite with push_fold_right. + fold (from_associational n p); fold (Positional.from_associational weight n p). + cbv [Let_In]. + match goal with |- context [Positional.place _ ?x ?n] => + pose proof (Positional.place_in_range weight x n) end. + repeat match goal with + | _ => rewrite Nat.succ_pred in * by auto + | _ => rewrite IHp by auto + | _ => progress autorewrite with push_eval + | _ => progress cases + | _ => congruence + end. + Qed. + + Lemma from_associational_step n t p : + from_associational n (t :: p) = + cons_to_nth (fst (Positional.place weight t (Nat.pred n))) + (snd (Positional.place weight t (Nat.pred n))) + (from_associational n p). + Proof. reflexivity. Qed. + End FromAssociational. + End Columns. +End Columns. + +Module Rows. + Import Saturated. + Section Rows. + Context weight {wprops : @weight_properties weight}. + + Local Notation rows := (list (list Z)) (only parsing). + Local Notation cols := (list (list Z)) (only parsing). + + Hint Rewrite Positional.eval_nil Positional.eval0 @Positional.eval_snoc + Positional.eval_to_associational + Columns.eval_nil Columns.eval_snoc using (auto; solve [distr_length]) : push_eval. + Hint Resolve in_eq in_cons. + + Definition eval n (inp : rows) := + sum (map (Positional.eval weight n) inp). + Lemma eval_nil n : eval n nil = 0. + Proof. cbv [eval]. rewrite map_nil, sum_nil; reflexivity. Qed. + Hint Rewrite eval_nil : push_eval. + Lemma eval0 x : eval 0 x = 0. + Proof. cbv [eval]. induction x; autorewrite with push_map push_sum push_eval; omega. Qed. + Hint Rewrite eval0 : push_eval. + Lemma eval_cons n r inp : eval n (r :: inp) = Positional.eval weight n r + eval n inp. + Proof. cbv [eval]; autorewrite with push_map push_sum; reflexivity. Qed. + Hint Rewrite eval_cons : push_eval. + Lemma eval_app n x y : eval n (x ++ y) = eval n x + eval n y. + Proof. cbv [eval]; autorewrite with push_map push_sum; reflexivity. Qed. + Hint Rewrite eval_app : push_eval. + + Ltac In_cases := + repeat match goal with + | H: In _ (_ ++ _) |- _ => apply in_app_or in H; destruct H + | H: In _ (_ :: _) |- _ => apply in_inv in H; destruct H + | H: In _ nil |- _ => contradiction H + | H: forall x, In x (?y :: ?ls) -> ?P |- _ => + unique pose proof (H y ltac:(apply in_eq)); + unique assert (forall x, In x ls -> P) by auto + | H: forall x, In x (?ls ++ ?y :: nil) -> ?P |- _ => + unique pose proof (H y ltac:(auto using in_or_app, in_eq)); + unique assert (forall x, In x ls -> P) by eauto using in_or_app + end. + + Section FromAssociational. + (* extract row *) + Definition extract_row (inp : cols) : cols * list Z := (map (fun c => tl c) inp, map (fun c => hd 0 c) inp). + + Lemma eval_extract_row (inp : cols): forall n, + length inp = n -> + Positional.eval weight n (snd (extract_row inp)) = Columns.eval weight n inp - Columns.eval weight n (fst (extract_row inp)) . + Proof. + cbv [extract_row]. + induction inp using rev_ind; [ | destruct n ]; + repeat match goal with + | _ => progress intros + | _ => progress distr_length + | _ => rewrite Positional.eval_snoc with (n:=n) by distr_length + | _ => progress autorewrite with cancel_pair push_eval push_map in * + | _ => ring + end. + rewrite IHinp by distr_length. + destruct x; cbn [hd tl]; rewrite ?sum_nil, ?sum_cons; ring. + Qed. Hint Rewrite eval_extract_row using (solve [distr_length]) : push_eval. + + Lemma length_fst_extract_row n (inp : cols) : + length inp = n -> length (fst (extract_row inp)) = n. + Proof. cbv [extract_row]; autorewrite with cancel_pair; distr_length. Qed. + Hint Rewrite length_fst_extract_row : distr_length. + + Lemma length_snd_extract_row n (inp : cols) : + length inp = n -> length (snd (extract_row inp)) = n. + Proof. cbv [extract_row]; autorewrite with cancel_pair; distr_length. Qed. + Hint Rewrite length_snd_extract_row : distr_length. + + (* max column size *) + Definition max_column_size (x:cols) := fold_right (fun a b => Nat.max a b) 0%nat (map (fun c => length c) x). + + (* TODO: move to where list is defined *) + Hint Rewrite @app_nil_l : list. + Hint Rewrite <-@app_comm_cons: list. + + Lemma max_column_size_nil : max_column_size nil = 0%nat. + Proof. reflexivity. Qed. Hint Rewrite max_column_size_nil : push_max_column_size. + Lemma max_column_size_cons col (inp : cols) : + max_column_size (col :: inp) = Nat.max (length col) (max_column_size inp). + Proof. reflexivity. Qed. Hint Rewrite max_column_size_cons : push_max_column_size. + Lemma max_column_size_app (x y : cols) : + max_column_size (x ++ y) = Nat.max (max_column_size x) (max_column_size y). + Proof. induction x; autorewrite with list push_max_column_size; lia. Qed. + Hint Rewrite max_column_size_app : push_max_column_size. + Lemma max_column_size0 (inp : cols) : + forall n, + length inp = n -> (* this is not needed to make the lemma true, but prevents reliance on the implementation of Columns.eval*) + max_column_size inp = 0%nat -> Columns.eval weight n inp = 0. + Proof. + induction inp as [|x inp] using rev_ind; destruct n; try destruct x; intros; + autorewrite with push_max_column_size push_eval push_sum distr_length in *; try lia. + rewrite IHinp; distr_length; lia. + Qed. + + (* from_columns *) + Definition from_columns' n start_state : cols * rows := + fold_right (fun _ (state : cols * rows) => + let cols'_row := extract_row (fst state) in + (fst cols'_row, snd state ++ [snd cols'_row]) + ) start_state (repeat 0 n). + + Definition from_columns (inp : cols) : rows := snd (from_columns' (max_column_size inp) (inp, [])). + + Lemma eval_from_columns'_with_length m st n: + (length (fst st) = n) -> + length (fst (from_columns' m st)) = n /\ + ((forall r, In r (snd st) -> length r = n) -> + forall r, In r (snd (from_columns' m st)) -> length r = n) /\ + eval n (snd (from_columns' m st)) = Columns.eval weight n (fst st) + eval n (snd st) + - Columns.eval weight n (fst (from_columns' m st)). + Proof. + cbv [from_columns']; intros. + apply fold_right_invariant; intros; + repeat match goal with + | _ => progress (intros; subst) + | _ => progress autorewrite with cancel_pair push_eval + | _ => progress In_cases + | _ => split; try omega + | H: _ /\ _ |- _ => destruct H + | _ => solve [auto using length_fst_extract_row, length_snd_extract_row] + end. + Qed. + Lemma length_fst_from_columns' m st : + length (fst (from_columns' m st)) = length (fst st). + Proof. apply eval_from_columns'_with_length; reflexivity. Qed. + Hint Rewrite length_fst_from_columns' : distr_length. + Lemma length_snd_from_columns' m st : + (forall r, In r (snd st) -> length r = length (fst st)) -> + forall r, In r (snd (from_columns' m st)) -> length r = length (fst st). + Proof. apply eval_from_columns'_with_length. reflexivity. Qed. + Hint Rewrite length_snd_from_columns' : distr_length. + Lemma eval_from_columns' m st n : + (length (fst st) = n) -> + eval n (snd (from_columns' m st)) = Columns.eval weight n (fst st) + eval n (snd st) + - Columns.eval weight n (fst (from_columns' m st)). + Proof. apply eval_from_columns'_with_length. Qed. + Hint Rewrite eval_from_columns' using (auto; solve [distr_length]) : push_eval. + + Lemma max_column_size_extract_row inp : + max_column_size (fst (extract_row inp)) = (max_column_size inp - 1)%nat. + Proof. + cbv [extract_row]. autorewrite with cancel_pair. + induction inp; [ reflexivity | ]. + autorewrite with push_max_column_size push_map distr_length. + rewrite IHinp. auto using Nat.sub_max_distr_r. + Qed. + Hint Rewrite max_column_size_extract_row : push_max_column_size. + + Lemma max_column_size_from_columns' m st : + max_column_size (fst (from_columns' m st)) = (max_column_size (fst st) - m)%nat. + Proof. + cbv [from_columns']; induction m; intros; cbn - [max_column_size extract_row]; + autorewrite with push_max_column_size; lia. + Qed. + Hint Rewrite max_column_size_from_columns' : push_max_column_size. + + Lemma eval_from_columns (inp : cols) : + forall n, length inp = n -> eval n (from_columns inp) = Columns.eval weight n inp. + Proof. + intros; cbv [from_columns]; + repeat match goal with + | _ => progress autorewrite with cancel_pair push_eval push_max_column_size + | _ => rewrite max_column_size0 with (inp := fst (from_columns' _ _)) by + (autorewrite with push_max_column_size; distr_length) + | _ => omega + end. + Qed. + Hint Rewrite eval_from_columns using (auto; solve [distr_length]) : push_eval. + + Lemma length_from_columns inp: + forall r, In r (from_columns inp) -> length r = length inp. + Proof. + cbv [from_columns]; intros. + change inp with (fst (inp, @nil (list Z))). + eapply length_snd_from_columns'; eauto. + autorewrite with cancel_pair; intros; In_cases. + Qed. + Hint Rewrite length_from_columns : distr_length. + + (* from associational *) + Definition from_associational n (p : list (Z * Z)) := from_columns (Columns.from_associational weight n p). + + Lemma eval_from_associational n p: (n <> 0%nat \/ p = nil) -> + eval n (from_associational n p) = Associational.eval p. + Proof. + intros. cbv [from_associational]. + rewrite eval_from_columns by auto using Columns.length_from_associational. + auto using Columns.eval_from_associational. + Qed. + + Lemma length_from_associational n p : + forall r, In r (from_associational n p) -> length r = n. + Proof. + cbv [from_associational]; intros. + match goal with H: _ |- _ => apply length_from_columns in H end. + rewrite Columns.length_from_associational in *; auto. + Qed. + + (* TODO : move *) + Lemma max_0_iff a b : Nat.max a b = 0%nat <-> (a = 0%nat /\ b = 0%nat). + Proof. + destruct a, b; try tauto. + rewrite <-Nat.succ_max_distr. + split; [ | destruct 1]; congruence. + Qed. + Lemma max_column_size_zero_iff x : + max_column_size x = 0%nat <-> (forall c, In c x -> c = nil). + Proof. + cbv [max_column_size]; induction x; intros; [ cbn; tauto | ]. + autorewrite with push_fold_right push_map. + rewrite max_0_iff, IHx. + split; intros; [ | rewrite length_zero_iff_nil; solve [auto] ]. + match goal with H : _ /\ _ |- _ => destruct H end. + In_cases; subst; auto using length0_nil. + Qed. + + Lemma max_column_size_Columns_from_associational n p : + n <> 0%nat -> p <> nil -> + max_column_size (Columns.from_associational weight n p) <> 0%nat. + Proof. + intros. + rewrite max_column_size_zero_iff. + intro. destruct p; [congruence | ]. + rewrite Columns.from_associational_step in *. + cbv [Columns.cons_to_nth] in *. + match goal with H : forall c, In c (update_nth ?n ?f ?ls) -> _ |- _ => + assert (n < length (update_nth n f ls))%nat; + [ | specialize (H (nth n (update_nth n f ls) nil) ltac:(auto using nth_In)) ] + end. + { distr_length. + rewrite Columns.length_from_associational. + remember (Nat.pred n) as m. replace n with (S m) by omega. + apply Positional.place_in_range. } + rewrite <-nth_default_eq in *. + autorewrite with push_nth_default in *. + rewrite eq_nat_dec_refl in *. + congruence. + Qed. + + Lemma from_associational_nonnil n p : + n <> 0%nat -> p <> nil -> + from_associational n p <> nil. + Proof. + intros; cbv [from_associational from_columns from_columns']. + pose proof (max_column_size_Columns_from_associational n p ltac:(auto) ltac:(auto)). + case_eq (max_column_size (Columns.from_associational weight n p)); [omega|]. + intros; cbn. + rewrite <-length_zero_iff_nil. distr_length. + Qed. + End FromAssociational. + + Section Flatten. + Local Notation fw := (fun i => weight (S i) / weight i) (only parsing). + + Section SumRows. + Definition sum_rows' start_state (row1 row2 : list Z) : list Z * Z * nat := + fold_right (fun next (state : list Z * Z * nat) => + let i := snd state in + let low_high' := + let low_high := fst state in + let low := fst low_high in + let high := snd low_high in + dlet_nd sum_carry := Z.add_with_get_carry_full (fw i) high (fst next) (snd next) in + (low ++ [fst sum_carry], snd sum_carry) in + (low_high', S i)) start_state (rev (combine row1 row2)). + Definition sum_rows row1 row2 := fst (sum_rows' (nil, 0, 0%nat) row1 row2). + + Ltac push := + repeat match goal with + | _ => progress intros + | _ => progress cbv [Let_In] + | _ => rewrite Nat.add_1_r + | _ => erewrite Positional.eval_snoc by eauto + | H : length _ = _ |- _ => rewrite H + | H: 0%nat = _ |- _ => rewrite <-H + | [p := _ |- _] => subst p + | _ => progress autorewrite with cancel_pair natsimplify push_sum_rows list push_nth_default + | _ => progress autorewrite with cancel_pair in * + | _ => progress distr_length + | _ => progress break_match + | _ => ring + | _ => solve [ repeat (f_equal; try ring) ] + | _ => tauto + | _ => solve [eauto] + end. + + Lemma sum_rows'_cons state x1 row1 x2 row2 : + sum_rows' state (x1 :: row1) (x2 :: row2) = + sum_rows' (fst (fst state) ++ [(snd (fst state) + x1 + x2) mod (fw (snd state))], + (snd (fst state) + x1 + x2) / fw (snd state), + S (snd state)) row1 row2. + Proof. + cbv [sum_rows' Let_In]; autorewrite with push_combine. + rewrite !fold_left_rev_right. cbn [fold_left]. + autorewrite with cancel_pair to_div_mod. congruence. + Qed. + + Lemma sum_rows'_nil state : + sum_rows' state nil nil = state. + Proof. reflexivity. Qed. + + Hint Rewrite sum_rows'_cons sum_rows'_nil : push_sum_rows. + + Lemma sum_rows'_div_mod_length row1 : + forall nm start_state row2 row1' row2', + let m := snd start_state in + let n := length row1 in + length row2 = n -> + length row1' = m -> + length row2' = m -> + length (fst (fst start_state)) = m -> + (nm = n + m)%nat -> + let eval := Positional.eval weight in + is_div_mod (eval m) (fst start_state) (eval m row1' + eval m row2') (weight m) -> + length (fst (fst (sum_rows' start_state row1 row2))) = nm + /\ is_div_mod (eval nm) (fst (sum_rows' start_state row1 row2)) + (eval nm (row1' ++ row1) + eval nm (row2' ++ row2)) + (weight nm). + Proof. + induction row1 as [|x1 row1]; destruct row2 as [|x2 row2]; intros; subst nm; push; [ ]. + rewrite (app_cons_app_app _ row1'), (app_cons_app_app _ row2'). + apply IHrow1; clear IHrow1; autorewrite with cancel_pair distr_length in *; try omega. + eapply is_div_mod_step with (x := x1 + x2); try eassumption; push. + Qed. + + Lemma sum_rows_div_mod n row1 row2 : + length row1 = n -> length row2 = n -> + let eval := Positional.eval weight in + is_div_mod (eval n) (sum_rows row1 row2) (eval n row1 + eval n row2) (weight n). + Proof. + cbv [sum_rows]; intros. + apply sum_rows'_div_mod_length with (row1':=nil) (row2':=nil); + cbv [is_div_mod]; autorewrite with cancel_pair push_eval zsimplify; distr_length. + Qed. + + Lemma sum_rows_mod n row1 row2 : + length row1 = n -> length row2 = n -> + Positional.eval weight n (fst (sum_rows row1 row2)) + = (Positional.eval weight n row1 + Positional.eval weight n row2) mod (weight n). + Proof. apply sum_rows_div_mod. Qed. + Lemma sum_rows_div row1 row2 n: + length row1 = n -> length row2 = n -> + snd (sum_rows row1 row2) + = (Positional.eval weight n row1 + Positional.eval weight n row2) / (weight n). + Proof. apply sum_rows_div_mod. Qed. + + Lemma sum_rows'_partitions row1 : + forall nm start_state row2 row1' row2', + let m := snd start_state in + let n := length row1 in + length row2 = n -> + length row1' = m -> + length row2' = m -> + length (fst (fst start_state)) = m -> + nm = (n + m)%nat -> + let eval := Positional.eval weight in + snd (fst start_state) = (eval m row1' + eval m row2') / weight m -> + (forall j, (j < m)%nat -> + nth_default 0 (fst (fst start_state)) j = ((eval m row1' + eval m row2') mod (weight (S j))) / (weight j)) -> + forall i, (i < nm)%nat -> + nth_default 0 (fst (fst (sum_rows' start_state row1 row2))) i + = ((eval nm (row1' ++ row1) + eval nm (row2' ++ row2)) mod (weight (S i))) / (weight i). + Proof. + induction row1 as [|x1 row1]; destruct row2 as [|x2 row2]; intros; subst nm; push; []. + + rewrite (app_cons_app_app _ row1'), (app_cons_app_app _ row2'). + apply IHrow1; clear IHrow1; push; + repeat match goal with + | H : ?LHS = _ |- _ => + match LHS with context [start_state] => rewrite H end + | H : context [nth_default 0 (fst (fst start_state))] |- _ => rewrite H by omega + | _ => rewrite <-(Z.add_assoc _ x1 x2) + end. + { rewrite div_step by auto using Z.gt_lt. + rewrite Z.mul_div_eq_full by auto; rewrite weight_multiples by auto. push. } + { rewrite weight_div_mod with (j:=snd start_state) (i:=S j) by (auto; omega). + push_Zmod. autorewrite with zsimplify_fast. reflexivity. } + { push. replace (snd start_state) with j in * by omega. + push. rewrite add_mod_div_multiple by auto using Z.lt_le_incl. + push. } + Qed. + + Lemma sum_rows_partitions row1: forall row2 n i, + length row1 = n -> length row2 = n -> (i < n)%nat -> + nth_default 0 (fst (sum_rows row1 row2)) i + = ((Positional.eval weight n row1 + Positional.eval weight n row2) mod weight (S i)) / (weight i). + Proof. + cbv [sum_rows]; intros. rewrite <-(Nat.add_0_r n). + rewrite <-(app_nil_l row1), <-(app_nil_l row2). + apply sum_rows'_partitions; intros; + autorewrite with cancel_pair push_eval zsimplify_fast push_nth_default; distr_length. + Qed. + + Lemma length_sum_rows row1 row2 n: + length row1 = n -> length row2 = n -> + length (fst (sum_rows row1 row2)) = n. + Proof. + cbv [sum_rows]; intros. + eapply sum_rows'_div_mod_length; cbv [is_div_mod]; + autorewrite with cancel_pair; distr_length; auto using nil_length0. + Qed. Hint Rewrite length_sum_rows : distr_length. + End SumRows. + Hint Resolve length_sum_rows. + Hint Rewrite sum_rows_mod using (auto; solve [distr_length; auto]) : push_eval. + + Definition flatten' (start_state : list Z * Z) (inp : rows) : list Z * Z := + fold_right (fun next_row (state : list Z * Z)=> + let out_carry := sum_rows next_row (fst state) in + (fst out_carry, snd state + snd out_carry)) start_state inp. + + (* In order for the output to have the right length and bounds, + we insert rows of zeroes if there are fewer than two rows. *) + Definition flatten n (inp : rows) : list Z * Z := + let default := Positional.zeros n in + flatten' (hd default inp, 0) (hd default (tl inp) :: tl (tl inp)). + + Lemma flatten'_cons state r inp : + flatten' state (r :: inp) = (fst (sum_rows r (fst (flatten' state inp))), snd (flatten' state inp) + snd (sum_rows r (fst (flatten' state inp)))). + Proof. cbv [flatten']; autorewrite with list push_fold_right. reflexivity. Qed. + Lemma flatten'_snoc state r inp : + flatten' state (inp ++ r :: nil) = flatten' (fst (sum_rows r (fst state)), snd state + snd (sum_rows r (fst state))) inp. + Proof. cbv [flatten']; autorewrite with list push_fold_right. reflexivity. Qed. + Lemma flatten'_nil state : flatten' state [] = state. Proof. reflexivity. Qed. + Hint Rewrite flatten'_cons flatten'_snoc flatten'_nil : push_flatten. + + Ltac push := + repeat match goal with + | _ => progress intros + | H: length ?x = ?n |- context [snd (sum_rows ?x _)] => rewrite sum_rows_div with (n:=n) by (distr_length; eauto) + | H: length ?x = ?n |- context [snd (sum_rows _ ?x)] => rewrite sum_rows_div with (n:=n) by (distr_length; eauto) + | H: length _ = _ |- _ => rewrite H + | _ => progress autorewrite with cancel_pair push_flatten push_eval distr_length zsimplify_fast + | _ => progress In_cases + | |- _ /\ _ => split + | |- context [?x mod ?y] => unique pose proof (Z.mul_div_eq_full x y ltac:(auto)); lia + | _ => apply length_sum_rows + | _ => solve [repeat (ring_simplify; f_equal; try ring)] + | _ => congruence + | _ => solve [eauto] + end. + + Lemma flatten'_div_mod_length n inp : forall start_state, + length (fst start_state) = n -> + (forall row, In row inp -> length row = n) -> + length (fst (flatten' start_state inp)) = n + /\ (inp <> nil -> + is_div_mod (Positional.eval weight n) (flatten' start_state inp) + (Positional.eval weight n (fst start_state) + eval n inp + weight n * snd start_state) + (weight n)). + Proof. + induction inp using rev_ind; push; [apply IHinp; push|]. + destruct (dec (inp = nil)); [subst inp; cbv [is_div_mod] + | eapply is_div_mod_result_equal; try apply IHinp]; push. + { autorewrite with zsimplify; push. } + { rewrite Z.div_add' by auto; push. } + Qed. + + Hint Rewrite (@Positional.length_zeros weight) : distr_length. + Hint Rewrite (@Positional.eval_zeros weight) using auto : push_eval. + + Lemma flatten_div_mod inp n : + (forall row, In row inp -> length row = n) -> + is_div_mod (Positional.eval weight n) (flatten n inp) (eval n inp) (weight n). + Proof. + intros; cbv [flatten]. + destruct inp; [|destruct inp]; cbn [hd tl]. + { cbv [is_div_mod]; push. + erewrite sum_rows_div by (distr_length; reflexivity). + push. } + { cbv [is_div_mod]; push. } + { eapply is_div_mod_result_equal; try apply flatten'_div_mod_length; push. } + Qed. + + Lemma flatten_mod inp n : + (forall row, In row inp -> length row = n) -> + Positional.eval weight n (fst (flatten n inp)) = (eval n inp) mod (weight n). + Proof. apply flatten_div_mod. Qed. + Lemma flatten_div inp n : + (forall row, In row inp -> length row = n) -> + snd (flatten n inp) = (eval n inp) / (weight n). + Proof. apply flatten_div_mod. Qed. + + Lemma length_flatten' n start_state inp : + length (fst start_state) = n -> + (forall row, In row inp -> length row = n) -> + length (fst (flatten' start_state inp)) = n. + Proof. apply flatten'_div_mod_length. Qed. + Hint Rewrite length_flatten' : distr_length. + + Lemma length_flatten n inp : + (forall row, In row inp -> length row = n) -> + length (fst (flatten n inp)) = n. + Proof. + intros. + apply length_flatten'; push; + destruct inp as [|? [|? ?] ]; try congruence; cbn [hd tl] in *; push; + subst row; distr_length. + Qed. Hint Rewrite length_flatten : distr_length. + + Lemma flatten'_partitions n inp : forall start_state, + inp <> nil -> + length (fst start_state) = n -> + (forall row, In row inp -> length row = n) -> + forall i, (i < n)%nat -> + nth_default 0 (fst (flatten' start_state inp)) i + = ((Positional.eval weight n (fst start_state) + eval n inp) mod weight (S i)) / (weight i). + Proof. + induction inp using rev_ind; push. + destruct (dec (inp = nil)). + { subst inp; push. rewrite sum_rows_partitions with (n:=n) by eauto. push. } + { erewrite IHinp; push. + rewrite add_mod_l_multiple by auto using weight_divides_full, weight_multiples_full. + push. } + Qed. + + Lemma flatten_partitions inp n : + (forall row, In row inp -> length row = n) -> + forall i, (i < n)%nat -> + nth_default 0 (fst (flatten n inp)) i = (eval n inp mod weight (S i)) / (weight i). + Proof. + intros; cbv [flatten]. + intros; destruct inp as [| ? [| ? ?] ]; try congruence; cbn [hd tl] in *; try solve [push]. + { cbn. autorewrite with push_nth_default. + rewrite sum_rows_partitions with (n:=n) by distr_length. + autorewrite with push_eval zsimplify_fast. + auto with zarith. } + { push. rewrite sum_rows_partitions with (n:=n) by distr_length; push. } + { rewrite flatten'_partitions with (n:=n); push. } + Qed. + + Definition partition n x := + map (fun i => (x mod weight (S i)) / weight i) (seq 0 n). + + Lemma nth_default_partitions x : forall p n, + (forall i, (i < n)%nat -> nth_default 0 p i = (x mod weight (S i)) / weight i) -> + length p = n -> + p = partition n x. + Proof. + cbv [partition]; induction p using rev_ind; intros; distr_length; subst n; [reflexivity|]. + rewrite Nat.add_1_r, seq_snoc. + autorewrite with natsimplify push_map. + rewrite <-IHp; auto; intros; + match goal with H : context [nth_default _ (p ++ [ _ ])] |- _ => + rewrite <-H by omega end. + { autorewrite with push_nth_default natsimplify. reflexivity. } + { autorewrite with push_nth_default natsimplify. + break_match; omega. } + Qed. + + Lemma partition_step n x : + partition (S n) x = partition n x ++ [(x mod weight (S n)) / weight n]. + Proof. + cbv [partition]. rewrite seq_snoc. + autorewrite with natsimplify push_map. reflexivity. + Qed. + + Lemma length_partition n x : length (partition n x) = n. + Proof. cbv [partition]; distr_length. Qed. + Hint Rewrite length_partition : distr_length. + + Lemma eval_partition n x : + Positional.eval weight n (partition n x) = x mod (weight n). + Proof. + induction n; intros. + { cbn. rewrite (weight_0); auto with zarith. } + { rewrite (Z.div_mod (x mod weight (S n)) (weight n)) by auto. + rewrite <-Znumtheory.Zmod_div_mod by (try apply Z.mod_divide; auto). + rewrite partition_step, Positional.eval_snoc with (n:=n) by distr_length. + omega. } + Qed. + + Lemma flatten_partitions' inp n : + (forall row, In row inp -> length row = n) -> + fst (flatten n inp) = partition n (eval n inp). + Proof. auto using nth_default_partitions, flatten_partitions, length_flatten. Qed. + End Flatten. + + Section Ops. + Definition add n p q := flatten n [p; q]. + + (* TODO: Although cleaner, using Positional.negate snd inserts + dlets which prevent add-opp=>sub transformation in partial + evaluation. Should probably either make partial evaluation + handle that or remove the dlet in + Positional.from_associational. *) + Definition sub n p q := flatten n [p; map (fun x => dlet y := x in Z.opp y) q]. + + Hint Rewrite eval_cons eval_nil using solve [auto] : push_eval. + + Definition mul base n m (p q : list Z) := + let p_a := Positional.to_associational weight n p in + let q_a := Positional.to_associational weight n q in + let pq_a := Associational.sat_mul base p_a q_a in + flatten m (from_associational m pq_a). + + (* TODO : move sat_reduce and repeat_sat_reduce to Saturated.Associational *) + Definition sat_reduce base s c (p : list (Z * Z)) := + let lo_hi := Associational.split s p in + fst lo_hi ++ (Associational.sat_mul_const base c (snd lo_hi)). + + Definition repeat_sat_reduce base s c (p : list (Z * Z)) n := + fold_right (fun _ q => sat_reduce base s c q) p (seq 0 n). + + Definition mulmod base s c n nreductions (p q : list Z) := + let p_a := Positional.to_associational weight n p in + let q_a := Positional.to_associational weight n q in + let pq_a := Associational.sat_mul base p_a q_a in + let r_a := repeat_sat_reduce base s c pq_a nreductions in + flatten n (from_associational n r_a). + + Hint Rewrite Associational.eval_sat_mul_const Associational.eval_sat_mul Associational.eval_split using solve [auto] : push_eval. + Hint Rewrite eval_from_associational using solve [auto] : push_eval. + Hint Rewrite eval_partition using solve [auto] : push_eval. + Ltac solver := + intros; cbv [sub add mul mulmod sat_reduce]; + rewrite ?flatten_partitions' by (intros; In_cases; subst; distr_length; eauto using length_from_associational); + rewrite ?flatten_div by (intros; In_cases; subst; distr_length; eauto using length_from_associational); + autorewrite with push_eval; ring_simplify_subterms; + try reflexivity. + + Lemma add_partitions n p q : + n <> 0%nat -> length p = n -> length q = n -> + fst (add n p q) = partition n (Positional.eval weight n p + Positional.eval weight n q). + Proof. solver. Qed. + + Lemma add_div n p q : + n <> 0%nat -> length p = n -> length q = n -> + snd (add n p q) = (Positional.eval weight n p + Positional.eval weight n q) / weight n. + Proof. solver. Qed. + + Lemma eval_map_opp q : + forall n, length q = n -> + Positional.eval weight n (map Z.opp q) = - Positional.eval weight n q. + Proof. + induction q using rev_ind; intros; + repeat match goal with + | _ => progress autorewrite with push_map push_eval + | _ => erewrite !Positional.eval_snoc with (n:=length q) by distr_length + | _ => rewrite IHq by auto + | _ => ring + end. + Qed. Hint Rewrite eval_map_opp using solve [auto]: push_eval. + + Lemma sub_partitions n p q : + n <> 0%nat -> length p = n -> length q = n -> + fst (sub n p q) = partition n (Positional.eval weight n p - Positional.eval weight n q). + Proof. solver. Qed. + + Lemma sub_div n p q : + n <> 0%nat -> length p = n -> length q = n -> + snd (sub n p q) = (Positional.eval weight n p - Positional.eval weight n q) / weight n. + Proof. solver. Qed. + + Lemma mul_partitions base n m p q : + base <> 0 -> n <> 0%nat -> m <> 0%nat -> length p = n -> length q = n -> + fst (mul base n m p q) = partition m (Positional.eval weight n p * Positional.eval weight n q). + Proof. solver. Qed. + + Lemma eval_sat_reduce base s c p : + base <> 0 -> s - Associational.eval c <> 0 -> s <> 0 -> + Associational.eval (sat_reduce base s c p) mod (s - Associational.eval c) + = Associational.eval p mod (s - Associational.eval c). + Proof. + intros; cbv [sat_reduce]. + autorewrite with push_eval. + rewrite <-Associational.reduction_rule by omega. + autorewrite with push_eval; reflexivity. + Qed. + Hint Rewrite eval_sat_reduce using auto : push_eval. + + Lemma eval_repeat_sat_reduce base s c p n : + base <> 0 -> s - Associational.eval c <> 0 -> s <> 0 -> + Associational.eval (repeat_sat_reduce base s c p n) mod (s - Associational.eval c) + = Associational.eval p mod (s - Associational.eval c). + Proof. + intros; cbv [repeat_sat_reduce]. + apply fold_right_invariant; intros; autorewrite with push_eval; auto. + Qed. + Hint Rewrite eval_repeat_sat_reduce using auto : push_eval. + + Lemma eval_mulmod base s c n nreductions p q : + base <> 0 -> s <> 0 -> s - Associational.eval c <> 0 -> + n <> 0%nat -> length p = n -> length q = n -> + (Positional.eval weight n (fst (mulmod base s c n nreductions p q)) + + weight n * (snd (mulmod base s c n nreductions p q))) mod (s - Associational.eval c) + = (Positional.eval weight n p * Positional.eval weight n q) mod (s - Associational.eval c). + Proof. + solver. + rewrite <-Z.div_mod'' by auto. + autorewrite with push_eval; reflexivity. + Qed. + End Ops. + End Rows. +End Rows. + +Module BaseConversion. + Import Positional. + Section BaseConversion. + Hint Resolve Z.gt_lt. + Context (sw dw : nat -> Z) (* source/destination weight functions *) + {swprops : @weight_properties sw} + {dwprops : @weight_properties dw}. + + Definition convert_bases (sn dn : nat) (p : list Z) : list Z := + let p' := Positional.from_associational dw dn (Positional.to_associational sw sn p) in + chained_carries_no_reduce dw dn p' (seq 0 (pred dn)). + + Lemma eval_convert_bases sn dn p : + (dn <> 0%nat) -> length p = sn -> + eval dw dn (convert_bases sn dn p) = eval sw sn p. + Proof. + cbv [convert_bases]; intros. + rewrite eval_chained_carries_no_reduce; auto using ZUtil.Z.positive_is_nonzero. + rewrite eval_from_associational; auto. + Qed. + + Hint Rewrite + @Rows.eval_from_associational + @Associational.eval_carry + @Associational.eval_mul + @Positional.eval_to_associational + Associational.eval_carryterm + @eval_convert_bases using solve [auto using Z.positive_is_nonzero] : push_eval. + + Ltac push_eval := intros; autorewrite with push_eval; auto with zarith. + + (* convert from positional in one weight to the other, then to associational *) + Definition to_associational n m p : list (Z * Z) := + let p' := convert_bases n m p in + Positional.to_associational dw m p'. + + (* TODO : move to Associational? *) + Section reorder. + Definition reordering_carry (w fw : Z) (p : list (Z * Z)) := + fold_right (fun t acc => + let r := Associational.carryterm w fw t in + if fst t =? w then acc ++ r else r ++ acc) nil p. + + Lemma eval_reordering_carry w fw p (_:fw<>0): + Associational.eval (reordering_carry w fw p) = Associational.eval p. + Proof. + cbv [reordering_carry]. induction p; [reflexivity |]. + autorewrite with push_fold_right. break_match; push_eval. + Qed. + End reorder. + Hint Rewrite eval_reordering_carry using solve [auto using Z.positive_is_nonzero] : push_eval. + + (* carry at specified indices in dw, then use Rows.flatten to convert to Positional with sw *) + Definition from_associational idxs n (p : list (Z * Z)) : list Z := + (* important not to use Positional.carry here; we don't want to accumulate yet *) + let p' := fold_right (fun i acc => reordering_carry (dw i) (dw (S i) / dw i) acc) (Associational.bind_snd p) (rev idxs) in + fst (Rows.flatten sw n (Rows.from_associational sw n p')). + + Lemma eval_carries p idxs : + Associational.eval (fold_right (fun i acc => reordering_carry (dw i) (dw (S i) / dw i) acc) p idxs) = + Associational.eval p. + Proof. apply fold_right_invariant; push_eval. Qed. + Hint Rewrite eval_carries: push_eval. + + Lemma eval_to_associational n m p : + m <> 0%nat -> length p = n -> + Associational.eval (to_associational n m p) = Positional.eval sw n p. + Proof. cbv [to_associational]; push_eval. Qed. + Hint Rewrite eval_to_associational using solve [push_eval; distr_length] : push_eval. + + Lemma eval_from_associational idxs n p : + n <> 0%nat -> 0 <= Associational.eval p < sw n -> + Positional.eval sw n (from_associational idxs n p) = Associational.eval p. + Proof. + cbv [from_associational]; intros. + rewrite Rows.flatten_mod by eauto using Rows.length_from_associational. + rewrite Associational.bind_snd_correct. + push_eval. + Qed. + Hint Rewrite eval_from_associational using solve [push_eval; distr_length] : push_eval. + + Lemma from_associational_partitions n idxs p (_:n<>0%nat): + forall i, (i < n)%nat -> + nth_default 0 (from_associational idxs n p) i = (Associational.eval p) mod (sw (S i)) / sw i. + Proof. + intros; cbv [from_associational]. + rewrite Rows.flatten_partitions with (n:=n) by (eauto using Rows.length_from_associational; omega). + rewrite Associational.bind_snd_correct. + push_eval. + Qed. + + Lemma from_associational_eq n idxs p (_:n<>0%nat): + from_associational idxs n p = Rows.partition sw n (Associational.eval p). + Proof. + intros. cbv [from_associational]. + rewrite Rows.flatten_partitions' with (n:=n) by eauto using Rows.length_from_associational. + rewrite Associational.bind_snd_correct. + push_eval. + Qed. + + Derive from_associational_inlined + SuchThat (forall idxs n p, + from_associational_inlined idxs n p = from_associational idxs n p) + As from_associational_inlined_correct. + Proof. + intros. + cbv beta iota delta [from_associational reordering_carry Associational.carryterm]. + cbv beta iota delta [Let_In]. (* inlines all shifts/lands from carryterm *) + cbv beta iota delta [from_associational Rows.from_associational Columns.from_associational]. + cbv beta iota delta [Let_In]. (* inlines the shifts from place *) + subst from_associational_inlined; reflexivity. + Qed. + + Derive to_associational_inlined + SuchThat (forall n m p, + to_associational_inlined n m p = to_associational n m p) + As to_associational_inlined_correct. + Proof. + intros. + cbv beta iota delta [ to_associational convert_bases + Positional.to_associational + Positional.from_associational + chained_carries_no_reduce + carry + Associational.carry + Associational.carryterm + ]. + cbv beta iota delta [Let_In]. + subst to_associational_inlined; reflexivity. + Qed. + + (* carry chain that aligns terms in the intermediate weight with the final weight *) + Definition aligned_carries (log_dw_sw nout : nat) + := (map (fun i => ((log_dw_sw * (i + 1)) - 1))%nat (seq 0 nout)). + + Section mul_converted. + Definition mul_converted + n1 n2 (* lengths in original format *) + m1 m2 (* lengths in converted format *) + (n3 : nat) (* final length *) + (idxs : list nat) (* carries to do -- this helps preemptively line up weights *) + (p1 p2 : list Z) := + let p1_a := to_associational n1 m1 p1 in + let p2_a := to_associational n2 m2 p2 in + let p3_a := Associational.mul p1_a p2_a in + from_associational idxs n3 p3_a. + + Lemma eval_mul_converted n1 n2 m1 m2 n3 idxs p1 p2 (_:n3<>0%nat) (_:m1<>0%nat) (_:m2<>0%nat): + length p1 = n1 -> length p2 = n2 -> + 0 <= (Positional.eval sw n1 p1 * Positional.eval sw n2 p2) < sw n3 -> + Positional.eval sw n3 (mul_converted n1 n2 m1 m2 n3 idxs p1 p2) = (Positional.eval sw n1 p1) * (Positional.eval sw n2 p2). + Proof. cbv [mul_converted]; push_eval. Qed. + Hint Rewrite eval_mul_converted : push_eval. + + Lemma mul_converted_partitions n1 n2 m1 m2 n3 idxs p1 p2 (_:n3<>0%nat) (_:m1<>0%nat) (_:m2<>0%nat): + length p1 = n1 -> length p2 = n2 -> + mul_converted n1 n2 m1 m2 n3 idxs p1 p2 = Rows.partition sw n3 (Positional.eval sw n1 p1 * Positional.eval sw n2 p2). + Proof. + intros; cbv [mul_converted]. + rewrite from_associational_eq by auto. push_eval. + Qed. + End mul_converted. + End BaseConversion. + + (* multiply two (n*k)-bit numbers by converting them to n k-bit limbs each, multiplying, then converting back *) + Section widemul. + Context (log2base : Z) (log2base_pos : 0 < log2base). + Context (n : nat) (n_nz : n <> 0%nat) (n_le_log2base : Z.of_nat n <= log2base) + (nout : nat) (nout_2 : nout = 2%nat). (* nout is always 2, but partial evaluation is overeager if it's a constant *) + Let dw : nat -> Z := weight (log2base / Z.of_nat n) 1. + Let sw : nat -> Z := weight log2base 1. + + Local Lemma base_bounds : 0 < 1 <= log2base. Proof. auto with zarith. Qed. + Local Lemma dbase_bounds : 0 < 1 <= log2base / Z.of_nat n. Proof. auto with zarith. Qed. + Let dwprops : @weight_properties dw := wprops (log2base / Z.of_nat n) 1 dbase_bounds. + Let swprops : @weight_properties sw := wprops log2base 1 base_bounds. + + Hint Resolve Z.gt_lt Z.positive_is_nonzero Nat2Z.is_nonneg. + + Definition widemul a b := mul_converted sw dw 1 1 n n nout (aligned_carries n nout) [a] [b]. + + Lemma widemul_correct a b : + 0 <= a * b < 2^log2base * 2^log2base -> + widemul a b = [(a * b) mod 2^log2base; (a * b) / 2^log2base]. + Proof. + cbv [widemul]; intros. + rewrite mul_converted_partitions by auto with zarith. + subst nout sw; cbv [weight]; cbn. + autorewrite with zsimplify. + rewrite Z.pow_mul_r, Z.pow_2_r by omega. + Z.rewrite_mod_small. reflexivity. + Qed. + + Derive widemul_inlined + SuchThat (forall a b, + 0 <= a * b < 2^log2base * 2^log2base -> + widemul_inlined a b = [(a * b) mod 2^log2base; (a * b) / 2^log2base]) + As widemul_inlined_correct. + Proof. + intros. + rewrite <-widemul_correct by auto. + cbv beta iota delta [widemul mul_converted]. + rewrite <-to_associational_inlined_correct with (p:=[a]). + rewrite <-to_associational_inlined_correct with (p:=[b]). + rewrite <-from_associational_inlined_correct. + subst widemul_inlined; reflexivity. + Qed. + + Derive widemul_inlined_reverse + SuchThat (forall a b, + 0 <= a * b < 2^log2base * 2^log2base -> + widemul_inlined_reverse a b = [(a * b) mod 2^log2base; (a * b) / 2^log2base]) + As widemul_inlined_reverse_correct. + Proof. + intros. + rewrite <-widemul_inlined_correct by assumption. + cbv [widemul_inlined]. + match goal with |- _ = from_associational_inlined sw dw ?idxs ?n ?p => + transitivity (from_associational_inlined sw dw idxs n (rev p)); + [ | transitivity (from_associational sw dw idxs n p); [ | reflexivity ] ](* reverse to make addc chains line up *) + end. + Focus 2. { + rewrite from_associational_inlined_correct by (subst nout; auto). + cbv [from_associational]. + rewrite !Rows.flatten_partitions' by eauto using Rows.length_from_associational. + rewrite !Rows.eval_from_associational by (subst nout; auto). + f_equal. + rewrite !eval_carries, !Associational.bind_snd_correct, !Associational.eval_rev by auto. + reflexivity. } Unfocus. + subst widemul_inlined_reverse; reflexivity. + Qed. + End widemul. +End BaseConversion. diff --git a/src/Experiments/NewPipeline/CLI.v b/src/Experiments/NewPipeline/CLI.v new file mode 100644 index 000000000..24e26e4f4 --- /dev/null +++ b/src/Experiments/NewPipeline/CLI.v @@ -0,0 +1,269 @@ +Require Import Coq.ZArith.ZArith. +Require Import Coq.Lists.List. +Require Import Coq.Strings.String. +Require Crypto.Util.Strings.String. +Require Import Crypto.Util.Strings.Decimal. +Require Import Crypto.Util.Strings.HexString. +Require Import Crypto.Util.Option. +Require Import Crypto.Util.Strings.Show. +Require Import Crypto.Experiments.NewPipeline.Toplevel1. +Require Import Crypto.Experiments.NewPipeline.CStringification. +Import ListNotations. Local Open Scope Z_scope. Local Open Scope string_scope. + +Import CStringification.Compilers. + +Module ForExtraction. + Definition parse_neg (s : string) : string * Z + := match s with + | String a b + => if Ascii.ascii_dec a "-" + then (b, -1) + else if Ascii.ascii_dec a "+" + then (b, 1) + else (s, 1) + | _ => (s, 1) + end. + Definition parse_N (s : string) : N + := DecimalHelpers.N.of_uint (DecimalHelpers.String.to_uint s). + Definition parse_Z (s : string) : Z + := let '(s, sgn) := parse_neg s in + sgn * Z.of_N (parse_N s). + Definition parse_nat (s : string) : nat + := N.to_nat (parse_N s). + + Definition parse_n (n : string) : nat + := parse_nat n. + + Definition parse_pow (s : string) : option Z + := let '(s, sgn) := parse_neg s in + match String.split "^" s with + | v::nil + => Some (sgn * parse_Z v) + | b::e::nil + => Some (sgn * parse_Z b ^ parse_Z e) + | _ => None + end. + + Definition parse_mul (s : string) : option Z + := List.fold_right + (fun a b => (a <- a; b <- b; Some (Z.mul a b))%option) + (Some 1) + (List.map parse_pow (String.split "*" s)). + + (** We take in [c] in the format [a,b;c,d;e,f;...] becoming the list + [[(a,b), (c,d), (e, f), ...]] *) + Definition parse_s (s : string) : option Z + := parse_mul s. + Definition parse_c (s : string) : option (list (Z * Z)) + := List.fold_right + (fun ls rest + => (rest <- rest; + match ls with + | a::b::nil => (a <- parse_mul a; b <- parse_mul b; Some ((a, b)::rest)) + | _ => None + end)%option) + (Some nil) + (List.map (String.split ",") (String.split ";" s)). + + Definition parse_machine_wordsize (s : string) : Z + := parse_Z s. + + Local Open Scope string_scope. + Local Notation NewLine := (String "010" "") (only parsing). + + Definition CollectErrors + (res : list (string * Pipeline.ErrorT (list string)) + string) + : list (list string) + list string + := match res with + | inl res + => let header := hd "" (List.map (@fst _ _) res) in + let res := + List.fold_right + (fun '(name, res) rest + => match res, rest with + | ErrorT.Error err, rest + => let cur := ("In " ++ name ++ ": " ++ show false err) in + let rest := match rest with inl _ => nil | inr rest => rest end in + inr (cur :: rest) + | ErrorT.Success v, inr ls => inr ls + | ErrorT.Success v, inl ls + => inl (v :: ls) + end) + (inl nil) + res in + match res with + | inl ls => inl ls + | inr err => inr (header::err) + end + | inr res + => inr (res::nil) + end. + + Module UnsaturatedSolinas. + Definition PipelineLines + (n : string) + (s : string) + (c : string) + (machine_wordsize : string) + : list (string * Pipeline.ErrorT (list string)) + string + := let str_n := n in + let n : nat := parse_n n in + let str_machine_wordsize := machine_wordsize in + let str_c := c in + let str_s := s in + let machine_wordsize := parse_machine_wordsize machine_wordsize in + match parse_s s, parse_c c with + | None, None + => inr ("Could not parse s (" ++ s ++ ") nor c (" ++ c ++ ")") + | None, _ + => inr ("Could not parse s (" ++ s ++ ")") + | _, None + => inr ("Could not parse c (" ++ c ++ ")") + | Some s, Some c + => let header := + ((["/* Autogenerated */"; + "/* n = " ++ show false n ++ " (from """ ++ str_n ++ """) */"; + "/* s = " ++ Hex.show_Z false s ++ " (from """ ++ str_s ++ """) */"; + "/* c = " ++ show false c ++ " (from """ ++ str_c ++ """) */"; + "/* machine_wordsize = " ++ show false machine_wordsize ++ " (from """ ++ str_machine_wordsize ++ """) */"; + ""]%string) + ++ ToString.C.String.typedef_header + ++ [""])%list in + inl + ([("check_args" ++ NewLine ++ String.concat NewLine header, + UnsaturatedSolinas.check_args + n s c machine_wordsize + (ErrorT.Success header))%string] + ++ UnsaturatedSolinas.Synthesize n s c machine_wordsize "fe")%list + end. + + Definition ProcessedLines + (n : string) + (s : string) + (c : string) + (machine_wordsize : string) + : list string + string + := match CollectErrors (PipelineLines n s c machine_wordsize) with + | inl ls + => inl + (List.map (fun s => String.concat NewLine s ++ NewLine ++ NewLine) + ls) + | inr ls + => inr (String.concat + (NewLine ++ NewLine) + ls) + end. + + Definition Pipeline + {A} + (n : string) + (s : string) + (c : string) + (machine_wordsize : string) + (success : list string -> A) + (error : string -> A) + : A + := match ProcessedLines n s c machine_wordsize with + | inl s => success s + | inr s => error s + end. + + Definition PipelineMain + {A} + (argv : list string) + (success : list string -> A) + (error : string -> A) + : A + := match argv with + | _::n::s::c::machine_wordsize::nil + => Pipeline + n s c machine_wordsize + success + error + | nil => error "empty argv" + | prog::args + => error ("Expected arguments n, s, c, machine_wordsize, got " ++ show false (List.length args) ++ " arguments in " ++ prog) + end. + End UnsaturatedSolinas. + + Module SaturatedSolinas. + Definition PipelineLines + (s : string) + (c : string) + (machine_wordsize : string) + : list (string * Pipeline.ErrorT (list string)) + string + := let str_machine_wordsize := machine_wordsize in + let str_c := c in + let str_s := s in + let machine_wordsize := parse_machine_wordsize machine_wordsize in + match parse_s s, parse_c c with + | None, None + => inr ("Could not parse s (" ++ s ++ ") nor c (" ++ c ++ ")") + | None, _ + => inr ("Could not parse s (" ++ s ++ ")") + | _, None + => inr ("Could not parse c (" ++ c ++ ")") + | Some s, Some c + => let header := + ((["/* Autogenerated */"; + "/* s = " ++ Hex.show_Z false s ++ " (from """ ++ str_s ++ """) */"; + "/* c = " ++ show false c ++ " (from """ ++ str_c ++ """) */"; + "/* machine_wordsize = " ++ show false machine_wordsize ++ " (from """ ++ str_machine_wordsize ++ """) */"; + ""]%string) + ++ ToString.C.String.typedef_header + ++ [""])%list in + inl + ([("check_args" ++ NewLine ++ String.concat NewLine header, + SaturatedSolinas.check_args + s c machine_wordsize + (ErrorT.Success header))%string] + ++ SaturatedSolinas.Synthesize s c machine_wordsize "fe")%list + end. + + Definition ProcessedLines + (s : string) + (c : string) + (machine_wordsize : string) + : list string + string + := match CollectErrors (PipelineLines s c machine_wordsize) with + | inl ls + => inl + (List.map (fun s => String.concat NewLine s ++ NewLine ++ NewLine) + ls) + | inr ls + => inr (String.concat + (NewLine ++ NewLine) + ls) + end. + + Definition Pipeline + {A} + (s : string) + (c : string) + (machine_wordsize : string) + (success : list string -> A) + (error : string -> A) + : A + := match ProcessedLines s c machine_wordsize with + | inl s => success s + | inr s => error s + end. + + Definition PipelineMain + {A} + (argv : list string) + (success : list string -> A) + (error : string -> A) + : A + := match argv with + | _::s::c::machine_wordsize::nil + => Pipeline + s c machine_wordsize + success + error + | nil => error "empty argv" + | prog::args + => error ("Expected arguments s, c, machine_wordsize, got " ++ show false (List.length args) ++ " arguments in " ++ prog) + end. + End SaturatedSolinas. +End ForExtraction. diff --git a/src/Experiments/NewPipeline/CStringification.v b/src/Experiments/NewPipeline/CStringification.v new file mode 100644 index 000000000..c3644d3ec --- /dev/null +++ b/src/Experiments/NewPipeline/CStringification.v @@ -0,0 +1,1417 @@ +Require Import Coq.ZArith.ZArith. +Require Import Coq.MSets.MSetPositive. +Require Import Coq.FSets.FMapPositive. +Require Import Coq.Strings.String. +Require Import Coq.Strings.Ascii. +Require Import Coq.Bool.Bool. +Require Import Crypto.Util.ListUtil Coq.Lists.List. +Require Crypto.Util.Strings.String. +Require Import Crypto.Util.Strings.Decimal. +Require Import Crypto.Util.Strings.HexString. +Require Import Crypto.Util.Strings.Show. +Require Import Crypto.Util.ZRange. +Require Import Crypto.Util.ZRange.Operations. +Require Import Crypto.Util.ZRange.Show. +Require Import Crypto.Util.Option. +Require Import Crypto.Experiments.NewPipeline.Language. +Require Import Crypto.Experiments.NewPipeline.AbstractInterpretation. +Require Import Crypto.Util.Bool.Equality. +Require Import Crypto.Util.Notations. +Import ListNotations. Local Open Scope zrange_scope. Local Open Scope Z_scope. + +Module Compilers. + Local Set Boolean Equality Schemes. + Local Set Decidable Equality Schemes. + Export Language.Compilers. + Export AbstractInterpretation.Compilers. + Import invert_expr. + Import defaults. + + Module ToString. + Local Open Scope string_scope. + + Module PHOAS. + Module type. + Module base. + Global Instance show_base : Show base.type.base + := fun _ t => match t with + | base.type.unit => "()" + | base.type.Z => "ℤ" + | base.type.bool => "𝔹" + | base.type.nat => "ℕ" + end. + Fixpoint show_type (with_parens : bool) (t : base.type) : string + := match t with + | base.type.type_base t => show with_parens t + | base.type.prod A B => maybe_wrap_parens + with_parens + (@show_type false A ++ " * " ++ @show_type true B) + | base.type.list A => "[" ++ @show_type false A ++ "]" + end. + Fixpoint show_base_interp {t} : Show (base.base_interp t) + := match t with + | base.type.unit => @show unit _ + | base.type.Z => @show Z _ + | base.type.bool => @show bool _ + | base.type.nat => @show nat _ + end. + Global Existing Instance show_base_interp. + Fixpoint show_interp {t} : Show (base.interp t) + := match t with + | base.type.type_base t => @show (base.base_interp t) _ + | base.type.prod A B => @show (base.interp A * base.interp B) _ + | base.type.list A => @show (list (base.interp A)) _ + end. + Global Existing Instance show_interp. + Global Instance show : Show base.type := show_type. + End base. + Fixpoint show_type {base_type} {S : Show base_type} (with_parens : bool) (t : type.type base_type) : string + := match t with + | type.base t => S with_parens t + | type.arrow s d + => maybe_wrap_parens + with_parens + (@show_type base_type S true s ++ " → " ++ @show_type base_type S false d) + end. + Global Instance show {base_type} {S : Show base_type} : Show (type.type base_type) := show_type. + End type. + + Module ident. + Definition bitwidth_to_string (v : Z) : string + := (if v =? 2^Z.log2 v then "2^" ++ decimal_string_of_Z (Z.log2 v) else HexString.of_Z v). + Global Instance show_ident {t} : Show (ident.ident t) + := fun with_parens idc + => match idc with + | ident.Literal t v => show with_parens v + | ident.Nat_succ => "Nat.succ" + | ident.Nat_pred => "Nat.pred" + | ident.Nat_max => "Nat.max" + | ident.Nat_mul => "Nat.mul" + | ident.Nat_add => "Nat.add" + | ident.Nat_sub => "Nat.sub" + | ident.nil t => "[]" + | ident.cons t => "(::)" + | ident.pair A B => "(,)" + | ident.fst A B => "fst" + | ident.snd A B => "snd" + | ident.pair_rect A B T => "pair_rect" + | ident.bool_rect T => "bool_rect" + | ident.nat_rect P => "nat_rect" + | ident.list_rect A P => "list_rect" + | ident.list_case A P => "list_case" + | ident.List_length T => "length" + | ident.List_seq => "seq" + | ident.List_repeat A => "repeat" + | ident.List_combine A B => "combine" + | ident.List_map A B => "map" + | ident.List_app A => "(++)" + | ident.List_rev A => "rev" + | ident.List_flat_map A B => "flat_map" + | ident.List_partition A => "partition" + | ident.List_fold_right A B => "fold_right" + | ident.List_update_nth T => "update_nth" + | ident.List_nth_default T => "nth_default" + | ident.Z_add => "(+)" + | ident.Z_mul => "( * )" + | ident.Z_pow => "(^)" + | ident.Z_sub => "(-)" + | ident.Z_opp => "-" + | ident.Z_div => "(/)" + | ident.Z_modulo => "(mod)" + | ident.Z_eqb => "(=)" + | ident.Z_leb => "(≤)" + | ident.Z_of_nat => "(ℕ→ℤ)" + | ident.Z_shiftr offset => "(>> " ++ decimal_string_of_Z offset ++ ")" + | ident.Z_shiftl offset => "(<< " ++ decimal_string_of_Z offset ++ ")" + | ident.Z_land mask => "(& " ++ HexString.of_Z mask ++ ")" + | ident.Z_mul_split => "Z.mul_split" + | ident.Z_mul_split_concrete s => maybe_wrap_parens with_parens ("Z.mul_split " ++ bitwidth_to_string s) + | ident.Z_add_get_carry => "Z.add_get_carry" + | ident.Z_add_get_carry_concrete s => maybe_wrap_parens with_parens ("Z.add_get_carry " ++ bitwidth_to_string s) + | ident.Z_add_with_carry => "Z.add_with_carry" + | ident.Z_add_with_get_carry => "Z.add_with_get_carry" + | ident.Z_add_with_get_carry_concrete s => maybe_wrap_parens with_parens ("Z.add_with_get_carry " ++ bitwidth_to_string s) + | ident.Z_sub_get_borrow => "Z.sub_get_borrow" + | ident.Z_sub_get_borrow_concrete s => maybe_wrap_parens with_parens ("Z.sub_get_borrow " ++ bitwidth_to_string s) + | ident.Z_sub_with_get_borrow => "Z.sub_with_get_borrow" + | ident.Z_sub_with_get_borrow_concrete s => maybe_wrap_parens with_parens ("Z.sub_with_get_borrow " ++ bitwidth_to_string s) + | ident.Z_zselect => "Z.zselect" + | ident.Z_add_modulo => "Z.add_modulo" + | ident.Z_rshi => "Z.rshi" + | ident.Z_rshi_concrete s offset => maybe_wrap_parens with_parens ("Z.rshi " ++ bitwidth_to_string s ++ " " ++ decimal_string_of_Z offset) + | ident.Z_cc_m => "Z.cc_m" + | ident.Z_cc_m_concrete s => maybe_wrap_parens with_parens ("Z.cc_m " ++ bitwidth_to_string s) + | ident.Z_neg_snd => "Z.neg_snd" + | ident.Z_cast range => "(" ++ show false range ++ ")" + | ident.Z_cast2 range => "(" ++ show false range ++ ")" + | ident.fancy_add log2wordmax imm + => maybe_wrap_parens with_parens ("fancy.add 2^" ++ decimal_string_of_Z log2wordmax ++ " " ++ HexString.of_Z imm) + | ident.fancy_addc log2wordmax imm + => maybe_wrap_parens with_parens ("fancy.addc 2^" ++ decimal_string_of_Z log2wordmax ++ " " ++ HexString.of_Z imm) + | ident.fancy_sub log2wordmax imm + => maybe_wrap_parens with_parens ("fancy.sub 2^" ++ decimal_string_of_Z log2wordmax ++ " " ++ HexString.of_Z imm) + | ident.fancy_subb log2wordmax imm + => maybe_wrap_parens with_parens ("fancy.subb 2^" ++ decimal_string_of_Z log2wordmax ++ " " ++ HexString.of_Z imm) + | ident.fancy_mulll log2wordmax + => maybe_wrap_parens with_parens ("fancy.mulll 2^" ++ decimal_string_of_Z log2wordmax) + | ident.fancy_mullh log2wordmax + => maybe_wrap_parens with_parens ("fancy.mullh 2^" ++ decimal_string_of_Z log2wordmax) + | ident.fancy_mulhl log2wordmax + => maybe_wrap_parens with_parens ("fancy.mulhl 2^" ++ decimal_string_of_Z log2wordmax) + | ident.fancy_mulhh log2wordmax + => maybe_wrap_parens with_parens ("fancy.mulhh 2^" ++ decimal_string_of_Z log2wordmax) + | ident.fancy_rshi log2wordmax x + => maybe_wrap_parens with_parens ("fancy.rshi 2^" ++ decimal_string_of_Z log2wordmax ++ " " ++ decimal_string_of_Z x) + | ident.fancy_selc => "fancy.selc" + | ident.fancy_selm log2wordmax + => maybe_wrap_parens with_parens ("fancy.selm 2^" ++ decimal_string_of_Z log2wordmax) + | ident.fancy_sell => "fancy.sell" + | ident.fancy_addm => "fancy.addm" + end. + End ident. + + Local Notation NewLine := (String "010" "") (only parsing). + + Module expr. + Section with_base_type. + Context {base_type} {ident : type.type base_type -> Type} + {show_base_type : Show base_type} + {show_ident : forall t, Show (ident t)}. + Fixpoint show_expr_lines {t} (e : @expr.expr base_type ident (fun _ => string) t) (idx : positive) (with_parens : bool) : positive * list string + := match e with + | expr.Ident t idc + => (idx, [show with_parens idc]) + | expr.Var t v + => (idx, [v]) + | expr.Abs s d f + => (idx, + let n := "x" ++ decimal_string_of_pos idx in + let '(_, show_f) := @show_expr_lines _ (f n) (Pos.succ idx) false in + match show_f with + | nil => ["(λ " ++ n ++ ", (* NOTHING‽ *))"]%string + | show_f::nil + => ["(λ " ++ n ++ ", " ++ show_f ++ ")"]%string + | show_f + => ["(λ " ++ n ++ ","]%string ++ (List.map (String " ") show_f) ++ [")"] + end%list) + | expr.App s d f x + => let '(idx, show_f) := @show_expr_lines _ f idx false in + let '(idx, show_x) := @show_expr_lines _ x idx true in + (idx, match show_f, show_x with + | [show_f], [show_x] => [maybe_wrap_parens with_parens (show_f ++ " @ " ++ show_x)] + | _, _ => ["("] ++ show_f ++ [") @ ("] ++ show_x ++ [")"] + end%list) + | expr.LetIn A B x f + => let n := "x" ++ decimal_string_of_pos idx in + let '(_, show_x) := @show_expr_lines _ x idx false in + let '(idx, show_f) := @show_expr_lines _ (f n) (Pos.succ idx) false in + let expr_let_line := "expr_let " ++ n ++ " := " in + (idx, + match show_x with + | nil => [expr_let_line ++ "(* NOTHING‽ *) in"]%string ++ show_f + | show_x::nil => [expr_let_line ++ show_x ++ " in"]%string ++ show_f + | show_x::rest + => ([expr_let_line ++ show_x]%string) + ++ (List.map (fun l => String.of_list (List.repeat " "%char (String.length expr_let_line)) ++ l)%string + rest) + ++ ["in"] + ++ show_f + end%list) + end. + Global Instance show_expr {t} : Show (@expr.expr base_type ident (fun _ => string) t) + := fun with_parens e => String.concat NewLine (snd (@show_expr_lines t e 1%positive with_parens)). + Global Instance show_Expr {t} : Show (@expr.Expr base_type ident t) + := fun with_parens e => show with_parens (e _). + End with_base_type. + End expr. + End PHOAS. + + Module C. + Module type. + Inductive primitive := Z | Zptr. + Inductive type := type_primitive (t : primitive) | prod (A B : type) | unit. + Module Export Notations. + Global Coercion type_primitive : primitive >-> type. + Delimit Scope Ctype_scope with Ctype. + + Bind Scope Ctype_scope with type. + Notation "()" := unit : Ctype_scope. + Notation "A * B" := (prod A B) : Ctype_scope. + Notation type := type. + End Notations. + End type. + Import type.Notations. + + Module int. + Inductive type := signed (lgbitwidth : nat) | unsigned (lgbitwidth : nat). + + Definition lgbitwidth_of (t : type) : nat + := match t with + | signed lgbitwidth => lgbitwidth + | unsigned lgbitwidth => lgbitwidth + end. + Definition bitwidth_of (t : type) : Z := 2^Z.of_nat (lgbitwidth_of t). + Definition is_signed (t : type) : bool := match t with signed _ => true | unsigned _ => false end. + Definition is_unsigned (t : type) : bool := negb (is_signed t). + Definition to_zrange (t : type) : zrange + := let bw := bitwidth_of t in + if is_signed t + then r[-2^bw ~> 2^(bw-1) - 1] + else r[0 ~> 2^bw - 1]. + Definition is_tighter_than (t1 t2 : type) + := ZRange.is_tighter_than_bool (to_zrange t1) (to_zrange t2). + Definition of_zrange_relaxed (r : zrange) : type + := let lg2 := Z.log2_up ((upper r - lower r) + 1) in + let lg2u := Z.log2_up (upper r + 1) in + let lg2l := (if (lower r <? 0) then 1 + Z.log2_up (-lower r) else 0) in + let lg2 := Z.max lg2 (Z.max lg2u lg2l) in + let lg2lg2u := Z.log2_up lg2 in + if (0 <=? lower r) + then unsigned (Z.to_nat lg2lg2u) + else signed (Z.to_nat lg2lg2u). + Definition of_zrange (r : zrange) : option type + := let t := of_zrange_relaxed r in + let r' := to_zrange t in + if (r' =? r)%zrange + then Some t + else None. + Definition unsigned_counterpart_of (t : type) : type + := unsigned (lgbitwidth_of t). + + Definition union (t1 t2 : type) : type := of_zrange_relaxed (ZRange.union (to_zrange t1) (to_zrange t2)). + + Fixpoint base_interp (t : base.type) : Set + := match t with + | base.type.Z => type + | base.type.type_base _ => unit + | base.type.prod A B => base_interp A * base_interp B + | base.type.list A => list (base_interp A) + end%type. + + Module option. + Fixpoint interp (t : base.type) : Set + := match t with + | base.type.Z => option type + | base.type.type_base _ => unit + | base.type.prod A B => interp A * interp B + | base.type.list A => option (list (interp A)) + end%type. + Fixpoint None {t} : interp t + := match t with + | base.type.Z => Datatypes.None + | base.type.type_base _ => tt + | base.type.prod A B => (@None A, @None B) + | base.type.list A => Datatypes.None + end. + Fixpoint Some {t} : base_interp t -> interp t + := match t with + | base.type.Z => Datatypes.Some + | base.type.type_base _ => fun tt => tt + | base.type.prod A B => fun '(a, b) => (@Some A a, @Some B b) + | base.type.list A => fun ls => Datatypes.Some (List.map (@Some A) ls) + end. + End option. + + Module Export Notations. + Notation _Bool := (unsigned 0). + Notation uint8 := (unsigned 3). + Notation int8 := (signed 3). + Notation uint16 := (unsigned 4). + Notation int16 := (signed 4). + Notation uint32 := (unsigned 5). + Notation int32 := (signed 5). + Notation uint64 := (unsigned 6). + Notation int64 := (signed 6). + Notation uint128 := (unsigned 7). + Notation int128 := (signed 7). + End Notations. + End int. + Import int.Notations. + + Example of_zrange_int32 : int.of_zrange_relaxed r[-2^31 ~> 2^31-1] = int32 := eq_refl. + Example of_zrange_int64 : int.of_zrange_relaxed r[-2^31-1 ~> 2^31-1] = int64 := eq_refl. + Example of_zrange_int64' : int.of_zrange_relaxed r[-2^31 ~> 2^31] = int64 := eq_refl. + Example of_zrange_uint32 : int.of_zrange_relaxed r[0 ~> 2^32-1] = uint32 := eq_refl. + Example of_zrange_uint64 : int.of_zrange_relaxed r[0 ~> 2^32] = uint64 := eq_refl. + + Section ident. + Import type. + Inductive ident : type -> type -> Set := + | literal (v : BinInt.Z) : ident unit Z + | List_nth (n : Datatypes.nat) : ident Zptr Z + | Addr : ident Z Zptr + | Dereference : ident Zptr Z + | Z_shiftr (offset : BinInt.Z) : ident Z Z + | Z_shiftl (offset : BinInt.Z) : ident Z Z + | Z_land (mask : BinInt.Z) : ident Z Z + | Z_add : ident (Z * Z) Z + | Z_mul : ident (Z * Z) Z + | Z_sub : ident (Z * Z) Z + | Z_opp : ident Z Z + | Z_mul_split (lgs:BinInt.Z) : ident (Z * Z * Zptr) Z + | Z_add_get_carry (lgs:BinInt.Z) : ident (Z * Z * Zptr) Z + | Z_add_with_get_carry (lgs:BinInt.Z) : ident (Z * Z * Z * Zptr) Z + | Z_sub_get_borrow (lgs:BinInt.Z) : ident (Z * Z * Zptr) Z + | Z_sub_with_get_borrow (lgs:BinInt.Z) : ident (Z * Z * Z * Zptr) Z + | Z_zselect : ident (Z * Z * Z) Z + | Z_add_modulo : ident (Z * Z * Z) Z + | Z_static_cast (ty : int.type) : ident Z Z + . + End ident. + + Inductive arith_expr : type -> Set := + | AppIdent {s d} (idc : ident s d) (arg : arith_expr s) : arith_expr d + | Var (t : type.primitive) (v : string) : arith_expr t + | Pair {A B} (a : arith_expr A) (b : arith_expr B) : arith_expr (A * B) + | TT : arith_expr type.unit. + + Inductive stmt := + | Assign (declare : bool) (t : type.primitive) (sz : option int.type) (name : string) (val : arith_expr t) + | AssignZPtr (name : string) (sz : option int.type) (val : arith_expr type.Z) + | DeclareVar (t : type.primitive) (sz : option int.type) (name : string) + | AssignNth (name : string) (n : nat) (val : arith_expr type.Z). + Definition expr := list stmt. + + Module Export Notations. + Export int.Notations. + Export type.Notations. + Delimit Scope Cexpr_scope with Cexpr. + Bind Scope Cexpr_scope with expr. + Bind Scope Cexpr_scope with stmt. + Bind Scope Cexpr_scope with arith_expr. + Infix "@@" := AppIdent : Cexpr_scope. + Notation "( x , y , .. , z )" := (Pair .. (Pair x%Cexpr y%Cexpr) .. z%Cexpr) : Cexpr_scope. + Notation "( )" := TT : Cexpr_scope. + + Notation "()" := TT : Cexpr_scope. + Notation "x ;; y" := (@cons stmt x%Cexpr y%Cexpr) (at level 70, right associativity, format "'[v' x ;; '/' y ']'") : Cexpr_scope. + End Notations. + + Module OfPHOAS. + Fixpoint base_var_data (t : base.type) : Set + := match t with + | base.type.unit + => unit + | base.type.nat + | base.type.bool + => Empty_set + | base.type.Z => string * option int.type + | base.type.prod A B => base_var_data A * base_var_data B + | base.type.list A => string * option int.type * nat + end. + Definition var_data (t : Compilers.type.type base.type) : Set + := match t with + | type.base t => base_var_data t + | type.arrow s d => Empty_set + end. + + Fixpoint arith_expr_for_base (t : base.type) : Set + := match t with + | base.type.Z + => arith_expr type.Z * option int.type + | base.type.prod A B + => arith_expr_for_base A * arith_expr_for_base B + | base.type.list A => list (arith_expr_for_base A) + | base.type.type_base _ as t + => base.interp t + end. + Definition arith_expr_for (t : Compilers.type.type base.type) : Set + := match t with + | type.base t => arith_expr_for_base t + | type.arrow s d => Empty_set + end. + + (** Quoting + http://en.cppreference.com/w/c/language/conversion: + + ** Integer promotions + + Integer promotion is the implicit conversion of a value of + any integer type with rank less or equal to rank of int or + of a bit field of type _Bool, int, signed int, unsigned + int, to the value of type int or unsigned int + + If int can represent the entire range of values of the + original type (or the range of values of the original bit + field), the value is converted to type int. Otherwise the + value is converted to unsigned int. *) + (** We assume a 32-bit [int] type *) + Definition integer_promote_type (t : int.type) : int.type + := if int.is_tighter_than t int32 + then int32 + else t. + + (** Quoting + http://en.cppreference.com/w/c/language/conversion: + + rank above is a property of every integer type and is + defined as follows: + + 1) the ranks of all signed integer types are different and + increase with their precision: rank of signed char < + rank of short < rank of int < rank of long int < rank + of long long int + + 2) the ranks of all signed integer types equal the ranks + of the corresponding unsigned integer types + + 3) the rank of any standard integer type is greater than + the rank of any extended integer type of the same size + (that is, rank of __int64 < rank of long long int, but + rank of long long < rank of __int128 due to the rule + (1)) + + 4) rank of char equals rank of signed char and rank of + unsigned char + + 5) the rank of _Bool is less than the rank of any other + standard integer type + + 6) the rank of any enumerated type equals the rank of its + compatible integer type + + 7) ranking is transitive: if rank of T1 < rank of T2 and + rank of T2 < rank of T3 then rank of T1 < rank of T3 + + 8) any aspects of relative ranking of extended integer + types not covered above are implementation defined *) + (** We define the rank to be the bitwidth, which satisfies + (1), (2), (4), (5), and (7). Points (3) and (6) do not + apply. *) + Definition rank (r : int.type) : BinInt.Z := int.bitwidth_of r. + Definition IMPOSSIBLE {T} (v : T) : T. exact v. Qed. + (** Quoting + http://en.cppreference.com/w/c/language/conversion: *) + Definition common_type (t1 t2 : int.type) : int.type + (** First of all, both operands undergo integer promotions + (see below). Then *) + := let t1 := integer_promote_type t1 in + let t2 := integer_promote_type t2 in + (** - If the types after promotion are the same, that + type is the common type *) + if int.type_beq t1 t2 then + t1 + (** - Otherwise, if both operands after promotion have + the same signedness (both signed or both unsigned), + the operand with the lesser conversion rank (see + below) is implicitly converted to the type of the + operand with the greater conversion rank *) + else if bool_beq (int.is_signed t1) (int.is_signed t2) then + (if rank t1 >=? rank t2 then t1 else t2) + (** - Otherwise, the signedness is different: If the + operand with the unsigned type has conversion rank + greater or equal than the rank of the type of the + signed operand, then the operand with the signed + type is implicitly converted to the unsigned type + *) + else if int.is_unsigned t1 && (rank t1 >=? rank t2) then + t1 + else if int.is_unsigned t2 && (rank t2 >=? rank t1) then + t2 + (** - Otherwise, the signedness is different and the + signed operand's rank is greater than unsigned + operand's rank. In this case, if the signed type + can represent all values of the unsigned type, then + the operand with the unsigned type is implicitly + converted to the type of the signed operand. *) + else if int.is_signed t1 && int.is_tighter_than t2 t1 then + t1 + else if int.is_signed t2 && int.is_tighter_than t1 t2 then + t2 + (** - Otherwise, both operands undergo implicit + conversion to the unsigned type counterpart of the + signed operand's type. *) + (** N.B. This case ought to be impossible in our code, + where [rank] is the bitwidth. *) + else if int.is_signed t1 then + int.unsigned_counterpart_of t1 + else + int.unsigned_counterpart_of t2. + + Definition Zcast_down_if_needed + : option int.type -> arith_expr_for_base base.type.Z -> arith_expr_for_base base.type.Z + := fun desired_type '(e, known_type) + => match desired_type, known_type with + | None, _ => (e, known_type) + | Some desired_type, Some known_type + => if int.is_tighter_than known_type desired_type + then (e, Some known_type) + else (Z_static_cast desired_type @@ e, Some desired_type) + | Some desired_type, None + => (Z_static_cast desired_type @@ e, Some desired_type) + end%core%Cexpr. + + Fixpoint cast_down_if_needed {t} + : int.option.interp t -> arith_expr_for_base t -> arith_expr_for_base t + := match t with + | base.type.Z => Zcast_down_if_needed + | base.type.type_base _ => fun _ x => x + | base.type.prod A B + => fun '(r1, r2) '(e1, e2) => (@cast_down_if_needed A r1 e1, + @cast_down_if_needed B r2 e2) + | base.type.list A + => fun r1 ls + => match r1 with + | Some r1 => List.map (fun '(r, e) => @cast_down_if_needed A r e) + (List.combine r1 ls) + | None => ls + end + end. + + Definition Zcast_up_if_needed + : option int.type -> arith_expr_for_base base.type.Z -> arith_expr_for_base base.type.Z + := fun desired_type '(e, known_type) + => match desired_type, known_type with + | None, _ | _, None => (e, known_type) + | Some desired_type, Some known_type + => if int.is_tighter_than desired_type known_type + then (e, Some known_type) + else (Z_static_cast desired_type @@ e, Some desired_type)%core%Cexpr + end. + + Fixpoint cast_up_if_needed {t} + : int.option.interp t -> arith_expr_for_base t -> arith_expr_for_base t + := match t with + | base.type.Z => Zcast_up_if_needed + | base.type.type_base _ => fun _ x => x + | base.type.prod A B + => fun '(r1, r2) '(e1, e2) => (@cast_up_if_needed A r1 e1, + @cast_up_if_needed B r2 e2) + | base.type.list A + => fun r1 ls + => match r1 with + | Some r1 => List.map (fun '(r, e) => @cast_up_if_needed A r e) + (List.combine r1 ls) + | None => ls + end + end. + + Definition cast_bigger_up_if_needed + (desired_type : option int.type) + (args : arith_expr_for (base.type.Z * base.type.Z)) + : arith_expr_for (base.type.Z * base.type.Z) + := match desired_type with + | None => args + | Some _ + => let '((e1, t1), (e2, t2)) := args in + match t1, t2 with + | None, _ | _, None => args + | Some t1', Some t2' + => if int.is_tighter_than t2' t1' + then (Zcast_up_if_needed desired_type (e1, t1), (e2, t2)) + else ((e1, t1), Zcast_up_if_needed desired_type (e2, t2)) + end + end. + + Definition arith_bin_arith_expr_of_PHOAS_ident + (s:=(base.type.Z * base.type.Z)%etype) + (d:=base.type.Z) + (idc : ident (type.Z * type.Z) type.Z) + : option int.type -> arith_expr_for s -> option (arith_expr_for d) + := fun desired_type '((e1, t1), (e2, t2)) + => let t1 := option_map integer_promote_type t1 in + let t2 := option_map integer_promote_type t2 in + let '((e1, t1), (e2, t2)) + := cast_bigger_up_if_needed desired_type ((e1, t1), (e2, t2)) in + let ct := (t1 <- t1; t2 <- t2; Some (common_type t1 t2))%option in + Some (Zcast_down_if_needed desired_type ((idc @@ (e1, e2))%Cexpr, ct)). + + Local Definition fakeprod (A B : Compilers.type.type base.type) : Compilers.type.type base.type + := match A, B with + | type.base A, type.base B => type.base (base.type.prod A B) + | type.arrow _ _, _ + | _, type.arrow _ _ + => type.base (base.type.type_base base.type.unit) + end. + Definition arith_expr_for_uncurried_domain (t : Compilers.type.type base.type) + := match t with + | type.base t => unit + | type.arrow s d => arith_expr_for (type.uncurried_domain fakeprod s d) + end. + + Fixpoint arith_expr_of_PHOAS_ident + {t} + (idc : ident.ident t) + : int.option.interp (type.final_codomain t) -> type.interpM_final (fun T => option T) arith_expr_for_base t + := match idc in ident.ident t return int.option.interp (type.final_codomain t) -> type.interpM_final (fun T => option T) arith_expr_for_base t with + | ident.Literal base.type.Z v + => fun r => Some (cast_down_if_needed + r + (literal v @@ TT, Some (int.of_zrange_relaxed r[v~>v]))) + | ident.nil t + => fun _ => Some nil + | ident.cons t + => fun r x xs => Some (cast_down_if_needed r (cons x xs)) + | ident.fst A B => fun r xy => Some (cast_down_if_needed r (@fst _ _ xy)) + | ident.snd A B => fun r xy => Some (cast_down_if_needed r (@snd _ _ xy)) + | ident.List_nth_default base.type.Z + => fun r d ls n + => List.nth_default None (List.map (fun x => Some (cast_down_if_needed r x)) ls) n + | ident.Z_shiftr offset + => fun rout '(e, r) + => let rin := option_map integer_promote_type r in + Some (cast_down_if_needed rout (Z_shiftr offset @@ e, rin)) + | ident.Z_shiftl offset + => fun rout '(e, r) + => let rin := option_map integer_promote_type r in + let '(e', rin') := cast_up_if_needed rout (e, rin) in + Some (cast_down_if_needed rout (Z_shiftr offset @@ e', rin')) + | ident.Z_land mask + => fun rout '(e, r) + => Some (cast_down_if_needed + rout + (Z_land mask @@ e, + option_map integer_promote_type r)) + | ident.Z_add => fun r x y => arith_bin_arith_expr_of_PHOAS_ident Z_add r (x, y) + | ident.Z_mul => fun r x y => arith_bin_arith_expr_of_PHOAS_ident Z_mul r (x, y) + | ident.Z_sub => fun r x y => arith_bin_arith_expr_of_PHOAS_ident Z_sub r (x, y) + | ident.Z_zselect + => fun rout '(econd, _) '(e1, r1) '(e2, r2) + => let r1 := option_map integer_promote_type r1 in + let r2 := option_map integer_promote_type r2 in + let '((e1, r1), (e2, r2)) + := cast_bigger_up_if_needed rout ((e1, r1), (e2, r2)) in + let ct := (r1 <- r1; r2 <- r2; Some (common_type r1 r2))%option in + Some (cast_down_if_needed rout ((Z_zselect @@ (econd, e1, e2))%Cexpr, ct)) + | ident.pair A B + => fun _ _ _ => None + | ident.Z_opp + => fun _ _ => None + | ident.Literal _ v + => fun _ => Some v + | ident.Nat_succ + | ident.Nat_pred + | ident.Nat_max + | ident.Nat_mul + | ident.Nat_add + | ident.Nat_sub + | ident.pair_rect _ _ _ + | ident.bool_rect _ + | ident.nat_rect _ + | ident.list_rect _ _ + | ident.list_case _ _ + | ident.List_length _ + | ident.List_seq + | ident.List_repeat _ + | ident.List_combine _ _ + | ident.List_map _ _ + | ident.List_app _ + | ident.List_rev _ + | ident.List_flat_map _ _ + | ident.List_partition _ + | ident.List_fold_right _ _ + | ident.List_update_nth _ + | ident.List_nth_default _ + | ident.Z_pow + | ident.Z_div + | ident.Z_modulo + | ident.Z_eqb + | ident.Z_leb + | ident.Z_of_nat + | ident.Z_mul_split + | ident.Z_mul_split_concrete _ + | ident.Z_add_get_carry + | ident.Z_add_get_carry_concrete _ + | ident.Z_add_with_carry + | ident.Z_add_with_get_carry + | ident.Z_add_with_get_carry_concrete _ + | ident.Z_sub_get_borrow + | ident.Z_sub_get_borrow_concrete _ + | ident.Z_sub_with_get_borrow + | ident.Z_sub_with_get_borrow_concrete _ + | ident.Z_add_modulo + | ident.Z_rshi + | ident.Z_rshi_concrete _ _ + | ident.Z_cc_m + | ident.Z_cc_m_concrete _ + | ident.Z_neg_snd + | ident.Z_cast _ + | ident.Z_cast2 _ + | ident.fancy_add _ _ + | ident.fancy_addc _ _ + | ident.fancy_sub _ _ + | ident.fancy_subb _ _ + | ident.fancy_mulll _ + | ident.fancy_mullh _ + | ident.fancy_mulhl _ + | ident.fancy_mulhh _ + | ident.fancy_rshi _ _ + | ident.fancy_selc + | ident.fancy_selm _ + | ident.fancy_sell + | ident.fancy_addm + => fun _ => type.interpM_return _ _ _ None + end%core%Cexpr%option%zrange. + + Fixpoint collect_args_and_apply_unknown_casts {t} + : (int.option.interp (type.final_codomain t) -> type.interpM_final (fun T => option T) arith_expr_for_base t) + -> type.interpM_final + (fun T => option T) + (fun t => int.option.interp t -> option (arith_expr_for_base t)) + t + := match t + return ((int.option.interp (type.final_codomain t) -> type.interpM_final (fun T => option T) arith_expr_for_base t) + -> type.interpM_final + (fun T => option T) + (fun t => int.option.interp t -> option (arith_expr_for_base t)) + t) + with + | type.base t => fun v => Some v + | type.arrow (type.base s) d + => fun f + (x : (int.option.interp s -> option (arith_expr_for_base s))) + => match x int.option.None with + | Some x' + => @collect_args_and_apply_unknown_casts + d + (fun rout => f rout x') + | None => type.interpM_return _ _ _ None + end + | type.arrow (type.arrow _ _) _ + => fun _ => type.interpM_return _ _ _ None + end. + + Definition collect_args_and_apply_known_casts {t} + (idc : ident.ident t) + : option (type.interpM_final + (fun T => option T) + (fun t => int.option.interp t -> option (arith_expr_for_base t)) + t) + := match idc in ident.ident t + return option + (type.interpM_final + (fun T => option T) + (fun t => int.option.interp t -> option (arith_expr_for_base t)) + t) + with + | ident.Z_cast r + => Some (fun arg => Some (fun r' => option_map (Zcast_down_if_needed r') (arg (Some (int.of_zrange_relaxed r))))) + | ident.Z_cast2 (r1, r2) + => Some (fun arg => Some (fun r' => option_map (cast_down_if_needed (t:=base.type.Z*base.type.Z) r') + (arg (Some (int.of_zrange_relaxed r1), Some (int.of_zrange_relaxed r2))))) + | ident.pair A B + => Some (fun ea eb + => Some + (fun '(ra, rb) + => (ea' <- ea ra; + eb' <- eb rb; + Some (ea', eb')))) + | ident.nil _ + => Some (Some (fun _ => Some nil)) + | ident.cons t + => Some + (fun x xs + => Some + (fun rls + => let mkcons (r : int.option.interp t) + (rs : int.option.interp (base.type.list t)) + := (x <- x r; + xs <- xs rs; + Some (cons x xs)) in + match rls with + | Some (cons r rs) => mkcons r (Some rs) + | Some nil + | None + => mkcons int.option.None int.option.None + end)) + | _ => None + end%option. + + Definition collect_args_and_apply_casts {t} (idc : ident.ident t) + (convert_no_cast : int.option.interp (type.final_codomain t) -> type.interpM_final (fun T => option T) arith_expr_for_base t) + : type.interpM_final + (fun T => option T) + (fun t => int.option.interp t -> option (arith_expr_for_base t)) + t + := match collect_args_and_apply_known_casts idc with + | Some res => res + | None => collect_args_and_apply_unknown_casts convert_no_cast + end. + + Fixpoint arith_expr_of_base_PHOAS_Var + {t} + : base_var_data t -> int.option.interp t -> option (arith_expr_for_base t) + := match t with + | base.type.Z + => fun '(n, r) r' => Some (cast_down_if_needed r' (Var type.Z n, r)) + | base.type.prod A B + => fun '(da, db) '(ra, rb) + => (ea <- @arith_expr_of_base_PHOAS_Var A da ra; + eb <- @arith_expr_of_base_PHOAS_Var B db rb; + Some (ea, eb))%option + | base.type.list base.type.Z + => fun '(n, r, len) r' + => Some (List.map + (fun i => (List_nth i @@ Var type.Zptr n, r))%core%Cexpr + (List.seq 0 len)) + | base.type.list _ + | base.type.type_base _ + => fun _ _ => None + end. + + Fixpoint arith_expr_of_PHOAS + {t} + (e : @Compilers.expr.expr base.type ident.ident var_data t) + : type.interpM_final + (fun T => option T) + (fun t => int.option.interp t -> option (arith_expr_for_base t)) + t + := match e in expr.expr t + return type.interpM_final + (fun T => option T) + (fun t => int.option.interp t -> option (arith_expr_for_base t)) + t + with + | expr.Var (type.base _) v + => Some (arith_expr_of_base_PHOAS_Var v) + | expr.Ident t idc + => collect_args_and_apply_casts idc (arith_expr_of_PHOAS_ident idc) + | expr.App (type.base s) d f x + => let x' := @arith_expr_of_PHOAS s x in + match x' with + | Some x' => @arith_expr_of_PHOAS _ f x' + | None => type.interpM_return _ _ _ None + end + | expr.Var (type.arrow _ _) _ + | expr.App (type.arrow _ _) _ _ _ + | expr.LetIn _ _ _ _ + | expr.Abs _ _ _ + => type.interpM_return _ _ _ None + end. + + Definition arith_expr_of_base_PHOAS + {t:base.type} + (e : @Compilers.expr.expr base.type ident.ident var_data t) + (rout : int.option.interp t) + : option (arith_expr_for_base t) + := (e' <- arith_expr_of_PHOAS e; e' rout)%option. + + Fixpoint make_return_assignment_of_base_arith {t} + : base_var_data t + -> @Compilers.expr.expr base.type ident.ident var_data t + -> option expr + := match t return base_var_data t -> expr.expr t -> option expr with + | base.type.Z + => fun '(n, r) e + => (rhs <- arith_expr_of_base_PHOAS e r; + let '(e, r) := rhs in + Some [AssignZPtr n r e]) + | base.type.type_base _ => fun _ _ => None + | base.type.prod A B + => fun '(rva, rvb) e + => match invert_pair e with + | Some (ea, eb) + => (ea' <- @make_return_assignment_of_base_arith A rva ea; + eb' <- @make_return_assignment_of_base_arith B rvb eb; + Some (ea' ++ eb')) + | None => None + end + | base.type.list base.type.Z + => fun '(n, r, len) e + => (ls <- arith_expr_of_base_PHOAS e (Some (repeat r len)); + List.fold_right + (fun a b + => match b with + | Some b => Some (a ++ b) + | None => Some a + end) + None + (List.map + (fun '(i, (e, _)) => [AssignNth n i e]) + (List.combine (List.seq 0 len) ls))) + | base.type.list _ => fun _ _ => None + end%option%list. + Definition make_return_assignment_of_arith {t} + : var_data t + -> @Compilers.expr.expr base.type ident.ident var_data t + -> option expr + := match t with + | type.base t => make_return_assignment_of_base_arith + | type.arrow s d => fun _ _ => None + end. + + Definition make_assign_2arg_1ref + {t1 t2 d t3} + (r1 r2 : option int.type) + (x1 : @Compilers.expr.expr base.type ident.ident var_data t1) + (x2 : @Compilers.expr.expr base.type ident.ident var_data t2) + (idc : ident (type.Z * type.Z * type.Zptr) type.Z) + (count : positive) + (make_name : positive -> option string) + (v : var_data t3) + (e2 : var_data d -> var_data (base.type.Z * base.type.Z)%etype -> option expr) + : option expr + := (v <- type.try_transport base.try_make_transport_cps var_data _ d v; + x1 <- type.try_transport base.try_make_transport_cps expr.expr _ base.type.Z x1; + x2 <- type.try_transport base.try_make_transport_cps expr.expr _ base.type.Z x2; + let e2 := e2 v in + x1 <- arith_expr_of_base_PHOAS x1 None; + x2 <- arith_expr_of_base_PHOAS x2 None; + let '(x1, x1r) := x1 in + let '(x2, x2r) := x2 in + n1 <- make_name count; + n2 <- make_name (Pos.succ count); + e2 <- e2 ((n1, r1), (n2, r2)); + Some ([DeclareVar type.Z r2 n2; + Assign true type.Z r1 n1 (idc @@ (x1, x2, Addr @@ Var type.Z n2))] + ++ e2))%option%list. + + Definition make_assign_3arg_1ref + {t1 t2 t3 d t4} + (r1 r2 : option int.type) + (x1 : @Compilers.expr.expr base.type ident.ident var_data t1) + (x2 : @Compilers.expr.expr base.type ident.ident var_data t2) + (x3 : @Compilers.expr.expr base.type ident.ident var_data t3) + (idc : ident (type.Z * type.Z * type.Z * type.Zptr) type.Z) + (count : positive) + (make_name : positive -> option string) + (v : var_data t4) + (e2 : var_data d -> var_data (base.type.Z * base.type.Z)%etype -> option expr) + : option expr + := (v <- type.try_transport base.try_make_transport_cps var_data _ d v; + x1 <- type.try_transport base.try_make_transport_cps expr.expr _ base.type.Z x1; + x2 <- type.try_transport base.try_make_transport_cps expr.expr _ base.type.Z x2; + x3 <- type.try_transport base.try_make_transport_cps expr.expr _ base.type.Z x3; + let e2 := e2 v in + x1 <- arith_expr_of_base_PHOAS x1 None; + x2 <- arith_expr_of_base_PHOAS x2 None; + x3 <- arith_expr_of_base_PHOAS x3 None; + let '(x1, x1r) := x1 in + let '(x2, x2r) := x2 in + let '(x3, x3r) := x3 in + n1 <- make_name count; + n2 <- make_name (Pos.succ count); + e2 <- e2 ((n1, r1), (n2, r2)); + Some ([DeclareVar type.Z r2 n2; + Assign true type.Z r1 n1 (idc @@ (x1, x2, x3, Addr @@ Var type.Z n2))] + ++ e2))%option%list. + + Fixpoint size_of_type (t : base.type) : positive + := match t with + | base.type.type_base t => 1 + | base.type.prod A B => size_of_type A + size_of_type B + | base.type.list A => 1 + end%positive. + + Definition maybe_log2 (s : Z) : option Z + := if 2^Z.log2 s =? s then Some (Z.log2 s) else None. + + Definition recognize_ident_2arg {t} (idc : ident.ident t) + : option (ident (type.type_primitive type.Z * type.type_primitive type.Z * type.type_primitive type.Zptr) (type.type_primitive type.Z)) + := match idc with + | ident.Z_mul_split_concrete s + => option_map Z_mul_split (maybe_log2 s) + | ident.Z_add_get_carry_concrete s + => option_map Z_add_get_carry (maybe_log2 s) + | ident.Z_sub_get_borrow_concrete s + => option_map Z_sub_get_borrow (maybe_log2 s) + | _ => None + end. + Definition recognize_ident_3arg {t} (idc : ident.ident t) + : option (ident (type.type_primitive type.Z * type.type_primitive type.Z * type.type_primitive type.Z * type.type_primitive type.Zptr) (type.type_primitive type.Z)) + := match idc with + | ident.Z_add_with_get_carry_concrete s + => option_map Z_add_with_get_carry (maybe_log2 s) + | ident.Z_sub_with_get_borrow_concrete s + => option_map Z_sub_with_get_borrow (maybe_log2 s) + | _ => None + end. + + Definition make_uniform_assign_expr_of_PHOAS + {s} (e1 : @Compilers.expr.expr base.type ident.ident var_data s) + {d} (e2 : var_data s -> var_data d -> option expr) + (count : positive) + (make_name : positive -> option string) + (v : var_data d) + : option expr + := match s return (@Compilers.expr.expr base.type ident.ident var_data s) + -> (var_data s -> var_data d -> option expr) + -> option expr + with + | type.base (base.type.type_base base.type.Z) + => fun e1 e2 + => (e1 <- arith_expr_of_base_PHOAS e1 None; + let '(e1, r1) := e1 in + n1 <- make_name count; + e2 <- e2 (n1, r1) v; + Some ((Assign true type.Z r1 n1 e1) + :: e2)) + | type.base (base.type.Z * base.type.Z)%etype + => fun e1 e2 + => let '((r1, r2), e1)%core + := match invert_Z_cast2 e1 with + | Some ((r1, r2), e) => ((Some (int.of_zrange_relaxed r1), Some (int.of_zrange_relaxed r2)), e) + | None => ((None, None), e1) + end%core in + match e1 with + | (#idc @ x1 @ x2) + => idc <- recognize_ident_2arg idc; + make_assign_2arg_1ref + r1 r2 + x1 x2 idc count make_name v + (fun v rv => e2 rv v) + | (#idc @ x1 @ x2 @ x3) + => idc <- recognize_ident_3arg idc; + make_assign_3arg_1ref + r1 r2 + x1 x2 x3 idc count make_name v + (fun v rv => e2 rv v) + | _ => None + end%expr_pat + | _ => fun _ _ => None + end%option e1 e2. + Definition make_assign_expr_of_PHOAS + {s} (e1 : @Compilers.expr.expr base.type ident.ident var_data s) + {s' d} (e2 : var_data s' -> var_data d -> option expr) + (count : positive) + (make_name : positive -> option string) + (v : var_data d) + : option expr + := (e1 <- type.try_transport base.try_make_transport_cps _ _ _ e1; + make_uniform_assign_expr_of_PHOAS e1 e2 count make_name v). + + Fixpoint expr_of_base_PHOAS + {t} + (e : @Compilers.expr.expr base.type ident.ident var_data t) + (count : positive) + (make_name : positive -> option string) + {struct e} + : forall (ret_val : var_data t), option expr + := match e in expr.expr t return var_data t -> option expr with + | expr.LetIn (type.base s) d e1 e2 + => make_assign_expr_of_PHOAS + e1 + (fun vs vd => @expr_of_base_PHOAS d (e2 vs) (size_of_type s + count)%positive make_name vd) + count make_name + | expr.LetIn (type.arrow _ _) _ _ _ as e + | expr.Var _ _ as e + | expr.Ident _ _ as e + | expr.App _ _ _ _ as e + | expr.Abs _ _ _ as e + => fun v => make_return_assignment_of_arith v e + end%expr_pat%option. + + Fixpoint base_var_data_of_bounds {t} + (count : positive) + (make_name : positive -> option string) + {struct t} + : ZRange.type.base.option.interp t -> option (positive * var_data t) + := match t return ZRange.type.base.option.interp t -> option (positive * var_data t) with + | base.type.Z + => fun r => (n <- make_name count; + Some (Pos.succ count, (n, option_map int.of_zrange_relaxed r))) + | base.type.prod A B + => fun '(ra, rb) + => (va <- @base_var_data_of_bounds A count make_name ra; + let '(count, va) := va in + vb <- @base_var_data_of_bounds B count make_name rb; + let '(count, vb) := vb in + Some (count, (va, vb))) + | base.type.list base.type.Z + => fun r + => (ls <- r; + n <- make_name count; + Some (Pos.succ count, + (n, + match List.map (option_map int.of_zrange_relaxed) ls with + | nil => None + | cons x xs + => List.fold_right + (fun r1 r2 => r1 <- r1; r2 <- r2; Some (int.union r1 r2)) + x + xs + end, + length ls))) + | base.type.unit + => fun _ => Some (count, tt) + | base.type.list _ + | base.type.type_base _ + => fun _ => None + end%option. + + Definition var_data_of_bounds {t} + (count : positive) + (make_name : positive -> option string) + : ZRange.type.option.interp t -> option (positive * var_data t) + := match t with + | type.base t => base_var_data_of_bounds count make_name + | type.arrow s d => fun _ => None + end. + + Fixpoint expr_of_PHOAS + {t} + (e : @Compilers.expr.expr base.type ident.ident var_data t) + (make_name : positive -> option string) + (inbounds : type.for_each_lhs_of_arrow ZRange.type.option.interp t) + (outbounds : ZRange.type.option.interp (type.final_codomain t)) + (count : positive) + {struct t} + : option (type.for_each_lhs_of_arrow var_data t * var_data (type.final_codomain t) * expr) + := match t return @Compilers.expr.expr base.type ident.ident var_data t -> type.for_each_lhs_of_arrow ZRange.type.option.interp t -> ZRange.type.option.interp (type.final_codomain t) -> option (type.for_each_lhs_of_arrow var_data t * var_data (type.final_codomain t) * expr) with + | type.base t + => fun e tt outbounds + => vd <- var_data_of_bounds count make_name outbounds; + let '(count, vd) := vd in + rv <- expr_of_base_PHOAS e count make_name vd; + Some (tt, vd, rv) + | type.arrow s d + => fun e '(inbound, inbounds) outbounds + => vs <- var_data_of_bounds count make_name inbound; + let '(count, vs) := vs in + f <- invert_Abs e; + ret <- @expr_of_PHOAS d (f vs) make_name inbounds outbounds count; + let '(vss, vd, rv) := ret in + Some (vs, vss, vd, rv) + end%option%core%expr e inbounds outbounds. + + Definition ExprOfPHOAS + {t} + (e : @Compilers.expr.Expr base.type ident.ident t) + (name_list : option (list string)) + (inbounds : type.for_each_lhs_of_arrow ZRange.type.option.interp t) + : option (type.for_each_lhs_of_arrow var_data t * var_data (type.final_codomain t) * expr) + := (let outbounds := partial.Extract e inbounds in + let make_name := match name_list with + | None => fun p => Some ("x" ++ decimal_string_of_Z (Zpos p)) + | Some ls => fun p => List.nth_error ls (pred (Pos.to_nat p)) + end in + expr_of_PHOAS (e _) make_name inbounds outbounds 1). + End OfPHOAS. + + Module primitive. + Definition small_enough (v : Z) : bool + := Z.log2_up (Z.abs v + 1) <=? 128. + Definition to_UL_postfix (r : zrange) : string + := let lower := lower r in + let upper := upper r in + let u := (if lower >=? 0 then "U" else "") in + let sz := Z.log2_up (Z.max (Z.abs upper + 1) (Z.abs lower)) in + if sz <=? 32 + then "" + else if sz <=? 64 + then u ++ "L" + else if sz <=? 128 + then u ++ "LL" + else " /* " ++ HexString.of_Z lower ++ " <= val <= " ++ HexString.of_Z upper ++ " */". + + Definition to_string {t : type.primitive} (v : BinInt.Z) : string + := match t with + | type.Z => HexString.of_Z v ++ (if small_enough v + then to_UL_postfix r[v~>v] + else "ℤ") + | type.Zptr => "#error ""literal address " ++ HexString.of_Z v ++ """;" + end. + End primitive. + + Module String. + Definition typedef_header : list string + := ["typedef unsigned char uint1_t;"]%string. + Module int. + Module type. + Definition to_string (t : int.type) : string + := ((if int.is_unsigned t then "u" else "") + ++ "int" + ++ decimal_string_of_Z (int.bitwidth_of t) + ++ "_t")%string. + End type. + End int. + + Module type. + Module primitive. + Definition to_string (t : type.primitive) (r : option int.type) : string + := match r with + | Some int_t => int.type.to_string int_t + | None => "ℤ" + end ++ match t with + | type.Zptr => "*" + | type.Z => "" + end. + End primitive. + End type. + End String. + + Fixpoint arith_to_string {t} (e : arith_expr t) : string + := match e with + | (literal v @@ _) => primitive.to_string (t:=type.Z) v + | (List_nth n @@ Var _ v) + => "(" ++ v ++ "[" ++ decimal_string_of_Z (Z.of_nat n) ++ "])" + | (Addr @@ Var _ v) => "&" ++ v + | (Dereference @@ e) => "( *" ++ @arith_to_string _ e ++ " )" + | (Z_shiftr offset @@ e) + => "(" ++ @arith_to_string _ e ++ " >> " ++ decimal_string_of_Z offset ++ ")" + | (Z_shiftl offset @@ e) + => "(" ++ @arith_to_string _ e ++ " << " ++ decimal_string_of_Z offset ++ ")" + | (Z_land mask @@ e) + => "(" ++ @arith_to_string _ e ++ " & " ++ primitive.to_string (t:=type.Z) mask ++ ")" + | (Z_add @@ (x1, x2)) + => "(" ++ @arith_to_string _ x1 ++ " + " ++ @arith_to_string _ x2 ++ ")" + | (Z_mul @@ (x1, x2)) + => "(" ++ @arith_to_string _ x1 ++ " * " ++ @arith_to_string _ x2 ++ ")" + | (Z_sub @@ (x1, x2)) + => "(" ++ @arith_to_string _ x1 ++ " - " ++ @arith_to_string _ x2 ++ ")" + | (Z_opp @@ e) + => "(-" ++ @arith_to_string _ e ++ ")" + | (Z_mul_split lg2s @@ (x1, x2, x3)) + => "_mulx_u" + ++ decimal_string_of_Z lg2s ++ "(" + ++ @arith_to_string _ x1 ++ ", " + ++ @arith_to_string _ x2 ++ ", " + ++ @arith_to_string _ x3 ++ ")" + | (Z_add_get_carry lg2s @@ (x1, x2, x3)) + => "_add_carryx_u" + ++ decimal_string_of_Z lg2s ++ "(0, " + ++ @arith_to_string _ x1 ++ ", " + ++ @arith_to_string _ x2 ++ ", " + ++ @arith_to_string _ x3 ++ ")" + | (Z_add_with_get_carry lg2s @@ (x1, x2, x3, x4)) + => "_add_carryx_u" + ++ decimal_string_of_Z lg2s ++ "(" + ++ @arith_to_string _ x1 ++ ", " + ++ @arith_to_string _ x2 ++ ", " + ++ @arith_to_string _ x3 ++ ", " + ++ @arith_to_string _ x4 ++ ")" + | (Z_sub_get_borrow lg2s @@ (x1, x2, x3)) + => "_subborrow_u" + ++ decimal_string_of_Z lg2s ++ "(0, " + ++ @arith_to_string _ x1 ++ ", " + ++ @arith_to_string _ x2 ++ ", " + ++ @arith_to_string _ x3 ++ ")" + | (Z_sub_with_get_borrow lg2s @@ (x1, x2, x3, x4)) + => "_subborrow_u" + ++ decimal_string_of_Z lg2s ++ "(" + ++ @arith_to_string _ x1 ++ ", " + ++ @arith_to_string _ x2 ++ ", " + ++ @arith_to_string _ x3 ++ ", " + ++ @arith_to_string _ x4 ++ ")" + | (Z_zselect @@ (cond, et, ef)) => "#error zselect;" + | (Z_add_modulo @@ (x1, x2, x3)) => "#error addmodulo;" + | (Z_static_cast int_t @@ e) + => "(" ++ String.type.primitive.to_string type.Z (Some int_t) ++ ")" + ++ @arith_to_string _ e + | Var _ v => v + | (List_nth _ @@ _) + | (Addr @@ _) + | (Z_add @@ _) + | (Z_mul @@ _) + | (Z_sub @@ _) + | (Z_mul_split _ @@ _) + | (Z_add_get_carry _ @@ _) + | (Z_add_with_get_carry _ @@ _) + | (Z_sub_get_borrow _ @@ _) + | (Z_sub_with_get_borrow _ @@ _) + | (Z_zselect @@ _) + | (Z_add_modulo @@ _) + => "#error bad_arg;" + | Pair A B a b + => "#error pair;" + | TT + => "#error tt;" + end%core%Cexpr. + + Fixpoint stmt_to_string (e : stmt) : string + := match e with + | Assign true t sz name val + => String.type.primitive.to_string t sz ++ " " ++ name ++ " = " ++ arith_to_string val ++ ";" + | Assign false _ sz name val + => name ++ " = " ++ arith_to_string val ++ ";" + | AssignZPtr name sz val + => "*" ++ name ++ " = " ++ arith_to_string val ++ ";" + | DeclareVar t sz name + => String.type.primitive.to_string t sz ++ " " ++ name ++ ";" + | AssignNth name n val + => name ++ "[" ++ decimal_string_of_Z (Z.of_nat n) ++ "] = " ++ arith_to_string val ++ ";" + end. + Definition to_strings (e : expr) : list string + := List.map stmt_to_string e. + + Import OfPHOAS. + + Fixpoint to_base_arg_list {t} : base_var_data t -> list string + := match t return base_var_data t -> _ with + | base.type.Z + => fun '(n, r) => [String.type.primitive.to_string type.Z r ++ " " ++ n] + | base.type.prod A B + => fun '(va, vb) => (@to_base_arg_list A va ++ @to_base_arg_list B vb)%list + | base.type.list base.type.Z + => fun '(n, r, len) => [String.type.primitive.to_string type.Z r ++ " " ++ n ++ "[" ++ decimal_string_of_Z (Z.of_nat len) ++ "]"] + | base.type.list _ => fun _ => ["#error ""complex list"";"] + | base.type.unit => fun _ => ["#error unit;"] + | base.type.nat => fun _ => ["#error ℕ;"] + | base.type.bool => fun _ => ["#error bool;"] + end. + + Definition to_arg_list {t} : var_data t -> list string + := match t return var_data t -> _ with + | type.base t => to_base_arg_list + | type.arrow _ _ => fun _ => ["#error arrow;"] + end. + + Fixpoint to_arg_list_for_each_lhs_of_arrow {t} : type.for_each_lhs_of_arrow var_data t -> list string + := match t return type.for_each_lhs_of_arrow var_data t -> _ with + | type.base t => fun _ => nil + | type.arrow s d + => fun '(x, xs) + => to_arg_list x ++ @to_arg_list_for_each_lhs_of_arrow d xs + end%list. + + Fixpoint to_base_retarg_list {t} : base_var_data t -> list string + := match t return base_var_data t -> _ with + | base.type.Z + => fun '(n, r) => [String.type.primitive.to_string type.Zptr r ++ " " ++ n] + | base.type.prod A B + => fun '(va, vb) => (@to_base_retarg_list A va ++ @to_base_retarg_list B vb)%list + | base.type.list base.type.Z + => fun '(n, r, len) => [String.type.primitive.to_string type.Z r ++ " " ++ n ++ "[" ++ decimal_string_of_Z (Z.of_nat len) ++ "]"] + | base.type.list _ => fun _ => ["#error ""complex list"";"] + | base.type.unit => fun _ => ["#error unit;"] + | base.type.nat => fun _ => ["#error ℕ;"] + | base.type.bool => fun _ => ["#error bool;"] + end. + + Definition to_retarg_list {t} : var_data t -> list string + := match t return var_data t -> _ with + | type.base _ => to_base_arg_list + | type.arrow _ _ => fun _ => ["#error arrow;"] + end. + + Definition to_function_lines (name : string) + {t} + (f : type.for_each_lhs_of_arrow var_data t * var_data (type.final_codomain t) * expr) + : list string + := let '(args, rets, body) := f in + (((("void " + ++ name ++ "(" + ++ (String.concat ", " (to_arg_list_for_each_lhs_of_arrow args ++ to_retarg_list rets)) + ++ ") {")%string) + :: (List.map (fun s => " " ++ s)%string (to_strings body))) + ++ ["}"])%list. + + Local Notation NewLine := (String "010" "") (only parsing). + + Definition ToFunctionLines (name : string) + {t} + (e : @Compilers.expr.Expr base.type ident.ident t) + (name_list : option (list string)) + (inbounds : type.for_each_lhs_of_arrow ZRange.type.option.interp t) + : option (list string) + := (f <- ExprOfPHOAS e name_list inbounds; + Some (to_function_lines name f)). + + Definition LinesToString (lines : list string) + : string + := String.concat NewLine lines. + + Definition ToFunctionString (name : string) + {t} + (e : @Compilers.expr.Expr base.type ident.ident t) + (name_list : option (list string)) + (inbounds : type.for_each_lhs_of_arrow ZRange.type.option.interp t) + : option string + := (ls <- ToFunctionLines name e name_list inbounds; + Some (LinesToString ls)). + End C. + Notation ToFunctionLines := C.ToFunctionLines. + Notation ToFunctionString := C.ToFunctionString. + Notation LinesToString := C.LinesToString. + End ToString. +End Compilers. diff --git a/src/Experiments/NewPipeline/CompilersTestCases.v b/src/Experiments/NewPipeline/CompilersTestCases.v new file mode 100644 index 000000000..f69a0db42 --- /dev/null +++ b/src/Experiments/NewPipeline/CompilersTestCases.v @@ -0,0 +1,376 @@ +Require Import Coq.ZArith.ZArith. +Require Import Coq.Lists.List. +Require Import Crypto.Util.ZRange. +Require Import Crypto.Util.LetIn. +Require Import Crypto.Experiments.NewPipeline.Language. +Require Import Crypto.Experiments.NewPipeline.UnderLets. +Require Import Crypto.Experiments.NewPipeline.AbstractInterpretation. +Require Import Crypto.Experiments.NewPipeline.Rewriter. +Require Import Crypto.Experiments.NewPipeline.MiscCompilerPasses. +Require Import Crypto.Experiments.NewPipeline.CStringification. +Import ListNotations. Local Open Scope Z_scope. + +Import Language.Compilers. +Import UnderLets.Compilers. +Import AbstractInterpretation.Compilers. +Import Rewriter.Compilers. +Import MiscCompilerPasses.Compilers. +Import CStringification.Compilers. +Local Coercion Z.of_nat : nat >-> Z. +Import Compilers.defaults. + +Local Notation "x + y" + := ((#ident.Z_add @ x @ y)%expr) + : expr_scope. +Local Notation "x * y" + := ((#ident.Z_mul @ x @ y)%expr) + : expr_scope. +Local Notation "x" := (expr.Var x) (only printing, at level 9) : expr_scope. + +Example test1 : True. +Proof. + let v := Reify ((fun x => 2^x) 255)%Z in + pose v as E. + vm_compute in E. + pose (PartialEvaluate E) as E'. + vm_compute in E'. + lazymatch (eval cbv delta [E'] in E') with + | (fun var => expr.Ident (ident.Literal ?v)) => idtac + end. + constructor. +Qed. +Module testrewrite. + Import expr. + Import ident. + + Eval compute in RewriteRules.Rewrite (fun var => + (#ident.fst @ (expr_let x := ##10 in ($x, $x)))%expr). + + Notation "x + y" := (@expr.Ident base.type ident _ _ ident.Z_add @ x @ y)%expr : expr_scope. + + Eval compute in RewriteRules.Rewrite (fun var => + ((\ x , expr_let y := ##5 in #ident.fst @ $x + (#ident.fst @ $x + ($y + $y))) + @ (##1, ##1))%expr). + + Eval compute in RewriteRules.Rewrite (fun var => + ((\ x , expr_let y := ##5 in $y + ($y + (#ident.fst @ $x + #ident.snd @ $x))) + @ (##1, ##7))%expr). + + + Eval cbv in partial.eval_with_bound (RewriteRules.Rewrite (fun var => + (\z , ((\ x , expr_let y := ##5 in $y + ($z + (#ident.fst @ $x + #ident.snd @ $x))) + @ (##1, ##7)))%expr) _) + (Some r[0~>100]%zrange, tt). +End testrewrite. +Module testpartial. + Import expr. + Import ident. + + Eval compute in partial.eval + (#ident.fst @ (expr_let x := ##10 in ($x, $x)))%expr. + + Notation "x + y" := (@expr.Ident base.type ident _ _ (ident.Z_add) @ x @ y)%expr : expr_scope. + + Eval compute in partial.eval + ((\ x , expr_let y := ##5 in #ident.fst @ $x + (#ident.fst @ $x + ($y + $y))) + @ (##1, ##1))%expr. + + Eval compute in partial.eval + ((\ x , expr_let y := ##5 in $y + ($y + (#ident.fst @ $x + #ident.snd @ $x))) + @ (##1, ##7))%expr. + + + Eval cbv in partial.eval_with_bound + (\z , ((\ x , expr_let y := ##5 in $y + ($z + (#ident.fst @ $x + #ident.snd @ $x))) + @ (##1, ##7)))%expr + (Some r[0~>100]%zrange, tt). +End testpartial. + +Module test2. + Example test2 : True. + Proof. + let v := Reify (fun y : Z + => (fun k : Z * Z -> Z * Z + => dlet_nd x := (y * y) in + dlet_nd z := (x * x) in + k (z, z)) + (fun v => v)) in + pose v as E. + vm_compute in E. + pose (partial.Eval E) as E'. + vm_compute in E'. + lazymatch (eval cbv delta [E'] in E') with + | (fun var : type -> Type => + (λ x : var _, + expr_let x0 := ($x * $x) in + expr_let x1 := ($x0 * $x0) in + ($x1, $x1))%expr) => idtac + end. + pose (partial.EvalWithBound E' (Some r[0~>10]%zrange, tt)) as E''. + lazy in E''. + lazymatch (eval cbv delta [E''] in E'') with + | (fun var : type -> Type => + (λ x : var _, + expr_let y := #(ident.Z_cast r[0 ~> 100]) @ ((#(ident.Z_cast r[0 ~> 10]) @ $x) * (#(ident.Z_cast r[0 ~> 10]) @ $x)) in + expr_let y0 := #(ident.Z_cast r[0 ~> 10000]) @ ((#(ident.Z_cast r[0 ~> 100]) @ $y) * (#(ident.Z_cast r[0 ~> 100]) @ $y)) in + (#(ident.Z_cast r[0 ~> 10000]) @ $y0, #(ident.Z_cast r[0 ~> 10000]) @ $y0))%expr) + => idtac + end. + constructor. + Qed. +End test2. +Module test3. + Example test3 : True. + Proof. + let v := Reify (fun y : Z + => dlet_nd x := dlet_nd x := (y * y) in + (x * x) in + dlet_nd z := dlet_nd z := (x * x) in + (z * z) in + (z * z)) in + pose v as E. + vm_compute in E. + pose (partial.Eval E) as E'. + vm_compute in E'. + lazymatch (eval cbv delta [E'] in E') with + | (fun var : type -> Type => + (λ x : var _, + expr_let x0 := $x * $x in + expr_let x1 := $x0 * $x0 in + expr_let x2 := $x1 * $x1 in + expr_let x3 := $x2 * $x2 in + $x3 * $x3)%expr) + => idtac + end. + pose (partial.EvalWithBound E' (Some r[0~>10]%zrange, tt)) as E'''. + lazy in E'''. + lazymatch (eval cbv delta [E'''] in E''') with + | (fun var : type -> Type => + (λ x : var _, + expr_let y := #(ident.Z_cast r[0 ~> 100]) @ ((#(ident.Z_cast r[0 ~> 10]) @ $x) * (#(ident.Z_cast r[0 ~> 10]) @ $x)) in + expr_let y0 := #(ident.Z_cast r[0 ~> 10000]) @ ((#(ident.Z_cast r[0 ~> 100]) @ $y) * (#(ident.Z_cast r[0 ~> 100]) @ $y)) in + expr_let y1 := #(ident.Z_cast r[0 ~> 100000000]) @ ((#(ident.Z_cast r[0 ~> 10000]) @ $y0) * (#(ident.Z_cast r[0 ~> 10000]) @ $y0)) in + expr_let y2 := #(ident.Z_cast r[0 ~> 10000000000000000]) @ ((#(ident.Z_cast r[0 ~> 100000000]) @ $y1) * (#(ident.Z_cast r[0 ~> 100000000]) @ $y1)) in + #(ident.Z_cast r[0 ~> 100000000000000000000000000000000]) @ ((#(ident.Z_cast r[0 ~> 10000000000000000]) @ $y2) * (#(ident.Z_cast r[0 ~> 10000000000000000]) @ $y2)))%expr) + => idtac + end. + constructor. + Qed. +End test3. +Module test3point5. + Example test3point5 : True. + Proof. + let v := Reify (fun y : (list Z) => List.nth_default (-1) y 0) in + pose v as E. + vm_compute in E. + pose (partial.EvalWithBound E (Some [Some r[0~>10]%zrange], tt)) as E'. + lazy in E'. + clear E. + lazymatch (eval cbv delta [E'] in E') with + | (fun var : type -> Type => + (λ x : var _, + #(ident.Z_cast r[0 ~> 10]) @ (#ident.List_nth_default @ #(ident.Literal (-1)%Z) @ $x @ #(ident.Literal 0%nat)))%expr) + => idtac + end. + constructor. + Qed. +End test3point5. +Module test4. + Example test4 : True. + Proof. + let v := Reify (fun y : (list Z * list Z) + => dlet_nd x := List.nth_default (-1) (fst y) 0 in + dlet_nd z := List.nth_default (-1) (snd y) 0 in + dlet_nd xz := (x * z) in + (xz :: xz :: nil)) in + pose v as E. + vm_compute in E. + pose (partial.Eval E) as E'. + lazy in E'. + clear E. + pose (Some [Some r[0~>10]%zrange],Some [Some r[0~>10]%zrange], tt) as bound. + pose (partial.EtaExpandWithListInfoFromBound E' bound) as E''. + lazy in E''. + clear E'. + pose (PartialEvaluate E'') as E'''. + lazy in E'''. + pose (partial.EvalWithBound E''' bound) as E''''. + lazy in E''''. + clear E'' E'''. + lazymatch (eval cbv delta [E''''] in E'''') with + | (fun var : type -> Type => + (λ x : var _, + expr_let y := #(ident.Z_cast r[0 ~> 10]) @ + (#ident.List_nth_default @ #(ident.Literal (-1)%Z) @ (#ident.fst @ $x) @ #(ident.Literal 0%nat)) in + expr_let y0 := #(ident.Z_cast r[0 ~> 10]) @ + (#ident.List_nth_default @ #(ident.Literal (-1)%Z) @ (#ident.snd @ $x) @ #(ident.Literal 0%nat)) in + expr_let y1 := #(ident.Z_cast r[0 ~> 100]) @ ((#(ident.Z_cast r[0 ~> 10]) @ $y) * (#(ident.Z_cast r[0 ~> 10]) @ $y0)) in + #(ident.Z_cast r[0 ~> 100]) @ $y1 :: #(ident.Z_cast r[0 ~> 100]) @ $y1 :: [])%expr) + => idtac + end. + constructor. + Qed. +End test4. +Module test5. + Example test5 : True. + Proof. + let v := Reify (fun y : (Z * Z) + => dlet_nd x := (13 * (fst y * snd y)) in + x) in + pose v as E. + vm_compute in E. + pose (ReassociateSmallConstants.Reassociate (2^8) (partial.Eval E)) as E'. + lazy in E'. + clear E. + lazymatch (eval cbv delta [E'] in E') with + | (fun var => + expr.Abs (fun v + => (expr_let v0 := (#ident.Z_mul @ (#ident.fst @ $v) @ (#ident.Z_mul @ (#ident.snd @ $v) @ #(ident.Literal 13))) in + $v0)%expr)) + => idtac + end. + constructor. + Qed. +End test5. +Module test6. + (* check for no dead code with if *) + Example test6 : True. + Proof. + let v := Reify (fun y : Z + => if 0 =? 1 + then dlet_nd x := (y * y) in + x + else y) in + pose v as E. + vm_compute in E. + pose (PartialEvaluate E) as E''. + lazy in E''. + lazymatch eval cbv delta [E''] in E'' with + | fun var : type -> Type => (λ x : var _, $x)%expr + => idtac + end. + exact I. + Qed. +End test6. +Module test7. + Example test7 : True. + Proof. + let v := Reify (fun y : Z + => dlet_nd x := y + y in + dlet_nd z := x in + dlet_nd z' := z in + dlet_nd z'' := z in + z'' + z'') in + pose v as E. + vm_compute in E. + pose (Subst01.Subst01 (DeadCodeElimination.EliminateDead E)) as E''. + lazy in E''. + lazymatch eval cbv delta [E''] in E'' with + | fun var : type -> Type => (λ x : var _, expr_let v0 := $x + $x in $v0 + $v0)%expr + => idtac + end. + exact I. + Qed. +End test7. +Module test8. + Example test8 : True. + Proof. + let v := Reify (fun y : Z + => dlet_nd x := y + y in + dlet_nd z := x in + dlet_nd z' := z in + dlet_nd z'' := z in + z'' + z'') in + pose v as E. + vm_compute in E. + pose (GeneralizeVar.GeneralizeVar (E _)) as E''. + lazy in E''. + unify E E''. + exact I. + Qed. +End test8. +Module test9. + Example test9 : True. + Proof. + let v := Reify (fun y : list Z => (hd 0%Z y, tl y)) in + pose v as E. + vm_compute in E. + pose (PartialEvaluate E) as E'. + lazy in E'. + clear E. + lazymatch (eval cbv delta [E'] in E') with + | (fun var + => (λ x, + (#ident.list_case + @ (λ _, #(ident.Literal 0%Z)) + @ (λ x0 _, $x0) + @ $x, + #ident.list_case + @ (λ _, #ident.nil) + @ (λ _ x0, $x0) + @ $x))%expr) + => idtac + end. + exact I. + Qed. +End test9. +(* +Module test10. + Example test10 : True. + Proof. + let v := Reify (fun (f : Z -> Z -> Z) x y => f (x + y) (x * y))%Z in + pose v as E. + vm_compute in E. + pose (Uncurry.expr.Uncurry (partial.Eval true (canonicalize_list_recursion E))) as E'. + lazy in E'. + clear E. + lazymatch (eval cbv delta [E'] in E') with + | (fun var => + (λ v, + ident.fst @@ $v @ + (ident.fst @@ (ident.snd @@ $v) + ident.snd @@ (ident.snd @@ $v)) @ + (ident.fst @@ (ident.snd @@ $v) * ident.snd @@ (ident.snd @@ $v)))%expr) + => idtac + end. + constructor. + Qed. +End test10. + *) +(* +Module test11. + Example test11 : True. + Proof. + let v := Reify (fun x y => (fun f a b => f a b) (fun a b => a + b) (x + y) (x * y))%Z in + pose v as E. + vm_compute in E. + pose (Uncurry.expr.Uncurry (partial.Eval true (canonicalize_list_recursion E))) as E'. + lazy in E'. + clear E. + lazymatch (eval cbv delta [E'] in E') with + | (fun var => + (λ x, + ident.fst @@ $x + ident.snd @@ $x + ident.fst @@ $x * ident.snd @@ $x)%expr) + => idtac + end. + constructor. + Qed. +End test11. + *) +Module test12. + Example test12 : True. + Proof. + let v := Reify (fun y : list Z => repeat y 2) in + pose v as E. + vm_compute in E. + pose (Some (repeat (@None zrange) 3), tt) as bound. + pose (PartialEvaluate (partial.EtaExpandWithListInfoFromBound E bound)) as E'. + lazy in E'. + clear E. + lazymatch (eval cbv delta [E'] in E') with + | (fun var + => (λ x, [ [ $x[[0]] ; $x[[1]]; $x[[2]] ] ; [ $x[[0]] ; $x[[1]]; $x[[2]] ] ])%expr) + => idtac + end. + exact I. + Qed. +End test12. diff --git a/src/Experiments/NewPipeline/ExtractionHaskell/saturated_solinas.v b/src/Experiments/NewPipeline/ExtractionHaskell/saturated_solinas.v new file mode 100644 index 000000000..fe323d3b7 --- /dev/null +++ b/src/Experiments/NewPipeline/ExtractionHaskell/saturated_solinas.v @@ -0,0 +1,4 @@ +Require Import Crypto.Experiments.NewPipeline.StandaloneHaskellMain. + +(*Redirect "/tmp/saturated_solinas.hs"*) Recursive Extraction SaturatedSolinas.main. +(* cat /tmp/solinas.hs.out | sed -f haskell.sed > ../../solinas.hs *) diff --git a/src/Experiments/NewPipeline/ExtractionHaskell/unsaturated_solinas.v b/src/Experiments/NewPipeline/ExtractionHaskell/unsaturated_solinas.v new file mode 100644 index 000000000..225649b99 --- /dev/null +++ b/src/Experiments/NewPipeline/ExtractionHaskell/unsaturated_solinas.v @@ -0,0 +1,4 @@ +Require Import Crypto.Experiments.NewPipeline.StandaloneHaskellMain. + +(*Redirect "/tmp/unsaturated_solinas.hs" *)Recursive Extraction UnsaturatedSolinas.main. +(* cat /tmp/solinas.hs.out | sed -f haskell.sed > ../../solinas.hs *) diff --git a/src/Experiments/NewPipeline/ExtractionOCaml/saturated_solinas.v b/src/Experiments/NewPipeline/ExtractionOCaml/saturated_solinas.v new file mode 100644 index 000000000..ffca16caf --- /dev/null +++ b/src/Experiments/NewPipeline/ExtractionOCaml/saturated_solinas.v @@ -0,0 +1,3 @@ +Require Import Crypto.Experiments.NewPipeline.StandaloneOCamlMain. + +(*Redirect "/tmp/saturated_solinas.ml"*) Recursive Extraction SaturatedSolinas.main. diff --git a/src/Experiments/NewPipeline/ExtractionOCaml/unsaturated_solinas.v b/src/Experiments/NewPipeline/ExtractionOCaml/unsaturated_solinas.v new file mode 100644 index 000000000..bd37edfe2 --- /dev/null +++ b/src/Experiments/NewPipeline/ExtractionOCaml/unsaturated_solinas.v @@ -0,0 +1,3 @@ +Require Import Crypto.Experiments.NewPipeline.StandaloneOCamlMain. + +(*Redirect "/tmp/unsaturated_solinas.ml"*) Recursive Extraction UnsaturatedSolinas.main. diff --git a/src/Experiments/NewPipeline/GENERATEDIdentifiersWithoutTypes.v b/src/Experiments/NewPipeline/GENERATEDIdentifiersWithoutTypes.v new file mode 100644 index 000000000..94257f793 --- /dev/null +++ b/src/Experiments/NewPipeline/GENERATEDIdentifiersWithoutTypes.v @@ -0,0 +1,1741 @@ +Require Import Coq.ZArith.ZArith. +Require Import Crypto.Util.CPSNotations. +Require Import Crypto.Util.ZRange. +Require Import Crypto.Experiments.NewPipeline.Language. + +Module Compilers. + Export Language.Compilers. + + Module pattern. + Module ident. + Set Boolean Equality Schemes. + (*Print Compilers.ident.ident.*) + (*Show Match Compilers.ident.ident.*) + (* +<<< +#!/usr/bin/env python2 +import re + +print_ident = r"""Inductive ident : Compilers.type Compilers.base.type.type -> Set := + Literal : forall t : base.type.base, + base.interp (Compilers.base.type.type_base t) -> + ident ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base t)) + | Nat_succ : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat))%etype + | Nat_pred : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat))%etype + | Nat_max : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat))%etype + | Nat_mul : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat))%etype + | Nat_add : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat))%etype + | Nat_sub : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat))%etype + | nil : forall t : Compilers.base.type.type, ident ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list t)) + | cons : forall t : Compilers.base.type.type, + ident + ((fun x : Compilers.base.type.type => type.base x) t -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list t) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list t))%etype + | pair : forall A B : Compilers.base.type.type, + ident + ((fun x : Compilers.base.type.type => type.base x) A -> + (fun x : Compilers.base.type.type => type.base x) B -> (fun x : Compilers.base.type.type => type.base x) (A * B)%etype)%etype + | fst : forall A B : Compilers.base.type.type, + ident + ((fun x : Compilers.base.type.type => type.base x) (A * B)%etype -> (fun x : Compilers.base.type.type => type.base x) A)%etype + | snd : forall A B : Compilers.base.type.type, + ident + ((fun x : Compilers.base.type.type => type.base x) (A * B)%etype -> (fun x : Compilers.base.type.type => type.base x) B)%etype + | pair_rect : forall A B T : Compilers.base.type.type, + ident + (((fun x : Compilers.base.type.type => type.base x) A -> + (fun x : Compilers.base.type.type => type.base x) B -> (fun x : Compilers.base.type.type => type.base x) T) -> + (fun x : Compilers.base.type.type => type.base x) (A * B)%etype -> + (fun x : Compilers.base.type.type => type.base x) T)%etype + | bool_rect : forall T : Compilers.base.type.type, + ident + (((fun x : Compilers.base.type.type => type.base x) ()%etype -> (fun x : Compilers.base.type.type => type.base x) T) -> + ((fun x : Compilers.base.type.type => type.base x) ()%etype -> (fun x : Compilers.base.type.type => type.base x) T) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.bool) -> + (fun x : Compilers.base.type.type => type.base x) T)%etype + | nat_rect : forall P : Compilers.base.type.type, + ident + (((fun x : Compilers.base.type.type => type.base x) ()%etype -> (fun x : Compilers.base.type.type => type.base x) P) -> + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) P -> (fun x : Compilers.base.type.type => type.base x) P) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) P)%etype + | list_rect : forall A P : Compilers.base.type.type, + ident + (((fun x : Compilers.base.type.type => type.base x) ()%etype -> (fun x : Compilers.base.type.type => type.base x) P) -> + ((fun x : Compilers.base.type.type => type.base x) A -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list A) -> + (fun x : Compilers.base.type.type => type.base x) P -> (fun x : Compilers.base.type.type => type.base x) P) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list A) -> + (fun x : Compilers.base.type.type => type.base x) P)%etype + | list_case : forall A P : Compilers.base.type.type, + ident + (((fun x : Compilers.base.type.type => type.base x) ()%etype -> (fun x : Compilers.base.type.type => type.base x) P) -> + ((fun x : Compilers.base.type.type => type.base x) A -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list A) -> + (fun x : Compilers.base.type.type => type.base x) P) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list A) -> + (fun x : Compilers.base.type.type => type.base x) P)%etype + | List_length : forall T : Compilers.base.type.type, + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list T) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat))%etype + | List_seq : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.list (Compilers.base.type.type_base base.type.nat)))%etype + | List_repeat : forall A : Compilers.base.type.type, + ident + ((fun x : Compilers.base.type.type => type.base x) A -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list A))%etype + | List_combine : forall A B : Compilers.base.type.type, + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list A) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list B) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list (A * B)))%etype + | List_map : forall A B : Compilers.base.type.type, + ident + (((fun x : Compilers.base.type.type => type.base x) A -> (fun x : Compilers.base.type.type => type.base x) B) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list A) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list B))%etype + | List_app : forall A : Compilers.base.type.type, + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list A) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list A) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list A))%etype + | List_rev : forall A : Compilers.base.type.type, + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list A) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list A))%etype + | List_flat_map : forall A B : Compilers.base.type.type, + ident + (((fun x : Compilers.base.type.type => type.base x) A -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list B)) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list A) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list B))%etype + | List_partition : forall A : Compilers.base.type.type, + ident + (((fun x : Compilers.base.type.type => type.base x) A -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.bool)) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list A) -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.list A * Compilers.base.type.list A)%etype)%etype + | List_fold_right : forall A B : Compilers.base.type.type, + ident + (((fun x : Compilers.base.type.type => type.base x) B -> + (fun x : Compilers.base.type.type => type.base x) A -> (fun x : Compilers.base.type.type => type.base x) A) -> + (fun x : Compilers.base.type.type => type.base x) A -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list B) -> + (fun x : Compilers.base.type.type => type.base x) A)%etype + | List_update_nth : forall T : Compilers.base.type.type, + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + ((fun x : Compilers.base.type.type => type.base x) T -> (fun x : Compilers.base.type.type => type.base x) T) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list T) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list T))%etype + | List_nth_default : forall T : Compilers.base.type.type, + ident + ((fun x : Compilers.base.type.type => type.base x) T -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.list T) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) T)%etype + | Z_add : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_mul : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_pow : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_sub : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_opp : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_div : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_modulo : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_eqb : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.bool))%etype + | Z_leb : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.bool))%etype + | Z_of_nat : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.nat) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_shiftr : Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_shiftl : Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_land : Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_mul_split : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_mul_split_concrete : Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_add_get_carry : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_add_get_carry_concrete : Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_add_with_carry : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_add_with_get_carry : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_add_with_get_carry_concrete : Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_sub_get_borrow : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_sub_get_borrow_concrete : Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_sub_with_get_borrow : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_sub_with_get_borrow_concrete : Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_zselect : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_add_modulo : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_rshi : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_rshi_concrete : Z -> + Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_cc_m : ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_cc_m_concrete : Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_neg_snd : ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_cast : zrange -> + ident + ((fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z) -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | Z_cast2 : zrange * zrange -> + ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | fancy_add : Z -> + Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | fancy_addc : Z -> + Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z * + Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | fancy_sub : Z -> + Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | fancy_subb : Z -> + Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z * + Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | fancy_mulll : Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | fancy_mullh : Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | fancy_mulhl : Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | fancy_mulhh : Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | fancy_rshi : Z -> + Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | fancy_selc : ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z * + Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | fancy_selm : Z -> + ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z * + Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | fancy_sell : ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z * + Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype + | fancy_addm : ident + ((fun x : Compilers.base.type.type => type.base x) + (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z * + Compilers.base.type.type_base base.type.Z)%etype -> + (fun x : Compilers.base.type.type => type.base x) (Compilers.base.type.type_base base.type.Z))%etype +""" +show_match_ident = r"""match # with + | ident.Literal t v => + | ident.Nat_succ => + | ident.Nat_pred => + | ident.Nat_max => + | ident.Nat_mul => + | ident.Nat_add => + | ident.Nat_sub => + | ident.nil t => + | ident.cons t => + | ident.pair A B => + | ident.fst A B => + | ident.snd A B => + | ident.pair_rect A B T => + | ident.bool_rect T => + | ident.nat_rect P => + | ident.list_rect A P => + | ident.list_case A P => + | ident.List_length T => + | ident.List_seq => + | ident.List_repeat A => + | ident.List_combine A B => + | ident.List_map A B => + | ident.List_app A => + | ident.List_rev A => + | ident.List_flat_map A B => + | ident.List_partition A => + | ident.List_fold_right A B => + | ident.List_update_nth T => + | ident.List_nth_default T => + | ident.Z_add => + | ident.Z_mul => + | ident.Z_pow => + | ident.Z_sub => + | ident.Z_opp => + | ident.Z_div => + | ident.Z_modulo => + | ident.Z_eqb => + | ident.Z_leb => + | ident.Z_of_nat => + | ident.Z_shiftr offset => + | ident.Z_shiftl offset => + | ident.Z_land mask => + | ident.Z_mul_split => + | ident.Z_mul_split_concrete s => + | ident.Z_add_get_carry => + | ident.Z_add_get_carry_concrete s => + | ident.Z_add_with_carry => + | ident.Z_add_with_get_carry => + | ident.Z_add_with_get_carry_concrete s => + | ident.Z_sub_get_borrow => + | ident.Z_sub_get_borrow_concrete s => + | ident.Z_sub_with_get_borrow => + | ident.Z_sub_with_get_borrow_concrete s => + | ident.Z_zselect => + | ident.Z_add_modulo => + | ident.Z_rshi => + | ident.Z_rshi_concrete s offset => + | ident.Z_cc_m => + | ident.Z_cc_m_concrete s => + | ident.Z_neg_snd => + | ident.Z_cast range => + | ident.Z_cast2 range => + | ident.fancy_add log2wordmax imm => + | ident.fancy_addc log2wordmax imm => + | ident.fancy_sub log2wordmax imm => + | ident.fancy_subb log2wordmax imm => + | ident.fancy_mulll log2wordmax => + | ident.fancy_mullh log2wordmax => + | ident.fancy_mulhl log2wordmax => + | ident.fancy_mulhh log2wordmax => + | ident.fancy_rshi log2wordmax x => + | ident.fancy_selc => + | ident.fancy_selm log2wordmax => + | ident.fancy_sell => + | ident.fancy_addm => + end + +""" +prefix = 'Compilers.' +indent = ' ' +exts = ('Unit', 'Z', 'Bool', 'Nat') +tys = [('%sbase.type.' % prefix) + i for i in ('unit', 'Z', 'bool', 'nat')] +type_or_set = 'Type' +ctors = [i.strip('|=> ').split(' ') for i in show_match_ident.split('\n') if i.strip().startswith('|')] +assert(ctors[0][0] == 'ident.Literal') +assert(len(ctors[0]) > 1) +ctors = [[ctors[0][0] + ext] + ctors[0][2:] for ext in exts] + ctors[1:] +ctors_with_prefix = [[prefix + i[0]] + i[1:] for i in ctors] +ctors_no_prefix = [[i[0].replace('ident.', '')] + i[1:] for i in ctors] +pctors = [i[0] for i in ctors_no_prefix] +def get_dep_types(case): + dep_tys = re.findall('forall ([^:]+):([^,]+),', case) + if len(dep_tys) == 0: return [] + dep_tys = dep_tys[0] + return [dep_tys[-1].strip()] * len([i for i in dep_tys[0].split(' ') if i.strip()]) +ttypes = ([[] for ty in tys] + + [get_dep_types(case) + for case in print_ident.replace('\n', ' ').split('|')[1:]]) +ctypes = ([['base.interp ' + ty] for ty in tys] + + [[i.strip() for i in re.sub(r'forall [^:]+ : %sbase.type.type,' % prefix, '', i[i.find(':')+1:i.find('ident')]).strip(' ->').split('->') if i.strip()] + for i in print_ident.replace('\n', ' ').split('|')[1:]]) +crettypes = ([('%sident.ident (type.base (%sbase.type.type_base ' + ty + '))') % (prefix, prefix) for ty in tys] + + [prefix + 'ident.' + re.sub(r'\(fun x : [^ ]+ => ([^ ]+) x\)', r'\1', re.sub(' +', ' ', i[i.find('ident'):])) + for i in print_ident.replace('\n', ' ').split('|')[1:]]) + +retcode = r"""Require Import Coq.ZArith.ZArith. +Require Import Crypto.Util.CPSNotations. +Require Import Crypto.Util.ZRange. +Require Import Crypto.Experiments.NewPipeline.Language. + +Module Compilers. + Export Language.Compilers. + + Module pattern. + Module ident. + Set Boolean Equality Schemes. + (*Print Compilers.ident.ident.*) + (*Show Match Compilers.ident.ident.*) +""" + +def addnewline(s): return s + '\n' + +retcode += addnewline(r"""%s(* +<<< +%s +>>> +%s*) +""" % (indent, open(__file__).read(), indent)) +retcode += addnewline(r"""%sInductive ident := +%s| %s. +""" % (indent, indent, ('\n' + indent + '| ').join(pctors))) +#retcode += addnewline((r"""%sDefinition beq_typed {t} (X : ident) (Y : %sident.ident t) : bool +# := match X, Y with +# | %s +# => true +# | %s +# => false +# end. +#""" % (indent, prefix, +# '\n | '.join(pctor + ', ' + ' '.join([ctor[0]] + ['_'] * (len(ctor)-1)) +# for pctor, ctor in zip(pctors, ctors_with_prefix)), +# '\n | '.join(pctor + ', _' for pctor in pctors))).replace('\n', '\n' + indent)) +retcode += addnewline((r"""%sDefinition try_make_transport_ident_cps (P : ident -> Type) (idc1 idc2 : ident) : ~> option (P idc1 -> P idc2) + := match idc1, idc2 with + | %s + => fun T k => k (Some (fun v => v)) + | %s + => fun T k => k None + end%%cps. +""" % (indent, + '\n | '.join(pctor + ', ' + pctor for pctor in pctors), + '\n | '.join(pctor + ', _' for pctor in pctors))).replace('\n', '\n' + indent)) +retcode += addnewline((r"""%sDefinition eta_ident_cps {T : %stype %sbase.type -> Type} {t} (idc : %sident.ident t) + (f : forall t', %sident.ident t' -> T t') + : T t + := match idc with + | %s + end. +""" % (indent, prefix, prefix, prefix, prefix, + '\n | '.join(' '.join(ctor) + ' => f _ ' + + (('%s' if len(ctor) == 1 else '(@%s)') + % ' '.join(ctor)) + for ctor in ctors_with_prefix))).replace('\n', '\n' + indent)) +#retcode += addnewline((r"""%sDefinition eta_all_option_cps {T} (f : ident -> option T) +# : option (ident -> T) +# := (%s; +# Some (fun c +# => match c with +# | %s +# end))%%option. +#""" % (indent, +# ';\n '.join('f' + pctor + ' <- f ' + ctor[0] for ctor, pctor in zip(ctors_no_prefix, pctors)), +# '\n | '.join(ctor[0] + ' => f' + pctor for pctor, ctor in zip(pctors, ctors_no_prefix)))).replace('\n', '\n' + indent)) +retcode += addnewline((r"""%sDefinition of_typed_ident {t} (idc : %sident.ident t) : ident + := match idc with + | %s + end. +""" % (indent, prefix, '\n | '.join(' '.join(ctor) + ' => ' + pctor for ctor, pctor in zip(ctors_with_prefix, pctors)))).replace('\n', '\n' + indent)) +#retcode += addnewline((r"""%sDefinition orb (f : ident -> bool) : bool +# := (%s)%%bool. +#""" % (indent, ' || '.join('f ' + pctor for pctor in pctors))).replace('\n', '\n' + indent)) +retcode += addnewline((r"""%sDefinition arg_types (idc : ident) : option %s + := match idc return option %s with + | %s + end%%type. +""" % (indent, type_or_set, type_or_set, + '\n | '.join(pctor + ' => ' + ('None' if len(ctype) == 0 else '@Some ' + type_or_set + ' ' + (ctype[0] if ' ' not in ' * '.join(ctype) else '(%s)' % ' * '.join(ctype))) + for pctor, ctype in zip(pctors, ctypes)))).replace('\n', '\n' + indent)) +retcode += addnewline((r"""%sDefinition full_types (idc : ident) : %s + := match idc return %s with + | %s + end%%type. +""" % (indent, type_or_set, type_or_set, + '\n | '.join(pctor + ' => ' + (' * '.join(ttype + ctype) if len(ttype + ctype) > 0 else 'unit') + for pctor, ttype, ctype in zip(pctors, ttypes, ctypes)))).replace('\n', '\n' + indent)) + +retcode += addnewline((r"""%sDefinition bind_args {t} (idc : %sident.ident t) : match arg_types (of_typed_ident idc) return %s with Some t => t | None => unit end + := match idc return match arg_types (of_typed_ident idc) return %s with Some t => t | None => unit end with + | %s + end%%cps. +""" % (indent, prefix, type_or_set, type_or_set, + '\n | '.join(' '.join(ctor) + ' => ' + ('tt' if len(ctype) == 0 else (ctor[-1] if len(ctype) == 1 else '(%s)' % ', '.join(ctor[-len(ctype):]))) + for ctor, ctype in zip(ctors_with_prefix, ctypes)))).replace('\n', '\n' + indent)) +retcode += addnewline((r"""%sDefinition invert_bind_args {t} (idc : %sident.ident t) (pidc : ident) : option (full_types pidc) + := match pidc, idc return option (full_types pidc) with + | %s + | %s + => None + end%%cps. +""" % (indent, prefix, + '\n | '.join(pctor + ', ' + ' '.join(ctor) + ' => Some ' + ('tt' if len(ttype + ctype) == 0 else (ctor[-1] if len(ttype + ctype) == 1 else '(%s)' % ', '.join(ctor[-len(ttype + ctype):]))) + for pctor, ctor, ttype, ctype in zip(pctors, ctors_with_prefix, ttypes, ctypes)), + '\n | '.join(pctor + ', _' for pctor in pctors))).replace('\n', '\n' + indent)) + +maxeta = max([len(ttype + ctype) for ttype, ctype in zip(ttypes, ctypes)]) +if maxeta >= 2: + retcode += addnewline(r"""%sLocal Notation eta2 x := (Datatypes.fst x, Datatypes.snd x) (only parsing).""" % indent) +for i in range(3, maxeta+1): + retcode += addnewline(r"""%sLocal Notation eta%d x := (eta%d (Datatypes.fst x), Datatypes.snd x) (only parsing).""" % (indent, i, i-1)) +retcode += addnewline('') + +def do_adjust_type(ctor, ctype): + return len(ctor) > 1 and 'Literal' in ctor[0] + +retcode += addnewline((r"""%sDefinition type_of (pidc : ident) : full_types pidc -> %stype %sbase.type + := match pidc return full_types pidc -> _ with + | %s + end. +""" % (indent, prefix, prefix, + '\n | '.join(pctor + ' => ' + + 'fun ' + ('_ => ' if len(ttype + ctype) == 0 else ((ctor[-1] + ' => ') if len(ttype + ctype) == 1 else "arg => let '(%s) := eta%d arg in " % (', '.join(ctor[-len(ttype + ctype):]), len(ttype + ctype)))) + cretty.replace(prefix + 'ident.ident ', '') + for pctor, ctor, ttype, ctype, cretty in zip(pctors, ctors_with_prefix, ttypes, ctypes, crettypes)))).replace('\n', '\n' + indent)) +retcode += addnewline((r"""%sDefinition to_typed (pidc : ident) : forall args : full_types pidc, %sident.ident (type_of pidc args) + := match pidc return forall args : full_types pidc, %sident.ident (type_of pidc args) with + | %s + end. +""" % (indent, prefix, prefix, + '\n | '.join(pctor + ' => ' + + 'fun ' + (('_ => %s' if len(ttype + ctype) == 0 else ((ctor[-1] + ' => %s') if len(ttype + ctype) == 1 else "arg => match eta%d arg as args' return %sident.ident (type_of %s args') with (%s) => %%s end" % (len(ttype + ctype), prefix, pctor, ', '.join(ctor[-len(ttype + ctype):])))) % ("@" + ' '.join(ctor))) + for pctor, ctor, ttype, ctype in zip(pctors, ctors_with_prefix, ttypes, ctypes)))).replace('\n', '\n' + indent)) +retcode += addnewline((r"""%sDefinition retype_ident {t} (idc : %sident.ident t) : match arg_types (of_typed_ident idc) return %s with Some t => t | None => unit end -> %sident.ident t + := match idc in %sident.ident t return match arg_types (of_typed_ident idc) return %s with Some t => t | None => unit end -> %sident.ident t with + | %s + end. +""" % (indent, prefix, type_or_set, prefix, prefix, type_or_set, prefix, + '\n | '.join(' '.join(ctor) + ' => ' + + ('' if not do_adjust_type(ctor, ctype) else '(') + + 'fun ' + ('_ => ' if len(ctype) == 0 else ((ctor[-1] + ' => ') if len(ctype) == 1 else "arg => let '(%s) := eta%d arg in " % (', '.join(ctor[-len(ctype):]), len(ctype)))) + "@" + ' '.join(ctor) + + ('' if not do_adjust_type(ctor, ctype) else + (') : ' + + ('match arg_types (of_typed_ident %s) return %s with Some t => t | None => unit end -> _' + % (('%s' if ' ' not in ' '.join(ctor) else '(@%s)') % ' '.join(ctor), + type_or_set)) + + ' (* COQBUG(https://github.com/coq/coq/issues/7726) *)')) + for ctor, ctype in zip(ctors_with_prefix, ctypes)))).replace('\n', '\n' + indent)) +# ctor[:len(ctor)-len(ctype)] + ['_'] * len(ctype) + +retcode += addnewline(indent + '\n' + indent + '(*===*)') + +retcode += r""" End ident. + End pattern. +End Compilers. +""" +with open('GENERATEDIdentifiersWithoutTypes.v', 'w') as f: + f.write(retcode) + +>>> + *) + + Inductive ident := + | LiteralUnit + | LiteralZ + | LiteralBool + | LiteralNat + | Nat_succ + | Nat_pred + | Nat_max + | Nat_mul + | Nat_add + | Nat_sub + | nil + | cons + | pair + | fst + | snd + | pair_rect + | bool_rect + | nat_rect + | list_rect + | list_case + | List_length + | List_seq + | List_repeat + | List_combine + | List_map + | List_app + | List_rev + | List_flat_map + | List_partition + | List_fold_right + | List_update_nth + | List_nth_default + | Z_add + | Z_mul + | Z_pow + | Z_sub + | Z_opp + | Z_div + | Z_modulo + | Z_eqb + | Z_leb + | Z_of_nat + | Z_shiftr + | Z_shiftl + | Z_land + | Z_mul_split + | Z_mul_split_concrete + | Z_add_get_carry + | Z_add_get_carry_concrete + | Z_add_with_carry + | Z_add_with_get_carry + | Z_add_with_get_carry_concrete + | Z_sub_get_borrow + | Z_sub_get_borrow_concrete + | Z_sub_with_get_borrow + | Z_sub_with_get_borrow_concrete + | Z_zselect + | Z_add_modulo + | Z_rshi + | Z_rshi_concrete + | Z_cc_m + | Z_cc_m_concrete + | Z_neg_snd + | Z_cast + | Z_cast2 + | fancy_add + | fancy_addc + | fancy_sub + | fancy_subb + | fancy_mulll + | fancy_mullh + | fancy_mulhl + | fancy_mulhh + | fancy_rshi + | fancy_selc + | fancy_selm + | fancy_sell + | fancy_addm. + + Definition try_make_transport_ident_cps (P : ident -> Type) (idc1 idc2 : ident) : ~> option (P idc1 -> P idc2) + := match idc1, idc2 with + | LiteralUnit, LiteralUnit + | LiteralZ, LiteralZ + | LiteralBool, LiteralBool + | LiteralNat, LiteralNat + | Nat_succ, Nat_succ + | Nat_pred, Nat_pred + | Nat_max, Nat_max + | Nat_mul, Nat_mul + | Nat_add, Nat_add + | Nat_sub, Nat_sub + | nil, nil + | cons, cons + | pair, pair + | fst, fst + | snd, snd + | pair_rect, pair_rect + | bool_rect, bool_rect + | nat_rect, nat_rect + | list_rect, list_rect + | list_case, list_case + | List_length, List_length + | List_seq, List_seq + | List_repeat, List_repeat + | List_combine, List_combine + | List_map, List_map + | List_app, List_app + | List_rev, List_rev + | List_flat_map, List_flat_map + | List_partition, List_partition + | List_fold_right, List_fold_right + | List_update_nth, List_update_nth + | List_nth_default, List_nth_default + | Z_add, Z_add + | Z_mul, Z_mul + | Z_pow, Z_pow + | Z_sub, Z_sub + | Z_opp, Z_opp + | Z_div, Z_div + | Z_modulo, Z_modulo + | Z_eqb, Z_eqb + | Z_leb, Z_leb + | Z_of_nat, Z_of_nat + | Z_shiftr, Z_shiftr + | Z_shiftl, Z_shiftl + | Z_land, Z_land + | Z_mul_split, Z_mul_split + | Z_mul_split_concrete, Z_mul_split_concrete + | Z_add_get_carry, Z_add_get_carry + | Z_add_get_carry_concrete, Z_add_get_carry_concrete + | Z_add_with_carry, Z_add_with_carry + | Z_add_with_get_carry, Z_add_with_get_carry + | Z_add_with_get_carry_concrete, Z_add_with_get_carry_concrete + | Z_sub_get_borrow, Z_sub_get_borrow + | Z_sub_get_borrow_concrete, Z_sub_get_borrow_concrete + | Z_sub_with_get_borrow, Z_sub_with_get_borrow + | Z_sub_with_get_borrow_concrete, Z_sub_with_get_borrow_concrete + | Z_zselect, Z_zselect + | Z_add_modulo, Z_add_modulo + | Z_rshi, Z_rshi + | Z_rshi_concrete, Z_rshi_concrete + | Z_cc_m, Z_cc_m + | Z_cc_m_concrete, Z_cc_m_concrete + | Z_neg_snd, Z_neg_snd + | Z_cast, Z_cast + | Z_cast2, Z_cast2 + | fancy_add, fancy_add + | fancy_addc, fancy_addc + | fancy_sub, fancy_sub + | fancy_subb, fancy_subb + | fancy_mulll, fancy_mulll + | fancy_mullh, fancy_mullh + | fancy_mulhl, fancy_mulhl + | fancy_mulhh, fancy_mulhh + | fancy_rshi, fancy_rshi + | fancy_selc, fancy_selc + | fancy_selm, fancy_selm + | fancy_sell, fancy_sell + | fancy_addm, fancy_addm + => fun T k => k (Some (fun v => v)) + | LiteralUnit, _ + | LiteralZ, _ + | LiteralBool, _ + | LiteralNat, _ + | Nat_succ, _ + | Nat_pred, _ + | Nat_max, _ + | Nat_mul, _ + | Nat_add, _ + | Nat_sub, _ + | nil, _ + | cons, _ + | pair, _ + | fst, _ + | snd, _ + | pair_rect, _ + | bool_rect, _ + | nat_rect, _ + | list_rect, _ + | list_case, _ + | List_length, _ + | List_seq, _ + | List_repeat, _ + | List_combine, _ + | List_map, _ + | List_app, _ + | List_rev, _ + | List_flat_map, _ + | List_partition, _ + | List_fold_right, _ + | List_update_nth, _ + | List_nth_default, _ + | Z_add, _ + | Z_mul, _ + | Z_pow, _ + | Z_sub, _ + | Z_opp, _ + | Z_div, _ + | Z_modulo, _ + | Z_eqb, _ + | Z_leb, _ + | Z_of_nat, _ + | Z_shiftr, _ + | Z_shiftl, _ + | Z_land, _ + | Z_mul_split, _ + | Z_mul_split_concrete, _ + | Z_add_get_carry, _ + | Z_add_get_carry_concrete, _ + | Z_add_with_carry, _ + | Z_add_with_get_carry, _ + | Z_add_with_get_carry_concrete, _ + | Z_sub_get_borrow, _ + | Z_sub_get_borrow_concrete, _ + | Z_sub_with_get_borrow, _ + | Z_sub_with_get_borrow_concrete, _ + | Z_zselect, _ + | Z_add_modulo, _ + | Z_rshi, _ + | Z_rshi_concrete, _ + | Z_cc_m, _ + | Z_cc_m_concrete, _ + | Z_neg_snd, _ + | Z_cast, _ + | Z_cast2, _ + | fancy_add, _ + | fancy_addc, _ + | fancy_sub, _ + | fancy_subb, _ + | fancy_mulll, _ + | fancy_mullh, _ + | fancy_mulhl, _ + | fancy_mulhh, _ + | fancy_rshi, _ + | fancy_selc, _ + | fancy_selm, _ + | fancy_sell, _ + | fancy_addm, _ + => fun T k => k None + end%cps. + + Definition eta_ident_cps {T : Compilers.type Compilers.base.type -> Type} {t} (idc : Compilers.ident.ident t) + (f : forall t', Compilers.ident.ident t' -> T t') + : T t + := match idc with + | Compilers.ident.LiteralUnit v => f _ (@Compilers.ident.LiteralUnit v) + | Compilers.ident.LiteralZ v => f _ (@Compilers.ident.LiteralZ v) + | Compilers.ident.LiteralBool v => f _ (@Compilers.ident.LiteralBool v) + | Compilers.ident.LiteralNat v => f _ (@Compilers.ident.LiteralNat v) + | Compilers.ident.Nat_succ => f _ Compilers.ident.Nat_succ + | Compilers.ident.Nat_pred => f _ Compilers.ident.Nat_pred + | Compilers.ident.Nat_max => f _ Compilers.ident.Nat_max + | Compilers.ident.Nat_mul => f _ Compilers.ident.Nat_mul + | Compilers.ident.Nat_add => f _ Compilers.ident.Nat_add + | Compilers.ident.Nat_sub => f _ Compilers.ident.Nat_sub + | Compilers.ident.nil t => f _ (@Compilers.ident.nil t) + | Compilers.ident.cons t => f _ (@Compilers.ident.cons t) + | Compilers.ident.pair A B => f _ (@Compilers.ident.pair A B) + | Compilers.ident.fst A B => f _ (@Compilers.ident.fst A B) + | Compilers.ident.snd A B => f _ (@Compilers.ident.snd A B) + | Compilers.ident.pair_rect A B T => f _ (@Compilers.ident.pair_rect A B T) + | Compilers.ident.bool_rect T => f _ (@Compilers.ident.bool_rect T) + | Compilers.ident.nat_rect P => f _ (@Compilers.ident.nat_rect P) + | Compilers.ident.list_rect A P => f _ (@Compilers.ident.list_rect A P) + | Compilers.ident.list_case A P => f _ (@Compilers.ident.list_case A P) + | Compilers.ident.List_length T => f _ (@Compilers.ident.List_length T) + | Compilers.ident.List_seq => f _ Compilers.ident.List_seq + | Compilers.ident.List_repeat A => f _ (@Compilers.ident.List_repeat A) + | Compilers.ident.List_combine A B => f _ (@Compilers.ident.List_combine A B) + | Compilers.ident.List_map A B => f _ (@Compilers.ident.List_map A B) + | Compilers.ident.List_app A => f _ (@Compilers.ident.List_app A) + | Compilers.ident.List_rev A => f _ (@Compilers.ident.List_rev A) + | Compilers.ident.List_flat_map A B => f _ (@Compilers.ident.List_flat_map A B) + | Compilers.ident.List_partition A => f _ (@Compilers.ident.List_partition A) + | Compilers.ident.List_fold_right A B => f _ (@Compilers.ident.List_fold_right A B) + | Compilers.ident.List_update_nth T => f _ (@Compilers.ident.List_update_nth T) + | Compilers.ident.List_nth_default T => f _ (@Compilers.ident.List_nth_default T) + | Compilers.ident.Z_add => f _ Compilers.ident.Z_add + | Compilers.ident.Z_mul => f _ Compilers.ident.Z_mul + | Compilers.ident.Z_pow => f _ Compilers.ident.Z_pow + | Compilers.ident.Z_sub => f _ Compilers.ident.Z_sub + | Compilers.ident.Z_opp => f _ Compilers.ident.Z_opp + | Compilers.ident.Z_div => f _ Compilers.ident.Z_div + | Compilers.ident.Z_modulo => f _ Compilers.ident.Z_modulo + | Compilers.ident.Z_eqb => f _ Compilers.ident.Z_eqb + | Compilers.ident.Z_leb => f _ Compilers.ident.Z_leb + | Compilers.ident.Z_of_nat => f _ Compilers.ident.Z_of_nat + | Compilers.ident.Z_shiftr offset => f _ (@Compilers.ident.Z_shiftr offset) + | Compilers.ident.Z_shiftl offset => f _ (@Compilers.ident.Z_shiftl offset) + | Compilers.ident.Z_land mask => f _ (@Compilers.ident.Z_land mask) + | Compilers.ident.Z_mul_split => f _ Compilers.ident.Z_mul_split + | Compilers.ident.Z_mul_split_concrete s => f _ (@Compilers.ident.Z_mul_split_concrete s) + | Compilers.ident.Z_add_get_carry => f _ Compilers.ident.Z_add_get_carry + | Compilers.ident.Z_add_get_carry_concrete s => f _ (@Compilers.ident.Z_add_get_carry_concrete s) + | Compilers.ident.Z_add_with_carry => f _ Compilers.ident.Z_add_with_carry + | Compilers.ident.Z_add_with_get_carry => f _ Compilers.ident.Z_add_with_get_carry + | Compilers.ident.Z_add_with_get_carry_concrete s => f _ (@Compilers.ident.Z_add_with_get_carry_concrete s) + | Compilers.ident.Z_sub_get_borrow => f _ Compilers.ident.Z_sub_get_borrow + | Compilers.ident.Z_sub_get_borrow_concrete s => f _ (@Compilers.ident.Z_sub_get_borrow_concrete s) + | Compilers.ident.Z_sub_with_get_borrow => f _ Compilers.ident.Z_sub_with_get_borrow + | Compilers.ident.Z_sub_with_get_borrow_concrete s => f _ (@Compilers.ident.Z_sub_with_get_borrow_concrete s) + | Compilers.ident.Z_zselect => f _ Compilers.ident.Z_zselect + | Compilers.ident.Z_add_modulo => f _ Compilers.ident.Z_add_modulo + | Compilers.ident.Z_rshi => f _ Compilers.ident.Z_rshi + | Compilers.ident.Z_rshi_concrete s offset => f _ (@Compilers.ident.Z_rshi_concrete s offset) + | Compilers.ident.Z_cc_m => f _ Compilers.ident.Z_cc_m + | Compilers.ident.Z_cc_m_concrete s => f _ (@Compilers.ident.Z_cc_m_concrete s) + | Compilers.ident.Z_neg_snd => f _ Compilers.ident.Z_neg_snd + | Compilers.ident.Z_cast range => f _ (@Compilers.ident.Z_cast range) + | Compilers.ident.Z_cast2 range => f _ (@Compilers.ident.Z_cast2 range) + | Compilers.ident.fancy_add log2wordmax imm => f _ (@Compilers.ident.fancy_add log2wordmax imm) + | Compilers.ident.fancy_addc log2wordmax imm => f _ (@Compilers.ident.fancy_addc log2wordmax imm) + | Compilers.ident.fancy_sub log2wordmax imm => f _ (@Compilers.ident.fancy_sub log2wordmax imm) + | Compilers.ident.fancy_subb log2wordmax imm => f _ (@Compilers.ident.fancy_subb log2wordmax imm) + | Compilers.ident.fancy_mulll log2wordmax => f _ (@Compilers.ident.fancy_mulll log2wordmax) + | Compilers.ident.fancy_mullh log2wordmax => f _ (@Compilers.ident.fancy_mullh log2wordmax) + | Compilers.ident.fancy_mulhl log2wordmax => f _ (@Compilers.ident.fancy_mulhl log2wordmax) + | Compilers.ident.fancy_mulhh log2wordmax => f _ (@Compilers.ident.fancy_mulhh log2wordmax) + | Compilers.ident.fancy_rshi log2wordmax x => f _ (@Compilers.ident.fancy_rshi log2wordmax x) + | Compilers.ident.fancy_selc => f _ Compilers.ident.fancy_selc + | Compilers.ident.fancy_selm log2wordmax => f _ (@Compilers.ident.fancy_selm log2wordmax) + | Compilers.ident.fancy_sell => f _ Compilers.ident.fancy_sell + | Compilers.ident.fancy_addm => f _ Compilers.ident.fancy_addm + end. + + Definition of_typed_ident {t} (idc : Compilers.ident.ident t) : ident + := match idc with + | Compilers.ident.LiteralUnit v => LiteralUnit + | Compilers.ident.LiteralZ v => LiteralZ + | Compilers.ident.LiteralBool v => LiteralBool + | Compilers.ident.LiteralNat v => LiteralNat + | Compilers.ident.Nat_succ => Nat_succ + | Compilers.ident.Nat_pred => Nat_pred + | Compilers.ident.Nat_max => Nat_max + | Compilers.ident.Nat_mul => Nat_mul + | Compilers.ident.Nat_add => Nat_add + | Compilers.ident.Nat_sub => Nat_sub + | Compilers.ident.nil t => nil + | Compilers.ident.cons t => cons + | Compilers.ident.pair A B => pair + | Compilers.ident.fst A B => fst + | Compilers.ident.snd A B => snd + | Compilers.ident.pair_rect A B T => pair_rect + | Compilers.ident.bool_rect T => bool_rect + | Compilers.ident.nat_rect P => nat_rect + | Compilers.ident.list_rect A P => list_rect + | Compilers.ident.list_case A P => list_case + | Compilers.ident.List_length T => List_length + | Compilers.ident.List_seq => List_seq + | Compilers.ident.List_repeat A => List_repeat + | Compilers.ident.List_combine A B => List_combine + | Compilers.ident.List_map A B => List_map + | Compilers.ident.List_app A => List_app + | Compilers.ident.List_rev A => List_rev + | Compilers.ident.List_flat_map A B => List_flat_map + | Compilers.ident.List_partition A => List_partition + | Compilers.ident.List_fold_right A B => List_fold_right + | Compilers.ident.List_update_nth T => List_update_nth + | Compilers.ident.List_nth_default T => List_nth_default + | Compilers.ident.Z_add => Z_add + | Compilers.ident.Z_mul => Z_mul + | Compilers.ident.Z_pow => Z_pow + | Compilers.ident.Z_sub => Z_sub + | Compilers.ident.Z_opp => Z_opp + | Compilers.ident.Z_div => Z_div + | Compilers.ident.Z_modulo => Z_modulo + | Compilers.ident.Z_eqb => Z_eqb + | Compilers.ident.Z_leb => Z_leb + | Compilers.ident.Z_of_nat => Z_of_nat + | Compilers.ident.Z_shiftr offset => Z_shiftr + | Compilers.ident.Z_shiftl offset => Z_shiftl + | Compilers.ident.Z_land mask => Z_land + | Compilers.ident.Z_mul_split => Z_mul_split + | Compilers.ident.Z_mul_split_concrete s => Z_mul_split_concrete + | Compilers.ident.Z_add_get_carry => Z_add_get_carry + | Compilers.ident.Z_add_get_carry_concrete s => Z_add_get_carry_concrete + | Compilers.ident.Z_add_with_carry => Z_add_with_carry + | Compilers.ident.Z_add_with_get_carry => Z_add_with_get_carry + | Compilers.ident.Z_add_with_get_carry_concrete s => Z_add_with_get_carry_concrete + | Compilers.ident.Z_sub_get_borrow => Z_sub_get_borrow + | Compilers.ident.Z_sub_get_borrow_concrete s => Z_sub_get_borrow_concrete + | Compilers.ident.Z_sub_with_get_borrow => Z_sub_with_get_borrow + | Compilers.ident.Z_sub_with_get_borrow_concrete s => Z_sub_with_get_borrow_concrete + | Compilers.ident.Z_zselect => Z_zselect + | Compilers.ident.Z_add_modulo => Z_add_modulo + | Compilers.ident.Z_rshi => Z_rshi + | Compilers.ident.Z_rshi_concrete s offset => Z_rshi_concrete + | Compilers.ident.Z_cc_m => Z_cc_m + | Compilers.ident.Z_cc_m_concrete s => Z_cc_m_concrete + | Compilers.ident.Z_neg_snd => Z_neg_snd + | Compilers.ident.Z_cast range => Z_cast + | Compilers.ident.Z_cast2 range => Z_cast2 + | Compilers.ident.fancy_add log2wordmax imm => fancy_add + | Compilers.ident.fancy_addc log2wordmax imm => fancy_addc + | Compilers.ident.fancy_sub log2wordmax imm => fancy_sub + | Compilers.ident.fancy_subb log2wordmax imm => fancy_subb + | Compilers.ident.fancy_mulll log2wordmax => fancy_mulll + | Compilers.ident.fancy_mullh log2wordmax => fancy_mullh + | Compilers.ident.fancy_mulhl log2wordmax => fancy_mulhl + | Compilers.ident.fancy_mulhh log2wordmax => fancy_mulhh + | Compilers.ident.fancy_rshi log2wordmax x => fancy_rshi + | Compilers.ident.fancy_selc => fancy_selc + | Compilers.ident.fancy_selm log2wordmax => fancy_selm + | Compilers.ident.fancy_sell => fancy_sell + | Compilers.ident.fancy_addm => fancy_addm + end. + + Definition arg_types (idc : ident) : option Type + := match idc return option Type with + | LiteralUnit => @Some Type (base.interp Compilers.base.type.unit) + | LiteralZ => @Some Type (base.interp Compilers.base.type.Z) + | LiteralBool => @Some Type (base.interp Compilers.base.type.bool) + | LiteralNat => @Some Type (base.interp Compilers.base.type.nat) + | Nat_succ => None + | Nat_pred => None + | Nat_max => None + | Nat_mul => None + | Nat_add => None + | Nat_sub => None + | nil => None + | cons => None + | pair => None + | fst => None + | snd => None + | pair_rect => None + | bool_rect => None + | nat_rect => None + | list_rect => None + | list_case => None + | List_length => None + | List_seq => None + | List_repeat => None + | List_combine => None + | List_map => None + | List_app => None + | List_rev => None + | List_flat_map => None + | List_partition => None + | List_fold_right => None + | List_update_nth => None + | List_nth_default => None + | Z_add => None + | Z_mul => None + | Z_pow => None + | Z_sub => None + | Z_opp => None + | Z_div => None + | Z_modulo => None + | Z_eqb => None + | Z_leb => None + | Z_of_nat => None + | Z_shiftr => @Some Type Z + | Z_shiftl => @Some Type Z + | Z_land => @Some Type Z + | Z_mul_split => None + | Z_mul_split_concrete => @Some Type Z + | Z_add_get_carry => None + | Z_add_get_carry_concrete => @Some Type Z + | Z_add_with_carry => None + | Z_add_with_get_carry => None + | Z_add_with_get_carry_concrete => @Some Type Z + | Z_sub_get_borrow => None + | Z_sub_get_borrow_concrete => @Some Type Z + | Z_sub_with_get_borrow => None + | Z_sub_with_get_borrow_concrete => @Some Type Z + | Z_zselect => None + | Z_add_modulo => None + | Z_rshi => None + | Z_rshi_concrete => @Some Type (Z * Z) + | Z_cc_m => None + | Z_cc_m_concrete => @Some Type Z + | Z_neg_snd => None + | Z_cast => @Some Type zrange + | Z_cast2 => @Some Type (zrange * zrange) + | fancy_add => @Some Type (Z * Z) + | fancy_addc => @Some Type (Z * Z) + | fancy_sub => @Some Type (Z * Z) + | fancy_subb => @Some Type (Z * Z) + | fancy_mulll => @Some Type Z + | fancy_mullh => @Some Type Z + | fancy_mulhl => @Some Type Z + | fancy_mulhh => @Some Type Z + | fancy_rshi => @Some Type (Z * Z) + | fancy_selc => None + | fancy_selm => @Some Type Z + | fancy_sell => None + | fancy_addm => None + end%type. + + Definition full_types (idc : ident) : Type + := match idc return Type with + | LiteralUnit => base.interp Compilers.base.type.unit + | LiteralZ => base.interp Compilers.base.type.Z + | LiteralBool => base.interp Compilers.base.type.bool + | LiteralNat => base.interp Compilers.base.type.nat + | Nat_succ => unit + | Nat_pred => unit + | Nat_max => unit + | Nat_mul => unit + | Nat_add => unit + | Nat_sub => unit + | nil => Compilers.base.type.type + | cons => Compilers.base.type.type + | pair => Compilers.base.type.type * Compilers.base.type.type + | fst => Compilers.base.type.type * Compilers.base.type.type + | snd => Compilers.base.type.type * Compilers.base.type.type + | pair_rect => Compilers.base.type.type * Compilers.base.type.type * Compilers.base.type.type + | bool_rect => Compilers.base.type.type + | nat_rect => Compilers.base.type.type + | list_rect => Compilers.base.type.type * Compilers.base.type.type + | list_case => Compilers.base.type.type * Compilers.base.type.type + | List_length => Compilers.base.type.type + | List_seq => unit + | List_repeat => Compilers.base.type.type + | List_combine => Compilers.base.type.type * Compilers.base.type.type + | List_map => Compilers.base.type.type * Compilers.base.type.type + | List_app => Compilers.base.type.type + | List_rev => Compilers.base.type.type + | List_flat_map => Compilers.base.type.type * Compilers.base.type.type + | List_partition => Compilers.base.type.type + | List_fold_right => Compilers.base.type.type * Compilers.base.type.type + | List_update_nth => Compilers.base.type.type + | List_nth_default => Compilers.base.type.type + | Z_add => unit + | Z_mul => unit + | Z_pow => unit + | Z_sub => unit + | Z_opp => unit + | Z_div => unit + | Z_modulo => unit + | Z_eqb => unit + | Z_leb => unit + | Z_of_nat => unit + | Z_shiftr => Z + | Z_shiftl => Z + | Z_land => Z + | Z_mul_split => unit + | Z_mul_split_concrete => Z + | Z_add_get_carry => unit + | Z_add_get_carry_concrete => Z + | Z_add_with_carry => unit + | Z_add_with_get_carry => unit + | Z_add_with_get_carry_concrete => Z + | Z_sub_get_borrow => unit + | Z_sub_get_borrow_concrete => Z + | Z_sub_with_get_borrow => unit + | Z_sub_with_get_borrow_concrete => Z + | Z_zselect => unit + | Z_add_modulo => unit + | Z_rshi => unit + | Z_rshi_concrete => Z * Z + | Z_cc_m => unit + | Z_cc_m_concrete => Z + | Z_neg_snd => unit + | Z_cast => zrange + | Z_cast2 => zrange * zrange + | fancy_add => Z * Z + | fancy_addc => Z * Z + | fancy_sub => Z * Z + | fancy_subb => Z * Z + | fancy_mulll => Z + | fancy_mullh => Z + | fancy_mulhl => Z + | fancy_mulhh => Z + | fancy_rshi => Z * Z + | fancy_selc => unit + | fancy_selm => Z + | fancy_sell => unit + | fancy_addm => unit + end%type. + + Definition bind_args {t} (idc : Compilers.ident.ident t) : match arg_types (of_typed_ident idc) return Type with Some t => t | None => unit end + := match idc return match arg_types (of_typed_ident idc) return Type with Some t => t | None => unit end with + | Compilers.ident.LiteralUnit v => v + | Compilers.ident.LiteralZ v => v + | Compilers.ident.LiteralBool v => v + | Compilers.ident.LiteralNat v => v + | Compilers.ident.Nat_succ => tt + | Compilers.ident.Nat_pred => tt + | Compilers.ident.Nat_max => tt + | Compilers.ident.Nat_mul => tt + | Compilers.ident.Nat_add => tt + | Compilers.ident.Nat_sub => tt + | Compilers.ident.nil t => tt + | Compilers.ident.cons t => tt + | Compilers.ident.pair A B => tt + | Compilers.ident.fst A B => tt + | Compilers.ident.snd A B => tt + | Compilers.ident.pair_rect A B T => tt + | Compilers.ident.bool_rect T => tt + | Compilers.ident.nat_rect P => tt + | Compilers.ident.list_rect A P => tt + | Compilers.ident.list_case A P => tt + | Compilers.ident.List_length T => tt + | Compilers.ident.List_seq => tt + | Compilers.ident.List_repeat A => tt + | Compilers.ident.List_combine A B => tt + | Compilers.ident.List_map A B => tt + | Compilers.ident.List_app A => tt + | Compilers.ident.List_rev A => tt + | Compilers.ident.List_flat_map A B => tt + | Compilers.ident.List_partition A => tt + | Compilers.ident.List_fold_right A B => tt + | Compilers.ident.List_update_nth T => tt + | Compilers.ident.List_nth_default T => tt + | Compilers.ident.Z_add => tt + | Compilers.ident.Z_mul => tt + | Compilers.ident.Z_pow => tt + | Compilers.ident.Z_sub => tt + | Compilers.ident.Z_opp => tt + | Compilers.ident.Z_div => tt + | Compilers.ident.Z_modulo => tt + | Compilers.ident.Z_eqb => tt + | Compilers.ident.Z_leb => tt + | Compilers.ident.Z_of_nat => tt + | Compilers.ident.Z_shiftr offset => offset + | Compilers.ident.Z_shiftl offset => offset + | Compilers.ident.Z_land mask => mask + | Compilers.ident.Z_mul_split => tt + | Compilers.ident.Z_mul_split_concrete s => s + | Compilers.ident.Z_add_get_carry => tt + | Compilers.ident.Z_add_get_carry_concrete s => s + | Compilers.ident.Z_add_with_carry => tt + | Compilers.ident.Z_add_with_get_carry => tt + | Compilers.ident.Z_add_with_get_carry_concrete s => s + | Compilers.ident.Z_sub_get_borrow => tt + | Compilers.ident.Z_sub_get_borrow_concrete s => s + | Compilers.ident.Z_sub_with_get_borrow => tt + | Compilers.ident.Z_sub_with_get_borrow_concrete s => s + | Compilers.ident.Z_zselect => tt + | Compilers.ident.Z_add_modulo => tt + | Compilers.ident.Z_rshi => tt + | Compilers.ident.Z_rshi_concrete s offset => (s, offset) + | Compilers.ident.Z_cc_m => tt + | Compilers.ident.Z_cc_m_concrete s => s + | Compilers.ident.Z_neg_snd => tt + | Compilers.ident.Z_cast range => range + | Compilers.ident.Z_cast2 range => range + | Compilers.ident.fancy_add log2wordmax imm => (log2wordmax, imm) + | Compilers.ident.fancy_addc log2wordmax imm => (log2wordmax, imm) + | Compilers.ident.fancy_sub log2wordmax imm => (log2wordmax, imm) + | Compilers.ident.fancy_subb log2wordmax imm => (log2wordmax, imm) + | Compilers.ident.fancy_mulll log2wordmax => log2wordmax + | Compilers.ident.fancy_mullh log2wordmax => log2wordmax + | Compilers.ident.fancy_mulhl log2wordmax => log2wordmax + | Compilers.ident.fancy_mulhh log2wordmax => log2wordmax + | Compilers.ident.fancy_rshi log2wordmax x => (log2wordmax, x) + | Compilers.ident.fancy_selc => tt + | Compilers.ident.fancy_selm log2wordmax => log2wordmax + | Compilers.ident.fancy_sell => tt + | Compilers.ident.fancy_addm => tt + end%cps. + + Definition invert_bind_args {t} (idc : Compilers.ident.ident t) (pidc : ident) : option (full_types pidc) + := match pidc, idc return option (full_types pidc) with + | LiteralUnit, Compilers.ident.LiteralUnit v => Some v + | LiteralZ, Compilers.ident.LiteralZ v => Some v + | LiteralBool, Compilers.ident.LiteralBool v => Some v + | LiteralNat, Compilers.ident.LiteralNat v => Some v + | Nat_succ, Compilers.ident.Nat_succ => Some tt + | Nat_pred, Compilers.ident.Nat_pred => Some tt + | Nat_max, Compilers.ident.Nat_max => Some tt + | Nat_mul, Compilers.ident.Nat_mul => Some tt + | Nat_add, Compilers.ident.Nat_add => Some tt + | Nat_sub, Compilers.ident.Nat_sub => Some tt + | nil, Compilers.ident.nil t => Some t + | cons, Compilers.ident.cons t => Some t + | pair, Compilers.ident.pair A B => Some (A, B) + | fst, Compilers.ident.fst A B => Some (A, B) + | snd, Compilers.ident.snd A B => Some (A, B) + | pair_rect, Compilers.ident.pair_rect A B T => Some (A, B, T) + | bool_rect, Compilers.ident.bool_rect T => Some T + | nat_rect, Compilers.ident.nat_rect P => Some P + | list_rect, Compilers.ident.list_rect A P => Some (A, P) + | list_case, Compilers.ident.list_case A P => Some (A, P) + | List_length, Compilers.ident.List_length T => Some T + | List_seq, Compilers.ident.List_seq => Some tt + | List_repeat, Compilers.ident.List_repeat A => Some A + | List_combine, Compilers.ident.List_combine A B => Some (A, B) + | List_map, Compilers.ident.List_map A B => Some (A, B) + | List_app, Compilers.ident.List_app A => Some A + | List_rev, Compilers.ident.List_rev A => Some A + | List_flat_map, Compilers.ident.List_flat_map A B => Some (A, B) + | List_partition, Compilers.ident.List_partition A => Some A + | List_fold_right, Compilers.ident.List_fold_right A B => Some (A, B) + | List_update_nth, Compilers.ident.List_update_nth T => Some T + | List_nth_default, Compilers.ident.List_nth_default T => Some T + | Z_add, Compilers.ident.Z_add => Some tt + | Z_mul, Compilers.ident.Z_mul => Some tt + | Z_pow, Compilers.ident.Z_pow => Some tt + | Z_sub, Compilers.ident.Z_sub => Some tt + | Z_opp, Compilers.ident.Z_opp => Some tt + | Z_div, Compilers.ident.Z_div => Some tt + | Z_modulo, Compilers.ident.Z_modulo => Some tt + | Z_eqb, Compilers.ident.Z_eqb => Some tt + | Z_leb, Compilers.ident.Z_leb => Some tt + | Z_of_nat, Compilers.ident.Z_of_nat => Some tt + | Z_shiftr, Compilers.ident.Z_shiftr offset => Some offset + | Z_shiftl, Compilers.ident.Z_shiftl offset => Some offset + | Z_land, Compilers.ident.Z_land mask => Some mask + | Z_mul_split, Compilers.ident.Z_mul_split => Some tt + | Z_mul_split_concrete, Compilers.ident.Z_mul_split_concrete s => Some s + | Z_add_get_carry, Compilers.ident.Z_add_get_carry => Some tt + | Z_add_get_carry_concrete, Compilers.ident.Z_add_get_carry_concrete s => Some s + | Z_add_with_carry, Compilers.ident.Z_add_with_carry => Some tt + | Z_add_with_get_carry, Compilers.ident.Z_add_with_get_carry => Some tt + | Z_add_with_get_carry_concrete, Compilers.ident.Z_add_with_get_carry_concrete s => Some s + | Z_sub_get_borrow, Compilers.ident.Z_sub_get_borrow => Some tt + | Z_sub_get_borrow_concrete, Compilers.ident.Z_sub_get_borrow_concrete s => Some s + | Z_sub_with_get_borrow, Compilers.ident.Z_sub_with_get_borrow => Some tt + | Z_sub_with_get_borrow_concrete, Compilers.ident.Z_sub_with_get_borrow_concrete s => Some s + | Z_zselect, Compilers.ident.Z_zselect => Some tt + | Z_add_modulo, Compilers.ident.Z_add_modulo => Some tt + | Z_rshi, Compilers.ident.Z_rshi => Some tt + | Z_rshi_concrete, Compilers.ident.Z_rshi_concrete s offset => Some (s, offset) + | Z_cc_m, Compilers.ident.Z_cc_m => Some tt + | Z_cc_m_concrete, Compilers.ident.Z_cc_m_concrete s => Some s + | Z_neg_snd, Compilers.ident.Z_neg_snd => Some tt + | Z_cast, Compilers.ident.Z_cast range => Some range + | Z_cast2, Compilers.ident.Z_cast2 range => Some range + | fancy_add, Compilers.ident.fancy_add log2wordmax imm => Some (log2wordmax, imm) + | fancy_addc, Compilers.ident.fancy_addc log2wordmax imm => Some (log2wordmax, imm) + | fancy_sub, Compilers.ident.fancy_sub log2wordmax imm => Some (log2wordmax, imm) + | fancy_subb, Compilers.ident.fancy_subb log2wordmax imm => Some (log2wordmax, imm) + | fancy_mulll, Compilers.ident.fancy_mulll log2wordmax => Some log2wordmax + | fancy_mullh, Compilers.ident.fancy_mullh log2wordmax => Some log2wordmax + | fancy_mulhl, Compilers.ident.fancy_mulhl log2wordmax => Some log2wordmax + | fancy_mulhh, Compilers.ident.fancy_mulhh log2wordmax => Some log2wordmax + | fancy_rshi, Compilers.ident.fancy_rshi log2wordmax x => Some (log2wordmax, x) + | fancy_selc, Compilers.ident.fancy_selc => Some tt + | fancy_selm, Compilers.ident.fancy_selm log2wordmax => Some log2wordmax + | fancy_sell, Compilers.ident.fancy_sell => Some tt + | fancy_addm, Compilers.ident.fancy_addm => Some tt + | LiteralUnit, _ + | LiteralZ, _ + | LiteralBool, _ + | LiteralNat, _ + | Nat_succ, _ + | Nat_pred, _ + | Nat_max, _ + | Nat_mul, _ + | Nat_add, _ + | Nat_sub, _ + | nil, _ + | cons, _ + | pair, _ + | fst, _ + | snd, _ + | pair_rect, _ + | bool_rect, _ + | nat_rect, _ + | list_rect, _ + | list_case, _ + | List_length, _ + | List_seq, _ + | List_repeat, _ + | List_combine, _ + | List_map, _ + | List_app, _ + | List_rev, _ + | List_flat_map, _ + | List_partition, _ + | List_fold_right, _ + | List_update_nth, _ + | List_nth_default, _ + | Z_add, _ + | Z_mul, _ + | Z_pow, _ + | Z_sub, _ + | Z_opp, _ + | Z_div, _ + | Z_modulo, _ + | Z_eqb, _ + | Z_leb, _ + | Z_of_nat, _ + | Z_shiftr, _ + | Z_shiftl, _ + | Z_land, _ + | Z_mul_split, _ + | Z_mul_split_concrete, _ + | Z_add_get_carry, _ + | Z_add_get_carry_concrete, _ + | Z_add_with_carry, _ + | Z_add_with_get_carry, _ + | Z_add_with_get_carry_concrete, _ + | Z_sub_get_borrow, _ + | Z_sub_get_borrow_concrete, _ + | Z_sub_with_get_borrow, _ + | Z_sub_with_get_borrow_concrete, _ + | Z_zselect, _ + | Z_add_modulo, _ + | Z_rshi, _ + | Z_rshi_concrete, _ + | Z_cc_m, _ + | Z_cc_m_concrete, _ + | Z_neg_snd, _ + | Z_cast, _ + | Z_cast2, _ + | fancy_add, _ + | fancy_addc, _ + | fancy_sub, _ + | fancy_subb, _ + | fancy_mulll, _ + | fancy_mullh, _ + | fancy_mulhl, _ + | fancy_mulhh, _ + | fancy_rshi, _ + | fancy_selc, _ + | fancy_selm, _ + | fancy_sell, _ + | fancy_addm, _ + => None + end%cps. + + Local Notation eta2 x := (Datatypes.fst x, Datatypes.snd x) (only parsing). + Local Notation eta3 x := (eta2 (Datatypes.fst x), Datatypes.snd x) (only parsing). + + Definition type_of (pidc : ident) : full_types pidc -> Compilers.type Compilers.base.type + := match pidc return full_types pidc -> _ with + | LiteralUnit => fun v => (type.base (Compilers.base.type.type_base Compilers.base.type.unit)) + | LiteralZ => fun v => (type.base (Compilers.base.type.type_base Compilers.base.type.Z)) + | LiteralBool => fun v => (type.base (Compilers.base.type.type_base Compilers.base.type.bool)) + | LiteralNat => fun v => (type.base (Compilers.base.type.type_base Compilers.base.type.nat)) + | Nat_succ => fun _ => (type.base (Compilers.base.type.type_base base.type.nat) -> type.base (Compilers.base.type.type_base base.type.nat))%etype + | Nat_pred => fun _ => (type.base (Compilers.base.type.type_base base.type.nat) -> type.base (Compilers.base.type.type_base base.type.nat))%etype + | Nat_max => fun _ => (type.base (Compilers.base.type.type_base base.type.nat) -> type.base (Compilers.base.type.type_base base.type.nat) -> type.base (Compilers.base.type.type_base base.type.nat))%etype + | Nat_mul => fun _ => (type.base (Compilers.base.type.type_base base.type.nat) -> type.base (Compilers.base.type.type_base base.type.nat) -> type.base (Compilers.base.type.type_base base.type.nat))%etype + | Nat_add => fun _ => (type.base (Compilers.base.type.type_base base.type.nat) -> type.base (Compilers.base.type.type_base base.type.nat) -> type.base (Compilers.base.type.type_base base.type.nat))%etype + | Nat_sub => fun _ => (type.base (Compilers.base.type.type_base base.type.nat) -> type.base (Compilers.base.type.type_base base.type.nat) -> type.base (Compilers.base.type.type_base base.type.nat))%etype + | nil => fun t => (type.base (Compilers.base.type.list t)) + | cons => fun t => (type.base t -> type.base (Compilers.base.type.list t) -> type.base (Compilers.base.type.list t))%etype + | pair => fun arg => let '(A, B) := eta2 arg in (type.base A -> type.base B -> type.base (A * B)%etype)%etype + | fst => fun arg => let '(A, B) := eta2 arg in (type.base (A * B)%etype -> type.base A)%etype + | snd => fun arg => let '(A, B) := eta2 arg in (type.base (A * B)%etype -> type.base B)%etype + | pair_rect => fun arg => let '(A, B, T) := eta3 arg in ((type.base A -> type.base B -> type.base T) -> type.base (A * B)%etype -> type.base T)%etype + | bool_rect => fun T => ((type.base ()%etype -> type.base T) -> (type.base ()%etype -> type.base T) -> type.base (Compilers.base.type.type_base base.type.bool) -> type.base T)%etype + | nat_rect => fun P => ((type.base ()%etype -> type.base P) -> (type.base (Compilers.base.type.type_base base.type.nat) -> type.base P -> type.base P) -> type.base (Compilers.base.type.type_base base.type.nat) -> type.base P)%etype + | list_rect => fun arg => let '(A, P) := eta2 arg in ((type.base ()%etype -> type.base P) -> (type.base A -> type.base (Compilers.base.type.list A) -> type.base P -> type.base P) -> type.base (Compilers.base.type.list A) -> type.base P)%etype + | list_case => fun arg => let '(A, P) := eta2 arg in ((type.base ()%etype -> type.base P) -> (type.base A -> type.base (Compilers.base.type.list A) -> type.base P) -> type.base (Compilers.base.type.list A) -> type.base P)%etype + | List_length => fun T => (type.base (Compilers.base.type.list T) -> type.base (Compilers.base.type.type_base base.type.nat))%etype + | List_seq => fun _ => (type.base (Compilers.base.type.type_base base.type.nat) -> type.base (Compilers.base.type.type_base base.type.nat) -> type.base (Compilers.base.type.list (Compilers.base.type.type_base base.type.nat)))%etype + | List_repeat => fun A => (type.base A -> type.base (Compilers.base.type.type_base base.type.nat) -> type.base (Compilers.base.type.list A))%etype + | List_combine => fun arg => let '(A, B) := eta2 arg in (type.base (Compilers.base.type.list A) -> type.base (Compilers.base.type.list B) -> type.base (Compilers.base.type.list (A * B)))%etype + | List_map => fun arg => let '(A, B) := eta2 arg in ((type.base A -> type.base B) -> type.base (Compilers.base.type.list A) -> type.base (Compilers.base.type.list B))%etype + | List_app => fun A => (type.base (Compilers.base.type.list A) -> type.base (Compilers.base.type.list A) -> type.base (Compilers.base.type.list A))%etype + | List_rev => fun A => (type.base (Compilers.base.type.list A) -> type.base (Compilers.base.type.list A))%etype + | List_flat_map => fun arg => let '(A, B) := eta2 arg in ((type.base A -> type.base (Compilers.base.type.list B)) -> type.base (Compilers.base.type.list A) -> type.base (Compilers.base.type.list B))%etype + | List_partition => fun A => ((type.base A -> type.base (Compilers.base.type.type_base base.type.bool)) -> type.base (Compilers.base.type.list A) -> type.base (Compilers.base.type.list A * Compilers.base.type.list A)%etype)%etype + | List_fold_right => fun arg => let '(A, B) := eta2 arg in ((type.base B -> type.base A -> type.base A) -> type.base A -> type.base (Compilers.base.type.list B) -> type.base A)%etype + | List_update_nth => fun T => (type.base (Compilers.base.type.type_base base.type.nat) -> (type.base T -> type.base T) -> type.base (Compilers.base.type.list T) -> type.base (Compilers.base.type.list T))%etype + | List_nth_default => fun T => (type.base T -> type.base (Compilers.base.type.list T) -> type.base (Compilers.base.type.type_base base.type.nat) -> type.base T)%etype + | Z_add => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_mul => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_pow => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_sub => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_opp => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_div => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_modulo => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_eqb => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.bool))%etype + | Z_leb => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.bool))%etype + | Z_of_nat => fun _ => (type.base (Compilers.base.type.type_base base.type.nat) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_shiftr => fun offset => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_shiftl => fun offset => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_land => fun mask => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_mul_split => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_mul_split_concrete => fun s => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_add_get_carry => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_add_get_carry_concrete => fun s => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_add_with_carry => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_add_with_get_carry => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_add_with_get_carry_concrete => fun s => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_sub_get_borrow => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_sub_get_borrow_concrete => fun s => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_sub_with_get_borrow => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_sub_with_get_borrow_concrete => fun s => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_zselect => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_add_modulo => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_rshi => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_rshi_concrete => fun arg => let '(s, offset) := eta2 arg in (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_cc_m => fun _ => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_cc_m_concrete => fun s => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_neg_snd => fun _ => (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | Z_cast => fun range => (type.base (Compilers.base.type.type_base base.type.Z) -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | Z_cast2 => fun range => (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | fancy_add => fun arg => let '(log2wordmax, imm) := eta2 arg in (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | fancy_addc => fun arg => let '(log2wordmax, imm) := eta2 arg in (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | fancy_sub => fun arg => let '(log2wordmax, imm) := eta2 arg in (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | fancy_subb => fun arg => let '(log2wordmax, imm) := eta2 arg in (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype)%etype + | fancy_mulll => fun log2wordmax => (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | fancy_mullh => fun log2wordmax => (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | fancy_mulhl => fun log2wordmax => (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | fancy_mulhh => fun log2wordmax => (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | fancy_rshi => fun arg => let '(log2wordmax, x) := eta2 arg in (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | fancy_selc => fun _ => (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | fancy_selm => fun log2wordmax => (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | fancy_sell => fun _ => (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z))%etype + | fancy_addm => fun _ => (type.base (Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z * Compilers.base.type.type_base base.type.Z)%etype -> type.base (Compilers.base.type.type_base base.type.Z))%etype + end. + + Definition to_typed (pidc : ident) : forall args : full_types pidc, Compilers.ident.ident (type_of pidc args) + := match pidc return forall args : full_types pidc, Compilers.ident.ident (type_of pidc args) with + | LiteralUnit => fun v => @Compilers.ident.LiteralUnit v + | LiteralZ => fun v => @Compilers.ident.LiteralZ v + | LiteralBool => fun v => @Compilers.ident.LiteralBool v + | LiteralNat => fun v => @Compilers.ident.LiteralNat v + | Nat_succ => fun _ => @Compilers.ident.Nat_succ + | Nat_pred => fun _ => @Compilers.ident.Nat_pred + | Nat_max => fun _ => @Compilers.ident.Nat_max + | Nat_mul => fun _ => @Compilers.ident.Nat_mul + | Nat_add => fun _ => @Compilers.ident.Nat_add + | Nat_sub => fun _ => @Compilers.ident.Nat_sub + | nil => fun t => @Compilers.ident.nil t + | cons => fun t => @Compilers.ident.cons t + | pair => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of pair args') with (A, B) => @Compilers.ident.pair A B end + | fst => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of fst args') with (A, B) => @Compilers.ident.fst A B end + | snd => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of snd args') with (A, B) => @Compilers.ident.snd A B end + | pair_rect => fun arg => match eta3 arg as args' return Compilers.ident.ident (type_of pair_rect args') with (A, B, T) => @Compilers.ident.pair_rect A B T end + | bool_rect => fun T => @Compilers.ident.bool_rect T + | nat_rect => fun P => @Compilers.ident.nat_rect P + | list_rect => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of list_rect args') with (A, P) => @Compilers.ident.list_rect A P end + | list_case => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of list_case args') with (A, P) => @Compilers.ident.list_case A P end + | List_length => fun T => @Compilers.ident.List_length T + | List_seq => fun _ => @Compilers.ident.List_seq + | List_repeat => fun A => @Compilers.ident.List_repeat A + | List_combine => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of List_combine args') with (A, B) => @Compilers.ident.List_combine A B end + | List_map => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of List_map args') with (A, B) => @Compilers.ident.List_map A B end + | List_app => fun A => @Compilers.ident.List_app A + | List_rev => fun A => @Compilers.ident.List_rev A + | List_flat_map => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of List_flat_map args') with (A, B) => @Compilers.ident.List_flat_map A B end + | List_partition => fun A => @Compilers.ident.List_partition A + | List_fold_right => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of List_fold_right args') with (A, B) => @Compilers.ident.List_fold_right A B end + | List_update_nth => fun T => @Compilers.ident.List_update_nth T + | List_nth_default => fun T => @Compilers.ident.List_nth_default T + | Z_add => fun _ => @Compilers.ident.Z_add + | Z_mul => fun _ => @Compilers.ident.Z_mul + | Z_pow => fun _ => @Compilers.ident.Z_pow + | Z_sub => fun _ => @Compilers.ident.Z_sub + | Z_opp => fun _ => @Compilers.ident.Z_opp + | Z_div => fun _ => @Compilers.ident.Z_div + | Z_modulo => fun _ => @Compilers.ident.Z_modulo + | Z_eqb => fun _ => @Compilers.ident.Z_eqb + | Z_leb => fun _ => @Compilers.ident.Z_leb + | Z_of_nat => fun _ => @Compilers.ident.Z_of_nat + | Z_shiftr => fun offset => @Compilers.ident.Z_shiftr offset + | Z_shiftl => fun offset => @Compilers.ident.Z_shiftl offset + | Z_land => fun mask => @Compilers.ident.Z_land mask + | Z_mul_split => fun _ => @Compilers.ident.Z_mul_split + | Z_mul_split_concrete => fun s => @Compilers.ident.Z_mul_split_concrete s + | Z_add_get_carry => fun _ => @Compilers.ident.Z_add_get_carry + | Z_add_get_carry_concrete => fun s => @Compilers.ident.Z_add_get_carry_concrete s + | Z_add_with_carry => fun _ => @Compilers.ident.Z_add_with_carry + | Z_add_with_get_carry => fun _ => @Compilers.ident.Z_add_with_get_carry + | Z_add_with_get_carry_concrete => fun s => @Compilers.ident.Z_add_with_get_carry_concrete s + | Z_sub_get_borrow => fun _ => @Compilers.ident.Z_sub_get_borrow + | Z_sub_get_borrow_concrete => fun s => @Compilers.ident.Z_sub_get_borrow_concrete s + | Z_sub_with_get_borrow => fun _ => @Compilers.ident.Z_sub_with_get_borrow + | Z_sub_with_get_borrow_concrete => fun s => @Compilers.ident.Z_sub_with_get_borrow_concrete s + | Z_zselect => fun _ => @Compilers.ident.Z_zselect + | Z_add_modulo => fun _ => @Compilers.ident.Z_add_modulo + | Z_rshi => fun _ => @Compilers.ident.Z_rshi + | Z_rshi_concrete => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of Z_rshi_concrete args') with (s, offset) => @Compilers.ident.Z_rshi_concrete s offset end + | Z_cc_m => fun _ => @Compilers.ident.Z_cc_m + | Z_cc_m_concrete => fun s => @Compilers.ident.Z_cc_m_concrete s + | Z_neg_snd => fun _ => @Compilers.ident.Z_neg_snd + | Z_cast => fun range => @Compilers.ident.Z_cast range + | Z_cast2 => fun range => @Compilers.ident.Z_cast2 range + | fancy_add => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of fancy_add args') with (log2wordmax, imm) => @Compilers.ident.fancy_add log2wordmax imm end + | fancy_addc => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of fancy_addc args') with (log2wordmax, imm) => @Compilers.ident.fancy_addc log2wordmax imm end + | fancy_sub => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of fancy_sub args') with (log2wordmax, imm) => @Compilers.ident.fancy_sub log2wordmax imm end + | fancy_subb => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of fancy_subb args') with (log2wordmax, imm) => @Compilers.ident.fancy_subb log2wordmax imm end + | fancy_mulll => fun log2wordmax => @Compilers.ident.fancy_mulll log2wordmax + | fancy_mullh => fun log2wordmax => @Compilers.ident.fancy_mullh log2wordmax + | fancy_mulhl => fun log2wordmax => @Compilers.ident.fancy_mulhl log2wordmax + | fancy_mulhh => fun log2wordmax => @Compilers.ident.fancy_mulhh log2wordmax + | fancy_rshi => fun arg => match eta2 arg as args' return Compilers.ident.ident (type_of fancy_rshi args') with (log2wordmax, x) => @Compilers.ident.fancy_rshi log2wordmax x end + | fancy_selc => fun _ => @Compilers.ident.fancy_selc + | fancy_selm => fun log2wordmax => @Compilers.ident.fancy_selm log2wordmax + | fancy_sell => fun _ => @Compilers.ident.fancy_sell + | fancy_addm => fun _ => @Compilers.ident.fancy_addm + end. + + Definition retype_ident {t} (idc : Compilers.ident.ident t) : match arg_types (of_typed_ident idc) return Type with Some t => t | None => unit end -> Compilers.ident.ident t + := match idc in Compilers.ident.ident t return match arg_types (of_typed_ident idc) return Type with Some t => t | None => unit end -> Compilers.ident.ident t with + | Compilers.ident.LiteralUnit v => (fun v => @Compilers.ident.LiteralUnit v) : match arg_types (of_typed_ident (@Compilers.ident.LiteralUnit v)) return Type with Some t => t | None => unit end -> _ (* COQBUG(https://github.com/coq/coq/issues/7726) *) + | Compilers.ident.LiteralZ v => (fun v => @Compilers.ident.LiteralZ v) : match arg_types (of_typed_ident (@Compilers.ident.LiteralZ v)) return Type with Some t => t | None => unit end -> _ (* COQBUG(https://github.com/coq/coq/issues/7726) *) + | Compilers.ident.LiteralBool v => (fun v => @Compilers.ident.LiteralBool v) : match arg_types (of_typed_ident (@Compilers.ident.LiteralBool v)) return Type with Some t => t | None => unit end -> _ (* COQBUG(https://github.com/coq/coq/issues/7726) *) + | Compilers.ident.LiteralNat v => (fun v => @Compilers.ident.LiteralNat v) : match arg_types (of_typed_ident (@Compilers.ident.LiteralNat v)) return Type with Some t => t | None => unit end -> _ (* COQBUG(https://github.com/coq/coq/issues/7726) *) + | Compilers.ident.Nat_succ => fun _ => @Compilers.ident.Nat_succ + | Compilers.ident.Nat_pred => fun _ => @Compilers.ident.Nat_pred + | Compilers.ident.Nat_max => fun _ => @Compilers.ident.Nat_max + | Compilers.ident.Nat_mul => fun _ => @Compilers.ident.Nat_mul + | Compilers.ident.Nat_add => fun _ => @Compilers.ident.Nat_add + | Compilers.ident.Nat_sub => fun _ => @Compilers.ident.Nat_sub + | Compilers.ident.nil t => fun _ => @Compilers.ident.nil t + | Compilers.ident.cons t => fun _ => @Compilers.ident.cons t + | Compilers.ident.pair A B => fun _ => @Compilers.ident.pair A B + | Compilers.ident.fst A B => fun _ => @Compilers.ident.fst A B + | Compilers.ident.snd A B => fun _ => @Compilers.ident.snd A B + | Compilers.ident.pair_rect A B T => fun _ => @Compilers.ident.pair_rect A B T + | Compilers.ident.bool_rect T => fun _ => @Compilers.ident.bool_rect T + | Compilers.ident.nat_rect P => fun _ => @Compilers.ident.nat_rect P + | Compilers.ident.list_rect A P => fun _ => @Compilers.ident.list_rect A P + | Compilers.ident.list_case A P => fun _ => @Compilers.ident.list_case A P + | Compilers.ident.List_length T => fun _ => @Compilers.ident.List_length T + | Compilers.ident.List_seq => fun _ => @Compilers.ident.List_seq + | Compilers.ident.List_repeat A => fun _ => @Compilers.ident.List_repeat A + | Compilers.ident.List_combine A B => fun _ => @Compilers.ident.List_combine A B + | Compilers.ident.List_map A B => fun _ => @Compilers.ident.List_map A B + | Compilers.ident.List_app A => fun _ => @Compilers.ident.List_app A + | Compilers.ident.List_rev A => fun _ => @Compilers.ident.List_rev A + | Compilers.ident.List_flat_map A B => fun _ => @Compilers.ident.List_flat_map A B + | Compilers.ident.List_partition A => fun _ => @Compilers.ident.List_partition A + | Compilers.ident.List_fold_right A B => fun _ => @Compilers.ident.List_fold_right A B + | Compilers.ident.List_update_nth T => fun _ => @Compilers.ident.List_update_nth T + | Compilers.ident.List_nth_default T => fun _ => @Compilers.ident.List_nth_default T + | Compilers.ident.Z_add => fun _ => @Compilers.ident.Z_add + | Compilers.ident.Z_mul => fun _ => @Compilers.ident.Z_mul + | Compilers.ident.Z_pow => fun _ => @Compilers.ident.Z_pow + | Compilers.ident.Z_sub => fun _ => @Compilers.ident.Z_sub + | Compilers.ident.Z_opp => fun _ => @Compilers.ident.Z_opp + | Compilers.ident.Z_div => fun _ => @Compilers.ident.Z_div + | Compilers.ident.Z_modulo => fun _ => @Compilers.ident.Z_modulo + | Compilers.ident.Z_eqb => fun _ => @Compilers.ident.Z_eqb + | Compilers.ident.Z_leb => fun _ => @Compilers.ident.Z_leb + | Compilers.ident.Z_of_nat => fun _ => @Compilers.ident.Z_of_nat + | Compilers.ident.Z_shiftr offset => fun offset => @Compilers.ident.Z_shiftr offset + | Compilers.ident.Z_shiftl offset => fun offset => @Compilers.ident.Z_shiftl offset + | Compilers.ident.Z_land mask => fun mask => @Compilers.ident.Z_land mask + | Compilers.ident.Z_mul_split => fun _ => @Compilers.ident.Z_mul_split + | Compilers.ident.Z_mul_split_concrete s => fun s => @Compilers.ident.Z_mul_split_concrete s + | Compilers.ident.Z_add_get_carry => fun _ => @Compilers.ident.Z_add_get_carry + | Compilers.ident.Z_add_get_carry_concrete s => fun s => @Compilers.ident.Z_add_get_carry_concrete s + | Compilers.ident.Z_add_with_carry => fun _ => @Compilers.ident.Z_add_with_carry + | Compilers.ident.Z_add_with_get_carry => fun _ => @Compilers.ident.Z_add_with_get_carry + | Compilers.ident.Z_add_with_get_carry_concrete s => fun s => @Compilers.ident.Z_add_with_get_carry_concrete s + | Compilers.ident.Z_sub_get_borrow => fun _ => @Compilers.ident.Z_sub_get_borrow + | Compilers.ident.Z_sub_get_borrow_concrete s => fun s => @Compilers.ident.Z_sub_get_borrow_concrete s + | Compilers.ident.Z_sub_with_get_borrow => fun _ => @Compilers.ident.Z_sub_with_get_borrow + | Compilers.ident.Z_sub_with_get_borrow_concrete s => fun s => @Compilers.ident.Z_sub_with_get_borrow_concrete s + | Compilers.ident.Z_zselect => fun _ => @Compilers.ident.Z_zselect + | Compilers.ident.Z_add_modulo => fun _ => @Compilers.ident.Z_add_modulo + | Compilers.ident.Z_rshi => fun _ => @Compilers.ident.Z_rshi + | Compilers.ident.Z_rshi_concrete s offset => fun arg => let '(s, offset) := eta2 arg in @Compilers.ident.Z_rshi_concrete s offset + | Compilers.ident.Z_cc_m => fun _ => @Compilers.ident.Z_cc_m + | Compilers.ident.Z_cc_m_concrete s => fun s => @Compilers.ident.Z_cc_m_concrete s + | Compilers.ident.Z_neg_snd => fun _ => @Compilers.ident.Z_neg_snd + | Compilers.ident.Z_cast range => fun range => @Compilers.ident.Z_cast range + | Compilers.ident.Z_cast2 range => fun range => @Compilers.ident.Z_cast2 range + | Compilers.ident.fancy_add log2wordmax imm => fun arg => let '(log2wordmax, imm) := eta2 arg in @Compilers.ident.fancy_add log2wordmax imm + | Compilers.ident.fancy_addc log2wordmax imm => fun arg => let '(log2wordmax, imm) := eta2 arg in @Compilers.ident.fancy_addc log2wordmax imm + | Compilers.ident.fancy_sub log2wordmax imm => fun arg => let '(log2wordmax, imm) := eta2 arg in @Compilers.ident.fancy_sub log2wordmax imm + | Compilers.ident.fancy_subb log2wordmax imm => fun arg => let '(log2wordmax, imm) := eta2 arg in @Compilers.ident.fancy_subb log2wordmax imm + | Compilers.ident.fancy_mulll log2wordmax => fun log2wordmax => @Compilers.ident.fancy_mulll log2wordmax + | Compilers.ident.fancy_mullh log2wordmax => fun log2wordmax => @Compilers.ident.fancy_mullh log2wordmax + | Compilers.ident.fancy_mulhl log2wordmax => fun log2wordmax => @Compilers.ident.fancy_mulhl log2wordmax + | Compilers.ident.fancy_mulhh log2wordmax => fun log2wordmax => @Compilers.ident.fancy_mulhh log2wordmax + | Compilers.ident.fancy_rshi log2wordmax x => fun arg => let '(log2wordmax, x) := eta2 arg in @Compilers.ident.fancy_rshi log2wordmax x + | Compilers.ident.fancy_selc => fun _ => @Compilers.ident.fancy_selc + | Compilers.ident.fancy_selm log2wordmax => fun log2wordmax => @Compilers.ident.fancy_selm log2wordmax + | Compilers.ident.fancy_sell => fun _ => @Compilers.ident.fancy_sell + | Compilers.ident.fancy_addm => fun _ => @Compilers.ident.fancy_addm + end. + + + (*===*) + End ident. + End pattern. +End Compilers. diff --git a/src/Experiments/NewPipeline/Language.v b/src/Experiments/NewPipeline/Language.v new file mode 100644 index 000000000..a27936fef --- /dev/null +++ b/src/Experiments/NewPipeline/Language.v @@ -0,0 +1,1597 @@ +Require Import Coq.ZArith.ZArith. +Require Import Coq.FSets.FMapPositive. +Require Import Coq.Bool.Bool. +Require Import Coq.Classes.Morphisms. +Require Import Crypto.Util.Tuple Crypto.Util.Prod Crypto.Util.LetIn. +Require Import Crypto.Util.ListUtil Coq.Lists.List Crypto.Util.NatUtil. +Require Import Crypto.Util.Option. +Require Import Crypto.Util.ZRange. +Require Import Crypto.Util.ZRange.Operations. +Require Import Crypto.Util.ZUtil.Definitions. +Require Import Crypto.Util.ZUtil.Notations. +Require Import Crypto.Util.CPSNotations. +Require Import Crypto.Util.Notations. +Require Import Crypto.Util.Tactics.RunTacticAsConstr. +Require Import Crypto.Util.Tactics.DebugPrint. +Import ListNotations. Local Open Scope bool_scope. Local Open Scope Z_scope. + +Module Compilers. + Local Set Boolean Equality Schemes. + Local Set Decidable Equality Schemes. + Module Reify. + (** Change this with [Ltac reify_debug_level ::= constr:(1).] to get + more debugging. *) + Ltac debug_level := constr:(0%nat). + + Tactic Notation "debug_enter_reify_idtac" ident(funname) uconstr(e) + := idtac funname ": Attempting to reify:" e. + Tactic Notation "debug_leave_reify_success_idtac" ident(funname) uconstr(e) uconstr(ret) + := idtac funname ": Success in reifying:" e "as" ret. + Tactic Notation "debug_leave_reify_failure_idtac" ident(funname) uconstr(e) + := idtac funname ": Failure in reifying:" e. + Ltac check_debug_level_then_Set _ := + let lvl := debug_level in + lazymatch type of lvl with + | nat => constr:(Set) + | ?T => constr_run_tac ltac:(fun _ => idtac "Error: debug_level should have type nat but instead has type" T) + end. + Ltac debug0 tac := + constr_run_tac tac. + Ltac debug1 tac := + let lvl := debug_level in + lazymatch lvl with + | S _ => constr_run_tac tac + | _ => check_debug_level_then_Set () + end. + Ltac debug2 tac := + let lvl := debug_level in + lazymatch lvl with + | S (S _) => constr_run_tac tac + | _ => check_debug_level_then_Set () + end. + Ltac debug3 tac := + let lvl := debug_level in + lazymatch lvl with + | S (S (S _)) => constr_run_tac tac + | _ => check_debug_level_then_Set () + end. + Ltac debug_enter_reify_base_type e := debug2 ltac:(fun _ => debug_enter_reify_idtac reify_base_type e). + Ltac debug_enter_reify_type e := debug2 ltac:(fun _ => debug_enter_reify_idtac reify_type e). + Ltac debug_enter_reify_in_context e := debug2 ltac:(fun _ => debug_enter_reify_idtac reify_in_context e). + Ltac debug_leave_reify_in_context_success e ret := debug3 ltac:(fun _ => debug_leave_reify_success_idtac reify_in_context e ret). + Ltac debug_leave_reify_in_context_failure e + := let dummy := debug0 ltac:(fun _ => debug_leave_reify_failure_idtac reify_in_context e) in + constr:(I : I). + Ltac debug_leave_reify_base_type_failure e + := let dummy := debug0 ltac:(fun _ => debug_leave_reify_failure_idtac reify_base_type e) in + constr:(I : I). + Tactic Notation "idtac_reify_in_context_case" ident(case) := + idtac "reify_in_context:" case. + Ltac debug_reify_in_context_case tac := + debug3 tac. + Ltac debug_enter_reify_abs e := debug2 ltac:(fun _ => debug_enter_reify_idtac reify_abs e). + End Reify. + + Module type. + Inductive type (base_type : Type) := base (t : base_type) | arrow (s d : type base_type). + Global Arguments base {_}. + Global Arguments arrow {_} s d. + + Fixpoint final_codomain {base_type} (t : type base_type) : base_type + := match t with + | base t + => t + | arrow s d => @final_codomain base_type d + end. + + Fixpoint uncurried_domain {base_type} prod s (t : type base_type) : type base_type + := match t with + | base t + => s + | arrow s' d => @uncurried_domain base_type prod (prod s s') d + end. + + Fixpoint for_each_lhs_of_arrow {base_type} (f : type base_type -> Type) (t : type base_type) : Type + := match t with + | base t => unit + | arrow s d => f s * @for_each_lhs_of_arrow _ f d + end. + + (** Denote [type]s into their interpretation in [Type]/[Set] *) + Fixpoint interp {base_type} (base_interp : base_type -> Type) (t : type base_type) : Type + := match t with + | base t => base_interp t + | arrow s d => @interp _ base_interp s -> @interp _ base_interp d + end. + + Fixpoint app_curried {base_type} {f : base_type -> Type} {t : type base_type} + : interp f t -> for_each_lhs_of_arrow (interp f) t -> f (final_codomain t) + := match t with + | base t => fun v _ => v + | arrow s d => fun F x_xs => @app_curried _ f d (F (fst x_xs)) (snd x_xs) + end. + + Fixpoint app_curried_gen {base_type} {f : type base_type -> Type} (app : forall s d, f (arrow s d) -> f s -> f d) + {t : type base_type} + : f t -> for_each_lhs_of_arrow f t -> f (base (final_codomain t)) + := match t with + | base t => fun v _ => v + | arrow s d => fun F x_xs => @app_curried_gen _ f app d (app _ _ F (fst x_xs)) (snd x_xs) + end. + + Fixpoint map_for_each_lhs_of_arrow {base_type} {f g : type base_type -> Type} + (F : forall t, f t -> g t) + {t} + : for_each_lhs_of_arrow f t -> for_each_lhs_of_arrow g t + := match t with + | base t => fun 'tt => tt + | arrow s d => fun '(x, xs) => (F s x, @map_for_each_lhs_of_arrow _ f g F d xs) + end. + + Fixpoint andb_bool_for_each_lhs_of_arrow {base_type} {f g : type base_type -> Type} + (R : forall t, f t -> g t -> bool) + {t} + : for_each_lhs_of_arrow f t -> for_each_lhs_of_arrow g t -> bool + := match t with + | base t => fun _ _ => true + | arrow s d => fun x_xs y_ys => R s (fst x_xs) (fst y_ys) && @andb_bool_for_each_lhs_of_arrow _ f g R d (snd x_xs) (snd y_ys) + end%bool. + + Section interpM. + Context {base_type} (M : Type -> Type) (base_interp : base_type -> Type). + (** half-monadic denotation function; denote [type]s into their + interpretation in [Type]/[Set], wrapping the codomain of any + arrow in [M]. *) + Fixpoint interpM (t : type base_type) : Type + := match t with + | base t => base_interp t + | arrow s d => @interpM s -> M (@interpM d) + end. + Fixpoint interpM_final' (withM : bool) (t : type base_type) + := match t with + | base t => if withM then M (base_interp t) else base_interp t + | arrow s d => interpM_final' false s -> interpM_final' true d + end. + Definition interpM_final := interpM_final' true. + + Fixpoint interpM_return (t : type base_type) : M (base_interp (final_codomain t)) -> interpM_final t + := match t with + | base t => fun v => v + | arrow s d => fun v _ => @interpM_return d v + end. + End interpM. + + Definition domain {base_type} (default : base_type) (t : type base_type) + : type base_type + := match t with + | arrow s d => s + | base _ => base default + end. + + Definition codomain {base_type} (t : type base_type) : type base_type + := match t with + | arrow s d => d + | t => t + end. + + Section transport_cps. + Context {base_type} + (try_make_transport_base_type_cps : forall (P : base_type -> Type) t1 t2, ~> option (P t1 -> P t2)). + + Fixpoint try_make_transport_cps (P : type base_type -> Type) (t1 t2 : type base_type) + : ~> option (P t1 -> P t2) + := match t1, t2 with + | base t1, base t2 => try_make_transport_base_type_cps (fun t => P (base t)) t1 t2 + | arrow s1 d1, arrow s2 d2 + => (trs <-- try_make_transport_cps (fun s => P (arrow s _)) _ _; + trd <-- try_make_transport_cps (fun d => P (arrow _ d)) _ _; + return (Some (fun v => trd (trs v)))) + | base _, _ + | arrow _ _, _ + => (return None) + end%cps. + + Definition try_transport_cps (P : type base_type -> Type) (t1 t2 : type base_type) (v : P t1) : ~> option (P t2) + := (tr <-- try_make_transport_cps P t1 t2; + return (Some (tr v)))%cps. + + Definition try_transport (P : type base_type -> Type) (t1 t2 : type base_type) (v : P t1) : option (P t2) + := try_transport_cps P t1 t2 v _ id. + End transport_cps. + + (* + Fixpoint try_transport {base_type} + (try_transport_base_type : forall (P : base_type -> Type) t1 t2, P t1 -> option (P t2)) + (P : type base_type -> Type) (t1 t2 : type base_type) : P t1 -> option (P t2) + := match t1, t2 return P t1 -> option (P t2) with + | base t1, base t2 + => try_transport_base_type (fun t => P (base t)) t1 t2 + | arrow s d, arrow s' d' + => fun v + => (v <- (try_transport + try_transport_base_type (fun s => P (arrow s d)) + s s' v); + (try_transport + try_transport_base_type (fun d => P (arrow s' d)) + d d' v))%option + | base _, _ + | arrow _ _, _ + => fun _ => None + end. +*) + + Ltac reify base_reify base_type ty := + let __ := Reify.debug_enter_reify_type ty in + let reify_rec t := reify base_reify base_type t in + lazymatch eval cbv beta in ty with + | ?A -> ?B + => let rA := reify_rec A in + let rB := reify_rec B in + constr:(@arrow base_type rA rB) + | @interp _ _ ?T => T + | _ => let rt := base_reify ty in + constr:(@base base_type rt) + end. + End type. + Notation type := type.type. + Delimit Scope etype_scope with etype. + Bind Scope etype_scope with type.type. + Infix "->" := type.arrow : etype_scope. + Module base. + Local Notation einterp := type.interp. + Module type. + Inductive base := unit | Z | bool | nat. (* Not Variant because COQBUG(https://github.com/coq/coq/issues/7738) *) + Inductive type := type_base (t : base) | prod (A B : type) | list (A : type). + Global Coercion type_base : base >-> type. + End type. + Global Coercion type.type_base : type.base >-> type.type. + Notation type := type.type. + Definition base_interp (ty : type.base) + := match ty with + | type.unit => Datatypes.unit + | type.Z => BinInt.Z + | type.bool => Datatypes.bool + | type.nat => Datatypes.nat + end. + Fixpoint interp (ty : type) + := match ty with + | type.type_base t => base_interp t + | type.prod A B => interp A * interp B + | type.list A => Datatypes.list (interp A) + end%type. + + Definition try_make_base_transport_cps + (P : type.base -> Type) (t1 t2 : type.base) + : ~> option (P t1 -> P t2) + := match t1, t2 with + | type.unit, type.unit + | type.Z, type.Z + | type.bool, type.bool + | type.nat, type.nat + => (return (Some id)) + | type.unit, _ + | type.Z, _ + | type.bool, _ + | type.nat, _ + => (return None) + end%cps. + Fixpoint try_make_transport_cps + (P : type -> Type) (t1 t2 : type) + : ~> option (P t1 -> P t2) + := match t1, t2 with + | type.type_base t1, type.type_base t2 + => try_make_base_transport_cps (fun t => P (type.type_base t)) t1 t2 + | type.prod A B, type.prod A' B' + => (trA <-- try_make_transport_cps (fun A => P (type.prod A _)) _ _; + trB <-- try_make_transport_cps (fun B => P (type.prod _ B)) _ _; + return (Some (fun v => trB (trA v)))) + | type.list A, type.list A' => try_make_transport_cps (fun A => P (type.list A)) A A' + | type.type_base _, _ + | type.prod _ _, _ + | type.list _, _ + => (return None) + end%cps. + + Definition try_transport_cps (P : type -> Type) (t1 t2 : type) (v : P t1) : ~> option (P t2) + := (tr <-- try_make_transport_cps P t1 t2; + return (Some (tr v)))%cps. + + Definition try_transport (P : type -> Type) (t1 t2 : type) (v : P t1) : option (P t2) + := try_transport_cps P t1 t2 v _ id. + (* + Fixpoint try_transport + (P : type -> Type) (t1 t2 : type) : P t1 -> option (P t2) + := match t1, t2 return P t1 -> option (P t2) with + | type.unit, type.unit + | type.Z, type.Z + | type.bool, type.bool + | type.nat, type.nat + => @Some _ + | type.list A, type.list A' + => @try_transport (fun A => P (type.list A)) A A' + | type.prod s d, type.prod s' d' + => fun v + => (v <- (try_transport (fun s => P (type.prod s d)) s s' v); + (try_transport (fun d => P (type.prod s' d)) d d' v))%option + + | type.unit, _ + | type.Z, _ + | type.bool, _ + | type.nat, _ + | type.prod _ _, _ + | type.list _, _ + => fun _ => None + end. + *) + + Ltac reify_base ty := + let __ := Reify.debug_enter_reify_base_type ty in + lazymatch eval cbv beta in ty with + | Datatypes.unit => type.unit + | Datatypes.nat => type.nat + | Datatypes.bool => type.bool + | BinInt.Z => type.Z + | interp (type.type_base ?T) => T + | @einterp type interp (@Compilers.type.base type (type.type_base ?T)) => T + | _ => let __ := match goal with + | _ => fail 1 "Unrecognized type:" ty + end in + constr:(I : I) + end. + Ltac reify ty := + let __ := Reify.debug_enter_reify_base_type ty in + lazymatch eval cbv beta in ty with + | Datatypes.prod ?A ?B + => let rA := reify A in + let rB := reify B in + constr:(type.prod rA rB) + | Datatypes.list ?T + => let rT := reify T in + constr:(type.list rT) + | interp ?T => T + | @einterp type interp (@Compilers.type.base type ?T) => T + | ?ty => let rT := reify_base ty in + constr:(@type.type_base rT) + end. + Notation reify_base t := (ltac:(let rt := reify_base t in exact rt)) (only parsing). + Notation reify t := (ltac:(let rt := reify t in exact rt)) (only parsing). + Notation reify_norm_base t := (ltac:(let t' := eval cbv in t in let rt := reify_base t' in exact rt)) (only parsing). + Notation reify_norm t := (ltac:(let t' := eval cbv in t in let rt := reify t' in exact rt)) (only parsing). + Notation reify_base_type_of e := (reify_base ((fun t (_ : t) => t) _ e)) (only parsing). + Notation reify_type_of e := (reify ((fun t (_ : t) => t) _ e)) (only parsing). + Notation reify_norm_base_type_of e := (reify_norm_base ((fun t (_ : t) => t) _ e)) (only parsing). + Notation reify_norm_type_of e := (reify_norm ((fun t (_ : t) => t) _ e)) (only parsing). + End base. + Global Coercion base.type.type_base : base.type.base >-> base.type.type. + Bind Scope etype_scope with base.type. + Infix "*" := base.type.prod : etype_scope. + Notation "()" := (base.type.type_base base.type.unit) : etype_scope. + + Module expr. + Section with_var. + Context {base_type : Type}. + Local Notation type := (type base_type). + Context {ident : type -> Type} + {var : type -> Type}. + + Inductive expr : type -> Type := + | Ident {t} (idc : ident t) : expr t + | Var {t} (v : var t) : expr t + | Abs {s d} (f : var s -> expr d) : expr (s -> d) + | App {s d} (f : expr (s -> d)) (x : expr s) : expr d + | LetIn {A B} (x : expr A) (f : var A -> expr B) : expr B + . + End with_var. + + Fixpoint interp {base_type ident} {interp_base_type : base_type -> Type} + (interp_ident : forall t, ident t -> type.interp interp_base_type t) + {t} (e : @expr base_type ident (type.interp interp_base_type) t) + : type.interp interp_base_type t + := match e in expr t return type.interp _ t with + | Ident t idc => interp_ident _ idc + | Var t v => v + | Abs s d f => fun x => @interp _ _ _ interp_ident _ (f x) + | App s d f x => (@interp _ _ _ interp_ident _ f) + (@interp _ _ _ interp_ident _ x) + | LetIn A B x f + => dlet y := @interp _ _ _ interp_ident _ x in + @interp _ _ _ interp_ident _ (f y) + end. + + Definition Expr {base_type ident} t := forall var, @expr base_type ident var t. + Definition APP {base_type ident s d} (f : Expr (s -> d)) (x : Expr s) : Expr d + := fun var => @App base_type ident var s d (f var) (x var). + + Definition Interp {base_type ident interp_base_type} interp_ident {t} (e : @Expr base_type ident t) + : type.interp interp_base_type t + := @interp base_type ident interp_base_type interp_ident t (e _). + + (** [Interp (APP _ _)] is the same thing as Gallina application of + the [Interp]retations of the two arguments to [APP]. *) + Definition Interp_APP {base_type ident interp_base_type interp_ident} {s d} (f : @Expr base_type ident (s -> d)) (x : @Expr base_type ident s) + : @Interp base_type ident interp_base_type interp_ident _ (APP f x) + = Interp interp_ident f (Interp interp_ident x) + := eq_refl. + + (** Same as [Interp_APP], but for any reflexive relation, not just + [eq] *) + Definition Interp_APP_rel_reflexive {base_type ident interp_base_type interp_ident} {s d} {R} {H:Reflexive R} + (f : @Expr base_type ident (s -> d)) (x : @Expr base_type ident s) + : R (@Interp base_type ident interp_base_type interp_ident _ (APP f x)) + (Interp interp_ident f (Interp interp_ident x)) + := H _. + + Module var_context. + Inductive list {base_type} {var : type base_type -> Type} := + | nil + | cons {T t} (gallina_v : T) (v : var t) (ctx : list). + End var_context. + + (* cf COQBUG(https://github.com/coq/coq/issues/5448) , COQBUG(https://github.com/coq/coq/issues/6315) , COQBUG(https://github.com/coq/coq/issues/6559) , COQBUG(https://github.com/coq/coq/issues/6534) , https://github.com/mit-plv/fiat-crypto/issues/320 *) + Ltac require_same_var n1 n2 := + (*idtac n1 n2;*) + let c1 := constr:(fun n1 n2 : Set => ltac:(exact n1)) in + let c2 := constr:(fun n1 n2 : Set => ltac:(exact n2)) in + (*idtac c1 c2;*) + first [ constr_eq c1 c2 | fail 1 "Not the same var:" n1 "and" n2 "(via constr_eq" c1 c2 ")" ]. + Ltac is_same_var n1 n2 := + match goal with + | _ => let check := match goal with _ => require_same_var n1 n2 end in + true + | _ => false + end. + Ltac is_underscore v := + let v' := fresh v in + let v' := fresh v' in + is_same_var v v'. + Ltac refresh n fresh_tac := + let n_is_underscore := is_underscore n in + let n' := lazymatch n_is_underscore with + | true => fresh + | false => fresh_tac n + end in + let n' := fresh_tac n' in + n'. + + Ltac type_of_first_argument_of f := + let f_ty := type of f in + lazymatch eval hnf in f_ty with + | forall x : ?T, _ => T + end. + + (** Forms of abstraction in Gallina that our reflective language + cannot handle get handled by specializing the code "template" + to each particular application of that abstraction. In + particular, type arguments (nat, Z, (λ _, nat), etc) get + substituted into lambdas and treated as a integral part of + primitive operations (such as [@List.app T], [@list_rect (λ _, + nat)]). During reification, we accumulate them in a + right-associated tuple, using [tt] as the "nil" base case. + When we hit a λ or an identifier, we plug in the template + parameters as necessary. *) + Ltac require_template_parameter parameter_type := + first [ unify parameter_type Prop + | unify parameter_type Set + | unify parameter_type Type + | lazymatch eval hnf in parameter_type with + | forall x : ?T, @?P x + => let check := constr:(fun x : T + => ltac:(require_template_parameter (P x); + exact I)) in + idtac + end ]. + Ltac is_template_parameter parameter_type := + is_success_run_tactic ltac:(fun _ => require_template_parameter parameter_type). + Ltac plug_template_ctx f template_ctx := + lazymatch template_ctx with + | tt => f + | (?arg, ?template_ctx') + => + let T := type_of_first_argument_of f in + let x_is_template_parameter := is_template_parameter T in + lazymatch x_is_template_parameter with + | true + => plug_template_ctx (f arg) template_ctx' + | false + => constr:(fun x : T + => ltac:(let v := plug_template_ctx (f x) template_ctx in + exact v)) + end + end. + + Ltac reify_in_context base_type ident reify_base_type reify_ident var term value_ctx template_ctx := + let reify_rec_gen term value_ctx template_ctx := reify_in_context base_type ident reify_base_type reify_ident var term value_ctx template_ctx in + let reify_rec term := reify_rec_gen term value_ctx template_ctx in + let reify_rec_not_head term := reify_rec_gen term value_ctx tt in + let do_reify_ident term else_tac + := reify_ident + term + ltac:(fun idc => constr:(@Ident base_type ident var _ idc)) + reify_rec + else_tac in + let __ := Reify.debug_enter_reify_in_context term in + lazymatch value_ctx with + | context[@var_context.cons _ _ ?T ?rT term ?v _] + => constr:(@Var base_type ident var rT v) + | _ + => + lazymatch term with + | match ?b with true => ?t | false => ?f end + => let T := type of term in + reify_rec (@bool_rect (fun _ => T) t f b) + | match ?x with Datatypes.pair a b => ?f end + => let x' := fresh in + let T := type of x in + reify_rec ((fun x' : T + => match Datatypes.fst x, Datatypes.snd x return _ with + | a, b => f + end) x) + | match ?x with nil => ?N | cons a b => @?C a b end + => let T := type of term in + reify_rec (@list_case _ (fun _ => T) N C x) + | let x := ?a in @?b x + => let A := type of a in + let B := lazymatch type of b with forall x, @?B x => B end in + reify_rec (b a) (*(@Let_In A B a b)*) + | @Let_In ?A ?B ?a ?b + => let ra := reify_rec a in + let rb := reify_rec b in + lazymatch rb with + | @Abs _ _ _ ?s ?d ?f + => constr:(@LetIn base_type ident var s d ra f) + | ?rb => let __ := match goal with + | _ => fail 1 "Invalid non-Abs function reification of" b "to" rb + end in + constr:(I : I) + end + | (fun x : ?T => ?f) + => + let x_is_template_parameter := is_template_parameter T in + lazymatch x_is_template_parameter with + | true + => + lazymatch template_ctx with + | (?arg, ?template_ctx) + => (* we pull a trick with [match] to plug in [arg] without running cbv β *) + lazymatch type of term with + | forall y, ?P + => reify_rec_gen (match arg as y return P with x => f end) value_ctx template_ctx + end + end + | false + => + let rT := type.reify reify_base_type base_type T in + let not_x := fresh (* could be [refresh x ltac:(fun n => fresh n)] in 8.8; c.f. https://github.com/mit-plv/fiat-crypto/issues/320 and probably COQBUG(https://github.com/coq/coq/issues/6534) *) in + let not_x2 := fresh (* could be [refresh not_x ltac:(fun n => fresh n)] in 8.8; c.f. https://github.com/mit-plv/fiat-crypto/issues/320 and probably COQBUG(https://github.com/coq/coq/issues/6534) *) in + let not_x3 := fresh (* could be [refresh not_x2 ltac:(fun n => fresh n)] in 8.8; c.f. https://github.com/mit-plv/fiat-crypto/issues/320 and probably COQBUG(https://github.com/coq/coq/issues/6534) *) in + (*let __ := match goal with _ => idtac "reify_in_context: λ case:" term "using vars:" not_x not_x2 not_x3 end in*) + let rf0 := + constr:( + fun (x : T) (not_x : var rT) + => match f, @var_context.cons base_type var T rT x not_x value_ctx return _ with (* c.f. COQBUG(https://github.com/coq/coq/issues/6252#issuecomment-347041995) for [return _] *) + | not_x2, not_x3 + => ltac:( + let f := (eval cbv delta [not_x2] in not_x2) in + let var_ctx := (eval cbv delta [not_x3] in not_x3) in + (*idtac "rec call" f "was" term;*) + let rf := reify_rec_gen f var_ctx template_ctx in + exact rf) + end) in + lazymatch rf0 with + | (fun _ => ?rf) + => constr:(@Abs base_type ident var rT _ rf) + | _ + => (* This will happen if the reified term still + mentions the non-var variable. By chance, [cbv + delta] strips type casts, which are only places + that I can think of where such dependency might + remain. However, if this does come up, having a + distinctive error message is much more useful for + debugging than the generic "no matching clause" *) + let __ := match goal with + | _ => fail 1 "Failure to eliminate functional dependencies of" rf0 + end in + constr:(I : I) + end + end + | _ + => + do_reify_ident + term + ltac:( + fun _ + => + lazymatch term with + | ?f ?x + => + let ty := type_of_first_argument_of f in + let x_is_template_parameter := is_template_parameter ty in + lazymatch x_is_template_parameter with + | true + => (* we can't reify things of type [Type], so we save it for later to plug in *) + reify_rec_gen f value_ctx (x, template_ctx) + | false + => let rx := reify_rec_gen x value_ctx tt in + let rf := reify_rec_gen f value_ctx template_ctx in + constr:(App (base_type:=base_type) (ident:=ident) (var:=var) rf rx) + end + | _ + => let term' := plug_template_ctx term template_ctx in + do_reify_ident + term' + ltac:(fun _ + => + (*let __ := match goal with _ => idtac "Attempting to unfold" term end in*) + let term + := match constr:(Set) with + | _ => (eval cbv delta [term] in term) (* might fail, so we wrap it in a match to give better error messages *) + | _ + => let __ := match goal with + | _ => fail 2 "Unrecognized term:" term' + end in + constr:(I : I) + end in + reify_rec term) + end) + end + end. + Ltac reify base_type ident reify_base_type reify_ident var term := + reify_in_context base_type ident reify_base_type reify_ident var term (@var_context.nil base_type var) tt. + Ltac Reify base_type ident reify_base_type reify_ident term := + constr:(fun var : type base_type -> Type + => ltac:(let r := reify base_type ident reify_base_type reify_ident var term in + exact r)). + Ltac Reify_rhs base_type ident reify_base_type reify_ident base_interp interp_ident _ := + let RHS := lazymatch goal with |- _ = ?RHS => RHS end in + let R := Reify base_type ident reify_base_type reify_ident RHS in + transitivity (@Interp base_type ident base_interp interp_ident _ R); + [ | reflexivity ]. + + Module Export Notations. + Delimit Scope expr_scope with expr. + Delimit Scope Expr_scope with Expr. + Delimit Scope expr_pat_scope with expr_pat. + Bind Scope expr_scope with expr. + Bind Scope Expr_scope with Expr. + Infix "@" := App : expr_scope. + Infix "@" := APP : Expr_scope. + Notation "\ x .. y , f" := (Abs (fun x => .. (Abs (fun y => f%expr)) .. )) : expr_scope. + Notation "'λ' x .. y , f" := (Abs (fun x => .. (Abs (fun y => f%expr)) .. )) : expr_scope. + Notation "'expr_let' x := A 'in' b" := (LetIn A (fun x => b%expr)) : expr_scope. + Notation "'$' x" := (Var x) (at level 10, format "'$' x") : expr_scope. + Notation "### x" := (Ident x) : expr_scope. + End Notations. + End expr. + Export expr.Notations. + Notation expr := expr.expr. + + Module ident. + Local Notation type := (type base.type). + Local Notation ttype := type. + Module fancy. + Section with_base. + Let type_base (x : base.type) : type := type.base x. + Local Coercion type_base : base.type >-> type. + Section with_scope. + Import base.type. + Notation type := ttype. + + Inductive ident_with_wordmax {log2wordmax : BinInt.Z} : base.type -> base.type -> Set := + | add (imm : BinInt.Z) : ident_with_wordmax (Z * Z) (Z * Z) + | addc (imm : BinInt.Z) : ident_with_wordmax (Z * Z * Z) (Z * Z) + | sub (imm : BinInt.Z) : ident_with_wordmax (Z * Z) (Z * Z) + | subb (imm : BinInt.Z) : ident_with_wordmax (Z * Z * Z) (Z * Z) + | mulll : ident_with_wordmax (Z * Z) Z + | mullh : ident_with_wordmax (Z * Z) Z + | mulhl : ident_with_wordmax (Z * Z) Z + | mulhh : ident_with_wordmax (Z * Z) Z + | selm : ident_with_wordmax (Z * Z * Z) Z + | rshi : BinInt.Z -> ident_with_wordmax (Z * Z) Z + . + + Inductive ident : base.type -> base.type -> Set := + | with_wordmax (log2wordmax : BinInt.Z) {s d} (idc : @ident_with_wordmax log2wordmax s d) : ident s d + | selc : ident (Z * Z * Z) Z + | sell : ident (Z * Z * Z) Z + | addm : ident (Z * Z * Z) Z + . + + Section interp_with_wordmax. + Context (log2wordmax : BinInt.Z). + Let wordmax := 2 ^ log2wordmax. + Let half_bits := log2wordmax / 2. + Let wordmax_half_bits := 2 ^ half_bits. + + Local Notation low x := (Z.land x (wordmax_half_bits - 1)). + Local Notation high x := (x >> half_bits). + Local Notation shift x imm := ((x << imm) mod wordmax). + + Definition interp_with_wordmax {s d} (idc : @ident_with_wordmax log2wordmax s d) : base.interp s -> base.interp d := + match idc with + | add imm => fun x => Z.add_get_carry_full wordmax (fst x) (shift (snd x) imm) + | addc imm => fun x => Z.add_with_get_carry_full wordmax (fst (fst x)) (snd (fst x)) (shift (snd x) imm) + | sub imm => fun x => Z.sub_get_borrow_full wordmax (fst x) (shift (snd x) imm) + | subb imm => fun x => Z.sub_with_get_borrow_full wordmax (fst (fst x)) (snd (fst x)) (shift (snd x) imm) + | mulll => fun x => low (fst x) * low (snd x) + | mullh => fun x => low (fst x) * high (snd x) + | mulhl => fun x => high (fst x) * low (snd x) + | mulhh => fun x => high (fst x) * high (snd x) + | rshi n => fun x => Z.rshi wordmax (fst x) (snd x) n + | selm => fun x => Z.zselect (Z.cc_m wordmax (fst (fst x))) (snd (fst x)) (snd x) + end. + End interp_with_wordmax. + + Definition interp {s d} (idc : @ident s d) : base.interp s -> base.interp d := + match idc with + | with_wordmax lwm s d idc => interp_with_wordmax lwm idc + | selc => fun x => Z.zselect (fst (fst x)) (snd (fst x)) (snd x) + | sell => fun x => Z.zselect (Z.land (fst (fst x)) 1) (snd (fst x)) (snd x) + | addm => fun x => Z.add_modulo (fst (fst x)) (snd (fst x)) (snd x) + end. + End with_scope. + End with_base. + Global Coercion with_wordmax : ident_with_wordmax >-> ident. + Global Arguments interp_with_wordmax {_ s d} idc. + Global Arguments interp {s d} idc. + End fancy. + + Section with_base. + Let type_base (x : base.type) : type := type.base x. + Local Coercion type_base : base.type >-> type. + Section with_scope. + Import base.type. + Notation type := ttype. + + (* N.B. [ident] must have essentially flat structure for the + python script constructing [pattern.ident] to work *) + Inductive ident : type -> Type := + | Literal {t:base.type.base} (v : base.interp t) : ident t + | Nat_succ : ident (nat -> nat) + | Nat_pred : ident (nat -> nat) + | Nat_max : ident (nat -> nat -> nat) + | Nat_mul : ident (nat -> nat -> nat) + | Nat_add : ident (nat -> nat -> nat) + | Nat_sub : ident (nat -> nat -> nat) + | nil {t} : ident (list t) + | cons {t:base.type} : ident (t -> list t -> list t) + | pair {A B:base.type} : ident (A -> B -> A * B) + | fst {A B} : ident (A * B -> A) + | snd {A B} : ident (A * B -> B) + | pair_rect {A B T:base.type} : ident ((A -> B -> T) -> A * B -> T) + | bool_rect {T:base.type} : ident ((unit -> T) -> (unit -> T) -> bool -> T) + | nat_rect {P:base.type} : ident ((unit -> P) -> (nat -> P -> P) -> nat -> P) + | list_rect {A P:base.type} : ident ((unit -> P) -> (A -> list A -> P -> P) -> list A -> P) + | list_case {A P:base.type} : ident ((unit -> P) -> (A -> list A -> P) -> list A -> P) + | List_length {T} : ident (list T -> nat) + | List_seq : ident (nat -> nat -> list nat) + | List_repeat {A:base.type} : ident (A -> nat -> list A) + | List_combine {A B} : ident (list A -> list B -> list (A * B)) + | List_map {A B:base.type} : ident ((A -> B) -> list A -> list B) + | List_app {A} : ident (list A -> list A -> list A) + | List_rev {A} : ident (list A -> list A) + | List_flat_map {A B:base.type} : ident ((A -> (list B)) -> list A -> (list B)) + | List_partition {A:base.type} : ident ((A -> bool) -> list A -> (list A * list A)) + | List_fold_right {A B:base.type} : ident ((B -> A -> A) -> A -> list B -> A) + | List_update_nth {T:base.type} : ident (nat -> (T -> T) -> list T -> list T) + | List_nth_default {T:base.type} : ident (T -> list T -> nat -> T) + | Z_add : ident (Z -> Z -> Z) + | Z_mul : ident (Z -> Z -> Z) + | Z_pow : ident (Z -> Z -> Z) + | Z_sub : ident (Z -> Z -> Z) + | Z_opp : ident (Z -> Z) + | Z_div : ident (Z -> Z -> Z) + | Z_modulo : ident (Z -> Z -> Z) + | Z_eqb : ident (Z -> Z -> bool) + | Z_leb : ident (Z -> Z -> bool) + | Z_of_nat : ident (nat -> Z) + | Z_shiftr (offset : BinInt.Z) : ident (Z -> Z) + | Z_shiftl (offset : BinInt.Z) : ident (Z -> Z) + | Z_land (mask : BinInt.Z) : ident (Z -> Z) + | Z_mul_split : ident (Z -> Z -> Z -> Z * Z) + | Z_mul_split_concrete (s:BinInt.Z) : ident (Z -> Z -> Z * Z) + | Z_add_get_carry : ident (Z -> Z -> Z -> (Z * Z)) + | Z_add_get_carry_concrete (s:BinInt.Z) : ident (Z -> Z -> (Z * Z)) + | Z_add_with_carry : ident (Z -> Z -> Z -> Z) + | Z_add_with_get_carry : ident (Z -> Z -> Z -> Z -> (Z * Z)) + | Z_add_with_get_carry_concrete (s:BinInt.Z) : ident (Z -> Z -> Z -> Z * Z) + | Z_sub_get_borrow : ident (Z -> Z -> Z -> (Z * Z)) + | Z_sub_get_borrow_concrete (s:BinInt.Z) : ident (Z -> Z -> Z * Z) + | Z_sub_with_get_borrow : ident (Z -> Z -> Z -> Z -> (Z * Z)) + | Z_sub_with_get_borrow_concrete (s:BinInt.Z) : ident (Z -> Z -> Z -> Z * Z) + | Z_zselect : ident (Z -> Z -> Z -> Z) + | Z_add_modulo : ident (Z -> Z -> Z -> Z) + | Z_rshi : ident (Z -> Z -> Z -> Z -> Z) + | Z_rshi_concrete (s offset:BinInt.Z) : ident (Z -> Z -> Z) + | Z_cc_m : ident (Z -> Z -> Z) + | Z_cc_m_concrete (s:BinInt.Z) : ident (Z -> Z) + | Z_neg_snd : ident ((Z * Z) -> Z * Z) (** TODO(jadep): This is only here for demonstration purposes; remove it once you no longer need it as a template; N.B. the type signature here says "given any amount of information about a thing of type [ℤ * ℤ], we promise to return a concrete pair of some amount of information about a thing of type ℤ and a thing of type ℤ" *) + | Z_cast (range : zrange) : ident (Z -> Z) + | Z_cast2 (range : zrange * zrange) : ident ((Z * Z) -> (Z * Z)) + | fancy_add (log2wordmax : BinInt.Z) (imm : BinInt.Z) : ident (Z * Z -> Z * Z) + | fancy_addc (log2wordmax : BinInt.Z) (imm : BinInt.Z) : ident (Z * Z * Z -> Z * Z) + | fancy_sub (log2wordmax : BinInt.Z) (imm : BinInt.Z) : ident (Z * Z -> Z * Z) + | fancy_subb (log2wordmax : BinInt.Z) (imm : BinInt.Z) : ident (Z * Z * Z -> Z * Z) + | fancy_mulll (log2wordmax : BinInt.Z) : ident (Z * Z -> Z) + | fancy_mullh (log2wordmax : BinInt.Z) : ident (Z * Z -> Z) + | fancy_mulhl (log2wordmax : BinInt.Z) : ident (Z * Z -> Z) + | fancy_mulhh (log2wordmax : BinInt.Z) : ident (Z * Z -> Z) + | fancy_rshi (log2wordmax : BinInt.Z) : BinInt.Z -> ident (Z * Z -> Z) + | fancy_selc : ident (Z * Z * Z -> Z) + | fancy_selm (log2wordmax : BinInt.Z) : ident (Z * Z * Z -> Z) + | fancy_sell : ident (Z * Z * Z -> Z) + | fancy_addm : ident (Z * Z * Z -> Z) + . + + Definition to_fancy {s d : base.type} (idc : ident (s -> d)) : option (fancy.ident s d) + := match idc in ident t return option match t with + | type.base s -> type.base d => fancy.ident s d + | _ => Datatypes.unit + end%etype with + | fancy_add log2wordmax imm => Some (fancy.with_wordmax log2wordmax (fancy.add imm)) + | fancy_addc log2wordmax imm => Some (fancy.with_wordmax log2wordmax (fancy.addc imm)) + | fancy_sub log2wordmax imm => Some (fancy.with_wordmax log2wordmax (fancy.sub imm)) + | fancy_subb log2wordmax imm => Some (fancy.with_wordmax log2wordmax (fancy.subb imm)) + | fancy_mulll log2wordmax => Some (fancy.with_wordmax log2wordmax fancy.mulll) + | fancy_mullh log2wordmax => Some (fancy.with_wordmax log2wordmax fancy.mullh) + | fancy_mulhl log2wordmax => Some (fancy.with_wordmax log2wordmax fancy.mulhl) + | fancy_mulhh log2wordmax => Some (fancy.with_wordmax log2wordmax fancy.mulhh) + | fancy_rshi log2wordmax x => Some (fancy.with_wordmax log2wordmax (fancy.rshi x)) + | fancy_selc => Some fancy.selc + | fancy_selm log2wordmax => Some (fancy.with_wordmax log2wordmax fancy.selm) + | fancy_sell => Some fancy.sell + | fancy_addm => Some fancy.addm + | _ => None + end. + End with_scope. + + Section gen. + Context (cast_outside_of_range : zrange -> BinInt.Z -> BinInt.Z). + + Definition cast (r : zrange) (x : BinInt.Z) + := if (lower r <=? x) && (x <=? upper r) + then x + else cast_outside_of_range r x. + + Local Notation wordmax log2wordmax := (2 ^ log2wordmax). + Local Notation half_bits log2wordmax := (log2wordmax / 2). + Local Notation wordmax_half_bits log2wordmax := (2 ^ (half_bits log2wordmax)). + + Local Notation low log2wordmax x := (Z.land x ((wordmax_half_bits log2wordmax) - 1)). + Local Notation high log2wordmax x := (x >> (half_bits log2wordmax)). + Local Notation shift log2wordmax x imm := ((x << imm) mod (wordmax log2wordmax)). + + (** Interpret identifiers where the behavior of [Z_cast] on a + value that does not fit in the range is given by a context + variable. (This allows us to treat [Z_cast] as "undefined + behavior" when the value doesn't fit in the range by + quantifying over all possible interpretations. *) + Definition gen_interp {t} (idc : ident t) : type.interp base.interp t + := match idc in ident t return type.interp base.interp t with + | Literal _ v => v + | Nat_succ => Nat.succ + | Nat_pred => Nat.pred + | Nat_max => Nat.max + | Nat_mul => Nat.mul + | Nat_add => Nat.add + | Nat_sub => Nat.sub + | nil t => Datatypes.nil + | cons t => Datatypes.cons + | pair A B => Datatypes.pair + | fst A B => Datatypes.fst + | snd A B => Datatypes.snd + | pair_rect A B T => fun f '((a, b) : base.interp A * base.interp B) => f a b + | bool_rect T + => fun t f => Datatypes.bool_rect _ (t tt) (f tt) + | nat_rect P + => fun O_case S_case => Datatypes.nat_rect _ (O_case tt) S_case + | list_rect A P + => fun N_case C_case => Datatypes.list_rect _ (N_case tt) C_case + | list_case A P + => fun N_case C_case => ListUtil.list_case _ (N_case tt) C_case + | List_length T => @List.length _ + | List_seq => List.seq + | List_repeat A => @repeat _ + | List_combine A B => @List.combine _ _ + | List_map A B => @List.map _ _ + | List_app A => @List.app _ + | List_rev A => @List.rev _ + | List_flat_map A B => @List.flat_map _ _ + | List_partition A => @List.partition _ + | List_fold_right A B => @List.fold_right _ _ + | List_update_nth T => update_nth + | List_nth_default T => @nth_default _ + | Z_add => Z.add + | Z_mul => Z.mul + | Z_pow => Z.pow + | Z_sub => Z.sub + | Z_opp => Z.opp + | Z_div => Z.div + | Z_modulo => Z.modulo + | Z_eqb => Z.eqb + | Z_leb => Z.leb + | Z_of_nat => Z.of_nat + | Z_shiftr offset => fun v => Z.shiftr v offset + | Z_shiftl offset => fun v => Z.shiftl v offset + | Z_land mask => fun v => Z.land v mask + | Z_mul_split => Z.mul_split + | Z_mul_split_concrete s => Z.mul_split s + | Z_add_get_carry => Z.add_get_carry_full + | Z_add_get_carry_concrete s => Z.add_get_carry_full s + | Z_add_with_carry => Z.add_with_carry + | Z_add_with_get_carry => Z.add_with_get_carry_full + | Z_add_with_get_carry_concrete s => Z.add_with_get_carry_full s + | Z_sub_get_borrow => Z.sub_get_borrow_full + | Z_sub_get_borrow_concrete s => Z.sub_get_borrow_full s + | Z_sub_with_get_borrow => Z.sub_with_get_borrow_full + | Z_sub_with_get_borrow_concrete s => Z.sub_with_get_borrow_full s + | Z_zselect => Z.zselect + | Z_add_modulo => Z.add_modulo + | Z_rshi => Z.rshi + | Z_rshi_concrete s offset => fun x y => Z.rshi s x y offset + | Z_cc_m => Z.cc_m + | Z_cc_m_concrete s => Z.cc_m s + | Z_neg_snd => fun '(x, y) => (x, -y) (** TODO(jadep): This is only here for demonstration purposes; remove it once you no longer need it as a template *) + | Z_cast r => cast r + | Z_cast2 (r1, r2) => fun '(x1, x2) => (cast r1 x1, cast r2 x2) + | fancy_add _ _ as idc + | fancy_addc _ _ as idc + | fancy_sub _ _ as idc + | fancy_subb _ _ as idc + | fancy_mulll _ as idc + | fancy_mullh _ as idc + | fancy_mulhl _ as idc + | fancy_mulhh _ as idc + | fancy_rshi _ _ as idc + | fancy_selc as idc + | fancy_selm _ as idc + | fancy_sell as idc + | fancy_addm as idc + => fancy.interp (invert_Some (to_fancy idc)) + end. + End gen. + + Definition cast_outside_of_range (r : zrange) (v : BinInt.Z) : BinInt.Z. + Proof. exact v. Qed. + + (** Interpret identifiers where [Z_cast] is an opaque identity + function when the value is not inside the range *) + Definition interp {t} (idc : ident t) : type.interp base.interp t + := @gen_interp cast_outside_of_range t idc. + Global Arguments interp _ !_ / . + End with_base. + Notation LiteralUnit := (@Literal base.type.unit). + Notation LiteralZ := (@Literal base.type.Z). + Notation LiteralBool := (@Literal base.type.bool). + Notation LiteralNat := (@Literal base.type.nat). + + (** TODO: MOVE ME? *) + Module Thunked. + Definition pair_rect {A B} P (f : A -> B -> P) (x : A * B) : P + := let '(a, b) := x in f a b. + Definition bool_rect P (t f : Datatypes.unit -> P) (b : bool) : P + := Datatypes.bool_rect (fun _ => P) (t tt) (f tt) b. + Definition list_rect {A} P (N : Datatypes.unit -> P) (C : A -> list A -> P -> P) (ls : list A) : P + := Datatypes.list_rect (fun _ => P) (N tt) C ls. + Definition list_case {A} P (N : Datatypes.unit -> P) (C : A -> list A -> P) (ls : list A) : P + := ListUtil.list_case (fun _ => P) (N tt) C ls. + Definition nat_rect P (O_case : unit -> P) (S_case : nat -> P -> P) (n : nat) : P + := Datatypes.nat_rect (fun _ => P) (O_case tt) S_case n. + End Thunked. + + Ltac require_primitive_const term := + lazymatch term with + | S ?n => require_primitive_const n + | O => idtac + | true => idtac + | false => idtac + | tt => idtac + | Z0 => idtac + | Zpos ?p => require_primitive_const p + | Zneg ?p => require_primitive_const p + | xI ?p => require_primitive_const p + | xO ?p => require_primitive_const p + | xH => idtac + | ?term => fail 0 "Not a known const:" term + end. + Ltac is_primitive_const term := + match constr:(Set) with + | _ => let check := match goal with + | _ => require_primitive_const term + end in + true + | _ => false + end. + + Ltac reify + term + then_tac + reify_rec + else_tac := + (*let __ := match goal with _ => idtac "attempting to reify_op" term end in*) + let term_is_primitive_const := is_primitive_const term in + lazymatch term_is_primitive_const with + | true + => + let T := type of term in + let rT := base.reify_base T in + then_tac (@ident.Literal rT term) + | false + => + lazymatch term with + | Nat.succ => then_tac Nat_succ + | Nat.add => then_tac Nat_add + | Nat.sub => then_tac Nat_sub + | Nat.mul => then_tac Nat_mul + | Nat.max => then_tac Nat_max + | Nat.pred => then_tac Nat_pred + | S => then_tac Nat_succ + | @Datatypes.nil ?T + => let rT := base.reify T in + then_tac (@ident.nil rT) + | @Datatypes.cons ?T + => let rT := base.reify T in + then_tac (@ident.cons rT) + | @Datatypes.fst ?A ?B + => let rA := base.reify A in + let rB := base.reify B in + then_tac (@ident.fst rA rB) + | @Datatypes.snd ?A ?B + => let rA := base.reify A in + let rB := base.reify B in + then_tac (@ident.snd rA rB) + | @Datatypes.pair ?A ?B + => let rA := base.reify A in + let rB := base.reify B in + then_tac (@ident.pair rA rB) + | @Datatypes.bool_rect (fun _ => ?T) ?Ptrue ?Pfalse + => reify_rec (@Thunked.bool_rect T (fun _ : Datatypes.unit => Ptrue) (fun _ : Datatypes.unit => Pfalse)) + | @Thunked.bool_rect ?T + => let rT := base.reify T in + then_tac (@ident.bool_rect rT) + | @Datatypes.nat_rect (fun _ => ?T) ?P0 + => reify_rec (@Thunked.nat_rect T (fun _ : Datatypes.unit => P0)) + | @Thunked.nat_rect ?T + => let rT := base.reify T in + then_tac (@ident.nat_rect rT) + | @Datatypes.list_rect ?A (fun _ => ?T) ?Pnil + => reify_rec (@Thunked.list_rect A T (fun _ : Datatypes.unit => Pnil)) + | @Thunked.list_rect ?A ?T + => let rA := base.reify A in + let rT := base.reify T in + then_tac (@ident.list_rect rA rT) + | @ListUtil.list_case ?A (fun _ => ?T) ?Pnil + => reify_rec (@Thunked.list_case A T (fun _ : Datatypes.unit => Pnil)) + | @Thunked.list_case ?A ?T + => let rA := base.reify A in + let rT := base.reify T in + then_tac (@ident.list_case rA rT) + | @List.length ?A => + let rA := base.reify A in + then_tac (@ident.List_length rA) + | List.seq => then_tac ident.List_seq + | @repeat ?A + => let rA := base.reify A in + then_tac (@ident.List_repeat rA) + | @combine ?A ?B + => let rA := base.reify A in + let rB := base.reify B in + then_tac (@ident.List_combine rA rB) + | @List.map ?A ?B + => let rA := base.reify A in + let rB := base.reify B in + then_tac (@ident.List_map rA rB) + | @List.flat_map ?A ?B + => let rA := base.reify A in + let rB := base.reify B in + then_tac (@ident.List_flat_map rA rB) + | @List.partition ?A + => let rA := base.reify A in + then_tac (@ident.List_partition rA) + | @List.app ?A + => let rA := base.reify A in + then_tac (@ident.List_app rA) + | @List.rev ?A + => let rA := base.reify A in + then_tac (@ident.List_rev rA) + | @List.fold_right ?A ?B + => let rA := base.reify A in + let rB := base.reify B in + then_tac (@ident.List_fold_right rA rB) + | @update_nth ?T + => let rT := base.reify T in + then_tac (@ident.List_update_nth rT) + | @List.nth_default ?T + => let rT := base.reify T in + then_tac (@ident.List_nth_default rT) + | Z.add => then_tac ident.Z_add + | Z.mul => then_tac ident.Z_mul + | Z.pow => then_tac ident.Z_pow + | Z.sub => then_tac ident.Z_sub + | Z.opp => then_tac ident.Z_opp + | Z.div => then_tac ident.Z_div + | Z.modulo => then_tac ident.Z_modulo + | Z.eqb => then_tac ident.Z_eqb + | Z.leb => then_tac ident.Z_leb + | Z.of_nat => then_tac ident.Z_of_nat + | Z.mul_split => then_tac ident.Z_mul_split + | Z.add_get_carry_full => then_tac ident.Z_add_get_carry + | Z.add_with_carry => then_tac ident.Z_add_with_carry + | Z.add_with_get_carry_full => then_tac ident.Z_add_with_get_carry + | Z.sub_get_borrow_full => then_tac ident.Z_sub_get_borrow + | Z.sub_with_get_borrow_full => then_tac ident.Z_sub_with_get_borrow + | Z.zselect => then_tac ident.Z_zselect + | Z.add_modulo => then_tac ident.Z_add_modulo + | Z.rshi => then_tac ident.Z_rshi + | Z.cc_m => then_tac ident.Z_cc_m + | _ => else_tac () + end + end. + + Fixpoint smart_Literal {var} {t:base.type} : base.interp t -> @expr.expr base.type ident var (type.base t) + := match t with + | base.type.type_base t => fun v => expr.Ident (ident.Literal v) + | base.type.prod A B + => fun '((a, b) : base.interp A * base.interp B) + => expr.Ident ident.pair @ (@smart_Literal var A a) @ (@smart_Literal var B b) + | base.type.list A + => fun v : list (base.interp A) + => fold_right + (fun x xs => expr.Ident ident.cons @ x @ xs) + (expr.Ident ident.nil) + (List.map (@smart_Literal var A) v) + end%expr. + + Module Export Notations. + Delimit Scope ident_scope with ident. + Bind Scope ident_scope with ident. + Global Arguments expr.Ident {base_type%type ident%function var%function t%etype} idc%ident. + Notation "## x" := (Literal x) (only printing) : ident_scope. + Notation "## x" := (Literal (t:=base.reify_base_type_of x) x) (only parsing) : ident_scope. + Notation "## x" := (expr.Ident (Literal x)) (only printing) : expr_scope. + Notation "## x" := (smart_Literal (t:=base.reify_type_of x) x) (only parsing) : expr_scope. + Notation "# x" := (expr.Ident x) : expr_pat_scope. + Notation "# x" := (@expr.Ident base.type _ _ _ x) : expr_scope. + Notation "x @ y" := (expr.App x%expr_pat y%expr_pat) : expr_pat_scope. + Notation "( x , y , .. , z )" := (expr.App (expr.App (#pair) .. (expr.App (expr.App (#pair) x%expr) y%expr) .. ) z%expr) : expr_scope. + Notation "( x , y , .. , z )" := (expr.App (expr.App (#pair)%expr_pat .. (expr.App (expr.App (#pair)%expr_pat x%expr_pat) y%expr_pat) .. ) z%expr_pat) : expr_pat_scope. + Notation "x :: y" := (#cons @ x @ y)%expr : expr_scope. + Notation "[ ]" := (#nil)%expr : expr_scope. + Notation "x :: y" := (#cons @ x @ y)%expr_pat : expr_pat_scope. + Notation "[ ]" := (#nil)%expr_pat : expr_pat_scope. + Notation "[ x ]" := (x :: [])%expr : expr_scope. + Notation "[ x ; y ; .. ; z ]" := (#cons @ x @ (#cons @ y @ .. (#cons @ z @ #nil) ..))%expr : expr_scope. + Notation "ls [[ n ]]" + := ((#(List_nth_default) @ _ @ ls @ #(Literal n%nat))%expr) + : expr_scope. + Notation "xs ++ ys" := (#List_app @ xs @ ys)%expr : expr_scope. + Notation "x - y" := (#Z_sub @ x @ y)%expr : expr_scope. + Notation "x + y" := (#Z_add @ x @ y)%expr : expr_scope. + Notation "x / y" := (#Z_div @ x @ y)%expr : expr_scope. + Notation "x * y" := (#Z_mul @ x @ y)%expr : expr_scope. + Notation "x >> y" := (#(Z_shiftr y) @ x)%expr : expr_scope. + Notation "x << y" := (#(Z_shiftl y) @ x)%expr : expr_scope. + Notation "x 'mod' y" := (#Z_modulo @ x @ y)%expr : expr_scope. + Notation "- x" := (#Z_opp @ x)%expr : expr_scope. + End Notations. + End ident. + Export ident.Notations. + Notation ident := ident.ident. + + Global Strategy -1000 [expr.Interp expr.interp ident.interp type.interp base.interp base.base_interp ident.gen_interp]. + Ltac reify var term := + expr.reify base.type ident ltac:(base.reify) ident.reify var term. + Ltac Reify term := + expr.Reify base.type ident ltac:(base.reify) ident.reify term. + Ltac Reify_rhs _ := + expr.Reify_rhs base.type ident ltac:(base.reify) ident.reify (@base.interp) (@ident.interp) (). + + Module Import invert_expr. + Module ident. + Definition invert_Literal_cps {t} (idc : ident t) : ~> option (type.interp base.interp t) + := fun T => match idc with + | ident.Literal _ n => fun k => k (Some n) + | _ => fun k => k None + end. + + Definition invert_Literal {t} (idc : ident t) : option (type.interp base.interp t) + := match idc with + | ident.Literal _ n => Some n + | _ => None + end. + End ident. + + Section with_var_gen. + Context {base_type} {ident var : type base_type -> Type}. + Local Notation expr := (@expr base_type ident var). + Local Notation if_arrow f t + := (match t return Type with + | type.arrow s d => f s d + | type.base _ => unit + end) (only parsing). + Definition invert_Ident {t} (e : expr t) + : option (ident t) + := match e with + | expr.Ident t idc => Some idc + | _ => None + end. + Definition invert_App {t} (e : expr t) + : option { s : _ & expr (s -> t) * expr s }%type + := match e with + | expr.App A B f x => Some (existT _ A (f, x)) + | _ => None + end. + Definition invert_Abs {s d} (e : expr (s -> d)) + : option (var s -> expr d)%type + := match e in expr.expr t return option (if_arrow (fun s d => var s -> expr d) t) with + | expr.Abs s d f => Some f + | _ => None + end. + Definition invert_App2 {t} (e : expr t) + : option { ss' : _ & expr (fst ss' -> snd ss' -> t) * expr (fst ss') * expr (snd ss') }%type + := (e <- invert_App e; + let '(existT s' (f', x')) := e in + f' <- invert_App f'; + let '(existT s (f, x)) := f' in + Some (existT _ (s, s') (f, x, x')))%option. + Definition invert_AppIdent {t} (e : expr t) + : option { s : _ & ident (s -> t) * expr s }%type + := (e <- invert_App e; + let '(existT s (f, x)) := e in + f' <- invert_Ident f; + Some (existT _ s (f', x)))%option. + Definition invert_AppIdent2 {t} (e : expr t) + : option { ss' : _ & ident (fst ss' -> snd ss' -> t) * expr (fst ss') * expr (snd ss') }%type + := (e <- invert_App2 e; + let '(existT ss' (f, x, x')) := e in + f' <- invert_Ident f; + Some (existT _ ss' (f', x, x')))%option. + Definition invert_Var {t} (e : expr t) + : option (var t) + := match e with + | expr.Var t v => Some v + | _ => None + end. + + Fixpoint App_curried {t} : expr t -> type.for_each_lhs_of_arrow expr t -> expr (type.base (type.final_codomain t)) + := match t with + | type.base t => fun e _ => e + | type.arrow s d => fun e x => @App_curried d (e @ (fst x)) (snd x) + end. + Fixpoint smart_App_curried {t} (e : expr t) : type.for_each_lhs_of_arrow var t -> expr (type.base (type.final_codomain t)) + := match e in expr.expr t return type.for_each_lhs_of_arrow var t -> expr (type.base (type.final_codomain t)) with + | expr.Abs s d f + => fun v => @smart_App_curried d (f (fst v)) (snd v) + | e + => fun v => @App_curried _ e (type.map_for_each_lhs_of_arrow (fun _ v => expr.Var v) v) + end. + End with_var_gen. + + Section with_var. + Context {var : type base.type -> Type}. + Local Notation expr := (@expr base.type ident var). + Local Notation try_transportP P := (@type.try_transport base.type (@base.try_make_transport_cps) P _ _). + Local Notation try_transport := (try_transportP _). + Let type_base (v : base.type) : type.type base.type := type.base v. + Coercion type_base : base.type >-> type.type. + + Definition invert_Z_opp {t} (e : expr t) + : option (expr t) + := match e in expr.expr t return option (expr t) with + | expr.App (type.base base.type.Z) (type.base base.type.Z) (#ident.Z_opp) v => Some v + | _ => None + end%expr_pat%expr. + + Definition invert_Z_cast (e : expr base.type.Z) + : option (zrange * expr base.type.Z) + := match e with + | expr.App (type.base base.type.Z) _ (#(ident.Z_cast r)) v => Some (r, v) + | _ => None + end%core%expr_pat%expr. + + Definition invert_Z_cast2 (e : expr (base.type.Z * base.type.Z)) + : option ((zrange * zrange) * expr (base.type.Z * base.type.Z)) + := match e with + | expr.App (type.base (base.type.Z * base.type.Z)) _ (#(ident.Z_cast2 r)) v => Some (r, v) + | _ => None + end%etype%core%expr_pat%expr. + + Definition invert_pair {A B} (e : expr (A * B)) + : option (expr A * expr B) + := match e with + | (a, b) + => a <- try_transport a; b <- try_transport b; Some (a, b)%core + | _ => None + end%expr_pat%expr%option. + Definition invert_Literal {t} (e : expr t) + : option (type.interp base.interp t) + := match e with + | expr.Ident _ idc => ident.invert_Literal idc + | _ => None + end%expr_pat%expr. + End with_var. + + Definition reify_list {var} {t : base.type} (ls : list (@expr.expr base.type ident var (type.base t))) : expr (type.base (base.type.list t)) + := fold_right + (fun x xs => x :: xs)%expr + []%expr + ls. + + Fixpoint reflect_list_cps' {var t} (e : @expr.expr base.type ident var t) {struct e} + : ~> option (list (@expr.expr base.type ident var (type.base match t return base.type with + | type.base (base.type.list t) => t + | _ => base.type.unit + end))) + := match e in expr.expr t return ~> option (list (@expr.expr base.type ident var (type.base match t return base.type with + | type.base (base.type.list t) => t + | _ => base.type.unit + end))) + with + | [] => (return (Some nil)) + | x :: xs + => (x' <-- type.try_transport_cps base.try_make_transport_cps (@expr.expr base.type ident var) _ _ x; + xs' <-- @reflect_list_cps' var _ xs; + xs' <-- type.try_transport_cps base.try_make_transport_cps (fun t => list (@expr.expr _ _ _ (type.base match t return base.type with + | type.base (base.type.list t) => t + | _ => base.type.unit + end))) _ _ xs'; + return (Some (x' :: xs')%list)) + | _ => (return None) + end%expr_pat%expr%cps. + + Definition reflect_list_cps {var t} (e : @expr.expr base.type ident var (type.base (base.type.list t))) + : ~> option (list (@expr.expr base.type ident var (type.base t))) + := reflect_list_cps' e. + Global Arguments reflect_list_cps {var t} e [T] k. + + Definition reflect_list {var t} (e : @expr.expr base.type ident var (type.base (base.type.list t))) + : option (list (@expr.expr base.type ident var (type.base t))) + := reflect_list_cps e id. + End invert_expr. + + Module DefaultValue. + (** This module provides "default" inhabitants for the + interpretation of PHOAS types and for the PHOAS [expr] type. + These values are used for things like [nth_default] and in + other places where we need to provide a dummy value in cases + that will never actually be reached in correctly used code. *) + Module type. + Module base. + Fixpoint default {t : base.type} : base.interp t + := match t with + | base.type.unit => tt + | base.type.Z => (-1)%Z + | base.type.nat => 0%nat + | base.type.bool => true + | base.type.list _ => nil + | base.type.prod A B + => (@default A, @default B) + end. + End base. + Fixpoint default {t} : type.interp base.interp t + := match t with + | type.base x => @base.default x + | type.arrow s d => fun _ => @default d + end. + End type. + + Module expr. + Module base. + Section with_var. + Context {var : type.type base.type -> Type}. + Fixpoint default {t : base.type} : @expr base.type ident var (type.base t) + := match t with + | base.type.prod A B + => (@default A, @default B) + | base.type.list A => #ident.nil + | base.type.unit as t + | base.type.Z as t + | base.type.nat as t + | base.type.bool as t + => ##(@type.base.default t) + end%expr. + End with_var. + + Definition Default {t : base.type} : expr.Expr (type.base t) := fun _ => default. + End base. + + Section with_var. + Context {var : type base.type -> Type}. + Fixpoint default {t : type base.type} : @expr base.type ident var t + := match t with + | type.base x => base.default + | type.arrow s d => λ _, @default d + end%expr. + End with_var. + + Definition Default {t} : expr.Expr t := fun _ => default. + End expr. + End DefaultValue. + + Module Import defaults. + Notation expr := (@expr base.type ident). + Notation Expr := (@expr.Expr base.type ident). + Notation type := (type base.type). + Global Coercion type_base (t : base.type) : type := type.base t. + Global Arguments type_base _ / . + Notation interp := (@expr.interp base.type ident base.interp (@ident.interp)). + Notation Interp := (@expr.Interp base.type ident base.interp (@ident.interp)). + Ltac reify_type ty := type.reify ltac:(base.reify) base.type ty. + Notation reify_type t := (ltac:(let rt := reify_type t in exact rt)) (only parsing). + Notation reify_type_of e := (reify_type ((fun t (_ : t) => t) _ e)) (only parsing). + End defaults. + + Section gallina_reify. + Context {var : type -> Type}. + Definition reify_list {t} (ls : list (@expr var (type.base t))) : @expr var (base.type.list t) + := (list_rect + (fun _ => _) + (#ident.nil) + (fun x _ xs => x :: xs) + ls)%expr. + End gallina_reify. + + Lemma interp_reify_list {t} ls + : interp (@reify_list _ t ls) = List.map interp ls. + Proof. + unfold reify_list. + induction ls as [|x xs IHxs]; cbn in *; [ reflexivity | ]. + rewrite IHxs; reflexivity. + Qed. + + Module GallinaReify. + Module base. + Fixpoint value (t : base.type) : Set + := match t with + | base.type.unit as t + | base.type.Z as t + | base.type.bool as t + | base.type.nat as t + => base.interp t + | base.type.prod A B => value A * value B + | base.type.list A => list (value A) + end%type. + + Section reify. + Context {var : type -> Type}. + Fixpoint reify {t : base.type} {struct t} + : value t -> @expr var t + := match t return value t -> expr t with + | base.type.prod A B as t + => fun '((a, b) : value A * value B) + => (@reify A a, @reify B b)%expr + | base.type.list A as t + => fun x : list (value A) + => reify_list (List.map (@reify A) x) + | base.type.unit as t + | base.type.Z as t + | base.type.bool as t + | base.type.nat as t + => fun x : base.interp t + => (##x)%expr + end. + End reify. + + Definition Reify_as (t : base.type) (v : value t) : Expr t + := fun var => reify v. + + (** [Reify] does Ltac type inference to get the type *) + Notation Reify v + := (Reify_as (base.reify_type_of v) (fun _ => v)) (only parsing). + End base. + + Section value. + Context (var : type -> Type). + Fixpoint value (t : type) + := match t return Type with + | type.arrow s d => var s -> value d + | type.base t => base.value t + end%type. + End value. + + Section reify. + Context {var : type -> Type}. + Fixpoint reify {t : type} {struct t} + : value var t -> @expr var t + := match t return value var t -> expr t with + | type.arrow s d + => fun (f : var s -> value var d) + => (λ x , @reify d (f x))%expr + | type.base t + => @base.reify var t + end. + End reify. + + Definition Reify_as (t : type) (v : forall var, value var t) : Expr t + := fun var => reify (v _). + + (** [Reify] does Ltac type inference to get the type *) + Notation Reify v + := (Reify_as (reify_type_of v) (fun _ => v)) (only parsing). + End GallinaReify. + + Module GeneralizeVar. + (** In both lazy and cbv evaluation strategies, reduction under + lambdas is only done at the very end. This means that if we + have a computation which returns a PHOAS syntax tree, and we + plug in two different values for [var], the computation is run + twice. This module provides a way of computing a + representation of terms which does not suffer from this issue. + By computing a flat representation, and then going back to + PHOAS, the cbv strategy will fully compute the preceeding + PHOAS passes only once, and the lazy strategy will share + computation among the various uses of [var] (because there are + no lambdas to get blocked on) and thus will also compute the + preceeding PHOAS passes only once. *) + Module Flat. + Inductive expr : type -> Set := + | Ident {t} (idc : ident t) : expr t + | Var (t : type) (n : positive) : expr t + | Abs (s : type) (n : positive) {d} (f : expr d) : expr (s -> d) + | App {s d} (f : expr (s -> d)) (x : expr s) : expr d + | LetIn {A B} (n : positive) (ex : expr A) (eC : expr B) : expr B. + End Flat. + + Definition ERROR {T} (v : T) : T. exact v. Qed. + + Fixpoint to_flat' {t} (e : @expr (fun _ => PositiveMap.key) t) + (cur_idx : PositiveMap.key) + : Flat.expr t + := match e in expr.expr t return Flat.expr t with + | expr.Var t v => Flat.Var t v + | expr.App s d f x => Flat.App + (@to_flat' _ f cur_idx) + (@to_flat' _ x cur_idx) + | expr.Ident t idc => Flat.Ident idc + | expr.Abs s d f + => Flat.Abs s cur_idx + (@to_flat' + d (f cur_idx) + (Pos.succ cur_idx)) + | expr.LetIn A B ex eC + => Flat.LetIn + cur_idx + (@to_flat' A ex cur_idx) + (@to_flat' + B (eC cur_idx) + (Pos.succ cur_idx)) + end. + + Fixpoint from_flat {t} (e : Flat.expr t) + : forall var, PositiveMap.t { t : type & var t } -> @expr var t + := match e in Flat.expr t return forall var, _ -> expr t with + | Flat.Var t v + => fun var ctx + => match (tv <- PositiveMap.find v ctx; + type.try_transport base.try_make_transport_cps var _ _ (projT2 tv))%option with + | Some v => expr.Var v + | None => ERROR DefaultValue.expr.default + end + | Flat.Ident t idc => fun var ctx => expr.Ident idc + | Flat.App s d f x + => let f' := @from_flat _ f in + let x' := @from_flat _ x in + fun var ctx => expr.App (f' var ctx) (x' var ctx) + | Flat.Abs s cur_idx d f + => let f' := @from_flat d f in + fun var ctx + => expr.Abs (fun v => f' var (PositiveMap.add cur_idx (existT _ s v) ctx)) + | Flat.LetIn A B cur_idx ex eC + => let ex' := @from_flat A ex in + let eC' := @from_flat B eC in + fun var ctx + => expr.LetIn + (ex' var ctx) + (fun v => eC' var (PositiveMap.add cur_idx (existT _ A v) ctx)) + end. + + Definition to_flat {t} (e : expr t) : Flat.expr t + := to_flat' e 1%positive. + Definition ToFlat {t} (E : Expr t) : Flat.expr t + := to_flat (E _). + Definition FromFlat {t} (e : Flat.expr t) : Expr t + := let e' := @from_flat t e in + fun var => e' var (PositiveMap.empty _). + Definition GeneralizeVar {t} (e : @expr (fun _ => PositiveMap.key) t) : Expr t + := FromFlat (to_flat e). + End GeneralizeVar. +End Compilers. diff --git a/src/Experiments/NewPipeline/MiscCompilerPasses.v b/src/Experiments/NewPipeline/MiscCompilerPasses.v new file mode 100644 index 000000000..becce25d1 --- /dev/null +++ b/src/Experiments/NewPipeline/MiscCompilerPasses.v @@ -0,0 +1,211 @@ +Require Import Coq.ZArith.ZArith. +Require Import Coq.MSets.MSetPositive. +Require Import Coq.FSets.FMapPositive. +Require Import Crypto.Util.ListUtil Coq.Lists.List. +Require Import Crypto.Experiments.NewPipeline.Language. +Require Import Crypto.Util.Notations. +Import ListNotations. Local Open Scope Z_scope. + +Module Compilers. + Export Language.Compilers. + Import invert_expr. + Import defaults. + + Module DeadCodeElimination. + Section with_ident. + Context {base_type : Type}. + Local Notation type := (type.type base_type). + Context {ident : type -> Type}. + Local Notation expr := (@expr.expr base_type ident). + Fixpoint compute_live' {t} (e : @expr (fun _ => PositiveSet.t) t) (cur_idx : positive) + : positive * PositiveSet.t + := match e with + | expr.Var t v => (cur_idx, v) + | expr.App s d f x + => let '(idx, live1) := @compute_live' _ f cur_idx in + let '(idx, live2) := @compute_live' _ x idx in + (idx, PositiveSet.union live1 live2) + | expr.Abs s d f + => let '(_, live) := @compute_live' _ (f PositiveSet.empty) cur_idx in + (cur_idx, live) + | expr.LetIn tx tC ex eC + => let '(idx, live) := @compute_live' tx ex cur_idx in + let '(_, live) := @compute_live' tC (eC (PositiveSet.add idx live)) (Pos.succ idx) in + (Pos.succ idx, live) + | expr.Ident t idc => (cur_idx, PositiveSet.empty) + end. + Definition compute_live {t} e : PositiveSet.t := snd (@compute_live' t e 1). + Definition ComputeLive {t} (e : expr.Expr t) := compute_live (e _). + + Section with_var. + Context {var : type -> Type} + (live : PositiveSet.t). + Definition OUGHT_TO_BE_UNUSED {T1 T2} (v : T1) (v' : T2) := v. + Global Opaque OUGHT_TO_BE_UNUSED. + Fixpoint eliminate_dead' {t} (e : @expr (@expr var) t) (cur_idx : positive) + : positive * @expr var t + := match e with + | expr.Var t v => (cur_idx, v) + | expr.Ident t idc => (cur_idx, expr.Ident idc) + | expr.App s d f x + => let '(idx, f') := @eliminate_dead' _ f cur_idx in + let '(idx, x') := @eliminate_dead' _ x idx in + (idx, expr.App f' x') + | expr.Abs s d f + => (cur_idx, expr.Abs (fun v => snd (@eliminate_dead' _ (f (expr.Var v)) cur_idx))) + | expr.LetIn tx tC ex eC + => let '(idx, ex') := @eliminate_dead' tx ex cur_idx in + let eC' := fun v => snd (@eliminate_dead' _ (eC v) (Pos.succ idx)) in + if PositiveSet.mem idx live + then (Pos.succ idx, expr.LetIn ex' (fun v => eC' (expr.Var v))) + else (Pos.succ idx, eC' (OUGHT_TO_BE_UNUSED ex' (Pos.succ idx, PositiveSet.elements live))) + end. + + Definition eliminate_dead {t} e : expr t + := snd (@eliminate_dead' t e 1). + End with_var. + + Definition EliminateDead {t} (e : expr.Expr t) : expr.Expr t + := fun var => eliminate_dead (ComputeLive e) (e _). + End with_ident. + End DeadCodeElimination. + + Module Subst01. + Local Notation PositiveMap_incr idx m + := (PositiveMap.add idx (match PositiveMap.find idx m with + | Some n => S n + | None => S O + end) m). + Local Notation PositiveMap_union m1 m2 + := (PositiveMap.map2 + (fun c1 c2 + => match c1, c2 with + | Some n1, Some n2 => Some (n1 + n2)%nat + | Some n, None + | None, Some n + => Some n + | None, None => None + end) m1 m2). + Section with_ident. + Context {base_type : Type}. + Local Notation type := (type.type base_type). + Context {ident : type -> Type}. + Local Notation expr := (@expr.expr base_type ident). + Fixpoint compute_live_counts' {t} (e : @expr (fun _ => positive) t) (cur_idx : positive) + : positive * PositiveMap.t nat + := match e with + | expr.Var t v => (cur_idx, PositiveMap_incr v (PositiveMap.empty _)) + | expr.Ident t idc => (cur_idx, PositiveMap.empty _) + | expr.App s d f x + => let '(idx, live1) := @compute_live_counts' _ f cur_idx in + let '(idx, live2) := @compute_live_counts' _ x idx in + (idx, PositiveMap_union live1 live2) + | expr.Abs s d f + => let '(idx, live) := @compute_live_counts' _ (f cur_idx) (Pos.succ cur_idx) in + (cur_idx, live) + | expr.LetIn tx tC ex eC + => let '(idx, live1) := @compute_live_counts' tx ex cur_idx in + let '(idx, live2) := @compute_live_counts' tC (eC idx) (Pos.succ idx) in + (idx, PositiveMap_union live1 live2) + end. + Definition compute_live_counts {t} e : PositiveMap.t _ := snd (@compute_live_counts' t e 1). + Definition ComputeLiveCounts {t} (e : expr.Expr t) := compute_live_counts (e _). + + Section with_var. + Context {var : type -> Type} + (live : PositiveMap.t nat). + Fixpoint subst01' {t} (e : @expr (@expr var) t) (cur_idx : positive) + : positive * @expr var t + := match e with + | expr.Var t v => (cur_idx, v) + | expr.Ident t idc => (cur_idx, expr.Ident idc) + | expr.App s d f x + => let '(idx, f') := @subst01' _ f cur_idx in + let '(idx, x') := @subst01' _ x idx in + (idx, expr.App f' x') + | expr.Abs s d f + => (cur_idx, expr.Abs (fun v => snd (@subst01' _ (f (expr.Var v)) (Pos.succ cur_idx)))) + | expr.LetIn tx tC ex eC + => let '(idx, ex') := @subst01' tx ex cur_idx in + let eC' := fun v => snd (@subst01' tC (eC v) (Pos.succ idx)) in + if match PositiveMap.find idx live with + | Some n => (n <=? 1)%nat + | None => true + end + then (Pos.succ idx, eC' ex') + else (Pos.succ idx, expr.LetIn ex' (fun v => eC' (expr.Var v))) + end. + + Definition subst01 {t} e : expr t + := snd (@subst01' t e 1). + End with_var. + + Definition Subst01 {t} (e : expr.Expr t) : expr.Expr t + := fun var => subst01 (ComputeLiveCounts e) (e _). + End with_ident. + End Subst01. + + Module ReassociateSmallConstants. + Section with_var. + Context (max_const_val : Z) + {var : type -> Type}. + + Local Notation tZ := (base.type.type_base base.type.Z). + Local Notation TZ := (type.base tZ). + Local Notation "x * y" := (expr.App (s:=TZ) (d:=TZ) (expr.App (s:=TZ) (d:=type.arrow TZ TZ) (expr.Ident ident.Z_mul) x) y) : expr_pat_scope. (* for patterns, for type inference *) + + Fixpoint to_mul_list (e : @expr var base.type.Z) : list (@expr var base.type.Z) + := match e in expr.expr t return list (@expr var t) with + | (x * y)%expr_pat => to_mul_list x ++ to_mul_list y + | expr.Var _ _ as e + | expr.Ident _ _ as e + | expr.LetIn _ _ _ _ as e + | expr.Abs _ _ _ as e + | expr.App _ _ _ _ as e + => [e] + end. + + Definition is_small_prim (e : @expr var base.type.Z) : bool + := match e with + | expr.Ident _ (ident.Literal base.type.Z v) + => Z.abs v <=? Z.abs max_const_val + | _ => false + end. + Definition is_not_small_prim (e : @expr var base.type.Z) : bool + := negb (is_small_prim e). + + Definition reorder_mul_list (ls : list (@expr var base.type.Z)) + : list (@expr var base.type.Z) + := filter is_not_small_prim ls ++ filter is_small_prim ls. + + Fixpoint of_mul_list (ls : list (@expr var base.type.Z)) : @expr var base.type.Z + := match ls with + | nil => ##1 + | cons x nil + => x + | cons x xs + => x * of_mul_list xs + end%expr_pat%expr. + + Fixpoint reassociate {t} (e : @expr var t) : @expr var t + := match e in expr.expr t return expr t with + | expr.Var _ _ as e + | expr.Ident _ _ as e + => e + | expr.App s d f x + => let reorder := match d return expr d -> expr d with + | type.base base.type.Z + => fun e => of_mul_list (reorder_mul_list (to_mul_list e)) + | _ => fun e => e + end in + reorder (expr.App (@reassociate _ f) (@reassociate _ x)) + | expr.Abs s d f => expr.Abs (fun v => @reassociate _ (f v)) + | expr.LetIn tx tC ex eC + => expr.LetIn (@reassociate tx ex) (fun v => @reassociate tC (eC v)) + end. + End with_var. + + Definition Reassociate (max_const_val : Z) {t} (e : Expr t) : Expr t + := fun var => reassociate max_const_val (e _). + End ReassociateSmallConstants. +End Compilers. diff --git a/src/Experiments/NewPipeline/README.md b/src/Experiments/NewPipeline/README.md new file mode 100644 index 000000000..27c350ec8 --- /dev/null +++ b/src/Experiments/NewPipeline/README.md @@ -0,0 +1,100 @@ +The ordering of files (eliding `*Proofs.v` files) is: + +``` + Arithmetic.v + ↑ + Language.v ←──────────────────────────────────────────────────┐ + ↗ ↖ │ + ↗ ↖ │ + UnderLets.v GENERATEDIdentifiersWithoutTypes.v MiscCompilerPasses.v + ↑ ↖ ↗ ↑ +AbstractInterpretation.v Rewriter.v │ + ↑ ↑ ┌────────────────────────────────────────────────────┘ +CStringification.v │ │ + ↑ ┌───────────────────┴─┘ +Toplevel1.v ←── Toplevel2.v ←───────────┐ + ↑ │ +CLI.v SlowPrimeSynthesisExamples.v +↑ ↑ +│ └────────────────────────────┐ +StandaloneHaskellMain.v StandaloneOCamlMain.v + ↑ ↑ +ExtractionHaskell.v ExtractionOCaml.v +``` + +The files contain: + +- Arithmetic.v: All of the high-level field arithmetic stuff + +- Language.v: + + PHOAS + + reification + + denotation/intepretation + + utilities for inverting PHOAS exprs + + default/dummy values of PHOAS exprs + + default instantiation of generic PHOAS types + + gallina reification of ground terms + + Flat/indexed syntax trees, and conversions to and from PHOAS + Defines the passes: + + ToFlat + + FromFlat + + GeneralizeVar + +- UnderLets.v: the UnderLets monad, a pass that does substitution of var-like + things, a pass that inserts let-binders in the next-to-last line of code, + substituting away var-like things (this is used to ensure that when we output + C code, aliasing the input and the output arrays doesn't cause issues). + Defines the passes: + + SubstVarFstSndPairOpp + +- AbstractInterpretation.v: type-code-based ZRange definitions, abstract + interpretation of identifiers (which does let-lifting, for historical reasons, + and the dependency on UnderLets should probably be removed), defines the + passes: + + PartialEvaluateWithBounds + + PartialEvaluateWithListInfoFromBounds + + CheckPartialEvaluateWithBounds + +- GENERATEDIdentifiersWithoutTypes.v: generated by a python script which is + included in a comment in the file, this is an untyped version of identifiers + for the rewriter + +- Rewriter.v: rewrite rules, rewriting. Defines the passes: + + Rewrite + + RewriteToFancy + + PartialEvaluate (which is just a synonym for Rewrite) + +- MiscCompilerPasses.v: Defines the passes: + + EliminateDead (dead code elimination) + + Subst01 (substitute let-binders used 0 or 1 times) + + ReassociateSmallConstants.Reassociate: + * (turn expressions of the form ((x * y) * ##v) into (x * (y * ##v)) for + small values of v) + +- CStringification.v: conversion to C code as strings. (Depends on + AbstractInterpretation.v for ZRange utilities.) Defines the passes: + + ToString.ToFunctionLines + + ToString.ToFunctionString + + ToString.LinesToString + +- CompilersTestCases.v: Various test cases to ensure everything is working + +- Toplevel1.v: Ring Goal (which SHOULD NOT depend on compilers) + pipeline + a couple of examples + pipeline + most of the stuff that uses compilers + arithmetic. This is the file that CLI.v depends on. + +- Toplevel2.v: Some not-quite-finished-but-kind-of-slow pipeline stuff + + all the stuff that uses compilers + arithmetic, together with more + examples. Also has semi-broken fancy-machine stuff. This should + probably be merged into Toplevel1.v when working on the pipeline. + +- SlowPrimeSynthesisExamples.v: Additional uses of the pipeline for + primes that are kind-of slow, which I don't want extraction blocking + on. + +- CLI.v: Setting up all of the language-independent parts of extraction; relies + on having a list of strings-or-error-messages for each pipeline, and on the + arguments to that pipeline, and builds a parser for command line arguments for + that. + +- StandaloneHaskellMain.v, StandaloneOCamlMain.v, ExtractionHaskell.v, + ExtractionOCaml.v: Extraction of pipeline to various languages diff --git a/src/Experiments/NewPipeline/Rewriter.v b/src/Experiments/NewPipeline/Rewriter.v new file mode 100644 index 000000000..a055c4735 --- /dev/null +++ b/src/Experiments/NewPipeline/Rewriter.v @@ -0,0 +1,1780 @@ +Require Import Coq.ZArith.ZArith. +Require Import Crypto.Util.ListUtil Coq.Lists.List Crypto.Util.ListUtil.FoldBool. +Require Import Crypto.Util.ZRange. +Require Import Crypto.Util.ZRange.Operations. +Require Import Crypto.Util.Option. +Require Import Crypto.Util.OptionList. +Require Import Crypto.Util.ZUtil.Tactics.LtbToLt. +Require Import Crypto.Util.CPSNotations. +Require Crypto.Util.PrimitiveProd. +Require Crypto.Util.PrimitiveHList. +Require Import Crypto.Experiments.NewPipeline.Language. +Require Import Crypto.Experiments.NewPipeline.UnderLets. +Require Import Crypto.Experiments.NewPipeline.GENERATEDIdentifiersWithoutTypes. +Require Import Crypto.Util.Notations. +Import ListNotations. Local Open Scope bool_scope. Local Open Scope Z_scope. + +Module Compilers. + Export Language.Compilers. + Export UnderLets.Compilers. + Export GENERATEDIdentifiersWithoutTypes.Compilers. + Import invert_expr. + + Module pattern. + Export GENERATEDIdentifiersWithoutTypes.Compilers.pattern. + + Module base. + Local Notation einterp := type.interp. + Module type. + Inductive type := any | type_base (t : Compilers.base.type.base) | prod (A B : type) | list (A : type). + End type. + Notation type := type.type. + + Module Notations. + Global Coercion type.type_base : Compilers.base.type.base >-> type.type. + Bind Scope pbtype_scope with type.type. + (*Bind Scope ptype_scope with Compilers.type.type type.type.*) (* COQBUG(https://github.com/coq/coq/issues/7699) *) + Delimit Scope ptype_scope with ptype. + Delimit Scope pbtype_scope with pbtype. + Notation "A * B" := (type.prod A%ptype B%ptype) : ptype_scope. + Notation "A * B" := (type.prod A%pbtype B%pbtype) : pbtype_scope. + Notation "()" := (type.type_base base.type.unit) : pbtype_scope. + Notation "()" := (type.base (type.type_base base.type.unit)) : ptype_scope. + Notation "A -> B" := (type.arrow A%ptype B%ptype) : ptype_scope. + Notation "??" := type.any : pbtype_scope. + Notation "??" := (type.base type.any) : ptype_scope. + End Notations. + End base. + Notation type := (type.type base.type). + Export base.Notations. + + Inductive pattern {ident : Type} := + | Wildcard (t : type) + | Ident (idc : ident) + | App (f x : pattern). + + Global Arguments Wildcard {ident%type} t%ptype. + + Notation ident := ident.ident. + + Module Export Notations. + Export base.Notations. + Delimit Scope pattern_scope with pattern. + Bind Scope pattern_scope with pattern. + Local Open Scope pattern_scope. + Notation "#?()" := (Ident ident.LiteralUnit) : pattern_scope. + Notation "#?N" := (Ident ident.LiteralNat) : pattern_scope. + Notation "#?ℕ" := (Ident ident.LiteralNat) : pattern_scope. + Notation "#?Z" := (Ident ident.LiteralZ) : pattern_scope. + Notation "#?ℤ" := (Ident ident.LiteralZ) : pattern_scope. + Notation "#?B" := (Ident ident.LiteralBool) : pattern_scope. + Notation "#?𝔹" := (Ident ident.LiteralBool) : pattern_scope. + Notation "??{ t }" := (Wildcard t) (format "??{ t }") : pattern_scope. + Notation "??" := (??{??})%pattern : pattern_scope. + Notation "# idc" := (Ident idc) : pattern_scope. + Infix "@" := App : pattern_scope. + Notation "( x , y , .. , z )" := (#ident.pair @ .. (#ident.pair @ x @ y) .. @ z) : pattern_scope. + Notation "x :: xs" := (#ident.cons @ x @ xs) : pattern_scope. + Notation "xs ++ ys" := (#ident.List_app @ xs @ ys) : pattern_scope. + Notation "[ ]" := (#ident.nil) : pattern_scope. + Notation "[ x ]" := (x :: []) : pattern_scope. + Notation "[ x ; y ; .. ; z ]" := (x :: (y :: .. (z :: []) ..)) : pattern_scope. + Notation "x - y" := (#ident.Z_sub @ x @ y) : pattern_scope. + Notation "x + y" := (#ident.Z_add @ x @ y) : pattern_scope. + Notation "x / y" := (#ident.Z_div @ x @ y) : pattern_scope. + Notation "x * y" := (#ident.Z_mul @ x @ y) : pattern_scope. + Notation "x 'mod' y" := (#ident.Z_modulo @ x @ y)%pattern : pattern_scope. + Notation "- x" := (#ident.Z_opp @ x) : pattern_scope. + End Notations. + End pattern. + Export pattern.Notations. + Notation pattern := (@pattern.pattern pattern.ident). + + Module RewriteRules. + Module Import AnyExpr. + Record anyexpr {base_type} {ident var : type.type base_type -> Type} + := wrap { anyexpr_ty : base_type ; unwrap :> @expr.expr base_type ident var (type.base anyexpr_ty) }. + Global Arguments wrap {base_type ident var _} _. + End AnyExpr. + + Module Compile. + Section with_var0. + Context {base_type} {ident var : type.type base_type -> Type}. + Local Notation type := (type.type base_type). + Local Notation expr := (@expr.expr base_type ident var). + Local Notation UnderLets := (@UnderLets.UnderLets base_type ident var). + Let type_base (t : base_type) : type := type.base t. + Coercion type_base : base_type >-> type. + + Fixpoint value' (with_lets : bool) (t : type) + := match t with + | type.base t + => if with_lets then UnderLets (expr t) else expr t + | type.arrow s d + => value' false s -> value' true d + end. + Definition value := value' false. + Definition value_with_lets := value' true. + + Definition Base_value {t} : value t -> value_with_lets t + := match t with + | type.base t => fun v => UnderLets.Base v + | type.arrow _ _ => fun v => v + end. + + Fixpoint splice_under_lets_with_value {T t} (x : UnderLets T) : (T -> value_with_lets t) -> value_with_lets t + := match t return (T -> value_with_lets t) -> value_with_lets t with + | type.arrow s d + => fun k v => @splice_under_lets_with_value T d x (fun x' => k x' v) + | type.base _ => fun k => x <-- x; k x + end%under_lets. + Local Notation "x <--- v ; f" := (splice_under_lets_with_value x (fun v => f%under_lets)) : under_lets_scope. + Definition splice_value_with_lets {t t'} : value_with_lets t -> (value t -> value_with_lets t') -> value_with_lets t' + := match t return value_with_lets t -> (value t -> value_with_lets t') -> value_with_lets t' with + | type.arrow _ _ + => fun e k => k e + | type.base _ => fun e k => e <--- e; k e + end%under_lets. + End with_var0. + Section with_var. + Context {ident var : type.type base.type -> Type} + {pident : Type} + (*(invert_Literal_cps : forall t, ident t ~> option (type.interp base.interp t))*) + (*(beq_typed : forall t (X : pident) (Y : ident t), bool)*) + (full_types : pident -> Type) + (invert_bind_args : forall t (idc : ident t) (pidc : pident), option (full_types pidc)) + (type_of_pident : forall (pidc : pident), full_types pidc -> type.type base.type) + (pident_to_typed : forall (pidc : pident) (args : full_types pidc), ident (type_of_pident pidc args)) + (eta_ident_cps : forall {T : type.type base.type -> Type} {t} (idc : ident t) + (f : forall t', ident t' -> T t'), + T t) + (of_typed_ident : forall {t}, ident t -> pident) + (arg_types : pident -> option Type) + (bind_args : forall {t} (idc : ident t), match arg_types (of_typed_ident idc) return Type with Some t => t | None => unit end) + (pident_beq : pident -> pident -> bool) + (try_make_transport_ident_cps : forall (P : pident -> Type) (idc1 idc2 : pident), ~> option (P idc1 -> P idc2)). + Local Notation type := (type.type base.type). + Local Notation expr := (@expr.expr base.type ident var). + Local Notation anyexpr := (@anyexpr ident var). + Local Notation pattern := (@pattern.pattern pident). + Local Notation UnderLets := (@UnderLets.UnderLets base.type ident var). + Local Notation ptype := (type.type pattern.base.type). + Local Notation value' := (@value' base.type ident var). + Local Notation value := (@value base.type ident var). + Local Notation value_with_lets := (@value_with_lets base.type ident var). + Local Notation Base_value := (@Base_value base.type ident var). + Local Notation splice_under_lets_with_value := (@splice_under_lets_with_value base.type ident var). + Local Notation splice_value_with_lets := (@splice_value_with_lets base.type ident var). + Let type_base (t : base.type) : type := type.base t. + Coercion type_base : base.type >-> type. + + Context (reify_and_let_binds_base_cps : forall (t : base.type), expr t -> forall T, (expr t -> UnderLets T) -> UnderLets T). + + Local Notation "e <---- e' ; f" := (splice_value_with_lets e' (fun e => f%under_lets)) : under_lets_scope. + Local Notation "e <----- e' ; f" := (splice_under_lets_with_value e' (fun e => f%under_lets)) : under_lets_scope. + + Fixpoint reify {with_lets} {t} : value' with_lets t -> expr t + := match t, with_lets return value' with_lets t -> expr t with + | type.base _, false => fun v => v + | type.base _, true => fun v => UnderLets.to_expr v + | type.arrow s d, _ + => fun f + => λ x , @reify _ d (f (@reflect _ s ($x))) + end%expr%under_lets%cps + with reflect {with_lets} {t} : expr t -> value' with_lets t + := match t, with_lets return expr t -> value' with_lets t with + | type.base _, false => fun v => v + | type.base _, true => fun v => UnderLets.Base v + | type.arrow s d, _ + => fun f (x : value' _ _) => @reflect _ d (f @ (@reify _ s x)) + end%expr%under_lets. + + Definition reify_and_let_binds_cps {with_lets} {t} : value' with_lets t -> forall T, (expr t -> UnderLets T) -> UnderLets T + := match t, with_lets return value' with_lets t -> forall T, (expr t -> UnderLets T) -> UnderLets T with + | type.base _, false => reify_and_let_binds_base_cps _ + | type.base _, true => fun v => fun T k => v' <-- v; reify_and_let_binds_base_cps _ v' T k + | type.arrow s d, _ + => fun f T k => k (reify f) + end%expr%under_lets%cps. + + Inductive rawexpr : Type := + | rIdent {t} (idc : ident t) {t'} (alt : expr t') + | rApp (f x : rawexpr) {t} (alt : expr t) + | rExpr {t} (e : expr t) + | rValue {t} (e : value t). + + Definition type_of_rawexpr (e : rawexpr) : type + := match e with + | rIdent t idc t' alt => t' + | rApp f x t alt => t + | rExpr t e => t + | rValue t e => t + end. + Definition expr_of_rawexpr (e : rawexpr) : expr (type_of_rawexpr e) + := match e with + | rIdent t idc t' alt => alt + | rApp f x t alt => alt + | rExpr t e => e + | rValue t e => reify e + end. + Definition value_of_rawexpr (e : rawexpr) : value (type_of_rawexpr e) + := Eval cbv [expr_of_rawexpr] in + match e with + | rValue t e => e + | e => reflect (expr_of_rawexpr e) + end. + Definition rValueOrExpr {t} : value t -> rawexpr + := match t with + | type.base _ => @rExpr _ + | type.arrow _ _ => @rValue _ + end. + Definition rValueOrExpr2 {t} : value t -> expr t -> rawexpr + := match t with + | type.base _ => fun v e => @rExpr _ e + | type.arrow _ _ => fun v e => @rValue _ v + end. + + Definition try_rExpr_cps {T t} (k : option rawexpr -> T) : expr t -> T + := match t with + | type.base _ => fun e => k (Some (rExpr e)) + | type.arrow _ _ => fun _ => k None + end. + + Definition reveal_rawexpr_cps (e : rawexpr) : ~> rawexpr + := fun T k + => match e with + | rExpr _ e as r + | rValue (type.base _) e as r + => match e with + | expr.Ident t idc => k (rIdent idc e) + | expr.App s d f x => k (rApp (rExpr f) (rExpr x) e) + | _ => k r + end + | e' => k e' + end. + + Inductive quant_type := qforall | qexists. + + (* p for pattern *) + Fixpoint pbase_type_interp_cps (quant : quant_type) (t : pattern.base.type) (K : base.type -> Type) : Type + := match t with + | pattern.base.type.any + => match quant with + | qforall => forall t : base.type, K t + | qexists => { t : base.type & K t } + end + | pattern.base.type.type_base t => K t + | pattern.base.type.prod A B + => @pbase_type_interp_cps + quant A + (fun A' + => @pbase_type_interp_cps + quant B (fun B' => K (A' * B')%etype)) + | pattern.base.type.list A + => @pbase_type_interp_cps + quant A (fun A' => K (base.type.list A')) + end. + + Fixpoint ptype_interp_cps (quant : quant_type) (t : ptype) (K : type -> Type) {struct t} : Type + := match t with + | type.base t + => pbase_type_interp_cps quant t (fun t => K (type.base t)) + | type.arrow s d + => @ptype_interp_cps + quant s + (fun s => @ptype_interp_cps + quant d (fun d => K (type.arrow s d))) + end. + + Definition ptype_interp (quant : quant_type) (t : ptype) (K : Type -> Type) : Type + := ptype_interp_cps quant t (fun t => K (value t)). + + Fixpoint binding_dataT (p : pattern) : Type + := match p return Type with + | pattern.Wildcard t => ptype_interp qexists t id + | pattern.Ident idc => match arg_types idc return Type with + | Some t => t + | None => unit + end + | pattern.App f x => binding_dataT f * binding_dataT x + end%type. + + Fixpoint bind_base_cps {t1 t2} + (K : base.type -> Type) + (v : K t2) + {struct t1} + : ~> option (pbase_type_interp_cps qexists t1 K) + := match t1 return ~> option (pbase_type_interp_cps qexists t1 K) with + | pattern.base.type.any + => (return (Some (existT K t2 v))) + | pattern.base.type.type_base t + => (tr <-- base.try_make_transport_cps _ _ _; + return (Some (tr v))) + | pattern.base.type.prod A B + => fun T k + => match t2 return K t2 -> T with + | base.type.prod A' B' + => fun v + => (v' <-- @bind_base_cps B B' (fun B' => K (A' * B')%etype) v; + v'' <-- @bind_base_cps A A' (fun A' => pbase_type_interp_cps qexists B (fun B' => K (A' * B')%etype)) v'; + return (Some v'')) + T k + | _ => fun _ => k None + end v + | pattern.base.type.list A + => fun T k + => match t2 return K t2 -> T with + | base.type.list A' + => fun v => @bind_base_cps A A' (fun A' => K (base.type.list A')) v T k + | _ => fun _ => k None + end v + end%cps. + + Fixpoint bind_value_cps {t1 t2} + (K : type -> Type) + (v : K t2) + {struct t1} + : ~> option (ptype_interp_cps qexists t1 K) + := match t1 return ~> option (ptype_interp_cps qexists t1 K) with + | type.base t1 + => fun T k + => match t2 return K t2 -> T with + | type.base t2 + => fun v => bind_base_cps (fun t => K (type.base t)) v T k + | _ => fun _ => k None + end v + | type.arrow A B + => fun T k + => match t2 return K t2 -> T with + | type.arrow A' B' + => fun v + => (v' <-- @bind_value_cps B B' (fun B' => K (A' -> B')%etype) v; + v'' <-- @bind_value_cps A A' (fun A' => ptype_interp_cps qexists B (fun B' => K (A' -> B')%etype)) v'; + return (Some v'')) + T k + | _ => fun _ => k None + end v + end%cps. + + Fixpoint bind_data_cps (e : rawexpr) (p : pattern) + : ~> option (binding_dataT p) + := match p, e return ~> option (binding_dataT p) with + | pattern.Wildcard t, _ + => bind_value_cps value (value_of_rawexpr e) + | pattern.Ident pidc, rIdent _ idc _ _ + => (tr <-- (try_make_transport_ident_cps + (fun idc => match arg_types idc with + | Some t1 => t1 + | None => unit + end) _ _); + return (Some (tr (bind_args _ idc)))) + | pattern.App pf px, rApp f x _ _ + => (f' <-- bind_data_cps f pf; + x' <-- bind_data_cps x px; + return (Some (f', x'))) + | pattern.Ident _, _ + | pattern.App _ _, _ + => (return None) + end%cps. + + (** We follow + http://moscova.inria.fr/~maranget/papers/ml05e-maranget.pdf, + "Compiling Pattern Matching to Good Decision Trees" by Luc + Maranget. A [decision_tree] describes how to match a + vector (or list) of patterns against a vector of + expressions. The cases of a [decision_tree] are: + + - [TryLeaf k onfailure]: Try the kth rewrite rule; if it + fails, keep going with [onfailure] + + - [Failure]: Abort; nothing left to try + + - [Switch icases app_case default]: With the first element + of the vector, match on its kind; if it is an identifier + matching something in [icases], remove the first element + of the vector run that decision tree; if it is an + application and [app_case] is not [None], try the + [app_case] decision_tree, replacing the first element of + each vector with the two elements of the function and + the argument its applied to; otherwise, don't modify the + vectors, and use the [default] decision tree. + + - [Swap i cont]: Swap the first element of the vector with + the ith element, and keep going with [cont] *) + Inductive decision_tree := + | TryLeaf (k : nat) (onfailure : decision_tree) + | Failure + | Switch (icases : list (pident * decision_tree)) + (app_case : option decision_tree) + (default : decision_tree) + | Swap (i : nat) (cont : decision_tree). + + Definition swap_list {A} (i j : nat) (ls : list A) : option (list A) + := match nth_error ls i, nth_error ls j with + | Some vi, Some vj => Some (set_nth i vj (set_nth j vi ls)) + | _, _ => None + end. + + Fixpoint eval_decision_tree {T} (ctx : list rawexpr) (d : decision_tree) (cont : option nat -> list rawexpr -> option (unit -> T) -> T) {struct d} : T + := match d with + | TryLeaf k onfailure + => cont (Some k) ctx + (Some (fun 'tt => @eval_decision_tree T ctx onfailure cont)) + | Failure => cont None ctx None + | Switch icases app_case default_case + => match ctx with + | nil => cont None ctx None + | ctx0 :: ctx' + => let default _ := @eval_decision_tree T ctx default_case cont in + reveal_rawexpr_cps + ctx0 _ + (fun ctx0' + => match ctx0' with + | rIdent t idc t' alt + => fold_right + (fun '(pidc, icase) default 'tt + => match invert_bind_args _ idc pidc with + | Some args + => @eval_decision_tree + T ctx' icase + (fun k ctx'' + => cont k (rIdent (pident_to_typed pidc args) alt :: ctx'')) + | None => default tt + end) + default + icases + tt + | rApp f x t alt + => match app_case with + | Some app_case + => @eval_decision_tree + T (f :: x :: ctx') app_case + (fun k ctx'' + => match ctx'' with + | f' :: x' :: ctx''' + => cont k (rApp f' x' alt :: ctx''') + | _ => cont None ctx + end) + | None => default tt + end + | rExpr t e + | rValue t e + => default tt + end) + end + | Swap i d' + => match swap_list 0 i ctx with + | Some ctx' + => @eval_decision_tree + T ctx' d' + (fun k ctx'' + => match swap_list 0 i ctx'' with + | Some ctx''' => cont k ctx''' + | None => cont None ctx + end) + | None => cont None ctx None + end + end. + + Local Notation opt_anyexprP ivar + := (fun should_do_again : bool => UnderLets (@AnyExpr.anyexpr base.type ident (if should_do_again then ivar else var))) + (only parsing). + Local Notation opt_anyexpr ivar + := (option (sigT (opt_anyexprP ivar))) (only parsing). + + Definition rewrite_ruleTP + := (fun p : pattern => binding_dataT p -> forall T, (opt_anyexpr value -> T) -> T). + Definition rewrite_ruleT := sigT rewrite_ruleTP. + Definition rewrite_rulesT + := (list rewrite_ruleT). + + Definition eval_rewrite_rules + (do_again : forall t : base.type, @expr.expr base.type ident value t -> UnderLets (expr t)) + (maybe_do_again + := fun (should_do_again : bool) (t : base.type) + => if should_do_again return ((@expr.expr base.type ident (if should_do_again then value else var) t) -> UnderLets (expr t)) + then do_again t + else UnderLets.Base) + (d : decision_tree) + (rew : rewrite_rulesT) + (e : rawexpr) + : UnderLets (expr (type_of_rawexpr e)) + := eval_decision_tree + (e::nil) d + (fun k ctx default_on_rewrite_failure + => match k, ctx return UnderLets (expr (type_of_rawexpr e)) with + | Some k', e'::nil + => match nth_error rew k' return UnderLets (expr (type_of_rawexpr e)) with + | Some (existT p f) + => bind_data_cps + e' p _ + (fun v + => match v with + | Some v + => f v _ + (fun fv + => match fv return UnderLets (expr (type_of_rawexpr e)) with + | Some (existT should_do_again fv) + => (fv <-- fv; + fv <-- maybe_do_again should_do_again _ fv; + type.try_transport_cps + base.try_make_transport_cps _ _ _ fv _ + (fun fv' + => match fv', default_on_rewrite_failure with + | Some fv'', _ => UnderLets.Base fv'' + | None, Some default => default tt + | None, None => UnderLets.Base (expr_of_rawexpr e) + end))%under_lets + | None => match default_on_rewrite_failure with + | Some default => default tt + | None => UnderLets.Base (expr_of_rawexpr e) + end + end) + | None => UnderLets.Base (expr_of_rawexpr e) + end) + | None => UnderLets.Base (expr_of_rawexpr e) + end + | _, _ => UnderLets.Base (expr_of_rawexpr e) + end). + + Local Notation enumerate ls + := (List.combine (List.seq 0 (List.length ls)) ls). + + Fixpoint first_satisfying_helper {A B} (f : A -> option B) (ls : list A) : option B + := match ls with + | nil => None + | cons x xs + => match f x with + | Some v => Some v + | None => first_satisfying_helper f xs + end + end. + + Definition get_index_of_first_non_wildcard (p : list pattern) : option nat + := first_satisfying_helper + (fun '(n, x) => match x with + | pattern.Wildcard _ => None + | _ => Some n + end) + (enumerate p). + + Definition filter_pattern_wildcard (p : list (nat * list pattern)) : list (nat * list pattern) + := filter (fun '(_, p) => match p with + | pattern.Wildcard _::_ => true + | _ => false + end) + p. + + Fixpoint get_unique_pattern_ident' (p : list (nat * list pattern)) (so_far : list pident) : list pident + := match p with + | nil => List.rev so_far + | (_, pattern.Ident pidc :: _) :: ps + => let so_far' := if existsb (pident_beq pidc) so_far + then so_far + else pidc :: so_far in + get_unique_pattern_ident' ps so_far' + | _ :: ps => get_unique_pattern_ident' ps so_far + end. + + Definition get_unique_pattern_ident p : list pident := get_unique_pattern_ident' p nil. + + Definition contains_pattern_pident (pidc : pident) (p : list (nat * list pattern)) : bool + := existsb (fun '(n, p) => match p with + | pattern.Ident pidc'::_ => pident_beq pidc pidc' + | _ => false + end) + p. + + Definition contains_pattern_app (p : list (nat * list pattern)) : bool + := existsb (fun '(n, p) => match p with + | pattern.App _ _::_ => true + | _ => false + end) + p. + + Definition refine_pattern_app (p : nat * list pattern) : option (nat * list pattern) + := match p with + | (n, pattern.Wildcard d::ps) + => Some (n, (??{?? -> d} :: ?? :: ps)%list%pattern) + | (n, pattern.App f x :: ps) + => Some (n, f :: x :: ps) + | (_, pattern.Ident _::_) + | (_, nil) + => None + end. + + Definition refine_pattern_pident (pidc : pident) (p : nat * list pattern) : option (nat * list pattern) + := match p with + | (n, pattern.Wildcard _::ps) + => Some (n, ps) + | (n, pattern.Ident pidc'::ps) + => if pident_beq pidc pidc' + then Some (n, ps) + else None + | (_, pattern.App _ _::_) + | (_, nil) + => None + end. + + Definition compile_rewrites_step + (compile_rewrites : list (nat * list pattern) -> option decision_tree) + (pattern_matrix : list (nat * list pattern)) + : option decision_tree + := match pattern_matrix with + | nil => Some Failure + | (n1, p1) :: ps + => match get_index_of_first_non_wildcard p1 with + | None (* p1 is all wildcards *) + => (onfailure <- compile_rewrites ps; + Some (TryLeaf n1 onfailure)) + | Some Datatypes.O + => default_case <- compile_rewrites (filter_pattern_wildcard pattern_matrix); + app_case <- (if contains_pattern_app pattern_matrix + then option_map Some (compile_rewrites (Option.List.map refine_pattern_app pattern_matrix)) + else Some None); + let pidcs := get_unique_pattern_ident pattern_matrix in + let icases := Option.List.map + (fun pidc => option_map (pair pidc) (compile_rewrites (Option.List.map (refine_pattern_pident pidc) pattern_matrix))) + pidcs in + Some (Switch icases app_case default_case) + | Some i + => let pattern_matrix' + := List.map + (fun '(n, ps) + => (n, + match swap_list 0 i ps with + | Some ps' => ps' + | None => nil (* should be impossible *) + end)) + pattern_matrix in + d <- compile_rewrites pattern_matrix'; + Some (Swap i d) + end + end%option. + + Fixpoint compile_rewrites' (fuel : nat) (pattern_matrix : list (nat * list pattern)) + : option decision_tree + := match fuel with + | Datatypes.O => None + | Datatypes.S fuel' => compile_rewrites_step (@compile_rewrites' fuel') pattern_matrix + end. + + Definition compile_rewrites (fuel : nat) (ps : rewrite_rulesT) + := compile_rewrites' fuel (enumerate (List.map (fun p => projT1 p :: nil) ps)). + + + Fixpoint with_bindingsT (p : pattern) (T : Type) + := match p return Type with + | pattern.Wildcard t => ptype_interp qforall t (fun eT => eT -> T) + | pattern.Ident idc + => match arg_types idc with + | Some t => t -> T + | None => T + end + | pattern.App f x => with_bindingsT f (with_bindingsT x T) + end. + + Fixpoint lift_pbase_type_interp_cps {K1 K2} {quant} (F : forall t : base.type, K1 t -> K2 t) {t} + : pbase_type_interp_cps quant t K1 + -> pbase_type_interp_cps quant t K2 + := match t, quant return pbase_type_interp_cps quant t K1 + -> pbase_type_interp_cps quant t K2 with + | pattern.base.type.any, qforall + => fun f t => F t (f t) + | pattern.base.type.any, qexists + => fun tf => existT _ _ (F _ (projT2 tf)) + | pattern.base.type.type_base t, _ + => F _ + | pattern.base.type.prod A B, _ + => @lift_pbase_type_interp_cps + _ _ quant + (fun A' + => @lift_pbase_type_interp_cps + _ _ quant (fun _ => F _) B) + A + | pattern.base.type.list A, _ + => @lift_pbase_type_interp_cps + _ _ quant (fun _ => F _) A + end. + + Fixpoint lift_ptype_interp_cps {K1 K2} {quant} (F : forall t : type.type base.type, K1 t -> K2 t) {t} + : ptype_interp_cps quant t K1 + -> ptype_interp_cps quant t K2 + := match t return ptype_interp_cps quant t K1 + -> ptype_interp_cps quant t K2 with + | type.base t + => lift_pbase_type_interp_cps F + | type.arrow A B + => @lift_ptype_interp_cps + _ _ quant + (fun A' + => @lift_ptype_interp_cps + _ _ quant (fun _ => F _) B) + A + end. + + Fixpoint lift_with_bindings {p} {A B : Type} (F : A -> B) {struct p} : with_bindingsT p A -> with_bindingsT p B + := match p return with_bindingsT p A -> with_bindingsT p B with + | pattern.Wildcard t + => lift_ptype_interp_cps + (K1:=fun t => value t -> A) + (K2:=fun t => value t -> B) + (fun _ f v => F (f v)) + | pattern.Ident idc + => match arg_types idc as ty + return match ty with + | Some t => t -> A + | None => A + end -> match ty with + | Some t => t -> B + | None => B + end + with + | Some _ => fun f v => F (f v) + | None => F + end + | pattern.App f x + => @lift_with_bindings + f _ _ + (@lift_with_bindings x _ _ F) + end. + + Fixpoint app_pbase_type_interp_cps {T : Type} {K1 K2 : base.type -> Type} + (F : forall t, K1 t -> K2 t -> T) + {t} + : pbase_type_interp_cps qforall t K1 + -> pbase_type_interp_cps qexists t K2 -> T + := match t return pbase_type_interp_cps qforall t K1 + -> pbase_type_interp_cps qexists t K2 -> T with + | pattern.base.type.any + => fun f tv => F _ (f _) (projT2 tv) + | pattern.base.type.type_base t + => fun f v => F _ f v + | pattern.base.type.prod A B + => @app_pbase_type_interp_cps + _ + (fun A' => pbase_type_interp_cps qforall B (fun B' => K1 (A' * B')%etype)) + (fun A' => pbase_type_interp_cps qexists B (fun B' => K2 (A' * B')%etype)) + (fun A' + => @app_pbase_type_interp_cps + _ + (fun B' => K1 (A' * B')%etype) + (fun B' => K2 (A' * B')%etype) + (fun _ => F _) + B) + A + | pattern.base.type.list A + => @app_pbase_type_interp_cps T (fun A' => K1 (base.type.list A')) (fun A' => K2 (base.type.list A')) (fun _ => F _) A + end. + + Fixpoint app_ptype_interp_cps {T : Type} {K1 K2 : type -> Type} + (F : forall t, K1 t -> K2 t -> T) + {t} + : ptype_interp_cps qforall t K1 + -> ptype_interp_cps qexists t K2 -> T + := match t return ptype_interp_cps qforall t K1 + -> ptype_interp_cps qexists t K2 -> T with + | type.base t => app_pbase_type_interp_cps F + | type.arrow A B + => @app_ptype_interp_cps + _ + (fun A' => ptype_interp_cps qforall B (fun B' => K1 (A' -> B')%etype)) + (fun A' => ptype_interp_cps qexists B (fun B' => K2 (A' -> B')%etype)) + (fun A' + => @app_ptype_interp_cps + _ + (fun B' => K1 (A' -> B')%etype) + (fun B' => K2 (A' -> B')%etype) + (fun _ => F _) + B) + A + end. + + Fixpoint app_binding_data {T p} : forall (f : with_bindingsT p T) (v : binding_dataT p), T + := match p return forall (f : with_bindingsT p T) (v : binding_dataT p), T with + | pattern.Wildcard t + => app_ptype_interp_cps + (K1:=fun t => value t -> T) + (K2:=fun t => value t) + (fun _ f v => f v) + | pattern.Ident idc + => match arg_types idc as ty + return match ty with + | Some t => t -> T + | None => T + end -> match ty return Type with + | Some t => t + | None => unit + end -> T + with + | Some t => fun f x => f x + | None => fun v 'tt => v + end + | pattern.App f x + => fun F '(vf, vx) + => @app_binding_data _ x (@app_binding_data _ f F vf) vx + end. + + (** XXX MOVEME? *) + Definition mkcast {P : type -> Type} {t1 t2 : type} : ~> (option (P t1 -> P t2)) + := fun T k => type.try_make_transport_cps base.try_make_transport_cps P t1 t2 _ k. + Definition cast {P : type -> Type} {t1 t2 : type} (v : P t1) : ~> (option (P t2)) + := fun T k => type.try_transport_cps base.try_make_transport_cps P t1 t2 v _ k. + Definition castb {P : base.type -> Type} {t1 t2 : base.type} (v : P t1) : ~> (option (P t2)) + := fun T k => base.try_transport_cps P t1 t2 v _ k. + Definition castbe {t1 t2 : base.type} (v : expr t1) : ~> (option (expr t2)) + := @castb expr t1 t2 v. + Definition castv {t1 t2} (v : value t1) : ~> (option (value t2)) + := fun T k => type.try_transport_cps base.try_make_transport_cps value t1 t2 v _ k. + + Section with_do_again. + Context (dtree : decision_tree) + (rewrite_rules : rewrite_rulesT) + (default_fuel : nat) + (do_again : forall t : base.type, @expr.expr base.type ident value t -> UnderLets (expr t)). + + Let dorewrite1 (e : rawexpr) : UnderLets (expr (type_of_rawexpr e)) + := eval_rewrite_rules do_again dtree rewrite_rules e. + + Fixpoint assemble_identifier_rewriters' (t : type) : forall e : rawexpr, (forall P, P (type_of_rawexpr e) -> P t) -> value_with_lets t + := match t return forall e : rawexpr, (forall P, P (type_of_rawexpr e) -> P t) -> value_with_lets t with + | type.base _ + => fun e k => k (fun t => UnderLets (expr t)) (dorewrite1 e) + | type.arrow s d + => fun f k (x : value' _ _) + => let x' := reify x in + @assemble_identifier_rewriters' d (rApp f (rValueOrExpr2 x x') (k _ (expr_of_rawexpr f) @ x'))%expr (fun _ => id) + end%under_lets. + + Definition assemble_identifier_rewriters {t} (idc : ident t) : value_with_lets t + := eta_ident_cps _ _ idc (fun t' idc' => assemble_identifier_rewriters' t' (rIdent idc' #idc') (fun _ => id)). + End with_do_again. + End with_var. + + Section full. + Context {var : type.type base.type -> Type}. + Local Notation expr := (@expr base.type ident). + Local Notation value := (@Compile.value base.type ident var). + Local Notation value_with_lets := (@Compile.value_with_lets base.type ident var). + Local Notation UnderLets := (UnderLets.UnderLets base.type ident var). + Local Notation reify_and_let_binds_cps := (@Compile.reify_and_let_binds_cps ident var (@UnderLets.reify_and_let_binds_base_cps var)). + Local Notation reflect := (@Compile.reflect ident var). + Section with_rewrite_head. + Context (rewrite_head : forall t (idc : ident t), value_with_lets t). + + Local Notation "e <---- e' ; f" := (Compile.splice_value_with_lets e' (fun e => f%under_lets)) : under_lets_scope. + Local Notation "e <----- e' ; f" := (Compile.splice_under_lets_with_value e' (fun e => f%under_lets)) : under_lets_scope. + + Fixpoint rewrite_bottomup {t} (e : @expr value t) : value_with_lets t + := match e in expr.expr t return value_with_lets t with + | expr.Ident t idc + => rewrite_head _ idc + | expr.App s d f x => let f : value s -> value_with_lets d := @rewrite_bottomup _ f in x <---- @rewrite_bottomup _ x; f x + | expr.LetIn A B x f => x <---- @rewrite_bottomup A x; + xv <----- reify_and_let_binds_cps x _ UnderLets.Base; + @rewrite_bottomup B (f (reflect xv)) + | expr.Var t v => Compile.Base_value v + | expr.Abs s d f => fun x : value s => @rewrite_bottomup d (f x) + end%under_lets. + End with_rewrite_head. + + Notation nbe := (@rewrite_bottomup (fun t idc => reflect (expr.Ident idc))). + + Fixpoint repeat_rewrite + (rewrite_head : forall (do_again : forall t : base.type, @expr value (type.base t) -> UnderLets (@expr var (type.base t))) + t (idc : ident t), value_with_lets t) + (fuel : nat) {t} e : value_with_lets t + := @rewrite_bottomup + (rewrite_head + (fun t' e' + => match fuel with + | Datatypes.O => nbe e' + | Datatypes.S fuel' => @repeat_rewrite rewrite_head fuel' (type.base t') e' + end%under_lets)) + t e. + + Definition rewrite rewrite_head fuel {t} e : expr t + := reify (@repeat_rewrite rewrite_head fuel t e). + End full. + + Definition Rewrite rewrite_head fuel {t} (e : expr.Expr (ident:=ident) t) : expr.Expr (ident:=ident) t + := fun var => @rewrite var (rewrite_head var) fuel t (e _). + End Compile. + + Module pident := pattern.ident. + + Module Make. + Section make_rewrite_rules. + Import Compile. + Context {var : type.type base.type -> Type}. + Local Notation type := (type.type base.type). + Local Notation expr := (@expr.expr base.type ident var). + Local Notation value := (@value base.type ident var). + Local Notation anyexpr := (@anyexpr ident var). + Local Notation pattern := (@pattern.pattern pattern.ident). + Local Notation UnderLets := (@UnderLets.UnderLets base.type ident var). + Local Notation ptype := (type.type pattern.base.type). + Let type_base (t : base.type) : type := type.base t. + Let ptype_base (t : pattern.base.type) : ptype := type.base t. + Let ptype_base' (t : base.type.base) : ptype := @type.base pattern.base.type t. + Coercion ptype_base' : base.type.base >-> ptype. + Coercion type_base : base.type >-> type. + Coercion ptype_base : pattern.base.type >-> ptype. + Local Notation opt_anyexprP ivar + := (fun should_do_again : bool => UnderLets (@AnyExpr.anyexpr base.type ident (if should_do_again then ivar else var))). + Local Notation opt_anyexpr ivar + := (option (sigT (opt_anyexprP ivar))). + Local Notation binding_dataT := (@binding_dataT ident var pattern.ident pattern.ident.arg_types). + Local Notation lift_with_bindings := (@lift_with_bindings ident var pattern.ident pattern.ident.arg_types). + Local Notation app_binding_data := (@app_binding_data ident var pattern.ident pattern.ident.arg_types). + Local Notation rewrite_rulesT := (@rewrite_rulesT ident var pattern.ident pattern.ident.arg_types). + Local Notation rewrite_ruleT := (@rewrite_ruleT ident var pattern.ident pattern.ident.arg_types). + Local Notation castv := (@castv ident var). + + Definition make_base_Literal_pattern (t : base.type.base) : pattern + := Eval cbv [pident.of_typed_ident] in + pattern.Ident (pident.of_typed_ident (@ident.Literal t DefaultValue.type.base.default)). + + Definition bind_base_Literal_pattern (t : base.type.base) : binding_dataT (make_base_Literal_pattern t) ~> base.interp t + := match t return binding_dataT (make_base_Literal_pattern t) ~> base.interp t with + | base.type.unit + | base.type.Z + | base.type.bool + | base.type.nat + => fun v => (return v) + end%cps. + + Fixpoint make_Literal_pattern (t : base.type) : option { p : pattern & binding_dataT p ~> base.interp t } + := match t return option { p : pattern & binding_dataT p ~> base.interp t } with + | base.type.type_base t => Some (existT _ (make_base_Literal_pattern t) (bind_base_Literal_pattern t)) + | base.type.prod A B + => (a <- make_Literal_pattern A; + b <- make_Literal_pattern B; + Some (existT + (fun p : pattern => binding_dataT p ~> base.interp (A * B)) + (#pident.pair @ (projT1 a) @ (projT1 b))%pattern + (fun '(args : unit * binding_dataT (projT1 a) * binding_dataT (projT1 b)) + => (av <--- projT2 a (snd (fst args)); + bv <--- projT2 b (snd args); + return (av, bv))))) + | base.type.list A => None + end%option%cps. + + Fixpoint make_interp_rewrite' (t : type) (p : pattern) (rew : binding_dataT p ~> type.interp base.interp t) {struct t} + : option rewrite_ruleT + := match t return (_ ~> type.interp base.interp t) -> _ with + | type.base t + => fun rew + => Some (existT _ p (fun args => v <--- rew args; + return (Some (existT _ false (UnderLets.Base (AnyExpr.wrap (ident.smart_Literal v))))))) + | type.arrow (type.base s) d + => fun rew + => (lit_s <- make_Literal_pattern s; + @make_interp_rewrite' + d + (pattern.App p (projT1 lit_s)) + (fun (args : binding_dataT p * binding_dataT (projT1 lit_s)) + => (rewp <--- rew (fst args); + sv <--- projT2 lit_s (snd args); + return (rewp sv)))) + | type.arrow _ _ => fun _ => None + end%option%cps rew. + + Definition make_interp_rewrite'' {t} (idc : ident t) : option rewrite_ruleT + := make_interp_rewrite' + t + (pattern.Ident (pident.of_typed_ident idc)) + (fun iargs => return (ident.interp (pident.retype_ident idc iargs)))%cps. + (* + Definition make_interp_rewrite {t} (idc : ident t) + := invert_Some (make_interp_rewrite'' idc). + *) + + Local Ltac get_all_valid_interp_rules_from body so_far := + let next := match body with + | context[@Some (sigT (fun x : pattern => binding_dataT x ~> opt_anyexpr value)) ?rew] + => lazymatch so_far with + | context[cons rew _] => constr:(I : I) + | _ => lazymatch rew with + | existT _ _ _ => constr:(Some rew) + | _ => constr:(I : I) + end + end + | _ => constr:(@None unit) + end in + lazymatch next with + | Some ?rew => get_all_valid_interp_rules_from body (cons rew so_far) + | None => (eval cbv [List.rev List.app] in (List.rev so_far)) + end. + Local Ltac make_valid_interp_rules := + let body := constr:(fun t idc => @pident.eta_ident_cps _ t idc (@make_interp_rewrite'')) in + let body := (eval cbv [pident.eta_ident_cps make_interp_rewrite'' make_interp_rewrite' make_Literal_pattern pident.of_typed_ident Option.bind projT1 projT2 cpsbind cpsreturn cpscall ident.interp pident.retype_ident ident.gen_interp bind_base_Literal_pattern make_base_Literal_pattern] in body) in + let body := (eval cbn [base.interp binding_dataT pattern.ident.arg_types base.base_interp ident.smart_Literal fold_right map] in body) in + let retv := get_all_valid_interp_rules_from body (@nil rewrite_ruleT) in + exact retv. + Definition interp_rewrite_rules : rewrite_rulesT + := ltac:(make_valid_interp_rules). + End make_rewrite_rules. + End Make. + + Section with_var. + Import Compile. + Context {var : type.type base.type -> Type}. + Local Notation type := (type.type base.type). + Local Notation expr := (@expr.expr base.type ident var). + Local Notation value := (@value base.type ident var). + Local Notation anyexpr := (@anyexpr ident var). + Local Notation pattern := (@pattern.pattern pattern.ident). + Local Notation UnderLets := (@UnderLets.UnderLets base.type ident var). + Local Notation ptype := (type.type pattern.base.type). + Let type_base (t : base.type) : type := type.base t. + Let ptype_base (t : pattern.base.type) : ptype := type.base t. + Let ptype_base' (t : base.type.base) : ptype := @type.base pattern.base.type t. + Coercion ptype_base' : base.type.base >-> ptype. + Coercion type_base : base.type >-> type. + Coercion ptype_base : pattern.base.type >-> ptype. + Local Notation opt_anyexprP ivar + := (fun should_do_again : bool => UnderLets (@AnyExpr.anyexpr base.type ident (if should_do_again then ivar else var))). + Local Notation opt_anyexpr ivar + := (option (sigT (opt_anyexprP ivar))). + Local Notation binding_dataT := (@binding_dataT ident var pattern.ident pattern.ident.arg_types). + Local Notation lift_with_bindings := (@lift_with_bindings ident var pattern.ident pattern.ident.arg_types). + Local Notation app_binding_data := (@app_binding_data ident var pattern.ident pattern.ident.arg_types). + Local Notation rewrite_ruleTP := (@rewrite_ruleTP ident var pattern.ident pattern.ident.arg_types). + Local Notation rewrite_rulesT := (@rewrite_rulesT ident var pattern.ident pattern.ident.arg_types). + Local Notation castv := (@castv ident var). + Local Notation assemble_identifier_rewriters := (@assemble_identifier_rewriters ident var pattern.ident pattern.ident.full_types (@pattern.ident.invert_bind_args) pattern.ident.type_of pattern.ident.to_typed (@pattern.ident.eta_ident_cps) (@pattern.ident.of_typed_ident) pattern.ident.arg_types (@pattern.ident.bind_args) pattern.ident.try_make_transport_ident_cps). + + Let UnderLetsExpr {btype bident ivar} t := @UnderLets.UnderLets base.type ident var (@expr.expr btype bident ivar t). + Let UnderLetsAnyExpr {btype ident ivar} := @UnderLets.UnderLets btype ident ivar (@AnyExpr.anyexpr btype ident ivar). + Let UnderLetsAnyExprCpsOpt {btype bident ivar} := ~> option (@UnderLets.UnderLets base.type ident var (@AnyExpr.anyexpr btype bident ivar)). + (*Let UnderLetsAnyAnyExpr {btype ident ivar} := @UnderLets.UnderLets btype ident ivar (@AnyAnyExpr.anyexpr btype ident ivar).*) + Let BaseWrapUnderLetsAnyExpr {btype bident ivar t} : @UnderLetsExpr btype bident ivar t -> @UnderLetsAnyExprCpsOpt btype bident ivar + := fun e T k + => k (match t return @UnderLets.UnderLets _ _ _ (@expr.expr _ _ _ t) -> _ with + | type.base _ => fun e => Some (e <-- e; UnderLets.Base (AnyExpr.wrap e))%under_lets + | type.arrow _ _ => fun _ => None + end e)%cps. + Let BaseExpr {btype ident ivar t} : @expr.expr btype ident ivar t -> @UnderLetsExpr btype ident ivar t := UnderLets.Base. + (*Let BaseAnyAnyExpr {btype ident ivar t} : @expr.expr btype ident ivar t -> @UnderLets.UnderLets btype ident ivar (@expr.expr btype ident ivar t) := UnderLets.Base.*) + Coercion BaseWrapUnderLetsAnyExpr : UnderLetsExpr >-> UnderLetsAnyExprCpsOpt. + Coercion BaseExpr : expr >-> UnderLetsExpr. + Notation ret v := ((v : UnderLetsExpr _) : UnderLetsAnyExprCpsOpt). + Notation oret v := (fun T k => k (Some v)). + (*Coercion BaseExpr : expr >-> UnderLets.*) + Notation make_rewrite'_cps p f + := (existT + (fun p' : pattern => binding_dataT p' ~> (opt_anyexpr value)) + p%pattern + (fun v T (k : opt_anyexpr value -> T) + => @app_binding_data _ p%pattern f%expr v T k)). + Notation make_rewrite' p f + := (existT + (fun p' : pattern => binding_dataT p' ~> (opt_anyexpr value)) + p%pattern + (fun v T (k : opt_anyexpr value -> T) + => k (@app_binding_data _ p%pattern f%expr v))). + Notation make_rewrite p f + := (let f' := (@lift_with_bindings p _ _ (fun x:@UnderLetsAnyExprCpsOpt base.type ident var => (x' <-- x; oret (existT (opt_anyexprP value) false x'))%cps) f%expr) in + make_rewrite'_cps p f'). + Notation make_rewrite_step p f + := (let f' := (@lift_with_bindings p _ _ (fun x:@UnderLetsAnyExprCpsOpt base.type ident value => (x' <-- x; oret (existT (opt_anyexprP value) true x'))%cps) f%expr) in + make_rewrite'_cps p f'). + + Local Notation "x' <- v ; C" := (fun T k => v%cps T (fun x' => match x' with Some x' => (C%cps : UnderLetsAnyExprCpsOpt) T k | None => k None end)) : cps_scope. + Local Notation "x <-- y ; f" := (UnderLets.splice y (fun x => (f%cps : UnderLetsExpr _))) : cps_scope. + Local Notation "x <--- y ; f" := (UnderLets.splice_list y (fun x => (f%cps : UnderLetsExpr _))) : cps_scope. + Local Notation "x <---- y ; f" := (fun T k => match y with Some x => (f%cps : UnderLetsAnyExprCpsOpt) T k | None => k None end) : cps_scope. + + Definition rlist_rect {A P} + {ivar} + (Pnil : @UnderLetsExpr base.type ident ivar (type.base P)) + (Pcons : expr (type.base A) -> list (expr (type.base A)) -> @expr.expr base.type ident ivar (type.base P) -> @UnderLetsExpr base.type ident ivar (type.base P)) + (e : expr (type.base (base.type.list A))) + : @UnderLetsAnyExprCpsOpt base.type ident ivar + := (ls <- reflect_list_cps e; + list_rect + (fun _ => UnderLetsExpr (type.base P)) + Pnil + (fun x xs rec => rec' <-- rec; Pcons x xs rec') + ls)%cps. + + Definition rlist_rect_cast {A A' P} + {ivar} + (Pnil : @UnderLetsExpr base.type ident ivar (type.base P)) + (Pcons : expr (type.base A) -> list (expr (type.base A)) -> @expr.expr base.type ident ivar (type.base P) -> @UnderLetsExpr base.type ident ivar (type.base P)) + (e : expr (type.base A')) + : @UnderLetsAnyExprCpsOpt base.type ident ivar + := (e <- castbe e; rlist_rect Pnil Pcons e)%cps. + + Definition rwhen {ivar} (v : @UnderLetsAnyExprCpsOpt base.type ident ivar) (cond : bool) + : @UnderLetsAnyExprCpsOpt base.type ident ivar + := fun T k => if cond then v T k else k None. + + Local Notation "e 'when' cond" := (rwhen e%cps cond) (only parsing, at level 100). + + Local Notation ℤ := base.type.Z. + Local Notation ℕ := base.type.nat. + Local Notation bool := base.type.bool. + Local Notation list := pattern.base.type.list. + + Local Arguments Make.interp_rewrite_rules / . + + (** + The follow are rules for rewriting expressions. On the left is a pattern to match: + ??: any expression whose type contains no arrows. + ??{x}: any expression whose type is x. + ??{pattern.base.type.list ??}: for example, a list with elements of a captured type. (The captured type does not match a type with arrows.) + x @ y: x applied to y. + #?x: a value, know at compile time, with type x. (Where x is one of {ℕ or N (nat), 𝔹 or B (bool), ℤ or Z (integers)}.) + #x: the identifer x. + + A matched expression is replaced with the right-hand-side, which is a function that returns a syntax tree, or None to indicate that the match didn't really match. The syntax tree is under three monads: continuation, option, and custom UnderLets monad. + + The function takes the elements that where matched on the LHS as arguments. The arguments are given in the same order as on the LHS, but where wildcards in a type appear before the outer wildcard for that element. So ??{??} results in two arguments, the second wildcard comes first, and ??{?? -> ??} gives arguments in the order 2, 3, 1. + + Sometimes matching an identifer will also result in arguments. Depends on the identifer. Good luck! + +In the RHS, the follow notation applies: + ##x: the literal value x + #x: the identifier x + x @ y: x applied to y + $x: PHOAS variable named x + λ: PHOAS abstraction / functions + + On the RHS, since we're returning a value under three monads, there's some fun notion for dealing with different levels of the monad stack in a single expression: + ret: return something of type [UnderLets expr] + <-: bind, under the CPS+Option monad. + <--: bind, under the UnderLets monad + <---: bind, under the UnderLets+List monad + <----: bind, under the Option monad. + + If you have an expression of type expr or UnderLetsExpr or UnderLetsAnyExprCpsOpt, coercions will handle it; if you have an expression of type [UnderLets expr], you will need [ret]. + + If stuck, email Jason. + *) + Definition rewrite_rules : rewrite_rulesT + := Eval cbn [Make.interp_rewrite_rules List.app] in + Make.interp_rewrite_rules + ++ [ + make_rewrite (#pident.fst @ (??, ??)) (fun _ x _ y => x) + ; make_rewrite (#pident.snd @ (??, ??)) (fun _ x _ y => y) + ; make_rewrite (#pident.List_repeat @ ?? @ #?ℕ) (fun _ x n => reify_list (repeat x n)) + ; make_rewrite + (#pident.bool_rect @ ??{() -> ??} @ ??{() -> ??} @ #?𝔹) + (fun _ t _ f b + => if b return UnderLetsExpr (type.base (if b then _ else _)) + then t ##tt + else f ##tt) + ; make_rewrite + (#pident.pair_rect @ ??{?? -> ?? -> ??} @ (??, ??)) + (fun _ _ _ f _ x _ y + => x <- castbe x; y <- castbe y; ret (f x y)) + ; make_rewrite + (??{list ??} ++ ??{list ??}) + (fun _ xs _ ys => rlist_rect_cast ys (fun x _ xs_ys => x :: xs_ys) xs) + ; make_rewrite + (#pident.List_rev @ ??{list ??}) + (fun _ xs + => xs <- reflect_list_cps xs; + reify_list (List.rev xs)) + ; make_rewrite_step + (#pident.List_flat_map @ ??{?? -> list ??} @ ??{list ??}) + (fun _ B f _ xs + => rlist_rect_cast + [] + (fun x _ flat_map_tl => fx <-- f x; UnderLets.Base ($fx ++ flat_map_tl)) + xs) + ; make_rewrite_step + (#pident.List_partition @ ??{?? -> base.type.bool} @ ??{list ??}) + (fun _ f _ xs + => rlist_rect_cast + ([], []) + (fun x tl partition_tl + => fx <-- f x; + (#ident.pair_rect + @ (λ g d, #ident.bool_rect + @ (λ _, ($x :: $g, $d)) + @ (λ _, ($g, $x :: $d)) + @ $fx) + @ partition_tl)) + xs) + ; make_rewrite + (#pident.List_fold_right @ ??{?? -> ?? -> ??} @ ?? @ ??{list ??}) + (fun _ _ _ f B init A xs + => f <- @castv _ (A -> B -> B)%etype f; + rlist_rect + init + (fun x _ y => f x y) + xs) + ; make_rewrite + (#pident.list_rect @ ??{() -> ??} @ ??{?? -> ?? -> ?? -> ??} @ ??{list ??}) + (fun P Pnil _ _ _ _ Pcons A xs + => Pcons <- @castv _ (A -> base.type.list A -> P -> P) Pcons; + rlist_rect + (Pnil ##tt) + (fun x' xs' rec => Pcons x' (reify_list xs') rec) + xs) + ; make_rewrite + (#pident.list_case @ ??{() -> ??} @ ??{?? -> ?? -> ??} @ []) (fun _ Pnil _ _ _ Pcons => ret (Pnil ##tt)) + ; make_rewrite + (#pident.list_case @ ??{() -> ??} @ ??{?? -> ?? -> ??} @ (?? :: ??)) + (fun _ Pnil _ _ _ Pcons _ x _ xs + => x <- castbe x; xs <- castbe xs; ret (Pcons x xs)) + ; make_rewrite + (#pident.List_map @ ??{?? -> ??} @ ??{list ??}) + (fun _ _ f _ xs + => rlist_rect_cast + [] + (fun x _ fxs => fx <-- f x; fx :: fxs) + xs) + ; make_rewrite + (#pident.List_nth_default @ ?? @ ??{list ??} @ #?ℕ) + (fun _ default _ ls n + => default <- castbe default; + ls <- reflect_list_cps ls; + nth_default default ls n) + ; make_rewrite + (#pident.nat_rect @ ??{() -> ??} @ ??{base.type.nat -> ?? -> ??} @ #?ℕ) + (fun P O_case _ _ S_case n + => S_case <- @castv _ (@type.base base.type base.type.nat -> type.base P -> type.base P) S_case; + ret (nat_rect _ (O_case ##tt) (fun n' rec => rec <-- rec; S_case ##n' rec) n)) + ; make_rewrite + (#pident.List_length @ ??{list ??}) + (fun _ xs => xs <- reflect_list_cps xs; ##(List.length xs)) + ; make_rewrite + (#pident.List_combine @ ??{list ??} @ ??{list ??}) + (fun _ xs _ ys + => xs <- reflect_list_cps xs; + ys <- reflect_list_cps ys; + reify_list (List.map (fun '((x, y)%core) => (x, y)) (List.combine xs ys))) + ; make_rewrite + (#pident.List_update_nth @ #?ℕ @ ??{?? -> ??} @ ??{list ??}) + (fun n _ _ f A ls + => f <- @castv _ (A -> A) f; + ls <- reflect_list_cps ls; + ret + (retv <--- (update_nth + n + (fun x => x <-- x; f x) + (List.map UnderLets.Base ls)); + reify_list retv)) + ; make_rewrite (#?ℤ + ??{ℤ}) (fun z v => v when Z.eqb z 0) + ; make_rewrite (??{ℤ} + #?ℤ ) (fun v z => v when Z.eqb z 0) + ; make_rewrite (#?ℤ + (-??{ℤ})) (fun z v => ##z - v when Z.gtb z 0) + ; make_rewrite ((-??{ℤ}) + #?ℤ ) (fun v z => ##z - v when Z.gtb z 0) + ; make_rewrite (#?ℤ + (-??{ℤ})) (fun z v => -(##((-z)%Z) + v) when Z.ltb z 0) + ; make_rewrite ((-??{ℤ}) + #?ℤ ) (fun v z => -(v + ##((-z)%Z)) when Z.ltb z 0) + ; make_rewrite ((-??{ℤ}) + (-??{ℤ})) (fun x y => -(x + y)) + ; make_rewrite ((-??{ℤ}) + ??{ℤ} ) (fun x y => y - x) + ; make_rewrite ( ??{ℤ} + (-??{ℤ})) (fun x y => x - y) + + ; make_rewrite (#?ℤ - (-??{ℤ})) (fun z v => v when Z.eqb z 0) + ; make_rewrite (#?ℤ - ??{ℤ} ) (fun z v => -v when Z.eqb z 0) + ; make_rewrite (??{ℤ} - #?ℤ ) (fun v z => v when Z.eqb z 0) + ; make_rewrite (#?ℤ - (-??{ℤ})) (fun z v => ##z + v when Z.gtb z 0) + ; make_rewrite (#?ℤ - (-??{ℤ})) (fun z v => v - ##((-z)%Z) when Z.ltb z 0) + ; make_rewrite (#?ℤ - ??{ℤ} ) (fun z v => -(##((-z)%Z) + v) when Z.ltb z 0) + ; make_rewrite ((-??{ℤ}) - #?ℤ ) (fun v z => -(v + ##((-z)%Z)) when Z.gtb z 0) + ; make_rewrite ((-??{ℤ}) - #?ℤ ) (fun v z => ##((-z)%Z) - v when Z.ltb z 0) + ; make_rewrite ( ??{ℤ} - #?ℤ ) (fun v z => v + ##((-z)%Z) when Z.ltb z 0) + ; make_rewrite ((-??{ℤ}) - (-??{ℤ})) (fun x y => y - x) + ; make_rewrite ((-??{ℤ}) - ??{ℤ} ) (fun x y => -(x + y)) + ; make_rewrite ( ??{ℤ} - (-??{ℤ})) (fun x y => x + y) + + ; make_rewrite (#?ℤ * ??{ℤ}) (fun z v => ##0 when Z.eqb z 0) + ; make_rewrite (??{ℤ} * #?ℤ ) (fun v z => ##0 when Z.eqb z 0) + ; make_rewrite (#?ℤ * ??{ℤ}) (fun z v => v when Z.eqb z 1) + ; make_rewrite (??{ℤ} * #?ℤ ) (fun v z => v when Z.eqb z 1) + ; make_rewrite (#?ℤ * (-??{ℤ})) (fun z v => v when Z.eqb z (-1)) + ; make_rewrite ((-??{ℤ}) * #?ℤ ) (fun v z => v when Z.eqb z (-1)) + ; make_rewrite (#?ℤ * ??{ℤ} ) (fun z v => -v when Z.eqb z (-1)) + ; make_rewrite (??{ℤ} * #?ℤ ) (fun v z => -v when Z.eqb z (-1)) + ; make_rewrite (#?ℤ * ??{ℤ} ) (fun z v => -(##((-z)%Z) * v) when Z.ltb z 0) + ; make_rewrite (??{ℤ} * #?ℤ ) (fun v z => -(v * ##((-z)%Z)) when Z.ltb z 0) + ; make_rewrite ((-??{ℤ}) * (-??{ℤ})) (fun x y => x * y) + ; make_rewrite ((-??{ℤ}) * ??{ℤ} ) (fun x y => -(x * y)) + ; make_rewrite ( ??{ℤ} * (-??{ℤ})) (fun x y => -(x * y)) + + ; make_rewrite (??{ℤ} * #?ℤ) (fun x y => x << (Z.log2 y) when Z.eqb y (2^Z.log2 y)) + ; make_rewrite (#?ℤ * ??{ℤ}) (fun y x => x << (Z.log2 y) when Z.eqb y (2^Z.log2 y)) + ; make_rewrite (??{ℤ} / #?ℤ) (fun x y => x >> (Z.log2 y) when Z.eqb y (2^Z.log2 y)) + ; make_rewrite (??{ℤ} mod #?ℤ) (fun x y => #(ident.Z_land (y-1)) @ x when Z.eqb y (2^Z.log2 y)) + ; make_rewrite (-(-??{ℤ})) (fun v => v) + + (** TODO(jadep): These next two are only here for demonstration purposes; remove them once you no longer need it as a template *) + (* if it's a concrete pair, we can opp the second value *) + ; make_rewrite (#pident.Z_neg_snd @ (??{ℤ}, ??{ℤ})) (fun x y => (x, -y)) + (* if it's not a concrete pair, let-bind the pair and negate the second element *) + ; make_rewrite + (#pident.Z_neg_snd @ ??{ℤ * ℤ}) + (fun xy => ret (UnderLets.UnderLet xy (fun xyv => UnderLets.Base (#ident.fst @ $xyv, -(#ident.snd @ $xyv))))) + + ; make_rewrite (#pident.Z_mul_split @ #?ℤ @ #?ℤ @ ??{ℤ}) (fun s xx y => (##0, ##0)%Z when Z.eqb xx 0) + ; make_rewrite (#pident.Z_mul_split @ #?ℤ @ ??{ℤ} @ #?ℤ) (fun s y xx => (##0, ##0)%Z when Z.eqb xx 0) + ; make_rewrite (#pident.Z_mul_split @ #?ℤ @ #?ℤ @ ??{ℤ}) (fun s xx y => (y, ##0)%Z when Z.eqb xx 1) + ; make_rewrite (#pident.Z_mul_split @ #?ℤ @ ??{ℤ} @ #?ℤ) (fun s y xx => (y, ##0)%Z when Z.eqb xx 1) + ; make_rewrite (#pident.Z_mul_split @ #?ℤ @ #?ℤ @ ??{ℤ}) (fun s xx y => (-y, ##0%Z) when Z.eqb xx (-1)) + ; make_rewrite (#pident.Z_mul_split @ #?ℤ @ ??{ℤ} @ #?ℤ) (fun s y xx => (-y, ##0%Z) when Z.eqb xx (-1)) + + ; make_rewrite (#pident.Z_add_get_carry @ #?ℤ @ #?ℤ @ ??{ℤ}) (fun s xx y => (y, ##0%Z) when Z.eqb xx 0) + ; make_rewrite (#pident.Z_add_get_carry @ #?ℤ @ ??{ℤ} @ #?ℤ) (fun s y xx => (y, ##0%Z) when Z.eqb xx 0) + + ; make_rewrite (#pident.Z_add_with_carry @ #?ℤ @ ??{ℤ} @ ??{ℤ}) (fun c x y => x + y when Z.eqb c 0) + + + ; make_rewrite + (#pident.Z_add_with_get_carry @ #?ℤ @ #?ℤ @ #?ℤ @ ??{ℤ}) (fun s cc xx y => (y, ##0) when (cc =? 0) && (xx =? 0)) + ; make_rewrite + (#pident.Z_add_with_get_carry @ #?ℤ @ #?ℤ @ ??{ℤ} @ #?ℤ) (fun s cc y xx => (y, ##0) when (cc =? 0) && (xx =? 0)) + ; make_rewrite (* carry = 0: ADC x y -> ADD x y *) + (#pident.Z_add_with_get_carry @ #?ℤ @ #?ℤ @ ??{ℤ} @ ??{ℤ}) + (fun s cc x y => #(ident.Z_add_get_carry_concrete s) @ x @ y when cc =? 0) + ; make_rewrite (* ADC 0 0 -> (ADX 0 0, 0) *) + (#pident.Z_add_with_get_carry @ #?ℤ @ ??{ℤ} @ #?ℤ @ #?ℤ) + (fun s c xx yy => #ident.Z_add_with_carry @ ##s @ ##xx @ ##yy when (xx =? 0) && (yy =? 0)) + + ; make_rewrite + (#pident.Z_add_get_carry @ #?ℤ @ (-??{ℤ}) @ ??{ℤ}) + (fun s y x => ret (UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s) @ x @ y) + (fun vc => UnderLets.Base (#ident.fst @ $vc, -(#ident.snd @ $vc))))) + ; make_rewrite + (#pident.Z_add_get_carry @ #?ℤ @ ??{ℤ} @ (-??{ℤ})) + (fun s x y => ret (UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s) @ x @ y) + (fun vc => UnderLets.Base (#ident.fst @ $vc, -(#ident.snd @ $vc))))) + + + ; make_rewrite + (#pident.Z_add_with_get_carry @ #?ℤ @ (-??{ℤ}) @ (-??{ℤ}) @ ??{ℤ}) + (fun s c y x => ret (UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete s) @ c @ x @ y) + (fun vc => UnderLets.Base (#ident.fst @ $vc, -(#ident.snd @ $vc))))) + ; make_rewrite + (#pident.Z_add_with_get_carry @ #?ℤ @ (-??{ℤ}) @ ??{ℤ} @ (-??{ℤ})) + (fun s c x y => ret (UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete s) @ c @ x @ y) + (fun vc => UnderLets.Base (#ident.fst @ $vc, -(#ident.snd @ $vc))))) + + ; make_rewrite + (#pident.Z_add_get_carry_concrete @ (-??{ℤ}) @ ??{ℤ}) + (fun s y x => ret (UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s) @ x @ y) + (fun vc => UnderLets.Base (#ident.fst @ $vc, -(#ident.snd @ $vc))))) + ; make_rewrite + (#pident.Z_add_get_carry_concrete @ ??{ℤ} @ (-??{ℤ})) + (fun s x y => ret (UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s) @ x @ y) + (fun vc => UnderLets.Base (#ident.fst @ $vc, -(#ident.snd @ $vc))))) + ; make_rewrite + (#pident.Z_add_get_carry_concrete @ #?ℤ @ ??{ℤ}) + (fun s yy x => ret (UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s) @ x @ ##(-yy)%Z) + (fun vc => UnderLets.Base (#ident.fst @ $vc, -(#ident.snd @ $vc)))) + when yy <=? 0) + ; make_rewrite + (#pident.Z_add_get_carry_concrete @ ??{ℤ} @ #?ℤ) + (fun s x yy => ret (UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s) @ x @ ##(-yy)%Z) + (fun vc => UnderLets.Base (#ident.fst @ $vc, -(#ident.snd @ $vc)))) + when yy <=? 0) + + + ; make_rewrite + (#pident.Z_add_with_get_carry_concrete @ (-??{ℤ}) @ (-??{ℤ}) @ ??{ℤ}) + (fun s c y x => ret (UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete s) @ c @ x @ y) + (fun vc => UnderLets.Base (#ident.fst @ $vc, -(#ident.snd @ $vc))))) + ; make_rewrite + (#pident.Z_add_with_get_carry_concrete @ (-??{ℤ}) @ ??{ℤ} @ (-??{ℤ})) + (fun s c x y => ret (UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete s) @ c @ x @ y) + (fun vc => UnderLets.Base (#ident.fst @ $vc, -(#ident.snd @ $vc))))) + ; make_rewrite + (#pident.Z_add_with_get_carry_concrete @ (-??{ℤ}) @ #?ℤ @ ??{ℤ}) + (fun s c yy x => ret (UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete s) @ c @ x @ ##(-yy)%Z) + (fun vc => UnderLets.Base (#ident.fst @ $vc, -(#ident.snd @ $vc)))) + when yy <=? 0) + ; make_rewrite + (#pident.Z_add_with_get_carry_concrete @ (-??{ℤ}) @ ??{ℤ} @ #?ℤ) + (fun s c x yy => ret (UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete s) @ c @ x @ ##(-yy)%Z) + (fun vc => UnderLets.Base (#ident.fst @ $vc, -(#ident.snd @ $vc)))) + when yy <=? 0) + + ; make_rewrite (#pident.Z_add_get_carry_concrete @ #?ℤ @ ??{ℤ}) (fun s xx y => (y, ##0) when xx =? 0) + ; make_rewrite (#pident.Z_add_get_carry_concrete @ ??{ℤ} @ #?ℤ) (fun s y xx => (y, ##0) when xx =? 0) + + (** XXX TODO: Do we still need the _concrete versions? *) + ; make_rewrite (#pident.Z_mul_split @ #?ℤ @ ??{ℤ} @ ??{ℤ}) (fun s x y => #(ident.Z_mul_split_concrete s) @ x @ y) + ; make_rewrite (#pident.Z_rshi @ #?ℤ @ ??{ℤ} @ ??{ℤ} @ #?ℤ) (fun x y z a => #(ident.Z_rshi_concrete x a) @ y @ z) + ; make_rewrite (#pident.Z_cc_m @ #?ℤ @ ??{ℤ}) (fun x y => #(ident.Z_cc_m_concrete x) @ y) + ; make_rewrite (#pident.Z_add_get_carry @ #?ℤ @ ??{ℤ} @ ??{ℤ}) (fun s x y => #(ident.Z_add_get_carry_concrete s) @ x @ y) + ; make_rewrite (#pident.Z_add_with_get_carry @ #?ℤ @ ??{ℤ} @ ??{ℤ} @ ??{ℤ}) (fun s c x y => #(ident.Z_add_with_get_carry_concrete s) @ c @ x @ y) + ; make_rewrite (#pident.Z_sub_get_borrow @ #?ℤ @ ??{ℤ} @ ??{ℤ}) (fun s x y => #(ident.Z_sub_get_borrow_concrete s) @ x @ y) + ; make_rewrite (#pident.Z_sub_with_get_borrow @ #?ℤ @ ??{ℤ} @ ??{ℤ} @ ??{ℤ}) (fun s x y b => #(ident.Z_sub_with_get_borrow_concrete s) @ x @ y @ b) + + ; make_rewrite_step (* _step, so that if one of the arguments is concrete, we automatically get the rewrite rule for [Z_cast] applying to it *) + (#pident.Z_cast2 @ (??{ℤ}, ??{ℤ})) (fun r x y => (#(ident.Z_cast (fst r)) @ $x, #(ident.Z_cast (snd r)) @ $y)) + ]%list%pattern%cps%option%under_lets%Z%bool. + + Definition dtree' + := Eval compute in @compile_rewrites ident var pattern.ident pattern.ident.arg_types pattern.ident.ident_beq 100 rewrite_rules. + Definition dtree : decision_tree + := Eval compute in invert_Some dtree'. + Definition default_fuel := Eval compute in List.length rewrite_rules. + + Import PrimitiveHList. + (* N.B. The [combine_hlist] call MUST eta-expand + [pr2_rewrite_rules]. That is, it MUST NOT block reduction of + the resulting list of cons cells on the pair-structure of + [pr2_rewrite_rules]. This is required so that we can use + [cbv -] to unfold the entire discrimination tree evaluation, + including choosing which rewrite rule to apply and binding + its arguments, without unfolding any of the identifiers used + to define the replacement value. (The symptom of messing + this up is that the [cbv -] will run out of memory when + trying to reduce things.) We accomplish this by making + [hlist] based on a primitive [prod] type with judgmental η, + so that matching on its structure never blocks reduction. *) + Definition split_rewrite_rules := Eval cbv [split_list projT1 projT2 rewrite_rules] in split_list rewrite_rules. + Definition pr1_rewrite_rules := Eval hnf in projT1 split_rewrite_rules. + Definition pr2_rewrite_rules := Eval hnf in projT2 split_rewrite_rules. + Definition all_rewrite_rules := combine_hlist (P:=rewrite_ruleTP) pr1_rewrite_rules pr2_rewrite_rules. + + Definition rewrite_head0 do_again {t} (idc : ident t) : value_with_lets t + := @assemble_identifier_rewriters dtree all_rewrite_rules do_again t idc. + + Section fancy. + Context (invert_low invert_high : Z (*log2wordmax*) -> Z -> option Z). + Definition fancy_rewrite_rules : rewrite_rulesT + := [ + (* +(Z.add_get_carry_concrete 2^256) @@ (?x, ?y << 128) --> (add 128) @@ (x, y) +(Z.add_get_carry_concrete 2^256) @@ (?x << 128, ?y) --> (add 128) @@ (y, x) +(Z.add_get_carry_concrete 2^256) @@ (?x, ?y >> 128) --> (add (- 128)) @@ (x, y) +(Z.add_get_carry_concrete 2^256) @@ (?x >> 128, ?y) --> (add (- 128)) @@ (y, x) +(Z.add_get_carry_concrete 2^256) @@ (?x, ?y) --> (add 0) @@ (y, x) +*) + make_rewrite + (#pident.Z_add_get_carry_concrete @ ??{ℤ} @ (#pident.Z_shiftl @ ??{ℤ})) + (fun s x offset y => #(ident.fancy_add (Z.log2 s) offset) @ (x, y) when s =? 2^Z.log2 s) + ; make_rewrite + (#pident.Z_add_get_carry_concrete @ (#pident.Z_shiftl @ ??{ℤ}) @ ??{ℤ}) + (fun s offset y x => #(ident.fancy_add (Z.log2 s) offset) @ (x, y) when s =? 2^Z.log2 s) + ; make_rewrite + (#pident.Z_add_get_carry_concrete @ ??{ℤ} @ (#pident.Z_shiftr @ ??{ℤ})) + (fun s x offset y => #(ident.fancy_add (Z.log2 s) (-offset)) @ (x, y) when s =? 2^Z.log2 s) + ; make_rewrite + (#pident.Z_add_get_carry_concrete @ (#pident.Z_shiftr @ ??{ℤ}) @ ??{ℤ}) + (fun s offset y x => #(ident.fancy_add (Z.log2 s) (-offset)) @ (x, y) when s =? 2^Z.log2 s) + ; make_rewrite + (#pident.Z_add_get_carry_concrete @ ??{ℤ} @ ??{ℤ}) + (fun s x y => #(ident.fancy_add (Z.log2 s) 0) @ (x, y) when s =? 2^Z.log2 s) +(* +(Z.add_with_get_carry_concrete 2^256) @@ (?c, ?x, ?y << 128) --> (addc 128) @@ (c, x, y) +(Z.add_with_get_carry_concrete 2^256) @@ (?c, ?x << 128, ?y) --> (addc 128) @@ (c, y, x) +(Z.add_with_get_carry_concrete 2^256) @@ (?c, ?x, ?y >> 128) --> (addc (- 128)) @@ (c, x, y) +(Z.add_with_get_carry_concrete 2^256) @@ (?c, ?x >> 128, ?y) --> (addc (- 128)) @@ (c, y, x) +(Z.add_with_get_carry_concrete 2^256) @@ (?c, ?x, ?y) --> (addc 0) @@ (c, y, x) + *) + ; make_rewrite + (#pident.Z_add_with_get_carry_concrete @ ??{ℤ} @ ??{ℤ} @ (#pident.Z_shiftl @ ??{ℤ})) + (fun s c x offset y => #(ident.fancy_addc (Z.log2 s) offset) @ (c, x, y) when s =? 2^Z.log2 s) + ; make_rewrite + (#pident.Z_add_with_get_carry_concrete @ ??{ℤ} @ (#pident.Z_shiftl @ ??{ℤ}) @ ??{ℤ}) + (fun s c offset y x => #(ident.fancy_addc (Z.log2 s) offset) @ (c, x, y) when s =? 2^Z.log2 s) + ; make_rewrite + (#pident.Z_add_with_get_carry_concrete @ ??{ℤ} @ ??{ℤ} @ (#pident.Z_shiftr @ ??{ℤ})) + (fun s c x offset y => #(ident.fancy_addc (Z.log2 s) (-offset)) @ (c, x, y) when s =? 2^Z.log2 s) + ; make_rewrite + (#pident.Z_add_with_get_carry_concrete @ ??{ℤ} @ (#pident.Z_shiftr @ ??{ℤ}) @ ??{ℤ}) + (fun s c offset y x => #(ident.fancy_addc (Z.log2 s) (-offset)) @ (c, x, y) when s =? 2^Z.log2 s) + ; make_rewrite + (#pident.Z_add_with_get_carry_concrete @ ??{ℤ} @ ??{ℤ} @ ??{ℤ}) + (fun s c x y => #(ident.fancy_addc (Z.log2 s) 0) @ (c, x, y) when s =? 2^Z.log2 s) +(* +(Z.sub_get_borrow_concrete 2^256) @@ (?x, ?y << 128) --> (sub 128) @@ (x, y) +(Z.sub_get_borrow_concrete 2^256) @@ (?x, ?y >> 128) --> (sub (- 128)) @@ (x, y) +(Z.sub_get_borrow_concrete 2^256) @@ (?x, ?y) --> (sub 0) @@ (y, x) + *) + ; make_rewrite + (#pident.Z_sub_get_borrow_concrete @ ??{ℤ} @ (#pident.Z_shiftl @ ??{ℤ})) + (fun s x offset y => #(ident.fancy_sub (Z.log2 s) offset) @ (x, y) when s =? 2^Z.log2 s) + ; make_rewrite + (#pident.Z_sub_get_borrow_concrete @ ??{ℤ} @ (#pident.Z_shiftr @ ??{ℤ})) + (fun s x offset y => #(ident.fancy_sub (Z.log2 s) (-offset)) @ (x, y) when s =? 2^Z.log2 s) + ; make_rewrite + (#pident.Z_sub_get_borrow_concrete @ ??{ℤ} @ ??{ℤ}) + (fun s x y => #(ident.fancy_sub (Z.log2 s) 0) @ (x, y) when s =? 2^Z.log2 s) +(* +(Z.sub_with_get_borrow_concrete 2^256) @@ (?c, ?x, ?y << 128) --> (subb 128) @@ (c, x, y) +(Z.sub_with_get_borrow_concrete 2^256) @@ (?c, ?x, ?y >> 128) --> (subb (- 128)) @@ (c, x, y) +(Z.sub_with_get_borrow_concrete 2^256) @@ (?c, ?x, ?y) --> (subb 0) @@ (c, y, x) + *) + ; make_rewrite + (#pident.Z_sub_with_get_borrow_concrete @ ??{ℤ} @ ??{ℤ} @ (#pident.Z_shiftl @ ??{ℤ})) + (fun s b x offset y => #(ident.fancy_subb (Z.log2 s) offset) @ (b, x, y) when s =? 2^Z.log2 s) + ; make_rewrite + (#pident.Z_sub_with_get_borrow_concrete @ ??{ℤ} @ ??{ℤ} @ (#pident.Z_shiftr @ ??{ℤ})) + (fun s b x offset y => #(ident.fancy_subb (Z.log2 s) (-offset)) @ (b, x, y) when s =? 2^Z.log2 s) + ; make_rewrite + (#pident.Z_sub_with_get_borrow_concrete @ ??{ℤ} @ ??{ℤ} @ ??{ℤ}) + (fun s b x y => #(ident.fancy_subb (Z.log2 s) 0) @ (b, x, y) when s =? 2^Z.log2 s) + (*(Z.rshi_concrete 2^256 ?n) @@ (?c, ?x, ?y) --> (rshi n) @@ (x, y)*) + ; make_rewrite + (#pident.Z_rshi_concrete @ ??{ℤ} @ ??{ℤ}) + (fun '((s, n)%core) x y => #(ident.fancy_rshi (Z.log2 s) n) @ (x, y) when s =? 2^Z.log2 s) +(* +Z.zselect @@ (Z.cc_m_concrete 2^256 ?c, ?x, ?y) --> selm @@ (c, x, y) +Z.zselect @@ (?c &' 1, ?x, ?y) --> sell @@ (c, x, y) +Z.zselect @@ (?c, ?x, ?y) --> selc @@ (c, x, y) + *) + ; make_rewrite + (#pident.Z_zselect @ (#pident.Z_cc_m_concrete @ ??{ℤ}) @ ??{ℤ} @ ??{ℤ}) + (fun s c x y => #(ident.fancy_selm (Z.log2 s)) @ (c, x, y) when s =? 2^Z.log2 s) + ; make_rewrite + (#pident.Z_zselect @ (#pident.Z_land @ ??{ℤ}) @ ??{ℤ} @ ??{ℤ}) + (fun mask c x y => #ident.fancy_sell @ (c, x, y) when mask =? 1) + ; make_rewrite + (#pident.Z_zselect @ ??{ℤ} @ ??{ℤ} @ ??{ℤ}) + (fun c x y => #ident.fancy_selc @ (c, x, y)) +(*Z.add_modulo @@ (?x, ?y, ?m) --> addm @@ (x, y, m)*) + ; make_rewrite + (#pident.Z_add_modulo @ ??{ℤ} @ ??{ℤ} @ ??{ℤ}) + (fun x y m => #ident.fancy_addm @ (x, y, m)) +(* +Z.mul @@ (?x &' (2^128-1), ?y &' (2^128-1)) --> mulll @@ (x, y) +Z.mul @@ (?x &' (2^128-1), ?y >> 128) --> mullh @@ (x, y) +Z.mul @@ (?x >> 128, ?y &' (2^128-1)) --> mulhl @@ (x, y) +Z.mul @@ (?x >> 128, ?y >> 128) --> mulhh @@ (x, y) + *) + (* literal on left *) + ; make_rewrite + (#?ℤ * (#pident.Z_land @ ??{ℤ})) + (fun x mask y => let s := (2*Z.log2_up mask)%Z in x <---- invert_low s x; #(ident.fancy_mulll s) @ (##x, y) when (mask =? 2^(s/2)-1)) + ; make_rewrite + (#?ℤ * (#pident.Z_shiftr @ ??{ℤ})) + (fun x offset y => let s := (2*offset)%Z in x <---- invert_low s x; #(ident.fancy_mullh s) @ (##x, y)) + ; make_rewrite + (#?ℤ * (#pident.Z_land @ ??{ℤ})) + (fun x mask y => let s := (2*Z.log2_up mask)%Z in x <---- invert_high s x; #(ident.fancy_mulhl s) @ (##x, y) when mask =? 2^(s/2)-1) + ; make_rewrite + (#?ℤ * (#pident.Z_shiftr @ ??{ℤ})) + (fun x offset y => let s := (2*offset)%Z in x <---- invert_high s x; #(ident.fancy_mulhh s) @ (##x, y)) + + (* literal on right *) + ; make_rewrite + ((#pident.Z_land @ ??{ℤ}) * #?ℤ) + (fun mask x y => let s := (2*Z.log2_up mask)%Z in y <---- invert_low s y; #(ident.fancy_mulll s) @ (x, ##y) when (mask =? 2^(s/2)-1)) + ; make_rewrite + ((#pident.Z_land @ ??{ℤ}) * #?ℤ) + (fun mask x y => let s := (2*Z.log2_up mask)%Z in y <---- invert_high s y; #(ident.fancy_mullh s) @ (x, ##y) when mask =? 2^(s/2)-1) + ; make_rewrite + ((#pident.Z_shiftr @ ??{ℤ}) * #?ℤ) + (fun offset x y => let s := (2*offset)%Z in y <---- invert_low s y; #(ident.fancy_mulhl s) @ (x, ##y)) + ; make_rewrite + ((#pident.Z_shiftr @ ??{ℤ}) * #?ℤ) + (fun offset x y => let s := (2*offset)%Z in y <---- invert_high s y; #(ident.fancy_mulhh s) @ (x, ##y)) + + (* no literal *) + ; make_rewrite + ((#pident.Z_land @ ??{ℤ}) * (#pident.Z_land @ ??{ℤ})) + (fun mask1 x mask2 y => let s := (2*Z.log2_up mask1)%Z in #(ident.fancy_mulll s) @ (x, y) when (mask1 =? 2^(s/2)-1) && (mask2 =? 2^(s/2)-1)) + ; make_rewrite + ((#pident.Z_land @ ??{ℤ}) * (#pident.Z_shiftr @ ??{ℤ})) + (fun mask x offset y => let s := (2*offset)%Z in #(ident.fancy_mullh s) @ (x, y) when mask =? 2^(s/2)-1) + ; make_rewrite + ((#pident.Z_shiftr @ ??{ℤ}) * (#pident.Z_land @ ??{ℤ})) + (fun offset x mask y => let s := (2*offset)%Z in #(ident.fancy_mulhl s) @ (x, y) when mask =? 2^(s/2)-1) + ; make_rewrite + ((#pident.Z_shiftr @ ??{ℤ}) * (#pident.Z_shiftr @ ??{ℤ})) + (fun offset1 x offset2 y => let s := (2*offset1)%Z in #(ident.fancy_mulhh s) @ (x, y) when offset1 =? offset2) + + ]%list%pattern%cps%option%under_lets%Z%bool. + + Definition fancy_dtree' + := Eval compute in @compile_rewrites ident var pattern.ident pattern.ident.arg_types pattern.ident.ident_beq 100 fancy_rewrite_rules. + Definition fancy_dtree : decision_tree + := Eval compute in invert_Some fancy_dtree'. + Definition fancy_default_fuel := Eval compute in List.length fancy_rewrite_rules. + + Import PrimitiveHList. + Definition fancy_split_rewrite_rules := Eval cbv [split_list projT1 projT2 fancy_rewrite_rules] in split_list fancy_rewrite_rules. + Definition fancy_pr1_rewrite_rules := Eval hnf in projT1 fancy_split_rewrite_rules. + Definition fancy_pr2_rewrite_rules := Eval hnf in projT2 fancy_split_rewrite_rules. + Definition fancy_all_rewrite_rules := combine_hlist (P:=rewrite_ruleTP) fancy_pr1_rewrite_rules fancy_pr2_rewrite_rules. + + Definition fancy_rewrite_head0 do_again {t} (idc : ident t) : value_with_lets t + := @assemble_identifier_rewriters fancy_dtree fancy_all_rewrite_rules do_again t idc. + End fancy. + End with_var. + + Section red_fancy. + Context (invert_low invert_high : Z (*log2wordmax*) -> Z -> option Z) + {var : type.type base.type -> Type} + (do_again : forall t : base.type, @expr base.type ident (@Compile.value base.type ident var) (type.base t) + -> UnderLets.UnderLets base.type ident var (@expr base.type ident var (type.base t))) + {t} (idc : ident t). + + Time Let rewrite_head1 + := Eval cbv -[fancy_pr2_rewrite_rules + base.interp base.try_make_transport_cps + type.try_make_transport_cps type.try_transport_cps + UnderLets.splice UnderLets.to_expr + Compile.reflect Compile.reify Compile.reify_and_let_binds_cps UnderLets.reify_and_let_binds_base_cps + Compile.value' SubstVarLike.is_var_fst_snd_pair_opp + ] in @fancy_rewrite_head0 var invert_low invert_high do_again t idc. + (* Finished transaction in 1.434 secs (1.432u,0.s) (successful) *) + + Time Local Definition fancy_rewrite_head2 + := Eval cbv [id + rewrite_head1 fancy_pr2_rewrite_rules + projT1 projT2 + cpsbind cpscall cps_option_bind cpsreturn + pattern.ident.arg_types + Compile.app_binding_data + Compile.app_pbase_type_interp_cps + Compile.app_ptype_interp_cps + Compile.bind_base_cps + Compile.bind_data_cps + Compile.binding_dataT + Compile.bind_value_cps + Compile.eval_decision_tree + Compile.eval_rewrite_rules + Compile.expr_of_rawexpr + Compile.lift_pbase_type_interp_cps + Compile.lift_ptype_interp_cps + Compile.lift_with_bindings + Compile.pbase_type_interp_cps + Compile.ptype_interp + Compile.ptype_interp_cps + (*Compile.reflect*) + (*Compile.reify*) + Compile.reveal_rawexpr_cps + Compile.rValueOrExpr + Compile.swap_list + Compile.type_of_rawexpr + Compile.value + (*Compile.value'*) + Compile.value_of_rawexpr + Compile.value_with_lets + Compile.with_bindingsT + ident.smart_Literal + type.try_transport_cps + rlist_rect rlist_rect_cast rwhen + ] in rewrite_head1. + (* Finished transaction in 1.347 secs (1.343u,0.s) (successful) *) + + Local Arguments base.try_make_base_transport_cps _ !_ !_. + Local Arguments base.try_make_transport_cps _ !_ !_. + Local Arguments type.try_make_transport_cps _ _ _ !_ !_. + Local Arguments fancy_rewrite_head2 / . + + Time Definition fancy_rewrite_head + := Eval cbn [id + fancy_rewrite_head2 + cpsbind cpscall cps_option_bind cpsreturn + Compile.reify Compile.reify_and_let_binds_cps Compile.reflect Compile.value' + UnderLets.reify_and_let_binds_base_cps + UnderLets.splice UnderLets.splice_list UnderLets.to_expr + base.interp base.base_interp + type.try_make_transport_cps base.try_make_transport_cps base.try_make_base_transport_cps + PrimitiveProd.Primitive.fst PrimitiveProd.Primitive.snd Datatypes.fst Datatypes.snd + ] in fancy_rewrite_head2. + (* Finished transaction in 13.298 secs (13.283u,0.s) (successful) *) + + Redirect "/tmp/fancy_rewrite_head" Print fancy_rewrite_head. + End red_fancy. + + Section red. + Context {var : type.type base.type -> Type} + (do_again : forall t : base.type, @expr base.type ident (@Compile.value base.type ident var) (type.base t) + -> UnderLets.UnderLets base.type ident var (@expr base.type ident var (type.base t))) + {t} (idc : ident t). + + Time Let rewrite_head1 + := Eval cbv -[pr2_rewrite_rules + base.interp base.try_make_transport_cps + type.try_make_transport_cps type.try_transport_cps + UnderLets.splice UnderLets.to_expr + Compile.reflect UnderLets.reify_and_let_binds_base_cps Compile.reify Compile.reify_and_let_binds_cps + Compile.value' + SubstVarLike.is_var_fst_snd_pair_opp + ] in @rewrite_head0 var do_again t idc. + (* Finished transaction in 16.593 secs (16.567u,0.s) (successful) *) + + Time Local Definition rewrite_head2 + := Eval cbv [id + rewrite_head1 pr2_rewrite_rules + projT1 projT2 + cpsbind cpscall cps_option_bind cpsreturn + pattern.ident.arg_types + Compile.app_binding_data + Compile.app_pbase_type_interp_cps + Compile.app_ptype_interp_cps + Compile.bind_base_cps + Compile.bind_data_cps + Compile.binding_dataT + Compile.bind_value_cps + Compile.eval_decision_tree + Compile.eval_rewrite_rules + Compile.expr_of_rawexpr + Compile.lift_pbase_type_interp_cps + Compile.lift_ptype_interp_cps + Compile.lift_with_bindings + Compile.pbase_type_interp_cps + Compile.ptype_interp + Compile.ptype_interp_cps + (*Compile.reflect*) + (*Compile.reify*) + Compile.reveal_rawexpr_cps + Compile.rValueOrExpr + Compile.swap_list + Compile.type_of_rawexpr + Compile.value + (*Compile.value'*) + Compile.value_of_rawexpr + Compile.value_with_lets + Compile.with_bindingsT + ident.smart_Literal + type.try_transport_cps + rlist_rect rlist_rect_cast rwhen + ] in rewrite_head1. + (* Finished transaction in 29.683 secs (29.592u,0.048s) (successful) *) + + Local Arguments base.try_make_base_transport_cps _ !_ !_. + Local Arguments base.try_make_transport_cps _ !_ !_. + Local Arguments type.try_make_transport_cps _ _ _ !_ !_. + Local Arguments rewrite_head2 / . + + Time Definition rewrite_head + := Eval cbn [id + rewrite_head2 + cpsbind cpscall cps_option_bind cpsreturn + Compile.reify Compile.reify_and_let_binds_cps Compile.reflect Compile.value' + UnderLets.reify_and_let_binds_base_cps + UnderLets.splice UnderLets.splice_list UnderLets.to_expr + base.interp base.base_interp + type.try_make_transport_cps base.try_make_transport_cps base.try_make_base_transport_cps + PrimitiveProd.Primitive.fst PrimitiveProd.Primitive.snd Datatypes.fst Datatypes.snd + ] in rewrite_head2. + (* Finished transaction in 16.561 secs (16.54u,0.s) (successful) *) + + Redirect "/tmp/rewrite_head" Print rewrite_head. + End red. + + Definition Rewrite {t} (e : expr.Expr (ident:=ident) t) : expr.Expr (ident:=ident) t + := @Compile.Rewrite (@rewrite_head) default_fuel t e. + Definition RewriteToFancy + (invert_low invert_high : Z (*log2wordmax*) -> Z -> option Z) + {t} (e : expr.Expr (ident:=ident) t) : expr.Expr (ident:=ident) t + := @Compile.Rewrite (fun var _ => @fancy_rewrite_head invert_low invert_high var) fancy_default_fuel t e. + End RewriteRules. + + Import defaults. + + Definition PartialEvaluate {t} (e : Expr t) : Expr t := RewriteRules.Rewrite e. +End Compilers. diff --git a/src/Experiments/NewPipeline/SlowPrimeSynthesisExamples.v b/src/Experiments/NewPipeline/SlowPrimeSynthesisExamples.v new file mode 100644 index 000000000..4cfefcabb --- /dev/null +++ b/src/Experiments/NewPipeline/SlowPrimeSynthesisExamples.v @@ -0,0 +1,865 @@ +Require Import Coq.ZArith.ZArith. +Require Import Coq.derive.Derive. +Require Import Coq.Lists.List. +Require Import Crypto.Experiments.NewPipeline.Arithmetic. +Require Import Crypto.Experiments.NewPipeline.Toplevel1. +Require Import Crypto.Experiments.NewPipeline.Toplevel2. +Require Import Crypto.Experiments.NewPipeline.CStringification. + +Require Import Crypto.Util.Notations. +Import ListNotations. Local Open Scope Z_scope. + +Import UnsaturatedSolinas. + +Module X25519_64. + Definition n := 5%nat. + Definition s := 2^255. + Definition c := [(1, 19)]. + Definition machine_wordsize := 64. + Local Notation tight_bounds := (tight_bounds n s c). + Local Notation loose_bounds := (loose_bounds n s c). + Local Notation prime_bound := (prime_bound s c). + + Derive base_51_relax + SuchThat (rrelax_correctT n s c machine_wordsize base_51_relax) + As base_51_relax_correct. + Proof. Time solve_rrelax machine_wordsize. Time Qed. + Derive base_51_carry_mul + SuchThat (rcarry_mul_correctT n s c machine_wordsize base_51_carry_mul) + As base_51_carry_mul_correct. + Proof. Time solve_rcarry_mul machine_wordsize. Time Qed. + Derive base_51_carry + SuchThat (rcarry_correctT n s c machine_wordsize base_51_carry) + As base_51_carry_correct. + Proof. Time solve_rcarry machine_wordsize. Time Qed. + Derive base_51_add + SuchThat (radd_correctT n s c machine_wordsize base_51_add) + As base_51_add_correct. + Proof. Time solve_radd machine_wordsize. Time Qed. + Derive base_51_sub + SuchThat (rsub_correctT n s c machine_wordsize base_51_sub) + As base_51_sub_correct. + Proof. Time solve_rsub machine_wordsize. Time Qed. + Derive base_51_opp + SuchThat (ropp_correctT n s c machine_wordsize base_51_opp) + As base_51_opp_correct. + Proof. Time solve_ropp machine_wordsize. Time Qed. + Derive base_51_encode + SuchThat (rencode_correctT n s c machine_wordsize base_51_encode) + As base_51_encode_correct. + Proof. Time solve_rencode machine_wordsize. Time Qed. + Derive base_51_zero + SuchThat (rzero_correctT n s c machine_wordsize base_51_zero) + As base_51_zero_correct. + Proof. Time solve_rzero machine_wordsize. Time Qed. + Derive base_51_one + SuchThat (rone_correctT n s c machine_wordsize base_51_one) + As base_51_one_correct. + Proof. Time solve_rone machine_wordsize. Time Qed. + Lemma base_51_curve_good + : check_args n s c machine_wordsize (ErrorT.Success tt) = ErrorT.Success tt. + Proof. vm_compute; reflexivity. Qed. + + Definition base_51_good : GoodT n s c + := Good n s c machine_wordsize + base_51_curve_good + base_51_carry_mul_correct + base_51_carry_correct + base_51_relax_correct + base_51_add_correct + base_51_sub_correct + base_51_opp_correct + base_51_zero_correct + base_51_one_correct + base_51_encode_correct. + + Print Assumptions base_51_good. + Import PrintingNotations. + Set Printing Width 80. + Open Scope string_scope. + Print base_51_carry_mul. +(*base_51_carry_mul = +fun var : type -> Type => +(λ x x0 : var (type.base (base.type.list (base.type.type_base base.type.Z))), + expr_let x1 := (uint64)(x[[0]]) *₁₂₈ (uint64)(x0[[0]]) +₁₂₈ + ((uint64)(x[[1]]) *₁₂₈ ((uint64)(x0[[4]]) *₆₄ 19) +₁₂₈ + ((uint64)(x[[2]]) *₁₂₈ ((uint64)(x0[[3]]) *₆₄ 19) +₁₂₈ + ((uint64)(x[[3]]) *₁₂₈ ((uint64)(x0[[2]]) *₆₄ 19) +₁₂₈ + (uint64)(x[[4]]) *₁₂₈ ((uint64)(x0[[1]]) *₆₄ 19)))) in + expr_let x2 := (uint64)(x1 >> 51) +₁₂₈ + ((uint64)(x[[0]]) *₁₂₈ (uint64)(x0[[1]]) +₁₂₈ + ((uint64)(x[[1]]) *₁₂₈ (uint64)(x0[[0]]) +₁₂₈ + ((uint64)(x[[2]]) *₁₂₈ ((uint64)(x0[[4]]) *₆₄ 19) +₁₂₈ + ((uint64)(x[[3]]) *₁₂₈ ((uint64)(x0[[3]]) *₆₄ 19) +₁₂₈ + (uint64)(x[[4]]) *₁₂₈ ((uint64)(x0[[2]]) *₆₄ 19))))) in + expr_let x3 := (uint64)(x2 >> 51) +₁₂₈ + ((uint64)(x[[0]]) *₁₂₈ (uint64)(x0[[2]]) +₁₂₈ + ((uint64)(x[[1]]) *₁₂₈ (uint64)(x0[[1]]) +₁₂₈ + ((uint64)(x[[2]]) *₁₂₈ (uint64)(x0[[0]]) +₁₂₈ + ((uint64)(x[[3]]) *₁₂₈ ((uint64)(x0[[4]]) *₆₄ 19) +₁₂₈ + (uint64)(x[[4]]) *₁₂₈ ((uint64)(x0[[3]]) *₆₄ 19))))) in + expr_let x4 := (uint64)(x3 >> 51) +₁₂₈ + ((uint64)(x[[0]]) *₁₂₈ (uint64)(x0[[3]]) +₁₂₈ + ((uint64)(x[[1]]) *₁₂₈ (uint64)(x0[[2]]) +₁₂₈ + ((uint64)(x[[2]]) *₁₂₈ (uint64)(x0[[1]]) +₁₂₈ + ((uint64)(x[[3]]) *₁₂₈ (uint64)(x0[[0]]) +₁₂₈ + (uint64)(x[[4]]) *₁₂₈ ((uint64)(x0[[4]]) *₆₄ 19))))) in + expr_let x5 := (uint64)(x4 >> 51) +₁₂₈ + ((uint64)(x[[0]]) *₁₂₈ (uint64)(x0[[4]]) +₁₂₈ + ((uint64)(x[[1]]) *₁₂₈ (uint64)(x0[[3]]) +₁₂₈ + ((uint64)(x[[2]]) *₁₂₈ (uint64)(x0[[2]]) +₁₂₈ + ((uint64)(x[[3]]) *₁₂₈ (uint64)(x0[[1]]) +₁₂₈ + (uint64)(x[[4]]) *₁₂₈ (uint64)(x0[[0]]))))) in + expr_let x6 := ((uint64)(x1) & 2251799813685247) +₆₄ (uint64)(x5 >> 51) *₆₄ 19 in + expr_let x7 := (uint64)(x6 >> 51) +₆₄ ((uint64)(x2) & 2251799813685247) in + expr_let x8 := ((uint64)(x6) & 2251799813685247) in + expr_let x9 := ((uint64)(x7) & 2251799813685247) in + expr_let x10 := (uint64)(x7 >> 51) +₆₄ ((uint64)(x3) & 2251799813685247) in + expr_let x11 := ((uint64)(x4) & 2251799813685247) in + expr_let x12 := ((uint64)(x5) & 2251799813685247) in + [x8; x9; x10; x11; x12])%expr + : Expr + (type.base (base.type.list (base.type.type_base base.type.Z)) -> + type.base (base.type.list (base.type.type_base base.type.Z)) -> + type.base (base.type.list (base.type.type_base base.type.Z)))%ptype +*) + Print base_51_sub. + (* +base_51_sub = +fun var : type -> Type => +(λ x x0 : var (type.base (base.type.list (base.type.type_base base.type.Z))), + expr_let x1 := (4503599627370458 +₆₄ (uint64)(x[[0]])) -₆₄ (uint64)(x0[[0]]) in + expr_let x2 := (4503599627370494 +₆₄ (uint64)(x[[1]])) -₆₄ (uint64)(x0[[1]]) in + expr_let x3 := (4503599627370494 +₆₄ (uint64)(x[[2]])) -₆₄ (uint64)(x0[[2]]) in + expr_let x4 := (4503599627370494 +₆₄ (uint64)(x[[3]])) -₆₄ (uint64)(x0[[3]]) in + expr_let x5 := (4503599627370494 +₆₄ (uint64)(x[[4]])) -₆₄ (uint64)(x0[[4]]) in + [x1; x2; x3; x4; x5])%expr + : Expr + (type.base (base.type.list (base.type.type_base base.type.Z)) -> + type.base (base.type.list (base.type.type_base base.type.Z)) -> + type.base (base.type.list (base.type.type_base base.type.Z)))%ptype +*) + + Compute Compilers.ToString.C.ToFunctionString + "fecarry_mul" base_51_carry_mul + None (Some loose_bounds, (Some loose_bounds, tt)). + (* +void fecarry_mul(uint64_t[5] x1, uint64_t[5] x2, uint64_t[5] x3) { + uint128_t x4 = (((uint128_t)(x1[0]) * (x2[0])) + (((uint128_t)(x1[1]) * ((x2[4]) * 0x13)) + (((uint128_t)(x1[2]) * ((x2[3]) * 0x13)) + (((uint128_t)(x1[3]) * ((x2[2]) * 0x13)) + ((uint128_t)(x1[4]) * ((x2[1]) * 0x13)))))); + uint128_t x5 = ((uint64_t)(x4 >> 51) + (((uint128_t)(x1[0]) * (x2[1])) + (((uint128_t)(x1[1]) * (x2[0])) + (((uint128_t)(x1[2]) * ((x2[4]) * 0x13)) + (((uint128_t)(x1[3]) * ((x2[3]) * 0x13)) + ((uint128_t)(x1[4]) * ((x2[2]) * 0x13))))))); + uint128_t x6 = ((uint64_t)(x5 >> 51) + (((uint128_t)(x1[0]) * (x2[2])) + (((uint128_t)(x1[1]) * (x2[1])) + (((uint128_t)(x1[2]) * (x2[0])) + (((uint128_t)(x1[3]) * ((x2[4]) * 0x13)) + ((uint128_t)(x1[4]) * ((x2[3]) * 0x13))))))); + uint128_t x7 = ((uint64_t)(x6 >> 51) + (((uint128_t)(x1[0]) * (x2[3])) + (((uint128_t)(x1[1]) * (x2[2])) + (((uint128_t)(x1[2]) * (x2[1])) + (((uint128_t)(x1[3]) * (x2[0])) + ((uint128_t)(x1[4]) * ((x2[4]) * 0x13))))))); + uint128_t x8 = ((uint64_t)(x7 >> 51) + (((uint128_t)(x1[0]) * (x2[4])) + (((uint128_t)(x1[1]) * (x2[3])) + (((uint128_t)(x1[2]) * (x2[2])) + (((uint128_t)(x1[3]) * (x2[1])) + ((uint128_t)(x1[4]) * (x2[0]))))))); + uint64_t x9 = ((uint64_t)(x4 & 0x7ffffffffffffUL) + ((uint64_t)(x8 >> 51) * 0x13)); + uint64_t x10 = ((x9 >> 51) + (uint64_t)(x5 & 0x7ffffffffffffUL)); + x3[0] = (x9 & 0x7ffffffffffffUL); + x3[1] = (x10 & 0x7ffffffffffffUL); + x3[2] = ((x10 >> 51) + (uint64_t)(x6 & 0x7ffffffffffffUL)); + x3[3] = (uint64_t)(x7 & 0x7ffffffffffffUL); + x3[4] = (uint64_t)(x8 & 0x7ffffffffffffUL); +} +*) + Compute Compilers.ToString.C.ToFunctionString + "fesub" base_51_sub + None (Some tight_bounds, (Some tight_bounds, tt)). +(* +void fesub(uint64_t[5] x1, uint64_t[5] x2, uint64_t[5] x3) { + x3[0] = ((0xfffffffffffdaUL + (x1[0])) - (x2[0])); + x3[1] = ((0xffffffffffffeUL + (x1[1])) - (x2[1])); + x3[2] = ((0xffffffffffffeUL + (x1[2])) - (x2[2])); + x3[3] = ((0xffffffffffffeUL + (x1[3])) - (x2[3])); + x3[4] = ((0xffffffffffffeUL + (x1[4])) - (x2[4])); +} +*) +End X25519_64. + +Module X25519_32. + Definition n := 10%nat. + Definition s := 2^255. + Definition c := [(1, 19)]. + Definition machine_wordsize := 32. + + Derive base_25p5_relax + SuchThat (rrelax_correctT n s c machine_wordsize base_25p5_relax) + As base_25p5_relax_correct. + Proof. Time solve_rrelax machine_wordsize. Time Qed. + Derive base_25p5_carry_mul + SuchThat (rcarry_mul_correctT n s c machine_wordsize base_25p5_carry_mul) + As base_25p5_carry_mul_correct. + Proof. Time solve_rcarry_mul machine_wordsize. Time Qed. + Derive base_25p5_carry + SuchThat (rcarry_correctT n s c machine_wordsize base_25p5_carry) + As base_25p5_carry_correct. + Proof. Time solve_rcarry machine_wordsize. Time Qed. + Derive base_25p5_add + SuchThat (radd_correctT n s c machine_wordsize base_25p5_add) + As base_25p5_add_correct. + Proof. Time solve_radd machine_wordsize. Time Qed. + Derive base_25p5_sub + SuchThat (rsub_correctT n s c machine_wordsize base_25p5_sub) + As base_25p5_sub_correct. + Proof. Time solve_rsub machine_wordsize. Time Qed. + Derive base_25p5_opp + SuchThat (ropp_correctT n s c machine_wordsize base_25p5_opp) + As base_25p5_opp_correct. + Proof. Time solve_ropp machine_wordsize. Time Qed. + Derive base_25p5_encode + SuchThat (rencode_correctT n s c machine_wordsize base_25p5_encode) + As base_25p5_encode_correct. + Proof. Time solve_rencode machine_wordsize. Time Qed. + Derive base_25p5_zero + SuchThat (rzero_correctT n s c machine_wordsize base_25p5_zero) + As base_25p5_zero_correct. + Proof. Time solve_rzero machine_wordsize. Time Qed. + Derive base_25p5_one + SuchThat (rone_correctT n s c machine_wordsize base_25p5_one) + As base_25p5_one_correct. + Proof. Time solve_rone machine_wordsize. Time Qed. + Lemma base_25p5_curve_good + : check_args n s c machine_wordsize (ErrorT.Success tt) = ErrorT.Success tt. + Proof. vm_compute; reflexivity. Qed. + + Definition base_25p5_good : GoodT n s c + := Good n s c machine_wordsize + base_25p5_curve_good + base_25p5_carry_mul_correct + base_25p5_carry_correct + base_25p5_relax_correct + base_25p5_add_correct + base_25p5_sub_correct + base_25p5_opp_correct + base_25p5_zero_correct + base_25p5_one_correct + base_25p5_encode_correct. + + Print Assumptions base_25p5_good. + Import PrintingNotations. + Set Printing Width 80. + Print base_25p5_carry_mul. +(* +base_25p5_carry_mul = +fun var : type -> Type => +(λ x x0 : var (type.base (base.type.list (base.type.type_base base.type.Z))), + expr_let x1 := (uint32)(x[[0]]) *₆₄ (uint32)(x0[[0]]) +₆₄ + ((uint64)((uint32)(x[[1]]) *₆₄ ((uint32)(x0[[9]]) *₃₂ 19) << 1) +₆₄ + ((uint32)(x[[2]]) *₆₄ ((uint32)(x0[[8]]) *₃₂ 19) +₆₄ + ((uint64)((uint32)(x[[3]]) *₆₄ ((uint32)(x0[[7]]) *₃₂ 19) << 1) +₆₄ + ((uint32)(x[[4]]) *₆₄ ((uint32)(x0[[6]]) *₃₂ 19) +₆₄ + ((uint64)((uint32)(x[[5]]) *₆₄ ((uint32)(x0[[5]]) *₃₂ 19) << 1) +₆₄ + ((uint32)(x[[6]]) *₆₄ ((uint32)(x0[[4]]) *₃₂ 19) +₆₄ + ((uint64)((uint32)(x[[7]]) *₆₄ ((uint32)(x0[[3]]) *₃₂ 19) << 1) +₆₄ + ((uint32)(x[[8]]) *₆₄ ((uint32)(x0[[2]]) *₃₂ 19) +₆₄ + (uint64)((uint32)(x[[9]]) *₆₄ + ((uint32)(x0[[1]]) *₃₂ 19) << 1))))))))) in + expr_let x2 := (uint64)(x1 >> 26) +₆₄ + ((uint32)(x[[0]]) *₆₄ (uint32)(x0[[1]]) +₆₄ + ((uint32)(x[[1]]) *₆₄ (uint32)(x0[[0]]) +₆₄ + ((uint32)(x[[2]]) *₆₄ ((uint32)(x0[[9]]) *₃₂ 19) +₆₄ + ((uint32)(x[[3]]) *₆₄ ((uint32)(x0[[8]]) *₃₂ 19) +₆₄ + ((uint32)(x[[4]]) *₆₄ ((uint32)(x0[[7]]) *₃₂ 19) +₆₄ + ((uint32)(x[[5]]) *₆₄ ((uint32)(x0[[6]]) *₃₂ 19) +₆₄ + ((uint32)(x[[6]]) *₆₄ ((uint32)(x0[[5]]) *₃₂ 19) +₆₄ + ((uint32)(x[[7]]) *₆₄ ((uint32)(x0[[4]]) *₃₂ 19) +₆₄ + ((uint32)(x[[8]]) *₆₄ ((uint32)(x0[[3]]) *₃₂ 19) +₆₄ + (uint32)(x[[9]]) *₆₄ ((uint32)(x0[[2]]) *₃₂ 19)))))))))) in + expr_let x3 := (uint64)(x2 >> 25) +₆₄ + ((uint32)(x[[0]]) *₆₄ (uint32)(x0[[2]]) +₆₄ + ((uint64)((uint32)(x[[1]]) *₆₄ (uint32)(x0[[1]]) << 1) +₆₄ + ((uint32)(x[[2]]) *₆₄ (uint32)(x0[[0]]) +₆₄ + ((uint64)((uint32)(x[[3]]) *₆₄ ((uint32)(x0[[9]]) *₃₂ 19) << 1) +₆₄ + ((uint32)(x[[4]]) *₆₄ ((uint32)(x0[[8]]) *₃₂ 19) +₆₄ + ((uint64)((uint32)(x[[5]]) *₆₄ ((uint32)(x0[[7]]) *₃₂ 19) << 1) +₆₄ + ((uint32)(x[[6]]) *₆₄ ((uint32)(x0[[6]]) *₃₂ 19) +₆₄ + ((uint64)((uint32)(x[[7]]) *₆₄ + ((uint32)(x0[[5]]) *₃₂ 19) << 1) +₆₄ + ((uint32)(x[[8]]) *₆₄ ((uint32)(x0[[4]]) *₃₂ 19) +₆₄ + (uint64)((uint32)(x[[9]]) *₆₄ + ((uint32)(x0[[3]]) *₃₂ 19) << 1)))))))))) in + expr_let x4 := (uint64)(x3 >> 26) +₆₄ + ((uint32)(x[[0]]) *₆₄ (uint32)(x0[[3]]) +₆₄ + ((uint32)(x[[1]]) *₆₄ (uint32)(x0[[2]]) +₆₄ + ((uint32)(x[[2]]) *₆₄ (uint32)(x0[[1]]) +₆₄ + ((uint32)(x[[3]]) *₆₄ (uint32)(x0[[0]]) +₆₄ + ((uint32)(x[[4]]) *₆₄ ((uint32)(x0[[9]]) *₃₂ 19) +₆₄ + ((uint32)(x[[5]]) *₆₄ ((uint32)(x0[[8]]) *₃₂ 19) +₆₄ + ((uint32)(x[[6]]) *₆₄ ((uint32)(x0[[7]]) *₃₂ 19) +₆₄ + ((uint32)(x[[7]]) *₆₄ ((uint32)(x0[[6]]) *₃₂ 19) +₆₄ + ((uint32)(x[[8]]) *₆₄ ((uint32)(x0[[5]]) *₃₂ 19) +₆₄ + (uint32)(x[[9]]) *₆₄ ((uint32)(x0[[4]]) *₃₂ 19)))))))))) in + expr_let x5 := (uint64)(x4 >> 25) +₆₄ + ((uint32)(x[[0]]) *₆₄ (uint32)(x0[[4]]) +₆₄ + ((uint64)((uint32)(x[[1]]) *₆₄ (uint32)(x0[[3]]) << 1) +₆₄ + ((uint32)(x[[2]]) *₆₄ (uint32)(x0[[2]]) +₆₄ + ((uint64)((uint32)(x[[3]]) *₆₄ (uint32)(x0[[1]]) << 1) +₆₄ + ((uint32)(x[[4]]) *₆₄ (uint32)(x0[[0]]) +₆₄ + ((uint64)((uint32)(x[[5]]) *₆₄ ((uint32)(x0[[9]]) *₃₂ 19) << 1) +₆₄ + ((uint32)(x[[6]]) *₆₄ ((uint32)(x0[[8]]) *₃₂ 19) +₆₄ + ((uint64)((uint32)(x[[7]]) *₆₄ + ((uint32)(x0[[7]]) *₃₂ 19) << 1) +₆₄ + ((uint32)(x[[8]]) *₆₄ ((uint32)(x0[[6]]) *₃₂ 19) +₆₄ + (uint64)((uint32)(x[[9]]) *₆₄ + ((uint32)(x0[[5]]) *₃₂ 19) << 1)))))))))) in + expr_let x6 := (uint64)(x5 >> 26) +₆₄ + ((uint32)(x[[0]]) *₆₄ (uint32)(x0[[5]]) +₆₄ + ((uint32)(x[[1]]) *₆₄ (uint32)(x0[[4]]) +₆₄ + ((uint32)(x[[2]]) *₆₄ (uint32)(x0[[3]]) +₆₄ + ((uint32)(x[[3]]) *₆₄ (uint32)(x0[[2]]) +₆₄ + ((uint32)(x[[4]]) *₆₄ (uint32)(x0[[1]]) +₆₄ + ((uint32)(x[[5]]) *₆₄ (uint32)(x0[[0]]) +₆₄ + ((uint32)(x[[6]]) *₆₄ ((uint32)(x0[[9]]) *₃₂ 19) +₆₄ + ((uint32)(x[[7]]) *₆₄ ((uint32)(x0[[8]]) *₃₂ 19) +₆₄ + ((uint32)(x[[8]]) *₆₄ ((uint32)(x0[[7]]) *₃₂ 19) +₆₄ + (uint32)(x[[9]]) *₆₄ ((uint32)(x0[[6]]) *₃₂ 19)))))))))) in + expr_let x7 := (uint64)(x6 >> 25) +₆₄ + ((uint32)(x[[0]]) *₆₄ (uint32)(x0[[6]]) +₆₄ + ((uint64)((uint32)(x[[1]]) *₆₄ (uint32)(x0[[5]]) << 1) +₆₄ + ((uint32)(x[[2]]) *₆₄ (uint32)(x0[[4]]) +₆₄ + ((uint64)((uint32)(x[[3]]) *₆₄ (uint32)(x0[[3]]) << 1) +₆₄ + ((uint32)(x[[4]]) *₆₄ (uint32)(x0[[2]]) +₆₄ + ((uint64)((uint32)(x[[5]]) *₆₄ (uint32)(x0[[1]]) << 1) +₆₄ + ((uint32)(x[[6]]) *₆₄ (uint32)(x0[[0]]) +₆₄ + ((uint64)((uint32)(x[[7]]) *₆₄ + ((uint32)(x0[[9]]) *₃₂ 19) << 1) +₆₄ + ((uint32)(x[[8]]) *₆₄ ((uint32)(x0[[8]]) *₃₂ 19) +₆₄ + (uint64)((uint32)(x[[9]]) *₆₄ + ((uint32)(x0[[7]]) *₃₂ 19) << 1)))))))))) in + expr_let x8 := (uint64)(x7 >> 26) +₆₄ + ((uint32)(x[[0]]) *₆₄ (uint32)(x0[[7]]) +₆₄ + ((uint32)(x[[1]]) *₆₄ (uint32)(x0[[6]]) +₆₄ + ((uint32)(x[[2]]) *₆₄ (uint32)(x0[[5]]) +₆₄ + ((uint32)(x[[3]]) *₆₄ (uint32)(x0[[4]]) +₆₄ + ((uint32)(x[[4]]) *₆₄ (uint32)(x0[[3]]) +₆₄ + ((uint32)(x[[5]]) *₆₄ (uint32)(x0[[2]]) +₆₄ + ((uint32)(x[[6]]) *₆₄ (uint32)(x0[[1]]) +₆₄ + ((uint32)(x[[7]]) *₆₄ (uint32)(x0[[0]]) +₆₄ + ((uint32)(x[[8]]) *₆₄ ((uint32)(x0[[9]]) *₃₂ 19) +₆₄ + (uint32)(x[[9]]) *₆₄ ((uint32)(x0[[8]]) *₃₂ 19)))))))))) in + expr_let x9 := (uint64)(x8 >> 25) +₆₄ + ((uint32)(x[[0]]) *₆₄ (uint32)(x0[[8]]) +₆₄ + ((uint64)((uint32)(x[[1]]) *₆₄ (uint32)(x0[[7]]) << 1) +₆₄ + ((uint32)(x[[2]]) *₆₄ (uint32)(x0[[6]]) +₆₄ + ((uint64)((uint32)(x[[3]]) *₆₄ (uint32)(x0[[5]]) << 1) +₆₄ + ((uint32)(x[[4]]) *₆₄ (uint32)(x0[[4]]) +₆₄ + ((uint64)((uint32)(x[[5]]) *₆₄ (uint32)(x0[[3]]) << 1) +₆₄ + ((uint32)(x[[6]]) *₆₄ (uint32)(x0[[2]]) +₆₄ + ((uint64)((uint32)(x[[7]]) *₆₄ (uint32)(x0[[1]]) << 1) +₆₄ + ((uint32)(x[[8]]) *₆₄ (uint32)(x0[[0]]) +₆₄ + (uint64)((uint32)(x[[9]]) *₆₄ + ((uint32)(x0[[9]]) *₃₂ 19) << 1)))))))))) in + expr_let x10 := (uint64)(x9 >> 26) +₆₄ + ((uint32)(x[[0]]) *₆₄ (uint32)(x0[[9]]) +₆₄ + ((uint32)(x[[1]]) *₆₄ (uint32)(x0[[8]]) +₆₄ + ((uint32)(x[[2]]) *₆₄ (uint32)(x0[[7]]) +₆₄ + ((uint32)(x[[3]]) *₆₄ (uint32)(x0[[6]]) +₆₄ + ((uint32)(x[[4]]) *₆₄ (uint32)(x0[[5]]) +₆₄ + ((uint32)(x[[5]]) *₆₄ (uint32)(x0[[4]]) +₆₄ + ((uint32)(x[[6]]) *₆₄ (uint32)(x0[[3]]) +₆₄ + ((uint32)(x[[7]]) *₆₄ (uint32)(x0[[2]]) +₆₄ + ((uint32)(x[[8]]) *₆₄ (uint32)(x0[[1]]) +₆₄ + (uint32)(x[[9]]) *₆₄ (uint32)(x0[[0]])))))))))) in + expr_let x11 := ((uint32)(x1) & 67108863) +₆₄ (uint64)(x10 >> 25) *₆₄ 19 in + expr_let x12 := (uint32)(x11 >> 26) +₃₂ ((uint32)(x2) & 33554431) in + expr_let x13 := ((uint32)(x11) & 67108863) in + expr_let x14 := ((uint32)(x12) & 33554431) in + expr_let x15 := (uint32)(x12 >> 25) +₃₂ ((uint32)(x3) & 67108863) in + expr_let x16 := ((uint32)(x4) & 33554431) in + expr_let x17 := ((uint32)(x5) & 67108863) in + expr_let x18 := ((uint32)(x6) & 33554431) in + expr_let x19 := ((uint32)(x7) & 67108863) in + expr_let x20 := ((uint32)(x8) & 33554431) in + expr_let x21 := ((uint32)(x9) & 67108863) in + expr_let x22 := ((uint32)(x10) & 33554431) in + [x13; x14; x15; x16; x17; x18; x19; x20; x21; x22])%expr + : Expr + (type.base (base.type.list (base.type.type_base base.type.Z)) -> + type.base (base.type.list (base.type.type_base base.type.Z)) -> + type.base (base.type.list (base.type.type_base base.type.Z)))%ptype + *) + Print base_25p5_sub. + (* +base_25p5_sub = +fun var : type -> Type => +(λ x x0 : var (type.base (base.type.list (base.type.type_base base.type.Z))), + expr_let x1 := (134217690 +₃₂ (uint32)(x[[0]])) -₃₂ (uint32)(x0[[0]]) in + expr_let x2 := (67108862 +₃₂ (uint32)(x[[1]])) -₃₂ (uint32)(x0[[1]]) in + expr_let x3 := (134217726 +₃₂ (uint32)(x[[2]])) -₃₂ (uint32)(x0[[2]]) in + expr_let x4 := (67108862 +₃₂ (uint32)(x[[3]])) -₃₂ (uint32)(x0[[3]]) in + expr_let x5 := (134217726 +₃₂ (uint32)(x[[4]])) -₃₂ (uint32)(x0[[4]]) in + expr_let x6 := (67108862 +₃₂ (uint32)(x[[5]])) -₃₂ (uint32)(x0[[5]]) in + expr_let x7 := (134217726 +₃₂ (uint32)(x[[6]])) -₃₂ (uint32)(x0[[6]]) in + expr_let x8 := (67108862 +₃₂ (uint32)(x[[7]])) -₃₂ (uint32)(x0[[7]]) in + expr_let x9 := (134217726 +₃₂ (uint32)(x[[8]])) -₃₂ (uint32)(x0[[8]]) in + expr_let x10 := (67108862 +₃₂ (uint32)(x[[9]])) -₃₂ (uint32)(x0[[9]]) in + [x1; x2; x3; x4; x5; x6; x7; x8; x9; x10])%expr + : Expr + (type.base (base.type.list (base.type.type_base base.type.Z)) -> + type.base (base.type.list (base.type.type_base base.type.Z)) -> + type.base (base.type.list (base.type.type_base base.type.Z)))%ptype +*) +End X25519_32. + +Import Language.Compilers. + +Module P192_64. + Definition s := 2^192. + Definition c := [(2^64, 1); (1,1)]. + Definition machine_wordsize := 64. + + Derive mulmod + SuchThat (SaturatedSolinas.rmulmod_correctT s c machine_wordsize mulmod) + As mulmod_correct. + Proof. Time solve_rmulmod machine_wordsize. Time Qed. + + Import PrintingNotations. + Open Scope expr_scope. + Set Printing Width 100000. + Set Printing Depth 100000. + + Local Notation "'mul64' '(' x ',' y ')'" := + (#(Z_cast2 (uint64, _)%core) @ (#(Z_mul_split_concrete 18446744073709551616) @ x @ y))%expr (at level 50) : expr_scope. + Local Notation "'add64' '(' x ',' y ')'" := + (#(Z_cast2 (uint64, bool)%core) @ (#(Z_add_get_carry_concrete 18446744073709551616) @ x @ y))%expr (at level 50) : expr_scope. + Local Notation "'adc64' '(' c ',' x ',' y ')'" := + (#(Z_cast2 (uint64, bool)%core) @ (#(Z_add_with_get_carry_concrete 18446744073709551616) @ c @ x @ y))%expr (at level 50) : expr_scope. + Local Notation "'adx64' '(' c ',' x ',' y ')'" := + (#(Z_cast bool) @ (#Z_add_with_carry @ c @ x @ y))%expr (at level 50) : expr_scope. + + Print mulmod. +(* +mulmod = fun var : type -> Type => λ x x0 : var (type.base (base.type.list (base.type.type_base base.type.Z))), + expr_let x1 := mul64 ((uint64)(x[[2]]), (uint64)(x0[[2]])) in + expr_let x2 := mul64 ((uint64)(x[[2]]), (uint64)(x0[[1]])) in + expr_let x3 := mul64 ((uint64)(x[[2]]), (uint64)(x0[[0]])) in + expr_let x4 := mul64 ((uint64)(x[[1]]), (uint64)(x0[[2]])) in + expr_let x5 := mul64 ((uint64)(x[[1]]), (uint64)(x0[[1]])) in + expr_let x6 := mul64 ((uint64)(x[[1]]), (uint64)(x0[[0]])) in + expr_let x7 := mul64 ((uint64)(x[[0]]), (uint64)(x0[[2]])) in + expr_let x8 := mul64 ((uint64)(x[[0]]), (uint64)(x0[[1]])) in + expr_let x9 := mul64 ((uint64)(x[[0]]), (uint64)(x0[[0]])) in + expr_let x10 := add64 (x1₂, x9₂) in + expr_let x11 := adc64 (x10₂, 0, x8₂) in + expr_let x12 := add64 (x1₁, x10₁) in + expr_let x13 := adc64 (x12₂, 0, x11₁) in + expr_let x14 := add64 (x2₂, x12₁) in + expr_let x15 := adc64 (x14₂, 0, x13₁) in + expr_let x16 := add64 (x4₂, x14₁) in + expr_let x17 := adc64 (x16₂, x1₂, x15₁) in + expr_let x18 := add64 (x2₁, x16₁) in + expr_let x19 := adc64 (x18₂, x1₁, x17₁) in + expr_let x20 := add64 (x1₂, x9₁) in + expr_let x21 := adc64 (x20₂, x3₂, x18₁) in + expr_let x22 := adc64 (x21₂, x2₂, x19₁) in + expr_let x23 := add64 (x2₁, x20₁) in + expr_let x24 := adc64 (x23₂, x4₁, x21₁) in + expr_let x25 := adc64 (x24₂, x4₂, x22₁) in + expr_let x26 := add64 (x3₂, x23₁) in + expr_let x27 := adc64 (x26₂, x5₂, x24₁) in + expr_let x28 := adc64 (x27₂, x3₁, x25₁) in + expr_let x29 := add64 (x4₁, x26₁) in + expr_let x30 := adc64 (x29₂, x7₂, x27₁) in + expr_let x31 := adc64 (x30₂, x5₁, x28₁) in + expr_let x32 := add64 (x5₂, x29₁) in + expr_let x33 := adc64 (x32₂, x6₁, x30₁) in + expr_let x34 := adc64 (x33₂, x6₂, x31₁) in + expr_let x35 := add64 (x7₂, x32₁) in + expr_let x36 := adc64 (x35₂, x8₁, x33₁) in + expr_let x37 := adc64 (x36₂, x7₁, x34₁) in + [x35₁; x36₁; x37₁] + : Expr (type.base (base.type.list (base.type.type_base base.type.Z)) -> type.base (base.type.list (base.type.type_base base.type.Z)) -> type.base (base.type.list (base.type.type_base base.type.Z)))%ptype +*) + +End P192_64. + +Module P192_32. + Definition s := 2^192. + Definition c := [(2^64, 1); (1,1)]. + Definition machine_wordsize := 32. + + Derive mulmod + SuchThat (SaturatedSolinas.rmulmod_correctT s c machine_wordsize mulmod) + As mulmod_correct. + Proof. Time solve_rmulmod machine_wordsize. Time Qed. + + Import PrintingNotations. + Open Scope expr_scope. + Set Printing Width 100000. + Set Printing Depth 100000. + + Local Notation "'mul32' '(' x ',' y ')'" := + (#(Z_cast2 (uint32, _)%core) @ (#(Z_mul_split_concrete 4294967296) @ x @ y))%expr (at level 50) : expr_scope. + Local Notation "'add32' '(' x ',' y ')'" := + (#(Z_cast2 (uint32, bool)%core) @ (#(Z_add_get_carry_concrete 4294967296) @ x @ y))%expr (at level 50) : expr_scope. + Local Notation "'adc32' '(' c ',' x ',' y ')'" := + (#(Z_cast2 (uint32, bool)%core) @ (#(Z_add_with_get_carry_concrete 4294967296) @ c @ x @ y))%expr (at level 50) : expr_scope. + + Print mulmod. + (* +mulmod = fun var : type -> Type => λ x x0 : var (type.base (base.type.list (base.type.type_base base.type.Z))), + expr_let x1 := mul32 ((uint32)(x[[5]]), (uint32)(x0[[5]])) in + expr_let x2 := mul32 ((uint32)(x[[5]]), (uint32)(x0[[4]])) in + expr_let x3 := mul32 ((uint32)(x[[5]]), (uint32)(x0[[3]])) in + expr_let x4 := mul32 ((uint32)(x[[5]]), (uint32)(x0[[2]])) in + expr_let x5 := mul32 ((uint32)(x[[5]]), (uint32)(x0[[1]])) in + expr_let x6 := mul32 ((uint32)(x[[5]]), (uint32)(x0[[0]])) in + expr_let x7 := mul32 ((uint32)(x[[4]]), (uint32)(x0[[5]])) in + expr_let x8 := mul32 ((uint32)(x[[4]]), (uint32)(x0[[4]])) in + expr_let x9 := mul32 ((uint32)(x[[4]]), (uint32)(x0[[3]])) in + expr_let x10 := mul32 ((uint32)(x[[4]]), (uint32)(x0[[2]])) in + expr_let x11 := mul32 ((uint32)(x[[4]]), (uint32)(x0[[1]])) in + expr_let x12 := mul32 ((uint32)(x[[4]]), (uint32)(x0[[0]])) in + expr_let x13 := mul32 ((uint32)(x[[3]]), (uint32)(x0[[5]])) in + expr_let x14 := mul32 ((uint32)(x[[3]]), (uint32)(x0[[4]])) in + expr_let x15 := mul32 ((uint32)(x[[3]]), (uint32)(x0[[3]])) in + expr_let x16 := mul32 ((uint32)(x[[3]]), (uint32)(x0[[2]])) in + expr_let x17 := mul32 ((uint32)(x[[3]]), (uint32)(x0[[1]])) in + expr_let x18 := mul32 ((uint32)(x[[3]]), (uint32)(x0[[0]])) in + expr_let x19 := mul32 ((uint32)(x[[2]]), (uint32)(x0[[5]])) in + expr_let x20 := mul32 ((uint32)(x[[2]]), (uint32)(x0[[4]])) in + expr_let x21 := mul32 ((uint32)(x[[2]]), (uint32)(x0[[3]])) in + expr_let x22 := mul32 ((uint32)(x[[2]]), (uint32)(x0[[2]])) in + expr_let x23 := mul32 ((uint32)(x[[2]]), (uint32)(x0[[1]])) in + expr_let x24 := mul32 ((uint32)(x[[2]]), (uint32)(x0[[0]])) in + expr_let x25 := mul32 ((uint32)(x[[1]]), (uint32)(x0[[5]])) in + expr_let x26 := mul32 ((uint32)(x[[1]]), (uint32)(x0[[4]])) in + expr_let x27 := mul32 ((uint32)(x[[1]]), (uint32)(x0[[3]])) in + expr_let x28 := mul32 ((uint32)(x[[1]]), (uint32)(x0[[2]])) in + expr_let x29 := mul32 ((uint32)(x[[1]]), (uint32)(x0[[1]])) in + expr_let x30 := mul32 ((uint32)(x[[1]]), (uint32)(x0[[0]])) in + expr_let x31 := mul32 ((uint32)(x[[0]]), (uint32)(x0[[5]])) in + expr_let x32 := mul32 ((uint32)(x[[0]]), (uint32)(x0[[4]])) in + expr_let x33 := mul32 ((uint32)(x[[0]]), (uint32)(x0[[3]])) in + expr_let x34 := mul32 ((uint32)(x[[0]]), (uint32)(x0[[2]])) in + expr_let x35 := mul32 ((uint32)(x[[0]]), (uint32)(x0[[1]])) in + expr_let x36 := mul32 ((uint32)(x[[0]]), (uint32)(x0[[0]])) in + expr_let x37 := add32 (x1₁, x35₂) in + expr_let x38 := adc32 (x37₂, 0, x34₂) in + expr_let x39 := adc32 (x38₂, 0, x33₂) in + expr_let x40 := adc32 (x39₂, 0, x32₂) in + expr_let x41 := add32 (x2₂, x37₁) in + expr_let x42 := adc32 (x41₂, 0, x38₁) in + expr_let x43 := adc32 (x42₂, 0, x39₁) in + expr_let x44 := adc32 (x43₂, 0, x40₁) in + expr_let x45 := add32 (x7₂, x41₁) in + expr_let x46 := adc32 (x45₂, 0, x42₁) in + expr_let x47 := adc32 (x46₂, 0, x43₁) in + expr_let x48 := adc32 (x47₂, 0, x44₁) in + expr_let x49 := add32 (x3₁, x45₁) in + expr_let x50 := adc32 (x49₂, 0, x46₁) in + expr_let x51 := adc32 (x50₂, 0, x47₁) in + expr_let x52 := adc32 (x51₂, 0, x48₁) in + expr_let x53 := add32 (x4₂, x49₁) in + expr_let x54 := adc32 (x53₂, x1₂, x50₁) in + expr_let x55 := adc32 (x54₂, 0, x51₁) in + expr_let x56 := adc32 (x55₂, 0, x52₁) in + expr_let x57 := add32 (x8₁, x53₁) in + expr_let x58 := adc32 (x57₂, x2₁, x54₁) in + expr_let x59 := adc32 (x58₂, 0, x55₁) in + expr_let x60 := adc32 (x59₂, 0, x56₁) in + expr_let x61 := add32 (x9₂, x57₁) in + expr_let x62 := adc32 (x61₂, x3₂, x58₁) in + expr_let x63 := adc32 (x62₂, 0, x59₁) in + expr_let x64 := adc32 (x63₂, 0, x60₁) in + expr_let x65 := add32 (x13₁, x61₁) in + expr_let x66 := adc32 (x65₂, x7₁, x62₁) in + expr_let x67 := adc32 (x66₂, x1₁, x63₁) in + expr_let x68 := adc32 (x67₂, 0, x64₁) in + expr_let x69 := add32 (x14₂, x65₁) in + expr_let x70 := adc32 (x69₂, x8₂, x66₁) in + expr_let x71 := adc32 (x70₂, x2₂, x67₁) in + expr_let x72 := adc32 (x71₂, 0, x68₁) in + expr_let x73 := add32 (x19₂, x69₁) in + expr_let x74 := adc32 (x73₂, x13₂, x70₁) in + expr_let x75 := adc32 (x74₂, x7₂, x71₁) in + expr_let x76 := adc32 (x75₂, x1₂, x72₁) in + expr_let x77 := add32 (x5₁, x73₁) in + expr_let x78 := adc32 (x77₂, x4₁, x74₁) in + expr_let x79 := adc32 (x78₂, x3₁, x75₁) in + expr_let x80 := adc32 (x79₂, x2₁, x76₁) in + expr_let x81 := add32 (x1₁, x36₁) in + expr_let x82 := adc32 (x81₂, 0, x36₂) in + expr_let x83 := adc32 (x82₂, x6₂, x77₁) in + expr_let x84 := adc32 (x83₂, x5₂, x78₁) in + expr_let x85 := adc32 (x84₂, x4₂, x79₁) in + expr_let x86 := adc32 (x85₂, x3₂, x80₁) in + expr_let x87 := add32 (x2₂, x81₁) in + expr_let x88 := adc32 (x87₂, 0, x82₁) in + expr_let x89 := adc32 (x88₂, x10₁, x83₁) in + expr_let x90 := adc32 (x89₂, x9₁, x84₁) in + expr_let x91 := adc32 (x90₂, x8₁, x85₁) in + expr_let x92 := adc32 (x91₂, x7₁, x86₁) in + expr_let x93 := add32 (x7₂, x87₁) in + expr_let x94 := adc32 (x93₂, x1₂, x88₁) in + expr_let x95 := adc32 (x94₂, x11₂, x89₁) in + expr_let x96 := adc32 (x95₂, x10₂, x90₁) in + expr_let x97 := adc32 (x96₂, x9₂, x91₁) in + expr_let x98 := adc32 (x97₂, x8₂, x92₁) in + expr_let x99 := add32 (x5₁, x93₁) in + expr_let x100 := adc32 (x99₂, x4₁, x94₁) in + expr_let x101 := adc32 (x100₂, x15₁, x95₁) in + expr_let x102 := adc32 (x101₂, x14₁, x96₁) in + expr_let x103 := adc32 (x102₂, x13₁, x97₁) in + expr_let x104 := adc32 (x103₂, x13₂, x98₁) in + expr_let x105 := add32 (x6₂, x99₁) in + expr_let x106 := adc32 (x105₂, x5₂, x100₁) in + expr_let x107 := adc32 (x106₂, x16₂, x101₁) in + expr_let x108 := adc32 (x107₂, x15₂, x102₁) in + expr_let x109 := adc32 (x108₂, x14₂, x103₁) in + expr_let x110 := adc32 (x109₂, x6₁, x104₁) in + expr_let x111 := add32 (x10₁, x105₁) in + expr_let x112 := adc32 (x111₂, x9₁, x106₁) in + expr_let x113 := adc32 (x112₂, x20₁, x107₁) in + expr_let x114 := adc32 (x113₂, x19₁, x108₁) in + expr_let x115 := adc32 (x114₂, x19₂, x109₁) in + expr_let x116 := adc32 (x115₂, x11₁, x110₁) in + expr_let x117 := add32 (x11₂, x111₁) in + expr_let x118 := adc32 (x117₂, x10₂, x112₁) in + expr_let x119 := adc32 (x118₂, x21₂, x113₁) in + expr_let x120 := adc32 (x119₂, x20₂, x114₁) in + expr_let x121 := adc32 (x120₂, x12₁, x115₁) in + expr_let x122 := adc32 (x121₂, x12₂, x116₁) in + expr_let x123 := add32 (x15₁, x117₁) in + expr_let x124 := adc32 (x123₂, x14₁, x118₁) in + expr_let x125 := adc32 (x124₂, x25₁, x119₁) in + expr_let x126 := adc32 (x125₂, x25₂, x120₁) in + expr_let x127 := adc32 (x126₂, x17₁, x121₁) in + expr_let x128 := adc32 (x127₂, x16₁, x122₁) in + expr_let x129 := add32 (x16₂, x123₁) in + expr_let x130 := adc32 (x129₂, x15₂, x124₁) in + expr_let x131 := adc32 (x130₂, x26₂, x125₁) in + expr_let x132 := adc32 (x131₂, x18₁, x126₁) in + expr_let x133 := adc32 (x132₂, x18₂, x127₁) in + expr_let x134 := adc32 (x133₂, x17₂, x128₁) in + expr_let x135 := add32 (x20₁, x129₁) in + expr_let x136 := adc32 (x135₂, x19₁, x130₁) in + expr_let x137 := adc32 (x136₂, x31₂, x131₁) in + expr_let x138 := adc32 (x137₂, x23₁, x132₁) in + expr_let x139 := adc32 (x138₂, x22₁, x133₁) in + expr_let x140 := adc32 (x139₂, x21₁, x134₁) in + expr_let x141 := add32 (x21₂, x135₁) in + expr_let x142 := adc32 (x141₂, x20₂, x136₁) in + expr_let x143 := adc32 (x142₂, x24₁, x137₁) in + expr_let x144 := adc32 (x143₂, x24₂, x138₁) in + expr_let x145 := adc32 (x144₂, x23₂, x139₁) in + expr_let x146 := adc32 (x145₂, x22₂, x140₁) in + expr_let x147 := add32 (x25₁, x141₁) in + expr_let x148 := adc32 (x147₂, x25₂, x142₁) in + expr_let x149 := adc32 (x148₂, x29₁, x143₁) in + expr_let x150 := adc32 (x149₂, x28₁, x144₁) in + expr_let x151 := adc32 (x150₂, x27₁, x145₁) in + expr_let x152 := adc32 (x151₂, x26₁, x146₁) in + expr_let x153 := add32 (x26₂, x147₁) in + expr_let x154 := adc32 (x153₂, x30₁, x148₁) in + expr_let x155 := adc32 (x154₂, x30₂, x149₁) in + expr_let x156 := adc32 (x155₂, x29₂, x150₁) in + expr_let x157 := adc32 (x156₂, x28₂, x151₁) in + expr_let x158 := adc32 (x157₂, x27₂, x152₁) in + expr_let x159 := add32 (x31₂, x153₁) in + expr_let x160 := adc32 (x159₂, x35₁, x154₁) in + expr_let x161 := adc32 (x160₂, x34₁, x155₁) in + expr_let x162 := adc32 (x161₂, x33₁, x156₁) in + expr_let x163 := adc32 (x162₂, x32₁, x157₁) in + expr_let x164 := adc32 (x163₂, x31₁, x158₁) in + [x159₁; x160₁; x161₁; x162₁; x163₁; x164₁] + : Expr (type.base (base.type.list (base.type.type_base base.type.Z)) -> type.base (base.type.list (base.type.type_base base.type.Z)) -> type.base (base.type.list (base.type.type_base base.type.Z)))%ptype +*) + +End P192_32. + +Module P384_32. + Definition s := 2^384. + Definition c := [(2^128, 1); (2^96, 1); (2^32,-1); (1,1)]. + Definition machine_wordsize := 32. + Import PrintingNotations. + Open Scope expr_scope. + Set Printing Depth 100000. + + Derive mulmod + SuchThat (SaturatedSolinas.rmulmod_correctT s c machine_wordsize mulmod) + As mulmod_correct. + Proof. Time solve_rmulmod machine_wordsize. Time Qed. + + Import PrintingNotations. + Open Scope expr_scope. + Set Printing Width 100000. + Set Printing Depth 100000. + + Local Notation "'mul32' '(' x ',' y ')'" := + (#(Z_cast2 (uint32, _)%core) @ (#(Z_mul_split_concrete 4294967296) @ x @ y))%expr (at level 50) : expr_scope. + Local Notation "'add32' '(' x ',' y ')'" := + (#(Z_cast2 (uint32, bool)%core) @ (#(Z_add_get_carry_concrete 4294967296) @ x @ y))%expr (at level 50) : expr_scope. + Local Notation "'adc32' '(' c ',' x ',' y ')'" := + (#(Z_cast2 (uint32, bool)%core) @ (#(Z_add_with_get_carry_concrete 4294967296) @ c @ x @ y))%expr (at level 50) : expr_scope. + Local Notation "'sub32' '(' x ',' y ')'" := + (#(Z_cast2 (uint32, bool)%core) @ (#(Z_sub_get_borrow_concrete 4294967296) @ x @ y))%expr (at level 50) : expr_scope. + Local Notation "'sbb32' '(' c ',' x ',' y ')'" := + (#(Z_cast2 (uint32, bool)%core) @ (#(Z_sub_with_get_borrow_concrete 4294967296) @ c @ x @ y))%expr (at level 50) : expr_scope. + + Print mulmod. + + +End P384_32. + +(* TODO : Too slow! Many, many terms in this one. *) + +Module P256_32. + Definition s := 2^256. + Definition c := [(2^224, 1); (2^192, -1); (2^96, -1); (1,1)]. + Definition machine_wordsize := 32. + + Derive mulmod + SuchThat (SaturatedSolinas.rmulmod_correctT s c machine_wordsize mulmod) + As mulmod_correct. + Proof. Time solve_rmulmod machine_wordsize. Time Qed. + + Import PrintingNotations. + Open Scope expr_scope. + Set Printing Width 100000. + + Local Notation "'mul32' '(' x ',' y ')'" := + (#(Z_cast2 (uint32, _)%core) @ (#(Z_mul_split_concrete 4294967296) @ x @ y))%expr (at level 50) : expr_scope. + Local Notation "'add32' '(' x ',' y ')'" := + (#(Z_cast2 (uint32, bool)%core) @ (#(Z_add_get_carry_concrete 4294967296) @ x @ y))%expr (at level 50) : expr_scope. + Local Notation "'adc32' '(' c ',' x ',' y ')'" := + (#(Z_cast2 (uint32, bool)%core) @ (#(Z_add_with_get_carry_concrete 4294967296) @ c @ x @ y))%expr (at level 50) : expr_scope. + + (* Print is too slow *) + + Time Print mulmod. + + (* +mulmod = +fun var : type -> Type => +λ x x0 : var (type.base (base.type.list (base.type.type_base base.type.Z))), +expr_let x1 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[7]]) @ (uint32)(x0[[7]])))%expr_pat in +expr_let x2 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[7]]) @ (uint32)(x0[[6]])))%expr_pat in +expr_let x3 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[7]]) @ (uint32)(x0[[5]])))%expr_pat in +expr_let x4 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[7]]) @ (uint32)(x0[[4]])))%expr_pat in +expr_let x5 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[7]]) @ (uint32)(x0[[3]])))%expr_pat in +expr_let x6 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[7]]) @ (uint32)(x0[[2]])))%expr_pat in +expr_let x7 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[7]]) @ (uint32)(x0[[1]])))%expr_pat in +expr_let x8 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[7]]) @ (uint32)(x0[[0]])))%expr_pat in +expr_let x9 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[6]]) @ (uint32)(x0[[7]])))%expr_pat in +expr_let x10 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[6]]) @ (uint32)(x0[[6]])))%expr_pat in +expr_let x11 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[6]]) @ (uint32)(x0[[5]])))%expr_pat in +expr_let x12 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[6]]) @ (uint32)(x0[[4]])))%expr_pat in +expr_let x13 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[6]]) @ (uint32)(x0[[3]])))%expr_pat in +expr_let x14 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[6]]) @ (uint32)(x0[[2]])))%expr_pat in +expr_let x15 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[6]]) @ (uint32)(x0[[1]])))%expr_pat in +expr_let x16 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[6]]) @ (uint32)(x0[[0]])))%expr_pat in +expr_let x17 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[5]]) @ (uint32)(x0[[7]])))%expr_pat in +expr_let x18 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[5]]) @ (uint32)(x0[[6]])))%expr_pat in +expr_let x19 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[5]]) @ (uint32)(x0[[5]])))%expr_pat in +expr_let x20 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[5]]) @ (uint32)(x0[[4]])))%expr_pat in +expr_let x21 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[5]]) @ (uint32)(x0[[3]])))%expr_pat in +expr_let x22 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[5]]) @ (uint32)(x0[[2]])))%expr_pat in +expr_let x23 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[5]]) @ (uint32)(x0[[1]])))%expr_pat in +expr_let x24 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[5]]) @ (uint32)(x0[[0]])))%expr_pat in +expr_let x25 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[4]]) @ (uint32)(x0[[7]])))%expr_pat in +expr_let x26 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[4]]) @ (uint32)(x0[[6]])))%expr_pat in +expr_let x27 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[4]]) @ (uint32)(x0[[5]])))%expr_pat in +expr_let x28 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[4]]) @ (uint32)(x0[[4]])))%expr_pat in +expr_let x29 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[4]]) @ (uint32)(x0[[3]])))%expr_pat in +expr_let x30 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[4]]) @ (uint32)(x0[[2]])))%expr_pat in +expr_let x31 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[4]]) @ (uint32)(x0[[1]])))%expr_pat in +expr_let x32 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[4]]) @ (uint32)(x0[[0]])))%expr_pat in +expr_let x33 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[3]]) @ (uint32)(x0[[7]])))%expr_pat in +expr_let x34 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[3]]) @ (uint32)(x0[[6]])))%expr_pat in +expr_let x35 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[3]]) @ (uint32)(x0[[5]])))%expr_pat in +expr_let x36 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[3]]) @ (uint32)(x0[[4]])))%expr_pat in +expr_let x37 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[3]]) @ (uint32)(x0[[3]])))%expr_pat in +expr_let x38 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[3]]) @ (uint32)(x0[[2]])))%expr_pat in +expr_let x39 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[3]]) @ (uint32)(x0[[1]])))%expr_pat in +expr_let x40 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[3]]) @ (uint32)(x0[[0]])))%expr_pat in +expr_let x41 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[2]]) @ (uint32)(x0[[7]])))%expr_pat in +expr_let x42 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[2]]) @ (uint32)(x0[[6]])))%expr_pat in +expr_let x43 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[2]]) @ (uint32)(x0[[5]])))%expr_pat in +expr_let x44 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[2]]) @ (uint32)(x0[[4]])))%expr_pat in +expr_let x45 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[2]]) @ (uint32)(x0[[3]])))%expr_pat in +expr_let x46 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[2]]) @ (uint32)(x0[[2]])))%expr_pat in +expr_let x47 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[2]]) @ (uint32)(x0[[1]])))%expr_pat in +expr_let x48 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[2]]) @ (uint32)(x0[[0]])))%expr_pat in +expr_let x49 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[1]]) @ (uint32)(x0[[7]])))%expr_pat in +expr_let x50 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[1]]) @ (uint32)(x0[[6]])))%expr_pat in +expr_let x51 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[1]]) @ (uint32)(x0[[5]])))%expr_pat in +expr_let x52 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[1]]) @ (uint32)(x0[[4]])))%expr_pat in +expr_let x53 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[1]]) @ (uint32)(x0[[3]])))%expr_pat in +expr_let x54 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[1]]) @ (uint32)(x0[[2]])))%expr_pat in +expr_let x55 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[1]]) @ (uint32)(x0[[1]])))%expr_pat in +expr_let x56 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[1]]) @ (uint32)(x0[[0]])))%expr_pat in +expr_let x57 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[0]]) @ (uint32)(x0[[7]])))%expr_pat in +expr_let x58 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[0]]) @ (uint32)(x0[[6]])))%expr_pat in +expr_let x59 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[0]]) @ (uint32)(x0[[5]])))%expr_pat in +expr_let x60 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[0]]) @ (uint32)(x0[[4]])))%expr_pat in +expr_let x61 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[0]]) @ (uint32)(x0[[3]])))%expr_pat in +expr_let x62 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[0]]) @ (uint32)(x0[[2]])))%expr_pat in +expr_let x63 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[0]]) @ (uint32)(x0[[1]])))%expr_pat in +expr_let x64 := (#(Z_cast2 (uint32, uint32)%core)%expr @ (#(Z_mul_split_concrete 4294967296)%expr @ (uint32)(x[[0]]) @ (uint32)(x0[[0]])))%expr_pat in +expr_let x65 := (#(Z_cast r[-4294967294 ~> 0])%expr @ (- x1₂))%expr_pat in +expr_let x66 := (#(Z_cast r[-4294967294 ~> 0])%expr @ (- x1₂))%expr_pat in +expr_let x67 := (#(Z_cast r[-4294967294 ~> 0])%expr @ (- x1₂))%expr_pat in +expr_let x68 := (#(Z_cast r[-4294967294 ~> 0])%expr @ (- x1₂))%expr_pat in +expr_let x69 := (#(Z_cast r[-4294967294 ~> 0])%expr @ (- x1₂))%expr_pat in +expr_let x70 := (#(Z_cast r[-4294967294 ~> 0])%expr @ (- x1₂))%expr_pat in +expr_let x71 := (#(Z_cast r[-4294967294 ~> 0])%expr @ (- x1₂))%expr_pat in +[...] +expr_let x2983 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_get_carry_concrete 4294967296)%expr @ x35₁ @ x2975₁))%expr_pat in +expr_let x2984 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2983₂ @ x34₁ @ x2976₁))%expr_pat in +expr_let x2985 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2984₂ @ x33₁ @ x2977₁))%expr_pat in +expr_let x2986 := (#(Z_cast2 (uint32, r[-1 ~> 1])%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2985₂ @ x826 @ x2978₁))%expr_pat in +expr_let x2987 := (#(Z_cast2 (uint32, r[-1 ~> 1])%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2986₂ @ x39₁ @ x2979₁))%expr_pat in +expr_let x2988 := (#(Z_cast2 (uint32, r[-1 ~> 1])%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2987₂ @ x38₁ @ x2980₁))%expr_pat in +expr_let x2989 := (#(Z_cast2 (uint32, r[-1 ~> 1])%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2988₂ @ x37₁ @ x2981₁))%expr_pat in +expr_let x2990 := (#(Z_cast2 (uint32, r[-1 ~> 1])%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2989₂ @ x36₁ @ x2982₁))%expr_pat in +expr_let x2991 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_get_carry_concrete 4294967296)%expr @ x36₂ @ x2983₁))%expr_pat in +expr_let x2992 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2991₂ @ x35₂ @ x2984₁))%expr_pat in +expr_let x2993 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2992₂ @ x34₂ @ x2985₁))%expr_pat in +expr_let x2994 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2993₂ @ x40₁ @ x2986₁))%expr_pat in +expr_let x2995 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2994₂ @ x40₂ @ x2987₁))%expr_pat in +expr_let x2996 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2995₂ @ x39₂ @ x2988₁))%expr_pat in +expr_let x2997 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2996₂ @ x38₂ @ x2989₁))%expr_pat in +expr_let x2998 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2997₂ @ x37₂ @ x2990₁))%expr_pat in +expr_let x2999 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_get_carry_concrete 4294967296)%expr @ x42₁ @ x2991₁))%expr_pat in +expr_let x3000 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x2999₂ @ x41₁ @ x2992₁))%expr_pat in +expr_let x3001 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3000₂ @ x41₂ @ x2993₁))%expr_pat in +expr_let x3002 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3001₂ @ x47₁ @ x2994₁))%expr_pat in +expr_let x3003 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3002₂ @ x46₁ @ x2995₁))%expr_pat in +expr_let x3004 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3003₂ @ x45₁ @ x2996₁))%expr_pat in +expr_let x3005 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3004₂ @ x44₁ @ x2997₁))%expr_pat in +expr_let x3006 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3005₂ @ x43₁ @ x2998₁))%expr_pat in +expr_let x3007 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_get_carry_concrete 4294967296)%expr @ x43₂ @ x2999₁))%expr_pat in +expr_let x3008 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3007₂ @ x42₂ @ x3000₁))%expr_pat in +expr_let x3009 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3008₂ @ x48₁ @ x3001₁))%expr_pat in +expr_let x3010 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3009₂ @ x48₂ @ x3002₁))%expr_pat in +expr_let x3011 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3010₂ @ x47₂ @ x3003₁))%expr_pat in +expr_let x3012 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3011₂ @ x46₂ @ x3004₁))%expr_pat in +expr_let x3013 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3012₂ @ x45₂ @ x3005₁))%expr_pat in +expr_let x3014 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3013₂ @ x44₂ @ x3006₁))%expr_pat in +expr_let x3015 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_get_carry_concrete 4294967296)%expr @ x49₁ @ x3007₁))%expr_pat in +expr_let x3016 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3015₂ @ x49₂ @ x3008₁))%expr_pat in +expr_let x3017 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3016₂ @ x55₁ @ x3009₁))%expr_pat in +expr_let x3018 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3017₂ @ x54₁ @ x3010₁))%expr_pat in +expr_let x3019 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3018₂ @ x53₁ @ x3011₁))%expr_pat in +expr_let x3020 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3019₂ @ x52₁ @ x3012₁))%expr_pat in +expr_let x3021 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3020₂ @ x51₁ @ x3013₁))%expr_pat in +expr_let x3022 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3021₂ @ x50₁ @ x3014₁))%expr_pat in +expr_let x3023 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_get_carry_concrete 4294967296)%expr @ x50₂ @ x3015₁))%expr_pat in +expr_let x3024 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3023₂ @ x56₁ @ x3016₁))%expr_pat in +expr_let x3025 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3024₂ @ x56₂ @ x3017₁))%expr_pat in +expr_let x3026 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3025₂ @ x55₂ @ x3018₁))%expr_pat in +expr_let x3027 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3026₂ @ x54₂ @ x3019₁))%expr_pat in +expr_let x3028 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3027₂ @ x53₂ @ x3020₁))%expr_pat in +expr_let x3029 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3028₂ @ x52₂ @ x3021₁))%expr_pat in +expr_let x3030 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3029₂ @ x51₂ @ x3022₁))%expr_pat in +expr_let x3031 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_get_carry_concrete 4294967296)%expr @ x57₂ @ x3023₁))%expr_pat in +expr_let x3032 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3031₂ @ x63₁ @ x3024₁))%expr_pat in +expr_let x3033 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3032₂ @ x62₁ @ x3025₁))%expr_pat in +expr_let x3034 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3033₂ @ x61₁ @ x3026₁))%expr_pat in +expr_let x3035 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3034₂ @ x60₁ @ x3027₁))%expr_pat in +expr_let x3036 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3035₂ @ x59₁ @ x3028₁))%expr_pat in +expr_let x3037 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3036₂ @ x58₁ @ x3029₁))%expr_pat in +expr_let x3038 := (#(Z_cast2 (uint32, bool)%core)%expr @ (#(Z_add_with_get_carry_concrete 4294967296)%expr @ x3037₂ @ x57₁ @ x3030₁))%expr_pat in +[x3031₁; x3032₁; x3033₁; x3034₁; x3035₁; x3036₁; x3037₁; x3038₁] + : Expr (type.base (base.type.list (base.type.type_base base.type.Z)) -> type.base (base.type.list (base.type.type_base base.type.Z)) -> type.base (base.type.list (base.type.type_base base.type.Z)))%ptype +Finished transaction in 211.393 secs (210.924u,0.028s) (successful) +*) +End P256_32. diff --git a/src/Experiments/NewPipeline/StandaloneHaskellMain.v b/src/Experiments/NewPipeline/StandaloneHaskellMain.v new file mode 100644 index 000000000..5333f7c92 --- /dev/null +++ b/src/Experiments/NewPipeline/StandaloneHaskellMain.v @@ -0,0 +1,62 @@ +Require Export Coq.extraction.Extraction. +Require Export Coq.extraction.ExtrHaskellBasic. +Require Export Coq.extraction.ExtrHaskellString. +Require Import Coq.Lists.List. +Require Import Coq.Strings.String. +Require Crypto.Util.Strings.String. +Require Import Crypto.Util.Strings.Decimal. +Require Import Crypto.Util.Strings.HexString. +Require Import Crypto.Experiments.NewPipeline.Toplevel1. +Require Import Crypto.Experiments.NewPipeline.CLI. +Require Import Crypto.Util.Notations. +Import ListNotations. Local Open Scope string_scope. + +Global Set Warnings Append "-extraction-opaque-accessed". +Extraction Language Haskell. +Global Unset Extraction Optimize. + +Axiom IO_unit : Set. +Axiom _IO : Set -> Set. +Axiom printf_string : string -> _IO unit. +Axiom getArgs : _IO (list string). +Axiom getProgName : _IO string. +Axiom raise_failure : forall A, string -> A. +Axiom _IO_bind : forall A B, _IO A -> (A -> _IO B) -> _IO B. +Axiom _IO_return : forall A : Set, A -> _IO A. +Axiom cast_io : _IO unit -> IO_unit. +Extract Constant printf_string => +"\s -> Text.Printf.printf ""%s"" s". +Extract Constant _IO "a" => "GHC.Base.IO a". +Extract Inlined Constant getArgs => "System.Environment.getArgs". +Extract Inlined Constant getProgName => "System.Environment.getProgName". +Extract Constant raise_failure => "\x -> Prelude.error x". +Extract Inlined Constant _IO_bind => "(Prelude.>>=)". +Extract Inlined Constant _IO_return => "return". +Extract Inlined Constant IO_unit => "GHC.Base.IO ()". +Extract Inlined Constant cast_io => "". + +Local Notation "x <- y ; f" := (_IO_bind _ _ y (fun x => f)). + +Module UnsaturatedSolinas. + Definition main : IO_unit + := cast_io + (argv <- getArgs; + prog <- getProgName; + ForExtraction.UnsaturatedSolinas.PipelineMain + (prog::argv) + (fun res => printf_string + (String.concat "" res)) + (fun err => raise_failure _ err)). +End UnsaturatedSolinas. + +Module SaturatedSolinas. + Definition main : IO_unit + := cast_io + (argv <- getArgs; + prog <- getProgName; + ForExtraction.SaturatedSolinas.PipelineMain + (prog::argv) + (fun res => printf_string + (String.concat "" res)) + (fun err => raise_failure _ err)). +End SaturatedSolinas. diff --git a/src/Experiments/NewPipeline/StandaloneOCamlMain.v b/src/Experiments/NewPipeline/StandaloneOCamlMain.v new file mode 100644 index 000000000..c9336ad50 --- /dev/null +++ b/src/Experiments/NewPipeline/StandaloneOCamlMain.v @@ -0,0 +1,102 @@ +Require Export Coq.extraction.Extraction. +Require Export Coq.extraction.ExtrOcamlBasic. +Require Export Coq.extraction.ExtrOcamlString. +Require Import Coq.Lists.List. +Require Import Coq.Strings.Ascii. +Require Import Coq.Strings.String. +Require Crypto.Util.Strings.String. +Require Import Crypto.Util.Strings.Decimal. +Require Import Crypto.Util.Strings.HexString. +Require Import Crypto.Experiments.NewPipeline.Toplevel1. +Require Import Crypto.Experiments.NewPipeline.CLI. +Require Import Crypto.Util.Notations. +Import ListNotations. Local Open Scope string_scope. + +Global Set Warnings Append "-extraction-opaque-accessed". +Extraction Language Ocaml. +Global Unset Extraction Optimize. + +Inductive int : Set := int_O | int_S (x : int). + +Axiom printf_char : Ascii.ascii -> unit. +Axiom flush : unit -> unit. +Axiom string : Set. +Axiom string_length : string -> int. +Axiom string_get : string -> int -> Ascii.ascii. +Axiom sys_argv : list string. +Axiom string_init : int -> (int -> Ascii.ascii) -> string. +Axiom raise_failure : forall A, string -> A. + +Extract Inductive int +=> int [ "0" "Pervasives.succ" ] + "(fun fO fS n -> if n=0 then fO () else fS (n-1))". +Extract Constant printf_char => +"fun c -> Printf.printf ""%c%!"" c". +Extract Constant flush => +"fun () -> Printf.printf ""%!""". +Extract Inlined Constant string => "string". +Extract Inlined Constant string_length => "String.length". +Extract Inlined Constant string_get => "String.get". +Extract Constant sys_argv => "Array.to_list Sys.argv". +Extract Inlined Constant string_init => "String.init". +Extract Constant raise_failure => "fun x -> Printf.printf ""%s\n\n%!"" x; raise (Failure x)". + +Fixpoint nat_of_int (x : int) : nat + := match x with + | int_O => O + | int_S x' => S (nat_of_int x') + end. +Fixpoint int_of_nat (x : nat) : int + := match x with + | O => int_O + | S x' => int_S (int_of_nat x') + end. +Coercion nat_of_int : int >-> nat. +Coercion int_of_nat : nat >-> int. + +Definition string_of_Coq_string (s : String.string) : string + := let s := String.to_list s in + string_init + (List.length s) + (fun n => List.nth n s "?"%char). + +Definition string_to_Coq_string (s : string) : String.string + := String.of_list + (List.map (fun n:nat => string_get s n) (List.seq 0 (string_length s))). + +Definition seq {A B} (x : unit -> A) (f : A -> B) : B := let y := x tt in f y. +Extraction NoInline seq. +(* +Axiom seq : forall A B, (unit -> A) -> (A -> B) -> B. +Extract Inlined Constant seq => "(fun x f => let y = x () in f y)". +*) + +Fixpoint list_iter {A} (f : A -> unit) (ls : list A) : unit + := match ls with + | cons x xs => seq (fun _ => f x) (fun _ => @list_iter A f xs) + | nil => tt + end. + +Module UnsaturatedSolinas. + Definition main : unit + := let argv := List.map string_to_Coq_string sys_argv in + ForExtraction.UnsaturatedSolinas.PipelineMain + argv + (fun res => list_iter + (fun ls + => list_iter printf_char (String.to_list ls)) + res) + (fun err => raise_failure _ (string_of_Coq_string err)). +End UnsaturatedSolinas. + +Module SaturatedSolinas. + Definition main : unit + := let argv := List.map string_to_Coq_string sys_argv in + ForExtraction.SaturatedSolinas.PipelineMain + argv + (fun res => list_iter + (fun ls + => list_iter printf_char (String.to_list ls)) + res) + (fun err => raise_failure _ (string_of_Coq_string err)). +End SaturatedSolinas. diff --git a/src/Experiments/NewPipeline/Toplevel1.v b/src/Experiments/NewPipeline/Toplevel1.v new file mode 100644 index 000000000..6168dfd22 --- /dev/null +++ b/src/Experiments/NewPipeline/Toplevel1.v @@ -0,0 +1,2318 @@ +Require Import Coq.ZArith.ZArith Coq.micromega.Lia. +Require Import Coq.derive.Derive. +Require Import Coq.Bool.Bool. +Require Import Coq.Strings.String. +Require Import Coq.Lists.List. +Require Crypto.Util.Strings.String. +Require Import Crypto.Util.Strings.Decimal. +Require Import Crypto.Util.Strings.HexString. +Require Import QArith.QArith_base QArith.Qround Crypto.Util.QUtil. +Require Import Crypto.Algebra.Ring Crypto.Util.Decidable.Bool2Prop. +Require Import Crypto.Algebra.Ring. +Require Import Crypto.Algebra.SubsetoidRing. +Require Import Crypto.Util.ZRange. +Require Import Crypto.Util.ListUtil.FoldBool. +Require Import Crypto.Util.LetIn. +Require Import Crypto.Arithmetic.PrimeFieldTheorems. +Require Import Crypto.Util.ZUtil.Tactics.LtbToLt. +Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo. +Require Import Crypto.Util.Tactics.SplitInContext. +Require Import Crypto.Util.Tactics.SubstEvars. +Require Import Crypto.Util.Tactics.DestructHead. +Require Import Crypto.Util.Tuple. +Require Import Crypto.Util.ListUtil Coq.Lists.List. +Require Import Crypto.Util.Equality. +Require Import Crypto.Util.Tactics.GetGoal. +Require Import Crypto.Arithmetic.BarrettReduction.Generalized. +Require Import Crypto.Util.Tactics.UniquePose. +Require Import Crypto.Util.ZUtil.Rshi. +Require Import Crypto.Util.Option. +Require Import Crypto.Util.Tactics.BreakMatch. +Require Import Crypto.Util.Tactics.SpecializeBy. +Require Import Crypto.Util.ZUtil. +Require Import Crypto.Util.ZUtil.Zselect. +Require Import Crypto.Util.ZUtil.AddModulo. +Require Import Crypto.Util.ZUtil.CC. +Require Import Crypto.Arithmetic.MontgomeryReduction.Definition. +Require Import Crypto.Arithmetic.MontgomeryReduction.Proofs. +Require Import Crypto.Util.ErrorT. +Require Import Crypto.Util.Strings.Show. +Require Import Crypto.Util.ZRange.Show. +Require Import Crypto.Experiments.NewPipeline.Arithmetic. +Require Crypto.Experiments.NewPipeline.Language. +Require Crypto.Experiments.NewPipeline.UnderLets. +Require Crypto.Experiments.NewPipeline.AbstractInterpretation. +Require Crypto.Experiments.NewPipeline.AbstractInterpretationProofs. +Require Crypto.Experiments.NewPipeline.Rewriter. +Require Crypto.Experiments.NewPipeline.MiscCompilerPasses. +Require Crypto.Experiments.NewPipeline.CStringification. +Require Import Crypto.Util.Notations. +Import ListNotations. Local Open Scope Z_scope. + +(** NOTE: Module Ring SHOULD NOT depend on any compilers things *) +Module Ring. + Local Notation is_bounded_by0 r v + := ((lower r <=? v) && (v <=? upper r)). + Local Notation is_bounded_by0o r + := (match r with Some r' => fun v' => is_bounded_by0 r' v' | None => fun _ => true end). + Local Notation is_bounded_by bounds ls + := (fold_andb_map (fun r v'' => is_bounded_by0o r v'') bounds ls). + Local Notation is_bounded_by1 bounds ls + := (andb (is_bounded_by bounds (@fst _ unit ls)) true). + Local Notation is_bounded_by2 bounds ls + := (andb (is_bounded_by bounds (fst ls)) (is_bounded_by1 bounds (snd ls))). + + Lemma length_is_bounded_by bounds ls + : is_bounded_by bounds ls = true -> length ls = length bounds. + Proof. + intro H. + apply fold_andb_map_length in H; congruence. + Qed. + + Section ring_goal. + Context (limbwidth_num limbwidth_den : Z) + (n : nat) + (s : Z) + (c : list (Z * Z)) + (tight_bounds : list (option zrange)) + (length_tight_bounds : length tight_bounds = n) + (loose_bounds : list (option zrange)) + (length_loose_bounds : length loose_bounds = n). + Local Notation weight := (weight limbwidth_num limbwidth_den). + Local Notation eval := (Positional.eval weight n). + Let prime_bound : zrange + := r[0~>(s - Associational.eval c - 1)]%zrange. + Let m := Z.to_pos (s - Associational.eval c). + Context (m_eq : Z.pos m = s - Associational.eval c) + (sc_pos : 0 < s - Associational.eval c) + (Interp_rrelaxv : list Z -> list Z) + (HInterp_rrelaxv : forall arg, + is_bounded_by1 tight_bounds arg = true + -> is_bounded_by loose_bounds (Interp_rrelaxv (fst arg)) = true + /\ Interp_rrelaxv (fst arg) = id (fst arg)) + (carry_mulmod : list Z -> list Z -> list Z) + (Hcarry_mulmod + : forall f g, + length f = n -> length g = n -> + (eval (carry_mulmod f g)) mod (s - Associational.eval c) + = (eval f * eval g) mod (s - Associational.eval c)) + (Interp_rcarry_mulv : list Z -> list Z -> list Z) + (HInterp_rcarry_mulv : forall arg, + is_bounded_by2 loose_bounds arg = true + -> is_bounded_by tight_bounds (Interp_rcarry_mulv (fst arg) (fst (snd arg))) = true + /\ Interp_rcarry_mulv (fst arg) (fst (snd arg)) = carry_mulmod (fst arg) (fst (snd arg))) + (carrymod : list Z -> list Z) + (Hcarrymod + : forall f, + length f = n -> + (eval (carrymod f)) mod (s - Associational.eval c) + = (eval f) mod (s - Associational.eval c)) + (Interp_rcarryv : list Z -> list Z) + (HInterp_rcarryv : forall arg, + is_bounded_by1 loose_bounds arg = true + -> is_bounded_by tight_bounds (Interp_rcarryv (fst arg)) = true + /\ Interp_rcarryv (fst arg) = carrymod (fst arg)) + (addmod : list Z -> list Z -> list Z) + (Haddmod + : forall f g, + length f = n -> length g = n -> + (eval (addmod f g)) mod (s - Associational.eval c) + = (eval f + eval g) mod (s - Associational.eval c)) + (Interp_raddv : list Z -> list Z -> list Z) + (HInterp_raddv : forall arg, + is_bounded_by2 tight_bounds arg = true + -> is_bounded_by loose_bounds (Interp_raddv (fst arg) (fst (snd arg))) = true + /\ Interp_raddv (fst arg) (fst (snd arg)) = addmod (fst arg) (fst (snd arg))) + (submod : list Z -> list Z -> list Z) + (Hsubmod + : forall f g, + length f = n -> length g = n -> + (eval (submod f g)) mod (s - Associational.eval c) + = (eval f - eval g) mod (s - Associational.eval c)) + (Interp_rsubv : list Z -> list Z -> list Z) + (HInterp_rsubv : forall arg, + is_bounded_by2 tight_bounds arg = true + -> is_bounded_by loose_bounds (Interp_rsubv (fst arg) (fst (snd arg))) = true + /\ Interp_rsubv (fst arg) (fst (snd arg)) = submod (fst arg) (fst (snd arg))) + (oppmod : list Z -> list Z) + (Hoppmod + : forall f, + length f = n -> + (eval (oppmod f)) mod (s - Associational.eval c) + = (- eval f) mod (s - Associational.eval c)) + (Interp_roppv : list Z -> list Z) + (HInterp_roppv : forall arg, + is_bounded_by1 tight_bounds arg = true + -> is_bounded_by loose_bounds (Interp_roppv (fst arg)) = true + /\ Interp_roppv (fst arg) = oppmod (fst arg)) + (zeromod : list Z) + (Hzeromod + : (eval zeromod) mod (s - Associational.eval c) + = 0 mod (s - Associational.eval c)) + (Interp_rzerov : list Z) + (HInterp_rzerov : is_bounded_by tight_bounds Interp_rzerov = true + /\ Interp_rzerov = zeromod) + (onemod : list Z) + (Honemod + : (eval onemod) mod (s - Associational.eval c) + = 1 mod (s - Associational.eval c)) + (Interp_ronev : list Z) + (HInterp_ronev : is_bounded_by tight_bounds Interp_ronev = true + /\ Interp_ronev = onemod) + (encodemod : Z -> list Z) + (Hencodemod + : forall f, + (eval (encodemod f)) mod (s - Associational.eval c) + = f mod (s - Associational.eval c)) + (Interp_rencodev : Z -> list Z) + (HInterp_rencodev : forall arg, + is_bounded_by0 prime_bound (@fst _ unit arg) && true = true + -> is_bounded_by tight_bounds (Interp_rencodev (fst arg)) = true + /\ Interp_rencodev (fst arg) = encodemod (fst arg)). + + Local Notation T := (list Z) (only parsing). + Local Notation encoded_ok ls + := (is_bounded_by tight_bounds ls = true) (only parsing). + Local Notation encoded_okf := (fun ls => encoded_ok ls) (only parsing). + + Definition Fdecode (v : T) : F m + := F.of_Z m (Positional.eval weight n v). + Definition T_eq (x y : T) + := Fdecode x = Fdecode y. + + Definition encodedT := sig encoded_okf. + + Definition ring_mul (x y : T) : T + := Interp_rcarry_mulv (Interp_rrelaxv x) (Interp_rrelaxv y). + Definition ring_add (x y : T) : T := Interp_rcarryv (Interp_raddv x y). + Definition ring_sub (x y : T) : T := Interp_rcarryv (Interp_rsubv x y). + Definition ring_opp (x : T) : T := Interp_rcarryv (Interp_roppv x). + Definition ring_encode (x : F m) : T := Interp_rencodev (F.to_Z x). + + Definition GoodT : Prop + := @subsetoid_ring + (list Z) encoded_okf T_eq + Interp_rzerov Interp_ronev ring_opp ring_add ring_sub ring_mul + /\ @is_subsetoid_homomorphism + (F m) (fun _ => True) eq 1%F F.add F.mul + (list Z) encoded_okf T_eq Interp_ronev ring_add ring_mul ring_encode + /\ @is_subsetoid_homomorphism + (list Z) encoded_okf T_eq Interp_ronev ring_add ring_mul + (F m) (fun _ => True) eq 1%F F.add F.mul + Fdecode. + + Hint Rewrite ->@F.to_Z_add : push_FtoZ. + Hint Rewrite ->@F.to_Z_mul : push_FtoZ. + Hint Rewrite ->@F.to_Z_opp : push_FtoZ. + Hint Rewrite ->@F.to_Z_of_Z : push_FtoZ. + + Lemma Fm_bounded_alt (x : F m) + : (0 <=? F.to_Z x) && (F.to_Z x <=? Z.pos m - 1) = true. + Proof using m_eq. + clear -m_eq. + destruct x as [x H]; cbn [F.to_Z proj1_sig]. + pose proof (Z.mod_pos_bound x (Z.pos m)). + rewrite andb_true_iff; split; Z.ltb_to_lt; lia. + Qed. + + Lemma Good : GoodT. + Proof. + split_and. + repeat match goal with + | [ H : context[andb _ true] |- _ ] => setoid_rewrite andb_true_r in H + end. + eapply subsetoid_ring_by_ring_isomorphism; + cbv [ring_opp ring_add ring_sub ring_mul ring_encode F.sub] in *; + repeat match goal with + | [ H : forall arg : _ * unit, _ |- _ ] => specialize (fun arg => H (arg, tt)) + | [ H : forall arg : _ * (_ * unit), _ |- _ ] => specialize (fun a b => H (a, (b, tt))) + | _ => progress cbn [fst snd] in * + | _ => solve [ auto using andb_true_intro, conj with nocore ] + | _ => progress intros + | [ H : _ |- is_bounded_by _ _ = true ] => apply H + | [ |- _ <-> _ ] => reflexivity + | [ |- ?x = ?x ] => reflexivity + | [ |- _ = _ :> Z ] => first [ reflexivity | rewrite <- m_eq; reflexivity ] + | [ H : context[?x] |- Fdecode ?x = _ ] => rewrite H + | [ H : context[?x _] |- Fdecode (?x _) = _ ] => rewrite H + | [ H : context[?x _ _] |- Fdecode (?x _ _) = _ ] => rewrite H + | _ => progress cbv [Fdecode] + | [ |- _ = _ :> F _ ] => apply F.eq_to_Z_iff + | _ => progress autorewrite with push_FtoZ + | _ => rewrite m_eq + | [ H : context[?x _ _] |- context[eval (?x _ _)] ] => rewrite H + | [ H : context[?x _] |- context[eval (?x _)] ] => rewrite H + | [ H : context[?x] |- context[eval ?x] ] => rewrite H + | [ |- context[List.length ?x] ] + => erewrite (length_is_bounded_by _ x) + by eauto using andb_true_intro, conj with nocore + | [ |- _ = _ :> Z ] + => push_Zmod; reflexivity + | _ => pull_Zmod; rewrite Z.add_opp_r + | _ => rewrite expanding_id_id + | [ |- context[F.to_Z _ mod (_ - _)] ] + => rewrite <- m_eq, F.mod_to_Z + | _ => rewrite <- m_eq; apply Fm_bounded_alt + | [ |- context[andb _ true] ] => rewrite andb_true_r + end. + Qed. + End ring_goal. +End Ring. + +Import Associational Positional. + +Import + Crypto.Experiments.NewPipeline.Language + Crypto.Experiments.NewPipeline.UnderLets + Crypto.Experiments.NewPipeline.AbstractInterpretation + Crypto.Experiments.NewPipeline.AbstractInterpretationProofs + Crypto.Experiments.NewPipeline.Rewriter + Crypto.Experiments.NewPipeline.MiscCompilerPasses + Crypto.Experiments.NewPipeline.CStringification. + +Import + Language.Compilers + UnderLets.Compilers + AbstractInterpretation.Compilers + AbstractInterpretationProofs.Compilers + Rewriter.Compilers + MiscCompilerPasses.Compilers + CStringification.Compilers. + +Import Compilers.defaults. +Local Coercion Z.of_nat : nat >-> Z. +Local Coercion QArith_base.inject_Z : Z >-> Q. +Notation "x" := (expr.Var x) (only printing, at level 9) : expr_scope. + +Axiom admit_pf : False. +Notation admit := (match admit_pf with end). +Ltac cache_reify _ := + intros; + etransitivity; + [ + | repeat match goal with |- _ = ?f' ?x => is_var x; apply (f_equal (fun f => f _)) end; + Reify_rhs (); + reflexivity ]; + subst_evars; + reflexivity. + +Create HintDb reify_gen_cache. + +Derive carry_mul_gen + SuchThat (forall (limbwidth_num limbwidth_den : Z) + (f g : list Z) + (n : nat) + (s : Z) + (c : list (Z * Z)) + (idxs : list nat), + Interp (t:=reify_type_of carry_mulmod) + carry_mul_gen limbwidth_num limbwidth_den s c n idxs f g + = carry_mulmod limbwidth_num limbwidth_den s c n idxs f g) + As carry_mul_gen_correct. +Proof. Time cache_reify (). Time Qed. +Hint Extern 1 (_ = carry_mulmod _ _ _ _ _ _ _ _) => simple apply carry_mul_gen_correct : reify_gen_cache. + +Derive carry_gen + SuchThat (forall (limbwidth_num limbwidth_den : Z) + (f : list Z) + (n : nat) + (s : Z) + (c : list (Z * Z)) + (idxs : list nat), + Interp (t:=reify_type_of carrymod) + carry_gen limbwidth_num limbwidth_den s c n idxs f + = carrymod limbwidth_num limbwidth_den s c n idxs f) + As carry_gen_correct. +Proof. cache_reify (). Qed. +Hint Extern 1 (_ = carrymod _ _ _ _ _ _ _) => simple apply carry_gen_correct : reify_gen_cache. + +Derive encode_gen + SuchThat (forall (limbwidth_num limbwidth_den : Z) + (v : Z) + (n : nat) + (s : Z) + (c : list (Z * Z)), + Interp (t:=reify_type_of encodemod) + encode_gen limbwidth_num limbwidth_den s c n v + = encodemod limbwidth_num limbwidth_den s c n v) + As encode_gen_correct. +Proof. cache_reify (). Qed. +Hint Extern 1 (_ = encodemod _ _ _ _ _ _) => simple apply encode_gen_correct : reify_gen_cache. + +Derive add_gen + SuchThat (forall (limbwidth_num limbwidth_den : Z) + (f g : list Z) + (n : nat), + Interp (t:=reify_type_of addmod) + add_gen limbwidth_num limbwidth_den n f g + = addmod limbwidth_num limbwidth_den n f g) + As add_gen_correct. +Proof. cache_reify (). Qed. +Hint Extern 1 (_ = addmod _ _ _ _ _) => simple apply add_gen_correct : reify_gen_cache. +Derive sub_gen + SuchThat (forall (limbwidth_num limbwidth_den : Z) + (n : nat) + (s : Z) + (c : list (Z * Z)) + (coef : Z) + (f g : list Z), + Interp (t:=reify_type_of submod) + sub_gen limbwidth_num limbwidth_den s c n coef f g + = submod limbwidth_num limbwidth_den s c n coef f g) + As sub_gen_correct. +Proof. cache_reify (). Qed. +Hint Extern 1 (_ = submod _ _ _ _ _ _ _ _) => simple apply sub_gen_correct : reify_gen_cache. + +Derive opp_gen + SuchThat (forall (limbwidth_num limbwidth_den : Z) + (n : nat) + (s : Z) + (c : list (Z * Z)) + (coef : Z) + (f : list Z), + Interp (t:=reify_type_of oppmod) + opp_gen limbwidth_num limbwidth_den s c n coef f + = oppmod limbwidth_num limbwidth_den s c n coef f) + As opp_gen_correct. +Proof. cache_reify (). Qed. +Hint Extern 1 (_ = oppmod _ _ _ _ _ _ _) => simple apply opp_gen_correct : reify_gen_cache. + +Definition zeromod limbwidth_num limbwidth_den n s c := encodemod limbwidth_num limbwidth_den n s c 0. +Definition onemod limbwidth_num limbwidth_den n s c := encodemod limbwidth_num limbwidth_den n s c 1. + +Derive zero_gen + SuchThat (forall (limbwidth_num limbwidth_den : Z) + (n : nat) + (s : Z) + (c : list (Z * Z)), + Interp (t:=reify_type_of zeromod) + zero_gen limbwidth_num limbwidth_den s c n + = zeromod limbwidth_num limbwidth_den s c n) + As zero_gen_correct. +Proof. cache_reify (). Qed. +Hint Extern 1 (_ = zeromod _ _ _ _ _) => simple apply zero_gen_correct : reify_gen_cache. + +Derive one_gen + SuchThat (forall (limbwidth_num limbwidth_den : Z) + (n : nat) + (s : Z) + (c : list (Z * Z)), + Interp (t:=reify_type_of onemod) + one_gen limbwidth_num limbwidth_den s c n + = onemod limbwidth_num limbwidth_den s c n) + As one_gen_correct. +Proof. cache_reify (). Qed. +Hint Extern 1 (_ = onemod _ _ _ _ _) => simple apply one_gen_correct : reify_gen_cache. + +Derive id_gen + SuchThat (forall (ls : list Z), + Interp (t:=reify_type_of (@id (list Z))) + id_gen ls + = id ls) + As id_gen_correct. +Proof. cache_reify (). Qed. +Hint Extern 1 (_ = id _) => simple apply id_gen_correct : reify_gen_cache. + +Module Pipeline. + Import GeneralizeVar. + Inductive ErrorMessage := + | Computed_bounds_are_not_tight_enough + {t} (computed_bounds expected_bounds : ZRange.type.base.option.interp (type.final_codomain t)) + (syntax_tree : Expr t) (arg_bounds : type.for_each_lhs_of_arrow ZRange.type.option.interp t) + | Bounds_analysis_failed + | Type_too_complicated_for_cps (t : type) + | Value_not_leZ (descr : string) (lhs rhs : Z) + | Value_not_leQ (descr : string) (lhs rhs : Q) + | Value_not_ltZ (descr : string) (lhs rhs : Z) + | Values_not_provably_distinctZ (descr : string) (lhs rhs : Z) + | Values_not_provably_equalZ (descr : string) (lhs rhs : Z) + | Stringification_failed {t} (e : @Compilers.defaults.Expr t). + + Notation ErrorT := (ErrorT ErrorMessage). + + Section show. + Local Open Scope string_scope. + Definition show_prim_zrange_opt_interp {t:base.type.base} + : Show (ZRange.type.base.option.interp t) + := match t return Show (ZRange.type.base.option.interp t) with + | base.type.unit => _ + | base.type.Z => _ + | base.type.nat => _ + | base.type.bool => _ + end. + Global Existing Instance show_prim_zrange_opt_interp. + Fixpoint show_base_zrange_opt_interp {t} : Show (ZRange.type.base.option.interp t) + := fun parens + => match t return ZRange.type.base.option.interp t -> string with + | base.type.type_base t + => fun v : ZRange.type.base.option.interp t + => @show_prim_zrange_opt_interp t parens v + | base.type.prod A B + => fun '(a, b) + => "(" ++ @show_base_zrange_opt_interp A false a + ++ ", " ++ @show_base_zrange_opt_interp B true b + ++ ")" + | base.type.list A + => fun v : option (list (ZRange.type.option.interp A)) + => show parens v + end. + Global Existing Instance show_base_zrange_opt_interp. + Definition show_zrange_opt_interp {t} : Show (ZRange.type.option.interp t) + := fun parens + => match t return ZRange.type.option.interp t -> string with + | type.base t + => fun v : ZRange.type.base.option.interp t + => show parens v + | type.arrow s d => fun _ => "λ" + end. + Global Existing Instance show_zrange_opt_interp. + Fixpoint show_for_each_lhs_of_arrow {base_type} (f : type.type base_type -> Type) (show_f : forall t, Show (f t)) (t : type.type base_type) (p : bool) : type.for_each_lhs_of_arrow f t -> string + := match t return type.for_each_lhs_of_arrow f t -> string with + | type.base t => fun (tt : unit) => show p tt + | type.arrow s d + => fun '((x, xs) : f s * type.for_each_lhs_of_arrow f d) + => let _ : Show (f s) := show_f s in + let _ : Show (type.for_each_lhs_of_arrow f d) := @show_for_each_lhs_of_arrow base_type f show_f d in + show p (x, xs) + end. + Global Instance: forall {base_type f show_f t}, Show (type.for_each_lhs_of_arrow f t) := @show_for_each_lhs_of_arrow. + + Local Notation NewLine := (String "010" "") (only parsing). + + Fixpoint find_too_loose_base_bounds {t} + : ZRange.type.base.option.interp t -> ZRange.type.base.option.interp t-> bool * list (nat * nat) * list (zrange * zrange) + := match t return ZRange.type.base.option.interp t -> ZRange.type.option.interp t-> bool * list (nat * nat) * list (zrange * zrange) with + | base.type.unit + => fun 'tt 'tt => (false, nil, nil) + | base.type.nat + | base.type.bool + => fun _ _ => (false, nil, nil) + | base.type.Z + => fun a b + => match a, b with + | None, None => (false, nil, nil) + | Some _, None => (false, nil, nil) + | None, Some _ => (true, nil, nil) + | Some a, Some b + => if is_tighter_than_bool a b + then (false, nil, nil) + else (false, nil, ((a, b)::nil)) + end + | base.type.prod A B + => fun '(ra, rb) '(ra', rb') + => let '(b1, lens1, ls1) := @find_too_loose_base_bounds A ra ra' in + let '(b2, lens2, ls2) := @find_too_loose_base_bounds B rb rb' in + (orb b1 b2, lens1 ++ lens2, ls1 ++ ls2)%list + | base.type.list A + => fun ls1 ls2 + => match ls1, ls2 with + | None, None + | Some _, None + => (false, nil, nil) + | None, Some _ + => (true, nil, nil) + | Some ls1, Some ls2 + => List.fold_right + (fun '(b, len, err) '(bs, lens, errs) + => (orb b bs, len ++ lens, err ++ errs)%list) + (false, + (if (List.length ls1 =? List.length ls2)%nat + then nil + else ((List.length ls1, List.length ls2)::nil)), + nil) + (List.map + (fun '(a, b) => @find_too_loose_base_bounds A a b) + (List.combine ls1 ls2)) + end + end. + + Definition find_too_loose_bounds {t} + : ZRange.type.option.interp t -> ZRange.type.option.interp t-> bool * list (nat * nat) * list (zrange * zrange) + := match t with + | type.arrow s d => fun _ _ => (false, nil, nil) + | type.base t => @find_too_loose_base_bounds t + end. + Definition explain_too_loose_bounds {t} (b1 b2 : ZRange.type.option.interp t) + : string + := let '(none_some, lens, bs) := find_too_loose_bounds b1 b2 in + String.concat + NewLine + ((if none_some then "Found None where Some was expected"::nil else nil) + ++ (List.map + (A:=nat*nat) + (fun '(l1, l2) => "Found a list of length " ++ show false l1 ++ " where a list of length " ++ show false l2 ++ " was expected.") + lens) + ++ (List.map + (A:=zrange*zrange) + (fun '(b1, b2) => "The bounds " ++ show false b1 ++ " are looser than the expected bounds " ++ show false b2) + bs)). + + Global Instance show_ErrorMessage : Show ErrorMessage + := fun parens e + => maybe_wrap_parens + parens + match e with + | Computed_bounds_are_not_tight_enough t computed_bounds expected_bounds syntax_tree arg_bounds + => ("Computed bounds " ++ show true computed_bounds ++ " are not tight enough (expected bounds not looser than " ++ show true expected_bounds ++ ")." ++ NewLine) + ++ (explain_too_loose_bounds (t:=type.base _) computed_bounds expected_bounds ++ NewLine) + ++ match ToString.C.ToFunctionString + "f" syntax_tree None arg_bounds with + | Some E_str + => ("When doing bounds analysis on the syntax tree:" ++ NewLine) + ++ E_str ++ NewLine + ++ "with input bounds " ++ show true arg_bounds ++ "." ++ NewLine + | None => "(Unprintible syntax tree used in bounds analysis)" ++ NewLine + end + | Bounds_analysis_failed => "Bounds analysis failed." + | Type_too_complicated_for_cps t + => "Type too complicated for cps: " ++ show false t + | Value_not_leZ descr lhs rhs + => "Value not ≤ (" ++ descr ++ ") : expected " ++ show false lhs ++ " ≤ " ++ show false rhs + | Value_not_leQ descr lhs rhs + => "Value not ≤ (" ++ descr ++ ") : expected " ++ show false lhs ++ " ≤ " ++ show false rhs + | Value_not_ltZ descr lhs rhs + => "Value not < (" ++ descr ++ ") : expected " ++ show false lhs ++ " < " ++ show false rhs + | Values_not_provably_distinctZ descr lhs rhs + => "Values not provalby distinct (" ++ descr ++ ") : expected " ++ show true lhs ++ " ≠ " ++ show true rhs + | Values_not_provably_equalZ descr lhs rhs + => "Values not provalby equal (" ++ descr ++ ") : expected " ++ show true lhs ++ " = " ++ show true rhs + | Stringification_failed t e => "Stringification failed on the syntax tree:" ++ NewLine ++ show false e + end. + End show. + + Definition invert_result {T} (v : ErrorT T) + := match v return match v with Success _ => T | _ => ErrorMessage end with + | Success v => v + | Error msg => msg + end. + + Record to_fancy_args := { invert_low : Z (*log2wordmax*) -> Z -> option Z ; invert_high : Z (*log2wordmax*) -> Z -> option Z }. + + Definition BoundsPipeline + (with_dead_code_elimination : bool := true) + (with_subst01 : bool) + (translate_to_fancy : option to_fancy_args) + relax_zrange + {t} + (E : Expr t) + arg_bounds + out_bounds + : ErrorT (Expr t) + := (*let E := expr.Uncurry E in*) + let E := PartialEvaluateWithListInfoFromBounds E arg_bounds in + let E := PartialEvaluate E in + (* Note that DCE evaluates the expr with two different [var] + arguments, and so results in a pipeline that is 2x slower + unless we pass through a uniformly concrete [var] type + first *) + dlet_nd e := ToFlat E in + let E := FromFlat e in + let E := if with_dead_code_elimination then DeadCodeElimination.EliminateDead E else E in + dlet_nd e := ToFlat E in + let E := FromFlat e in + let E := if with_subst01 then Subst01.Subst01 E else E in + let E := UnderLets.LetBindReturn E in + let E := PartialEvaluate E in (* after inlining, see if any new rewrite redexes are available *) + let E := ReassociateSmallConstants.Reassociate (2^8) E in + let E := match translate_to_fancy with + | Some {| invert_low := invert_low ; invert_high := invert_high |} => RewriteRules.RewriteToFancy invert_low invert_high E + | None => E + end in + dlet_nd e := ToFlat E in + let E := FromFlat e in + let E := CheckedPartialEvaluateWithBounds relax_zrange E arg_bounds out_bounds in + match E with + | inl E => Success E + | inr (b, E) + => Error (Computed_bounds_are_not_tight_enough b out_bounds E arg_bounds) + end. + + Definition BoundsPipelineToStrings + (name : string) + (with_dead_code_elimination : bool := true) + (with_subst01 : bool) + (translate_to_fancy : option to_fancy_args) + relax_zrange + {t} + (E : Expr t) + arg_bounds + out_bounds + : ErrorT (list string) + := let E := BoundsPipeline + (*with_dead_code_elimination*) + with_subst01 + translate_to_fancy + relax_zrange + E arg_bounds out_bounds in + match E with + | Success E' => let E := ToString.C.ToFunctionLines + name E' None arg_bounds in + match E with + | Some E => Success E + | None => Error (Stringification_failed E') + end + | Error err => Error err + end. + + Definition BoundsPipelineToString + (name : string) + (with_dead_code_elimination : bool := true) + (with_subst01 : bool) + (translate_to_fancy : option to_fancy_args) + relax_zrange + {t} + (E : Expr t) + arg_bounds + out_bounds + : ErrorT string + := let E := BoundsPipelineToStrings + name + (*with_dead_code_elimination*) + with_subst01 + translate_to_fancy + relax_zrange + E arg_bounds out_bounds in + match E with + | Success E => Success (ToString.C.LinesToString E) + | Error err => Error err + end. + + Lemma BoundsPipeline_correct + (with_dead_code_elimination : bool := true) + (with_subst01 : bool) + (translate_to_fancy : option to_fancy_args) + relax_zrange + (Hrelax : forall r r' z : zrange, + (z <=? r)%zrange = true -> relax_zrange r = Some r' -> (z <=? r')%zrange = true) + {t} + (e : Expr t) + arg_bounds + out_bounds + rv + (Hrv : BoundsPipeline (*with_dead_code_elimination*) with_subst01 translate_to_fancy relax_zrange e arg_bounds out_bounds = Success rv) + : forall arg + (Harg : type.andb_bool_for_each_lhs_of_arrow (@ZRange.type.option.is_bounded_by) arg_bounds arg = true), + ZRange.type.base.option.is_bounded_by out_bounds (type.app_curried (Interp rv) arg) = true + /\ forall cast_outside_of_range, type.app_curried (expr.Interp (@ident.gen_interp cast_outside_of_range) rv) arg + = type.app_curried (Interp e) arg. + Proof. + cbv [BoundsPipeline Let_In] in *; + repeat match goal with + | [ H : match ?x with _ => _ end = Success _ |- _ ] + => destruct x eqn:?; cbv beta iota in H; [ | destruct_head'_prod; congruence ]; + let H' := fresh in + inversion H as [H']; clear H; rename H' into H + end. + { intros; + match goal with + | [ H : _ = _ |- _ ] + => eapply CheckedPartialEvaluateWithBounds_Correct in H; + [ destruct H as [H0 H1] | .. ] + end; + [ + | eassumption || (try reflexivity).. ]. + subst. + split; [ assumption | ]. + { intros; rewrite H1. + exact admit. (* interp correctness *) } } + Qed. + + Definition BoundsPipeline_correct_transT + {t} + arg_bounds + out_bounds + (InterpE : type.interp base.interp t) + (rv : Expr t) + := forall arg + (Harg : type.andb_bool_for_each_lhs_of_arrow (@ZRange.type.option.is_bounded_by) arg_bounds arg = true), + ZRange.type.base.option.is_bounded_by out_bounds (type.app_curried (Interp rv) arg) = true + /\ forall cast_outside_of_range, type.app_curried (expr.Interp (@ident.gen_interp cast_outside_of_range) rv) arg + = type.app_curried InterpE arg. + + Lemma BoundsPipeline_correct_trans + (with_dead_code_elimination : bool := true) + (with_subst01 : bool) + (translate_to_fancy : option to_fancy_args) + relax_zrange + (Hrelax + : forall r r' z : zrange, + (z <=? r)%zrange = true -> relax_zrange r = Some r' -> (z <=? r')%zrange = true) + {t} + (e : Expr t) + arg_bounds out_bounds + (InterpE : type.interp base.interp t) + (InterpE_correct + : forall arg + (Harg : type.andb_bool_for_each_lhs_of_arrow (@ZRange.type.option.is_bounded_by) arg_bounds arg = true), + type.app_curried (Interp e) arg = type.app_curried InterpE arg) + rv + (Hrv : BoundsPipeline (*with_dead_code_elimination*) with_subst01 translate_to_fancy relax_zrange e arg_bounds out_bounds = Success rv) + : BoundsPipeline_correct_transT arg_bounds out_bounds InterpE rv. + Proof. + intros arg Harg; rewrite <- InterpE_correct by assumption. + eapply @BoundsPipeline_correct; eassumption. + Qed. +End Pipeline. + +Definition round_up_bitwidth_gen (possible_values : list Z) (bitwidth : Z) : option Z + := List.fold_right + (fun allowed cur + => if bitwidth <=? allowed + then Some allowed + else cur) + None + possible_values. + +Lemma round_up_bitwidth_gen_le possible_values bitwidth v + : round_up_bitwidth_gen possible_values bitwidth = Some v + -> bitwidth <= v. +Proof. + cbv [round_up_bitwidth_gen]. + induction possible_values as [|x xs IHxs]; cbn; intros; inversion_option. + break_innermost_match_hyps; Z.ltb_to_lt; inversion_option; subst; trivial. + specialize_by_assumption; omega. +Qed. + +Definition relax_zrange_gen (possible_values : list Z) : zrange -> option zrange + := (fun '(r[ l ~> u ]) + => if (0 <=? l)%Z + then option_map (fun u => r[0~>2^u-1]) + (round_up_bitwidth_gen possible_values (Z.log2_up (u+1))) + else None)%zrange. + +Lemma relax_zrange_gen_good + (possible_values : list Z) + : forall r r' z : zrange, + (z <=? r)%zrange = true -> relax_zrange_gen possible_values r = Some r' -> (z <=? r')%zrange = true. +Proof. + cbv [is_tighter_than_bool relax_zrange_gen]; intros *. + pose proof (Z.log2_up_nonneg (upper r + 1)). + rewrite !Bool.andb_true_iff; destruct_head' zrange; cbn [ZRange.lower ZRange.upper] in *. + cbv [fold_right option_map]. + break_innermost_match; intros; destruct_head'_and; + try match goal with + | [ H : _ |- _ ] => apply round_up_bitwidth_gen_le in H + end; + inversion_option; inversion_zrange; + subst; + repeat apply conj; + Z.ltb_to_lt; try omega; + try (rewrite <- Z.log2_up_le_pow2_full in *; omega). +Qed. + +(** XXX TODO: Translate Jade's python script *) +Module Import UnsaturatedSolinas. + Section rcarry_mul. + Context (n : nat) + (s : Z) + (c : list (Z * Z)) + (machine_wordsize : Z). + + Let limbwidth := (Z.log2_up (s - Associational.eval c) / Z.of_nat n)%Q. + Let idxs := (seq 0 n ++ [0; 1])%list%nat. + Let coef := 2. + Let tight_upperbounds : list Z + := List.map + (fun v : Z => Qceiling (11/10 * v)) + (encode (weight (Qnum limbwidth) (Qden limbwidth)) n s c (s-1)). + Definition prime_bound : ZRange.type.option.interp (base.type.Z) + := Some r[0~>(s - Associational.eval c - 1)]%zrange. + + Definition relax_zrange_of_machine_wordsize + := relax_zrange_gen [machine_wordsize; 2 * machine_wordsize]%Z. + + Let relax_zrange := relax_zrange_of_machine_wordsize. + Definition tight_bounds : list (ZRange.type.option.interp base.type.Z) + := List.map (fun u => Some r[0~>u]%zrange) tight_upperbounds. + Definition loose_bounds : list (ZRange.type.option.interp base.type.Z) + := List.map (fun u => Some r[0 ~> 3*u]%zrange) tight_upperbounds. + + (** Note: If you change the name or type signature of this + function, you will need to update the code in CLI.v *) + Definition check_args {T} (res : Pipeline.ErrorT T) + : Pipeline.ErrorT T + := if negb (Qle_bool 1 limbwidth)%Q + then Error (Pipeline.Value_not_leQ "1 ≤ limbwidth" 1%Q limbwidth) + else if (negb (0 <? s - Associational.eval c))%Z + then Error (Pipeline.Value_not_ltZ "s - Associational.eval c ≤ 0" 0 (s - Associational.eval c)) + else if (s =? 0)%Z + then Error (Pipeline.Values_not_provably_distinctZ "s ≠ 0" s 0) + else if (n =? 0)%nat + then Error (Pipeline.Values_not_provably_distinctZ "n ≠ 0" n 0%nat) + else if (negb (0 <? machine_wordsize)) + then Error (Pipeline.Value_not_ltZ "0 < machine_wordsize" 0 machine_wordsize) + else res. + + Notation type_of_strip_3arrow := ((fun (d : Prop) (_ : forall A B C, d) => d) _). + + Notation BoundsPipeline rop in_bounds out_bounds + := (Pipeline.BoundsPipeline + (*false*) true None + relax_zrange + rop%Expr in_bounds out_bounds). + + Notation BoundsPipeline_correct in_bounds out_bounds op + := (fun rv (rop : Expr (reify_type_of op)) Hrop + => @Pipeline.BoundsPipeline_correct_trans + (*false*) true None + relax_zrange + (relax_zrange_gen_good _) + _ + rop + in_bounds + out_bounds + op + Hrop rv) + (only parsing). + + (* N.B. We only need [rcarry_mul] if we want to extract the Pipeline; otherwise we can just use [rcarry_mul_correct] *) + Definition rcarry_mul + := BoundsPipeline + (carry_mul_gen + @ GallinaReify.Reify (Qnum limbwidth) @ GallinaReify.Reify (Z.pos (Qden limbwidth)) @ GallinaReify.Reify s @ GallinaReify.Reify c @ GallinaReify.Reify n @ GallinaReify.Reify idxs) + (Some loose_bounds, (Some loose_bounds, tt)) + (Some tight_bounds). + + Definition rcarry_mul_correct + := BoundsPipeline_correct + (Some loose_bounds, (Some loose_bounds, tt)) + (Some tight_bounds) + (carry_mulmod (Qnum limbwidth) (Z.pos (Qden limbwidth)) s c n idxs). + + Definition rcarry + := BoundsPipeline + (carry_gen + @ GallinaReify.Reify (Qnum limbwidth) @ GallinaReify.Reify (Z.pos (Qden limbwidth)) @ GallinaReify.Reify s @ GallinaReify.Reify c @ GallinaReify.Reify n @ GallinaReify.Reify idxs) + (Some loose_bounds, tt) + (Some tight_bounds). + + Definition rcarry_correct + := BoundsPipeline_correct + (Some loose_bounds, tt) + (Some tight_bounds) + (carrymod (Qnum limbwidth) (Z.pos (Qden limbwidth)) s c n idxs). + + Definition rrelax + := BoundsPipeline + id_gen + (Some tight_bounds, tt) + (Some loose_bounds). + + Definition rrelax_correct + := BoundsPipeline_correct + (Some tight_bounds, tt) + (Some loose_bounds) + (@id (list Z)). + + Definition radd + := BoundsPipeline + (add_gen + @ GallinaReify.Reify (Qnum limbwidth) @ GallinaReify.Reify (Z.pos (Qden limbwidth)) @ GallinaReify.Reify n) + (Some tight_bounds, (Some tight_bounds, tt)) + (Some loose_bounds). + + Definition radd_correct + := BoundsPipeline_correct + (Some tight_bounds, (Some tight_bounds, tt)) + (Some loose_bounds) + (addmod (Qnum limbwidth) (Z.pos (Qden limbwidth)) n). + + Definition rsub + := BoundsPipeline + (sub_gen + @ GallinaReify.Reify (Qnum limbwidth) @ GallinaReify.Reify (Z.pos (Qden limbwidth)) @ GallinaReify.Reify s @ GallinaReify.Reify c @ GallinaReify.Reify n @ GallinaReify.Reify coef) + (Some tight_bounds, (Some tight_bounds, tt)) + (Some loose_bounds). + + Definition rsub_correct + := BoundsPipeline_correct + (Some tight_bounds, (Some tight_bounds, tt)) + (Some loose_bounds) + (submod (Qnum limbwidth) (Z.pos (Qden limbwidth)) s c n coef). + + Definition ropp + := BoundsPipeline + (opp_gen + @ GallinaReify.Reify (Qnum limbwidth) @ GallinaReify.Reify (Z.pos (Qden limbwidth)) @ GallinaReify.Reify s @ GallinaReify.Reify c @ GallinaReify.Reify n @ GallinaReify.Reify coef) + (Some tight_bounds, tt) + (Some loose_bounds). + + Definition ropp_correct + := BoundsPipeline_correct + (Some tight_bounds, tt) + (Some loose_bounds) + (oppmod (Qnum limbwidth) (Z.pos (Qden limbwidth)) s c n coef). + + Definition rencode_correct + := BoundsPipeline_correct + (prime_bound, tt) + (Some tight_bounds) + (encodemod (Qnum limbwidth) (Z.pos (Qden limbwidth)) s c n). + + Definition rzero_correct + := BoundsPipeline_correct + tt + (Some tight_bounds) + (zeromod (Qnum limbwidth) (Z.pos (Qden limbwidth)) s c n). + + Definition rone_correct + := BoundsPipeline_correct + tt + (Some tight_bounds) + (onemod (Qnum limbwidth) (Z.pos (Qden limbwidth)) s c n). + + (* we need to strip off [Hrv : ... = Pipeline.Success rv] and related arguments *) + Definition rcarry_mul_correctT rv : Prop + := type_of_strip_3arrow (@rcarry_mul_correct rv). + Definition rcarry_correctT rv : Prop + := type_of_strip_3arrow (@rcarry_correct rv). + Definition rrelax_correctT rv : Prop + := type_of_strip_3arrow (@rrelax_correct rv). + Definition radd_correctT rv : Prop + := type_of_strip_3arrow (@radd_correct rv). + Definition rsub_correctT rv : Prop + := type_of_strip_3arrow (@rsub_correct rv). + Definition ropp_correctT rv : Prop + := type_of_strip_3arrow (@ropp_correct rv). + Definition rencode_correctT rv : Prop + := type_of_strip_3arrow (@rencode_correct rv). + Definition rzero_correctT rv : Prop + := type_of_strip_3arrow (@rzero_correct rv). + Definition rone_correctT rv : Prop + := type_of_strip_3arrow (@rone_correct rv). + + Section make_ring. + Let m : positive := Z.to_pos (s - Associational.eval c). + Context (curve_good : check_args (Success tt) = Success tt) + {rcarry_mulv} (Hrmulv : rcarry_mul_correctT rcarry_mulv) + {rcarryv} (Hrcarryv : rcarry_correctT rcarryv) + {rrelaxv} (Hrrelaxv : rrelax_correctT rrelaxv) + {raddv} (Hraddv : radd_correctT raddv) + {rsubv} (Hrsubv : rsub_correctT rsubv) + {roppv} (Hroppv : ropp_correctT roppv) + {rzerov} (Hrzerov : rzero_correctT rzerov) + {ronev} (Hronev : rone_correctT ronev) + {rencodev} (Hrencodev : rencode_correctT rencodev). + + Local Ltac use_curve_good_t := + repeat first [ progress rewrite ?map_length, ?Z.mul_0_r, ?Pos.mul_1_r, ?Z.mul_1_r in * + | reflexivity + | lia + | rewrite interp_reify_list, ?map_map + | rewrite map_ext with (g:=id), map_id + | progress distr_length + | progress cbv [Qceiling Qfloor Qopp Qdiv Qplus inject_Z Qmult Qinv] in * + | progress cbv [Qle] in * + | progress cbn -[reify_list] in * + | progress intros + | solve [ auto ] ]. + + Lemma use_curve_good + : Z.pos m = s - Associational.eval c + /\ Z.pos m <> 0 + /\ s - Associational.eval c <> 0 + /\ s <> 0 + /\ 0 < machine_wordsize + /\ n <> 0%nat + /\ List.length tight_bounds = n + /\ List.length loose_bounds = n + /\ 0 < Qden limbwidth <= Qnum limbwidth. + Proof. + clear -curve_good. + cbv [check_args] in curve_good. + cbv [tight_bounds loose_bounds prime_bound] in *. + break_innermost_match_hyps; try discriminate. + rewrite negb_false_iff in *. + Z.ltb_to_lt. + rewrite Qle_bool_iff in *. + rewrite NPeano.Nat.eqb_neq in *. + intros. + cbv [Qnum Qden limbwidth Qceiling Qfloor Qopp Qdiv Qplus inject_Z Qmult Qinv] in *. + rewrite ?map_length, ?Z.mul_0_r, ?Pos.mul_1_r, ?Z.mul_1_r in *. + specialize_by lia. + repeat match goal with H := _ |- _ => subst H end. + repeat apply conj. + { destruct (s - Associational.eval c); cbn; lia. } + { use_curve_good_t. } + { use_curve_good_t. } + { use_curve_good_t. } + { use_curve_good_t. } + { use_curve_good_t. } + { use_curve_good_t. } + { use_curve_good_t. } + { use_curve_good_t. } + { use_curve_good_t. } + Qed. + + Definition GoodT : Prop + := @Ring.GoodT + (Qnum limbwidth) + (Z.pos (Qden limbwidth)) + n s c + tight_bounds + (Interp rrelaxv) + (Interp rcarry_mulv) + (Interp rcarryv) + (Interp raddv) + (Interp rsubv) + (Interp roppv) + (Interp rzerov) + (Interp ronev) + (Interp rencodev). + + Theorem Good : GoodT. + Proof. + pose proof use_curve_good; destruct_head'_and; destruct_head_hnf' ex. + eapply Ring.Good; + lazymatch goal with + | [ H : ?P ?rop |- context[expr.Interp _ ?rop] ] + => intros; + let H1 := fresh in + let H2 := fresh in + unshelve edestruct H as [H1 H2]; [ .. | solve [ split; [ eapply H1 | eapply H2 ] ] ]; + solve [ exact tt | eassumption | reflexivity ] + | _ => idtac + end; + repeat first [ assumption + | intros; apply eval_carry_mulmod + | intros; apply eval_carrymod + | intros; apply eval_addmod + | intros; apply eval_submod + | intros; apply eval_oppmod + | intros; apply eval_encodemod + | apply conj ]. + Qed. + End make_ring. + + Section for_stringification. + Local Open Scope string_scope. + + Let ToFunLines t name E arg_bounds + := (name, + match E with + | Success E' + => let E := @ToString.C.ToFunctionLines + name t E' None arg_bounds in + match E with + | Some E => Success E + | None => Error (Pipeline.Stringification_failed E') + end + | Error err => Error err + end). + + (** Note: If you change the name or type signature of this + function, you will need to update the code in CLI.v *) + Definition Synthesize (function_name_prefix : string) : list (string * Pipeline.ErrorT (list string)) + := let loose_bounds := Some loose_bounds in + let tight_bounds := Some tight_bounds in + let fe op := (function_name_prefix ++ op)%string in + [(ToFunLines _ (fe "carry_mul") rcarry_mul (loose_bounds, (loose_bounds, tt))); + (ToFunLines _ (fe "carry") rcarry (loose_bounds, tt)); + (ToFunLines _ (fe "add") radd (tight_bounds, (tight_bounds, tt))); + (ToFunLines _ (fe "sub") rsub (tight_bounds, (tight_bounds, tt))); + (ToFunLines _ (fe "opp") ropp (tight_bounds, tt))]. + End for_stringification. + End rcarry_mul. +End UnsaturatedSolinas. + +Ltac peel_interp_app _ := + lazymatch goal with + | [ |- ?R' (?InterpE ?arg) (?f ?arg) ] + => apply fg_equal_rel; [ | reflexivity ]; + try peel_interp_app () + | [ |- ?R' (Interp ?ev) (?f ?x) ] + => let sv := type of x in + let fx := constr:(f x) in + let dv := type of fx in + let rs := reify_type sv in + let rd := reify_type dv in + etransitivity; + [ apply @expr.Interp_APP_rel_reflexive with (s:=rs) (d:=rd) (R:=R'); + typeclasses eauto + | apply fg_equal_rel; + [ try peel_interp_app () + | try lazymatch goal with + | [ |- ?R (Interp ?ev) (Interp _) ] + => reflexivity + | [ |- ?R (Interp ?ev) ?c ] + => let rc := constr:(GallinaReify.Reify c) in + unify ev rc; reflexivity + end ] ] + end. +Ltac pre_cache_reify _ := + cbv [type.app_curried]; + let arg := fresh "arg" in + intros arg _; + peel_interp_app (); + [ lazymatch goal with + | [ |- ?R (Interp ?ev) _ ] + => (tryif is_evar ev + then let ev' := fresh "ev" in set (ev' := ev) + else idtac) + end; + cbv [pointwise_relation]; intros; clear + | .. ]. +Ltac do_inline_cache_reify do_if_not_cached := + pre_cache_reify (); + [ try solve [ + repeat match goal with H := ?e |- _ => is_evar e; subst H end; + eauto with nocore reify_gen_cache; + do_if_not_cached () + ]; + cache_reify () + | .. ]. + +(* TODO: MOVE ME *) +Ltac vm_compute_lhs_reflexivity := + lazymatch goal with + | [ |- ?LHS = ?RHS ] + => let x := (eval vm_compute in LHS) in + (* we cannot use the unify tactic, which just gives "not + unifiable" as the error message, because we want to see the + terms that were not unifable. See also + COQBUG(https://github.com/coq/coq/issues/7291) *) + let _unify := constr:(ltac:(reflexivity) : RHS = x) in + vm_cast_no_check (eq_refl x) + end. + +Ltac solve_rop' rop_correct do_if_not_cached machine_wordsizev := + eapply rop_correct with (machine_wordsize:=machine_wordsizev); + [ do_inline_cache_reify do_if_not_cached + | subst_evars; vm_compute_lhs_reflexivity (* lazy; reflexivity *) ]. +Ltac solve_rop_nocache rop_correct := + solve_rop' rop_correct ltac:(fun _ => idtac). +Ltac solve_rop rop_correct := + solve_rop' + rop_correct + ltac:(fun _ => let G := get_goal in fail 2 "Could not find a solution in reify_gen_cache for" G). +Ltac solve_rcarry_mul := solve_rop rcarry_mul_correct. +Ltac solve_rcarry_mul_nocache := solve_rop_nocache rcarry_mul_correct. +Ltac solve_rcarry := solve_rop rcarry_correct. +Ltac solve_radd := solve_rop radd_correct. +Ltac solve_rsub := solve_rop rsub_correct. +Ltac solve_ropp := solve_rop ropp_correct. +Ltac solve_rencode := solve_rop rencode_correct. +Ltac solve_rrelax := solve_rop rrelax_correct. +Ltac solve_rzero := solve_rop rzero_correct. +Ltac solve_rone := solve_rop rone_correct. + +Module PrintingNotations. + Export ident. + (*Global Set Printing Width 100000.*) + Open Scope zrange_scope. + Notation "'uint256'" + := (r[0 ~> 115792089237316195423570985008687907853269984665640564039457584007913129639935]%zrange) : zrange_scope. + Notation "'uint128'" + := (r[0 ~> 340282366920938463463374607431768211455]%zrange) : zrange_scope. + Notation "'uint64'" + := (r[0 ~> 18446744073709551615]) : zrange_scope. + Notation "'uint32'" + := (r[0 ~> 4294967295]) : zrange_scope. + Notation "'bool'" + := (r[0 ~> 1]%zrange) : zrange_scope. + Notation "( range )( ls [[ n ]] )" + := ((#(ident.Z_cast range) @ (ls [[ n ]]))%expr) + (format "( range )( ls [[ n ]] )") : expr_scope. + (*Notation "( range )( v )" := (ident.Z_cast range @@ v)%expr : expr_scope.*) + Notation "x *₂₅₆ y" + := (#(ident.Z_cast uint256) @ (#ident.Z_mul @ x @ y))%expr (at level 40) : expr_scope. + Notation "x *₁₂₈ y" + := (#(ident.Z_cast uint128) @ (#ident.Z_mul @ x @ y))%expr (at level 40) : expr_scope. + Notation "x *₆₄ y" + := (#(ident.Z_cast uint64) @ (#ident.Z_mul @ x @ y))%expr (at level 40) : expr_scope. + Notation "x *₃₂ y" + := (#(ident.Z_cast uint32) @ (#ident.Z_mul @ x @ y))%expr (at level 40) : expr_scope. + Notation "x +₂₅₆ y" + := (#(ident.Z_cast uint256) @ (#ident.Z_add @ x @ y))%expr (at level 50) : expr_scope. + Notation "x +₁₂₈ y" + := (#(ident.Z_cast uint128) @ (#ident.Z_add @ x @ y))%expr (at level 50) : expr_scope. + Notation "x +₆₄ y" + := (#(ident.Z_cast uint64) @ (#ident.Z_add @ x @ y))%expr (at level 50) : expr_scope. + Notation "x +₃₂ y" + := (#(ident.Z_cast uint32) @ (#ident.Z_add @ x @ y))%expr (at level 50) : expr_scope. + Notation "x -₁₂₈ y" + := (#(ident.Z_cast uint128) @ (#ident.Z_sub @ x @ y))%expr (at level 50) : expr_scope. + Notation "x -₆₄ y" + := (#(ident.Z_cast uint64) @ (#ident.Z_sub @ x @ y))%expr (at level 50) : expr_scope. + Notation "x -₃₂ y" + := (#(ident.Z_cast uint32) @ (#ident.Z_sub @ x @ y))%expr (at level 50) : expr_scope. + Notation "( out_t )( v >> count )" + := ((#(ident.Z_cast out_t) @ (#(ident.Z_shiftr count) @ v))%expr) + (format "( out_t )( v >> count )") : expr_scope. + Notation "( out_t )( v << count )" + := ((#(ident.Z_cast out_t) @ (#(ident.Z_shiftl count) @ v))%expr) + (format "( out_t )( v << count )") : expr_scope. + Notation "( range )( v )" + := ((#(ident.Z_cast range) @ $v)%expr) + (format "( range )( v )") : expr_scope. + Notation "( ( out_t )( v ) & mask )" + := ((#(ident.Z_cast out_t) @ (#(ident.Z_land mask) @ v))%expr) + (format "( ( out_t )( v ) & mask )") + : expr_scope. + + Notation "x" := (#(ident.Z_cast _) @ $x)%expr (only printing, at level 9) : expr_scope. + Notation "x" := (#(ident.Z_cast2 _) @ $x)%expr (only printing, at level 9) : expr_scope. + Notation "v ₁" := (#ident.fst @ $v)%expr (at level 10, format "v ₁") : expr_scope. + Notation "v ₂" := (#ident.snd @ $v)%expr (at level 10, format "v ₂") : expr_scope. + Notation "v ₁" := (#(ident.Z_cast _) @ (#ident.fst @ $v))%expr (at level 10, format "v ₁") : expr_scope. + Notation "v ₂" := (#(ident.Z_cast _) @ (#ident.snd @ $v))%expr (at level 10, format "v ₂") : expr_scope. + Notation "v ₁" := (#(ident.Z_cast _) @ (#ident.fst @ (#(ident.Z_cast2 _) @ $v)))%expr (at level 10, format "v ₁") : expr_scope. + Notation "v ₂" := (#(ident.Z_cast _) @ (#ident.snd @ (#(ident.Z_cast2 _) @ $v)))%expr (at level 10, format "v ₂") : expr_scope. + Notation "x" := (#(ident.Literal x%Z))%expr (only printing) : expr_scope. + + (*Notation "ls [[ n ]]" := (List.nth_default_concrete _ n @@ ls)%expr : expr_scope. + Notation "( range )( v )" := (ident.Z_cast range @@ v)%expr : expr_scope. + Notation "x *₁₂₈ y" + := (ident.Z_cast uint128 @@ (ident.Z.mul (x, y)))%expr (at level 40) : expr_scope. + Notation "( out_t )( v >> count )" + := (ident.Z_cast out_t (ident.Z.shiftr count @@ v)%expr) + (format "( out_t )( v >> count )") : expr_scope. + Notation "( out_t )( v >> count )" + := (ident.Z_cast out_t (ident.Z.shiftr count @@ v)%expr) + (format "( out_t )( v >> count )") : expr_scope. + Notation "v ₁" := (ident.fst @@ v)%expr (at level 10, format "v ₁") : expr_scope. + Notation "v ₂" := (ident.snd @@ v)%expr (at level 10, format "v ₂") : expr_scope.*) + (* + Notation "'ℤ'" + := BoundsAnalysis.type.Z : zrange_scope. + Notation "ls [[ n ]]" := (List.nth n @@ ls)%nexpr : nexpr_scope. + Notation "x *₆₄₋₆₄₋₁₂₈ y" + := (mul uint64 uint64 uint128 @@ (x, y))%nexpr (at level 40) : nexpr_scope. + Notation "x *₆₄₋₆₄₋₆₄ y" + := (mul uint64 uint64 uint64 @@ (x, y))%nexpr (at level 40) : nexpr_scope. + Notation "x *₃₂₋₃₂₋₃₂ y" + := (mul uint32 uint32 uint32 @@ (x, y))%nexpr (at level 40) : nexpr_scope. + Notation "x *₃₂₋₁₂₈₋₁₂₈ y" + := (mul uint32 uint128 uint128 @@ (x, y))%nexpr (at level 40) : nexpr_scope. + Notation "x *₃₂₋₆₄₋₆₄ y" + := (mul uint32 uint64 uint64 @@ (x, y))%nexpr (at level 40) : nexpr_scope. + Notation "x *₃₂₋₃₂₋₆₄ y" + := (mul uint32 uint32 uint64 @@ (x, y))%nexpr (at level 40) : nexpr_scope. + Notation "x +₁₂₈ y" + := (add uint128 uint128 uint128 @@ (x, y))%nexpr (at level 50) : nexpr_scope. + Notation "x +₆₄₋₁₂₈₋₁₂₈ y" + := (add uint64 uint128 uint128 @@ (x, y))%nexpr (at level 50) : nexpr_scope. + Notation "x +₃₂₋₆₄₋₆₄ y" + := (add uint32 uint64 uint64 @@ (x, y))%nexpr (at level 50) : nexpr_scope. + Notation "x +₆₄ y" + := (add uint64 uint64 uint64 @@ (x, y))%nexpr (at level 50) : nexpr_scope. + Notation "x +₃₂ y" + := (add uint32 uint32 uint32 @@ (x, y))%nexpr (at level 50) : nexpr_scope. + Notation "x -₁₂₈ y" + := (sub uint128 uint128 uint128 @@ (x, y))%nexpr (at level 50) : nexpr_scope. + Notation "x -₆₄₋₁₂₈₋₁₂₈ y" + := (sub uint64 uint128 uint128 @@ (x, y))%nexpr (at level 50) : nexpr_scope. + Notation "x -₃₂₋₆₄₋₆₄ y" + := (sub uint32 uint64 uint64 @@ (x, y))%nexpr (at level 50) : nexpr_scope. + Notation "x -₆₄ y" + := (sub uint64 uint64 uint64 @@ (x, y))%nexpr (at level 50) : nexpr_scope. + Notation "x -₃₂ y" + := (sub uint32 uint32 uint32 @@ (x, y))%nexpr (at level 50) : nexpr_scope. + Notation "x" := ({| BoundsAnalysis.type.value := x |}) (only printing) : nexpr_scope. + Notation "( out_t )( v >> count )" + := ((shiftr _ out_t count @@ v)%nexpr) + (format "( out_t )( v >> count )") + : nexpr_scope. + Notation "( out_t )( v << count )" + := ((shiftl _ out_t count @@ v)%nexpr) + (format "( out_t )( v << count )") + : nexpr_scope. + Notation "( ( out_t ) v & mask )" + := ((land _ out_t mask @@ v)%nexpr) + (format "( ( out_t ) v & mask )") + : nexpr_scope. +*) + (* TODO: come up with a better notation for arithmetic with carries + that still distinguishes it from arithmetic without carries? *) + Local Notation "'TwoPow256'" := 115792089237316195423570985008687907853269984665640564039457584007913129639936 (only parsing). + Notation "'ADD_256' ( x , y )" := (#(ident.Z_cast2 (uint256, bool)%core) @ (#(ident.Z_add_get_carry_concrete TwoPow256) @ x @ y))%expr : expr_scope. + Notation "'ADD_128' ( x , y )" := (#(ident.Z_cast2 (uint128, bool)%core) @ (#(ident.Z_add_get_carry_concrete TwoPow256) @ x @ y))%expr : expr_scope. + Notation "'ADDC_256' ( x , y , z )" := (#(ident.Z_cast2 (uint256, bool)%core) @ (#(ident.Z_add_with_get_carry_concrete TwoPow256) @ x @ y @ z))%expr : expr_scope. + Notation "'ADDC_128' ( x , y , z )" := (#(ident.Z_cast2 (uint128, bool)%core) @ (#(ident.Z_add_with_get_carry_concrete TwoPow256) @ x @ y @ z))%expr : expr_scope. + Notation "'SUB_256' ( x , y )" := (#(ident.Z_cast2 (uint256, bool)%core) @ (#(ident.Z_sub_get_borrow_concrete TwoPow256) @ x @ y))%expr : expr_scope. + Notation "'SUBB_256' ( x , y , z )" := (#(ident.Z_cast2 (uint256, bool)%core) @ (#(ident.Z_sub_with_get_borrow_concrete TwoPow256) @ x @ y @ z))%expr : expr_scope. + Notation "'ADDM' ( x , y , z )" := (#(ident.Z_cast uint256) @ (#ident.Z_add_modulo @ x @ y @ z))%expr : expr_scope. + Notation "'RSHI' ( x , y , z )" := (#(ident.Z_cast _) @ (#(ident.Z_rshi_concrete _ z) @ x @ y))%expr : expr_scope. + Notation "'SELC' ( x , y , z )" := (#(ident.Z_cast uint256) @ (ident.Z_zselect @ x @ y @ z))%expr : expr_scope. + Notation "'SELM' ( x , y , z )" := (#(ident.Z_cast uint256) @ (ident.Z_zselect @ (#(Z_cast bool) @ (Z_cc_m_concrete _) @ x) @ y @ z))%expr : expr_scope. + Notation "'SELL' ( x , y , z )" := (#(ident.Z_cast uint256) @ (#ident.Z_zselect @ (#(Z_cast bool) @ (#(Z_land 1) @ x)) @ y @ z))%expr : expr_scope. +End PrintingNotations. + +(* +Notation "a ∈ b" := (ZRange.type.is_bounded_by b%zrange a = true) (at level 10) : type_scope. +Notation Interp := (expr.Interp _). +Notation "'ℤ'" := (type.type_primitive type.Z). +Set Printing Width 70. +Goal False. + let rop' := Reify (fun v1v2 : Z * Z => fst v1v2 + snd v1v2) in + pose rop' as rop. + pose (@Pipeline.BoundsPipeline_full + false (fun v => Some v) (type.Z * type.Z) type.Z + rop + (r[0~>10], r[0~>10])%zrange + r[0~>20]%zrange + ) as E. + simple refine (let Ev := _ in + let compiler_outputs_Ev : E = Pipeline.Success Ev := _ in + _); [ shelve | .. ]; revgoals. + clearbody compiler_outputs_Ev. + refine (let H' := + (fun H'' => + @Pipeline.BoundsPipeline_full_correct + _ _ + H'' _ _ _ _ _ _ compiler_outputs_Ev) _ + in _); + clearbody H'. + Focus 2. + { cbv [Pipeline.BoundsPipeline_full] in E. + remember (Pipeline.PrePipeline rop) as cache eqn:Hcache in (value of E). + lazy in Hcache. + subst cache. + lazy in E. + subst E Ev; reflexivity. + } Unfocus. + cbv [rop] in H'; cbn [expr.Interp expr.interp for_reification.ident.interp] in H'. +(* + H' : forall arg : type.interp (ℤ * ℤ), + arg ∈ (r[0 ~> 10], r[0 ~> 10]) -> + (Interp Ev arg) ∈ r[0 ~> 20] /\ + Interp Ev arg = fst arg + snd arg +*) +Abort. +*) + +Module SaturatedSolinas. + Section MulMod. + Context (s : Z) (c : list (Z * Z)) + (s_nz : s <> 0) (modulus_nz : s - Associational.eval c <> 0). + Context (log2base : Z) (log2base_pos : 0 < log2base) + (n nreductions : nat) (n_nz : n <> 0%nat). + + Let weight := weight log2base 1. + Let props : @weight_properties weight := wprops log2base 1 ltac:(omega). + Local Lemma base_nz : 2 ^ log2base <> 0. Proof. auto with zarith. Qed. + + Derive mulmod + SuchThat (forall (f g : list Z) + (Hf : length f = n) + (Hg : length g = n), + (eval weight n (fst (mulmod f g)) + weight n * (snd (mulmod f g))) mod (s - Associational.eval c) + = (eval weight n f * eval weight n g) mod (s - Associational.eval c)) + As eval_mulmod. + Proof. + intros. + rewrite <-Rows.eval_mulmod with (base:=2^log2base) (s:=s) (c:=c) (nreductions:=nreductions) by auto using base_nz. + eapply f_equal2; [|trivial]. + (* expand_lists (). *) (* uncommenting this line removes some unused multiplications but also inlines a bunch of carry stuff at the end *) + subst mulmod. reflexivity. + Qed. + Definition mulmod' := fun x y => fst (mulmod x y). + End MulMod. + + Derive mulmod_gen + SuchThat (forall (log2base s : Z) (c : list (Z * Z)) (n nreductions : nat) + (f g : list Z), + Interp (t:=reify_type_of mulmod') + mulmod_gen s c log2base n nreductions f g + = mulmod' s c log2base n nreductions f g) + As mulmod_gen_correct. + Proof. Time cache_reify (). Time Qed. + Module Export ReifyHints. + Global Hint Extern 1 (_ = mulmod' _ _ _ _ _ _ _) => simple apply mulmod_gen_correct : reify_gen_cache. + End ReifyHints. + + Section rmulmod. + Context (s : Z) + (c : list (Z * Z)) + (machine_wordsize : Z). + + Definition relax_zrange_of_machine_wordsize + := relax_zrange_gen [1; machine_wordsize]%Z. + + Let n : nat := Z.to_nat (Qceiling (Z.log2_up s / machine_wordsize)). + (* Number of reductions is calculated as follows : + Let i be the highest limb index of c. Then, each reduction + decreases the number of extra limbs by (n-i). So, to go from + the n extra limbs we have post-multiplication down to 0, we + need ceil (n / (n - i)) reductions. *) + Let nreductions : nat := + let i := fold_right Z.max 0 (map (fun t => Z.log2 (fst t) / machine_wordsize) c) in + Z.to_nat (Qceiling (Z.of_nat n / (Z.of_nat n - i))). + Let relax_zrange := relax_zrange_of_machine_wordsize. + Let bound := Some r[0 ~> (2^machine_wordsize - 1)]%zrange. + Let boundsn : list (ZRange.type.option.interp base.type.Z) + := repeat bound n. + + (** Note: If you change the name or type signature of this + function, you will need to update the code in CLI.v *) + Definition check_args {T} (res : Pipeline.ErrorT T) + : Pipeline.ErrorT T + := if (negb (0 <? s - Associational.eval c))%Z + then Error (Pipeline.Value_not_ltZ "s - Associational.eval c ≤ 0" 0 (s - Associational.eval c)) + else if (s =? 0)%Z + then Error (Pipeline.Values_not_provably_distinctZ "s ≠ 0" s 0) + else if (n =? 0)%nat + then Error (Pipeline.Values_not_provably_distinctZ "n ≠ 0" n 0) + else if (negb (0 <? machine_wordsize)) + then Error (Pipeline.Value_not_ltZ "0 < machine_wordsize" 0 machine_wordsize) + else res. + + Notation BoundsPipeline rop in_bounds out_bounds + := (Pipeline.BoundsPipeline + (*false*) false None + relax_zrange + rop%Expr in_bounds out_bounds). + + Notation BoundsPipeline_correct in_bounds out_bounds op + := (fun rv (rop : Expr (reify_type_of op)) Hrop + => @Pipeline.BoundsPipeline_correct_trans + (*false*) false None + relax_zrange + (relax_zrange_gen_good _) + _ + rop + in_bounds + out_bounds + op + Hrop rv) + (only parsing). + + Definition rmulmod_correct + := BoundsPipeline_correct + (Some boundsn, (Some boundsn, tt)) + (Some boundsn) + (mulmod' s c machine_wordsize n nreductions). + + Definition rmulmod + := BoundsPipeline + (mulmod_gen @ GallinaReify.Reify s @ GallinaReify.Reify c @ GallinaReify.Reify machine_wordsize @ GallinaReify.Reify n @ GallinaReify.Reify nreductions) + (Some boundsn, (Some boundsn, tt)) + (Some boundsn). + + Notation type_of_strip_3arrow := ((fun (d : Prop) (_ : forall A B C, d) => d) _). + Definition rmulmod_correctT rv : Prop + := type_of_strip_3arrow (@rmulmod_correct rv). + + Section for_stringification. + Local Open Scope string_scope. + + Let ToFunLines t name E arg_bounds + := (name, + match E with + | Success E' + => let E := @ToString.C.ToFunctionLines + name t E' None arg_bounds in + match E with + | Some E => Success E + | None => Error (Pipeline.Stringification_failed E') + end + | Error err => Error err + end). + + (** Note: If you change the name or type signature of this + function, you will need to update the code in CLI.v *) + Definition Synthesize (function_name_prefix : string) : list (string * Pipeline.ErrorT (list string)) + := let loose_bounds := Some loose_bounds in + let tight_bounds := Some tight_bounds in + let fe op := (function_name_prefix ++ op)%string in + [(ToFunLines _ (fe "mulmod") rmulmod (Some boundsn, (Some boundsn, tt)))]. + End for_stringification. + End rmulmod. +End SaturatedSolinas. + +Ltac solve_rmulmod := solve_rop SaturatedSolinas.rmulmod_correct. +Ltac solve_rmulmod_nocache := solve_rop_nocache SaturatedSolinas.rmulmod_correct. + +Module Import InvertHighLow. + Section with_wordmax. + Context (log2wordmax : Z) (consts : list Z). + Let wordmax := 2 ^ log2wordmax. + Let half_bits := log2wordmax / 2. + Let wordmax_half_bits := 2 ^ half_bits. + + Inductive kind_of_constant := upper_half (c : BinInt.Z) | lower_half (c : BinInt.Z). + + Definition constant_to_scalar_single (const x : BinInt.Z) : option kind_of_constant := + if x =? (BinInt.Z.shiftr const half_bits) + then Some (upper_half const) + else if x =? (BinInt.Z.land const (wordmax_half_bits - 1)) + then Some (lower_half const) + else None. + + Definition constant_to_scalar (x : BinInt.Z) + : option kind_of_constant := + fold_right (fun c res => match res with + | Some s => Some s + | None => constant_to_scalar_single c x + end) None consts. + + Definition invert_low (v : BinInt.Z) : option BinInt.Z + := match constant_to_scalar v with + | Some (lower_half v) => Some v + | _ => None + end. + + Definition invert_high (v : BinInt.Z) : option BinInt.Z + := match constant_to_scalar v with + | Some (upper_half v) => Some v + | _ => None + end. + End with_wordmax. +End InvertHighLow. + +Module BarrettReduction. + (* TODO : generalize to multi-word and operate on (list Z) instead of T; maybe stop taking ops as context variables *) + Section Generic. + Context {T} (rep : T -> Z -> Prop) + (k : Z) (k_pos : 0 < k) + (low : T -> Z) + (low_correct : forall a x, rep a x -> low a = x mod 2 ^ k) + (shiftr : T -> Z -> T) + (shiftr_correct : forall a x n, + rep a x -> + 0 <= n <= k -> + rep (shiftr a n) (x / 2 ^ n)) + (mul_high : T -> T -> Z -> T) + (mul_high_correct : forall a b x y x0y1, + rep a x -> + rep b y -> + 2 ^ k <= x < 2^(k+1) -> + 0 <= y < 2^(k+1) -> + x0y1 = x mod 2 ^ k * (y / 2 ^ k) -> + rep (mul_high a b x0y1) (x * y / 2 ^ k)) + (mul : Z -> Z -> T) + (mul_correct : forall x y, + 0 <= x < 2^k -> + 0 <= y < 2^k -> + rep (mul x y) (x * y)) + (sub : T -> T -> T) + (sub_correct : forall a b x y, + rep a x -> + rep b y -> + 0 <= x - y < 2^k * 2^k -> + rep (sub a b) (x - y)) + (cond_sub1 : T -> Z -> Z) + (cond_sub1_correct : forall a x y, + rep a x -> + 0 <= x < 2 * y -> + 0 <= y < 2 ^ k -> + cond_sub1 a y = if (x <? 2 ^ k) then x else x - y) + (cond_sub2 : Z -> Z -> Z) + (cond_sub2_correct : forall x y, cond_sub2 x y = if (x <? y) then x else x - y). + Context (xt mut : T) (M muSelect: Z). + + Let mu := 2 ^ (2 * k) / M. + Context x (mu_rep : rep mut mu) (x_rep : rep xt x). + Context (M_nz : 0 < M) + (x_range : 0 <= x < M * 2 ^ k) + (M_range : 2 ^ (k - 1) < M < 2 ^ k) + (M_good : 2 * (2 ^ (2 * k) mod M) <= 2 ^ (k + 1) - mu) + (muSelect_correct: muSelect = mu mod 2 ^ k * (x / 2 ^ (k - 1) / 2 ^ k)). + + Definition qt := + dlet_nd muSelect := muSelect in (* makes sure muSelect is not inlined in the output *) + dlet_nd q1 := shiftr xt (k - 1) in + dlet_nd twoq := mul_high mut q1 muSelect in + shiftr twoq 1. + Definition reduce := + dlet_nd qt := qt in + dlet_nd r2 := mul (low qt) M in + dlet_nd r := sub xt r2 in + let q3 := cond_sub1 r M in + cond_sub2 q3 M. + + Lemma looser_bound : M * 2 ^ k < 2 ^ (2*k). + Proof. clear -M_range M_nz x_range k_pos; rewrite <-Z.add_diag, Z.pow_add_r; nia. Qed. + + Lemma pow_2k_eq : 2 ^ (2*k) = 2 ^ (k - 1) * 2 ^ (k + 1). + Proof. clear -k_pos; rewrite <-Z.pow_add_r by omega. f_equal; ring. Qed. + + Lemma mu_bounds : 2 ^ k <= mu < 2^(k+1). + Proof. + pose proof looser_bound. + subst mu. split. + { apply Z.div_le_lower_bound; omega. } + { apply Z.div_lt_upper_bound; try omega. + rewrite pow_2k_eq; apply Z.mul_lt_mono_pos_r; auto with zarith. } + Qed. + + Lemma shiftr_x_bounds : 0 <= x / 2 ^ (k - 1) < 2^(k+1). + Proof. + pose proof looser_bound. + split; [ solve [Z.zero_bounds] | ]. + apply Z.div_lt_upper_bound; auto with zarith. + rewrite <-pow_2k_eq. omega. + Qed. + Hint Resolve shiftr_x_bounds. + + Ltac solve_rep := eauto using shiftr_correct, mul_high_correct, mul_correct, sub_correct with omega. + + Let q := mu * (x / 2 ^ (k - 1)) / 2 ^ (k + 1). + + Lemma q_correct : rep qt q . + Proof. + pose proof mu_bounds. cbv [qt]; subst q. + rewrite Z.pow_add_r, <-Z.div_div by Z.zero_bounds. + solve_rep. + Qed. + Hint Resolve q_correct. + + Lemma x_mod_small : x mod 2 ^ (k - 1) <= M. + Proof. transitivity (2 ^ (k - 1)); auto with zarith. Qed. + Hint Resolve x_mod_small. + + Lemma q_bounds : 0 <= q < 2 ^ k. + Proof. + pose proof looser_bound. pose proof x_mod_small. pose proof mu_bounds. + split; subst q; [ solve [Z.zero_bounds] | ]. + edestruct q_nice_strong with (n:=M) as [? Hqnice]; + try rewrite Hqnice; auto; try omega; [ ]. + apply Z.le_lt_trans with (m:= x / M). + { break_match; omega. } + { apply Z.div_lt_upper_bound; omega. } + Qed. + + Lemma two_conditional_subtracts : + forall a x, + rep a x -> + 0 <= x < 2 * M -> + cond_sub2 (cond_sub1 a M) M = cond_sub2 (cond_sub2 x M) M. + Proof. + intros. + erewrite !cond_sub2_correct, !cond_sub1_correct by (eassumption || omega). + break_match; Z.ltb_to_lt; try lia; discriminate. + Qed. + + Lemma r_bounds : 0 <= x - q * M < 2 * M. + Proof. + pose proof looser_bound. pose proof q_bounds. pose proof x_mod_small. + subst q mu; split. + { Z.zero_bounds. apply qn_small; omega. } + { apply r_small_strong; rewrite ?Z.pow_1_r; auto; omega. } + Qed. + + Lemma reduce_correct : reduce = x mod M. + Proof. + pose proof looser_bound. pose proof r_bounds. pose proof q_bounds. + assert (2 * M < 2^k * 2^k) by nia. + rewrite barrett_reduction_small with (k:=k) (m:=mu) (offset:=1) (b:=2) by (auto; omega). + cbv [reduce Let_In]. + erewrite low_correct by eauto. Z.rewrite_mod_small. + erewrite two_conditional_subtracts by solve_rep. + rewrite !cond_sub2_correct. + subst q; reflexivity. + Qed. + End Generic. + + Section BarrettReduction. + Context (k : Z) (k_bound : 2 <= k). + Context (M muLow : Z). + Context (M_pos : 0 < M) + (muLow_eq : muLow + 2^k = 2^(2*k) / M) + (muLow_bounds : 0 <= muLow < 2^k) + (M_bound1 : 2 ^ (k - 1) < M < 2^k) + (M_bound2: 2 * (2 ^ (2 * k) mod M) <= 2 ^ (k + 1) - (muLow + 2^k)). + + Context (n:nat) (Hn_nz: n <> 0%nat) (n_le_k : Z.of_nat n <= k). + Context (nout : nat) (Hnout : nout = 2%nat). + Let w := weight k 1. + Local Lemma k_range : 0 < 1 <= k. Proof. omega. Qed. + Let props : @weight_properties w := wprops k 1 k_range. + + Hint Rewrite Positional.eval_nil Positional.eval_snoc : push_eval. + + Definition low (t : list Z) : Z := nth_default 0 t 0. + Definition high (t : list Z) : Z := nth_default 0 t 1. + Definition represents (t : list Z) (x : Z) := + t = [x mod 2^k; x / 2^k] /\ 0 <= x < 2^k * 2^k. + + Lemma represents_eq t x : + represents t x -> t = [x mod 2^k; x / 2^k]. + Proof. cbv [represents]; tauto. Qed. + + Lemma represents_length t x : represents t x -> length t = 2%nat. + Proof. cbv [represents]; intuition. subst t; reflexivity. Qed. + + Lemma represents_low t x : + represents t x -> low t = x mod 2^k. + Proof. cbv [represents]; intros; rewrite (represents_eq t x) by auto; reflexivity. Qed. + + Lemma represents_high t x : + represents t x -> high t = x / 2^k. + Proof. cbv [represents]; intros; rewrite (represents_eq t x) by auto; reflexivity. Qed. + + Lemma represents_low_range t x : + represents t x -> 0 <= x mod 2^k < 2^k. + Proof. auto with zarith. Qed. + + Lemma represents_high_range t x : + represents t x -> 0 <= x / 2^k < 2^k. + Proof. + destruct 1 as [? [? ?] ]; intros. + auto using Z.div_lt_upper_bound with zarith. + Qed. + Hint Resolve represents_length represents_low_range represents_high_range. + + Lemma represents_range t x : + represents t x -> 0 <= x < 2^k*2^k. + Proof. cbv [represents]; tauto. Qed. + + Lemma represents_id x : + 0 <= x < 2^k * 2^k -> + represents [x mod 2^k; x / 2^k] x. + Proof. + intros; cbv [represents]; autorewrite with cancel_pair. + Z.rewrite_mod_small; tauto. + Qed. + + Local Ltac push_rep := + repeat match goal with + | H : represents ?t ?x |- _ => unique pose proof (represents_low_range _ _ H) + | H : represents ?t ?x |- _ => unique pose proof (represents_high_range _ _ H) + | H : represents ?t ?x |- _ => rewrite (represents_low t x) in * by assumption + | H : represents ?t ?x |- _ => rewrite (represents_high t x) in * by assumption + end. + + Definition shiftr (t : list Z) (n : Z) : list Z := + [Z.rshi (2^k) (high t) (low t) n; Z.rshi (2^k) 0 (high t) n]. + + Lemma shiftr_represents a i x : + represents a x -> + 0 <= i <= k -> + represents (shiftr a i) (x / 2 ^ i). + Proof. + cbv [shiftr]; intros; push_rep. + match goal with H : _ |- _ => pose proof (represents_range _ _ H) end. + assert (0 < 2 ^ i) by auto with zarith. + assert (x < 2 ^ i * 2 ^ k * 2 ^ k) by nia. + assert (0 <= x / 2 ^ k / 2 ^ i < 2 ^ k) by + (split; Z.zero_bounds; auto using Z.div_lt_upper_bound with zarith). + repeat match goal with + | _ => rewrite Z.rshi_correct by auto with zarith + | _ => rewrite <-Z.div_mod''' by auto with zarith + | _ => progress autorewrite with zsimplify_fast + | _ => progress Z.rewrite_mod_small + | |- context [represents [(?a / ?c) mod ?b; ?a / ?b / ?c] ] => + rewrite (Z.div_div_comm a b c) by auto with zarith + | _ => solve [auto using represents_id, Z.div_lt_upper_bound with zarith lia] + end. + Qed. + + Context (Hw : forall i, w i = (2 ^ k) ^ Z.of_nat i). + Ltac change_weight := rewrite !Hw, ?Z.pow_0_r, ?Z.pow_1_r, ?Z.pow_2_r. + + Definition wideadd t1 t2 := fst (Rows.add w 2 t1 t2). + (* TODO: use this definition once issue #352 is resolved *) + (* Definition widesub t1 t2 := fst (Rows.sub w 2 t1 t2). *) + Definition widesub (t1 t2 : list Z) := + let t1_0 := hd 0 t1 in + let t1_1 := hd 0 (tl t1) in + let t2_0 := hd 0 t2 in + let t2_1 := hd 0 (tl t2) in + dlet_nd x0 := Z.sub_get_borrow_full (2^k) t1_0 t2_0 in + dlet_nd x1 := Z.sub_with_get_borrow_full (2^k) (snd x0) t1_1 t2_1 in + [fst x0; fst x1]. + Definition widemul := BaseConversion.widemul_inlined k n nout. + + Lemma partition_represents x : + 0 <= x < 2^k*2^k -> + represents (Rows.partition w 2 x) x. + Proof. + intros; cbn. change_weight. + Z.rewrite_mod_small. + autorewrite with zsimplify_fast. + auto using represents_id. + Qed. + + Lemma eval_represents t x : + represents t x -> eval w 2 t = x. + Proof. + intros; rewrite (represents_eq t x) by assumption. + cbn. change_weight; push_rep. + autorewrite with zsimplify. reflexivity. + Qed. + + Ltac wide_op partitions_pf := + repeat match goal with + | _ => rewrite partitions_pf by eauto + | _ => rewrite partitions_pf by auto with zarith + | _ => erewrite eval_represents by eauto + | _ => solve [auto using partition_represents, represents_id] + end. + + Lemma wideadd_represents t1 t2 x y : + represents t1 x -> + represents t2 y -> + 0 <= x + y < 2^k*2^k -> + represents (wideadd t1 t2) (x + y). + Proof. intros; cbv [wideadd]. wide_op Rows.add_partitions. Qed. + + Lemma widesub_represents t1 t2 x y : + represents t1 x -> + represents t2 y -> + 0 <= x - y < 2^k*2^k -> + represents (widesub t1 t2) (x - y). + Proof. + intros; cbv [widesub Let_In]. + rewrite (represents_eq t1 x) by assumption. + rewrite (represents_eq t2 y) by assumption. + cbn [hd tl]. + autorewrite with to_div_mod. + pull_Zmod. + match goal with |- represents [?m; ?d] ?x => + replace d with (x / 2 ^ k); [solve [auto using represents_id] |] end. + rewrite <-(Z.mod_small ((x - y) / 2^k) (2^k)) by (split; try apply Z.div_lt_upper_bound; Z.zero_bounds). + f_equal. + transitivity ((x mod 2^k - y mod 2^k + 2^k * (x / 2 ^ k) - 2^k * (y / 2^k)) / 2^k). { + rewrite (Z.div_mod x (2^k)) at 1 by auto using Z.pow_nonzero with omega. + rewrite (Z.div_mod y (2^k)) at 1 by auto using Z.pow_nonzero with omega. + f_equal. ring. } + autorewrite with zsimplify. + ring. + Qed. + (* Works with Rows.sub-based widesub definition + Proof. intros; cbv [widesub]. wide_op Rows.sub_partitions. Qed. + *) + + Lemma widemul_represents x y : + 0 <= x < 2^k -> + 0 <= y < 2^k -> + represents (widemul x y) (x * y). + Proof. + intros; cbv [widemul]. + assert (0 <= x * y < 2^k*2^k) by auto with zarith. + wide_op BaseConversion.widemul_correct. + Qed. + + Definition mul_high (a b : list Z) a0b1 : list Z := + dlet_nd a0b0 := widemul (low a) (low b) in + dlet_nd ab := wideadd [high a0b0; high b] [low b; 0] in + wideadd ab [a0b1; 0]. + + Lemma mul_high_idea d a b a0 a1 b0 b1 : + d <> 0 -> + a = d * a1 + a0 -> + b = d * b1 + b0 -> + (a * b) / d = a0 * b0 / d + d * a1 * b1 + a1 * b0 + a0 * b1. + Proof. + intros. subst a b. autorewrite with push_Zmul. + ring_simplify_subterms. rewrite Z.pow_2_r. + rewrite Z.div_add_exact by (push_Zmod; autorewrite with zsimplify; omega). + repeat match goal with + | |- context [d * ?a * ?b * ?c] => + replace (d * a * b * c) with (a * b * c * d) by ring + | |- context [d * ?a * ?b] => + replace (d * a * b) with (a * b * d) by ring + end. + rewrite !Z.div_add by omega. + autorewrite with zsimplify. + rewrite (Z.mul_comm a0 b0). + ring_simplify. ring. + Qed. + + Lemma represents_trans t x y: + represents t y -> y = x -> + represents t x. + Proof. congruence. Qed. + + Lemma represents_add x y : + 0 <= x < 2 ^ k -> + 0 <= y < 2 ^ k -> + represents [x;y] (x + 2^k*y). + Proof. + intros; cbv [represents]; autorewrite with zsimplify. + repeat split; (reflexivity || nia). + Qed. + + Lemma represents_small x : + 0 <= x < 2^k -> + represents [x; 0] x. + Proof. + intros. + eapply represents_trans. + { eauto using represents_add with zarith. } + { ring. } + Qed. + + Lemma mul_high_represents a b x y a0b1 : + represents a x -> + represents b y -> + 2^k <= x < 2^(k+1) -> + 0 <= y < 2^(k+1) -> + a0b1 = x mod 2^k * (y / 2^k) -> + represents (mul_high a b a0b1) ((x * y) / 2^k). + Proof. + cbv [mul_high Let_In]; rewrite Z.pow_add_r, Z.pow_1_r by omega; intros. + assert (4 <= 2 ^ k) by (transitivity (Z.pow 2 2); auto with zarith). + assert (0 <= x * y / 2^k < 2^k*2^k) by (Z.div_mod_to_quot_rem; nia). + + rewrite mul_high_idea with (a:=x) (b:=y) (a0 := low a) (a1 := high a) (b0 := low b) (b1 := high b) in * + by (push_rep; Z.div_mod_to_quot_rem; lia). + + push_rep. subst a0b1. + assert (y / 2 ^ k < 2) by (apply Z.div_lt_upper_bound; omega). + replace (x / 2 ^ k) with 1 in * by (rewrite Z.div_between_1; lia). + autorewrite with zsimplify_fast in *. + + eapply represents_trans. + { repeat (apply wideadd_represents; + [ | apply represents_small; Z.div_mod_to_quot_rem; nia| ]). + erewrite represents_high; [ | apply widemul_represents; solve [ auto with zarith ] ]. + { apply represents_add; try reflexivity; solve [auto with zarith]. } + { match goal with H : 0 <= ?x + ?y < ?z |- 0 <= ?x < ?z => + split; [ solve [Z.zero_bounds] | ]; + eapply Z.le_lt_trans with (m:= x + y); nia + end. } + { omega. } } + { ring. } + Qed. + + Definition cond_sub1 (a : list Z) y : Z := + dlet_nd maybe_y := Z.zselect (Z.cc_l (high a)) 0 y in + dlet_nd diff := Z.sub_get_borrow_full (2^k) (low a) maybe_y in + fst diff. + + Lemma cc_l_only_bit : forall x s, 0 <= x < 2 * s -> Z.cc_l (x / s) = 0 <-> x < s. + Proof. + cbv [Z.cc_l]; intros. + rewrite Z.div_between_0_if by omega. + break_match; Z.ltb_to_lt; Z.rewrite_mod_small; omega. + Qed. + + Lemma cond_sub1_correct a x y : + represents a x -> + 0 <= x < 2 * y -> + 0 <= y < 2 ^ k -> + cond_sub1 a y = if (x <? 2 ^ k) then x else x - y. + Proof. + intros; cbv [cond_sub1 Let_In]. rewrite Z.zselect_correct. push_rep. + break_match; Z.ltb_to_lt; rewrite cc_l_only_bit in *; try omega; + autorewrite with zsimplify_fast to_div_mod pull_Zmod; auto with zarith. + Qed. + + Definition cond_sub2 x y := Z.add_modulo x 0 y. + Lemma cond_sub2_correct x y : + cond_sub2 x y = if (x <? y) then x else x - y. + Proof. + cbv [cond_sub2]. rewrite Z.add_modulo_correct. + autorewrite with zsimplify_fast. break_match; Z.ltb_to_lt; omega. + Qed. + + Section Defn. + Context (xLow xHigh : Z) (xLow_bounds : 0 <= xLow < 2^k) (xHigh_bounds : 0 <= xHigh < M). + Let xt := [xLow; xHigh]. + Let x := xLow + 2^k * xHigh. + + Lemma x_rep : represents xt x. + Proof. cbv [represents]; subst xt x; autorewrite with cancel_pair zsimplify; repeat split; nia. Qed. + + Lemma x_bounds : 0 <= x < M * 2 ^ k. + Proof. subst x; nia. Qed. + + Definition muSelect := Z.zselect (Z.cc_m (2 ^ k) xHigh) 0 muLow. + + Local Hint Resolve Z.div_nonneg Z.div_lt_upper_bound. + Local Hint Resolve shiftr_represents mul_high_represents widemul_represents widesub_represents + cond_sub1_correct cond_sub2_correct represents_low represents_add. + + Lemma muSelect_correct : + muSelect = (2 ^ (2 * k) / M) mod 2 ^ k * ((x / 2 ^ (k - 1)) / 2 ^ k). + Proof. + (* assertions to help arith tactics *) + pose proof x_bounds. + assert (2^k * M < 2 ^ (2*k)) by (rewrite <-Z.add_diag, Z.pow_add_r; nia). + assert (0 <= x / (2 ^ k * (2 ^ k / 2)) < 2) by (Z.div_mod_to_quot_rem; auto with nia). + assert (0 < 2 ^ k / 2) by Z.zero_bounds. + assert (2 ^ (k - 1) <> 0) by auto with zarith. + assert (2 < 2 ^ k) by (eapply Z.le_lt_trans with (m:=2 ^ 1); auto with zarith). + + cbv [muSelect]. rewrite <-muLow_eq. + rewrite Z.zselect_correct, Z.cc_m_eq by auto with zarith. + replace xHigh with (x / 2^k) by (subst x; autorewrite with zsimplify; lia). + autorewrite with pull_Zdiv push_Zpow. + rewrite (Z.mul_comm (2 ^ k / 2)). + break_match; [ ring | ]. + match goal with H : 0 <= ?x < 2, H' : ?x <> 0 |- _ => replace x with 1 by omega end. + autorewrite with zsimplify; reflexivity. + Qed. + + Lemma mu_rep : represents [muLow; 1] (2 ^ (2 * k) / M). + Proof. rewrite <-muLow_eq. eapply represents_trans; auto with zarith. Qed. + + Derive barrett_reduce + SuchThat (barrett_reduce = x mod M) + As barrett_reduce_correct. + Proof. + erewrite <-reduce_correct with (rep:=represents) (muSelect:=muSelect) (k0:=k) (mut:=[muLow;1]) (xt0:=xt) + by (auto using x_bounds, muSelect_correct, x_rep, mu_rep; omega). + subst barrett_reduce. reflexivity. + Qed. + End Defn. + End BarrettReduction. + + (* all the list operations from for_reification.ident *) + Strategy 100 [length seq repeat combine map flat_map partition app rev fold_right update_nth nth_default ]. + Strategy -10 [barrett_reduce reduce]. + + Derive barrett_red_gen + SuchThat (forall (k M muLow : Z) + (n nout: nat) + (xLow xHigh : Z), + Interp (t:=reify_type_of barrett_reduce) + barrett_red_gen k M muLow n nout xLow xHigh + = barrett_reduce k M muLow n nout xLow xHigh) + As barrett_red_gen_correct. + Proof. Time cache_reify (). Time Qed. (* Now only takes ~5-10 s, because we set up [Strategy] commands correctly *) + Module Export ReifyHints. + Global Hint Extern 1 (_ = barrett_reduce _ _ _ _ _ _ _) => simple apply barrett_red_gen_correct : reify_gen_cache. + End ReifyHints. + + Section rbarrett_red. + Context (M : Z) + (machine_wordsize : Z). + + Let bound := Some r[0 ~> (2^machine_wordsize - 1)%Z]%zrange. + Let mu := (2 ^ (2 * machine_wordsize)) / M. + Let muLow := mu mod (2 ^ machine_wordsize). + Let consts_list := [M; muLow]. + + Definition relax_zrange_of_machine_wordsize' + := relax_zrange_gen [1; machine_wordsize / 2; machine_wordsize; 2 * machine_wordsize]%Z. + (* TODO: This is a special-case hack to let the prefancy pass have enough bounds information. *) + Definition relax_zrange_of_machine_wordsize r : option zrange := + if (lower r =? 0) && (upper r =? 2) + then Some r + else relax_zrange_of_machine_wordsize' r. + + Lemma relax_zrange_good (r r' z : zrange) : + (z <=? r)%zrange = true -> + relax_zrange_of_machine_wordsize r = Some r' -> (z <=? r')%zrange = true. + Proof. + cbv [relax_zrange_of_machine_wordsize]; break_match; [congruence|]. + eauto using relax_zrange_gen_good. + Qed. + + Local Arguments relax_zrange_of_machine_wordsize / . + + Let relax_zrange := relax_zrange_of_machine_wordsize. + + Definition check_args {T} (res : Pipeline.ErrorT T) + : Pipeline.ErrorT T + := if (mu / (2 ^ machine_wordsize) =? 0) + then Error (Pipeline.Values_not_provably_distinctZ "mu / 2 ^ k ≠ 0" (mu / 2 ^ machine_wordsize) 0) + else if (machine_wordsize <? 2) + then Error (Pipeline.Value_not_leZ "~ (2 <=k)" 2 machine_wordsize) + else if (negb (Z.log2 M + 1 =? machine_wordsize)) + then Error + (Pipeline.Values_not_provably_equalZ "log2(M)+1 != k" (Z.log2 M + 1) machine_wordsize) + else if (2 ^ (machine_wordsize + 1) - mu <? 2 * (2 ^ (2 * machine_wordsize) mod M)) + then Error + (Pipeline.Value_not_leZ "~ (2 * (2 ^ (2*k) mod M) <= 2^(k + 1) - mu)" + (2 * (2 ^ (2*machine_wordsize) mod M)) + (2^(machine_wordsize + 1) - mu)) + else res. + + Let fancy_args + := (Some {| Pipeline.invert_low log2wordsize := invert_low log2wordsize consts_list; + Pipeline.invert_high log2wordsize := invert_high log2wordsize consts_list |}). + + Notation BoundsPipeline_correct in_bounds out_bounds op + := (fun rv (rop : Expr (reify_type_of op)) Hrop + => @Pipeline.BoundsPipeline_correct_trans + false (* subst01 *) fancy_args + relax_zrange + relax_zrange_good + _ + rop + in_bounds + out_bounds + op + Hrop rv) + (only parsing). + + Definition rbarrett_red_correct + := BoundsPipeline_correct + (bound, (bound, tt)) + bound + (barrett_reduce machine_wordsize M muLow 2 2). + + Notation type_of_strip_3arrow := ((fun (d : Prop) (_ : forall A B C, d) => d) _). + Definition rbarrett_red_correctT rv : Prop + := type_of_strip_3arrow (@rbarrett_red_correct rv). + End rbarrett_red. +End BarrettReduction. + +Ltac solve_rbarrett_red := solve_rop BarrettReduction.rbarrett_red_correct. +Ltac solve_rbarrett_red_nocache := solve_rop_nocache BarrettReduction.rbarrett_red_correct. + +Module MontgomeryReduction. + Section MontRed'. + Context (N R N' R' : Z). + Context (HN_range : 0 <= N < R) (HN'_range : 0 <= N' < R) (HN_nz : N <> 0) (R_gt_1 : R > 1) + (N'_good : Z.equiv_modulo R (N*N') (-1)) (R'_good: Z.equiv_modulo N (R*R') 1). + + Context (Zlog2R : Z) . + Let w : nat -> Z := weight Zlog2R 1. + Context (n:nat) (Hn_nz: n <> 0%nat) (n_good : Zlog2R mod Z.of_nat n = 0). + Context (R_big_enough : n <= Zlog2R) + (R_two_pow : 2^Zlog2R = R). + Let w_mul : nat -> Z := weight (Zlog2R / n) 1. + Context (nout : nat) (Hnout : nout = 2%nat). + + Definition montred' (lo_hi : (Z * Z)) := + dlet_nd y := nth_default 0 (BaseConversion.widemul_inlined Zlog2R n nout (fst lo_hi) N') 0 in + dlet_nd t1_t2 := (BaseConversion.widemul_inlined_reverse Zlog2R n nout N y) in + dlet_nd sum_carry := Rows.add (weight Zlog2R 1) 2 [fst lo_hi; snd lo_hi] t1_t2 in + dlet_nd y' := Z.zselect (snd sum_carry) 0 N in + dlet_nd lo''_carry := Z.sub_get_borrow_full R (nth_default 0 (fst sum_carry) 1) y' in + Z.add_modulo (fst lo''_carry) 0 N. + + Local Lemma Hw : forall i, w i = R ^ Z.of_nat i. + Proof. + clear -R_big_enough R_two_pow; cbv [w weight]; intro. + autorewrite with zsimplify. + rewrite Z.pow_mul_r, R_two_pow by omega; reflexivity. + Qed. + + Local Ltac change_weight := rewrite !Hw, ?Z.pow_0_r, ?Z.pow_1_r, ?Z.pow_2_r, ?Z.pow_1_l in *. + Local Ltac solve_range := + repeat match goal with + | _ => progress change_weight + | |- context [?a mod ?b] => unique pose proof (Z.mod_pos_bound a b ltac:(omega)) + | |- 0 <= _ => progress Z.zero_bounds + | |- 0 <= _ * _ < _ * _ => + split; [ solve [Z.zero_bounds] | apply Z.mul_lt_mono_nonneg; omega ] + | _ => solve [auto] + | _ => omega + end. + + Local Lemma eval2 x y : eval w 2 [x;y] = x + R * y. + Proof. cbn. change_weight. ring. Qed. + + Hint Rewrite BaseConversion.widemul_inlined_reverse_correct BaseConversion.widemul_inlined_correct + using (autorewrite with widemul push_nth_default; solve [solve_range]) : widemul. + + Lemma montred'_eq lo_hi T (HT_range: 0 <= T < R * N) + (Hlo: fst lo_hi = T mod R) (Hhi: snd lo_hi = T / R): + montred' lo_hi = reduce_via_partial N R N' T. + Proof. + rewrite <-reduce_via_partial_alt_eq by nia. + cbv [montred' partial_reduce_alt reduce_via_partial_alt prereduce Let_In]. + rewrite Hlo, Hhi. + assert (0 <= (T mod R) * N' < w 2) by (solve_range). + + autorewrite with widemul. + rewrite Rows.add_partitions, Rows.add_div by (distr_length; apply wprops; omega). + rewrite R_two_pow. + cbv [Rows.partition seq]. rewrite !eval2. + autorewrite with push_nth_default push_map. + autorewrite with to_div_mod. rewrite ?Z.zselect_correct, ?Z.add_modulo_correct. + change_weight. + + (* pull out value before last modular reduction *) + match goal with |- (if (?n <=? ?x)%Z then ?x - ?n else ?x) = (if (?n <=? ?y) then ?y - ?n else ?y)%Z => + let P := fresh "H" in assert (x = y) as P; [|rewrite P; reflexivity] end. + + autorewrite with zsimplify. + rewrite (Z.mul_comm (((T mod R) * N') mod R) N) in *. + break_match; try reflexivity; Z.ltb_to_lt; rewrite Z.div_small_iff in * by omega; + repeat match goal with + | _ => progress autorewrite with zsimplify_fast + | |- context [?x mod (R * R)] => + unique pose proof (Z.mod_pos_bound x (R * R)); + try rewrite (Z.mod_small x (R * R)) in * by Z.rewrite_mod_small_solver + | _ => omega + | _ => progress Z.rewrite_mod_small + end. + Qed. + + Lemma montred'_correct lo_hi T (HT_range: 0 <= T < R * N) + (Hlo: fst lo_hi = T mod R) (Hhi: snd lo_hi = T / R): montred' lo_hi = (T * R') mod N. + Proof. + erewrite montred'_eq by eauto. + apply Z.equiv_modulo_mod_small; auto using reduce_via_partial_correct. + replace 0 with (Z.min 0 (R-N)) by (apply Z.min_l; omega). + apply reduce_via_partial_in_range; omega. + Qed. + End MontRed'. + + Derive montred_gen + SuchThat (forall (N R N' : Z) + (Zlog2R : Z) + (n nout: nat) + (lo_hi : Z * Z), + Interp (t:=reify_type_of montred') + montred_gen N R N' Zlog2R n nout lo_hi + = montred' N R N' Zlog2R n nout lo_hi) + As montred_gen_correct. + Proof. Time cache_reify (). Time Qed. + Module Export ReifyHints. + Global Hint Extern 1 (_ = montred' _ _ _ _ _ _ _) => simple apply montred_gen_correct : reify_gen_cache. + End ReifyHints. + + Section rmontred. + Context (N R N' : Z) + (machine_wordsize : Z). + + Let bound := Some r[0 ~> (2^machine_wordsize - 1)%Z]%zrange. + Let consts_list := [N; N']. + + Definition relax_zrange_of_machine_wordsize + := relax_zrange_gen [1; machine_wordsize / 2; machine_wordsize; 2 * machine_wordsize]%Z. + Local Arguments relax_zrange_of_machine_wordsize / . + + Let relax_zrange := relax_zrange_of_machine_wordsize. + + Definition check_args {T} (res : Pipeline.ErrorT T) + : Pipeline.ErrorT T + := res. (* TODO: this should actually check stuff that corresponds with preconditions of montred'_correct *) + + Let fancy_args + := (Some {| Pipeline.invert_low log2wordsize := invert_low log2wordsize consts_list; + Pipeline.invert_high log2wordsize := invert_high log2wordsize consts_list |}). + + Notation BoundsPipeline_correct in_bounds out_bounds op + := (fun rv (rop : Expr (reify_type_of op)) Hrop + => @Pipeline.BoundsPipeline_correct_trans + false (* subst01 *) fancy_args + relax_zrange + (relax_zrange_gen_good _) + _ + rop + in_bounds + out_bounds + op + Hrop rv) + (only parsing). + + Definition rmontred_correct + := BoundsPipeline_correct + ((bound, bound), tt) + bound + (montred' N R N' (Z.log2 R) 2 2). + + Notation type_of_strip_3arrow := ((fun (d : Prop) (_ : forall A B C, d) => d) _). + Definition rmontred_correctT rv : Prop + := type_of_strip_3arrow (@rmontred_correct rv). + End rmontred. +End MontgomeryReduction. + +Ltac solve_rmontred := solve_rop MontgomeryReduction.rmontred_correct. +Ltac solve_rmontred_nocache := solve_rop_nocache MontgomeryReduction.rmontred_correct. + + +Time Compute + (Pipeline.BoundsPipeline + true None (relax_zrange_gen [64; 128]) + ltac:(let r := Reify (to_associational (weight 51 1) 5) in + exact r) + (Some (repeat (@None _) 5), tt) + ZRange.type.base.option.None). + +Time Compute + (Pipeline.BoundsPipeline + true None (relax_zrange_gen [64; 128]) + ltac:(let r := Reify (scmul (weight 51 1) 5) in + exact r) + (None, (Some (repeat (@None _) 5), tt)) + ZRange.type.base.option.None). diff --git a/src/Experiments/NewPipeline/Toplevel2.v b/src/Experiments/NewPipeline/Toplevel2.v new file mode 100644 index 000000000..4cba170bd --- /dev/null +++ b/src/Experiments/NewPipeline/Toplevel2.v @@ -0,0 +1,3395 @@ +Require Import Coq.ZArith.ZArith Coq.micromega.Lia. +Require Import Coq.derive.Derive. +Require Import Coq.Bool.Bool. +Require Import Coq.Strings.String. +Require Import Coq.Lists.List. +Require Crypto.Util.Strings.String. +Require Import Crypto.Util.Strings.Decimal. +Require Import Crypto.Util.Strings.HexString. +Require Import QArith.QArith_base QArith.Qround Crypto.Util.QUtil. +Require Import Crypto.Algebra.Ring Crypto.Util.Decidable.Bool2Prop. +Require Import Crypto.Algebra.Ring. +Require Import Crypto.Algebra.SubsetoidRing. +Require Import Crypto.Util.ZRange. +Require Import Crypto.Util.ListUtil.FoldBool. +Require Import Crypto.Util.LetIn. +Require Import Crypto.Arithmetic.PrimeFieldTheorems. +Require Import Crypto.Util.ZUtil.Tactics.LtbToLt. +Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo. +Require Import Crypto.Util.Tactics.SplitInContext. +Require Import Crypto.Util.Tactics.SubstEvars. +Require Import Crypto.Util.Tactics.DestructHead. +Require Import Crypto.Util.Tuple. +Require Import Crypto.Util.ListUtil Coq.Lists.List. +Require Import Crypto.Util.Equality. +Require Import Crypto.Util.Tactics.GetGoal. +Require Import Crypto.Arithmetic.BarrettReduction.Generalized. +Require Import Crypto.Util.Tactics.UniquePose. +Require Import Crypto.Util.ZUtil.Rshi. +Require Import Crypto.Util.Option. +Require Import Crypto.Util.Tactics.BreakMatch. +Require Import Crypto.Util.Tactics.SpecializeBy. +Require Import Crypto.Util.ZUtil. +Require Import Crypto.Util.ZUtil.Zselect. +Require Import Crypto.Util.ZUtil.AddModulo. +Require Import Crypto.Util.ZUtil.CC. +Require Import Crypto.Arithmetic.MontgomeryReduction.Definition. +Require Import Crypto.Arithmetic.MontgomeryReduction.Proofs. +Require Import Crypto.Util.ErrorT. +Require Import Crypto.Util.Strings.Show. +Require Import Crypto.Util.ZRange.Show. +Require Import Crypto.Experiments.NewPipeline.Arithmetic. +Require Crypto.Experiments.NewPipeline.Language. +Require Crypto.Experiments.NewPipeline.UnderLets. +Require Crypto.Experiments.NewPipeline.AbstractInterpretation. +Require Crypto.Experiments.NewPipeline.AbstractInterpretationProofs. +Require Crypto.Experiments.NewPipeline.Rewriter. +Require Crypto.Experiments.NewPipeline.MiscCompilerPasses. +Require Crypto.Experiments.NewPipeline.CStringification. +Require Export Crypto.Experiments.NewPipeline.Toplevel1. +Require Import Crypto.Util.Notations. +Import ListNotations. Local Open Scope Z_scope. + +Import Associational Positional. + +Import + Crypto.Experiments.NewPipeline.Language + Crypto.Experiments.NewPipeline.UnderLets + Crypto.Experiments.NewPipeline.AbstractInterpretation + Crypto.Experiments.NewPipeline.AbstractInterpretationProofs + Crypto.Experiments.NewPipeline.Rewriter + Crypto.Experiments.NewPipeline.MiscCompilerPasses + Crypto.Experiments.NewPipeline.CStringification. + +Import + Language.Compilers + UnderLets.Compilers + AbstractInterpretation.Compilers + AbstractInterpretationProofs.Compilers + Rewriter.Compilers + MiscCompilerPasses.Compilers + CStringification.Compilers. + +Import Compilers.defaults. +Local Coercion Z.of_nat : nat >-> Z. +Local Coercion QArith_base.inject_Z : Z >-> Q. +Notation "x" := (expr.Var x) (only printing, at level 9) : expr_scope. + +Import UnsaturatedSolinas. + +Module X25519_64. + Definition n := 5%nat. + Definition s := 2^255. + Definition c := [(1, 19)]. + Definition machine_wordsize := 64. + Local Notation tight_bounds := (tight_bounds n s c). + Local Notation loose_bounds := (loose_bounds n s c). + Local Notation prime_bound := (prime_bound s c). + + Derive base_51_relax + SuchThat (rrelax_correctT n s c machine_wordsize base_51_relax) + As base_51_relax_correct. + Proof. Time solve_rrelax machine_wordsize. Time Qed. + Derive base_51_carry_mul + SuchThat (rcarry_mul_correctT n s c machine_wordsize base_51_carry_mul) + As base_51_carry_mul_correct. + Proof. Time solve_rcarry_mul machine_wordsize. Time Qed. + Derive base_51_carry + SuchThat (rcarry_correctT n s c machine_wordsize base_51_carry) + As base_51_carry_correct. + Proof. Time solve_rcarry machine_wordsize. Time Qed. + Derive base_51_add + SuchThat (radd_correctT n s c machine_wordsize base_51_add) + As base_51_add_correct. + Proof. Time solve_radd machine_wordsize. Time Qed. + Derive base_51_sub + SuchThat (rsub_correctT n s c machine_wordsize base_51_sub) + As base_51_sub_correct. + Proof. Time solve_rsub machine_wordsize. Time Qed. + Derive base_51_opp + SuchThat (ropp_correctT n s c machine_wordsize base_51_opp) + As base_51_opp_correct. + Proof. Time solve_ropp machine_wordsize. Time Qed. + Derive base_51_encode + SuchThat (rencode_correctT n s c machine_wordsize base_51_encode) + As base_51_encode_correct. + Proof. Time solve_rencode machine_wordsize. Time Qed. + Derive base_51_zero + SuchThat (rzero_correctT n s c machine_wordsize base_51_zero) + As base_51_zero_correct. + Proof. Time solve_rzero machine_wordsize. Time Qed. + Derive base_51_one + SuchThat (rone_correctT n s c machine_wordsize base_51_one) + As base_51_one_correct. + Proof. Time solve_rone machine_wordsize. Time Qed. + Lemma base_51_curve_good + : check_args n s c machine_wordsize (Success tt) = Success tt. + Proof. vm_compute; reflexivity. Qed. + + Definition base_51_good : GoodT n s c + := Good n s c machine_wordsize + base_51_curve_good + base_51_carry_mul_correct + base_51_carry_correct + base_51_relax_correct + base_51_add_correct + base_51_sub_correct + base_51_opp_correct + base_51_zero_correct + base_51_one_correct + base_51_encode_correct. + + Print Assumptions base_51_good. + Import PrintingNotations. + Set Printing Width 80. + Open Scope string_scope. + Print base_51_carry_mul. +(*base_51_carry_mul = +fun var : type -> Type => +(λ x x0 : var (type.base (base.type.list (base.type.type_base base.type.Z))), + expr_let x1 := (uint64)(x[[0]]) *₁₂₈ (uint64)(x0[[0]]) +₁₂₈ + ((uint64)(x[[1]]) *₁₂₈ ((uint64)(x0[[4]]) *₆₄ 19) +₁₂₈ + ((uint64)(x[[2]]) *₁₂₈ ((uint64)(x0[[3]]) *₆₄ 19) +₁₂₈ + ((uint64)(x[[3]]) *₁₂₈ ((uint64)(x0[[2]]) *₆₄ 19) +₁₂₈ + (uint64)(x[[4]]) *₁₂₈ ((uint64)(x0[[1]]) *₆₄ 19)))) in + expr_let x2 := (uint64)(x1 >> 51) +₁₂₈ + ((uint64)(x[[0]]) *₁₂₈ (uint64)(x0[[1]]) +₁₂₈ + ((uint64)(x[[1]]) *₁₂₈ (uint64)(x0[[0]]) +₁₂₈ + ((uint64)(x[[2]]) *₁₂₈ ((uint64)(x0[[4]]) *₆₄ 19) +₁₂₈ + ((uint64)(x[[3]]) *₁₂₈ ((uint64)(x0[[3]]) *₆₄ 19) +₁₂₈ + (uint64)(x[[4]]) *₁₂₈ ((uint64)(x0[[2]]) *₆₄ 19))))) in + expr_let x3 := (uint64)(x2 >> 51) +₁₂₈ + ((uint64)(x[[0]]) *₁₂₈ (uint64)(x0[[2]]) +₁₂₈ + ((uint64)(x[[1]]) *₁₂₈ (uint64)(x0[[1]]) +₁₂₈ + ((uint64)(x[[2]]) *₁₂₈ (uint64)(x0[[0]]) +₁₂₈ + ((uint64)(x[[3]]) *₁₂₈ ((uint64)(x0[[4]]) *₆₄ 19) +₁₂₈ + (uint64)(x[[4]]) *₁₂₈ ((uint64)(x0[[3]]) *₆₄ 19))))) in + expr_let x4 := (uint64)(x3 >> 51) +₁₂₈ + ((uint64)(x[[0]]) *₁₂₈ (uint64)(x0[[3]]) +₁₂₈ + ((uint64)(x[[1]]) *₁₂₈ (uint64)(x0[[2]]) +₁₂₈ + ((uint64)(x[[2]]) *₁₂₈ (uint64)(x0[[1]]) +₁₂₈ + ((uint64)(x[[3]]) *₁₂₈ (uint64)(x0[[0]]) +₁₂₈ + (uint64)(x[[4]]) *₁₂₈ ((uint64)(x0[[4]]) *₆₄ 19))))) in + expr_let x5 := (uint64)(x4 >> 51) +₁₂₈ + ((uint64)(x[[0]]) *₁₂₈ (uint64)(x0[[4]]) +₁₂₈ + ((uint64)(x[[1]]) *₁₂₈ (uint64)(x0[[3]]) +₁₂₈ + ((uint64)(x[[2]]) *₁₂₈ (uint64)(x0[[2]]) +₁₂₈ + ((uint64)(x[[3]]) *₁₂₈ (uint64)(x0[[1]]) +₁₂₈ + (uint64)(x[[4]]) *₁₂₈ (uint64)(x0[[0]]))))) in + expr_let x6 := ((uint64)(x1) & 2251799813685247) +₆₄ (uint64)(x5 >> 51) *₆₄ 19 in + expr_let x7 := (uint64)(x6 >> 51) +₆₄ ((uint64)(x2) & 2251799813685247) in + expr_let x8 := ((uint64)(x6) & 2251799813685247) in + expr_let x9 := ((uint64)(x7) & 2251799813685247) in + expr_let x10 := (uint64)(x7 >> 51) +₆₄ ((uint64)(x3) & 2251799813685247) in + expr_let x11 := ((uint64)(x4) & 2251799813685247) in + expr_let x12 := ((uint64)(x5) & 2251799813685247) in + [x8; x9; x10; x11; x12])%expr + : Expr + (type.base (base.type.list (base.type.type_base base.type.Z)) -> + type.base (base.type.list (base.type.type_base base.type.Z)) -> + type.base (base.type.list (base.type.type_base base.type.Z)))%ptype +*) + Print base_51_sub. + (* +base_51_sub = +fun var : type -> Type => +(λ x x0 : var (type.base (base.type.list (base.type.type_base base.type.Z))), + expr_let x1 := (4503599627370458 +₆₄ (uint64)(x[[0]])) -₆₄ (uint64)(x0[[0]]) in + expr_let x2 := (4503599627370494 +₆₄ (uint64)(x[[1]])) -₆₄ (uint64)(x0[[1]]) in + expr_let x3 := (4503599627370494 +₆₄ (uint64)(x[[2]])) -₆₄ (uint64)(x0[[2]]) in + expr_let x4 := (4503599627370494 +₆₄ (uint64)(x[[3]])) -₆₄ (uint64)(x0[[3]]) in + expr_let x5 := (4503599627370494 +₆₄ (uint64)(x[[4]])) -₆₄ (uint64)(x0[[4]]) in + [x1; x2; x3; x4; x5])%expr + : Expr + (type.base (base.type.list (base.type.type_base base.type.Z)) -> + type.base (base.type.list (base.type.type_base base.type.Z)) -> + type.base (base.type.list (base.type.type_base base.type.Z)))%ptype +*) + + Compute ToString.C.ToFunctionString + "fecarry_mul" base_51_carry_mul + None (Some loose_bounds, (Some loose_bounds, tt)). + (* +void fecarry_mul(uint64_t[5] x1, uint64_t[5] x2, uint64_t[5] x3) { + uint128_t x4 = (((uint128_t)(x1[0]) * (x2[0])) + (((uint128_t)(x1[1]) * ((x2[4]) * 0x13)) + (((uint128_t)(x1[2]) * ((x2[3]) * 0x13)) + (((uint128_t)(x1[3]) * ((x2[2]) * 0x13)) + ((uint128_t)(x1[4]) * ((x2[1]) * 0x13)))))); + uint128_t x5 = ((uint64_t)(x4 >> 51) + (((uint128_t)(x1[0]) * (x2[1])) + (((uint128_t)(x1[1]) * (x2[0])) + (((uint128_t)(x1[2]) * ((x2[4]) * 0x13)) + (((uint128_t)(x1[3]) * ((x2[3]) * 0x13)) + ((uint128_t)(x1[4]) * ((x2[2]) * 0x13))))))); + uint128_t x6 = ((uint64_t)(x5 >> 51) + (((uint128_t)(x1[0]) * (x2[2])) + (((uint128_t)(x1[1]) * (x2[1])) + (((uint128_t)(x1[2]) * (x2[0])) + (((uint128_t)(x1[3]) * ((x2[4]) * 0x13)) + ((uint128_t)(x1[4]) * ((x2[3]) * 0x13))))))); + uint128_t x7 = ((uint64_t)(x6 >> 51) + (((uint128_t)(x1[0]) * (x2[3])) + (((uint128_t)(x1[1]) * (x2[2])) + (((uint128_t)(x1[2]) * (x2[1])) + (((uint128_t)(x1[3]) * (x2[0])) + ((uint128_t)(x1[4]) * ((x2[4]) * 0x13))))))); + uint128_t x8 = ((uint64_t)(x7 >> 51) + (((uint128_t)(x1[0]) * (x2[4])) + (((uint128_t)(x1[1]) * (x2[3])) + (((uint128_t)(x1[2]) * (x2[2])) + (((uint128_t)(x1[3]) * (x2[1])) + ((uint128_t)(x1[4]) * (x2[0]))))))); + uint64_t x9 = ((uint64_t)(x4 & 0x7ffffffffffffUL) + ((uint64_t)(x8 >> 51) * 0x13)); + uint64_t x10 = ((x9 >> 51) + (uint64_t)(x5 & 0x7ffffffffffffUL)); + x3[0] = (x9 & 0x7ffffffffffffUL); + x3[1] = (x10 & 0x7ffffffffffffUL); + x3[2] = ((x10 >> 51) + (uint64_t)(x6 & 0x7ffffffffffffUL)); + x3[3] = (uint64_t)(x7 & 0x7ffffffffffffUL); + x3[4] = (uint64_t)(x8 & 0x7ffffffffffffUL); +} +*) + Compute ToString.C.ToFunctionString + "fesub" base_51_sub + None (Some tight_bounds, (Some tight_bounds, tt)). +(* +void fesub(uint64_t[5] x1, uint64_t[5] x2, uint64_t[5] x3) { + x3[0] = ((0xfffffffffffdaUL + (x1[0])) - (x2[0])); + x3[1] = ((0xffffffffffffeUL + (x1[1])) - (x2[1])); + x3[2] = ((0xffffffffffffeUL + (x1[2])) - (x2[2])); + x3[3] = ((0xffffffffffffeUL + (x1[3])) - (x2[3])); + x3[4] = ((0xffffffffffffeUL + (x1[4])) - (x2[4])); +} +*) +End X25519_64. + +Module P192_64. + Definition s := 2^192. + Definition c := [(2^64, 1); (1,1)]. + Definition machine_wordsize := 64. + + Derive mulmod + SuchThat (SaturatedSolinas.rmulmod_correctT s c machine_wordsize mulmod) + As mulmod_correct. + Proof. Time solve_rmulmod machine_wordsize. Time Qed. + + Import PrintingNotations. + Open Scope expr_scope. + Set Printing Width 100000. + Set Printing Depth 100000. + + Local Notation "'mul64' '(' x ',' y ')'" := + (#(Z_cast2 (uint64, _)%core) @ (#(Z_mul_split_concrete 18446744073709551616) @ x @ y))%expr (at level 50) : expr_scope. + Local Notation "'add64' '(' x ',' y ')'" := + (#(Z_cast2 (uint64, bool)%core) @ (#(Z_add_get_carry_concrete 18446744073709551616) @ x @ y))%expr (at level 50) : expr_scope. + Local Notation "'adc64' '(' c ',' x ',' y ')'" := + (#(Z_cast2 (uint64, bool)%core) @ (#(Z_add_with_get_carry_concrete 18446744073709551616) @ c @ x @ y))%expr (at level 50) : expr_scope. + Local Notation "'adx64' '(' c ',' x ',' y ')'" := + (#(Z_cast bool) @ (#Z_add_with_carry @ c @ x @ y))%expr (at level 50) : expr_scope. + + Print mulmod. +(* +mulmod = fun var : type -> Type => λ x x0 : var (type.base (base.type.list (base.type.type_base base.type.Z))), + expr_let x1 := mul64 ((uint64)(x[[2]]), (uint64)(x0[[2]])) in + expr_let x2 := mul64 ((uint64)(x[[2]]), (uint64)(x0[[1]])) in + expr_let x3 := mul64 ((uint64)(x[[2]]), (uint64)(x0[[0]])) in + expr_let x4 := mul64 ((uint64)(x[[1]]), (uint64)(x0[[2]])) in + expr_let x5 := mul64 ((uint64)(x[[1]]), (uint64)(x0[[1]])) in + expr_let x6 := mul64 ((uint64)(x[[1]]), (uint64)(x0[[0]])) in + expr_let x7 := mul64 ((uint64)(x[[0]]), (uint64)(x0[[2]])) in + expr_let x8 := mul64 ((uint64)(x[[0]]), (uint64)(x0[[1]])) in + expr_let x9 := mul64 ((uint64)(x[[0]]), (uint64)(x0[[0]])) in + expr_let x10 := add64 (x1₂, x9₂) in + expr_let x11 := adc64 (x10₂, 0, x8₂) in + expr_let x12 := add64 (x1₁, x10₁) in + expr_let x13 := adc64 (x12₂, 0, x11₁) in + expr_let x14 := add64 (x2₂, x12₁) in + expr_let x15 := adc64 (x14₂, 0, x13₁) in + expr_let x16 := add64 (x4₂, x14₁) in + expr_let x17 := adc64 (x16₂, x1₂, x15₁) in + expr_let x18 := add64 (x2₁, x16₁) in + expr_let x19 := adc64 (x18₂, x1₁, x17₁) in + expr_let x20 := add64 (x1₂, x9₁) in + expr_let x21 := adc64 (x20₂, x3₂, x18₁) in + expr_let x22 := adc64 (x21₂, x2₂, x19₁) in + expr_let x23 := add64 (x2₁, x20₁) in + expr_let x24 := adc64 (x23₂, x4₁, x21₁) in + expr_let x25 := adc64 (x24₂, x4₂, x22₁) in + expr_let x26 := add64 (x3₂, x23₁) in + expr_let x27 := adc64 (x26₂, x5₂, x24₁) in + expr_let x28 := adc64 (x27₂, x3₁, x25₁) in + expr_let x29 := add64 (x4₁, x26₁) in + expr_let x30 := adc64 (x29₂, x7₂, x27₁) in + expr_let x31 := adc64 (x30₂, x5₁, x28₁) in + expr_let x32 := add64 (x5₂, x29₁) in + expr_let x33 := adc64 (x32₂, x6₁, x30₁) in + expr_let x34 := adc64 (x33₂, x6₂, x31₁) in + expr_let x35 := add64 (x7₂, x32₁) in + expr_let x36 := adc64 (x35₂, x8₁, x33₁) in + expr_let x37 := adc64 (x36₂, x7₁, x34₁) in + [x35₁; x36₁; x37₁] + : Expr (type.base (base.type.list (base.type.type_base base.type.Z)) -> type.base (base.type.list (base.type.type_base base.type.Z)) -> type.base (base.type.list (base.type.type_base base.type.Z)))%ptype +*) + +End P192_64. + +Module PreFancy. + Section with_wordmax. + Context (log2wordmax : Z) (log2wordmax_pos : 1 < log2wordmax) (log2wordmax_even : log2wordmax mod 2 = 0). + Let wordmax := 2 ^ log2wordmax. + Lemma wordmax_gt_2 : 2 < wordmax. + Proof. + apply Z.le_lt_trans with (m:=2 ^ 1); [ reflexivity | ]. + apply Z.pow_lt_mono_r; omega. + Qed. + + Lemma wordmax_even : wordmax mod 2 = 0. + Proof. + replace 2 with (2 ^ 1) by reflexivity. + subst wordmax. apply Z.mod_same_pow; omega. + Qed. + + Let half_bits := log2wordmax / 2. + + Lemma half_bits_nonneg : 0 <= half_bits. + Proof. subst half_bits; Z.zero_bounds. Qed. + + Let wordmax_half_bits := 2 ^ half_bits. + + Lemma wordmax_half_bits_pos : 0 < wordmax_half_bits. + Proof. subst wordmax_half_bits half_bits. Z.zero_bounds. Qed. + + Lemma half_bits_squared : (wordmax_half_bits - 1) * (wordmax_half_bits - 1) <= wordmax - 1. + Proof. + pose proof wordmax_half_bits_pos. + subst wordmax_half_bits. + transitivity (2 ^ (half_bits + half_bits) - 2 * 2 ^ half_bits + 1). + { rewrite Z.pow_add_r by (subst half_bits; Z.zero_bounds). + autorewrite with push_Zmul; omega. } + { transitivity (wordmax - 2 * 2 ^ half_bits + 1); [ | lia]. + subst wordmax. + apply Z.add_le_mono_r. + apply Z.sub_le_mono_r. + apply Z.pow_le_mono_r; [ omega | ]. + rewrite Z.add_diag; subst half_bits. + apply BinInt.Z.mul_div_le; omega. } + Qed. + + Lemma wordmax_half_bits_le_wordmax : wordmax_half_bits <= wordmax. + Proof. + subst wordmax half_bits wordmax_half_bits. + apply Z.pow_le_mono_r; [lia|]. + apply Z.div_le_upper_bound; lia. + Qed. + + Lemma ones_half_bits : wordmax_half_bits - 1 = Z.ones half_bits. + Proof. + subst wordmax_half_bits. cbv [Z.ones]. + rewrite Z.shiftl_mul_pow2, <-Z.sub_1_r by auto using half_bits_nonneg. + lia. + Qed. + + Lemma wordmax_half_bits_squared : wordmax_half_bits * wordmax_half_bits = wordmax. + Proof. + subst wordmax half_bits wordmax_half_bits. + rewrite <-Z.pow_add_r by Z.zero_bounds. + rewrite Z.add_diag, Z.mul_div_eq by omega. + f_equal; lia. + Qed. + +(* + Section interp. + Context {interp_cast : zrange -> Z -> Z}. + Local Notation interp_scalar := (interp_scalar (interp_cast:=interp_cast)). + Local Notation interp_cast2 := (interp_cast2 (interp_cast:=interp_cast)). + Local Notation low x := (Z.land x (wordmax_half_bits - 1)). + Local Notation high x := (x >> half_bits). + Local Notation shift x imm := ((x << imm) mod wordmax). + + Definition interp_ident {s d} (idc : ident s d) : type.interp s -> type.interp d := + match idc with + | add imm => fun x => Z.add_get_carry_full wordmax (fst x) (shift (snd x) imm) + | addc imm => fun x => Z.add_with_get_carry_full wordmax (fst (fst x)) (snd (fst x)) (shift (snd x) imm) + | sub imm => fun x => Z.sub_get_borrow_full wordmax (fst x) (shift (snd x) imm) + | subb imm => fun x => Z.sub_with_get_borrow_full wordmax (fst (fst x)) (snd (fst x)) (shift (snd x) imm) + | mulll => fun x => low (fst x) * low (snd x) + | mullh => fun x => low (fst x) * high (snd x) + | mulhl => fun x => high (fst x) * low (snd x) + | mulhh => fun x => high (fst x) * high (snd x) + | rshi n => fun x => Z.rshi wordmax (fst x) (snd x) n + | selc => fun x => Z.zselect (fst (fst x)) (snd (fst x)) (snd x) + | selm => fun x => Z.zselect (Z.cc_m wordmax (fst (fst x))) (snd (fst x)) (snd x) + | sell => fun x => Z.zselect (Z.land (fst (fst x)) 1) (snd (fst x)) (snd x) + | addm => fun x => Z.add_modulo (fst (fst x)) (snd (fst x)) (snd x) + end. + + Fixpoint interp {t} (e : @expr type.interp ident t) : type.interp t := + match e with + | Scalar t s => interp_scalar s + | LetInAppIdentZ s d r idc x f => + interp (f (interp_cast r (interp_ident idc (interp_scalar x)))) + | LetInAppIdentZZ s d r idc x f => + interp (f (interp_cast2 r (interp_ident idc (interp_scalar x)))) + end. + End interp. + + Section proofs. + Context (dummy_arrow : forall s d, type.interp (s -> d)%ctype) (consts : list Z) + (consts_ok : forall x, In x consts -> 0 <= x <= wordmax - 1). + Context {interp_cast : zrange -> Z -> Z} {interp_cast_correct : forall r x, lower r <= x <= upper r -> interp_cast r x = x}. + Local Notation interp_scalar := (interp_scalar (interp_cast:=interp_cast)). + Local Notation interp_cast2 := (interp_cast2 (interp_cast:=interp_cast)). + + Local Notation word_range := (r[0~>wordmax-1])%zrange. + Local Notation half_word_range := (r[0~>wordmax_half_bits-1])%zrange. + Local Notation flag_range := (r[0~>1])%zrange. + + Definition in_word_range (r : zrange) := is_tighter_than_bool r word_range = true. + Definition in_flag_range (r : zrange) := is_tighter_than_bool r flag_range = true. + + Fixpoint get_range_var (t : type) : type.interp t -> range_type t := + match t with + | type.type_primitive type.Z => + fun x => {| lower := x; upper := x |} + | type.prod a b => + fun x => (get_range_var a (fst x), get_range_var b (snd x)) + | _ => fun _ => tt + end. + + Fixpoint get_range {t} (x : @scalar type.interp t) : range_type t := + match x with + | Var t v => get_range_var t v + | TT => tt + | Nil _ => tt + | Pair _ _ x y => (get_range x, get_range y) + | Cast r _ => r + | Cast2 r _ => r + | Fst _ _ p => fst (get_range p) + | Snd _ _ p => snd (get_range p) + | Shiftr n x => ZRange.map (fun y => Z.shiftr y n) (get_range x) + | Shiftl n x => ZRange.map (fun y => Z.shiftl y n) (get_range x) + | Land n x => r[0~>n]%zrange + | CC_m n x => ZRange.map (Z.cc_m n) (get_range x) + | Primitive type.Z x => {| lower := x; upper := x |} + | Primitive p x => tt + end. + + Fixpoint has_range {t} : range_type t -> type.interp t -> Prop := + match t with + | type.type_primitive type.Z => + fun r x => + lower r <= x <= upper r + | type.prod a b => + fun r x => + has_range (fst r) (fst x) /\ has_range (snd r) (snd x) + | _ => fun _ _ => True + end. + + Inductive ok_scalar : forall {t}, @scalar type.interp t -> Prop := + | sc_ok_var : forall t v, ok_scalar (Var t v) + | sc_ok_unit : ok_scalar TT + | sc_ok_nil : forall t, ok_scalar (Nil t) + | sc_ok_pair : forall A B x y, + @ok_scalar A x -> + @ok_scalar B y -> + ok_scalar (Pair x y) + | sc_ok_cast : forall r (x : scalar type.Z), + ok_scalar x -> + is_tighter_than_bool (get_range x) r = true -> + ok_scalar (Cast r x) + | sc_ok_cast2 : forall r (x : scalar (type.prod type.Z type.Z)), + ok_scalar x -> + is_tighter_than_bool (fst (get_range x)) (fst r) = true -> + is_tighter_than_bool (snd (get_range x)) (snd r) = true -> + ok_scalar (Cast2 r x) + | sc_ok_fst : + forall A B p, @ok_scalar (A * B) p -> ok_scalar (Fst p) + | sc_ok_snd : + forall A B p, @ok_scalar (A * B) p -> ok_scalar (Snd p) + | sc_ok_shiftr : + forall n x, 0 <= n -> ok_scalar x -> ok_scalar (Shiftr n x) + | sc_ok_shiftl : + forall n x, 0 <= n -> 0 <= lower (@get_range type.Z x) -> ok_scalar x -> ok_scalar (Shiftl n x) + | sc_ok_land : + forall n x, 0 <= n -> 0 <= lower (@get_range type.Z x) -> ok_scalar x -> ok_scalar (Land n x) + | sc_ok_cc_m : + forall x, ok_scalar x -> ok_scalar (CC_m wordmax x) + | sc_ok_prim : forall p x, ok_scalar (@Primitive _ p x) + . + + Inductive is_halved : scalar type.Z -> Prop := + | is_halved_lower : + forall x : scalar type.Z, + in_word_range (get_range x) -> + is_halved (Cast half_word_range (Land (wordmax_half_bits - 1) x)) + | is_halved_upper : + forall x : scalar type.Z, + in_word_range (get_range x) -> + is_halved (Cast half_word_range (Shiftr half_bits x)) + | is_halved_constant : + forall y z, + constant_to_scalar consts z = Some y -> + is_halved y -> + is_halved (Primitive (t:=type.Z) z) + . + + Inductive ok_ident : forall s d, scalar s -> range_type d -> ident.ident s d -> Prop := + | ok_add : + forall x y : scalar type.Z, + in_word_range (get_range x) -> + in_word_range (get_range y) -> + ok_ident _ + (type.prod type.Z type.Z) + (Pair x y) + (word_range, flag_range) + (ident.Z.add_get_carry_concrete wordmax) + | ok_addc : + forall (c x y : scalar type.Z) outr, + in_flag_range (get_range c) -> + in_word_range (get_range x) -> + in_word_range (get_range y) -> + lower outr = 0 -> + (0 <= upper (get_range c) + upper (get_range x) + upper (get_range y) <= upper outr \/ outr = word_range) -> + ok_ident _ + (type.prod type.Z type.Z) + (Pair (Pair c x) y) + (outr, flag_range) + (ident.Z.add_with_get_carry_concrete wordmax) + | ok_sub : + forall x y : scalar type.Z, + in_word_range (get_range x) -> + in_word_range (get_range y) -> + ok_ident _ + (type.prod type.Z type.Z) + (Pair x y) + (word_range, flag_range) + (ident.Z.sub_get_borrow_concrete wordmax) + | ok_subb : + forall b x y : scalar type.Z, + in_flag_range (get_range b) -> + in_word_range (get_range x) -> + in_word_range (get_range y) -> + ok_ident _ + (type.prod type.Z type.Z) + (Pair (Pair b x) y) + (word_range, flag_range) + (ident.Z.sub_with_get_borrow_concrete wordmax) + | ok_rshi : + forall (x : scalar (type.prod type.Z type.Z)) n outr, + in_word_range (fst (get_range x)) -> + in_word_range (snd (get_range x)) -> + (* note : using [outr] rather than [word_range] allows for cases where the result has been put in a smaller word size. *) + lower outr = 0 -> + 0 <= n -> + ((0 <= (upper (snd (get_range x)) + upper (fst (get_range x)) * wordmax) / 2^n <= upper outr) + \/ outr = word_range) -> + ok_ident (type.prod type.Z type.Z) type.Z x outr (ident.Z.rshi_concrete wordmax n) + | ok_selc : + forall (x : scalar (type.prod type.Z type.Z)) (y z : scalar type.Z), + in_flag_range (snd (get_range x)) -> + in_word_range (get_range y) -> + in_word_range (get_range z) -> + ok_ident _ + type.Z + (Pair (Pair (Cast flag_range (Snd x)) y) z) + word_range + ident.Z.zselect + | ok_selm : + forall x y z : scalar type.Z, + in_word_range (get_range x) -> + in_word_range (get_range y) -> + in_word_range (get_range z) -> + ok_ident _ + type.Z + (Pair (Pair (Cast flag_range (CC_m wordmax x)) y) z) + word_range + ident.Z.zselect + | ok_sell : + forall x y z : scalar type.Z, + in_word_range (get_range x) -> + in_word_range (get_range y) -> + in_word_range (get_range z) -> + ok_ident _ + type.Z + (Pair (Pair (Cast flag_range (Land 1 x)) y) z) + word_range + ident.Z.zselect + | ok_addm : + forall (x : scalar (type.prod (type.prod type.Z type.Z) type.Z)), + in_word_range (fst (fst (get_range x))) -> + in_word_range (snd (fst (get_range x))) -> + in_word_range (snd (get_range x)) -> + upper (fst (fst (get_range x))) + upper (snd (fst (get_range x))) - lower (snd (get_range x)) < wordmax -> + ok_ident _ + type.Z + x + word_range + ident.Z.add_modulo + | ok_mul : + forall x y : scalar type.Z, + is_halved x -> + is_halved y -> + ok_ident (type.prod type.Z type.Z) + type.Z + (Pair x y) + word_range + ident.Z.mul + . + + Inductive ok_expr : forall {t}, @expr type.interp ident.ident t -> Prop := + | ok_of_scalar : forall t s, ok_scalar s -> @ok_expr t (Scalar s) + | ok_letin_z : forall s d r idc x f, + ok_ident _ type.Z x r idc -> + (r <=? word_range)%zrange = true -> + ok_scalar x -> + (forall y, has_range (t:=type.Z) r y -> ok_expr (f y)) -> + ok_expr (@LetInAppIdentZ _ _ s d r idc x f) + | ok_letin_zz : forall s d r idc x f, + ok_ident _ (type.prod type.Z type.Z) x (r, flag_range) idc -> + (r <=? word_range)%zrange = true -> + ok_scalar x -> + (forall y, has_range (t:=type.Z * type.Z) (r, flag_range) y -> ok_expr (f y)) -> + ok_expr (@LetInAppIdentZZ _ _ s d (r, flag_range) idc x f) + . + + Ltac invert H := + inversion H; subst; + repeat match goal with + | H : existT _ _ _ = existT _ _ _ |- _ => apply (Eqdep_dec.inj_pair2_eq_dec _ type.type_eq_dec) in H; subst + end. + + Lemma has_range_get_range_var {t} (v : type.interp t) : + has_range (get_range_var _ v) v. + Proof. + induction t; cbn [get_range_var has_range fst snd]; auto. + destruct p; auto; cbn [upper lower]; omega. + Qed. + + Lemma has_range_loosen r1 r2 (x : Z) : + @has_range type.Z r1 x -> + is_tighter_than_bool r1 r2 = true -> + @has_range type.Z r2 x. + Proof. + cbv [is_tighter_than_bool has_range]; intros; + match goal with H : _ && _ = true |- _ => rewrite andb_true_iff in H; destruct H end; + Z.ltb_to_lt; omega. + Qed. + + Lemma interp_cast_noop x r : + @has_range type.Z r x -> + interp_cast r x = x. + Proof. cbv [has_range]; intros; auto. Qed. + + Lemma interp_cast2_noop x r : + @has_range (type.prod type.Z type.Z) r x -> + interp_cast2 r x = x. + Proof. + cbv [has_range interp_cast2]; intros. + rewrite !interp_cast_correct by tauto. + destruct x; reflexivity. + Qed. + + Lemma has_range_shiftr n (x : scalar type.Z) : + 0 <= n -> + has_range (get_range x) (interp_scalar x) -> + @has_range type.Z (ZRange.map (fun y : Z => y >> n) (get_range x)) (interp_scalar x >> n). + Proof. cbv [has_range]; intros; cbn. auto using Z.shiftr_le with omega. Qed. + Hint Resolve has_range_shiftr : has_range. + + Lemma has_range_shiftl n r x : + 0 <= n -> 0 <= lower r -> + @has_range type.Z r x -> + @has_range type.Z (ZRange.map (fun y : Z => y << n) r) (x << n). + Proof. cbv [has_range]; intros; cbn. auto using Z.shiftl_le_mono with omega. Qed. + Hint Resolve has_range_shiftl : has_range. + + Lemma has_range_land n (x : scalar type.Z) : + 0 <= n -> 0 <= lower (get_range x) -> + has_range (get_range x) (interp_scalar x) -> + @has_range type.Z (r[0~>n])%zrange (Z.land (interp_scalar x) n). + Proof. + cbv [has_range]; intros; cbn. + split; [ apply Z.land_nonneg | apply Z.land_upper_bound_r ]; omega. + Qed. + Hint Resolve has_range_land : has_range. + + Lemma has_range_interp_scalar {t} (x : scalar t) : + ok_scalar x -> + has_range (get_range x) (interp_scalar x). + Proof. + induction 1; cbn [interp_scalar get_range]; + auto with has_range; + try solve [try inversion IHok_scalar; cbn [has_range]; + auto using has_range_get_range_var]; [ | | | ]. + { rewrite interp_cast_noop by eauto using has_range_loosen. + eapply has_range_loosen; eauto. } + { inversion IHok_scalar. + rewrite interp_cast2_noop; + cbn [has_range]; split; eapply has_range_loosen; eauto. } + { cbn. cbv [has_range] in *. + pose proof wordmax_gt_2. + rewrite !Z.cc_m_eq by omega. + split; apply Z.div_le_mono; Z.zero_bounds; omega. } + { destruct p; cbn [has_range upper lower]; auto; omega. } + Qed. + Hint Resolve has_range_interp_scalar : has_range. + + Lemma has_word_range_interp_scalar (x : scalar type.Z) : + ok_scalar x -> + in_word_range (get_range x) -> + @has_range type.Z word_range (interp_scalar x). + Proof. eauto using has_range_loosen, has_range_interp_scalar. Qed. + + Lemma in_word_range_nonneg r : in_word_range r -> 0 <= lower r. + Proof. + cbv [in_word_range is_tighter_than_bool]. + rewrite andb_true_iff; intuition. + Qed. + + Lemma in_word_range_upper_nonneg r x : @has_range type.Z r x -> in_word_range r -> 0 <= upper r. + Proof. + cbv [in_word_range is_tighter_than_bool]; cbn. + rewrite andb_true_iff; intuition. + Z.ltb_to_lt. omega. + Qed. + + Lemma has_word_range_shiftl n r x : + 0 <= n -> upper r * 2 ^ n <= wordmax - 1 -> + @has_range type.Z r x -> + in_word_range r -> + @has_range type.Z word_range (x << n). + Proof. + intros. + eapply has_range_loosen; + [ apply has_range_shiftl; eauto using in_word_range_nonneg with has_range; omega | ]. + cbv [is_tighter_than_bool]. cbn. + apply andb_true_iff; split; apply Z.leb_le; + [ apply Z.shiftl_nonneg; solve [auto using in_word_range_nonneg] | ]. + rewrite Z.shiftl_mul_pow2 by omega. + auto. + Qed. + + Lemma has_range_rshi r n x y : + 0 <= n -> + 0 <= x -> + 0 <= y -> + lower r = 0 -> + (0 <= (y + x * wordmax) / 2^n <= upper r \/ r = word_range) -> + @has_range type.Z r (Z.rshi wordmax x y n). + Proof. + pose proof wordmax_gt_2. + intros. cbv [has_range]. + rewrite Z.rshi_correct by omega. + match goal with |- context [?x mod ?m] => + pose proof (Z.mod_pos_bound x m ltac:(omega)) end. + split; [lia|]. + intuition. + { destruct (Z_lt_dec (upper r) wordmax); [ | lia]. + rewrite Z.mod_small by (split; Z.zero_bounds; omega). + omega. } + { subst r. cbn [upper]. omega. } + Qed. + + Lemma in_word_range_spec r : + (0 <= lower r /\ upper r <= wordmax - 1) + <-> in_word_range r. + Proof. + intros; cbv [in_word_range is_tighter_than_bool]. + rewrite andb_true_iff. + intuition; apply Z.leb_le; cbn [upper lower]; try omega. + Qed. + + Ltac destruct_scalar := + match goal with + | x : scalar (type.prod (type.prod _ _) _) |- _ => + match goal with |- context [interp_scalar x] => + destruct (interp_scalar x) as [ [? ?] ?]; + destruct (get_range x) as [ [? ?] ?] + end + | x : scalar (type.prod _ _) |- _ => + match goal with |- context [interp_scalar x] => + destruct (interp_scalar x) as [? ?]; destruct (get_range x) as [? ?] + end + end. + + Ltac extract_ok_scalar' level x := + match goal with + | H : ok_scalar (Pair (Pair (?f (?g x)) _) _) |- _ => + match (eval compute in (4 <=? level)) with + | true => invert H; extract_ok_scalar' 3 x + | _ => fail + end + | H : ok_scalar (Pair (?f (?g x)) _) |- _ => + match (eval compute in (3 <=? level)) with + | true => invert H; extract_ok_scalar' 2 x + | _ => fail + end + | H : ok_scalar (Pair _ (?f (?g x))) |- _ => + match (eval compute in (3 <=? level)) with + | true => invert H; extract_ok_scalar' 2 x + | _ => fail + end + | H : ok_scalar (?f (?g x)) |- _ => + match (eval compute in (2 <=? level)) with + | true => invert H; extract_ok_scalar' 1 x + | _ => fail + end + | H : ok_scalar (Pair (Pair x _) _) |- _ => + match (eval compute in (2 <=? level)) with + | true => invert H; extract_ok_scalar' 1 x + | _ => fail + end + | H : ok_scalar (Pair (Pair _ x) _) |- _ => + match (eval compute in (2 <=? level)) with + | true => invert H; extract_ok_scalar' 1 x + | _ => fail + end + | H : ok_scalar (?g x) |- _ => invert H + | H : ok_scalar (Pair x _) |- _ => invert H + | H : ok_scalar (Pair _ x) |- _ => invert H + end. + + Ltac extract_ok_scalar := + match goal with |- ok_scalar ?x => extract_ok_scalar' 4 x; assumption end. + + Lemma has_half_word_range_shiftr r x : + in_word_range r -> + @has_range type.Z r x -> + @has_range type.Z half_word_range (x >> half_bits). + Proof. + cbv [in_word_range is_tighter_than_bool]. + rewrite andb_true_iff. + cbn [has_range upper lower]; intros; intuition; Z.ltb_to_lt. + { apply Z.shiftr_nonneg. omega. } + { pose proof half_bits_nonneg. + pose proof half_bits_squared. + assert (x >> half_bits < wordmax_half_bits); [|omega]. + rewrite Z.shiftr_div_pow2 by auto. + apply Z.div_lt_upper_bound; Z.zero_bounds. + subst wordmax_half_bits half_bits. + rewrite <-Z.pow_add_r by omega. + rewrite Z.add_diag, Z.mul_div_eq, log2wordmax_even by omega. + autorewrite with zsimplify_fast. subst wordmax. omega. } + Qed. + + Lemma has_half_word_range_land r x : + in_word_range r -> + @has_range type.Z r x -> + @has_range type.Z half_word_range (x &' (wordmax_half_bits - 1)). + Proof. + pose proof wordmax_half_bits_pos. + cbv [in_word_range is_tighter_than_bool]. + rewrite andb_true_iff. + cbn [has_range upper lower]; intros; intuition; Z.ltb_to_lt. + { apply Z.land_nonneg; omega. } + { apply Z.land_upper_bound_r; omega. } + Qed. + + Section constant_to_scalar. + Lemma constant_to_scalar_single_correct s x z : + 0 <= x <= wordmax - 1 -> + constant_to_scalar_single x z = Some s -> interp_scalar s = z. + Proof. + cbv [constant_to_scalar_single]. + break_match; try discriminate; intros; Z.ltb_to_lt; subst; + try match goal with H : Some _ = Some _ |- _ => inversion H; subst end; + cbn [interp_scalar]; apply interp_cast_noop. + { apply has_half_word_range_shiftr with (r:=r[x~>x]%zrange); + cbv [in_word_range is_tighter_than_bool upper lower has_range]; try omega. + apply andb_true_iff; split; apply Z.leb_le; omega. } + { apply has_half_word_range_land with (r:=r[x~>x]%zrange); + cbv [in_word_range is_tighter_than_bool upper lower has_range]; try omega. + apply andb_true_iff; split; apply Z.leb_le; omega. } + Qed. + + Lemma constant_to_scalar_correct s z : + constant_to_scalar consts z = Some s -> interp_scalar s = z. + Proof. + cbv [constant_to_scalar]. + apply fold_right_invariant; try discriminate. + intros until 2; break_match; eauto using constant_to_scalar_single_correct. + Qed. + + Lemma constant_to_scalar_single_cases x y z : + @constant_to_scalar_single type.interp x z = Some y -> + (y = Cast half_word_range (Land (wordmax_half_bits - 1) (Primitive (t:=type.Z) x))) + \/ (y = Cast half_word_range (Shiftr half_bits (Primitive (t:=type.Z) x))). + Proof. + cbv [constant_to_scalar_single]. + break_match; try discriminate; intros; Z.ltb_to_lt; subst; + try match goal with H : Some _ = Some _ |- _ => inversion H; subst end; + tauto. + Qed. + + Lemma constant_to_scalar_cases y z : + @constant_to_scalar type.interp consts z = Some y -> + (exists x, + @has_range type.Z word_range x + /\ y = Cast half_word_range (Land (wordmax_half_bits - 1) (Primitive x))) + \/ (exists x, + @has_range type.Z word_range x + /\ y = Cast half_word_range (Shiftr half_bits (Primitive x))). + Proof. + cbv [constant_to_scalar]. + apply fold_right_invariant; try discriminate. + intros until 2; break_match; eauto; intros. + match goal with H : constant_to_scalar_single _ _ = _ |- _ => + destruct (constant_to_scalar_single_cases _ _ _ H); subst end. + { left; eexists; split; eauto. + apply consts_ok; auto. } + { right; eexists; split; eauto. + apply consts_ok; auto. } + Qed. + + Lemma ok_scalar_constant_to_scalar y z : constant_to_scalar consts z = Some y -> ok_scalar y. + Proof. + pose proof wordmax_half_bits_pos. pose proof half_bits_nonneg. + let H := fresh in + intro H; apply constant_to_scalar_cases in H; destruct H as [ [? ?] | [? ?] ]; intuition; subst; + cbn [has_range lower upper] in *; repeat constructor; cbn [lower get_range]; try apply Z.leb_refl; try omega. + assert (in_word_range r[x~>x]) by (apply in_word_range_spec; cbn [lower upper]; omega). + pose proof (has_half_word_range_shiftr r[x~>x] x ltac:(assumption) ltac:(cbv [has_range lower upper]; omega)). + cbn [has_range ZRange.map is_tighter_than_bool lower upper] in *. + apply andb_true_iff; cbn [lower upper]; split; apply Z.leb_le; omega. + Qed. + End constant_to_scalar. + Hint Resolve ok_scalar_constant_to_scalar. + + Lemma is_halved_has_range x : + ok_scalar x -> + is_halved x -> + @has_range type.Z half_word_range (interp_scalar x). + Proof. + intro; pose proof (has_range_interp_scalar x ltac:(assumption)). + induction 1; cbn [interp_scalar] in *; intros; try assumption; [ ]. + rewrite <-(constant_to_scalar_correct y z) by assumption. + eauto using has_range_interp_scalar. + Qed. + + Lemma ident_interp_has_range s d x r idc: + ok_scalar x -> + ok_ident s d x r idc -> + has_range r (ident.interp idc (interp_scalar x)). + Proof. + intro. + pose proof (has_range_interp_scalar x ltac:(assumption)). + pose proof wordmax_gt_2. + induction 1; cbn [ident.interp ident.gen_interp]; intros; try destruct_scalar; + repeat match goal with + | H : _ && _ = true |- _ => rewrite andb_true_iff in H; destruct H; Z.ltb_to_lt + | H : _ /\ _ |- _ => destruct H + | H : is_halved _ |- _ => apply is_halved_has_range in H; [ | extract_ok_scalar ] + | _ => progress subst + | _ => progress (cbv [in_word_range in_flag_range is_tighter_than_bool] in * ) + | _ => progress (cbn [interp_scalar get_range has_range upper lower fst snd] in * ) + end. + { + autorewrite with to_div_mod. + match goal with |- context[?x mod ?m] => pose proof (Z.mod_pos_bound x m ltac:(omega)) end. + rewrite Z.div_between_0_if by omega. + split; break_match; lia. } + { + autorewrite with to_div_mod. + match goal with |- context[?x mod ?m] => pose proof (Z.mod_pos_bound x m ltac:(omega)) end. + rewrite Z.div_between_0_if by omega. + match goal with H : _ \/ _ |- _ => destruct H; subst end. + { split; break_match; try lia. + destruct (Z_lt_dec (upper outr) wordmax). + { match goal with |- _ <= ?y mod _ <= ?u => + assert (y <= u) by nia end. + rewrite Z.mod_small by omega. omega. } + { match goal with|- context [?x mod ?m] => pose proof (Z.mod_pos_bound x m ltac:(omega)) end. + omega. } } + { split; break_match; cbn; lia. } } + { + autorewrite with to_div_mod. + match goal with |- context[?x mod ?m] => pose proof (Z.mod_pos_bound x m ltac:(omega)) end. + rewrite Z.div_sub_small by omega. + split; break_match; lia. } + { + autorewrite with to_div_mod. + match goal with |- context [?a - ?b - ?c] => replace (a - b - c) with (a - (b + c)) by ring end. + match goal with |- context[?x mod ?m] => pose proof (Z.mod_pos_bound x m ltac:(omega)) end. + rewrite Z.div_sub_small by omega. + split; break_match; lia. } + { apply has_range_rshi; try nia; [ ]. + match goal with H : context [upper ?ra + upper ?rb * wordmax] |- context [?a + ?b * wordmax] => + assert ((a + b * wordmax) / 2^n <= (upper ra + upper rb * wordmax) / 2^n) by (apply Z.div_le_mono; Z.zero_bounds; nia) + end. + match goal with H : _ \/ ?P |- _ \/ ?P => destruct H; [left|tauto] end. + split; Z.zero_bounds; nia. } + { rewrite Z.zselect_correct. break_match; omega. } + { cbn [interp_scalar fst snd get_range] in *. + rewrite Z.zselect_correct. break_match; omega. } + { cbn [interp_scalar fst snd get_range] in *. + rewrite Z.zselect_correct. break_match; omega. } + { rewrite Z.add_modulo_correct. + break_match; Z.ltb_to_lt; omega. } + { cbn [interp_scalar has_range fst snd get_range upper lower] in *. + pose proof half_bits_squared. nia. } + Qed. + + Lemma has_flag_range_cc_m r x : + @has_range type.Z r x -> + in_word_range r -> + @has_range type.Z flag_range (Z.cc_m wordmax x). + Proof. + cbv [has_range in_word_range is_tighter_than_bool]. + cbn [upper lower]; rewrite andb_true_iff; intros. + match goal with H : _ /\ _ |- _ => destruct H; Z.ltb_to_lt end. + pose proof wordmax_gt_2. pose proof wordmax_even. + pose proof (Z.cc_m_small wordmax x). omega. + Qed. + + Lemma has_flag_range_cc_m' (x : scalar type.Z) : + ok_scalar x -> + in_word_range (get_range x) -> + @has_range type.Z flag_range (Z.cc_m wordmax (interp_scalar x)). + Proof. eauto using has_flag_range_cc_m with has_range. Qed. + + Lemma has_flag_range_land r x : + @has_range type.Z r x -> + in_word_range r -> + @has_range type.Z flag_range (Z.land x 1). + Proof. + cbv [has_range in_word_range is_tighter_than_bool]. + cbn [upper lower]; rewrite andb_true_iff; intuition; Z.ltb_to_lt. + { apply Z.land_nonneg. left; omega. } + { apply Z.land_upper_bound_r; omega. } + Qed. + + Lemma has_flag_range_land' (x : scalar type.Z) : + ok_scalar x -> + in_word_range (get_range x) -> + @has_range type.Z flag_range (Z.land (interp_scalar x) 1). + Proof. eauto using has_flag_range_land with has_range. Qed. + + Ltac rewrite_cast_noop_in_mul := + repeat match goal with + | _ => rewrite interp_cast_noop with (r:=half_word_range) in * + by (eapply has_range_loosen; auto using has_range_land, has_range_interp_scalar) + | _ => rewrite interp_cast_noop with (r:=half_word_range) in * + by (eapply has_range_loosen; try apply has_range_shiftr; auto using has_range_interp_scalar; + cbn [ZRange.map get_range] in *; auto) + | _ => rewrite interp_cast_noop by assumption + end. + + Lemma is_halved_cases x : + is_halved x -> + ok_scalar x -> + (exists y, + invert_lower consts x = Some y + /\ invert_upper consts x = None + /\ interp_scalar y &' (wordmax_half_bits - 1) = interp_scalar x) + \/ (exists y, + invert_lower consts x = None + /\ invert_upper consts x = Some y + /\ interp_scalar y >> half_bits = interp_scalar x). + Proof. + induction 1; intros; cbn; rewrite ?Z.eqb_refl; cbn. + { left. eexists; repeat split; auto. + rewrite interp_cast_noop; [ reflexivity | ]. + apply has_half_word_range_land with (r:=get_range x); auto. + apply has_range_interp_scalar; extract_ok_scalar. } + { right. eexists; repeat split; auto. + rewrite interp_cast_noop; [ reflexivity | ]. + apply has_half_word_range_shiftr with (r:=get_range x); auto. + apply has_range_interp_scalar; extract_ok_scalar. } + { match goal with H : constant_to_scalar _ _ = Some _ |- _ => + rewrite H; + let P := fresh in + destruct (constant_to_scalar_cases _ _ H) as [ [? [? ?] ] | [? [? ?] ] ]; + subst; cbn; rewrite ?Z.eqb_refl; cbn + end. + { left; eexists; repeat split; auto. + erewrite <-constant_to_scalar_correct by eassumption. + subst. cbn. + rewrite interp_cast_noop; [ reflexivity | ]. + eapply has_half_word_range_land with (r:=word_range); auto. + cbv [in_word_range is_tighter_than_bool]. + rewrite !Z.leb_refl; reflexivity. } + { right; eexists; repeat split; auto. + erewrite <-constant_to_scalar_correct by eassumption. + subst. cbn. + rewrite interp_cast_noop; [ reflexivity | ]. + eapply has_half_word_range_shiftr with (r:=word_range); auto. + cbv [in_word_range is_tighter_than_bool]. + rewrite !Z.leb_refl; reflexivity. } } + Qed. + + Lemma halved_mul_range x y : + ok_scalar (Pair x y) -> + is_halved x -> + is_halved y -> + 0 <= interp_scalar x * interp_scalar y < wordmax. + Proof. + intro Hok; invert Hok. intros. + repeat match goal with H : _ |- _ => apply is_halved_has_range in H; [|assumption] end. + cbv [has_range lower upper] in *. + pose proof half_bits_squared. nia. + Qed. + + Lemma of_straightline_ident_mul_correct r t x y g : + is_halved x -> + is_halved y -> + ok_scalar (Pair x y) -> + (word_range <=? r)%zrange = true -> + @has_range type.Z word_range (ident.interp ident.Z.mul (interp_scalar (Pair x y))) -> + @interp interp_cast _ (of_straightline_ident dummy_arrow consts ident.Z.mul t r (Pair x y) g) = + @interp interp_cast _ (g (ident.interp ident.Z.mul (interp_scalar (Pair x y)))). + Proof. + intros Hx Hy Hok ? ?; invert Hok; cbn [interp_scalar of_straightline_ident]; + destruct (is_halved_cases x Hx ltac:(assumption)) as [ [? [Pxlow [Pxhigh Pxi] ] ] | [? [Pxlow [Pxhigh Pxi] ] ] ]; + rewrite ?Pxlow, ?Pxhigh; + destruct (is_halved_cases y Hy ltac:(assumption)) as [ [? [Pylow [Pyhigh Pyi] ] ] | [? [Pylow [Pyhigh Pyi] ] ] ]; + rewrite ?Pylow, ?Pyhigh; + cbn; rewrite Pxi, Pyi; assert (0 <= interp_scalar x * interp_scalar y < wordmax) by (auto using halved_mul_range); + rewrite interp_cast_noop by (cbv [is_tighter_than_bool] in *; cbn [has_range upper lower] in *; rewrite andb_true_iff in *; intuition; Z.ltb_to_lt; lia); reflexivity. + Qed. + + Lemma has_word_range_mod_small x: + @has_range type.Z word_range x -> + x mod wordmax = x. + Proof. + cbv [has_range upper lower]. + intros. apply Z.mod_small; omega. + Qed. + + Lemma half_word_range_le_word_range r : + upper r = wordmax_half_bits - 1 -> + lower r = 0 -> + (r <=? word_range)%zrange = true. + Proof. + pose proof wordmax_half_bits_le_wordmax. + destruct r; cbv [is_tighter_than_bool ZRange.lower ZRange.upper]. + intros; subst. + apply andb_true_iff; split; Z.ltb_to_lt; lia. + Qed. + + Lemma and_shiftl_half_bits_eq x : + (x &' (wordmax_half_bits - 1)) << half_bits = x << half_bits mod wordmax. + Proof. + rewrite ones_half_bits. + rewrite Z.land_ones, !Z.shiftl_mul_pow2 by auto using half_bits_nonneg. + rewrite <-wordmax_half_bits_squared. + subst wordmax_half_bits. + rewrite Z.mul_mod_distr_r_full. + reflexivity. + Qed. + + Lemma in_word_range_word_range : in_word_range word_range. + Proof. + cbv [in_word_range is_tighter_than_bool]. + rewrite !Z.leb_refl; reflexivity. + Qed. + + Lemma invert_shift_correct (s : scalar type.Z) x imm : + ok_scalar s -> + invert_shift consts s = Some (x, imm) -> + interp_scalar s = (interp_scalar x << imm) mod wordmax. + Proof. + intros Hok ?; invert Hok; + try match goal with H : ok_scalar ?x, H' : context[Cast _ ?x] |- _ => + invert H end; + try match goal with H : ok_scalar ?x, H' : context[Shiftl _ ?x] |- _ => + invert H end; + try match goal with H : ok_scalar ?x, H' : context[Shiftl _ (Cast _ ?x)] |- _ => + invert H end; + try (cbn [invert_shift invert_upper invert_upper'] in *; discriminate); + repeat match goal with + | _ => progress (cbn [invert_shift invert_lower invert_lower' invert_upper invert_upper' interp_scalar fst snd] in * ) + | _ => rewrite interp_cast_noop by eauto using has_half_word_range_land, has_half_word_range_shiftr, in_word_range_word_range, has_range_loosen + | H : ok_scalar (Shiftr _ _) |- _ => apply has_range_interp_scalar in H + | H : ok_scalar (Shiftl _ _) |- _ => apply has_range_interp_scalar in H + | H : ok_scalar (Land _ _) |- _ => apply has_range_interp_scalar in H + | H : context [if ?x then _ else _] |- _ => + let Heq := fresh in case_eq x; intro Heq; rewrite Heq in H + | H : context [match @constant_to_scalar ?v ?consts ?x with _ => _ end] |- _ => + let Heq := fresh in + case_eq (@constant_to_scalar v consts x); intros until 0; intro Heq; rewrite Heq in *; [|discriminate]; + destruct (constant_to_scalar_cases _ _ Heq) as [ [? [? ?] ] | [? [? ?] ] ]; subst; + pose proof (ok_scalar_constant_to_scalar _ _ Heq) + | H : constant_to_scalar _ _ = Some _ |- _ => erewrite <-(constant_to_scalar_correct _ _ H) + | H : _ |- _ => rewrite andb_true_iff in H; destruct H; Z.ltb_to_lt + | H : Some _ = Some _ |- _ => progress (invert H) + | _ => rewrite has_word_range_mod_small by eauto using has_range_loosen, half_word_range_le_word_range + | _ => rewrite has_word_range_mod_small by + (eapply has_range_loosen with (r1:=half_word_range); + [ eapply has_half_word_range_shiftr with (r:=word_range) | ]; + eauto using in_word_range_word_range, half_word_range_le_word_range) + | _ => rewrite and_shiftl_half_bits_eq + | _ => progress subst + | _ => reflexivity + | _ => discriminate + end. + Qed. + + Local Ltac solve_commutative_replace := + match goal with + | |- @eq (_ * _) ?x ?y => + replace x with (fst x, snd x) by (destruct x; reflexivity); + replace y with (fst y, snd y) by (destruct y; reflexivity) + end; autorewrite with to_div_mod; solve [repeat (f_equal; try ring)]. + + Fixpoint is_tighter_than_bool_range_type t : range_type t -> range_type t -> bool := + match t with + | type.type_primitive type.Z => (fun r1 r2 => (r1 <=? r2)%zrange) + | type.prod a b => fun r1 r2 => + (is_tighter_than_bool_range_type a (fst r1) (fst r2)) + && (is_tighter_than_bool_range_type b (snd r1) (snd r2)) + | _ => fun _ _ => true + end. + + Definition range_ok {t} : range_type t -> Prop := + match t with + | type.type_primitive type.Z => fun r => in_word_range r + | type.prod type.Z type.Z => fun r => in_word_range (fst r) /\ snd r = flag_range + | _ => fun _ => False + end. + + Lemma of_straightline_ident_correct s d t x r r' (idc : ident.ident s d) g : + ok_ident s d x r idc -> + range_ok r' -> + is_tighter_than_bool_range_type d r r' = true -> + ok_scalar x -> + @interp interp_cast _ (of_straightline_ident dummy_arrow consts idc t r' x g) = + @interp interp_cast _ (g (ident.interp idc (interp_scalar x))). + Proof. + intros. + pose proof wordmax_half_bits_pos. + pose proof (ident_interp_has_range _ _ x r idc ltac:(assumption) ltac:(assumption)). + match goal with H : ok_ident _ _ _ _ _ |- _ => induction H end; + try solve [auto using of_straightline_ident_mul_correct]; + cbv [is_tighter_than_bool_range_type is_tighter_than_bool range_ok] in *; + cbn [of_straightline_ident ident.interp ident.gen_interp + invert_selm invert_sell] in *; + intros; rewrite ?Z.eqb_refl; cbn [andb]; + try match goal with |- context [invert_shift] => break_match end; + cbn [interp interp_ident]; try destruct_scalar; + repeat match goal with + | _ => progress (cbn [fst snd interp_scalar] in * ) + | _ => progress break_match; [ ] + | _ => progress autorewrite with zsimplify_fast + | _ => progress Z.ltb_to_lt + | H : _ /\ _ |- _ => destruct H + | _ => rewrite andb_true_iff in * + | _ => rewrite interp_cast_noop with (r:=flag_range) in * + by (apply has_flag_range_cc_m'; auto; extract_ok_scalar) + | _ => rewrite interp_cast_noop with (r:=flag_range) in * + by (apply has_flag_range_land'; auto; extract_ok_scalar) + | H : _ = (_,_) |- _ => progress (inversion H; subst) + | H : invert_shift _ _ = Some _ |- _ => + apply invert_shift_correct in H; [|extract_ok_scalar]; + rewrite <-H + | H : has_range ?r (?f ?x ?y) |- context [?f ?y ?x] => + replace (f y x) with (f x y) by solve_commutative_replace + | _ => rewrite has_word_range_mod_small + by (eapply has_range_loosen; + [apply has_range_interp_scalar; extract_ok_scalar|]; + assumption) + | _ => rewrite interp_cast_noop by (cbn [has_range fst snd] in *; split; lia) + | _ => rewrite interp_cast2_noop by (cbn [has_range fst snd] in *; split; lia) + | _ => reflexivity + end. + Qed. + + Lemma of_straightline_correct {t} (e : expr t) : + ok_expr e -> + @interp interp_cast _ (of_straightline dummy_arrow consts e) + = Straightline.expr.interp (interp_ident:=@ident.interp) (interp_cast:=interp_cast) e. + Proof. + induction 1; cbn [of_straightline]; intros; + repeat match goal with + | _ => progress cbn [Straightline.expr.interp] + | _ => erewrite of_straightline_ident_correct + by (cbv [range_ok is_tighter_than_bool_range_type]; + eauto using in_word_range_word_range; + try apply andb_true_iff; auto) + | _ => rewrite interp_cast_noop by eauto using has_range_loosen, ident_interp_has_range + | _ => rewrite interp_cast2_noop by eauto using has_range_loosen, ident_interp_has_range + | H : forall y, has_range _ y -> interp _ = _ |- _ => rewrite H by eauto using has_range_loosen, ident_interp_has_range + | _ => reflexivity + end. + Qed. + End proofs. + + Section no_interp_cast. + Context (dummy_arrow : forall s d, type.interp (s -> d)%ctype) (consts : list Z) + (consts_ok : forall x, In x consts -> 0 <= x <= wordmax - 1). + + Local Arguments interp _ {_} _. + Local Arguments interp_scalar _ {_} _. + + Local Ltac tighter_than_to_le := + repeat match goal with + | _ => progress (cbv [is_tighter_than_bool] in * ) + | _ => rewrite andb_true_iff in * + | H : _ /\ _ |- _ => destruct H + end; Z.ltb_to_lt. + + Lemma replace_interp_cast_scalar {t} (x : scalar t) interp_cast interp_cast' + (interp_cast_correct : forall r x, lower r <= x <= upper r -> interp_cast r x = x) + (interp_cast'_correct : forall r x, lower r <= x <= upper r -> interp_cast' r x = x) : + ok_scalar x -> + interp_scalar interp_cast x = interp_scalar interp_cast' x. + Proof. + induction 1; cbn [interp_scalar Straightline.expr.interp_scalar]; + repeat match goal with + | _ => progress (cbv [has_range interp_cast2] in * ) + | _ => progress tighter_than_to_le + | H : ok_scalar _ |- _ => apply (has_range_interp_scalar (interp_cast_correct:=interp_cast_correct)) in H + | _ => rewrite <-IHok_scalar + | _ => rewrite interp_cast_correct by omega + | _ => rewrite interp_cast'_correct by omega + | _ => congruence + end. + Qed. + + Lemma replace_interp_cast {t} (e : expr t) interp_cast interp_cast' + (interp_cast_correct : forall r x, lower r <= x <= upper r -> interp_cast r x = x) + (interp_cast'_correct : forall r x, lower r <= x <= upper r -> interp_cast' r x = x) : + ok_expr consts e -> + interp interp_cast (of_straightline dummy_arrow consts e) = + interp interp_cast' (of_straightline dummy_arrow consts e). + Proof. + induction 1; intros; cbn [of_straightline interp]. + { apply replace_interp_cast_scalar; auto. } + { erewrite !of_straightline_ident_correct by (eauto; cbv [range_ok]; apply in_word_range_word_range). + rewrite replace_interp_cast_scalar with (interp_cast'0:=interp_cast') by auto. + eauto using ident_interp_has_range. } + { erewrite !of_straightline_ident_correct by + (eauto; try solve [cbv [range_ok]; split; auto using in_word_range_word_range]; + cbv [is_tighter_than_bool_range_type]; apply andb_true_iff; split; auto). + rewrite replace_interp_cast_scalar with (interp_cast'0:=interp_cast') by auto. + eauto using ident_interp_has_range. } + Qed. + End no_interp_cast. +*) + End with_wordmax. +(* + Definition of_Expr {s d} (log2wordmax : Z) (consts : list Z) (e : Expr (s -> d)) + (var : type -> Type) (x : var s) dummy_arrow : @Straightline.expr.expr var ident d := + @of_straightline log2wordmax var dummy_arrow consts _ (Straightline.of_Expr e var x dummy_arrow). +*) + Definition interp_cast_mod w r x := if (lower r =? 0) + then if (upper r =? 2^w - 1) + then x mod (2^w) + else if (upper r =? 1) + then x mod 2 + else x + else x. + + Lemma interp_cast_mod_correct w r x : + lower r <= x <= upper r -> + interp_cast_mod w r x = x. + Proof. + cbv [interp_cast_mod]. + intros; break_match; rewrite ?andb_true_iff in *; intuition; Z.ltb_to_lt; + apply Z.mod_small; omega. + Qed. +(* + Lemma of_Expr_correct {s d} (log2wordmax : Z) (consts : list Z) (e : Expr (s -> d)) + (e' : (type.interp s -> Uncurried.expr.expr d)) + (x : type.interp s) dummy_arrow : + e type.interp = Abs e' -> + 1 < log2wordmax -> + log2wordmax mod 2 = 0 -> + Straightline.expr.ok_expr (e' x) -> + (forall x0 : Z, In x0 consts -> 0 <= x0 <= 2 ^ log2wordmax - 1) -> + ok_expr log2wordmax consts + (of_uncurried (dummy_arrow:=dummy_arrow) (depth (fun _ : type => unit) (fun _ : type => tt) (e _)) (e' x)) -> + (depth type.interp (@DefaultValue.type.default) (e' x) <= depth (fun _ : type => unit) (fun _ : type => tt) (e _))%nat -> + @interp log2wordmax (interp_cast_mod log2wordmax) _ (of_Expr log2wordmax consts e type.interp x dummy_arrow) = @Uncurried.expr.interp _ (@ident.interp) _ (e type.interp) x. + Proof. + intro He'; intros; cbv [of_Expr Straightline.of_Expr]. + rewrite He'; cbn [invert_Abs expr.interp]. + assert (forall r z, lower r <= z <= upper r -> ident.cast ident.cast_outside_of_range r z = z) as interp_cast_correct. + { cbv [ident.cast]; intros; break_match; rewrite ?andb_true_iff, ?andb_false_iff in *; intuition; Z.ltb_to_lt; omega. } + erewrite replace_interp_cast with (interp_cast':=ident.cast ident.cast_outside_of_range) by auto using interp_cast_mod_correct. + rewrite of_straightline_correct by auto. + erewrite Straightline.expr.of_uncurried_correct by eassumption. + reflexivity. + Qed. +*) + Notation LetInAppIdentZ S D r eidc x f + := (expr.LetIn + (A:=type.base (base.type.type_base base.type.Z)) + (B:=type.base D) + (expr.App + (s:=type.base (base.type.type_base base.type.Z)) + (d:=type.base (base.type.type_base base.type.Z)) + (expr.Ident (ident.Z_cast r)) + (expr.App + (s:=type.base S) + (d:=type.base (base.type.type_base base.type.Z)) + eidc + x)) + f). + Notation LetInAppIdentZZ S D r eidc x f + := (expr.LetIn + (A:=type.base (base.type.prod (base.type.type_base base.type.Z) (base.type.type_base base.type.Z))) + (B:=type.base D) + (expr.App + (s:=type.base (base.type.prod (base.type.type_base base.type.Z) (base.type.type_base base.type.Z))) + (d:=type.base (base.type.prod (base.type.type_base base.type.Z) (base.type.type_base base.type.Z))) + (expr.Ident (ident.Z_cast2 r)) + (expr.App + (s:=type.base S) + (d:=type.base (base.type.prod (base.type.type_base base.type.Z) (base.type.type_base base.type.Z))) + eidc + x)) + f). + Module Notations. + Import PrintingNotations. + (*Import Straightline.expr.*) + + Local Open Scope expr_scope. + Local Notation "'tZ'" := (base.type.type_base base.type.Z). + Notation "'RegZero'" := (expr.Ident (ident.Literal 0)). + Notation "$ x" := (#(ident.Z_cast uint256) @ (#ident.fst @ (#(ident.Z_cast2 (uint256,bool)%core) @ (expr.Var x)))) (at level 10, format "$ x"). + Notation "$ x" := (#(ident.Z_cast uint128) @ (#ident.fst @ (#(ident.Z_cast2 (uint128,bool)%core) @ (expr.Var x)))) (at level 10, format "$ x"). + Notation "$ x ₁" := (#(ident.Z_cast uint256) @ (#ident.fst @ (expr.Var x))) (at level 10, format "$ x ₁"). + Notation "$ x ₂" := (#(ident.Z_cast uint256) @ (#ident.snd @ (expr.Var x))) (at level 10, format "$ x ₂"). + Notation "$ x" := (#(ident.Z_cast uint256) @ (expr.Var x)) (at level 10, format "$ x"). + Notation "$ x" := (#(ident.Z_cast uint128) @ (expr.Var x)) (at level 10, format "$ x"). + Notation "$ x" := (#(ident.Z_cast bool) @ (expr.Var x)) (at level 10, format "$ x"). + Notation "carry{ $ x }" := (#(ident.Z_cast bool) @ (#ident.snd @ (#(ident.Z_cast2 (uint256, bool)%core) @ (expr.Var x)))) + (at level 10, format "carry{ $ x }"). + Notation "Lower{ x }" := (#(ident.Z_cast uint128) @ (#(ident.Z_land 340282366920938463463374607431768211455) @ x)) + (at level 10, format "Lower{ x }"). + Notation "f @( y , x1 , x2 ); g " + := (LetInAppIdentZZ _ _ (uint256, bool)%core f (x1, x2) (fun y => g)) + (at level 10, g at level 200, format "f @( y , x1 , x2 ); '//' g "). + Notation "f @( y , x1 , x2 , x3 ); g " + := (LetInAppIdentZZ _ _ (uint256, bool)%core f (#ident.pair @ (#ident.pair @ x1 @ x2) @ x3) (fun y => g)) + (at level 10, g at level 200, format "f @( y , x1 , x2 , x3 ); '//' g "). + Notation "f @( y , x1 , x2 , x3 ); '#128' g " + := (LetInAppIdentZZ _ _ (uint128, bool)%core f (#ident.pair @ (#ident.pair @ x1 @ x2) @ x3) (fun y => g)) + (at level 10, g at level 200, format "f @( y , x1 , x2 , x3 ); '#128' '//' g "). + Notation "f @( y , x1 , x2 ); g " + := (LetInAppIdentZ _ _ uint256 f (#ident.pair @ x1 @ x2) (fun y => g)) + (at level 10, g at level 200, format "f @( y , x1 , x2 ); '//' g "). + Notation "f @( y , x1 , x2 , x3 ); g " + := (LetInAppIdentZ _ _ uint256 f (#ident.pair @ (#ident.pair @ x1 x2) x3) (fun y => g)) + (at level 10, g at level 200, format "f @( y , x1 , x2 , x3 ); '//' g "). + (* special cases for when the ident constructor takes a constant argument *) + Notation "add@( y , x1 , x2 , n ); g" + := (LetInAppIdentZZ _ _ (uint256, bool) (#(ident.fancy_add 256 n)) (#ident.pair @ x1 x2) (fun y => g)) + (at level 10, g at level 200, format "add@( y , x1 , x2 , n ); '//' g"). + Notation "addc@( y , x1 , x2 , x3 , n ); g" + := (LetInAppIdentZZ _ _ (uint256, bool) (#(ident.fancy_addc 256 n)) (#ident.pair @ (#ident.pair @ x1 x2) x3) (fun y => g)) + (at level 10, g at level 200, format "addc@( y , x1 , x2 , x3 , n ); '//' g"). + Notation "addc@( y , x1 , x2 , x3 , n ); '#128' g" + := (LetInAppIdentZZ _ _ (uint128, bool) (#(ident.fancy_addc 256 n)) (#ident.pair @ (#ident.pair @ x1 x2) x3) (fun y => g)) + (at level 10, g at level 200, format "addc@( y , x1 , x2 , x3 , n ); '#128' '//' g"). + Notation "sub@( y , x1 , x2 , n ); g" + := (LetInAppIdentZZ _ _ (uint256, bool) (#(ident.fancy_sub 256 n)) (#ident.pair @ x1 x2) (fun y => g)) + (at level 10, g at level 200, format "sub@( y , x1 , x2 , n ); '//' g"). + Notation "subb@( y , x1 , x2 , x3 , n ); g" + := (LetInAppIdentZZ _ _ (uint256, bool) (#(ident.fancy_subb 256 n)) (#ident.pair @ (#ident.pair @ x1 x2) x3) (fun y => g)) + (at level 10, g at level 200, format "subb@( y , x1 , x2 , x3 , n ); '//' g"). + Notation "rshi@( y , x1 , x2 , n ); g" + := (LetInAppIdentZ _ _ _ (#(ident.fancy_rshi 256 n)) (#ident.pair @ x1 x2) (fun y => g)) + (at level 10, g at level 200, format "rshi@( y , x1 , x2 , n ); '//' g "). + (*Notation "'ret' $ x" := (Scalar (expr.Var x)) (at level 10, format "'ret' $ x").*) + Notation "( x , y )" := (#ident.pair @ x @ y) (at level 10, left associativity). + End Notations. +(* + Module Tactics. + Ltac ok_expr_step' := + match goal with + | _ => assumption + | |- _ <= _ <= _ \/ @eq zrange _ _ => + right; lazy; try split; congruence + | |- _ <= _ <= _ \/ @eq zrange _ _ => + left; lazy; try split; congruence + | |- context [PreFancy.ok_ident] => constructor + | |- context [PreFancy.ok_scalar] => constructor; try omega + | |- context [PreFancy.is_halved] => eapply PreFancy.is_halved_constant; [lazy; reflexivity | ] + | |- context [PreFancy.is_halved] => constructor + | |- context [PreFancy.in_word_range] => lazy; reflexivity + | |- context [PreFancy.in_flag_range] => lazy; reflexivity + | |- context [PreFancy.get_range] => + cbn [PreFancy.get_range lower upper fst snd ZRange.map] + | x : type.interp (type.prod _ _) |- _ => destruct x + | |- (_ <=? _)%zrange = true => + match goal with + | |- context [PreFancy.get_range_var] => + cbv [is_tighter_than_bool PreFancy.has_range fst snd upper lower] in *; cbn; + apply andb_true_iff; split; apply Z.leb_le + | _ => lazy + end; omega || reflexivity + | |- @eq zrange _ _ => lazy; reflexivity + | |- _ <= _ => omega + | |- _ <= _ <= _ => omega + end; intros. + + Ltac ok_expr_step := + match goal with + | |- context [PreFancy.ok_expr] => constructor; cbn [fst snd]; repeat ok_expr_step' + end; intros; cbn [Nat.max]. + End Tactics. + *) + Notation interp w := (@expr.interp base.type ident.ident base.interp (@ident.gen_interp (PreFancy.interp_cast_mod w))). + Notation Interp w := (@expr.Interp base.type ident.ident base.interp (@ident.gen_interp (PreFancy.interp_cast_mod w))). +End PreFancy. + +Module Fancy. + (*Import Straightline.expr.*) + + Module CC. + Inductive code : Type := + | C : code + | M : code + | L : code + | Z : code + . + + Record state := + { cc_c : bool; cc_m : bool; cc_l : bool; cc_z : bool }. + + Definition code_dec (x y : code) : {x = y} + {x <> y}. + Proof. destruct x, y; try apply (left eq_refl); right; congruence. Defined. + + Definition update (to_write : list code) (result : BinInt.Z) (cc_spec : code -> BinInt.Z -> bool) (old_state : state) + : state := + {| + cc_c := if (In_dec code_dec C to_write) + then cc_spec C result + else old_state.(cc_c); + cc_m := if (In_dec code_dec M to_write) + then cc_spec M result + else old_state.(cc_m); + cc_l := if (In_dec code_dec L to_write) + then cc_spec L result + else old_state.(cc_l); + cc_z := if (In_dec code_dec Z to_write) + then cc_spec Z result + else old_state.(cc_z) + |}. + + End CC. + + Record instruction := + { + num_source_regs : nat; + writes_conditions : list CC.code; + spec : tuple Z num_source_regs -> CC.state -> Z + }. + + Section expr. + Context {name : Type} (name_eqb : name -> name -> bool) (wordmax : Z) (cc_spec : CC.code -> Z -> bool). + + Inductive expr := + | Ret : name -> expr + | Instr (i : instruction) + (rd : name) (* destination register *) + (args : tuple name i.(num_source_regs)) (* source registers *) + (cont : expr) (* next line *) + : expr + . + + Fixpoint interp (e : expr) (cc : CC.state) (ctx : name -> Z) : Z := + match e with + | Ret n => ctx n + | Instr i rd args cont => + let result := i.(spec) (Tuple.map ctx args) cc in + let new_cc := CC.update i.(writes_conditions) result cc_spec cc in + let new_ctx := (fun n : name => if name_eqb n rd then result mod wordmax else ctx n) in + interp cont new_cc new_ctx + end. + End expr. + + Section ISA. + Import CC. + + (* For the C flag, we have to consider cases with a negative result (like the one returned by an underflowing borrow). + In these cases, we want to set the C flag to true. *) + Definition cc_spec (x : CC.code) (result : BinInt.Z) : bool := + match x with + | CC.C => if result <? 0 then true else Z.testbit result 256 + | CC.M => Z.testbit result 255 + | CC.L => Z.testbit result 0 + | CC.Z => result =? 0 + end. + + Local Definition lower128 x := (Z.land x (Z.ones 128)). + Local Definition upper128 x := (Z.shiftr x 128). + Local Notation "x '[C]'" := (if x.(cc_c) then 1 else 0) (at level 20). + Local Notation "x '[M]'" := (if x.(cc_m) then 1 else 0) (at level 20). + Local Notation "x '[L]'" := (if x.(cc_l) then 1 else 0) (at level 20). + Local Notation "x '[Z]'" := (if x.(cc_z) then 1 else 0) (at level 20). + Local Notation "'int'" := (BinInt.Z). + Local Notation "x << y" := ((x << y) mod (2^256)) : Z_scope. (* truncating left shift *) + + + (* Note: In the specification document, argument order gets a bit + confusing. Like here, r0 is always the first argument "source 0" + and r1 the second. But the specification of MUL128LU is: + (R[RS1][127:0] * R[RS0][255:128]) + + while the specification of SUB is: + (R[RS0] - shift(R[RS1], imm)) + + In the SUB case, r0 is really treated the first argument, but in + MUL128LU the order seems to be reversed; rather than low-high, we + take the high part of the first argument r0 and the low parts of + r1. This is also true for MUL128UL. *) + + Definition ADD (imm : int) : instruction := + {| + num_source_regs := 2; + writes_conditions := [C; M; L; Z]; + spec := (fun '(r0, r1) cc => + r0 + (r1 << imm)) + |}. + + Definition ADDC (imm : int) : instruction := + {| + num_source_regs := 2; + writes_conditions := [C; M; L; Z]; + spec := (fun '(r0, r1) cc => + r0 + (r1 << imm) + cc[C]) + |}. + + Definition SUB (imm : int) : instruction := + {| + num_source_regs := 2; + writes_conditions := [C; M; L; Z]; + spec := (fun '(r0, r1) cc => + r0 - (r1 << imm)) + |}. + + Definition SUBC (imm : int) : instruction := + {| + num_source_regs := 2; + writes_conditions := [C; M; L; Z]; + spec := (fun '(r0, r1) cc => + r0 - (r1 << imm) - cc[C]) + |}. + + + Definition MUL128LL : instruction := + {| + num_source_regs := 2; + writes_conditions := [M; L; Z]; + spec := (fun '(r0, r1) cc => + (lower128 r0) * (lower128 r1)) + |}. + + Definition MUL128LU : instruction := + {| + num_source_regs := 2; + writes_conditions := [M; L; Z]; + spec := (fun '(r0, r1) cc => + (lower128 r1) * (upper128 r0)) (* see note *) + |}. + + Definition MUL128UL : instruction := + {| + num_source_regs := 2; + writes_conditions := [M; L; Z]; + spec := (fun '(r0, r1) cc => + (upper128 r1) * (lower128 r0)) (* see note *) + |}. + + Definition MUL128UU : instruction := + {| + num_source_regs := 2; + writes_conditions := [M; L; Z]; + spec := (fun '(r0, r1) cc => + (upper128 r0) * (upper128 r1)) + |}. + + (* Note : Unlike the other operations, the output of RSHI is + truncated in the specification. This is not strictly necessary, + since the interpretation function truncates the output + anyway. However, it is useful to make the definition line up + exactly with Z.rshi. *) + Definition RSHI (imm : int) : instruction := + {| + num_source_regs := 2; + writes_conditions := [M; L; Z]; + spec := (fun '(r0, r1) cc => + (((2^256 * r0) + r1) >> imm) mod (2^256)) + |}. + + Definition SELC : instruction := + {| + num_source_regs := 2; + writes_conditions := []; + spec := (fun '(r0, r1) cc => + if cc[C] =? 1 then r0 else r1) + |}. + + Definition SELM : instruction := + {| + num_source_regs := 2; + writes_conditions := []; + spec := (fun '(r0, r1) cc => + if cc[M] =? 1 then r0 else r1) + |}. + + Definition SELL : instruction := + {| + num_source_regs := 2; + writes_conditions := []; + spec := (fun '(r0, r1) cc => + if cc[L] =? 1 then r0 else r1) + |}. + + (* TODO : treat the MOD register specially, like CC *) + Definition ADDM : instruction := + {| + num_source_regs := 3; + writes_conditions := [M; L; Z]; + spec := (fun '(r0, r1, MOD) cc => + let ra := r0 + r1 in + if ra >=? MOD + then ra - MOD + else ra) + |}. + + End ISA. + + Module Registers. + Inductive register : Type := + | r0 : register + | r1 : register + | r2 : register + | r3 : register + | r4 : register + | r5 : register + | r6 : register + | r7 : register + | r8 : register + | r9 : register + | r10 : register + | r11 : register + | r12 : register + | r13 : register + | r14 : register + | r15 : register + | r16 : register + | r17 : register + | r18 : register + | r19 : register + | r20 : register + | r21 : register + | r22 : register + | r23 : register + | r24 : register + | r25 : register + | r26 : register + | r27 : register + | r28 : register + | r29 : register + | r30 : register + | RegZero : register (* r31 *) + | RegMod : register + . + + Definition reg_dec (x y : register) : {x = y} + {x <> y}. + Proof. destruct x, y; try (apply left; congruence); right; congruence. Defined. + Definition reg_eqb x y := if reg_dec x y then true else false. + + Lemma reg_eqb_neq x y : x <> y -> reg_eqb x y = false. + Proof. cbv [reg_eqb]; break_match; congruence. Qed. + Lemma reg_eqb_refl x : reg_eqb x x = true. + Proof. cbv [reg_eqb]; break_match; congruence. Qed. + End Registers. + + Section of_prefancy. + Local Notation cexpr := (@Compilers.expr.expr base.type ident.ident). + Context (name : Type) (name_succ : name -> name) (error : name) (consts : Z -> option name). + + Fixpoint base_var (t : base.type) : Type := + match t with + | base.type.Z => name + | base.type.prod a b => base_var a * base_var b + | _ => unit + end. + Fixpoint var (t : type.type base.type) : Type := + match t with + | type.base t => base_var t + | type.arrow s d => var s -> var d + end. + Fixpoint base_error {t} : base_var t + := match t with + | base.type.Z => error + | base.type.prod A B => (@base_error A, @base_error B) + | _ => tt + end. + Fixpoint make_error {t} : var t + := match t with + | type.base _ => base_error + | type.arrow s d => fun _ => @make_error d + end. + + Fixpoint of_prefancy_scalar {t} (s : @cexpr var t) : var t + := match s in expr.expr t return var t with + | Compilers.expr.Var t v => v + | expr.App s d f x => @of_prefancy_scalar _ f (@of_prefancy_scalar _ x) + | expr.Ident t idc + => match idc in ident.ident t return var t with + | ident.Literal base.type.Z v => match consts v with + | Some n => n + | None => error + end + | ident.pair A B => fun a b => (a, b)%core + | ident.fst A B => fun v => fst v + | ident.snd A B => fun v => snd v + | ident.Z_cast _ => fun v => v + | ident.Z_cast2 _ => fun v => v + | _ => make_error + end + | expr.Abs s d f => make_error + | expr.LetIn A B x f => make_error + end%expr_pat%etype. + + (* Note : some argument orders are reversed for MUL128LU, MUL128UL, SELC, SELM, and SELL *) + Local Notation tZ := base.type.Z. + Definition of_prefancy_ident {s d : base.type} (idc : ident.ident (s -> d)) + : @cexpr var s -> option {i : instruction & tuple name i.(num_source_regs) } := + match idc in ident.ident t return match t return Type with + | type.arrow (type.base s) (type.base d) + => @cexpr var s + | _ => unit + end + -> option {i : instruction & tuple name i.(num_source_regs) } + with + | ident.fancy_add log2wordmax imm + => fun args : @cexpr var (tZ * tZ) => + if Z.eqb log2wordmax 256 + then Some (existT _ (ADD imm) (of_prefancy_scalar args)) + else None + | ident.fancy_addc log2wordmax imm + => fun args : @cexpr var (tZ * tZ * tZ) => + if Z.eqb log2wordmax 256 + then Some (existT _ (ADDC imm) (of_prefancy_scalar ((#ident.snd @ (#ident.fst @ args)), (#ident.snd @ args)))) + else None + | ident.fancy_sub log2wordmax imm + => fun args : @cexpr var (tZ * tZ) => + if Z.eqb log2wordmax 256 + then Some (existT _ (SUB imm) (of_prefancy_scalar args)) + else None + | ident.fancy_subb log2wordmax imm + => fun args : @cexpr var (tZ * tZ * tZ) => + if Z.eqb log2wordmax 256 + then Some (existT _ (SUBC imm) (of_prefancy_scalar ((#ident.snd @ (#ident.fst @ args)), (#ident.snd @ args)))) + else None + | ident.fancy_mulll log2wordmax + => fun args : @cexpr var (tZ * tZ) => + if Z.eqb log2wordmax 256 + then Some (existT _ MUL128LL (of_prefancy_scalar args)) + else None + | ident.fancy_mullh log2wordmax + => fun args : @cexpr var (tZ * tZ) => + if Z.eqb log2wordmax 256 + then Some (existT _ MUL128LU (of_prefancy_scalar ((#ident.snd @ args), (#ident.fst @ args)))) + else None + | ident.fancy_mulhl log2wordmax + => fun args : @cexpr var (tZ * tZ) => + if Z.eqb log2wordmax 256 + then Some (existT _ MUL128UL (of_prefancy_scalar ((#ident.snd @ args), (#ident.fst @ args)))) + else None + | ident.fancy_mulhh log2wordmax + => fun args : @cexpr var (tZ * tZ) => + if Z.eqb log2wordmax 256 + then Some (existT _ MUL128UU (of_prefancy_scalar args)) + else None + | ident.fancy_rshi log2wordmax imm + => fun args : @cexpr var (tZ * tZ) => + if Z.eqb log2wordmax 256 + then Some (existT _ (RSHI imm) (of_prefancy_scalar args)) + else None + | ident.fancy_selc + => fun args : @cexpr var (tZ * tZ * tZ) => Some (existT _ SELC (of_prefancy_scalar ((#ident.snd @ args), (#ident.snd @ (#ident.fst @ args))))) + | ident.fancy_selm log2wordmax + => fun args : @cexpr var (tZ * tZ * tZ) => + if Z.eqb log2wordmax 256 + then Some (existT _ SELM (of_prefancy_scalar ((#ident.snd @ args), (#ident.snd @ (#ident.fst @ args))))) + else None + | ident.fancy_sell + => fun args : @cexpr var (tZ * tZ * tZ) => Some (existT _ SELL (of_prefancy_scalar ((#ident.snd @ args), (#ident.snd @ (#ident.fst @ args))))) + | ident.fancy_addm + => fun args : @cexpr var (tZ * tZ * tZ) => Some (existT _ ADDM (of_prefancy_scalar args)) + | _ => fun _ => None + end. + + Local Notation "x <- y ; f" := (match y with Some x => f | None => Ret error end). + Definition of_prefancy_step + (of_prefancy : forall (next_name : name) {t} (e : @cexpr var t), @expr name) + (next_name : name) {t} (e : @cexpr var t) : @expr name + := let default _ := (e' <- type.try_transport base.try_make_transport_cps (@cexpr var) t tZ e; + Ret (of_prefancy_scalar e')) in + match e with + | PreFancy.LetInAppIdentZ s d r eidc x f + => idc <- invert_expr.invert_Ident eidc; + instr_args <- @of_prefancy_ident s tZ idc x; + let i : instruction := projT1 instr_args in + let args : tuple name i.(num_source_regs) := projT2 instr_args in + Instr i next_name args (@of_prefancy (name_succ next_name) _ (f next_name)) + | PreFancy.LetInAppIdentZZ s d r eidc x f + => idc <- invert_expr.invert_Ident eidc; + instr_args <- @of_prefancy_ident s (tZ * tZ) idc x; + let i : instruction := projT1 instr_args in + let args : tuple name i.(num_source_regs) := projT2 instr_args in + Instr i next_name args (@of_prefancy (name_succ next_name) _ (f (next_name, error))) (* we pass the error code as the carry register, because it cannot be read from directly. *) + | _ => default tt + end. + Fixpoint of_prefancy (next_name : name) {t} (e : @cexpr var t) : @expr name + := @of_prefancy_step of_prefancy next_name t e. + End of_prefancy. + + Section allocate_registers. + Context (reg name : Type) (name_eqb : name -> name -> bool) (error : reg). + Fixpoint allocate (e : @expr name) (reg_list : list reg) (name_to_reg : name -> reg) : @expr reg := + match e with + | Ret n => Ret (name_to_reg n) + | Instr i rd args cont => + match reg_list with + | r :: reg_list' => Instr i r (Tuple.map name_to_reg args) (allocate cont reg_list' (fun n => if name_eqb n rd then r else name_to_reg n)) + | nil => Ret error + end + end. + End allocate_registers. + + Definition test_prog : @expr positive := + Instr (ADD (128)) 3%positive (1, 2)%positive + (Instr (ADDC 0) 4%positive (3,1)%positive + (Ret 4%positive)). + + Definition x1 := 2^256 - 1. + Definition x2 := 2^128 - 1. + Definition wordmax := 2^256. + Definition expected := + let r3' := (x1 + (x2 << 128)) in + let r3 := r3' mod wordmax in + let c := r3' / wordmax in + let r4' := (r3 + x1 + c) in + r4' mod wordmax. + Definition actual := + interp Pos.eqb + (2^256) cc_spec test_prog {|CC.cc_c:=false; CC.cc_m:=false; CC.cc_l:=false; CC.cc_z:=false|} + (fun n => if n =? 1%positive + then x1 + else if n =? 2%positive + then x2 + else 0). + Lemma test_prog_ok : expected = actual. + Proof. reflexivity. Qed. + + Definition of_Expr {t} next_name (consts : Z -> option positive) (consts_list : list Z) + (e : expr.Expr t) + (x : type.for_each_lhs_of_arrow (var positive) t) + : positive -> @expr positive := + fun error => + @of_prefancy positive Pos.succ error consts next_name _ (invert_expr.smart_App_curried (e _) x). + +End Fancy. + +Module Prod. + Import Fancy. Import Registers. + + Definition Mul256 (out src1 src2 tmp : register) (cont : Fancy.expr) : Fancy.expr := + Instr MUL128LL out (src1, src2) + (Instr MUL128UL tmp (src1, src2) + (Instr (ADD 128) out (out, tmp) + (Instr MUL128LU tmp (src1, src2) + (Instr (ADD 128) out (out, tmp) cont)))). + Definition Mul256x256 (out outHigh src1 src2 tmp : register) (cont : Fancy.expr) : Fancy.expr := + Instr MUL128LL out (src1, src2) + (Instr MUL128UU outHigh (src1, src2) + (Instr MUL128UL tmp (src1, src2) + (Instr (ADD 128) out (out, tmp) + (Instr (ADDC (-128)) outHigh (outHigh, tmp) + (Instr MUL128LU tmp (src1, src2) + (Instr (ADD 128) out (out, tmp) + (Instr (ADDC (-128)) outHigh (outHigh, tmp) cont))))))). + + Definition MontRed256 lo hi y t1 t2 scratch RegPInv : @Fancy.expr register := + Mul256 y lo RegPInv t1 + (Mul256x256 t1 t2 y RegMod scratch + (Instr (ADD 0) lo (lo, t1) + (Instr (ADDC 0) hi (hi, t2) + (Instr SELC y (RegMod, RegZero) + (Instr (SUB 0) lo (hi, y) + (Instr ADDM lo (lo, RegZero, RegMod) + (Ret lo))))))). + + (* Barrett reduction -- this is only the "reduce" part, excluding the initial multiplication. *) + Definition MulMod x xHigh RegMuLow scratchp1 scratchp2 scratchp3 scratchp4 scratchp5 : @Fancy.expr register := + let q1Bottom256 := scratchp1 in + let muSelect := scratchp2 in + let q2 := scratchp3 in + let q2High := scratchp4 in + let q2High2 := scratchp5 in + let q3 := scratchp1 in + let r2 := scratchp2 in + let r2High := scratchp3 in + let maybeM := scratchp1 in + Instr SELM muSelect (RegMuLow, RegZero) + (Instr (RSHI 255) q1Bottom256 (xHigh, x) + (Mul256x256 q2 q2High q1Bottom256 RegMuLow scratchp5 + (Instr (RSHI 255) q2High2 (RegZero, xHigh) + (Instr (ADD 0) q2High (q2High, q1Bottom256) + (Instr (ADDC 0) q2High2 (q2High2, RegZero) + (Instr (ADD 0) q2High (q2High, muSelect) + (Instr (ADDC 0) q2High2 (q2High2, RegZero) + (Instr (RSHI 1) q3 (q2High2, q2High) + (Mul256x256 r2 r2High RegMod q3 scratchp4 + (Instr (SUB 0) muSelect (x, r2) + (Instr (SUBC 0) xHigh (xHigh, r2High) + (Instr SELL maybeM (RegMod, RegZero) + (Instr (SUB 0) q3 (muSelect, maybeM) + (Instr ADDM x (q3, RegZero, RegMod) + (Ret x))))))))))))))). +End Prod. + +Module ProdEquiv. + Import Fancy. Import Registers. + + Definition interp256 := Fancy.interp reg_eqb (2^256) cc_spec. + Lemma interp_step i rd args cont cc ctx : + interp256 (Instr i rd args cont) cc ctx = + let result := spec i (Tuple.map ctx args) cc in + let new_cc := CC.update (writes_conditions i) result cc_spec cc in + let new_ctx := fun n => if reg_eqb n rd then result mod wordmax else ctx n in interp256 cont new_cc new_ctx. + Proof. reflexivity. Qed. + + (* TODO : move *) + Lemma tuple_map_ext {A B} (f g : A -> B) n (t : tuple A n) : + (forall x : A, f x = g x) -> + Tuple.map f t = Tuple.map g t. + Proof. + destruct n; [reflexivity|]; cbn in *. + induction n; cbn in *; intro H; auto; [ ]. + rewrite IHn by assumption. + rewrite H; reflexivity. + Qed. + + Lemma interp_state_equiv e : + forall cc ctx cc' ctx', + cc = cc' -> (forall r, ctx r = ctx' r) -> + interp256 e cc ctx = interp256 e cc' ctx'. + Proof. + induction e; intros; subst; cbn; [solve[auto]|]. + apply IHe; rewrite tuple_map_ext with (g:=ctx') by auto; + [reflexivity|]. + intros; break_match; auto. + Qed. + Lemma cc_overwrite_full x1 x2 l1 cc : + CC.update [CC.C; CC.M; CC.L; CC.Z] x2 cc_spec (CC.update l1 x1 cc_spec cc) = CC.update [CC.C; CC.M; CC.L; CC.Z] x2 cc_spec cc. + Proof. + cbv [CC.update]. cbn [CC.cc_c CC.cc_m CC.cc_l CC.cc_z]. + break_match; try match goal with H : ~ In _ _ |- _ => cbv [In] in H; tauto end. + reflexivity. + Qed. + + Lemma tuple_map_ext_In {A B} (f g : A -> B) n (t : tuple A n) : + (forall x, In x (to_list n t) -> f x = g x) -> + Tuple.map f t = Tuple.map g t. + Proof. + destruct n; [reflexivity|]; cbn in *. + induction n; cbn in *; intro H; auto; [ ]. + destruct t. + rewrite IHn by auto using in_cons. + rewrite H; auto using in_eq. + Qed. + + Definition value_unused r e : Prop := + forall x cc ctx, interp256 e cc ctx = interp256 e cc (fun r' => if reg_eqb r' r then x else ctx r'). + + Lemma value_unused_skip r i rd args cont (Hcont: value_unused r cont) : + r <> rd -> + (~ In r (Tuple.to_list _ args)) -> + value_unused r (Instr i rd args cont). + Proof. + cbv [value_unused] in *; intros. + rewrite !interp_step; cbv zeta. + rewrite Hcont with (x:=x). + match goal with |- ?lhs = ?rhs => + match lhs with context [Tuple.map ?f ?t] => + match rhs with context [Tuple.map ?g ?t] => + rewrite (tuple_map_ext_In f g) by (intros; cbv [reg_eqb]; break_match; congruence) + end end end. + apply interp_state_equiv; [ congruence | ]. + { intros; cbv [reg_eqb] in *; break_match; congruence. } + Qed. + + Lemma value_unused_overwrite r i args cont : + (~ In r (Tuple.to_list _ args)) -> + value_unused r (Instr i r args cont). + Proof. + cbv [value_unused]; intros; rewrite !interp_step; cbv zeta. + match goal with |- ?lhs = ?rhs => + match lhs with context [Tuple.map ?f ?t] => + match rhs with context [Tuple.map ?g ?t] => + rewrite (tuple_map_ext_In f g) by (intros; cbv [reg_eqb]; break_match; congruence) + end end end. + apply interp_state_equiv; [ congruence | ]. + { intros; cbv [reg_eqb] in *; break_match; congruence. } + Qed. + + Lemma value_unused_ret r r' : + r <> r' -> + value_unused r (Ret r'). + Proof. + cbv - [reg_dec]; intros. + break_match; congruence. + Qed. + + Ltac remember_results := + repeat match goal with |- context [(spec ?i ?args ?flags) mod ?w] => + let x := fresh "x" in + let y := fresh "y" in + let Heqx := fresh "Heqx" in + remember (spec i args flags) as x eqn:Heqx; + remember (x mod w) as y + end. + + Ltac do_interp_step := + rewrite interp_step; cbn - [interp spec]; + repeat progress rewrite ?reg_eqb_neq, ?reg_eqb_refl by congruence; + remember_results. + + Lemma interp_Mul256 out src1 src2 tmp tmp2 cont cc ctx: + out <> src1 -> + out <> src2 -> + out <> tmp -> + out <> tmp2 -> + src1 <> src2 -> + src1 <> tmp -> + src1 <> tmp2 -> + src2 <> tmp -> + src2 <> tmp2 -> + tmp <> tmp2 -> + value_unused tmp cont -> + value_unused tmp2 cont -> + interp256 (Prod.Mul256 out src1 src2 tmp cont) cc ctx = + interp256 ( + Instr MUL128LU tmp (src1, src2) + (Instr MUL128UL tmp2 (src1, src2) + (Instr MUL128LL out (src1, src2) + (Instr (ADD 128) out (out, tmp2) + (Instr (ADD 128) out (out, tmp) cont))))) cc ctx. + Proof. + intros; cbv [Prod.Mul256]. + repeat (do_interp_step; cbn [spec MUL128LL MUL128UL MUL128LU ADD] in * ). + + match goal with H : value_unused tmp _ |- _ => erewrite H end. + match goal with H : value_unused tmp2 _ |- _ => erewrite H end. + apply interp_state_equiv. + { rewrite !cc_overwrite_full. + f_equal. subst. lia. } + { intros; cbv [reg_eqb]. + repeat (break_match_step ltac:(fun _ => idtac); try congruence); reflexivity. } + Qed. + + Lemma interp_Mul256x256 out outHigh src1 src2 tmp tmp2 cont cc ctx: + out <> src1 -> + out <> outHigh -> + out <> src2 -> + out <> tmp -> + out <> tmp2 -> + outHigh <> src1 -> + outHigh <> src2 -> + outHigh <> tmp -> + outHigh <> tmp2 -> + src1 <> src2 -> + src1 <> tmp -> + src1 <> tmp2 -> + src2 <> tmp -> + src2 <> tmp2 -> + tmp <> tmp2 -> + value_unused tmp cont -> + value_unused tmp2 cont -> + interp256 (Prod.Mul256x256 out outHigh src1 src2 tmp cont) cc ctx = + interp256 ( + Instr MUL128LL out (src1, src2) + (Instr MUL128LU tmp (src1, src2) + (Instr MUL128UL tmp2 (src1, src2) + (Instr MUL128UU outHigh (src1, src2) + (Instr (ADD 128) out (out, tmp2) + (Instr (ADDC (-128)) outHigh (outHigh, tmp2) + (Instr (ADD 128) out (out, tmp) + (Instr (ADDC (-128)) outHigh (outHigh, tmp) cont)))))))) cc ctx. + Proof. + intros; cbv [Prod.Mul256x256]. + repeat (do_interp_step; cbn [spec MUL128LL MUL128UL MUL128LU MUL128UU ADD ADDC] in * ). + + match goal with H : value_unused tmp _ |- _ => erewrite H end. + match goal with H : value_unused tmp2 _ |- _ => erewrite H end. + apply interp_state_equiv. + { rewrite !cc_overwrite_full. + f_equal. + subst. cbn - [Z.add Z.modulo Z.testbit Z.mul Z.shiftl Fancy.lower128 Fancy.upper128]. + lia. } + { intros; cbv [reg_eqb]. + repeat (break_match_step ltac:(fun _ => idtac); try congruence); try reflexivity; [ ]. + subst. cbn - [Z.add Z.modulo Z.testbit Z.mul Z.shiftl Fancy.lower128 Fancy.upper128]. + lia. } + Qed. + + Lemma mulll_comm rd x y cont cc ctx : + ProdEquiv.interp256 (Fancy.Instr Fancy.MUL128LL rd (x, y) cont) cc ctx = ProdEquiv.interp256 (Fancy.Instr Fancy.MUL128LL rd (y, x) cont) cc ctx. + Proof. rewrite !ProdEquiv.interp_step. cbn - [Fancy.interp]. rewrite Z.mul_comm. reflexivity. Qed. + + Lemma mulhh_comm rd x y cont cc ctx : + ProdEquiv.interp256 (Fancy.Instr Fancy.MUL128UU rd (x, y) cont) cc ctx = ProdEquiv.interp256 (Fancy.Instr Fancy.MUL128UU rd (y, x) cont) cc ctx. + Proof. rewrite !ProdEquiv.interp_step. cbn - [Fancy.interp]. rewrite Z.mul_comm. reflexivity. Qed. + + Lemma mullh_mulhl rd x y cont cc ctx : + ProdEquiv.interp256 (Fancy.Instr Fancy.MUL128LU rd (x, y) cont) cc ctx = ProdEquiv.interp256 (Fancy.Instr Fancy.MUL128UL rd (y, x) cont) cc ctx. + Proof. rewrite !ProdEquiv.interp_step. cbn - [Fancy.interp]. rewrite Z.mul_comm. reflexivity. Qed. + + Lemma add_comm rd x y cont cc ctx : + 0 <= ctx x < 2^256 -> + 0 <= ctx y < 2^256 -> + ProdEquiv.interp256 (Fancy.Instr (Fancy.ADD 0) rd (x, y) cont) cc ctx = ProdEquiv.interp256 (Fancy.Instr (Fancy.ADD 0) rd (y, x) cont) cc ctx. + Proof. + intros; rewrite !ProdEquiv.interp_step. cbn - [Fancy.interp]. rewrite Z.add_comm. + rewrite !(Z.mod_small (ctx _)) by (cbn in *; omega). reflexivity. + Qed. + + Lemma addc_comm rd x y cont cc ctx : + 0 <= ctx x < 2^256 -> + 0 <= ctx y < 2^256 -> + ProdEquiv.interp256 (Fancy.Instr (Fancy.ADDC 0) rd (x, y) cont) cc ctx = ProdEquiv.interp256 (Fancy.Instr (Fancy.ADDC 0) rd (y, x) cont) cc ctx. + Proof. + intros; rewrite !ProdEquiv.interp_step. cbn - [Fancy.interp]. rewrite (Z.add_comm (ctx x)). + rewrite !(Z.mod_small (ctx _)) by (cbn in *; omega). reflexivity. + Qed. + + (* Tactics to help prove that something in Fancy is line-by-line equivalent to something in PreFancy *) + Ltac push_value_unused := + repeat match goal with + | |- ~ In _ _ => cbn; intuition; congruence + | _ => apply ProdEquiv.value_unused_overwrite + | _ => apply ProdEquiv.value_unused_skip; [ | congruence | ] + | _ => apply ProdEquiv.value_unused_ret; congruence + end. + + Ltac remember_single_result := + match goal with |- context [(Fancy.spec ?i ?args ?cc) mod ?w] => + let x := fresh "x" in + let y := fresh "y" in + let Heqx := fresh "Heqx" in + remember (Fancy.spec i args cc) as x eqn:Heqx; + remember (x mod w) as y + end. + Ltac step_both_sides := + match goal with |- ProdEquiv.interp256 (Fancy.Instr ?i ?rd1 ?args1 _) _ ?ctx1 = ProdEquiv.interp256 (Fancy.Instr ?i ?rd2 ?args2 _) _ ?ctx2 => + rewrite (ProdEquiv.interp_step i rd1 args1); rewrite (ProdEquiv.interp_step i rd2 args2); + cbn - [Fancy.interp Fancy.spec]; + repeat progress rewrite ?reg_eqb_neq, ?reg_eqb_refl by congruence; + remember_single_result; + lazymatch goal with + | |- context [Fancy.spec i _ _] => + let Heqa1 := fresh in + let Heqa2 := fresh in + remember (Tuple.map (n:=i.(Fancy.num_source_regs)) ctx1 args1) eqn:Heqa1; + remember (Tuple.map (n:=i.(Fancy.num_source_regs)) ctx2 args2) eqn:Heqa2; + cbn in Heqa1; cbn in Heqa2; + repeat progress rewrite ?reg_eqb_neq, ?reg_eqb_refl in Heqa1 by congruence; + repeat progress rewrite ?reg_eqb_neq, ?reg_eqb_refl in Heqa2 by congruence; + let a1 := match type of Heqa1 with _ = ?a1 => a1 end in + let a2 := match type of Heqa2 with _ = ?a2 => a2 end in + (fail 1 "arguments to " i " do not match; LHS has " a1 " and RHS has " a2) + | _ => idtac + end + end. +End ProdEquiv. + +(* Lemmas to help prove that a fancy and prefancy expression have the +same meaning -- should be replaced eventually with a proof of fancy +passes in general. *) + +Module Fancy_PreFancy_Equiv. + Import Fancy.Registers. + + Lemma interp_cast_mod_eq w u x: u = 2^w - 1 -> ident.cast (PreFancy.interp_cast_mod w) r[0 ~> u] x = x mod 2^w. + Proof. + cbv [ident.cast PreFancy.interp_cast_mod upper lower]; intros; subst. + rewrite !Z.eqb_refl. + break_innermost_match; Bool.split_andb; Z.ltb_to_lt; Z.rewrite_mod_small; reflexivity. + Qed. + Lemma interp_cast_mod_flag w x: ident.cast (PreFancy.interp_cast_mod w) r[0 ~> 1] x = x mod 2. + Proof. + cbv [ident.cast PreFancy.interp_cast_mod upper lower]. + break_match; Bool.split_andb; Z.ltb_to_lt; Z.rewrite_mod_small; subst; try omega. + f_equal; omega. + Qed. + + Lemma interp_equivZ {s} w u (Hu : u = 2^w-1) i rd regs e cc ctx idc args f : + (Fancy.spec i (Tuple.map ctx regs) cc + = ident.gen_interp (PreFancy.interp_cast_mod w) (t:=type.arrow _ base.type.Z) idc (PreFancy.interp w args)) -> + ( let r := Fancy.spec i (Tuple.map ctx regs) cc in + Fancy.interp reg_eqb (2 ^ w) Fancy.cc_spec e + (Fancy.CC.update (Fancy.writes_conditions i) r Fancy.cc_spec cc) + (fun n : register => if reg_eqb n rd then r mod 2 ^ w else ctx n) = + @PreFancy.interp w base.type.Z (f (r mod 2 ^ w))) -> + Fancy.interp reg_eqb (2^w) Fancy.cc_spec (Fancy.Instr i rd regs e) cc ctx + = @PreFancy.interp w base.type.Z + (@PreFancy.LetInAppIdentZ s _ (r[0~>2^w-1])%zrange (#idc) args f). + Proof. + cbv zeta; intros spec_eq next_eq. + cbn [Fancy.interp PreFancy.interp]. + cbv [Let_In]. + rewrite next_eq. + cbn in *. + rewrite <-spec_eq. + rewrite interp_cast_mod_eq by omega. + reflexivity. + Qed. + + Lemma interp_equivZZ {s} w (Hw : 2 < 2 ^ w) u (Hu : u = 2^w - 1) i rd regs e cc ctx idc args f : + ((Fancy.spec i (Tuple.map ctx regs) cc) mod 2 ^ w + = fst (ident.gen_interp (PreFancy.interp_cast_mod w) (t:=type.arrow _ (base.type.Z*base.type.Z)) idc (PreFancy.interp w args))) -> + ((if Fancy.cc_spec Fancy.CC.C(Fancy.spec i (Tuple.map ctx regs) cc) then 1 else 0) + = snd (ident.gen_interp (PreFancy.interp_cast_mod w) (t:=type.arrow _ (base.type.Z*base.type.Z)) idc (PreFancy.interp w args)) mod 2) -> + ( let r := Fancy.spec i (Tuple.map ctx regs) cc in + Fancy.interp reg_eqb (2 ^ w) Fancy.cc_spec e + (Fancy.CC.update (Fancy.writes_conditions i) r Fancy.cc_spec cc) + (fun n : register => if reg_eqb n rd then r mod 2 ^ w else ctx n) = + @PreFancy.interp w base.type.Z + (f (r mod 2 ^ w, if (Fancy.cc_spec Fancy.CC.C r) then 1 else 0))) -> + Fancy.interp reg_eqb (2^w) Fancy.cc_spec (Fancy.Instr i rd regs e) cc ctx + = @PreFancy.interp w base.type.Z + (@PreFancy.LetInAppIdentZZ s _ (r[0~>u], r[0~>1])%zrange (#idc) args f). + Proof. + cbv zeta; intros spec_eq1 spec_eq2 next_eq. + cbn [Fancy.interp PreFancy.interp]. + cbv [Let_In]. + cbn [ident.gen_interp]; Prod.eta_expand. + rewrite next_eq. + rewrite interp_cast_mod_eq by omega. + rewrite interp_cast_mod_flag by omega. + cbn -[Fancy.cc_spec] in *. + rewrite <-spec_eq1, <-spec_eq2. + rewrite Z.mod_mod by omega. + reflexivity. + Qed. +End Fancy_PreFancy_Equiv. + +Module Barrett256. + + Definition M := Eval lazy in (2^256-2^224+2^192+2^96-1). + Definition machine_wordsize := 256. + + Derive barrett_red256 + SuchThat (BarrettReduction.rbarrett_red_correctT M machine_wordsize barrett_red256) + As barrett_red256_correct. + Proof. Time solve_rbarrett_red machine_wordsize. Time Qed. + + Definition muLow := Eval lazy in (2 ^ (2 * machine_wordsize) / M) mod (2^machine_wordsize). + (* + Definition barrett_red256_prefancy' := PreFancy.of_Expr machine_wordsize [M; muLow] barrett_red256. + + Derive barrett_red256_prefancy + SuchThat (barrett_red256_prefancy = barrett_red256_prefancy' type.interp) + As barrett_red256_prefancy_eq. + Proof. lazy - [type.interp]; reflexivity. Qed. + *) + + Lemma barrett_reduce_correct_specialized : + forall (xLow xHigh : Z), + 0 <= xLow < 2 ^ machine_wordsize -> + 0 <= xHigh < M -> + BarrettReduction.barrett_reduce machine_wordsize M muLow 2 2 xLow xHigh = (xLow + 2 ^ machine_wordsize * xHigh) mod M. + Proof. + intros. + apply BarrettReduction.barrett_reduce_correct; cbv [machine_wordsize M muLow] in *; + try omega; + try match goal with + | |- context [weight] => intros; cbv [weight]; autorewrite with zsimplify; auto using Z.pow_mul_r with omega + end; lazy; try split; congruence. + Qed. + + (* + (* Note: If this is not factored out, then for some reason Qed takes forever in barrett_red256_correct_full. *) + Lemma barrett_red256_correct_proj2 : + forall xy : type.interp base.interp (base.type.prod base.type.Z base.type.Z), + ZRange.type.option.is_bounded_by + (t:=base.type.prod base.type.Z base.type.Z) + (Some r[0 ~> 2 ^ machine_wordsize - 1]%zrange, Some r[0 ~> 2 ^ machine_wordsize - 1]%zrange) + xy = true -> + type.app_curried (t:=type.arrow (base.type.prod base.type.Z base.type.Z) base.type.Z) (expr.Interp (@ident.interp) barrett_red256) xy = type.app_curried (t:=type.arrow (base.type.prod base.type.Z base.type.Z) base.type.Z) (fun xy => BarrettReduction.barrett_reduce machine_wordsize M muLow 2 2 (fst xy) (snd xy)) xy. + Proof. intros; destruct (barrett_red256_correct xy); assumption. Qed. + Lemma barrett_red256_correct_proj2' : + forall x y : Z, + ZRange.type.option.is_bounded_by + (t:=type.prod type.Z type.Z) + (Some r[0 ~> 2 ^ machine_wordsize - 1]%zrange, Some r[0 ~> 2 ^ machine_wordsize - 1]%zrange) + (x, y) = true -> + expr.Interp (@ident.interp) barrett_red256 (x, y) = BarrettReduction.barrett_reduce machine_wordsize M muLow 2 2 x y. + Proof. intros; rewrite barrett_red256_correct_proj2 by assumption; unfold app_curried; exact eq_refl. Qed. + *) + Strategy -100 [type.app_curried]. + Lemma barrett_red256_correct_full : + forall (xLow xHigh : Z), + 0 <= xLow < 2 ^ machine_wordsize -> + 0 <= xHigh < M -> + PreFancy.Interp 256 barrett_red256 xLow xHigh = (xLow + 2 ^ machine_wordsize * xHigh) mod M. + Proof. + intros. + rewrite <-barrett_reduce_correct_specialized by assumption. + destruct (barrett_red256_correct (xLow, (xHigh, tt))) as [H1 H2]. + { cbn -[Z.pow]. + rewrite !andb_true_iff. + assert (M < 2^machine_wordsize) by (vm_compute; reflexivity). + repeat apply conj; Z.ltb_to_lt; trivial; omega. } + { etransitivity; [ eapply H2 | ]. (* need Strategy -100 [type.app_curried]. for this to be fast *) + generalize BarrettReduction.barrett_reduce; vm_compute; reflexivity. } + Qed. + + (* + Import PreFancy.Tactics. (* for ok_expr_step *) + Lemma barrett_red256_prefancy_correct : + forall xLow xHigh dummy_arrow, + 0 <= xLow < 2 ^ machine_wordsize -> + 0 <= xHigh < M -> + @PreFancy.interp machine_wordsize (PreFancy.interp_cast_mod machine_wordsize) type.Z (barrett_red256_prefancy (xLow, xHigh) dummy_arrow) = (xLow + 2 ^ machine_wordsize * xHigh) mod M. + Proof. + intros. rewrite barrett_red256_prefancy_eq; cbv [barrett_red256_prefancy']. + erewrite PreFancy.of_Expr_correct. + { apply barrett_red256_correct_full; try assumption; reflexivity. } + { reflexivity. } + { lazy; reflexivity. } + { lazy; reflexivity. } + { repeat constructor. } + { cbv [In M muLow]; intros; intuition; subst; cbv; congruence. } + { let r := (eval compute in (2 ^ machine_wordsize)) in + replace (2^machine_wordsize) with r in * by reflexivity. + cbv [M muLow machine_wordsize] in *. + assert (lower r[0~>1] = 0) by reflexivity. + repeat (ok_expr_step; [ ]). + ok_expr_step. + lazy; congruence. + constructor. + constructor. } + { lazy. omega. } + Qed. + *) + Definition barrett_red256_fancy' (xLow xHigh RegMuLow RegMod RegZero error : positive) := + Fancy.of_Expr 3%positive + (fun z => if z =? muLow then Some RegMuLow else if z =? M then Some RegMod else if z =? 0 then Some RegZero else None) + [M; muLow] + barrett_red256 + (xLow, (xHigh, tt)) + error. + Derive barrett_red256_fancy + SuchThat (forall xLow xHigh RegMuLow RegMod RegZero, + barrett_red256_fancy xLow xHigh RegMuLow RegMod RegZero = barrett_red256_fancy' xLow xHigh RegMuLow RegMod RegZero) + As barrett_red256_fancy_eq. + Proof. + intros. + lazy - [Fancy.ADD Fancy.ADDC Fancy.SUB Fancy.SUBC + Fancy.MUL128LL Fancy.MUL128LU Fancy.MUL128UL Fancy.MUL128UU + Fancy.RSHI Fancy.SELC Fancy.SELM Fancy.SELL Fancy.ADDM]. + reflexivity. + Qed. + + Import Fancy.Registers. + + Definition barrett_red256_alloc' xLow xHigh RegMuLow := + fun errorP errorR => + Fancy.allocate register + positive Pos.eqb + errorR + (barrett_red256_fancy 1000%positive 1001%positive 1002%positive 1003%positive 1004%positive errorP) + [r2;r3;r4;r5;r6;r7;r8;r9;r10;r5;r11;r6;r12;r13;r14;r15;r16;r17;r18;r19;r20;r21;r22;r23;r24;r25;r26;r27;r28;r29] + (fun n => if n =? 1000 then xLow + else if n =? 1001 then xHigh + else if n =? 1002 then RegMuLow + else if n =? 1003 then RegMod + else if n =? 1004 then RegZero + else errorR). + Derive barrett_red256_alloc + SuchThat (barrett_red256_alloc = barrett_red256_alloc') + As barrett_red256_alloc_eq. + Proof. + intros. + cbv [barrett_red256_alloc' barrett_red256_fancy]. + cbn. subst barrett_red256_alloc. + reflexivity. + Qed. + + Set Printing Depth 1000. + Import ProdEquiv. + + Local Ltac solve_bounds := + match goal with + | H : ?a = ?b mod ?c |- 0 <= ?a < ?c => rewrite H; apply Z.mod_pos_bound; omega + | _ => assumption + end. + + Lemma barrett_red256_alloc_equivalent errorP errorR cc_start_state start_context : + forall x xHigh RegMuLow scratchp1 scratchp2 scratchp3 scratchp4 scratchp5 extra_reg, + NoDup [x; xHigh; RegMuLow; scratchp1; scratchp2; scratchp3; scratchp4; scratchp5; extra_reg; RegMod; RegZero] -> + 0 <= start_context x < 2^machine_wordsize -> + 0 <= start_context xHigh < 2^machine_wordsize -> + 0 <= start_context RegMuLow < 2^machine_wordsize -> + ProdEquiv.interp256 (barrett_red256_alloc r0 r1 r30 errorP errorR) cc_start_state + (fun r => if reg_eqb r r0 + then start_context x + else if reg_eqb r r1 + then start_context xHigh + else if reg_eqb r r30 + then start_context RegMuLow + else start_context r) + = ProdEquiv.interp256 (Prod.MulMod x xHigh RegMuLow scratchp1 scratchp2 scratchp3 scratchp4 scratchp5) cc_start_state start_context. + Proof. + intros. + let r := eval compute in (2^machine_wordsize) in + replace (2^machine_wordsize) with r in * by reflexivity. + cbv [Prod.MulMod barrett_red256_alloc]. + + (* Extract proofs that no registers are equal to each other *) + repeat match goal with + | H : NoDup _ |- _ => inversion H; subst; clear H + | H : ~ In _ _ |- _ => cbv [In] in H + | H : ~ (_ \/ _) |- _ => apply Decidable.not_or in H; destruct H + | H : ~ False |- _ => clear H + end. + + step_both_sides. + + (* TODO: To prove equivalence between these two, we need to either relocate the RSHI instructions so they're in the same places or use instruction commutativity to push them down. *) + + Admitted. + + Import Fancy_PreFancy_Equiv. + + Definition interp_equivZZ_256 {s} := + @interp_equivZZ s 256 ltac:(cbv; congruence) 115792089237316195423570985008687907853269984665640564039457584007913129639935 ltac:(reflexivity). + Definition interp_equivZ_256 {s} := + @interp_equivZ s 256 115792089237316195423570985008687907853269984665640564039457584007913129639935 ltac:(reflexivity). + + Local Ltac simplify_op_equiv start_ctx := + cbn - [Fancy.spec (*PreFancy.interp_ident*) ident.gen_interp Fancy.cc_spec Z.shiftl]; + repeat match goal with H : start_ctx _ = _ |- _ => rewrite H end; + cbv - [ + Z.rshi Z.cc_m Fancy.CC.cc_m + Z.add_with_get_carry_full Z.add_get_carry_full + Z.sub_get_borrow_full Z.sub_with_get_borrow_full + Z.le Z.lt Z.ltb Z.leb Z.geb Z.eqb Z.land Z.shiftr Z.shiftl + Z.add Z.mul Z.div Z.sub Z.modulo Z.testbit Z.pow Z.ones + fst snd]; cbn [fst snd]; + try (replace (2 ^ (256 / 2) - 1) with (Z.ones 128) by reflexivity; rewrite !Z.land_ones by omega); + autorewrite with to_div_mod; rewrite ?Z.mod_mod, <-?Z.testbit_spec' by omega; + let r := (eval compute in (2 ^ 256)) in + replace (2^256) with r in * by reflexivity; + repeat match goal with + | H : 0 <= ?x < ?m |- context [?x mod ?m] => rewrite (Z.mod_small x m) by apply H + | |- context [?x <? 0] => rewrite (proj2 (Z.ltb_ge x 0)) by (break_match; Z.zero_bounds) + | _ => rewrite Z.mod_small with (b:=2) by (break_match; omega) + | |- context [ (if Z.testbit ?a ?n then 1 else 0) + ?b + ?c] => + replace ((if Z.testbit a n then 1 else 0) + b + c) with (b + c + (if Z.testbit a n then 1 else 0)) by ring + end. + + Local Ltac solve_nonneg ctx := + match goal with x := (Fancy.spec _ _ _) |- _ => subst x end; + simplify_op_equiv ctx; Z.zero_bounds. + + Local Ltac generalize_result := + let v := fresh "v" in intro v; generalize v; clear v; intro v. + + Local Ltac generalize_result_nonneg ctx := + let v := fresh "v" in + let v_nonneg := fresh "v_nonneg" in + intro v; assert (0 <= v) as v_nonneg; [solve_nonneg ctx |generalize v v_nonneg; clear v v_nonneg; intros v v_nonneg]. + + Local Ltac step_abs := + match goal with + | [ |- context G[expr.interp ?ident_interp (expr.Abs ?f) ?x] ] + => let G' := context G[expr.interp ident_interp (f x)] in + change G'; cbv beta + end. + Local Ltac step ctx := + repeat step_abs; + match goal with + | |- Fancy.interp _ _ _ (Fancy.Instr (Fancy.ADD _) _ _ (Fancy.Instr (Fancy.ADDC _) _ _ _)) _ _ = _ => + apply interp_equivZZ_256; [ simplify_op_equiv ctx | simplify_op_equiv ctx | generalize_result_nonneg ctx] + | [ |- _ = expr.interp _ (PreFancy.LetInAppIdentZ _ _ _ _ _ _) ] + => apply interp_equivZ_256; [simplify_op_equiv ctx | generalize_result] + | [ |- _ = expr.interp _ (PreFancy.LetInAppIdentZZ _ _ _ _ _ _) ] + => apply interp_equivZZ_256; [ simplify_op_equiv ctx | simplify_op_equiv ctx | generalize_result] + end. + + (* TODO: move this lemma to ZUtil *) + Lemma testbit_neg_eq_if x n : + 0 <= n -> + - (2 ^ n) <= x < 2 ^ n -> + Z.b2z (if x <? 0 then true else Z.testbit x n) = - (x / 2 ^ n) mod 2. + Proof. + intros. break_match; Z.ltb_to_lt. + { autorewrite with zsimplify. reflexivity. } + { autorewrite with zsimplify. + rewrite Z.bits_above_pow2 by omega. + reflexivity. } + Qed. + + Lemma prod_barrett_red256_correct : + forall (cc_start_state : Fancy.CC.state) (* starting carry flags *) + (start_context : register -> Z) (* starting register values *) + (x xHigh RegMuLow scratchp1 scratchp2 scratchp3 scratchp4 scratchp5 extra_reg : register), (* registers to use in computation *) + NoDup [x; xHigh; RegMuLow; scratchp1; scratchp2; scratchp3; scratchp4; scratchp5; extra_reg; RegMod; RegZero] -> (* registers are unique *) + 0 <= start_context x < 2^machine_wordsize -> + 0 <= start_context xHigh < M -> + start_context RegMuLow = muLow -> + start_context RegMod = M -> + start_context RegZero = 0 -> + cc_start_state.(Fancy.CC.cc_m) = (Z.cc_m (2^256) (start_context xHigh) =? 1) -> + let X := start_context x + 2^machine_wordsize * start_context xHigh in + ProdEquiv.interp256 (Prod.MulMod x xHigh RegMuLow scratchp1 scratchp2 scratchp3 scratchp4 scratchp5) cc_start_state start_context = X mod M. + Proof. + intros. subst X. + assert (0 <= start_context xHigh < 2^machine_wordsize) by (cbv [M] in *; cbn; omega). + let r := (eval compute in (2 ^ machine_wordsize)) in + replace (2^machine_wordsize) with r in * by reflexivity. + cbv [M muLow] in *. + + rewrite <-barrett_red256_correct_full by auto. + rewrite <-barrett_red256_alloc_equivalent with (errorR := RegZero) (errorP := 1%positive) (extra_reg:=extra_reg) + by (auto; cbn; auto with omega). + cbv [ProdEquiv.interp256]. + let r := (eval compute in (2 ^ 256)) in + replace (2^256) with r in * by reflexivity. + cbv [barrett_red256_alloc barrett_red256 expr.Interp]. + + step start_context. + { match goal with H : Fancy.CC.cc_m _ = _ |- _ => rewrite H end. + match goal with |- context [Z.cc_m ?s ?x] => + pose proof (Z.cc_m_small s x ltac:(reflexivity) ltac:(reflexivity) ltac:(omega)); + let H := fresh in + assert (Z.cc_m s x = 1 \/ Z.cc_m s x = 0) as H by omega; + destruct H as [H | H]; rewrite H in * + end; repeat (change (0 =? 1) with false || change (?x =? ?x) with true || cbv beta iota); + break_innermost_match; Z.ltb_to_lt; try congruence. } + apply interp_equivZ_256; [ simplify_op_equiv start_context | ]. (* apply manually instead of using [step] to allow a custom bounds proof *) + { rewrite Z.rshi_correct by omega. + autorewrite with zsimplify_fast. + rewrite Z.shiftr_div_pow2 by omega. + break_innermost_match; Z.ltb_to_lt; try omega. + do 2 f_equal; omega. } + + (* Special case to remember the bound for the output of RSHI *) + let v := fresh "v" in + let v_bound := fresh "v_bound" in + intro v; assert (0 <= v <= 1) as v_bound; [ |generalize v v_bound; clear v v_bound; intros v v_bound]. + { solve_nonneg start_context. autorewrite with zsimplify_fast. + rewrite Z.shiftr_div_pow2 by omega. + rewrite Z.mod_small by admit. + split; [Z.zero_bounds|]. + apply Z.lt_succ_r. + apply Z.div_lt_upper_bound; try lia; admit. } +(* + step start_context. + { rewrite Z.rshi_correct by omega. + rewrite Z.shiftr_div_pow2 by omega. + repeat (f_equal; try ring). } + step start_context; [ reflexivity | ]. + step start_context; [ reflexivity | ]. + step start_context; [ reflexivity | ]. + step start_context; [ reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + step start_context; + [ rewrite Z.mod_small with (b:=2) by (rewrite Z.mod_small by omega; omega); (* Here we make use of the bound of RSHI *) + reflexivity + | rewrite Z.mod_small with (b:=2) by (rewrite Z.mod_small by omega; omega); (* Here we make use of the bound of RSHI *) + reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + step start_context. + { rewrite Z.rshi_correct by omega. + rewrite Z.shiftr_div_pow2 by omega. + repeat (f_equal; try ring). } + + step start_context; [ reflexivity | ]. + step start_context; [ reflexivity | ]. + step start_context; [ reflexivity | ]. + step start_context; [ reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + + step start_context. + { reflexivity. } + { autorewrite with zsimplify_fast. + match goal with |- context [?x mod ?m] => pose proof (Z.mod_pos_bound x m ltac:(omega)) end. + rewrite <-testbit_neg_eq_if with (n:=256) by (cbn; omega). + reflexivity. } + step start_context. + { reflexivity. } + { autorewrite with zsimplify_fast. + rewrite Z.mod_small with (a:=(if (if _ <? 0 then true else _) then _ else _)) (b:=2) by (break_innermost_match; omega). + match goal with |- context [?a - ?b - ?c] => replace (a - b - c) with (a - (b + c)) by ring end. + match goal with |- context [?x mod ?m] => pose proof (Z.mod_pos_bound x m ltac:(omega)) end. + rewrite <-testbit_neg_eq_if with (n:=256) by (break_innermost_match; cbn; omega). + reflexivity. } + step start_context. + { rewrite Z.bit0_eqb. + match goal with |- context [(?x mod ?m) &' 1] => + replace (x mod m) with (x &' Z.ones 256) by (rewrite Z.land_ones by omega; reflexivity) end. + rewrite <-Z.land_assoc. + rewrite Z.land_ones with (n:=1) by omega. + cbn. + match goal with |- context [?x mod 2] => + let H := fresh in + assert (x mod 2 = 0 \/ x mod 2 = 1) as H + by (pose proof (Z.mod_pos_bound x 2 ltac:(omega)); omega); + destruct H as [H | H]; rewrite H + end; reflexivity. } + step start_context. + { reflexivity. } + { autorewrite with zsimplify_fast. + repeat match goal with |- context [?x mod ?m] => unique pose proof (Z.mod_pos_bound x m ltac:(omega)) end. + rewrite <-testbit_neg_eq_if with (n:=256) by (cbn; omega). + reflexivity. } + step start_context; [ break_innermost_match; Z.ltb_to_lt; omega | ]. + reflexivity. +*) + Admitted. + + Import PrintingNotations. + Set Printing Width 1000. + Open Scope expr_scope. + Print barrett_red256. + (* +barrett_red256 = fun var : type -> Type => λ x : var (type.type_primitive type.Z * type.type_primitive type.Z)%ctype, + expr_let x0 := SELM (x₂, 0, 26959946667150639793205513449348445388433292963828203772348655992835) in + expr_let x1 := RSHI (0, x₂, 255) in + expr_let x2 := RSHI (x₂, x₁, 255) in + expr_let x3 := 79228162514264337589248983038 *₂₅₆ (uint128)(x2 >> 128) in + expr_let x4 := 79228162514264337589248983038 *₂₅₆ ((uint128)(x2) & 340282366920938463463374607431768211455) in + expr_let x5 := 340282366841710300930663525764514709507 *₂₅₆ (uint128)(x2 >> 128) in + expr_let x6 := 340282366841710300930663525764514709507 *₂₅₆ ((uint128)(x2) & 340282366920938463463374607431768211455) in + expr_let x7 := ADD_256 ((uint256)(((uint128)(x5) & 340282366920938463463374607431768211455) << 128), x6) in + expr_let x8 := ADDC_256 (x7₂, (uint128)(x5 >> 128), x3) in + expr_let x9 := ADD_256 ((uint256)(((uint128)(x4) & 340282366920938463463374607431768211455) << 128), x7₁) in + expr_let x10 := ADDC_256 (x9₂, (uint128)(x4 >> 128), x8₁) in + expr_let x11 := ADD_256 (x2, x10₁) in + expr_let x12 := ADDC_128 (x11₂, 0, x1) in + expr_let x13 := ADD_256 (x0, x11₁) in + expr_let x14 := ADDC_128 (x13₂, 0, x12₁) in + expr_let x15 := RSHI (x14₁, x13₁, 1) in + expr_let x16 := 340282366841710300967557013911933812736 *₂₅₆ (uint128)(x15 >> 128) in + expr_let x17 := 79228162514264337593543950335 *₂₅₆ (uint128)(x15 >> 128) in + expr_let x18 := 340282366841710300967557013911933812736 *₂₅₆ ((uint128)(x15) & 340282366920938463463374607431768211455) in + expr_let x19 := 79228162514264337593543950335 *₂₅₆ ((uint128)(x15) & 340282366920938463463374607431768211455) in + expr_let x20 := ADD_256 ((uint256)(((uint128)(x18) & 340282366920938463463374607431768211455) << 128), x19) in + expr_let x21 := ADDC_256 (x20₂, (uint128)(x18 >> 128), x16) in + expr_let x22 := ADD_256 ((uint256)(((uint128)(x17) & 340282366920938463463374607431768211455) << 128), x20₁) in + expr_let x23 := ADDC_256 (x22₂, (uint128)(x17 >> 128), x21₁) in + expr_let x24 := SUB_256 (x₁, x22₁) in + expr_let x25 := SUBB_256 (x24₂, x₂, x23₁) in + expr_let x26 := SELL (x25₁, 0, 115792089210356248762697446949407573530086143415290314195533631308867097853951) in + expr_let x27 := SUB_256 (x24₁, x26) in + ADDM (x27₁, 0, 115792089210356248762697446949407573530086143415290314195533631308867097853951) + : Expr (type.uncurry (type.type_primitive type.Z -> type.type_primitive type.Z -> type.type_primitive type.Z)) + *) + + Import PreFancy. + Import PreFancy.Notations. + (* +Local Notation "'RegMod'" := (Straightline.expr.Primitive (t:=type.Z) 115792089210356248762697446949407573530086143415290314195533631308867097853951). + Local Notation "'RegMuLow'" := (Straightline.expr.Primitive (t:=type.Z) 26959946667150639793205513449348445388433292963828203772348655992835). + *) + (* + Print barrett_red256_prefancy. +*) + (* + selm@(y, $x₂, RegZero, RegMuLow); + rshi@(y0, RegZero, $x₂,255); + rshi@(y1, $x₂, $x₁,255); + mulhh@(y2, RegMuLow, $y1); + mulhl@(y3, RegMuLow, $y1); + mullh@(y4, RegMuLow, $y1); + mulll@(y5, RegMuLow, $y1); + add@(y6, $y5, $y4, 128); + addc@(y7, carry{$y6}, $y2, $y4, -128); + add@(y8, $y6, $y3, 128); + addc@(y9, carry{$y8}, $y7, $y3, -128); + add@(y10, $y1, $y9, 0); + addc@(y11, carry{$y10}, RegZero, $y0, 0); #128 + add@(y12, $y, $y10, 0); + addc@(y13, carry{$y12}, RegZero, $y11, 0); #128 + rshi@(y14, $y13, $y12,1); + mulhh@(y15, RegMod, $y14); + mullh@(y16, RegMod, $y14); + mulhl@(y17, RegMod, $y14); + mulll@(y18, RegMod, $y14); + add@(y19, $y18, $y17, 128); + addc@(y20, carry{$y19}, $y15, $y17, -128); + add@(y21, $y19, $y16, 128); + addc@(y22, carry{$y21}, $y20, $y16, -128); + sub@(y23, $x₁, $y21, 0); + subb@(y24, carry{$y23}, $x₂, $y22, 0); + sell@(y25, $y24, RegZero, RegMod); + sub@(y26, $y23, $y25, 0); + addm@(y27, $y26, RegZero, RegMod); + ret $y27 + *) +End Barrett256. + +Module Montgomery256. + + Definition N := Eval lazy in (2^256-2^224+2^192+2^96-1). + Definition N':= (115792089210356248768974548684794254293921932838497980611635986753331132366849). + Definition R := Eval lazy in (2^256). + Definition R' := 115792089183396302114378112356516095823261736990586219612555396166510339686400. + Definition machine_wordsize := 256. + + Derive montred256 + SuchThat (MontgomeryReduction.rmontred_correctT N R N' machine_wordsize montred256) + As montred256_correct. + Proof. Time solve_rmontred machine_wordsize. Time Qed. + + (* + Definition montred256_prefancy' := PreFancy.of_Expr machine_wordsize [N;N'] montred256. + + Derive montred256_prefancy + SuchThat (montred256_prefancy = montred256_prefancy' type.interp) + As montred256_prefancy_eq. + Proof. lazy - [type.interp]; reflexivity. Qed. +*) + + Lemma montred'_correct_specialized R' (R'_correct : Z.equiv_modulo N (R * R') 1) : + forall (lo hi : Z), + 0 <= lo < R -> 0 <= hi < R -> 0 <= lo + R * hi < R * N -> + MontgomeryReduction.montred' N R N' (Z.log2 R) 2 2 (lo, hi) = ((lo + R * hi) * R') mod N. + Proof. + intros. + apply MontgomeryReduction.montred'_correct with (T:=lo + R * hi) (R':=R'); + try match goal with + | |- context[R'] => assumption + | |- context [lo] => + try assumption; progress autorewrite with zsimplify cancel_pair; reflexivity + end; lazy; try split; congruence. + Qed. + + (* + (* Note: If this is not factored out, then for some reason Qed takes forever in montred256_correct_full. *) + Lemma montred256_correct_proj2 : + forall xy : type.interp (type.prod type.Z type.Z), + ZRange.type.option.is_bounded_by + (t:=type.prod type.Z type.Z) + (Some r[0 ~> 2 ^ machine_wordsize - 1]%zrange, Some r[0 ~> 2 ^ machine_wordsize - 1]%zrange) + xy = true -> + expr.Interp (@ident.interp) montred256 xy = app_curried (t:=type.arrow (type.prod type.Z type.Z) type.Z) (MontgomeryReduction.montred' N R N' (Z.log2 R) 2 2) xy. + Proof. intros; destruct (montred256_correct xy); assumption. Qed. + Lemma montred256_correct_proj2' : + forall xy : type.interp (type.prod type.Z type.Z), + ZRange.type.option.is_bounded_by + (t:=type.prod type.Z type.Z) + (Some r[0 ~> 2 ^ machine_wordsize - 1]%zrange, Some r[0 ~> 2 ^ machine_wordsize - 1]%zrange) + xy = true -> + expr.Interp (@ident.interp) montred256 xy = MontgomeryReduction.montred' N R N' (Z.log2 R) 2 2 xy. + Proof. intros; rewrite montred256_correct_proj2 by assumption; unfold app_curried; exact eq_refl. Qed. +*) + Lemma montred256_correct_full R' (R'_correct : Z.equiv_modulo N (R * R') 1) : + forall (lo hi : Z), + 0 <= lo < R -> 0 <= hi < R -> 0 <= lo + R * hi < R * N -> + PreFancy.Interp 256 montred256 (lo, hi) = ((lo + R * hi) * R') mod N. + Proof. + intros. + rewrite <-montred'_correct_specialized by assumption. + destruct (montred256_correct ((lo, hi), tt)) as [H2 H3]. + { cbn -[Z.pow]. + rewrite !andb_true_iff. + repeat apply conj; Z.ltb_to_lt; trivial; cbv [R N machine_wordsize] in *; lia. } + { etransitivity; [ eapply H3 | ]. (* need Strategy -100 [type.app_curried]. for this to be fast *) + generalize MontgomeryReduction.montred'; vm_compute; reflexivity. } + Qed. + + (* + (* TODO : maybe move these ok_expr tactics somewhere else *) + Ltac ok_expr_step' := + match goal with + | _ => assumption + | |- _ <= _ <= _ \/ @eq zrange _ _ => + right; lazy; try split; congruence + | |- _ <= _ <= _ \/ @eq zrange _ _ => + left; lazy; try split; congruence + | |- lower r[0~>_]%zrange = 0 => reflexivity + | |- context [PreFancy.ok_ident] => constructor + | |- context [PreFancy.ok_scalar] => constructor; try omega + | |- context [PreFancy.is_halved] => eapply PreFancy.is_halved_constant; [lazy; reflexivity | ] + | |- context [PreFancy.is_halved] => constructor + | |- context [PreFancy.in_word_range] => lazy; reflexivity + | |- context [PreFancy.in_flag_range] => lazy; reflexivity + | |- context [PreFancy.get_range] => + cbn [PreFancy.get_range lower upper fst snd ZRange.map] + | x : type.interp (type.prod _ _) |- _ => destruct x + | |- (_ <=? _)%zrange = true => + match goal with + | |- context [PreFancy.get_range_var] => + cbv [is_tighter_than_bool PreFancy.has_range fst snd upper lower R N] in *; cbn; + apply andb_true_iff; split; apply Z.leb_le + | _ => lazy + end; omega || reflexivity + | |- @eq zrange _ _ => lazy; reflexivity + | |- _ <= _ => cbv [machine_wordsize]; omega + | |- _ <= _ <= _ => cbv [machine_wordsize]; omega + end; intros. + + (* TODO : maybe move these ok_expr tactics somewhere else *) + Ltac ok_expr_step := + match goal with + | |- context [PreFancy.ok_expr] => constructor; cbn [fst snd]; repeat ok_expr_step' + end; intros; cbn [Nat.max].*) + + (* + Lemma montred256_prefancy_correct : + forall (lo hi : Z), + 0 <= lo < R -> 0 <= hi < R -> 0 <= lo + R * hi < R * N -> + @PreFancy.interp machine_wordsize base.type.Z (montred256 _ @ (##lo,##hi)) = ((lo + R * hi) * R') mod N. + Proof. + intros. + + rewrite montred256_prefancy_eq; cbv [montred256_prefancy']. + erewrite PreFancy.of_Expr_correct. + { apply montred256_correct_full; try assumption; reflexivity. } + { reflexivity. } + { lazy; reflexivity. } + { lazy; reflexivity. } + { repeat constructor. } + { cbv [In N N']; intros; intuition; subst; cbv; congruence. } + { assert (340282366920938463463374607431768211455 * 2 ^ 128 <= 2 ^ machine_wordsize - 1) as shiftl_128_ok by (lazy; congruence). + repeat (ok_expr_step; [ ]). + ok_expr_step. + lazy; congruence. + constructor. + constructor. } + { lazy. omega. } + Qed. +*) + + Definition montred256_fancy' (lo hi RegMod RegPInv RegZero error : positive) := + Fancy.of_Expr 3%positive + (fun z => if z =? N then Some RegMod else if z =? N' then Some RegPInv else if z =? 0 then Some RegZero else None) + [N;N'] + montred256 + ((lo, hi)%positive, tt) + error. + Derive montred256_fancy + SuchThat (forall RegMod RegPInv RegZero, + montred256_fancy RegMod RegPInv RegZero = montred256_fancy' RegMod RegPInv RegZero) + As montred256_fancy_eq. + Proof. + intros. + lazy - [Fancy.ADD Fancy.ADDC Fancy.SUB + Fancy.MUL128LL Fancy.MUL128LU Fancy.MUL128UL Fancy.MUL128UU + Fancy.RSHI Fancy.SELC Fancy.SELM Fancy.SELL Fancy.ADDM]. + reflexivity. + Qed. + + Import Fancy.Registers. + + Definition montred256_alloc' lo hi RegPInv := + fun errorP errorR => + Fancy.allocate register + positive Pos.eqb + errorR + (montred256_fancy 1000%positive 1001%positive 1002%positive 1003%positive 1004%positive errorP) + [r2;r3;r4;r5;r6;r7;r8;r9;r10;r11;r12;r13;r14;r15;r16;r17;r18;r19;r20] + (fun n => if n =? 1000 then lo + else if n =? 1001 then hi + else if n =? 1002 then RegMod + else if n =? 1003 then RegPInv + else if n =? 1004 then RegZero + else errorR). + Derive montred256_alloc + SuchThat (montred256_alloc = montred256_alloc') + As montred256_alloc_eq. + Proof. + intros. + cbv [montred256_alloc' montred256_fancy]. + cbn. subst montred256_alloc. + reflexivity. + Qed. + + Import ProdEquiv. + + Local Ltac solve_bounds := + match goal with + | H : ?a = ?b mod ?c |- 0 <= ?a < ?c => rewrite H; apply Z.mod_pos_bound; omega + | _ => assumption + end. + + Lemma montred256_alloc_equivalent errorP errorR cc_start_state start_context : + forall lo hi y t1 t2 scratch RegPInv extra_reg, + NoDup [lo; hi; y; t1; t2; scratch; RegPInv; extra_reg; RegMod; RegZero] -> + 0 <= start_context lo < R -> + 0 <= start_context hi < R -> + 0 <= start_context RegPInv < R -> + ProdEquiv.interp256 (montred256_alloc r0 r1 r30 errorP errorR) cc_start_state + (fun r => if reg_eqb r r0 + then start_context lo + else if reg_eqb r r1 + then start_context hi + else if reg_eqb r r30 + then start_context RegPInv + else start_context r) + = ProdEquiv.interp256 (Prod.MontRed256 lo hi y t1 t2 scratch RegPInv) cc_start_state start_context. + Proof. + intros. cbv [R] in *. + cbv [Prod.MontRed256 montred256_alloc]. + + (* Extract proofs that no registers are equal to each other *) + repeat match goal with + | H : NoDup _ |- _ => inversion H; subst; clear H + | H : ~ In _ _ |- _ => cbv [In] in H + | H : ~ (_ \/ _) |- _ => apply Decidable.not_or in H; destruct H + | H : ~ False |- _ => clear H + end. + + rewrite ProdEquiv.interp_Mul256 with (tmp2:=extra_reg) by (congruence || push_value_unused). + + rewrite mullh_mulhl. step_both_sides. + rewrite mullh_mulhl. step_both_sides. + (* + step_both_sides. + step_both_sides. + + rewrite ProdEquiv.interp_Mul256x256 with (tmp2:=extra_reg) by (congruence || push_value_unused). + + rewrite mulll_comm. step_both_sides. + step_both_sides. + step_both_sides. + rewrite mulhh_comm. step_both_sides. + step_both_sides. + step_both_sides. + step_both_sides. + step_both_sides. + + + rewrite add_comm by (cbn; solve_bounds). step_both_sides. + rewrite addc_comm by (cbn; solve_bounds). step_both_sides. + step_both_sides. + step_both_sides. + step_both_sides. + + cbn; repeat progress rewrite ?reg_eqb_neq, ?reg_eqb_refl by congruence. + reflexivity.*) + Admitted. + + Import Fancy_PreFancy_Equiv. + + Definition interp_equivZZ_256 {s} := + @interp_equivZZ s 256 ltac:(cbv; congruence) 115792089237316195423570985008687907853269984665640564039457584007913129639935 ltac:(reflexivity). + Definition interp_equivZ_256 {s} := + @interp_equivZ s 256 115792089237316195423570985008687907853269984665640564039457584007913129639935 ltac:(reflexivity). + + Local Ltac simplify_op_equiv start_ctx := + cbn - [Fancy.spec ident.gen_interp Fancy.cc_spec]; + repeat match goal with H : start_ctx _ = _ |- _ => rewrite H end; + cbv - [ + Z.add_with_get_carry_full + Z.add_get_carry_full Z.sub_get_borrow_full + Z.le Z.ltb Z.leb Z.geb Z.eqb Z.land Z.shiftr Z.shiftl + Z.add Z.mul Z.div Z.sub Z.modulo Z.testbit Z.pow Z.ones + fst snd]; cbn [fst snd]; + try (replace (2 ^ (256 / 2) - 1) with (Z.ones 128) by reflexivity; rewrite !Z.land_ones by omega); + autorewrite with to_div_mod; rewrite ?Z.mod_mod, <-?Z.testbit_spec' by omega; + repeat match goal with + | H : 0 <= ?x < ?m |- context [?x mod ?m] => rewrite (Z.mod_small x m) by apply H + | |- context [?x <? 0] => rewrite (proj2 (Z.ltb_ge x 0)) by (break_match; Z.zero_bounds) + | _ => rewrite Z.mod_small with (b:=2) by (break_match; omega) + | |- context [ (if Z.testbit ?a ?n then 1 else 0) + ?b + ?c] => + replace ((if Z.testbit a n then 1 else 0) + b + c) with (b + c + (if Z.testbit a n then 1 else 0)) by ring + end. + + Local Ltac solve_nonneg ctx := + match goal with x := (Fancy.spec _ _ _) |- _ => subst x end; + simplify_op_equiv ctx; Z.zero_bounds. + + Local Ltac generalize_result := + let v := fresh "v" in intro v; generalize v; clear v; intro v. + + Local Ltac generalize_result_nonneg ctx := + let v := fresh "v" in + let v_nonneg := fresh "v_nonneg" in + intro v; assert (0 <= v) as v_nonneg; [solve_nonneg ctx |generalize v v_nonneg; clear v v_nonneg; intros v v_nonneg]. + + Local Ltac step_abs := + match goal with + | [ |- context G[expr.interp ?ident_interp (expr.Abs ?f) ?x] ] + => let G' := context G[expr.interp ident_interp (f x)] in + change G'; cbv beta + end. + Local Ltac step ctx := + repeat step_abs; + match goal with + | |- Fancy.interp _ _ _ (Fancy.Instr (Fancy.ADD _) _ _ (Fancy.Instr (Fancy.ADDC _) _ _ _)) _ _ = _ => + apply interp_equivZZ_256; [ simplify_op_equiv ctx | simplify_op_equiv ctx | generalize_result_nonneg ctx] + | [ |- _ = expr.interp _ (PreFancy.LetInAppIdentZ _ _ _ _ _ _) ] + => apply interp_equivZ_256; [simplify_op_equiv ctx | generalize_result] + | [ |- _ = expr.interp _ (PreFancy.LetInAppIdentZZ _ _ _ _ _ _) ] + => apply interp_equivZZ_256; [ simplify_op_equiv ctx | simplify_op_equiv ctx | generalize_result] + end. + + (* TODO: move this lemma to ZUtil *) + Lemma testbit_neg_eq_if x y n : + 0 <= n -> + 0 <= x < 2 ^ n -> + 0 <= y < 2 ^ n -> + Z.b2z (if (x - y) <? 0 then true else Z.testbit (x - y) n) = - ((x - y) / 2 ^ n) mod 2. + Proof. + intros. rewrite Z.sub_pos_bound_div_eq by omega. + break_innermost_match; Z.ltb_to_lt; try lia; try reflexivity; [ ]. + rewrite Z.testbit_eqb, Z.div_between_0_if by omega. + break_innermost_match; Z.ltb_to_lt; try lia; reflexivity. + Qed. + + Local Ltac break_ifs := + repeat (break_innermost_match_step; Z.ltb_to_lt; try (exfalso; omega); []). + + Lemma prod_montred256_correct : + forall (cc_start_state : Fancy.CC.state) (* starting carry flags can be anything *) + (start_context : register -> Z) (* starting register values *) + (lo hi y t1 t2 scratch RegPInv extra_reg : register), (* registers to use in computation *) + NoDup [lo; hi; y; t1; t2; scratch; RegPInv; extra_reg; RegMod; RegZero] -> (* registers must be distinct *) + start_context RegPInv = N' -> (* RegPInv needs to hold the inverse of the modulus *) + start_context RegMod = N -> (* RegMod needs to hold the modulus *) + start_context RegZero = 0 -> (* RegZero needs to hold zero *) + (0 <= start_context lo < R) -> (* low half of the input is in bounds (R=2^256) *) + (0 <= start_context hi < R) -> (* high half of the input is in bounds (R=2^256) *) + let x := (start_context lo) + R * (start_context hi) in (* x is the input (split into two registers) *) + (0 <= x < R * N) -> (* input precondition *) + (ProdEquiv.interp256 (Prod.MontRed256 lo hi y t1 t2 scratch RegPInv) cc_start_state start_context = (x * R') mod N). + Proof. + intros. subst x. cbv [N R N'] in *. + rewrite <-montred256_correct_full by (auto; vm_compute; reflexivity). + rewrite <-montred256_alloc_equivalent with (errorR := RegZero) (errorP := 1%positive) (extra_reg:=extra_reg) + by (cbv [R]; auto with omega). + cbv [ProdEquiv.interp256]. + cbv [montred256_alloc montred256 expr.Interp]. + + step start_context; [ break_ifs; reflexivity | ]. + step start_context; [ break_ifs; reflexivity | ]. + step start_context; [ break_ifs; reflexivity | ]. + (*step start_context; [ break_ifs; reflexivity | ]. + step start_context; [ break_ifs; reflexivity | break_ifs; reflexivity | ]. + step start_context; [ break_ifs; reflexivity | break_ifs; reflexivity | ]. + step start_context; [ reflexivity | ]. + step start_context; [ reflexivity | ]. + step start_context; [ reflexivity | ]. + step start_context; [ reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + + step start_context; [ reflexivity | reflexivity | ]. + step start_context; [ reflexivity | reflexivity | ]. + step start_context; [ break_innermost_match; Z.ltb_to_lt; omega | ]. + step start_context; [ reflexivity | | ]. + { + let r := eval cbv in (2^256) in replace (2^256) with r by reflexivity. + rewrite !Z.shiftl_0_r, !Z.mod_mod by omega. + apply testbit_neg_eq_if; + let r := eval cbv in (2^256) in replace (2^256) with r by reflexivity; + auto using Z.mod_pos_bound with omega. } + step start_context; [ break_innermost_match; Z.ltb_to_lt; omega | ]. + reflexivity. + *) + Admitted. + + Import PrintingNotations. + Set Printing Width 10000. + + Print montred256. +(* +montred256 = fun var : type -> Type => (λ x : var (type.type_primitive type.Z * type.type_primitive type.Z)%ctype, + expr_let x0 := 79228162514264337593543950337 *₂₅₆ (uint128)(x₁ >> 128) in + expr_let x1 := 340282366841710300986003757985643364352 *₂₅₆ ((uint128)(x₁) & 340282366920938463463374607431768211455) in + expr_let x2 := 79228162514264337593543950337 *₂₅₆ ((uint128)(x₁) & 340282366920938463463374607431768211455) in + expr_let x3 := ADD_256 ((uint256)(((uint128)(x1) & 340282366920938463463374607431768211455) << 128), x2) in + expr_let x4 := ADD_256 ((uint256)(((uint128)(x0) & 340282366920938463463374607431768211455) << 128), x3₁) in + expr_let x5 := 79228162514264337593543950335 *₂₅₆ ((uint128)(x4₁) & 340282366920938463463374607431768211455) in + expr_let x6 := 79228162514264337593543950335 *₂₅₆ (uint128)(x4₁ >> 128) in + expr_let x7 := 340282366841710300967557013911933812736 *₂₅₆ ((uint128)(x4₁) & 340282366920938463463374607431768211455) in + expr_let x8 := 340282366841710300967557013911933812736 *₂₅₆ (uint128)(x4₁ >> 128) in + expr_let x9 := ADD_256 ((uint256)(((uint128)(x7) & 340282366920938463463374607431768211455) << 128), x5) in + expr_let x10 := ADDC_256 (x9₂, (uint128)(x7 >> 128), x8) in + expr_let x11 := ADD_256 ((uint256)(((uint128)(x6) & 340282366920938463463374607431768211455) << 128), x9₁) in + expr_let x12 := ADDC_256 (x11₂, (uint128)(x6 >> 128), x10₁) in + expr_let x13 := ADD_256 (x11₁, x₁) in + expr_let x14 := ADDC_256 (x13₂, x12₁, x₂) in + expr_let x15 := SELC (x14₂, 0, 115792089210356248762697446949407573530086143415290314195533631308867097853951) in + expr_let x16 := SUB_256 (x14₁, x15) in + ADDM (x16₁, 0, 115792089210356248762697446949407573530086143415290314195533631308867097853951))%expr + : Expr (type.uncurry (type.type_primitive type.Z * type.type_primitive type.Z -> type.type_primitive type.Z)) +*) + + Import PreFancy. + Import PreFancy.Notations. + Local Notation "'RegMod'" := (expr.Ident (ident.Literal 115792089210356248762697446949407573530086143415290314195533631308867097853951)). + Local Notation "'RegPInv'" := (expr.Ident (ident.Literal 115792089210356248768974548684794254293921932838497980611635986753331132366849)). + Local Open Scope expr_scope. + Local Notation mulhl := (#(fancy_mulhl 256)). + Local Notation mulhh := (#(fancy_mulhh 256)). + Local Notation mulll := (#(fancy_mulll 256)). + Local Notation mullh := (#(fancy_mullh 256)). + Local Notation selc := (#(fancy_selc)). + Local Notation addm := (#(fancy_addm)). + Notation add n := (#(fancy_add 256 n)). + Notation addc n := (#(fancy_addc 256 n)). + + Print montred256. + (* +montred256 = +fun var : type -> Type => +λ x : var (type.base (base.type.type_base base.type.Z * base.type.type_base base.type.Z)%etype), +mulhl@(x0, x₁, RegPInv); +mullh@(x1, x₁, RegPInv); +mulll@(x2, x₁, RegPInv); +(add 128)@(x3, x2, Lower{x1}); +(add 128)@(x4, x3₁, Lower{x0}); +mulll@(x5, RegMod, x4₁); +mullh@(x6, RegMod, x4₁); +mulhl@(x7, RegMod, x4₁); +mulhh@(x8, RegMod, x4₁); +(add 128)@(x9, x5, Lower{x7}); +(addc (-128))@(x10, carry{$x9}, x8, x7); +(add 128)@(x11, x9₁, Lower{x6}); +(addc (-128))@(x12, carry{$x11}, x10₁, x6); +(add 0)@(x13, x11₁, x₁); +(addc 0)@(x14, carry{$x13}, x12₁, x₂); +selc@(x15, (carry{$x14}, RegZero), RegMod); +#(fancy_sub 256 0)@(x16, x14₁, x15); +addm@(x17, (x16₁, RegZero), RegMod); +x17 + : Expr + (type.base (base.type.type_base base.type.Z * base.type.type_base base.type.Z)%etype -> + type.base (base.type.type_base base.type.Z))%ptype + *) + +End Montgomery256. + +Local Notation "i rd x y ; cont" := (Fancy.Instr i rd (x, y) cont) (at level 40, cont at level 200, format "i rd x y ; '//' cont"). +Local Notation "i rd x y z ; cont" := (Fancy.Instr i rd (x, y, z) cont) (at level 40, cont at level 200, format "i rd x y z ; '//' cont"). + +Import Fancy.Registers. +Import Fancy. + +Import Barrett256 Montgomery256. + +(*** Montgomery Reduction ***) + +(* Status: Code in final form is proven correct modulo admits in compiler portions. *) + +(* Montgomery Code : *) +Eval cbv beta iota delta [Prod.MontRed256 Prod.Mul256 Prod.Mul256x256] in Prod.MontRed256. +(* + = fun lo hi y t1 t2 scratch RegPInv : register => + MUL128LL y lo RegPInv; + MUL128UL t1 lo RegPInv; + ADD 128 y y t1; + MUL128LU t1 lo RegPInv; + ADD 128 y y t1; + MUL128LL t1 y RegMod; + MUL128UU t2 y RegMod; + MUL128UL scratch y RegMod; + ADD 128 t1 t1 scratch; + ADDC (-128) t2 t2 scratch; + MUL128LU scratch y RegMod; + ADD 128 t1 t1 scratch; + ADDC (-128) t2 t2 scratch; + ADD 0 lo lo t1; + ADDC 0 hi hi t2; + SELC y RegMod RegZero; + SUB 0 lo hi y; + ADDM lo lo RegZero RegMod; + Ret lo + *) + +(* Uncomment to see proof statement and remaining admitted statements, +or search for "prod_montred256_correct" to see comments on the proof +preconditions. *) +(* +Check Montgomery256.prod_montred256_correct. +Print Assumptions Montgomery256.prod_montred256_correct. +*) + +(*** Barrett Reduction ***) + +(* Status: Code is proven correct modulo admits in compiler +portions. However, unlike for Montgomery, this code is not proven +equivalent to the register-allocated and efficiently-scheduled +reference (Prod.MulMod). This proof is currently admitted and would +require either fiddling with code generation to make instructions come +out in the right order or reasoning about which instructions +commute. *) + +(* Barrett reference code: *) +Eval cbv beta iota delta [Prod.MulMod Prod.Mul256x256] in Prod.MulMod. +(* + = fun x xHigh RegMuLow scratchp1 scratchp2 scratchp3 scratchp4 scratchp5 : register => + let q1Bottom256 := scratchp1 in + let muSelect := scratchp2 in + let q2 := scratchp3 in + let q2High := scratchp4 in + let q2High2 := scratchp5 in + let q3 := scratchp1 in + let r2 := scratchp2 in + let r2High := scratchp3 in + let maybeM := scratchp1 in + SELM muSelect RegMuLow RegZero; + RSHI 255 q1Bottom256 xHigh x; + MUL128LL q2 q1Bottom256 RegMuLow; + MUL128UU q2High q1Bottom256 RegMuLow; + MUL128UL scratchp5 q1Bottom256 RegMuLow; + ADD 128 q2 q2 scratchp5; + ADDC (-128) q2High q2High scratchp5; + MUL128LU scratchp5 q1Bottom256 RegMuLow; + ADD 128 q2 q2 scratchp5; + ADDC (-128) q2High q2High scratchp5; + RSHI 255 q2High2 RegZero xHigh; + ADD 0 q2High q2High q1Bottom256; + ADDC 0 q2High2 q2High2 RegZero; + ADD 0 q2High q2High muSelect; + ADDC 0 q2High2 q2High2 RegZero; + RSHI 1 q3 q2High2 q2High; + MUL128LL r2 RegMod q3; + MUL128UU r2High RegMod q3; + MUL128UL scratchp4 RegMod q3; + ADD 128 r2 r2 scratchp4; + ADDC (-128) r2High r2High scratchp4; + MUL128LU scratchp4 RegMod q3; + ADD 128 r2 r2 scratchp4; + ADDC (-128) r2High r2High scratchp4; + SUB 0 muSelect x r2; + SUBC 0 xHigh xHigh r2High; + SELL maybeM RegMod RegZero; + SUB 0 q3 muSelect maybeM; + ADDM x q3 RegZero RegMod; + Ret x + *) + +(* Barrett generated code (equivalence with reference admitted) *) +Eval cbv beta iota delta [barrett_red256_alloc] in barrett_red256_alloc. +(* + = fun (xLow xHigh RegMuLow : register) (_ : positive) (_ : register) => + SELM r2 RegMuLow RegZero; + RSHI 255 r3 RegZero xHigh; + RSHI 255 r4 xHigh xLow; + MUL128UU r5 RegMuLow r4; + MUL128UL r6 r4 RegMuLow; + MUL128LU r7 r4 RegMuLow; + MUL128LL r8 RegMuLow r4; + ADD 128 r9 r8 r7; + ADDC (-128) r10 r5 r7; + ADD 128 r5 r9 r6; + ADDC (-128) r11 r10 r6; + ADD 0 r6 r4 r11; + ADDC 0 r12 RegZero r3; + ADD 0 r13 r2 r6; + ADDC 0 r14 RegZero r12; + RSHI 1 r15 r14 r13; + MUL128UU r16 RegMod r15; + MUL128LU r17 r15 RegMod; + MUL128UL r18 r15 RegMod; + MUL128LL r19 RegMod r15; + ADD 128 r20 r19 r18; + ADDC (-128) r21 r16 r18; + ADD 128 r22 r20 r17; + ADDC (-128) r23 r21 r17; + SUB 0 r24 xLow r22; + SUBC 0 r25 xHigh r23; + SELL r26 RegMod RegZero; + SUB 0 r27 r24 r26; + ADDM r28 r27 RegZero RegMod; + Ret r28 + *) + +(* Uncomment to see proof statement and remaining admitted statements. *) +(* +Check prod_barrett_red256_correct. +Print Assumptions prod_barrett_red256_correct. +(* The equivalence with generated code is admitted as barrett_red256_alloc_equivalent. *) +*) diff --git a/src/Experiments/NewPipeline/UnderLets.v b/src/Experiments/NewPipeline/UnderLets.v new file mode 100644 index 000000000..689d53ee1 --- /dev/null +++ b/src/Experiments/NewPipeline/UnderLets.v @@ -0,0 +1,204 @@ +Require Import Crypto.Experiments.NewPipeline.Language. +Require Import Crypto.Util.Notations. + +Module Compilers. + Export Language.Compilers. + Import invert_expr. + + Module SubstVarLike. + Section with_ident. + Context {base_type : Type}. + Local Notation type := (type.type base_type). + Context {ident : type -> Type}. + Local Notation expr := (@expr.expr base_type ident). + Section with_var. + Context {var : type -> Type}. + Section with_var_like. + Context (is_var_like : forall t, @expr var t -> bool). + Fixpoint subst_var_like {t} (e : @expr (@expr var) t) : @expr var t + := match e with + | expr.LetIn tx tC ex eC + => let ex' := @subst_var_like tx ex in + let eC' := fun v => @subst_var_like tC (eC v) in + if is_var_like _ ex' + then eC' ex' + else expr.LetIn ex' (fun v => eC' ($v)) + | expr.App s d f x + => let f' := @subst_var_like _ f in + let x' := @subst_var_like _ x in + expr.App f' x' + | expr.Abs s d f + => expr.Abs (fun v => @subst_var_like _ (f ($v))) + | expr.Var t v => v + | expr.Ident t idc => expr.Ident idc + end%expr. + End with_var_like. + Section with_ident_like. + Context (ident_is_good : forall t, ident t -> bool). + Fixpoint is_recursively_var_or_ident {t} (e : @expr var t) : bool + := match e with + | expr.Ident t idc => ident_is_good _ idc + | expr.Var t v => true + | expr.Abs s d f => false + | expr.App s d f x + => andb (@is_recursively_var_or_ident _ f) + (@is_recursively_var_or_ident _ x) + | expr.LetIn A B x f => false + end. + End with_ident_like. + End with_var. + + Definition SubstVarLike (is_var_like : forall var t, @expr var t -> bool) + {t} (e : expr.Expr t) : expr.Expr t + := fun var => subst_var_like (is_var_like _) (e _). + + Definition SubstVar {t} (e : expr.Expr t) : expr.Expr t + := SubstVarLike (fun _ _ e => match invert_Var e with Some _ => true | None => false end) e. + + Definition SubstVarOrIdent (should_subst_ident : forall t, ident t -> bool) + {t} (e : expr.Expr t) : expr.Expr t + := SubstVarLike (fun var t => is_recursively_var_or_ident should_subst_ident) e. + End with_ident. + + Definition ident_is_var_like {t} (idc : ident t) : bool + := match idc with + | ident.Literal _ _ + | ident.nil _ + | ident.cons _ + | ident.pair _ _ + | ident.fst _ _ + | ident.snd _ _ + | ident.Z_opp + => true + | _ => false + end. + Definition is_var_fst_snd_pair_opp {var} {t} (e : expr (var:=var) t) : bool + := @is_recursively_var_or_ident base.type ident var (@ident_is_var_like) t e. + Definition IsVarFstSndPairOpp {t} (e : expr.Expr t) : bool + := @is_var_fst_snd_pair_opp (fun _ => unit) t (e _). + + Definition SubstVarFstSndPairOpp {t} (e : expr.Expr t) : expr.Expr t + := @SubstVarOrIdent base.type ident (@ident_is_var_like) t e. + End SubstVarLike. + + Module UnderLets. + Section with_var. + Context {base_type : Type}. + Local Notation type := (type base_type). + Context {ident : type -> Type} + {var : type -> Type}. + Local Notation expr := (@expr base_type ident var). + + Inductive UnderLets {T : Type} := + | Base (v : T) + | UnderLet {A} (x : expr A) (f : var A -> UnderLets). + + Fixpoint splice {A B} (x : @UnderLets A) (e : A -> @UnderLets B) : @UnderLets B + := match x with + | Base v => e v + | UnderLet A x f => UnderLet x (fun v => @splice _ _ (f v) e) + end. + + Fixpoint splice_list {A B} (ls : list (@UnderLets A)) (e : list A -> @UnderLets B) : @UnderLets B + := match ls with + | nil => e nil + | cons x xs + => splice x (fun x => @splice_list A B xs (fun xs => e (cons x xs))) + end. + + Fixpoint to_expr {t} (x : @UnderLets (expr t)) : expr t + := match x with + | Base v => v + | UnderLet A x f + => expr.LetIn x (fun v => @to_expr _ (f v)) + end. + Fixpoint of_expr {t} (x : expr t) : @UnderLets (expr t) + := match x in expr.expr t return @UnderLets (expr t) with + | expr.LetIn A B x f + => UnderLet x (fun v => @of_expr B (f v)) + | e => Base e + end. + End with_var. + Module Export Notations. + Global Arguments UnderLets : clear implicits. + Delimit Scope under_lets_scope with under_lets. + Bind Scope under_lets_scope with UnderLets.UnderLets. + Notation "x <-- y ; f" := (UnderLets.splice y (fun x => f%under_lets)) : under_lets_scope. + Notation "x <---- y ; f" := (UnderLets.splice_list y (fun x => f%under_lets)) : under_lets_scope. + End Notations. + + Section reify. + Context {var : type.type base.type -> Type}. + Local Notation type := (type.type base.type). + Local Notation expr := (@expr.expr base.type ident var). + Local Notation UnderLets := (@UnderLets.UnderLets base.type ident var). + Let type_base (t : base.type) : type := type.base t. + Coercion type_base : base.type >-> type. + + Let default_reify_and_let_binds_base_cps {t : base.type} : expr t -> forall T, (expr t -> UnderLets T) -> UnderLets T + := fun e T k + => match invert_expr.invert_Var e with + | Some v => k ($v)%expr + | None => if SubstVarLike.is_var_fst_snd_pair_opp e + then k e + else UnderLets.UnderLet e (fun v => k ($v)%expr) + end. + + Fixpoint reify_and_let_binds_base_cps {t : base.type} : expr t -> forall T, (expr t -> UnderLets T) -> UnderLets T + := match t return expr t -> forall T, (expr t -> UnderLets T) -> UnderLets T with + | base.type.type_base t + => fun e T k + => match invert_Literal e with + | Some v => k (expr.Ident (ident.Literal v)) + | None => @default_reify_and_let_binds_base_cps _ e T k + end + | base.type.prod A B + => fun e T k + => match invert_pair e with + | Some (a, b) + => @reify_and_let_binds_base_cps + A a _ + (fun ae + => @reify_and_let_binds_base_cps + B b _ + (fun be + => k (ae, be)%expr)) + | None => @default_reify_and_let_binds_base_cps _ e T k + end + | base.type.list A + => fun e T k + => match reflect_list e with + | Some ls + => list_rect + _ + (fun k => k []%expr) + (fun x _ rec k + => @reify_and_let_binds_base_cps + A x _ + (fun xe + => rec (fun xse => k (xe :: xse)%expr))) + ls + k + | None => @default_reify_and_let_binds_base_cps _ e T k + end + end%under_lets. + + Fixpoint let_bind_return {t} : expr t -> expr t + := match t return expr t -> expr t with + | type.base t + => fun e => to_expr (v <-- of_expr e; reify_and_let_binds_base_cps v _ Base) + | type.arrow s d + => fun e + => expr.Abs (fun v => @let_bind_return + d + match invert_Abs e with + | Some f => f v + | None => e @ $v + end%expr) + end. + End reify. + Definition LetBindReturn {t} (e : expr.Expr t) : expr.Expr t + := fun var => let_bind_return (e _). + End UnderLets. + Export UnderLets.Notations. +End Compilers. diff --git a/src/Experiments/NewPipeline/fancy_rewrite_head.out b/src/Experiments/NewPipeline/fancy_rewrite_head.out new file mode 100644 index 000000000..bf0910253 --- /dev/null +++ b/src/Experiments/NewPipeline/fancy_rewrite_head.out @@ -0,0 +1,5901 @@ +fancy_rewrite_head = +match idc in (ident t) return (Compile.value' true t) with +| @ident.Literal t v => + match + t as t0 + return + (base.base_interp t0 -> + UnderLets.UnderLets base.type ident var (expr (type.base t0))) + with + | base.type.unit => fun v0 : unit => UnderLets.Base ##(v0)%expr + | base.type.Z => fun v0 : Z => UnderLets.Base ##(v0)%expr + | base.type.bool => fun v0 : bool => UnderLets.Base ##(v0)%expr + | base.type.nat => fun v0 : nat => UnderLets.Base ##(v0)%expr + end v +| ident.Nat_succ => + fun x : expr (type.base base.type.nat) => + UnderLets.Base (#(ident.Nat_succ)%expr @ x)%expr_pat +| ident.Nat_pred => + fun x : expr (type.base base.type.nat) => + UnderLets.Base (#(ident.Nat_pred)%expr @ x)%expr_pat +| ident.Nat_max => + fun x x0 : expr (type.base base.type.nat) => + UnderLets.Base (#(ident.Nat_max)%expr @ x @ x0)%expr_pat +| ident.Nat_mul => + fun x x0 : expr (type.base base.type.nat) => + UnderLets.Base (#(ident.Nat_mul)%expr @ x @ x0)%expr_pat +| ident.Nat_add => + fun x x0 : expr (type.base base.type.nat) => + UnderLets.Base (#(ident.Nat_add)%expr @ x @ x0)%expr_pat +| ident.Nat_sub => + fun x x0 : expr (type.base base.type.nat) => + UnderLets.Base (#(ident.Nat_sub)%expr @ x @ x0)%expr_pat +| @ident.nil t => UnderLets.Base []%expr_pat +| @ident.cons t => + fun (x : expr (type.base t)) (x0 : expr (type.base (base.type.list t))) + => UnderLets.Base (x :: x0)%expr_pat +| @ident.pair A B => + fun (x : expr (type.base A)) (x0 : expr (type.base B)) => + UnderLets.Base (x, x0)%expr_pat +| @ident.fst A B => + fun x : expr (type.base (A * B)%etype) => + UnderLets.Base (#(ident.fst)%expr @ x)%expr_pat +| @ident.snd A B => + fun x : expr (type.base (A * B)%etype) => + UnderLets.Base (#(ident.snd)%expr @ x)%expr_pat +| @ident.pair_rect A B T => + fun + (x : expr (type.base A) -> + expr (type.base B) -> + UnderLets.UnderLets base.type ident var (expr (type.base T))) + (x0 : expr (type.base (A * B)%etype)) => + UnderLets.Base + (#(ident.pair_rect)%expr @ + (λ (x1 : var (type.base A))(x2 : var (type.base B)), + UnderLets.to_expr (x ($x1) ($x2)))%expr @ x0)%expr_pat +| @ident.bool_rect T => + fun + (x + x0 : expr (type.base base.type.unit) -> + UnderLets.UnderLets base.type ident var (expr (type.base T))) + (x1 : expr (type.base base.type.bool)) => + UnderLets.Base + (#(ident.bool_rect)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x0 ($x2)))%expr @ x1)%expr_pat +| @ident.nat_rect P => + fun + (x : expr (type.base base.type.unit) -> + UnderLets.UnderLets base.type ident var (expr (type.base P))) + (x0 : expr (type.base base.type.nat) -> + expr (type.base P) -> + UnderLets.UnderLets base.type ident var (expr (type.base P))) + (x1 : expr (type.base base.type.nat)) => + UnderLets.Base + (#(ident.nat_rect)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ (x2 : var (type.base base.type.nat))(x3 : var (type.base P)), + UnderLets.to_expr (x0 ($x2) ($x3)))%expr @ x1)%expr_pat +| @ident.list_rect A P => + fun + (x : expr (type.base base.type.unit) -> + UnderLets.UnderLets base.type ident var (expr (type.base P))) + (x0 : expr (type.base A) -> + expr (type.base (base.type.list A)) -> + expr (type.base P) -> + UnderLets.UnderLets base.type ident var (expr (type.base P))) + (x1 : expr (type.base (base.type.list A))) => + UnderLets.Base + (#(ident.list_rect)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ (x2 : var (type.base A))(x3 : var (type.base (base.type.list A))) + (x4 : var (type.base P)), + UnderLets.to_expr (x0 ($x2) ($x3) ($x4)))%expr @ x1)%expr_pat +| @ident.list_case A P => + fun + (x : expr (type.base base.type.unit) -> + UnderLets.UnderLets base.type ident var (expr (type.base P))) + (x0 : expr (type.base A) -> + expr (type.base (base.type.list A)) -> + UnderLets.UnderLets base.type ident var (expr (type.base P))) + (x1 : expr (type.base (base.type.list A))) => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ (x2 : var (type.base A))(x3 : var (type.base (base.type.list A))), + UnderLets.to_expr (x0 ($x2) ($x3)))%expr @ x1)%expr_pat +| @ident.List_length T => + fun x : expr (type.base (base.type.list T)) => + UnderLets.Base (#(ident.List_length)%expr @ x)%expr_pat +| ident.List_seq => + fun x x0 : expr (type.base base.type.nat) => + UnderLets.Base (#(ident.List_seq)%expr @ x @ x0)%expr_pat +| @ident.List_repeat A => + fun (x : expr (type.base A)) (x0 : expr (type.base base.type.nat)) => + UnderLets.Base (#(ident.List_repeat)%expr @ x @ x0)%expr_pat +| @ident.List_combine A B => + fun (x : expr (type.base (base.type.list A))) + (x0 : expr (type.base (base.type.list B))) => + UnderLets.Base (#(ident.List_combine)%expr @ x @ x0)%expr_pat +| @ident.List_map A B => + fun + (x : expr (type.base A) -> + UnderLets.UnderLets base.type ident var (expr (type.base B))) + (x0 : expr (type.base (base.type.list A))) => + UnderLets.Base + (#(ident.List_map)%expr @ + (λ x1 : var (type.base A), + UnderLets.to_expr (x ($x1)))%expr @ x0)%expr_pat +| @ident.List_app A => + fun x x0 : expr (type.base (base.type.list A)) => + UnderLets.Base (x ++ x0)%expr +| @ident.List_rev A => + fun x : expr (type.base (base.type.list A)) => + UnderLets.Base (#(ident.List_rev)%expr @ x)%expr_pat +| @ident.List_flat_map A B => + fun + (x : expr (type.base A) -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list B)))) + (x0 : expr (type.base (base.type.list A))) => + UnderLets.Base + (#(ident.List_flat_map)%expr @ + (λ x1 : var (type.base A), + UnderLets.to_expr (x ($x1)))%expr @ x0)%expr_pat +| @ident.List_partition A => + fun + (x : expr (type.base A) -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.bool))) + (x0 : expr (type.base (base.type.list A))) => + UnderLets.Base + (#(ident.List_partition)%expr @ + (λ x1 : var (type.base A), + UnderLets.to_expr (x ($x1)))%expr @ x0)%expr_pat +| @ident.List_fold_right A B => + fun + (x : expr (type.base B) -> + expr (type.base A) -> + UnderLets.UnderLets base.type ident var (expr (type.base A))) + (x0 : expr (type.base A)) (x1 : expr (type.base (base.type.list B))) => + UnderLets.Base + (#(ident.List_fold_right)%expr @ + (λ (x2 : var (type.base B))(x3 : var (type.base A)), + UnderLets.to_expr (x ($x2) ($x3)))%expr @ x0 @ x1)%expr_pat +| @ident.List_update_nth T => + fun (x : expr (type.base base.type.nat)) + (x0 : expr (type.base T) -> + UnderLets.UnderLets base.type ident var (expr (type.base T))) + (x1 : expr (type.base (base.type.list T))) => + UnderLets.Base + (#(ident.List_update_nth)%expr @ x @ + (λ x2 : var (type.base T), + UnderLets.to_expr (x0 ($x2)))%expr @ x1)%expr_pat +| @ident.List_nth_default T => + fun (x : expr (type.base T)) (x0 : expr (type.base (base.type.list T))) + (x1 : expr (type.base base.type.nat)) => + UnderLets.Base (#(ident.List_nth_default)%expr @ x @ x0 @ x1)%expr_pat +| ident.Z_add => + fun x x0 : expr (type.base base.type.Z) => UnderLets.Base (x + x0)%expr +| ident.Z_mul => + fun x x0 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | @expr.App _ _ _ s _ #(idc0)%expr_pat x1 => + match + match idc0 with + | ident.Z_land mask => Some mask + | _ => None + end + with + | Some args0 => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 =? 2 ^ (2 * Z.log2_up args0 / 2) - 1 + then + match + invert_low (2 * Z.log2_up args0) args + with + | Some x2 => + UnderLets.Base + (#(ident.fancy_mulll + (2 * Z.log2_up args0))%expr @ + (##(x2)%expr, x' v))%expr_pat + | None => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + if + args0 =? + 2 ^ (2 * Z.log2_up args0 / 2) - + 1 + then + match + invert_high + (2 * Z.log2_up args0) + args + with + | Some x2 => + UnderLets.Base + (#(ident.fancy_mulhl + (2 * + Z.log2_up args0))%expr @ + (##(x2)%expr, x'0 v0))%expr_pat + | None => + UnderLets.Base + (x * x0)%expr + end + else + UnderLets.Base (x * x0)%expr + | None => + UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + end + else + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + if + args0 =? + 2 ^ (2 * Z.log2_up args0 / 2) - 1 + then + match + invert_high + (2 * Z.log2_up args0) args + with + | Some x2 => + UnderLets.Base + (#(ident.fancy_mulhl + (2 * Z.log2_up args0))%expr @ + (##(x2)%expr, x'0 v0))%expr_pat + | None => + UnderLets.Base (x * x0)%expr + end + else UnderLets.Base (x * x0)%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => + match + match idc0 with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args0 => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match invert_low (2 * args0) args with + | Some x2 => + UnderLets.Base + (#(ident.fancy_mullh (2 * args0))%expr @ + (##(x2)%expr, x' v))%expr_pat + | None => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) => + match a0 with + | Some x'0 => + match + invert_high (2 * args0) + args + with + | Some x2 => + UnderLets.Base + (#(ident.fancy_mulhh + (2 * args0))%expr @ + (##(x2)%expr, + x'0 v0))%expr_pat + | None => + UnderLets.Base + (x * x0)%expr + end + | None => + UnderLets.Base + (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + end + | None => UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s _ + (@expr.LetIn _ _ _ _ _ _ _) _ => UnderLets.Base (x * x0)%expr + | _ => UnderLets.Base (x * x0)%expr + end + | None => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s _ #(idc)%expr_pat x1 => + match + match idc with + | ident.Z_land mask => Some mask + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args =? 2 ^ (2 * Z.log2_up args / 2) - 1 + then + match + invert_low (2 * Z.log2_up args) args0 + with + | Some y => + UnderLets.Base + (#(ident.fancy_mulll + (2 * Z.log2_up args))%expr @ + (x' v, ##(y)%expr))%expr_pat + | None => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + if + args =? + 2 ^ (2 * Z.log2_up args / 2) - + 1 + then + match + invert_high + (2 * Z.log2_up args) + args0 + with + | Some y => + UnderLets.Base + (#(ident.fancy_mullh + (2 * + Z.log2_up args))%expr @ + (x'0 v0, ##(y)%expr))%expr_pat + | None => + UnderLets.Base + (x * x0)%expr + end + else + UnderLets.Base (x * x0)%expr + | None => + UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + end + else + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + if + args =? + 2 ^ (2 * Z.log2_up args / 2) - 1 + then + match + invert_high + (2 * Z.log2_up args) args0 + with + | Some y => + UnderLets.Base + (#(ident.fancy_mullh + (2 * Z.log2_up args))%expr @ + (x'0 v0, ##(y)%expr))%expr_pat + | None => + UnderLets.Base (x * x0)%expr + end + else UnderLets.Base (x * x0)%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s0 _ #(idc0)%expr_pat x2 => + match + match idc0 with + | ident.Z_land mask => Some mask + | _ => None + end + with + | Some args0 => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s0 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + if + (args =? + 2 ^ (2 * Z.log2_up args / 2) - 1) && + (args0 =? + 2 ^ (2 * Z.log2_up args / 2) - 1) + then + UnderLets.Base + (#(ident.fancy_mulll + (2 * Z.log2_up args))%expr @ + (x' v, x'0 v0))%expr_pat + else UnderLets.Base (x * x0)%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x2) + | None => UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => + match + match idc0 with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args0 => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s0 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + if + args =? + 2 ^ (2 * args0 / 2) - 1 + then + UnderLets.Base + (#(ident.fancy_mullh + (2 * args0))%expr @ + (x' v, x'0 v0))%expr_pat + else + UnderLets.Base (x * x0)%expr + | None => + UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x2) + | None => UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s0 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => UnderLets.Base (x * x0)%expr + | _ => UnderLets.Base (x * x0)%expr + end + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match invert_low (2 * args) args0 with + | Some y => + UnderLets.Base + (#(ident.fancy_mulhl (2 * args))%expr @ + (x' v, ##(y)%expr))%expr_pat + | None => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) => + match a0 with + | Some x'0 => + match + invert_high (2 * args) + args0 + with + | Some y => + UnderLets.Base + (#(ident.fancy_mulhh + (2 * args))%expr @ + (x'0 v0, ##(y)%expr))%expr_pat + | None => + UnderLets.Base + (x * x0)%expr + end + | None => + UnderLets.Base + (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + end + | None => UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s0 _ #(idc0)%expr_pat x2 => + match + match idc0 with + | ident.Z_land mask => Some mask + | _ => None + end + with + | Some args0 => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s0 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + if + args0 =? + 2 ^ (2 * args / 2) - 1 + then + UnderLets.Base + (#(ident.fancy_mulhl + (2 * args))%expr @ + (x' v, x'0 v0))%expr_pat + else + UnderLets.Base (x * x0)%expr + | None => + UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x2) + | None => UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => + match + match idc0 with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args0 => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s0 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) => + match a0 with + | Some x'0 => + if args =? args0 + then + UnderLets.Base + (#(ident.fancy_mulhh + (2 * args))%expr @ + (x' v, x'0 v0))%expr_pat + else + UnderLets.Base + (x * x0)%expr + | None => + UnderLets.Base + (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x2) + | None => UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s0 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (x * x0)%expr + | _ => UnderLets.Base (x * x0)%expr + end + | None => UnderLets.Base (x * x0)%expr + end + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ (_ @ _)%expr_pat _ | + @expr.App _ _ _ s _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (x * x0)%expr + | _ => UnderLets.Base (x * x0)%expr + end +| ident.Z_pow => + fun x x0 : expr (type.base base.type.Z) => + UnderLets.Base (#(ident.Z_pow)%expr @ x @ x0)%expr_pat +| ident.Z_sub => + fun x x0 : expr (type.base base.type.Z) => UnderLets.Base (x - x0)%expr +| ident.Z_opp => + fun x : expr (type.base base.type.Z) => UnderLets.Base (- x)%expr +| ident.Z_div => + fun x x0 : expr (type.base base.type.Z) => UnderLets.Base (x / x0)%expr +| ident.Z_modulo => + fun x x0 : expr (type.base base.type.Z) => UnderLets.Base (x mod x0)%expr +| ident.Z_eqb => + fun x x0 : expr (type.base base.type.Z) => + UnderLets.Base (#(ident.Z_eqb)%expr @ x @ x0)%expr_pat +| ident.Z_leb => + fun x x0 : expr (type.base base.type.Z) => + UnderLets.Base (#(ident.Z_leb)%expr @ x @ x0)%expr_pat +| ident.Z_of_nat => + fun x : expr (type.base base.type.nat) => + UnderLets.Base (#(ident.Z_of_nat)%expr @ x)%expr_pat +| ident.Z_shiftr offset => + fun x : expr (type.base base.type.Z) => UnderLets.Base (x >> offset)%expr +| ident.Z_shiftl offset => + fun x : expr (type.base base.type.Z) => UnderLets.Base (x << offset)%expr +| ident.Z_land mask => + fun x : expr (type.base base.type.Z) => + UnderLets.Base (#(ident.Z_land mask)%expr @ x)%expr_pat +| ident.Z_mul_split => + fun x x0 x1 : expr (type.base base.type.Z) => + UnderLets.Base (#(ident.Z_mul_split)%expr @ x @ x0 @ x1)%expr_pat +| ident.Z_mul_split_concrete s => + fun x x0 : expr (type.base base.type.Z) => + UnderLets.Base (#(ident.Z_mul_split_concrete s)%expr @ x @ x0)%expr_pat +| ident.Z_add_get_carry => + fun x x0 x1 : expr (type.base base.type.Z) => + UnderLets.Base (#(ident.Z_add_get_carry)%expr @ x @ x0 @ x1)%expr_pat +| ident.Z_add_get_carry_concrete s => + fun x x0 : expr (type.base base.type.Z) => + match x0 with + | #(_)%expr_pat => + match x with + | @expr.App _ _ _ s0 _ #(idc0)%expr_pat x1 => + match + match idc0 with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) args)%expr @ + (x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + match + match idc0 with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | ($_)%expr => + match x with + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x1 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) args)%expr @ + (x0, x' v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x0, x' v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.Abs _ _ _ _ _ _ => + match x with + | @expr.App _ _ _ s1 _ #(idc)%expr_pat x1 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) args)%expr @ + (x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun _ : Compile.value' false s2 -> Compile.value' true d1 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x1 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) args)%expr @ + (x, x' v))%expr_pat + else + match x with + | @expr.App _ _ _ s1 _ #(idc0)%expr_pat x2 => + match + match idc0 with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args0 => + match + s1 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) + args0)%expr @ (x0, x'0 v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) + 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete + s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete + s)%expr @ x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end (Compile.reflect x2) + | None => + match + match idc0 with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args0 => + match + s1 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add + (Z.log2 s) (- args0))%expr @ + (x0, x'0 v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add + (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete + s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete + s)%expr @ x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end (Compile.reflect x2) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ + s1 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 + _ (_ @ _)%expr_pat _ | @expr.App _ _ _ s1 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match x with + | #(_)%expr_pat => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | ($_)%expr => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x, x' v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | @expr.Abs _ _ _ _ _ _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | @expr.App _ _ _ s1 _ #(idc0)%expr_pat x2 => + match + match idc0 with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args0 => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) args0)%expr @ + (x0, x' v))%expr_pat + else + match + s0 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add + (Z.log2 s) (- args))%expr @ + (x, x'0 v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add + (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete + s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete + s)%expr @ x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end (Compile.reflect x2) + | None => + match + match idc0 with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args0 => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) + (- args))%expr @ (x, x' v))%expr_pat + else + match + s1 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add + (Z.log2 s) + (- args0))%expr @ + (x0, x'0 v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add + (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete + s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete + s)%expr @ x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete + s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) + (- args))%expr @ (x, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete + s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end (Compile.reflect x1) + end + end + | @expr.App _ _ _ s1 _ ($_)%expr _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x, x' v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | @expr.App _ _ _ s1 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App + _ _ _ s1 _ (_ @ _)%expr_pat _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | @expr.App _ _ _ s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | @expr.LetIn _ _ _ _ _ _ _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + end + | None => + match x with + | @expr.App _ _ _ s1 _ #(idc0)%expr_pat x2 => + match + match idc0 with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) args)%expr @ + (x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end (Compile.reflect x2) + | None => + match + match idc0 with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) + (- args))%expr @ (x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete + s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end (Compile.reflect x2) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s1 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ => + match x with + | @expr.App _ _ _ s1 _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) args)%expr @ + (x0, x' v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun _ : Compile.value' false s2 -> Compile.value' true d1 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x2) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x0, x' v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x2) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _ => + match x with + | @expr.App _ _ _ s2 _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s2 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) args)%expr @ + (x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s3 -> d2)%ptype => + fun _ : Compile.value' false s3 -> Compile.value' true d2 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x2) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s2 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x2) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + end + | @expr.App _ _ _ s2 _ ($_)%expr _ | @expr.App _ _ _ s2 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s2 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s2 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat _ => + match x with + | @expr.App _ _ _ s2 _ #(idc)%expr_pat x3 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s2 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) args)%expr @ + (x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s3 -> d2)%ptype => + fun _ : Compile.value' false s3 -> Compile.value' true d2 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x3) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s2 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x3) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + end + | @expr.App _ _ _ s2 _ ($_)%expr _ | @expr.App _ _ _ s2 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s2 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s2 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + match x with + | @expr.App _ _ _ s1 _ #(idc)%expr_pat x3 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) args)%expr @ + (x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun _ : Compile.value' false s2 -> Compile.value' true d1 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x3) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x3) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.LetIn _ _ _ _ _ _ _ => + match x with + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) args)%expr @ + (x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x2) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) (- args))%expr @ + (x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x2) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_add (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + end +| ident.Z_add_with_carry => + fun x x0 x1 : expr (type.base base.type.Z) => + UnderLets.Base (#(ident.Z_add_with_carry)%expr @ x @ x0 @ x1)%expr_pat +| ident.Z_add_with_get_carry => + fun x x0 x1 x2 : expr (type.base base.type.Z) => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ x @ x0 @ x1 @ x2)%expr_pat +| ident.Z_add_with_get_carry_concrete s => + fun x x0 x1 : expr (type.base base.type.Z) => + match x1 with + | #(_)%expr_pat => + match x0 with + | @expr.App _ _ _ s0 _ #(idc0)%expr_pat x2 => + match + match idc0 with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) args)%expr @ + (x, x1, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 + => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x2) + | None => + match + match idc0 with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x1, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + end + | ($_)%expr => + match x0 with + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) args)%expr @ + (x, x1, x' v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 + => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x2) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x1, x' v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + end + | @expr.Abs _ _ _ _ _ _ => + match x0 with + | @expr.App _ _ _ s1 _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) args)%expr @ + (x, x1, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun _ : Compile.value' false s2 -> Compile.value' true d1 + => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x2) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x1, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) args)%expr @ + (x, x0, x' v))%expr_pat + else + match x0 with + | @expr.App _ _ _ s1 _ #(idc0)%expr_pat x3 => + match + match idc0 with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args0 => + match + s1 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) + args0)%expr @ + (x, x1, x'0 v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) + 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + match + match idc0 with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args0 => + match + s1 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc + (Z.log2 s) (- args0))%expr @ + (x, x1, x'0 v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc + (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ + s1 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 + _ (_ @ _)%expr_pat _ | @expr.App _ _ _ s1 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x2) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match x0 with + | #(_)%expr_pat => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x2) + | ($_)%expr => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x0, x' v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x2) + | @expr.Abs _ _ _ _ _ _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x2) + | @expr.App _ _ _ s1 _ #(idc0)%expr_pat x3 => + match + match idc0 with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args0 => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) args0)%expr @ + (x, x1, x' v))%expr_pat + else + match + s0 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc + (Z.log2 s) (- args))%expr @ + (x, x0, x'0 v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc + (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + match + match idc0 with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args0 => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) + (- args))%expr @ (x, x0, x' v))%expr_pat + else + match + s1 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc + (Z.log2 s) + (- args0))%expr @ + (x, x1, x'0 v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc + (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ + x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ + x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) + (- args))%expr @ (x, x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + end + end + | @expr.App _ _ _ s1 _ ($_)%expr _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x0, x' v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x2) + | @expr.App _ _ _ s1 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App + _ _ _ s1 _ (_ @ _)%expr_pat _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x2) + | @expr.App _ _ _ s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x2) + | @expr.LetIn _ _ _ _ _ _ _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x2) + end + | None => + match x0 with + | @expr.App _ _ _ s1 _ #(idc0)%expr_pat x3 => + match + match idc0 with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) args)%expr @ + (x, x1, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + match + match idc0 with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) + (- args))%expr @ (x, x1, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s1 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ => + match x0 with + | @expr.App _ _ _ s1 _ #(idc)%expr_pat x3 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) args)%expr @ + (x, x1, x' v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun _ : Compile.value' false s2 -> Compile.value' true d1 + => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x3) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x1, x' v0))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _ => + match x0 with + | @expr.App _ _ _ s2 _ #(idc)%expr_pat x3 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s2 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) args)%expr @ + (x, x1, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun _ : Compile.value' false s3 -> Compile.value' true d2 + => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x3) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s2 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x1, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + end + | @expr.App _ _ _ s2 _ ($_)%expr _ | @expr.App _ _ _ s2 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s2 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s2 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat _ => + match x0 with + | @expr.App _ _ _ s2 _ #(idc)%expr_pat x4 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s2 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) args)%expr @ + (x, x1, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun _ : Compile.value' false s3 -> Compile.value' true d2 + => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x4) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s2 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x1, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x4) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + end + | @expr.App _ _ _ s2 _ ($_)%expr _ | @expr.App _ _ _ s2 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s2 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s2 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + match x0 with + | @expr.App _ _ _ s1 _ #(idc)%expr_pat x4 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) args)%expr @ + (x, x1, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun _ : Compile.value' false s2 -> Compile.value' true d1 + => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x4) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x1, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x4) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + end + | @expr.LetIn _ _ _ _ _ _ _ => + match x0 with + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x3 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) args)%expr @ + (x, x1, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 + => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x3) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) (- args))%expr @ + (x, x1, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_addc (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + end + end +| ident.Z_sub_get_borrow => + fun x x0 x1 : expr (type.base base.type.Z) => + UnderLets.Base (#(ident.Z_sub_get_borrow)%expr @ x @ x0 @ x1)%expr_pat +| ident.Z_sub_get_borrow_concrete s => + fun x x0 : expr (type.base base.type.Z) => + match x0 with + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x1 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_sub (Z.log2 s) args)%expr @ + (x, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_sub (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_sub (Z.log2 s) (- args))%expr @ + (x, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_sub (Z.log2 s) 0)%expr @ + (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 + => + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_sub (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ x0)%expr_pat + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat _ | + @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_sub (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ x0)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_sub (Z.log2 s) 0)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ x0)%expr_pat + end +| ident.Z_sub_with_get_borrow => + fun x x0 x1 x2 : expr (type.base base.type.Z) => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow)%expr @ x @ x0 @ x1 @ x2)%expr_pat +| ident.Z_sub_with_get_borrow_concrete s => + fun x x0 x1 : expr (type.base base.type.Z) => + match x1 with + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_shiftl offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_subb (Z.log2 s) args)%expr @ + (x, x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_subb (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x2) + | None => + match + match idc with + | ident.Z_shiftr offset => Some offset + | _ => None + end + with + | Some args => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_subb (Z.log2 s) (- args))%expr @ + (x, x0, x' v))%expr_pat + else + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_subb (Z.log2 s) 0)%expr @ + (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 + => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_subb (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat _ | + @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_subb (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ x @ x0 @ x1)%expr_pat + | _ => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_subb (Z.log2 s) 0)%expr @ (x, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ x @ x0 @ x1)%expr_pat + end +| ident.Z_zselect => + fun x x0 x1 : expr (type.base base.type.Z) => + match x with + | @expr.App _ _ _ s _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_cc_m_concrete s0 => Some s0 + | _ => None + end + with + | Some args => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args =? 2 ^ Z.log2 args + then + UnderLets.Base + (#(ident.fancy_selm (Z.log2 args))%expr @ + (x' v, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.fancy_selc)%expr @ (x, x0, x1))%expr_pat + | None => + UnderLets.Base + (#(ident.Z_zselect)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s0 -> d0)%ptype => + fun _ : Compile.value' false s0 -> Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_zselect)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + match + match idc with + | ident.Z_land mask => Some mask + | _ => None + end + with + | Some args => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args =? 1 + then + UnderLets.Base + (#(ident.fancy_sell)%expr @ (x' v, x0, x1))%expr_pat + else + UnderLets.Base + (#(ident.fancy_selc)%expr @ (x, x0, x1))%expr_pat + | None => + UnderLets.Base + (#(ident.Z_zselect)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s0 -> d0)%ptype => + fun _ : Compile.value' false s0 -> Compile.value' true d0 + => + UnderLets.Base + (#(ident.Z_zselect)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.fancy_selc)%expr @ (x, x0, x1))%expr_pat + end + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ (_ @ _)%expr_pat _ | + @expr.App _ _ _ s _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (#(ident.fancy_selc)%expr @ (x, x0, x1))%expr_pat + | _ => UnderLets.Base (#(ident.fancy_selc)%expr @ (x, x0, x1))%expr_pat + end +| ident.Z_add_modulo => + fun x x0 x1 : expr (type.base base.type.Z) => + UnderLets.Base (#(ident.fancy_addm)%expr @ (x, x0, x1))%expr_pat +| ident.Z_rshi => + fun x x0 x1 x2 : expr (type.base base.type.Z) => + UnderLets.Base (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat +| ident.Z_rshi_concrete s offset => + fun x x0 : expr (type.base base.type.Z) => + if s =? 2 ^ Z.log2 s + then + UnderLets.Base + (#(ident.fancy_rshi (Z.log2 s) offset)%expr @ (x, x0))%expr_pat + else + UnderLets.Base + (#(ident.Z_rshi_concrete s offset)%expr @ x @ x0)%expr_pat +| ident.Z_cc_m => + fun x x0 : expr (type.base base.type.Z) => + UnderLets.Base (#(ident.Z_cc_m)%expr @ x @ x0)%expr_pat +| ident.Z_cc_m_concrete s => + fun x : expr (type.base base.type.Z) => + UnderLets.Base (#(ident.Z_cc_m_concrete s)%expr @ x)%expr_pat +| ident.Z_neg_snd => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base (#(ident.Z_neg_snd)%expr @ x)%expr_pat +| ident.Z_cast range => + fun x : expr (type.base base.type.Z) => + UnderLets.Base (#(ident.Z_cast range)%expr @ x)%expr_pat +| ident.Z_cast2 range => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base (#(ident.Z_cast2 range)%expr @ x)%expr_pat +| ident.fancy_add log2wordmax imm => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base (#(ident.fancy_add log2wordmax imm)%expr @ x)%expr_pat +| ident.fancy_addc log2wordmax imm => + fun x : expr (type.base (base.type.Z * base.type.Z * base.type.Z)%etype) + => UnderLets.Base (#(ident.fancy_addc log2wordmax imm)%expr @ x)%expr_pat +| ident.fancy_sub log2wordmax imm => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base (#(ident.fancy_sub log2wordmax imm)%expr @ x)%expr_pat +| ident.fancy_subb log2wordmax imm => + fun x : expr (type.base (base.type.Z * base.type.Z * base.type.Z)%etype) + => UnderLets.Base (#(ident.fancy_subb log2wordmax imm)%expr @ x)%expr_pat +| ident.fancy_mulll log2wordmax => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base (#(ident.fancy_mulll log2wordmax)%expr @ x)%expr_pat +| ident.fancy_mullh log2wordmax => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base (#(ident.fancy_mullh log2wordmax)%expr @ x)%expr_pat +| ident.fancy_mulhl log2wordmax => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base (#(ident.fancy_mulhl log2wordmax)%expr @ x)%expr_pat +| ident.fancy_mulhh log2wordmax => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base (#(ident.fancy_mulhh log2wordmax)%expr @ x)%expr_pat +| ident.fancy_rshi log2wordmax x => + fun x0 : expr (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base (#(ident.fancy_rshi log2wordmax x)%expr @ x0)%expr_pat +| ident.fancy_selc => + fun x : expr (type.base (base.type.Z * base.type.Z * base.type.Z)%etype) + => UnderLets.Base (#(ident.fancy_selc)%expr @ x)%expr_pat +| ident.fancy_selm log2wordmax => + fun x : expr (type.base (base.type.Z * base.type.Z * base.type.Z)%etype) + => UnderLets.Base (#(ident.fancy_selm log2wordmax)%expr @ x)%expr_pat +| ident.fancy_sell => + fun x : expr (type.base (base.type.Z * base.type.Z * base.type.Z)%etype) + => UnderLets.Base (#(ident.fancy_sell)%expr @ x)%expr_pat +| ident.fancy_addm => + fun x : expr (type.base (base.type.Z * base.type.Z * base.type.Z)%etype) + => UnderLets.Base (#(ident.fancy_addm)%expr @ x)%expr_pat +end + : Compile.value' true t diff --git a/src/Experiments/NewPipeline/haskell.sed b/src/Experiments/NewPipeline/haskell.sed new file mode 100644 index 000000000..2ef5dd06d --- /dev/null +++ b/src/Experiments/NewPipeline/haskell.sed @@ -0,0 +1 @@ +s/import qualified Prelude/import qualified Prelude\nimport qualified Data.Bits\nimport qualified Data.Char\nimport qualified Text.Printf\nimport qualified System.Environment\n/g diff --git a/src/Experiments/NewPipeline/rewrite_head.out b/src/Experiments/NewPipeline/rewrite_head.out new file mode 100644 index 000000000..81a45b663 --- /dev/null +++ b/src/Experiments/NewPipeline/rewrite_head.out @@ -0,0 +1,17274 @@ +rewrite_head = +match idc in (ident t) return (Compile.value' true t) with +| @ident.Literal t v => + match + t as t0 + return + (base.base_interp t0 -> + UnderLets.UnderLets base.type ident var (expr (type.base t0))) + with + | base.type.unit => fun v0 : unit => UnderLets.Base ##(v0)%expr + | base.type.Z => fun v0 : Z => UnderLets.Base ##(v0)%expr + | base.type.bool => fun v0 : bool => UnderLets.Base ##(v0)%expr + | base.type.nat => fun v0 : nat => UnderLets.Base ##(v0)%expr + end v +| ident.Nat_succ => + fun x : expr (type.base base.type.nat) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option nat) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args => UnderLets.Base ##(Nat.succ args)%expr + | None => UnderLets.Base (#(ident.Nat_succ)%expr @ x)%expr_pat + end + | _ => UnderLets.Base (#(ident.Nat_succ)%expr @ x)%expr_pat + end +| ident.Nat_pred => + fun x : expr (type.base base.type.nat) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option nat) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args => UnderLets.Base ##(Nat.pred args)%expr + | None => UnderLets.Base (#(ident.Nat_pred)%expr @ x)%expr_pat + end + | _ => UnderLets.Base (#(ident.Nat_pred)%expr @ x)%expr_pat + end +| ident.Nat_max => + fun x x0 : expr (type.base base.type.nat) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option nat) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option nat) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args0 => UnderLets.Base ##(Nat.max args args0)%expr + | None => + UnderLets.Base (#(ident.Nat_max)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Nat_max)%expr @ x @ x0)%expr_pat + end + | None => UnderLets.Base (#(ident.Nat_max)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Nat_max)%expr @ x @ x0)%expr_pat + end +| ident.Nat_mul => + fun x x0 : expr (type.base base.type.nat) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option nat) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option nat) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args0 => UnderLets.Base ##((args * args0)%nat)%expr + | None => + UnderLets.Base (#(ident.Nat_mul)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Nat_mul)%expr @ x @ x0)%expr_pat + end + | None => UnderLets.Base (#(ident.Nat_mul)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Nat_mul)%expr @ x @ x0)%expr_pat + end +| ident.Nat_add => + fun x x0 : expr (type.base base.type.nat) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option nat) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option nat) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args0 => UnderLets.Base ##((args + args0)%nat)%expr + | None => + UnderLets.Base (#(ident.Nat_add)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Nat_add)%expr @ x @ x0)%expr_pat + end + | None => UnderLets.Base (#(ident.Nat_add)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Nat_add)%expr @ x @ x0)%expr_pat + end +| ident.Nat_sub => + fun x x0 : expr (type.base base.type.nat) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option nat) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option nat) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args0 => UnderLets.Base ##((args - args0)%nat)%expr + | None => + UnderLets.Base (#(ident.Nat_sub)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Nat_sub)%expr @ x @ x0)%expr_pat + end + | None => UnderLets.Base (#(ident.Nat_sub)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Nat_sub)%expr @ x @ x0)%expr_pat + end +| @ident.nil t => UnderLets.Base []%expr_pat +| @ident.cons t => + fun (x : expr (type.base t)) (x0 : expr (type.base (base.type.list t))) + => UnderLets.Base (x :: x0)%expr_pat +| @ident.pair A B => + fun (x : expr (type.base A)) (x0 : expr (type.base B)) => + UnderLets.Base (x, x0)%expr_pat +| @ident.fst A B => + fun x : expr (type.base (A * B)%etype) => + match x with + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ #(idc)%expr_pat x1) x0 => + match + match idc with + | @ident.pair A0 B0 => Some (A0, B0) + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var (expr (type.base A))) + with + | type.base t2 => + fun v : expr (type.base t2) => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr (type.base A))) + with + | type.base t3 => + fun _ : expr (type.base t3) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 A + (UnderLets.UnderLets base.type ident var + (expr (type.base A))) + (fun + a : option + (expr (type.base t2) -> expr (type.base A)) => + match a with + | Some x' => UnderLets.Base (x' v) + | None => + UnderLets.Base (#(ident.fst)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 + => UnderLets.Base (#(ident.fst)%expr @ x)%expr_pat + end (Compile.reflect x0) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 => + UnderLets.Base (#(ident.fst)%expr @ x)%expr_pat + end (Compile.reflect x1) + | None => UnderLets.Base (#(ident.fst)%expr @ x)%expr_pat + end + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ ($_)%expr _) _ | @expr.App _ + _ _ s _ (@expr.App _ _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _) _ | @expr.App + _ _ _ s _ (@expr.App _ _ _ s0 _ (_ @ _)%expr_pat _) _ | @expr.App _ _ _ + s _ (@expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _) _ => + UnderLets.Base (#(ident.fst)%expr @ x)%expr_pat + | @expr.App _ _ _ s _ #(_)%expr_pat _ | @expr.App _ _ _ s _ ($_)%expr _ | + @expr.App _ _ _ s _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (#(ident.fst)%expr @ x)%expr_pat + | _ => UnderLets.Base (#(ident.fst)%expr @ x)%expr_pat + end +| @ident.snd A B => + fun x : expr (type.base (A * B)%etype) => + match x with + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ #(idc)%expr_pat x1) x0 => + match + match idc with + | @ident.pair A0 B0 => Some (A0, B0) + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var (expr (type.base B))) + with + | type.base t2 => + fun _ : expr (type.base t2) => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr (type.base B))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t3 B + (UnderLets.UnderLets base.type ident var + (expr (type.base B))) + (fun + a : option + (expr (type.base t3) -> expr (type.base B)) => + match a with + | Some x' => UnderLets.Base (x' v0) + | None => + UnderLets.Base (#(ident.snd)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 + => UnderLets.Base (#(ident.snd)%expr @ x)%expr_pat + end (Compile.reflect x0) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 => + UnderLets.Base (#(ident.snd)%expr @ x)%expr_pat + end (Compile.reflect x1) + | None => UnderLets.Base (#(ident.snd)%expr @ x)%expr_pat + end + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ ($_)%expr _) _ | @expr.App _ + _ _ s _ (@expr.App _ _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _) _ | @expr.App + _ _ _ s _ (@expr.App _ _ _ s0 _ (_ @ _)%expr_pat _) _ | @expr.App _ _ _ + s _ (@expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _) _ => + UnderLets.Base (#(ident.snd)%expr @ x)%expr_pat + | @expr.App _ _ _ s _ #(_)%expr_pat _ | @expr.App _ _ _ s _ ($_)%expr _ | + @expr.App _ _ _ s _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (#(ident.snd)%expr @ x)%expr_pat + | _ => UnderLets.Base (#(ident.snd)%expr @ x)%expr_pat + end +| @ident.pair_rect A B T => + fun + (x : expr (type.base A) -> + expr (type.base B) -> + UnderLets.UnderLets base.type ident var (expr (type.base T))) + (x0 : expr (type.base (A * B)%etype)) => + match x0 with + | @expr.App _ _ _ s _ #(_)%expr_pat _ | @expr.App _ _ _ s _ ($_)%expr _ | + @expr.App _ _ _ s _ (@expr.Abs _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.pair_rect)%expr @ + (λ (x2 : var (type.base A))(x3 : var (type.base B)), + UnderLets.to_expr (x ($x2) ($x3)))%expr @ x0)%expr_pat + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ #(idc)%expr_pat x2) x1 => + match + match idc with + | @ident.pair A0 B0 => Some (A0, B0) + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var (expr (type.base T))) + with + | type.base t2 => + fun v : expr (type.base t2) => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr (type.base T))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + Compile.castbe v + (UnderLets.UnderLets base.type ident var + (expr (type.base T))) + (fun x3 : option (expr (type.base A)) => + match x3 with + | Some x4 => + Compile.castbe v0 + (UnderLets.UnderLets base.type ident var + (expr (type.base T))) + (fun y : option (expr (type.base B)) => + match y with + | Some y0 => + (fv <-- (e <-- x x4 y0; + UnderLets.Base + {| + anyexpr_ty := T; + unwrap := e |}); + base.try_make_transport_cps + (fun t0 : base.type => + expr (type.base t0)) + (let (anyexpr_ty, _) := fv in anyexpr_ty) + T + (UnderLets.UnderLets base.type ident var + (expr (type.base T))) + (fun + a : option + (expr + (type.base + (let (anyexpr_ty, _) := + fv in + anyexpr_ty)) -> + expr (type.base T)) => + match a with + | Some x' => + UnderLets.Base + (x' + (let + (anyexpr_ty, unwrap) as a0 + return + (expr + (type.base + (let + (anyexpr_ty, + _) := a0 in + anyexpr_ty))) := + fv in + unwrap)) + | None => + UnderLets.Base + (#(ident.pair_rect)%expr @ + (λ (x5 : var (type.base A)) + (x6 : var (type.base B)), + UnderLets.to_expr + (x ($x5) ($x6)))%expr @ x0)%expr_pat + end))%under_lets + | None => + UnderLets.Base + (#(ident.pair_rect)%expr @ + (λ (x5 : var (type.base A))(x6 : + var + (type.base + B)), + UnderLets.to_expr (x ($x5) ($x6)))%expr @ + x0)%expr_pat + end) + | None => + UnderLets.Base + (#(ident.pair_rect)%expr @ + (λ (x4 : var (type.base A))(x5 : var + (type.base B)), + UnderLets.to_expr (x ($x4) ($x5)))%expr @ x0)%expr_pat + end) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 + => + UnderLets.Base + (#(ident.pair_rect)%expr @ + (λ (x3 : var (type.base A))(x4 : var (type.base B)), + UnderLets.to_expr (x ($x3) ($x4)))%expr @ x0)%expr_pat + end (Compile.reflect x1) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 => + UnderLets.Base + (#(ident.pair_rect)%expr @ + (λ (x3 : var (type.base A))(x4 : var (type.base B)), + UnderLets.to_expr (x ($x3) ($x4)))%expr @ x0)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.pair_rect)%expr @ + (λ (x3 : var (type.base A))(x4 : var (type.base B)), + UnderLets.to_expr (x ($x3) ($x4)))%expr @ x0)%expr_pat + end + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ ($_)%expr _) _ | @expr.App _ + _ _ s _ (@expr.App _ _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _) _ => + UnderLets.Base + (#(ident.pair_rect)%expr @ + (λ (x3 : var (type.base A))(x4 : var (type.base B)), + UnderLets.to_expr (x ($x3) ($x4)))%expr @ x0)%expr_pat + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ (_ @ _)%expr_pat _) _ | + @expr.App _ _ _ s _ + (@expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _) _ => + UnderLets.Base + (#(ident.pair_rect)%expr @ + (λ (x4 : var (type.base A))(x5 : var (type.base B)), + UnderLets.to_expr (x ($x4) ($x5)))%expr @ x0)%expr_pat + | @expr.App _ _ _ s _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.pair_rect)%expr @ + (λ (x3 : var (type.base A))(x4 : var (type.base B)), + UnderLets.to_expr (x ($x3) ($x4)))%expr @ x0)%expr_pat + | @expr.LetIn _ _ _ _ _ _ _ => + UnderLets.Base + (#(ident.pair_rect)%expr @ + (λ (x2 : var (type.base A))(x3 : var (type.base B)), + UnderLets.to_expr (x ($x2) ($x3)))%expr @ x0)%expr_pat + | _ => + UnderLets.Base + (#(ident.pair_rect)%expr @ + (λ (x1 : var (type.base A))(x2 : var (type.base B)), + UnderLets.to_expr (x ($x1) ($x2)))%expr @ x0)%expr_pat + end +| @ident.bool_rect T => + fun + (x + x0 : expr (type.base base.type.unit) -> + UnderLets.UnderLets base.type ident var (expr (type.base T))) + (x1 : expr (type.base base.type.bool)) => + match x1 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option bool) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun v0 : bool => Some v0 + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + (fv <-- (e <-- (if args as b + return + (UnderLets.UnderLets base.type ident var + (expr (type.base (if b then T else T)))) + then x ##(tt)%expr + else x0 ##(tt)%expr); + UnderLets.Base + {| anyexpr_ty := if args then T else T; unwrap := e |}); + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) + (let (anyexpr_ty, _) := fv in anyexpr_ty) T + (UnderLets.UnderLets base.type ident var (expr (type.base T))) + (fun + a : option + (expr + (type.base + (let (anyexpr_ty, _) := fv in anyexpr_ty)) -> + expr (type.base T)) => + match a with + | Some x' => + UnderLets.Base + (x' + (let + (anyexpr_ty, unwrap) as a0 + return + (expr + (type.base + (let (anyexpr_ty, _) := a0 in anyexpr_ty))) := + fv in + unwrap)) + | None => + UnderLets.Base + (#(ident.bool_rect)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x0 ($x2)))%expr @ x1)%expr_pat + end))%under_lets + | None => + UnderLets.Base + (#(ident.bool_rect)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x0 ($x2)))%expr @ x1)%expr_pat + end + | ($_)%expr | @expr.Abs _ _ _ _ _ _ => + UnderLets.Base + (#(ident.bool_rect)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x0 ($x2)))%expr @ x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.bool_rect)%expr @ + (λ x3 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x3)))%expr @ + (λ x3 : var (type.base base.type.unit), + UnderLets.to_expr (x0 ($x3)))%expr @ x1)%expr_pat + end +| @ident.nat_rect P => + fun + (x : expr (type.base base.type.unit) -> + UnderLets.UnderLets base.type ident var (expr (type.base P))) + (x0 : expr (type.base base.type.nat) -> + expr (type.base P) -> + UnderLets.UnderLets base.type ident var (expr (type.base P))) + (x1 : expr (type.base base.type.nat)) => + match x1 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option nat) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args => + Compile.castv x0 + (UnderLets.UnderLets base.type ident var (expr (type.base P))) + (fun + S_case : option + (expr (type.base base.type.nat) -> + expr (type.base P) -> + UnderLets.UnderLets base.type ident var + (expr (type.base P))) => + match S_case with + | Some S_case0 => + (fv <-- (e <-- nat_rect + (fun _ : nat => + UnderLets.UnderLets base.type ident var + (expr (type.base P))) (x ##(tt)%expr) + (fun (n' : nat) + (rec : UnderLets.UnderLets base.type + ident var + (expr (type.base P))) => + rec0 <-- rec; + S_case0 ##(n')%expr rec0) args; + UnderLets.Base {| anyexpr_ty := P; unwrap := e |}); + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) + (let (anyexpr_ty, _) := fv in anyexpr_ty) P + (UnderLets.UnderLets base.type ident var + (expr (type.base P))) + (fun + a : option + (expr + (type.base + (let (anyexpr_ty, _) := fv in anyexpr_ty)) -> + expr (type.base P)) => + match a with + | Some x' => + UnderLets.Base + (x' + (let + (anyexpr_ty, unwrap) as a0 + return + (expr + (type.base + (let (anyexpr_ty, _) := a0 in + anyexpr_ty))) := fv in + unwrap)) + | None => + UnderLets.Base + (#(ident.nat_rect)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ (x2 : var (type.base base.type.nat)) + (x3 : var (type.base P)), + UnderLets.to_expr (x0 ($x2) ($x3)))%expr @ x1)%expr_pat + end))%under_lets + | None => + UnderLets.Base + (#(ident.nat_rect)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ (x2 : var (type.base base.type.nat))(x3 : var + (type.base + P)), + UnderLets.to_expr (x0 ($x2) ($x3)))%expr @ x1)%expr_pat + end) + | None => + UnderLets.Base + (#(ident.nat_rect)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ (x2 : var (type.base base.type.nat))(x3 : var (type.base P)), + UnderLets.to_expr (x0 ($x2) ($x3)))%expr @ x1)%expr_pat + end + | ($_)%expr | @expr.Abs _ _ _ _ _ _ => + UnderLets.Base + (#(ident.nat_rect)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ (x2 : var (type.base base.type.nat))(x3 : var (type.base P)), + UnderLets.to_expr (x0 ($x2) ($x3)))%expr @ x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.nat_rect)%expr @ + (λ x3 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x3)))%expr @ + (λ (x3 : var (type.base base.type.nat))(x4 : var (type.base P)), + UnderLets.to_expr (x0 ($x3) ($x4)))%expr @ x1)%expr_pat + end +| @ident.list_rect A P => + fun + (x : expr (type.base base.type.unit) -> + UnderLets.UnderLets base.type ident var (expr (type.base P))) + (x0 : expr (type.base A) -> + expr (type.base (base.type.list A)) -> + expr (type.base P) -> + UnderLets.UnderLets base.type ident var (expr (type.base P))) + (x1 : expr (type.base (base.type.list A))) => + Compile.castv x0 + (UnderLets.UnderLets base.type ident var (expr (type.base P))) + (fun + Pcons : option + (expr (type.base A) -> + expr (type.base (base.type.list A)) -> + expr (type.base P) -> + UnderLets.UnderLets base.type ident var + (expr (type.base P))) => + match Pcons with + | Some Pcons0 => + reflect_list_cps x1 + (fun ls : option (list (expr (type.base A))) => + match ls with + | Some ls0 => + (fv <-- (e <-- list_rect + (fun _ : list (expr (type.base A)) => + UnderLets.UnderLets base.type ident var + (expr (type.base P))) (x ##(tt)%expr) + (fun (x2 : expr (type.base A)) + (xs : list (expr (type.base A))) + (rec : UnderLets.UnderLets base.type + ident var (expr (type.base P))) + => + rec' <-- rec; + Pcons0 x2 (reify_list xs) rec') ls0; + UnderLets.Base {| anyexpr_ty := P; unwrap := e |}); + base.try_make_transport_cps + (fun t : base.type => expr (type.base t)) + (let (anyexpr_ty, _) := fv in anyexpr_ty) P + (UnderLets.UnderLets base.type ident var + (expr (type.base P))) + (fun + a : option + (expr + (type.base + (let (anyexpr_ty, _) := fv in anyexpr_ty)) -> + expr (type.base P)) => + match a with + | Some x' => + UnderLets.Base + (x' + (let + (anyexpr_ty, unwrap) as a0 + return + (expr + (type.base + (let (anyexpr_ty, _) := a0 in + anyexpr_ty))) := fv in + unwrap)) + | None => + UnderLets.Base + (#(ident.list_rect)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ (x2 : var (type.base A))(x3 : var + (type.base + (base.type.list + A))) + (x4 : var (type.base P)), + UnderLets.to_expr (x0 ($x2) ($x3) ($x4)))%expr @ + x1)%expr_pat + end))%under_lets + | None => + UnderLets.Base + (#(ident.list_rect)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ (x2 : var (type.base A))(x3 : var + (type.base + (base.type.list A))) + (x4 : var (type.base P)), + UnderLets.to_expr (x0 ($x2) ($x3) ($x4)))%expr @ x1)%expr_pat + end) + | None => + UnderLets.Base + (#(ident.list_rect)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ (x2 : var (type.base A))(x3 : var + (type.base + (base.type.list A))) + (x4 : var (type.base P)), + UnderLets.to_expr (x0 ($x2) ($x3) ($x4)))%expr @ x1)%expr_pat + end) +| @ident.list_case A P => + fun + (x : expr (type.base base.type.unit) -> + UnderLets.UnderLets base.type ident var (expr (type.base P))) + (x0 : expr (type.base A) -> + expr (type.base (base.type.list A)) -> + UnderLets.UnderLets base.type ident var (expr (type.base P))) + (x1 : expr (type.base (base.type.list A))) => + match x1 with + | #(idc)%expr_pat => + match match idc with + | @ident.nil t0 => Some t0 + | _ => None + end with + | Some _ => + (fv <-- (e <-- x ##(tt)%expr; + UnderLets.Base {| anyexpr_ty := P; unwrap := e |}); + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) + (let (anyexpr_ty, _) := fv in anyexpr_ty) P + (UnderLets.UnderLets base.type ident var (expr (type.base P))) + (fun + a : option + (expr + (type.base + (let (anyexpr_ty, _) := fv in anyexpr_ty)) -> + expr (type.base P)) => + match a with + | Some x' => + UnderLets.Base + (x' + (let + (anyexpr_ty, unwrap) as a0 + return + (expr + (type.base + (let (anyexpr_ty, _) := a0 in anyexpr_ty))) := + fv in + unwrap)) + | None => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ (x2 : var (type.base A))(x3 : var + (type.base + (base.type.list + A))), + UnderLets.to_expr (x0 ($x2) ($x3)))%expr @ x1)%expr_pat + end))%under_lets + | None => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ (x2 : var (type.base A))(x3 : var + (type.base + (base.type.list A))), + UnderLets.to_expr (x0 ($x2) ($x3)))%expr @ x1)%expr_pat + end + | @expr.App _ _ _ s _ #(_)%expr_pat _ | @expr.App _ _ _ s _ ($_)%expr _ | + @expr.App _ _ _ s _ (@expr.Abs _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x3 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x3)))%expr @ + (λ (x3 : var (type.base A))(x4 : var + (type.base (base.type.list A))), + UnderLets.to_expr (x0 ($x3) ($x4)))%expr @ x1)%expr_pat + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ #(idc)%expr_pat x3) x2 => + match match idc with + | @ident.cons t0 => Some t0 + | _ => None + end with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var (expr (type.base P))) + with + | type.base t2 => + fun v : expr (type.base t2) => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr (type.base P))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + Compile.castbe v + (UnderLets.UnderLets base.type ident var + (expr (type.base P))) + (fun x4 : option (expr (type.base A)) => + match x4 with + | Some x5 => + Compile.castbe v0 + (UnderLets.UnderLets base.type ident var + (expr (type.base P))) + (fun + xs : option + (expr (type.base (base.type.list A))) + => + match xs with + | Some xs0 => + (fv <-- (e <-- x0 x5 xs0; + UnderLets.Base + {| + anyexpr_ty := P; + unwrap := e |}); + base.try_make_transport_cps + (fun t0 : base.type => + expr (type.base t0)) + (let (anyexpr_ty, _) := fv in anyexpr_ty) + P + (UnderLets.UnderLets base.type ident var + (expr (type.base P))) + (fun + a : option + (expr + (type.base + (let (anyexpr_ty, _) := + fv in + anyexpr_ty)) -> + expr (type.base P)) => + match a with + | Some x' => + UnderLets.Base + (x' + (let + (anyexpr_ty, unwrap) as a0 + return + (expr + (type.base + (let + (anyexpr_ty, + _) := a0 in + anyexpr_ty))) := + fv in + unwrap)) + | None => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x6 : var + (type.base + base.type.unit), + UnderLets.to_expr (x ($x6)))%expr @ + (λ (x6 : var (type.base A)) + (x7 : var + (type.base + (base.type.list A))), + UnderLets.to_expr + (x0 ($x6) ($x7)))%expr @ x1)%expr_pat + end))%under_lets + | None => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x6 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x6)))%expr @ + (λ (x6 : var (type.base A))(x7 : + var + (type.base + (base.type.list + A))), + UnderLets.to_expr (x0 ($x6) ($x7)))%expr @ + x1)%expr_pat + end) + | None => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x5 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x5)))%expr @ + (λ (x5 : var (type.base A))(x6 : var + (type.base + (base.type.list + A))), + UnderLets.to_expr (x0 ($x5) ($x6)))%expr @ x1)%expr_pat + end) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 + => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x4 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x4)))%expr @ + (λ (x4 : var (type.base A))(x5 : var + (type.base + (base.type.list + A))), + UnderLets.to_expr (x0 ($x4) ($x5)))%expr @ x1)%expr_pat + end (Compile.reflect x2) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x4 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x4)))%expr @ + (λ (x4 : var (type.base A))(x5 : var + (type.base + (base.type.list A))), + UnderLets.to_expr (x0 ($x4) ($x5)))%expr @ x1)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x4 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x4)))%expr @ + (λ (x4 : var (type.base A))(x5 : var + (type.base + (base.type.list A))), + UnderLets.to_expr (x0 ($x4) ($x5)))%expr @ x1)%expr_pat + end + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ ($_)%expr _) _ | @expr.App _ + _ _ s _ (@expr.App _ _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _) _ => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x4 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x4)))%expr @ + (λ (x4 : var (type.base A))(x5 : var + (type.base (base.type.list A))), + UnderLets.to_expr (x0 ($x4) ($x5)))%expr @ x1)%expr_pat + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ (_ @ _)%expr_pat _) _ | + @expr.App _ _ _ s _ + (@expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _) _ => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x5 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x5)))%expr @ + (λ (x5 : var (type.base A))(x6 : var + (type.base (base.type.list A))), + UnderLets.to_expr (x0 ($x5) ($x6)))%expr @ x1)%expr_pat + | @expr.App _ _ _ s _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x4 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x4)))%expr @ + (λ (x4 : var (type.base A))(x5 : var + (type.base (base.type.list A))), + UnderLets.to_expr (x0 ($x4) ($x5)))%expr @ x1)%expr_pat + | @expr.LetIn _ _ _ _ _ _ _ => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x3 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x3)))%expr @ + (λ (x3 : var (type.base A))(x4 : var + (type.base (base.type.list A))), + UnderLets.to_expr (x0 ($x3) ($x4)))%expr @ x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.list_case)%expr @ + (λ x2 : var (type.base base.type.unit), + UnderLets.to_expr (x ($x2)))%expr @ + (λ (x2 : var (type.base A))(x3 : var + (type.base (base.type.list A))), + UnderLets.to_expr (x0 ($x2) ($x3)))%expr @ x1)%expr_pat + end +| @ident.List_length T => + fun x : expr (type.base (base.type.list T)) => + reflect_list_cps x + (fun xs : option (list (expr (type.base T))) => + match xs with + | Some xs0 => UnderLets.Base ##(length xs0)%expr + | None => UnderLets.Base (#(ident.List_length)%expr @ x)%expr_pat + end) +| ident.List_seq => + fun x x0 : expr (type.base base.type.nat) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option nat) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option nat) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args0 => + UnderLets.Base + (fold_right + (fun (x1 : expr (type.base base.type.nat)) + (xs : expr + (type.base (base.type.list base.type.nat))) + => (x1 :: xs)%expr_pat) []%expr_pat + (map (fun v : nat => ##(v)%expr) (seq args args0))) + | None => + UnderLets.Base (#(ident.List_seq)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.List_seq)%expr @ x @ x0)%expr_pat + end + | None => UnderLets.Base (#(ident.List_seq)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.List_seq)%expr @ x @ x0)%expr_pat + end +| @ident.List_repeat A => + fun (x : expr (type.base A)) (x0 : expr (type.base base.type.nat)) => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option nat) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args => + base.try_make_transport_cps + (fun A0 : base.type => expr (type.base (base.type.list A0))) A + A + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list A)))) + (fun + a : option + (expr (type.base (base.type.list A)) -> + expr (type.base (base.type.list A))) => + match a with + | Some x' => UnderLets.Base (x' (reify_list (repeat x args))) + | None => + UnderLets.Base + (#(ident.List_repeat)%expr @ x @ x0)%expr_pat + end) + | None => + UnderLets.Base (#(ident.List_repeat)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.List_repeat)%expr @ x @ x0)%expr_pat + end +| @ident.List_combine A B => + fun (x : expr (type.base (base.type.list A))) + (x0 : expr (type.base (base.type.list B))) => + reflect_list_cps x + (fun xs : option (list (expr (type.base A))) => + match xs with + | Some xs0 => + reflect_list_cps x0 + (fun ys : option (list (expr (type.base B))) => + match ys with + | Some ys0 => + (trA <-- base.try_make_transport_cps + (fun A0 : base.type => + expr (type.base (base.type.list (A0 * B)))) A A; + trB <-- base.try_make_transport_cps + (fun B0 : base.type => + expr (type.base (base.type.list (A * B0)))) B B; + return Some + (fun + v : expr (type.base (base.type.list (A * B))) + => trB (trA v)))%cps + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list (A * B))))) + (fun + a : option + (expr (type.base (base.type.list (A * B))) -> + expr (type.base (base.type.list (A * B)))) => + match a with + | Some x' => + UnderLets.Base + (x' + (reify_list + (map (fun '(x1, y) => (x1, y)%expr_pat) + (combine xs0 ys0)))) + | None => + UnderLets.Base + (#(ident.List_combine)%expr @ x @ x0)%expr_pat + end) + | None => + UnderLets.Base + (#(ident.List_combine)%expr @ x @ x0)%expr_pat + end) + | None => + UnderLets.Base (#(ident.List_combine)%expr @ x @ x0)%expr_pat + end) +| @ident.List_map A B => + fun + (x : expr (type.base A) -> + UnderLets.UnderLets base.type ident var (expr (type.base B))) + (x0 : expr (type.base (base.type.list A))) => + Compile.castbe x0 + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list B)))) + (fun e : option (expr (type.base (base.type.list A))) => + match e with + | Some e0 => + reflect_list_cps e0 + (fun ls : option (list (expr (type.base A))) => + match ls with + | Some ls0 => + (fv <-- (e1 <-- list_rect + (fun _ : list (expr (type.base A)) => + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list B)))) + (UnderLets.Base []%expr_pat) + (fun (x1 : expr (type.base A)) + (_ : list (expr (type.base A))) + (rec : UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.list B)))) + => + rec' <-- rec; + fx <-- x x1; + UnderLets.Base (fx :: rec')%expr_pat) + ls0; + UnderLets.Base + {| + anyexpr_ty := base.type.list B; + unwrap := e1 |}); + base.try_make_transport_cps + (fun t : base.type => expr (type.base t)) + (let (anyexpr_ty, _) := fv in anyexpr_ty) + (base.type.list B) + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list B)))) + (fun + a : option + (expr + (type.base + (let (anyexpr_ty, _) := fv in anyexpr_ty)) -> + expr (type.base (base.type.list B))) => + match a with + | Some x' => + UnderLets.Base + (x' + (let + (anyexpr_ty, unwrap) as a0 + return + (expr + (type.base + (let (anyexpr_ty, _) := a0 in + anyexpr_ty))) := fv in + unwrap)) + | None => + UnderLets.Base + (#(ident.List_map)%expr @ + (λ x1 : var (type.base A), + UnderLets.to_expr (x ($x1)))%expr @ x0)%expr_pat + end))%under_lets + | None => + UnderLets.Base + (#(ident.List_map)%expr @ + (λ x1 : var (type.base A), + UnderLets.to_expr (x ($x1)))%expr @ x0)%expr_pat + end) + | None => + UnderLets.Base + (#(ident.List_map)%expr @ + (λ x1 : var (type.base A), + UnderLets.to_expr (x ($x1)))%expr @ x0)%expr_pat + end) +| @ident.List_app A => + fun x x0 : expr (type.base (base.type.list A)) => + Compile.castbe x + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list A)))) + (fun e : option (expr (type.base (base.type.list A))) => + match e with + | Some e0 => + reflect_list_cps e0 + (fun ls : option (list (expr (type.base A))) => + match ls with + | Some ls0 => + (fv <-- (e1 <-- list_rect + (fun _ : list (expr (type.base A)) => + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list A)))) + (UnderLets.Base x0) + (fun (x1 : expr (type.base A)) + (_ : list (expr (type.base A))) + (rec : UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.list A)))) + => + rec' <-- rec; + UnderLets.Base (x1 :: rec')%expr_pat) + ls0; + UnderLets.Base + {| + anyexpr_ty := base.type.list A; + unwrap := e1 |}); + base.try_make_transport_cps + (fun t : base.type => expr (type.base t)) + (let (anyexpr_ty, _) := fv in anyexpr_ty) + (base.type.list A) + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list A)))) + (fun + a : option + (expr + (type.base + (let (anyexpr_ty, _) := fv in anyexpr_ty)) -> + expr (type.base (base.type.list A))) => + match a with + | Some x' => + UnderLets.Base + (x' + (let + (anyexpr_ty, unwrap) as a0 + return + (expr + (type.base + (let (anyexpr_ty, _) := a0 in + anyexpr_ty))) := fv in + unwrap)) + | None => UnderLets.Base (x ++ x0)%expr + end))%under_lets + | None => UnderLets.Base (x ++ x0)%expr + end) + | None => UnderLets.Base (x ++ x0)%expr + end) +| @ident.List_rev A => + fun x : expr (type.base (base.type.list A)) => + reflect_list_cps x + (fun xs : option (list (expr (type.base A))) => + match xs with + | Some xs0 => + base.try_make_transport_cps + (fun A0 : base.type => expr (type.base (base.type.list A0))) A A + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list A)))) + (fun + a : option + (expr (type.base (base.type.list A)) -> + expr (type.base (base.type.list A))) => + match a with + | Some x' => UnderLets.Base (x' (reify_list (rev xs0))) + | None => UnderLets.Base (#(ident.List_rev)%expr @ x)%expr_pat + end) + | None => UnderLets.Base (#(ident.List_rev)%expr @ x)%expr_pat + end) +| @ident.List_flat_map A B => + fun + (x : expr (type.base A) -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list B)))) + (x0 : expr (type.base (base.type.list A))) => + Compile.castbe x0 + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list B)))) + (fun e : option (expr (type.base (base.type.list A))) => + match e with + | Some e0 => + reflect_list_cps e0 + (fun ls : option (list (expr (type.base A))) => + match ls with + | Some ls0 => + (fv <-- (e1 <-- list_rect + (fun _ : list (expr (type.base A)) => + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list B)))) + (UnderLets.Base []%expr_pat) + (fun (x1 : expr (type.base A)) + (_ : list (expr (type.base A))) + (rec : UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.list B)))) + => + rec' <-- rec; + fx <-- x x1; + UnderLets.Base ($fx ++ rec')%expr) ls0; + UnderLets.Base + {| + anyexpr_ty := base.type.list B; + unwrap := e1 |}); + fv0 <-- do_again (let (anyexpr_ty, _) := fv in anyexpr_ty) + (let + (anyexpr_ty, unwrap) as a + return + (expr + (type.base + (let (anyexpr_ty, _) := a in + anyexpr_ty))) := fv in + unwrap); + base.try_make_transport_cps + (fun t : base.type => expr (type.base t)) + (let (anyexpr_ty, _) := fv in anyexpr_ty) + (base.type.list B) + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list B)))) + (fun + a : option + (expr + (type.base + (let (anyexpr_ty, _) := fv in anyexpr_ty)) -> + expr (type.base (base.type.list B))) => + match a with + | Some x' => UnderLets.Base (x' fv0) + | None => + UnderLets.Base + (#(ident.List_flat_map)%expr @ + (λ x1 : var (type.base A), + UnderLets.to_expr (x ($x1)))%expr @ x0)%expr_pat + end))%under_lets + | None => + UnderLets.Base + (#(ident.List_flat_map)%expr @ + (λ x1 : var (type.base A), + UnderLets.to_expr (x ($x1)))%expr @ x0)%expr_pat + end) + | None => + UnderLets.Base + (#(ident.List_flat_map)%expr @ + (λ x1 : var (type.base A), + UnderLets.to_expr (x ($x1)))%expr @ x0)%expr_pat + end) +| @ident.List_partition A => + fun + (x : expr (type.base A) -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.bool))) + (x0 : expr (type.base (base.type.list A))) => + Compile.castbe x0 + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list A * base.type.list A)%etype))) + (fun e : option (expr (type.base (base.type.list A))) => + match e with + | Some e0 => + reflect_list_cps e0 + (fun ls : option (list (expr (type.base A))) => + match ls with + | Some ls0 => + (fv <-- (e1 <-- list_rect + (fun _ : list (expr (type.base A)) => + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.list A * + base.type.list A)%etype))) + (UnderLets.Base ([], [])%expr_pat) + (fun (x1 : expr (type.base A)) + (_ : list (expr (type.base A))) + (rec : UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.list A * + base.type.list A)%etype))) + => + rec' <-- rec; + fx <-- id x x1; + UnderLets.Base + (#(ident.pair_rect)%expr @ + (λ g + d : expr + (type.base + (base.type.list A)), + (#(ident.bool_rect)%expr @ + (λ _ : expr + (type.base base.type.unit), + ($x1 :: $g, $d)%expr_pat) @ + (λ _ : expr + (type.base base.type.unit), + ($g, $x1 :: $d)%expr_pat) @ $fx)%expr_pat)%expr @ + rec')%expr_pat) ls0; + UnderLets.Base + {| + anyexpr_ty := (base.type.list A * + base.type.list A)%etype; + unwrap := e1 |}); + fv0 <-- do_again (let (anyexpr_ty, _) := fv in anyexpr_ty) + (let + (anyexpr_ty, unwrap) as a + return + (expr + (type.base + (let (anyexpr_ty, _) := a in + anyexpr_ty))) := fv in + unwrap); + base.try_make_transport_cps + (fun t : base.type => expr (type.base t)) + (let (anyexpr_ty, _) := fv in anyexpr_ty) + (base.type.list A * base.type.list A) + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.list A * base.type.list A)%etype))) + (fun + a : option + (expr + (type.base + (let (anyexpr_ty, _) := fv in anyexpr_ty)) -> + expr + (type.base + (base.type.list A * base.type.list A)%etype)) + => + match a with + | Some x' => UnderLets.Base (x' fv0) + | None => + UnderLets.Base + (#(ident.List_partition)%expr @ + (λ x1 : var (type.base A), + UnderLets.to_expr (x ($x1)))%expr @ x0)%expr_pat + end))%under_lets + | None => + UnderLets.Base + (#(ident.List_partition)%expr @ + (λ x1 : var (type.base A), + UnderLets.to_expr (x ($x1)))%expr @ x0)%expr_pat + end) + | None => + UnderLets.Base + (#(ident.List_partition)%expr @ + (λ x1 : var (type.base A), + UnderLets.to_expr (x ($x1)))%expr @ x0)%expr_pat + end) +| @ident.List_fold_right A B => + fun + (x : expr (type.base B) -> + expr (type.base A) -> + UnderLets.UnderLets base.type ident var (expr (type.base A))) + (x0 : expr (type.base A)) (x1 : expr (type.base (base.type.list B))) => + Compile.castv x + (UnderLets.UnderLets base.type ident var (expr (type.base A))) + (fun + f : option + (expr (type.base B) -> + expr (type.base A) -> + UnderLets.UnderLets base.type ident var (expr (type.base A))) + => + match f with + | Some f0 => + reflect_list_cps x1 + (fun ls : option (list (expr (type.base B))) => + match ls with + | Some ls0 => + (fv <-- (e <-- list_rect + (fun _ : list (expr (type.base B)) => + UnderLets.UnderLets base.type ident var + (expr (type.base A))) + (UnderLets.Base x0) + (fun (x2 : expr (type.base B)) + (_ : list (expr (type.base B))) + (rec : UnderLets.UnderLets base.type + ident var (expr (type.base A))) + => rec' <-- rec; + f0 x2 rec') ls0; + UnderLets.Base {| anyexpr_ty := A; unwrap := e |}); + base.try_make_transport_cps + (fun t : base.type => expr (type.base t)) + (let (anyexpr_ty, _) := fv in anyexpr_ty) A + (UnderLets.UnderLets base.type ident var + (expr (type.base A))) + (fun + a : option + (expr + (type.base + (let (anyexpr_ty, _) := fv in anyexpr_ty)) -> + expr (type.base A)) => + match a with + | Some x' => + UnderLets.Base + (x' + (let + (anyexpr_ty, unwrap) as a0 + return + (expr + (type.base + (let (anyexpr_ty, _) := a0 in + anyexpr_ty))) := fv in + unwrap)) + | None => + UnderLets.Base + (#(ident.List_fold_right)%expr @ + (λ (x2 : var (type.base B))(x3 : var + (type.base A)), + UnderLets.to_expr (x ($x2) ($x3)))%expr @ x0 @ + x1)%expr_pat + end))%under_lets + | None => + UnderLets.Base + (#(ident.List_fold_right)%expr @ + (λ (x2 : var (type.base B))(x3 : var (type.base A)), + UnderLets.to_expr (x ($x2) ($x3)))%expr @ x0 @ x1)%expr_pat + end) + | None => + UnderLets.Base + (#(ident.List_fold_right)%expr @ + (λ (x2 : var (type.base B))(x3 : var (type.base A)), + UnderLets.to_expr (x ($x2) ($x3)))%expr @ x0 @ x1)%expr_pat + end) +| @ident.List_update_nth T => + fun (x : expr (type.base base.type.nat)) + (x0 : expr (type.base T) -> + UnderLets.UnderLets base.type ident var (expr (type.base T))) + (x1 : expr (type.base (base.type.list T))) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option nat) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args => + Compile.castv x0 + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list T)))) + (fun + f : option + (expr (type.base T) -> + UnderLets.UnderLets base.type ident var + (expr (type.base T))) => + match f with + | Some f0 => + reflect_list_cps x1 + (fun ls : option (list (expr (type.base T))) => + match ls with + | Some ls0 => + (fv <-- (e <-- (retv <---- update_nth args + (fun + x2 : UnderLets.UnderLets + base.type + ident var + (expr + (type.base + T)) => + x3 <-- x2; + f0 x3) + (map UnderLets.Base + ls0); + UnderLets.Base (reify_list retv)); + UnderLets.Base + {| + anyexpr_ty := base.type.list T; + unwrap := e |}); + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) + (let (anyexpr_ty, _) := fv in anyexpr_ty) + (base.type.list T) + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.list T)))) + (fun + a : option + (expr + (type.base + (let (anyexpr_ty, _) := fv in + anyexpr_ty)) -> + expr (type.base (base.type.list T))) + => + match a with + | Some x' => + UnderLets.Base + (x' + (let + (anyexpr_ty, unwrap) as a0 + return + (expr + (type.base + (let (anyexpr_ty, _) := + a0 in + anyexpr_ty))) := fv in + unwrap)) + | None => + UnderLets.Base + (#(ident.List_update_nth)%expr @ x @ + (λ x2 : var (type.base T), + UnderLets.to_expr (x0 ($x2)))%expr @ x1)%expr_pat + end))%under_lets + | None => + UnderLets.Base + (#(ident.List_update_nth)%expr @ x @ + (λ x2 : var (type.base T), + UnderLets.to_expr (x0 ($x2)))%expr @ x1)%expr_pat + end) + | None => + UnderLets.Base + (#(ident.List_update_nth)%expr @ x @ + (λ x2 : var (type.base T), + UnderLets.to_expr (x0 ($x2)))%expr @ x1)%expr_pat + end) + | None => + UnderLets.Base + (#(ident.List_update_nth)%expr @ x @ + (λ x2 : var (type.base T), + UnderLets.to_expr (x0 ($x2)))%expr @ x1)%expr_pat + end + | ($_)%expr | @expr.Abs _ _ _ _ _ _ => + UnderLets.Base + (#(ident.List_update_nth)%expr @ x @ + (λ x2 : var (type.base T), + UnderLets.to_expr (x0 ($x2)))%expr @ x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.List_update_nth)%expr @ x @ + (λ x3 : var (type.base T), + UnderLets.to_expr (x0 ($x3)))%expr @ x1)%expr_pat + end +| @ident.List_nth_default T => + fun (x : expr (type.base T)) (x0 : expr (type.base (base.type.list T))) + (x1 : expr (type.base base.type.nat)) => + match x1 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option nat) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args => + Compile.castbe x + (UnderLets.UnderLets base.type ident var (expr (type.base T))) + (fun default : option (expr (type.base T)) => + match default with + | Some default0 => + reflect_list_cps x0 + (fun ls : option (list (expr (type.base T))) => + match ls with + | Some ls0 => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) T T + (UnderLets.UnderLets base.type ident var + (expr (type.base T))) + (fun + a : option + (expr (type.base T) -> + expr (type.base T)) => + match a with + | Some x' => + UnderLets.Base + (x' (nth_default default0 ls0 args)) + | None => + UnderLets.Base + (#(ident.List_nth_default)%expr @ x @ x0 @ + x1)%expr_pat + end) + | None => + UnderLets.Base + (#(ident.List_nth_default)%expr @ x @ x0 @ x1)%expr_pat + end) + | None => + UnderLets.Base + (#(ident.List_nth_default)%expr @ x @ x0 @ x1)%expr_pat + end) + | None => + UnderLets.Base + (#(ident.List_nth_default)%expr @ x @ x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.List_nth_default)%expr @ x @ x0 @ x1)%expr_pat + end +| ident.Z_add => + fun x x0 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => UnderLets.Base ##((args + args0)%Z)%expr + | None => + if args =? 0 + then UnderLets.Base x0 + else UnderLets.Base (x + x0)%expr + end + | @expr.App _ _ _ s _ f x1 => + if args =? 0 + then UnderLets.Base x0 + else + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args >? 0 + then + UnderLets.Base (##(args) - x' v)%expr + else + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) => + match a0 with + | Some x'0 => + if args <? 0 + then + UnderLets.Base + (- + (##((- args)%Z) + x'0 v0))%expr + else + match + s as t4 + return + (Compile.value' false t4 -> + UnderLets.UnderLets + base.type ident var + (expr + (type.base + base.type.Z))) + with + | type.base t4 => + fun + v1 : expr + (type.base t4) + => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) + t4 base.type.Z + (UnderLets.UnderLets + base.type ident var + (expr + (type.base + base.type.Z))) + (fun + a1 : option + (expr + (type.base + t4) -> + expr + (type.base + base.type.Z)) + => + match a1 with + | Some x'1 => + UnderLets.Base + (x - x'1 v1)%expr + | None => + UnderLets.Base + (x + x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' + false s0 -> + Compile.value' + true d0 => + UnderLets.Base + (x + x0)%expr + end (Compile.reflect x1) + | None => + UnderLets.Base (x + x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end + | _ => UnderLets.Base (x + x0)%expr + end + | _ => + if args =? 0 + then UnderLets.Base x0 + else UnderLets.Base (x + x0)%expr + end + | None => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base x + else UnderLets.Base (x + x0)%expr + | None => UnderLets.Base (x + x0)%expr + end + | @expr.App _ _ _ s _ #(idc0)%expr_pat x1 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x - x' v)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s _ + (@expr.LetIn _ _ _ _ _ _ _) _ => UnderLets.Base (x + x0)%expr + | _ => UnderLets.Base (x + x0)%expr + end + end + | ($_)%expr => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t1 v0 => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base x + else UnderLets.Base (x + x0)%expr + | None => UnderLets.Base (x + x0)%expr + end + | @expr.App _ _ _ s _ #(idc)%expr_pat x1 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x - x' v0)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s0 -> d0)%ptype => + fun _ : Compile.value' false s0 -> Compile.value' true d0 + => UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (x + x0)%expr + | _ => UnderLets.Base (x + x0)%expr + end + | @expr.Abs _ _ _ _ _ _ => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base x + else UnderLets.Base (x + x0)%expr + | None => UnderLets.Base (x + x0)%expr + end + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x1 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x - x' v)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 + => UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (x + x0)%expr + | _ => UnderLets.Base (x + x0)%expr + end + | @expr.App _ _ _ s _ f x1 => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base x + else + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args >? 0 + then + UnderLets.Base (##(args) - x' v)%expr + else + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) => + match a0 with + | Some x'0 => + if args <? 0 + then + UnderLets.Base + (- + (x'0 v0 + ##((- args)%Z)))%expr + else + match + s as t4 + return + (Compile.value' false t4 -> + UnderLets.UnderLets + base.type ident var + (expr + (type.base + base.type.Z))) + with + | type.base t4 => + fun + v1 : expr + (type.base t4) + => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) + t4 base.type.Z + (UnderLets.UnderLets + base.type ident var + (expr + (type.base + base.type.Z))) + (fun + a1 : option + (expr + (type.base + t4) -> + expr + (type.base + base.type.Z)) + => + match a1 with + | Some x'1 => + UnderLets.Base + (x0 - x'1 v1)%expr + | None => + UnderLets.Base + (x + x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' + false s0 -> + Compile.value' + true d0 => + UnderLets.Base + (x + x0)%expr + end (Compile.reflect x1) + | None => + UnderLets.Base (x + x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end + | _ => UnderLets.Base (x + x0)%expr + end + | None => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x0 - x' v)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end + | _ => UnderLets.Base (x + x0)%expr + end + end + | ($_)%expr => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x0 - x' v0)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end + | _ => UnderLets.Base (x + x0)%expr + end + | @expr.Abs _ _ _ _ _ _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x0 - x' v)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end + | _ => UnderLets.Base (x + x0)%expr + end + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s0 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.Base + (- (x' v + x'0 v0))%expr + | None => + UnderLets.Base (x + x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x2) + | None => UnderLets.Base (x + x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x - x' v)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x2) + end + | ($_)%expr => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x - x' v0)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x2) + | @expr.LetIn _ _ _ _ _ _ _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x - x' v)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x2) + | _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x - x' v)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x2) + end + | None => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x0 - x' v)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end + | _ => UnderLets.Base (x + x0)%expr + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x0 - x' v0)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end + | _ => UnderLets.Base (x + x0)%expr + end + | @expr.App _ _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 + _ (_ @ _)%expr_pat _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x0 - x' v)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end + | _ => UnderLets.Base (x + x0)%expr + end + | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x0 - x' v)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end + | _ => UnderLets.Base (x + x0)%expr + end + | @expr.LetIn _ _ _ _ _ _ _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x0 - x' v)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x + x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x + x0)%expr + end + | _ => UnderLets.Base (x + x0)%expr + end + end + | @expr.LetIn _ _ _ _ _ _ _ => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base x + else UnderLets.Base (x + x0)%expr + | None => UnderLets.Base (x + x0)%expr + end + | @expr.App _ _ _ s _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x - x' v)%expr + | None => UnderLets.Base (x + x0)%expr + end) + | (s0 -> d0)%ptype => + fun _ : Compile.value' false s0 -> Compile.value' true d0 + => UnderLets.Base (x + x0)%expr + end (Compile.reflect x2) + | None => UnderLets.Base (x + x0)%expr + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (x + x0)%expr + | _ => UnderLets.Base (x + x0)%expr + end + end +| ident.Z_mul => + fun x x0 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => UnderLets.Base ##((args * args0)%Z)%expr + | None => + if args =? 0 + then UnderLets.Base ##(0)%expr + else + if args =? 1 + then UnderLets.Base x0 + else + if args =? -1 + then UnderLets.Base (- x0)%expr + else + if args <? 0 + then UnderLets.Base (- (##((- args)%Z) * x0))%expr + else + if args =? 2 ^ Z.log2 args + then UnderLets.Base (x0 << Z.log2 args)%expr + else UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s _ f x1 => + if args =? 0 + then UnderLets.Base ##(0)%expr + else + if args =? 1 + then UnderLets.Base x0 + else + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args =? -1 + then UnderLets.Base (x' v) + else + if args =? -1 + then UnderLets.Base (- x0)%expr + else + if args <? 0 + then + UnderLets.Base + (- (##((- args)%Z) * x0))%expr + else + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.Base + (- (x * x'0 v0))%expr + | None => + UnderLets.Base + (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => + if args =? -1 + then UnderLets.Base (- x0)%expr + else + if args <? 0 + then UnderLets.Base (- (##((- args)%Z) * x0))%expr + else + if args =? 2 ^ Z.log2 args + then UnderLets.Base (x0 << Z.log2 args)%expr + else UnderLets.Base (x * x0)%expr + end + | _ => + if args =? -1 + then UnderLets.Base (- x0)%expr + else + if args <? 0 + then UnderLets.Base (- (##((- args)%Z) * x0))%expr + else + if args =? 2 ^ Z.log2 args + then UnderLets.Base (x0 << Z.log2 args)%expr + else UnderLets.Base (x * x0)%expr + end + | _ => + if args =? 0 + then UnderLets.Base ##(0)%expr + else + if args =? 1 + then UnderLets.Base x0 + else + if args =? -1 + then UnderLets.Base (- x0)%expr + else + if args <? 0 + then UnderLets.Base (- (##((- args)%Z) * x0))%expr + else + if args =? 2 ^ Z.log2 args + then UnderLets.Base (x0 << Z.log2 args)%expr + else UnderLets.Base (x * x0)%expr + end + | None => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base ##(0)%expr + else + if args =? 1 + then UnderLets.Base x + else + if args =? -1 + then UnderLets.Base (- x)%expr + else + if args <? 0 + then UnderLets.Base (- (x * ##((- args)%Z)))%expr + else + if args =? 2 ^ Z.log2 args + then UnderLets.Base (x << Z.log2 args)%expr + else UnderLets.Base (x * x0)%expr + | None => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s _ #(idc0)%expr_pat x1 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x * x' v))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s _ + (@expr.LetIn _ _ _ _ _ _ _) _ => UnderLets.Base (x * x0)%expr + | _ => UnderLets.Base (x * x0)%expr + end + end + | ($_)%expr => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t1 v0 => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base ##(0)%expr + else + if args =? 1 + then UnderLets.Base x + else + if args =? -1 + then UnderLets.Base (- x)%expr + else + if args <? 0 + then UnderLets.Base (- (x * ##((- args)%Z)))%expr + else + if args =? 2 ^ Z.log2 args + then UnderLets.Base (x << Z.log2 args)%expr + else UnderLets.Base (x * x0)%expr + | None => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s _ #(idc)%expr_pat x1 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x * x' v0))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun _ : Compile.value' false s0 -> Compile.value' true d0 + => UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (x * x0)%expr + | _ => UnderLets.Base (x * x0)%expr + end + | @expr.Abs _ _ _ _ _ _ => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base ##(0)%expr + else + if args =? 1 + then UnderLets.Base x + else + if args =? -1 + then UnderLets.Base (- x)%expr + else + if args <? 0 + then UnderLets.Base (- (x * ##((- args)%Z)))%expr + else + if args =? 2 ^ Z.log2 args + then UnderLets.Base (x << Z.log2 args)%expr + else UnderLets.Base (x * x0)%expr + | None => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x1 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x * x' v))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 + => UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (x * x0)%expr + | _ => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s _ f x1 => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base ##(0)%expr + else + if args =? 1 + then UnderLets.Base x + else + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args =? -1 + then UnderLets.Base (x' v) + else + if args =? -1 + then UnderLets.Base (- x)%expr + else + if args <? 0 + then + UnderLets.Base + (- (x * ##((- args)%Z)))%expr + else + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.Base + (- (x'0 v0 * x0))%expr + | None => + UnderLets.Base + (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => + if args =? -1 + then UnderLets.Base (- x)%expr + else + if args <? 0 + then UnderLets.Base (- (x * ##((- args)%Z)))%expr + else + if args =? 2 ^ Z.log2 args + then UnderLets.Base (x << Z.log2 args)%expr + else UnderLets.Base (x * x0)%expr + end + | _ => + if args =? -1 + then UnderLets.Base (- x)%expr + else + if args <? 0 + then UnderLets.Base (- (x * ##((- args)%Z)))%expr + else + if args =? 2 ^ Z.log2 args + then UnderLets.Base (x << Z.log2 args)%expr + else UnderLets.Base (x * x0)%expr + end + | None => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.Base (- (x' v * x0))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + | _ => UnderLets.Base (x * x0)%expr + end + end + | ($_)%expr => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x' v0 * x0))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + | _ => UnderLets.Base (x * x0)%expr + end + | @expr.Abs _ _ _ _ _ _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x' v * x0))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + | _ => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s0 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.Base + (x' v * x'0 v0)%expr + | None => + UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x2) + | None => UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.Base (- (x * x' v))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x2) + end + | ($_)%expr => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x * x' v0))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x2) + | @expr.LetIn _ _ _ _ _ _ _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x * x' v))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x2) + | _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x * x' v))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x2) + end + | None => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.Base (- (x' v * x0))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + | _ => UnderLets.Base (x * x0)%expr + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x' v0 * x0))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + | _ => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 + _ (_ @ _)%expr_pat _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x' v * x0))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + | _ => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x' v * x0))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + | _ => UnderLets.Base (x * x0)%expr + end + | @expr.LetIn _ _ _ _ _ _ _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x' v * x0))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x * x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x * x0)%expr + end + | _ => UnderLets.Base (x * x0)%expr + end + end + | @expr.LetIn _ _ _ _ _ _ _ => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base ##(0)%expr + else + if args =? 1 + then UnderLets.Base x + else + if args =? -1 + then UnderLets.Base (- x)%expr + else + if args <? 0 + then UnderLets.Base (- (x * ##((- args)%Z)))%expr + else + if args =? 2 ^ Z.log2 args + then UnderLets.Base (x << Z.log2 args)%expr + else UnderLets.Base (x * x0)%expr + | None => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x * x' v))%expr + | None => UnderLets.Base (x * x0)%expr + end) + | (s0 -> d0)%ptype => + fun _ : Compile.value' false s0 -> Compile.value' true d0 + => UnderLets.Base (x * x0)%expr + end (Compile.reflect x2) + | None => UnderLets.Base (x * x0)%expr + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (x * x0)%expr + | _ => UnderLets.Base (x * x0)%expr + end + end +| ident.Z_pow => + fun x x0 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => UnderLets.Base ##(args ^ args0)%expr + | None => + UnderLets.Base (#(ident.Z_pow)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_pow)%expr @ x @ x0)%expr_pat + end + | None => UnderLets.Base (#(ident.Z_pow)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_pow)%expr @ x @ x0)%expr_pat + end +| ident.Z_sub => + fun x x0 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => UnderLets.Base ##((args - args0)%Z)%expr + | None => + if args =? 0 + then UnderLets.Base (- x0)%expr + else + if args <? 0 + then UnderLets.Base (- (##((- args)%Z) + x0))%expr + else UnderLets.Base (x - x0)%expr + end + | @expr.App _ _ _ s _ #(idc0)%expr_pat x1 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args =? 0 + then UnderLets.Base (x' v) + else + if args =? 0 + then UnderLets.Base (- x0)%expr + else + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + if args >? 0 + then + UnderLets.Base + (##(args) + x'0 v0)%expr + else + match + s as t4 + return + (Compile.value' false t4 -> + UnderLets.UnderLets + base.type ident var + (expr + (type.base base.type.Z))) + with + | type.base t4 => + fun v1 : expr (type.base t4) + => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t4 + base.type.Z + (UnderLets.UnderLets + base.type ident var + (expr + (type.base + base.type.Z))) + (fun + a1 : option + (expr + (type.base t4) -> + expr + (type.base + base.type.Z)) + => + match a1 with + | Some x'1 => + if args <? 0 + then + UnderLets.Base + (x'1 v1 - + ##((- args)%Z))%expr + else + if args <? 0 + then + UnderLets.Base + (- + (##((- args)%Z) + + x0))%expr + else + match + s as t5 + return + (Compile.value' + false t5 -> + UnderLets.UnderLets + base.type + ident var + (expr + (type.base + base.type.Z))) + with + | type.base t5 => + fun + v2 : + expr + (type.base + t5) => + base.try_make_transport_cps + (fun + t1 : base.type + => + expr + (type.base + t1)) t5 + base.type.Z + (UnderLets.UnderLets + base.type + ident var + (expr + (type.base + base.type.Z))) + (fun + a2 : + option + (expr + (type.base + t5) -> + expr + (type.base + base.type.Z)) + => + match + a2 + with + | Some + x'2 => + UnderLets.Base + (x + + x'2 v2)%expr + | None => + UnderLets.Base + (x - x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' + false s0 -> + Compile.value' + true d0 + => + UnderLets.Base + (x - x0)%expr + end + (Compile.reflect + x1) + | None => + UnderLets.Base + (x - x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false + s0 -> + Compile.value' true d0 + => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => + UnderLets.Base (x - x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x - x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => + if args =? 0 + then UnderLets.Base (- x0)%expr + else + if args <? 0 + then UnderLets.Base (- (##((- args)%Z) + x0))%expr + else UnderLets.Base (x - x0)%expr + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + if args =? 0 + then UnderLets.Base (- x0)%expr + else + if args <? 0 + then UnderLets.Base (- (##((- args)%Z) + x0))%expr + else UnderLets.Base (x - x0)%expr + | _ => + if args =? 0 + then UnderLets.Base (- x0)%expr + else + if args <? 0 + then UnderLets.Base (- (##((- args)%Z) + x0))%expr + else UnderLets.Base (x - x0)%expr + end + | None => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base x + else + if args <? 0 + then UnderLets.Base (x + ##((- args)%Z))%expr + else UnderLets.Base (x - x0)%expr + | None => UnderLets.Base (x - x0)%expr + end + | @expr.App _ _ _ s _ #(idc0)%expr_pat x1 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x + x' v)%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x - x0)%expr + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s _ + (@expr.LetIn _ _ _ _ _ _ _) _ => UnderLets.Base (x - x0)%expr + | _ => UnderLets.Base (x - x0)%expr + end + end + | ($_)%expr => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t1 v0 => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base x + else + if args <? 0 + then UnderLets.Base (x + ##((- args)%Z))%expr + else UnderLets.Base (x - x0)%expr + | None => UnderLets.Base (x - x0)%expr + end + | @expr.App _ _ _ s _ #(idc)%expr_pat x1 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x + x' v0)%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s0 -> d0)%ptype => + fun _ : Compile.value' false s0 -> Compile.value' true d0 + => UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x - x0)%expr + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (x - x0)%expr + | _ => UnderLets.Base (x - x0)%expr + end + | @expr.Abs _ _ _ _ _ _ => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base x + else + if args <? 0 + then UnderLets.Base (x + ##((- args)%Z))%expr + else UnderLets.Base (x - x0)%expr + | None => UnderLets.Base (x - x0)%expr + end + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x1 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x + x' v)%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 + => UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x - x0)%expr + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (x - x0)%expr + | _ => UnderLets.Base (x - x0)%expr + end + | @expr.App _ _ _ s _ f x1 => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base x + else + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args >? 0 + then + UnderLets.Base + (- (x' v + ##((- args)%Z)))%expr + else + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) => + match a0 with + | Some x'0 => + if args <? 0 + then + UnderLets.Base + (##((- args)%Z) - x'0 v0)%expr + else + if args <? 0 + then + UnderLets.Base + (x + ##((- args)%Z))%expr + else + match + s as t4 + return + (Compile.value' false + t4 -> + UnderLets.UnderLets + base.type ident var + (expr + (type.base + base.type.Z))) + with + | type.base t4 => + fun + v1 : expr + (type.base t4) + => + base.try_make_transport_cps + (fun t1 : base.type + => + expr (type.base t1)) + t4 base.type.Z + (UnderLets.UnderLets + base.type ident + var + (expr + (type.base + base.type.Z))) + (fun + a1 : option + (expr + (type.base + t4) -> + expr + (type.base + base.type.Z)) + => + match a1 with + | Some x'1 => + UnderLets.Base + (- + (x'1 v1 + x0))%expr + | None => + UnderLets.Base + (x - x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' + false s0 -> + Compile.value' + true d0 => + UnderLets.Base + (x - x0)%expr + end (Compile.reflect x1) + | None => + UnderLets.Base (x - x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x - x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => + if args <? 0 + then UnderLets.Base (x + ##((- args)%Z))%expr + else UnderLets.Base (x - x0)%expr + end + | _ => + if args <? 0 + then UnderLets.Base (x + ##((- args)%Z))%expr + else UnderLets.Base (x - x0)%expr + end + | None => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.Base (- (x' v + x0))%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x - x0)%expr + end + | _ => UnderLets.Base (x - x0)%expr + end + end + | ($_)%expr => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x' v0 + x0))%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x - x0)%expr + end + | _ => UnderLets.Base (x - x0)%expr + end + | @expr.Abs _ _ _ _ _ _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x' v + x0))%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x - x0)%expr + end + | _ => UnderLets.Base (x - x0)%expr + end + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s0 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var (expr (type.base base.type.Z))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr (type.base base.type.Z))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.Base + (x'0 v0 - x' v)%expr + | None => + UnderLets.Base (x - x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x2) + | None => UnderLets.Base (x - x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x + x' v)%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x2) + end + | ($_)%expr => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x + x' v0)%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x2) + | @expr.LetIn _ _ _ _ _ _ _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x + x' v)%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x2) + | _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x + x' v)%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x2) + end + | None => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.Base (- (x' v + x0))%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x - x0)%expr + end + | _ => UnderLets.Base (x - x0)%expr + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x' v0 + x0))%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x - x0)%expr + end + | _ => UnderLets.Base (x - x0)%expr + end + | @expr.App _ _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 + _ (_ @ _)%expr_pat _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x' v + x0))%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x - x0)%expr + end + | _ => UnderLets.Base (x - x0)%expr + end + | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x' v + x0))%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x - x0)%expr + end + | _ => UnderLets.Base (x - x0)%expr + end + | @expr.LetIn _ _ _ _ _ _ _ => + match f with + | #(idc)%expr_pat => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (- (x' v + x0))%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base (x - x0)%expr + end (Compile.reflect x1) + | None => UnderLets.Base (x - x0)%expr + end + | _ => UnderLets.Base (x - x0)%expr + end + end + | @expr.LetIn _ _ _ _ _ _ _ => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 0 + then UnderLets.Base x + else + if args <? 0 + then UnderLets.Base (x + ##((- args)%Z))%expr + else UnderLets.Base (x - x0)%expr + | None => UnderLets.Base (x - x0)%expr + end + | @expr.App _ _ _ s _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x + x' v)%expr + | None => UnderLets.Base (x - x0)%expr + end) + | (s0 -> d0)%ptype => + fun _ : Compile.value' false s0 -> Compile.value' true d0 + => UnderLets.Base (x - x0)%expr + end (Compile.reflect x2) + | None => UnderLets.Base (x - x0)%expr + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (x - x0)%expr + | _ => UnderLets.Base (x - x0)%expr + end + end +| ident.Z_opp => + fun x : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => UnderLets.Base ##((- args)%Z)%expr + | None => UnderLets.Base (- x)%expr + end + | @expr.App _ _ _ s _ #(idc)%expr_pat x0 => + match match idc with + | ident.Z_opp => Some tt + | _ => None + end with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base base.type.Z))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => UnderLets.Base (x' v) + | None => UnderLets.Base (- x)%expr + end) + | (s0 -> d0)%ptype => + fun _ : Compile.value' false s0 -> Compile.value' true d0 => + UnderLets.Base (- x)%expr + end (Compile.reflect x0) + | None => UnderLets.Base (- x)%expr + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ (_ @ _)%expr_pat _ | + @expr.App _ _ _ s _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (- x)%expr + | _ => UnderLets.Base (- x)%expr + end +| ident.Z_div => + fun x x0 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => UnderLets.Base ##((args / args0)%Z)%expr + | None => UnderLets.Base (x / x0)%expr + end + | _ => UnderLets.Base (x / x0)%expr + end + | None => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 2 ^ Z.log2 args + then UnderLets.Base (x >> Z.log2 args)%expr + else UnderLets.Base (x / x0)%expr + | None => UnderLets.Base (x / x0)%expr + end + | _ => UnderLets.Base (x / x0)%expr + end + end + | ($_)%expr => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t1 v0 => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args => + if args =? 2 ^ Z.log2 args + then UnderLets.Base (x >> Z.log2 args)%expr + else UnderLets.Base (x / x0)%expr + | None => UnderLets.Base (x / x0)%expr + end + | _ => UnderLets.Base (x / x0)%expr + end + | _ => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 2 ^ Z.log2 args + then UnderLets.Base (x >> Z.log2 args)%expr + else UnderLets.Base (x / x0)%expr + | None => UnderLets.Base (x / x0)%expr + end + | _ => UnderLets.Base (x / x0)%expr + end + end +| ident.Z_modulo => + fun x x0 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => UnderLets.Base ##((args mod args0)%Z)%expr + | None => UnderLets.Base (x mod x0)%expr + end + | _ => UnderLets.Base (x mod x0)%expr + end + | None => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 2 ^ Z.log2 args + then + UnderLets.Base + (#(ident.Z_land (args - 1))%expr @ x)%expr_pat + else UnderLets.Base (x mod x0)%expr + | None => UnderLets.Base (x mod x0)%expr + end + | _ => UnderLets.Base (x mod x0)%expr + end + end + | ($_)%expr => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t1 v0 => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args => + if args =? 2 ^ Z.log2 args + then + UnderLets.Base + (#(ident.Z_land (args - 1))%expr @ x)%expr_pat + else UnderLets.Base (x mod x0)%expr + | None => UnderLets.Base (x mod x0)%expr + end + | _ => UnderLets.Base (x mod x0)%expr + end + | _ => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args =? 2 ^ Z.log2 args + then + UnderLets.Base + (#(ident.Z_land (args - 1))%expr @ x)%expr_pat + else UnderLets.Base (x mod x0)%expr + | None => UnderLets.Base (x mod x0)%expr + end + | _ => UnderLets.Base (x mod x0)%expr + end + end +| ident.Z_eqb => + fun x x0 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => UnderLets.Base ##(args =? args0)%expr + | None => + UnderLets.Base (#(ident.Z_eqb)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_eqb)%expr @ x @ x0)%expr_pat + end + | None => UnderLets.Base (#(ident.Z_eqb)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_eqb)%expr @ x @ x0)%expr_pat + end +| ident.Z_leb => + fun x x0 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => UnderLets.Base ##(args <=? args0)%expr + | None => + UnderLets.Base (#(ident.Z_leb)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_leb)%expr @ x @ x0)%expr_pat + end + | None => UnderLets.Base (#(ident.Z_leb)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_leb)%expr @ x @ x0)%expr_pat + end +| ident.Z_of_nat => + fun x : expr (type.base base.type.nat) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option nat) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun _ : Z => None + | base.type.bool => fun _ : bool => None + | base.type.nat => fun v0 : nat => Some v0 + end v + | _ => None + end + with + | Some args => UnderLets.Base ##(Z.of_nat args)%expr + | None => UnderLets.Base (#(ident.Z_of_nat)%expr @ x)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_of_nat)%expr @ x)%expr_pat + end +| ident.Z_shiftr offset => + fun x : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => UnderLets.Base ##(Z.shiftr args offset)%expr + | None => UnderLets.Base (x >> offset)%expr + end + | _ => UnderLets.Base (x >> offset)%expr + end +| ident.Z_shiftl offset => + fun x : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => UnderLets.Base ##(Z.shiftl args offset)%expr + | None => UnderLets.Base (x << offset)%expr + end + | _ => UnderLets.Base (x << offset)%expr + end +| ident.Z_land mask => + fun x : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => UnderLets.Base ##(Z.land args mask)%expr + | None => UnderLets.Base (#(ident.Z_land mask)%expr @ x)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_land mask)%expr @ x)%expr_pat + end +| ident.Z_mul_split => + fun x x0 x1 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + (let + '(a, b) := + Definitions.Z.mul_split args args0 args1 in + (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + if args0 =? 0 + then + UnderLets.Base (##(0)%expr, ##(0)%expr)%expr_pat + else + if args0 =? 1 + then UnderLets.Base (x1, ##(0)%expr)%expr_pat + else + if args0 =? -1 + then + UnderLets.Base + ((- x1)%expr, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_mul_split_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | _ => + if args0 =? 0 + then UnderLets.Base (##(0)%expr, ##(0)%expr)%expr_pat + else + if args0 =? 1 + then UnderLets.Base (x1, ##(0)%expr)%expr_pat + else + if args0 =? -1 + then + UnderLets.Base ((- x1)%expr, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_mul_split_concrete args)%expr @ x0 @ + x1)%expr_pat + end + | None => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + if args0 =? 0 + then + UnderLets.Base (##(0)%expr, ##(0)%expr)%expr_pat + else + if args0 =? 1 + then UnderLets.Base (x0, ##(0)%expr)%expr_pat + else + if args0 =? -1 + then + UnderLets.Base + ((- x0)%expr, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_mul_split_concrete args)%expr @ + x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_mul_split_concrete args)%expr @ x0 @ + x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_mul_split_concrete args)%expr @ x0 @ x1)%expr_pat + end + end + | ($_)%expr => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t2 v0 => + match + t2 as t3 return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args0 => + if args0 =? 0 + then UnderLets.Base (##(0)%expr, ##(0)%expr)%expr_pat + else + if args0 =? 1 + then UnderLets.Base (x0, ##(0)%expr)%expr_pat + else + if args0 =? -1 + then + UnderLets.Base ((- x0)%expr, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_mul_split_concrete args)%expr @ x0 @ + x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_mul_split_concrete args)%expr @ x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_mul_split_concrete args)%expr @ x0 @ x1)%expr_pat + end + | _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + if args0 =? 0 + then UnderLets.Base (##(0)%expr, ##(0)%expr)%expr_pat + else + if args0 =? 1 + then UnderLets.Base (x0, ##(0)%expr)%expr_pat + else + if args0 =? -1 + then + UnderLets.Base ((- x0)%expr, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_mul_split_concrete args)%expr @ x0 @ + x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_mul_split_concrete args)%expr @ x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_mul_split_concrete args)%expr @ x0 @ x1)%expr_pat + end + end + | None => + UnderLets.Base (#(ident.Z_mul_split)%expr @ x @ x0 @ x1)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_mul_split)%expr @ x @ x0 @ x1)%expr_pat + end +| ident.Z_mul_split_concrete s => + fun x x0 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + UnderLets.Base + (let + '(a, b) := Definitions.Z.mul_split s args args0 in + (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_mul_split_concrete s)%expr @ x @ x0)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_mul_split_concrete s)%expr @ x @ x0)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_mul_split_concrete s)%expr @ x @ x0)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_mul_split_concrete s)%expr @ x @ x0)%expr_pat + end +| ident.Z_add_get_carry => + fun x x0 x1 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + (let + '(a, b) := + Definitions.Z.add_get_carry_full args args0 + args1 in (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + if args0 =? 0 + then UnderLets.Base (x1, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s _ f x2 => + if args0 =? 0 + then UnderLets.Base (x1, ##(0)%expr)%expr_pat + else + match f with + | #(idc1)%expr_pat => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => + expr (type.base t3)) t2 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) + => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete + args)%expr @ x0 @ + x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | _ => + if args0 =? 0 + then UnderLets.Base (x1, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + end + | None => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + if args0 =? 0 + then UnderLets.Base (x0, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s _ #(idc1)%expr_pat x2 => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete + args)%expr @ x0 @ x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ + x0 @ x1)%expr_pat + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + end + end + | ($_)%expr => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t2 v0 => + match + t2 as t3 return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args0 => + if args0 =? 0 + then UnderLets.Base (x0, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + end + | @expr.App _ _ _ s _ #(idc0)%expr_pat x2 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete args)%expr @ + x0 @ x' v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v1)%expr, + (- (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ + x1)%expr_pat + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ x1)%expr_pat + end + | @expr.Abs _ _ _ _ _ _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + if args0 =? 0 + then UnderLets.Base (x0, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + end + | @expr.App _ _ _ s0 _ #(idc0)%expr_pat x2 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete args)%expr @ + x0 @ x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ + x1)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s0 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s _ f x2 => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + if args0 =? 0 + then UnderLets.Base (x0, ##(0)%expr)%expr_pat + else + match f with + | #(idc1)%expr_pat => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => + expr (type.base t3)) t2 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) + => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete + args)%expr @ x1 @ + x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | None => + match f with + | #(idc1)%expr_pat => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => + expr (type.base t3)) t2 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) + => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete + args)%expr @ x1 @ x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + end + | ($_)%expr => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete + args)%expr @ x1 @ x' v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) => + UnderLets.Base + (#(ident.fst)%expr @ ($v1)%expr, + (- + (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ + x0 @ x1)%expr_pat + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + end + | @expr.Abs _ _ _ _ _ _ => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete + args)%expr @ x1 @ x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ + x0 @ x1)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + end + | @expr.App _ _ _ s0 _ f0 x3 => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete + args)%expr @ x1 @ x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ + x0 @ x1)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x2) + | None => + match f0 with + | #(idc1)%expr_pat => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => + expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr + (type.base base.type.Z)) + => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete + args)%expr @ x0 @ + x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + end + | ($_)%expr => + match f0 with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => + expr (type.base t3)) t2 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) + => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete + args)%expr @ x0 @ x' v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | @expr.LetIn _ _ _ _ _ _ _ => + match f0 with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t2 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) + => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete + args)%expr @ x0 @ x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | _ => + match f0 with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t2 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) + => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete + args)%expr @ x0 @ x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + end + | @expr.LetIn _ _ _ _ _ _ _ => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete + args)%expr @ x1 @ x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ + x0 @ x1)%expr_pat + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ + x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + end + end + | @expr.LetIn _ _ _ _ _ _ _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + if args0 =? 0 + then UnderLets.Base (x0, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + end + | @expr.App _ _ _ s _ #(idc0)%expr_pat x3 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete args)%expr @ + x0 @ x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ + x1)%expr_pat + end) + | (s0 -> d0)%ptype => + fun + _ : Compile.value' false s0 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ + x1)%expr_pat + end + | @expr.App _ _ _ s _ ($_)%expr _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ x0 @ x1)%expr_pat + end + end + | None => + UnderLets.Base + (#(ident.Z_add_get_carry)%expr @ x @ x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base (#(ident.Z_add_get_carry)%expr @ x @ x0 @ x1)%expr_pat + end +| ident.Z_add_get_carry_concrete s => + fun x x0 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + UnderLets.Base + (let + '(a, b) := + Definitions.Z.add_get_carry_full s args args0 in + (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x0 @ + ##((- args)%Z)%expr)%expr_pat + (fun + v : var + (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x0, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | ($_)%expr => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x0 @ + ##((- args)%Z)%expr)%expr_pat + (fun + v0 : var (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x0, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | @expr.App _ _ _ s0 _ #(idc0)%expr_pat x1 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ + x @ x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x0 @ + ##((- args)%Z)%expr)%expr_pat + (fun + v : var + (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x0, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ ($_)%expr _ => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x0 @ + ##((- args)%Z)%expr)%expr_pat + (fun + v0 : var (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x0, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | @expr.App _ _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ + _ s0 _ (_ @ _)%expr_pat _ | @expr.App _ _ _ s0 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x0 @ + ##((- args)%Z)%expr)%expr_pat + (fun v : var (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x0, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x0 @ + ##((- args)%Z)%expr)%expr_pat + (fun v : var (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x0, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | None => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + ##((- args)%Z)%expr)%expr_pat + (fun + v : var + (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ #(idc0)%expr_pat x1 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ + x @ x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s0 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + end + | ($_)%expr => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t1 v0 => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + ##((- args)%Z)%expr)%expr_pat + (fun + v0 : var (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x1 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + x' v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v1)%expr, + (- (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.Abs _ _ _ _ _ _ => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + ##((- args)%Z)%expr)%expr_pat + (fun v : var (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s1 _ #(idc)%expr_pat x1 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun _ : Compile.value' false s2 -> Compile.value' true d1 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x1 => + match match idc with + | ident.Z_opp => Some tt + | _ => None + end with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x0 @ + x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x1) + | None => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + ##((- args)%Z)%expr)%expr_pat + (fun + v : var + (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s1 _ #(idc0)%expr_pat x2 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ + x @ x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ + x @ x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s1 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t1 v0 => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + ##((- args)%Z)%expr)%expr_pat + (fun + v0 : var (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s1 _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + x' v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v1)%expr, + (- (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun _ : Compile.value' false s2 -> Compile.value' true d1 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _ => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + ##((- args)%Z)%expr)%expr_pat + (fun v : var (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s2 _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s2 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s3 -> d2)%ptype => + fun _ : Compile.value' false s3 -> Compile.value' true d2 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s2 _ ($_)%expr _ | @expr.App _ _ _ s2 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s2 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s2 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat _ => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + ##((- args)%Z)%expr)%expr_pat + (fun v : var (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s2 _ #(idc)%expr_pat x3 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s2 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s3 -> d2)%ptype => + fun _ : Compile.value' false s3 -> Compile.value' true d2 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s2 _ ($_)%expr _ | @expr.App _ _ _ s2 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s2 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s2 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + ##((- args)%Z)%expr)%expr_pat + (fun v : var (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s1 _ #(idc)%expr_pat x3 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s1 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s2 -> d1)%ptype => + fun _ : Compile.value' false s2 -> Compile.value' true d1 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.LetIn _ _ _ _ _ _ _ => + match x0 with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match + t0 as t1 return (base.base_interp t1 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + if args <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + ##((- args)%Z)%expr)%expr_pat + (fun v : var (type.base (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + else + if args =? 0 + then UnderLets.Base (x, ##(0)%expr)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x2 => + match + match idc with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + UnderLets.UnderLet + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ + x' v)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ + x0)%expr_pat + end) + | (s1 -> d0)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d0 + => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat + _ | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_get_carry_concrete s)%expr @ x @ x0)%expr_pat + end + end +| ident.Z_add_with_carry => + fun x x0 x1 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + ##(Definitions.Z.add_with_carry args args0 + args1)%expr + | None => + if args =? 0 + then UnderLets.Base (x0 + x1)%expr + else + UnderLets.Base + (#(ident.Z_add_with_carry)%expr @ x @ x0 @ x1)%expr_pat + end + | _ => + if args =? 0 + then UnderLets.Base (x0 + x1)%expr + else + UnderLets.Base + (#(ident.Z_add_with_carry)%expr @ x @ x0 @ x1)%expr_pat + end + | None => + if args =? 0 + then UnderLets.Base (x0 + x1)%expr + else + UnderLets.Base + (#(ident.Z_add_with_carry)%expr @ x @ x0 @ x1)%expr_pat + end + | _ => + if args =? 0 + then UnderLets.Base (x0 + x1)%expr + else + UnderLets.Base + (#(ident.Z_add_with_carry)%expr @ x @ x0 @ x1)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_carry)%expr @ x @ x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_carry)%expr @ x @ x0 @ x1)%expr_pat + end +| ident.Z_add_with_get_carry => + fun x x0 x1 x2 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + match x2 with + | #(idc2)%expr_pat => + match + match idc2 with + | @ident.Literal t3 v => + match + t3 as t4 + return + (base.base_interp t4 -> option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args2 => + UnderLets.Base + (let + '(a, b) := + Definitions.Z.add_with_get_carry_full + args args0 args1 args2 in + (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + if (args0 =? 0) && (args1 =? 0) + then + UnderLets.Base (x2, ##(0)%expr)%expr_pat + else + if args0 =? 0 + then + UnderLets.Base + (#(ident.Z_add_get_carry_concrete + args)%expr @ x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | _ => + if (args0 =? 0) && (args1 =? 0) + then UnderLets.Base (x2, ##(0)%expr)%expr_pat + else + if args0 =? 0 + then + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | None => + match x2 with + | #(idc2)%expr_pat => + match + match idc2 with + | @ident.Literal t3 v => + match + t3 as t4 + return + (base.base_interp t4 -> option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + if (args0 =? 0) && (args1 =? 0) + then + UnderLets.Base (x1, ##(0)%expr)%expr_pat + else + if args0 =? 0 + then + UnderLets.Base + (#(ident.Z_add_get_carry_concrete + args)%expr @ x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + | None => + if args0 =? 0 + then + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | _ => + if args0 =? 0 + then + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + end + | ($_)%expr => + match x2 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t3 v0 => + match + t3 as t4 + return (base.base_interp t4 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args1 => + if (args0 =? 0) && (args1 =? 0) + then UnderLets.Base (x1, ##(0)%expr)%expr_pat + else + if args0 =? 0 + then + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + | None => + if args0 =? 0 + then + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | _ => + if args0 =? 0 + then + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + match x2 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + if (args0 =? 0) && (args1 =? 0) + then UnderLets.Base (x1, ##(0)%expr)%expr_pat + else + if args0 =? 0 + then + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + | None => + if args0 =? 0 + then + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | _ => + if args0 =? 0 + then + UnderLets.Base + (#(ident.Z_add_get_carry_concrete args)%expr @ + x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + end + | None => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x2 with + | #(idc2)%expr_pat => + match + match idc2 with + | @ident.Literal t3 v => + match + t3 as t4 + return + (base.base_interp t4 -> option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + if (args0 =? 0) && (args1 =? 0) + then + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + end + | ($_)%expr => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t2 v0 => + match + t2 as t3 return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args0 => + match x2 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t3 v0 => + match + t3 as t4 + return (base.base_interp t4 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args1 => + if (args0 =? 0) && (args1 =? 0) + then + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ x0 @ + x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s _ f x3 => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x2 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + if (args0 =? 0) && (args1 =? 0) + then + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s0 _ #(idc1)%expr_pat x4 => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match f with + | #(idc2)%expr_pat => + match + match idc2 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun v : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) => + match a with + | Some x' => + match + s0 as t4 + return + (Compile.value' false + t4 -> + UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t4 => + fun + v0 : expr + (type.base t4) + => + base.try_make_transport_cps + (fun t5 : base.type + => + expr (type.base t5)) + t4 base.type.Z + (UnderLets.UnderLets + base.type ident + var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr + (type.base + t4) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + args)%expr @ + x' v @ x1 @ + x'0 v0)%expr_pat + (fun + v1 : + var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (# + (ident.fst)%expr @ + ($v1)%expr, + (- + (# + (ident.snd)%expr @ + $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ + x2)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' + false s1 -> + Compile.value' + true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x4) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ + s0 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 + _ (_ @ _)%expr_pat _ | @expr.App _ _ _ s0 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | None => + match f with + | #(idc1)%expr_pat => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match x2 with + | @expr.App _ _ _ s0 _ #(idc2)%expr_pat x4 => + match + match idc2 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun v : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) => + match a with + | Some x' => + match + s0 as t4 + return + (Compile.value' false + t4 -> + UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t4 => + fun + v0 : expr + (type.base t4) + => + base.try_make_transport_cps + (fun t5 : base.type + => + expr (type.base t5)) + t4 base.type.Z + (UnderLets.UnderLets + base.type ident + var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr + (type.base + t4) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + args)%expr @ + x' v @ x1 @ + x'0 v0)%expr_pat + (fun + v1 : + var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (# + (ident.fst)%expr @ + ($v1)%expr, + (- + (# + (ident.snd)%expr @ + $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ + x2)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' + false s1 -> + Compile.value' + true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x4) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | + @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ + s0 _ (_ @ _)%expr_pat _ | @expr.App _ _ _ + s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + end + | ($_)%expr => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match x2 with + | @expr.App _ _ _ s0 _ #(idc1)%expr_pat x4 => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a with + | Some x' => + match + s0 as t4 + return + (Compile.value' false t4 -> + UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t4 => + fun + v1 : expr (type.base t4) + => + base.try_make_transport_cps + (fun t5 : base.type => + expr (type.base t5)) t4 + base.type.Z + (UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr + (type.base + t4) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + args)%expr @ + x' v0 @ x1 @ + x'0 v1)%expr_pat + (fun + v2 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v2)%expr, + (- + (#(ident.snd)%expr @ + $v2)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false + s1 -> + Compile.value' true + d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x4) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ + _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App + _ _ _ s0 _ (_ @ _)%expr_pat _ | @expr.App _ _ _ + s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | @expr.Abs _ _ _ _ _ _ => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match x2 with + | @expr.App _ _ _ s1 _ #(idc1)%expr_pat x4 => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => + expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr + (type.base base.type.Z)) + => + match a with + | Some x' => + match + s1 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun + v0 : expr (type.base t3) + => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr + (type.base + t3) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + args)%expr @ + x' v @ x1 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ + $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false + s2 -> + Compile.value' true + d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x4) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ + _ _ s1 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App + _ _ _ s1 _ (_ @ _)%expr_pat _ | @expr.App _ _ _ + s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s0 _ #(idc0)%expr_pat x4 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match f with + | #(idc1)%expr_pat => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => + expr (type.base t3)) t2 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) + => + match a with + | Some x' => + match + s0 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) + => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr + (type.base t3) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + args)%expr @ + x' v @ x2 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ + $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 + => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x4) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ x @ + x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | None => + match f with + | #(idc1)%expr_pat => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match x2 with + | @expr.App _ _ _ s1 _ #(idc2)%expr_pat x5 => + match + match idc2 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun v : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) => + match a with + | Some x' => + match + s1 as t4 + return + (Compile.value' false + t4 -> + UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t4 => + fun + v0 : expr + (type.base t4) + => + base.try_make_transport_cps + (fun t5 : base.type + => + expr (type.base t5)) + t4 base.type.Z + (UnderLets.UnderLets + base.type ident + var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr + (type.base + t4) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + args)%expr @ + x' v @ x1 @ + x'0 v0)%expr_pat + (fun + v1 : + var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (# + (ident.fst)%expr @ + ($v1)%expr, + (- + (# + (ident.snd)%expr @ + $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ + x2)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' + false s2 -> + Compile.value' + true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x5) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | + @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ + s1 _ (_ @ _)%expr_pat _ | @expr.App _ _ _ + s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + end + | @expr.App _ _ _ s0 _ ($_)%expr _ => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match x2 with + | @expr.App _ _ _ s1 _ #(idc1)%expr_pat x5 => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a with + | Some x' => + match + s1 as t4 + return + (Compile.value' false t4 -> + UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t4 => + fun + v1 : expr (type.base t4) + => + base.try_make_transport_cps + (fun t5 : base.type => + expr (type.base t5)) t4 + base.type.Z + (UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr + (type.base + t4) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + args)%expr @ + x' v0 @ x1 @ + x'0 v1)%expr_pat + (fun + v2 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v2)%expr, + (- + (#(ident.snd)%expr @ + $v2)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false + s2 -> + Compile.value' true + d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x5) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ + _ _ s1 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App + _ _ _ s1 _ (_ @ _)%expr_pat _ | @expr.App _ _ _ + s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _ => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match x2 with + | @expr.App _ _ _ s2 _ #(idc1)%expr_pat x5 => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => + expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr + (type.base base.type.Z)) + => + match a with + | Some x' => + match + s2 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun + v0 : expr (type.base t3) + => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr + (type.base + t3) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + args)%expr @ + x' v @ x1 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ + $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s3 -> d3)%ptype => + fun + _ : Compile.value' false + s3 -> + Compile.value' true + d3 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x5) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s3 -> d3)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d3 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s2 _ ($_)%expr _ | @expr.App _ + _ _ s2 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App + _ _ _ s2 _ (_ @ _)%expr_pat _ | @expr.App _ _ _ + s2 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat _ => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match x2 with + | @expr.App _ _ _ s2 _ #(idc1)%expr_pat x6 => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => + expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr + (type.base base.type.Z)) + => + match a with + | Some x' => + match + s2 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun + v0 : expr (type.base t3) + => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr + (type.base + t3) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + args)%expr @ + x' v @ x1 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ + $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s3 -> d3)%ptype => + fun + _ : Compile.value' false + s3 -> + Compile.value' true + d3 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x6) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s3 -> d3)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d3 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s2 _ ($_)%expr _ | @expr.App _ + _ _ s2 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App + _ _ _ s2 _ (_ @ _)%expr_pat _ | @expr.App _ _ _ + s2 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match x2 with + | @expr.App _ _ _ s1 _ #(idc1)%expr_pat x6 => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => + expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr + (type.base base.type.Z)) + => + match a with + | Some x' => + match + s1 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun + v0 : expr (type.base t3) + => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr + (type.base + t3) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + args)%expr @ + x' v @ x1 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ + $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false + s2 -> + Compile.value' true + d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x6) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ + _ _ s1 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App + _ _ _ s1 _ (_ @ _)%expr_pat _ | @expr.App _ _ _ + s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | @expr.LetIn _ _ _ _ _ _ _ => + match f with + | #(idc0)%expr_pat => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match x2 with + | @expr.App _ _ _ s0 _ #(idc1)%expr_pat x5 => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => + expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr + (type.base base.type.Z)) + => + match a with + | Some x' => + match + s0 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun + v0 : expr (type.base t3) + => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets + base.type ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr + (type.base + t3) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + args)%expr @ + x' v @ x1 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ + $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false + s1 -> + Compile.value' true + d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x5) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ + x @ x0 @ x1 @ x2)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ + _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App + _ _ _ s0 _ (_ @ _)%expr_pat _ | @expr.App _ _ _ + s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + end + | _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x2 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + if (args0 =? 0) && (args1 =? 0) + then + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete args)%expr @ x0 @ + x1 @ x2)%expr_pat + end + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end +| ident.Z_add_with_get_carry_concrete s => + fun x x0 x1 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + (let + '(a, b) := + Definitions.Z.add_with_get_carry_full s args + args0 args1 in + (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s0 _ #(idc)%expr_pat x2 => + match match idc with + | ident.Z_opp => Some tt + | _ => None + end with + | Some _ => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x1 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + match + s0 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) + => + match a0 with + | Some x'0 => + if args1 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ + x'0 v0 @ x0 @ + ##((- args1)%Z)%expr)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ + $v1)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ + x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ + x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x1 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + end + | ($_)%expr => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v0 @ x1 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v1)%expr, + (- + (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | @expr.Abs _ _ _ _ _ _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x1 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | @expr.App _ _ _ s1 _ #(idc1)%expr_pat x3 => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s1 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ + $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ + x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x1 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + end + | @expr.App _ _ _ s1 _ ($_)%expr _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v0 @ x1 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v1)%expr, + (- + (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | @expr.App _ _ _ s1 _ (@expr.Abs _ _ _ _ _ _) _ | + @expr.App _ _ _ s1 _ (_ @ _)%expr_pat _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x1 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | @expr.App _ _ _ s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x1 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | @expr.LetIn _ _ _ _ _ _ _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x1 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + end + | None => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s1 _ #(idc1)%expr_pat x3 => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s1 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ + $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ + x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s1 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + end + | ($_)%expr => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t2 v0 => + match + t2 as t3 return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args0 => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v0 @ x0 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v1)%expr, + (- + (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s1 _ #(idc0)%expr_pat x3 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s1 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v1 : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v0 @ x0 @ + x'0 v1)%expr_pat + (fun + v2 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v2)%expr, + (- + (#(ident.snd)%expr @ $v2)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s1 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end + | @expr.Abs _ _ _ _ _ _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s2 _ #(idc0)%expr_pat x3 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s2 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s2 _ ($_)%expr _ | @expr.App _ _ _ s2 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s2 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s2 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end + | @expr.App _ _ _ s1 _ #(idc0)%expr_pat x3 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s1 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x1 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x3) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s2 _ #(idc1)%expr_pat x4 => + match + match idc1 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s2 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ + $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ + x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x4) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s2 _ ($_)%expr _ | @expr.App _ _ _ s2 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s2 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s2 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + end + | @expr.App _ _ _ s1 _ ($_)%expr _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t2 v0 => + match + t2 as t3 return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args0 => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v0 @ x0 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v1)%expr, + (- + (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s2 _ #(idc0)%expr_pat x4 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s2 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v1 : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v0 @ x0 @ + x'0 v1)%expr_pat + (fun + v2 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v2)%expr, + (- + (#(ident.snd)%expr @ $v2)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x4) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s2 _ ($_)%expr _ | @expr.App _ _ _ s2 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s2 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s2 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end + | @expr.App _ _ _ s1 _ (@expr.Abs _ _ _ _ _ _) _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s3 _ #(idc0)%expr_pat x4 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s3 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s4 -> d3)%ptype => + fun + _ : Compile.value' false s4 -> + Compile.value' true d3 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x4) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s4 -> d3)%ptype => + fun + _ : Compile.value' false s4 -> + Compile.value' true d3 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s3 _ ($_)%expr _ | @expr.App _ _ _ s3 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s3 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s3 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end + | @expr.App _ _ _ s1 _ (_ @ _)%expr_pat _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s3 _ #(idc0)%expr_pat x5 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s3 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s4 -> d3)%ptype => + fun + _ : Compile.value' false s4 -> + Compile.value' true d3 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x5) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s4 -> d3)%ptype => + fun + _ : Compile.value' false s4 -> + Compile.value' true d3 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s3 _ ($_)%expr _ | @expr.App _ _ _ s3 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s3 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s3 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end + | @expr.App _ _ _ s1 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s2 _ #(idc0)%expr_pat x5 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s2 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x5) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s3 -> d2)%ptype => + fun + _ : Compile.value' false s3 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s2 _ ($_)%expr _ | @expr.App _ _ _ s2 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s2 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s2 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end + | @expr.LetIn _ _ _ _ _ _ _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + if args0 <=? 0 + then + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + ##((- args0)%Z)%expr)%expr_pat + (fun + v0 : var + (type.base + (base.type.Z * base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- + (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + else + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s1 -> d0)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d0 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s1 _ #(idc0)%expr_pat x4 => + match + match idc0 with + | ident.Z_opp => Some tt + | _ => None + end + with + | Some _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s1 as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.UnderLet + (#(ident.Z_sub_with_get_borrow_concrete + s)%expr @ x' v @ x0 @ + x'0 v0)%expr_pat + (fun + v1 : var + (type.base + (base.type.Z * + base.type.Z)%etype) + => + UnderLets.Base + (#(ident.fst)%expr @ + ($v1)%expr, + (- + (#(ident.snd)%expr @ $v1)%expr_pat)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete + s)%expr @ x @ x0 @ x1)%expr_pat + end (Compile.reflect x4) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end) + | (s2 -> d1)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end (Compile.reflect x2) + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s1 _ ($_)%expr _ | @expr.App _ _ _ s1 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s1 _ + (_ @ _)%expr_pat _ | @expr.App _ _ _ s1 _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end + end + | None => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + end + | @expr.App _ _ _ s0 _ ($_)%expr _ | @expr.App _ _ _ s0 _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s0 _ (_ @ _)%expr_pat _ | + @expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + | _ => + UnderLets.Base + (#(ident.Z_add_with_get_carry_concrete s)%expr @ x @ x0 @ x1)%expr_pat + end +| ident.Z_sub_get_borrow => + fun x x0 x1 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + (let + '(a, b) := + Definitions.Z.sub_get_borrow_full args args0 + args1 in (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete args)%expr @ + x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete args)%expr @ x0 @ + x1)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete args)%expr @ x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete args)%expr @ x0 @ x1)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_sub_get_borrow)%expr @ x @ x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_sub_get_borrow)%expr @ x @ x0 @ x1)%expr_pat + end +| ident.Z_sub_get_borrow_concrete s => + fun x x0 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + UnderLets.Base + (let + '(a, b) := + Definitions.Z.sub_get_borrow_full s args args0 in + (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ x0)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ x0)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ x0)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_sub_get_borrow_concrete s)%expr @ x @ x0)%expr_pat + end +| ident.Z_sub_with_get_borrow => + fun x x0 x1 x2 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + match x2 with + | #(idc2)%expr_pat => + match + match idc2 with + | @ident.Literal t3 v => + match + t3 as t4 + return + (base.base_interp t4 -> option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args2 => + UnderLets.Base + (let + '(a, b) := + Definitions.Z.sub_with_get_borrow_full + args args0 args1 args2 in + (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete + args)%expr @ x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete args)%expr @ + x0 @ x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete args)%expr @ x0 @ + x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete args)%expr @ x0 @ + x1 @ x2)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end +| ident.Z_sub_with_get_borrow_concrete s => + fun x x0 x1 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + (let + '(a, b) := + Definitions.Z.sub_with_get_borrow_full s args + args0 args1 in + (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ + x @ x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ x @ + x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ x @ x0 @ + x1)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ x @ x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_sub_with_get_borrow_concrete s)%expr @ x @ x0 @ x1)%expr_pat + end +| ident.Z_zselect => + fun x x0 x1 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + ##(Definitions.Z.zselect args args0 args1)%expr + | None => + UnderLets.Base + (#(ident.Z_zselect)%expr @ x @ x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_zselect)%expr @ x @ x0 @ x1)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_zselect)%expr @ x @ x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_zselect)%expr @ x @ x0 @ x1)%expr_pat + end + | None => + UnderLets.Base (#(ident.Z_zselect)%expr @ x @ x0 @ x1)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_zselect)%expr @ x @ x0 @ x1)%expr_pat + end +| ident.Z_add_modulo => + fun x x0 x1 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + ##(Definitions.Z.add_modulo args args0 args1)%expr + | None => + UnderLets.Base + (#(ident.Z_add_modulo)%expr @ x @ x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_modulo)%expr @ x @ x0 @ x1)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_modulo)%expr @ x @ x0 @ x1)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_add_modulo)%expr @ x @ x0 @ x1)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_add_modulo)%expr @ x @ x0 @ x1)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_add_modulo)%expr @ x @ x0 @ x1)%expr_pat + end +| ident.Z_rshi => + fun x x0 x1 x2 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + match x2 with + | #(idc2)%expr_pat => + match + match idc2 with + | @ident.Literal t3 v => + match + t3 as t4 + return + (base.base_interp t4 -> option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args2 => + UnderLets.Base + ##(Definitions.Z.rshi args args0 args1 + args2)%expr + | None => + UnderLets.Base + (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ + x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + | None => + match x2 with + | #(idc2)%expr_pat => + match + match idc2 with + | @ident.Literal t3 v => + match + t3 as t4 + return + (base.base_interp t4 -> option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + (#(ident.Z_rshi_concrete args args1)%expr @ + x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ + x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + end + | ($_)%expr => + match x2 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t3 v0 => + match + t3 as t4 + return (base.base_interp t4 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args1 => + UnderLets.Base + (#(ident.Z_rshi_concrete args args1)%expr @ + x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + | _ => + match x2 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + (#(ident.Z_rshi_concrete args args1)%expr @ + x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + end + | None => + match x2 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + UnderLets.Base + (#(ident.Z_rshi_concrete args args0)%expr @ x0 @ + x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + end + | ($_)%expr => + match x2 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t2 v0 => + match + t2 as t3 return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v1 : Z => Some v1 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v0 + | _ => None + end + with + | Some args0 => + UnderLets.Base + (#(ident.Z_rshi_concrete args args0)%expr @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + | _ => + match x2 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + UnderLets.Base + (#(ident.Z_rshi_concrete args args0)%expr @ x0 @ x1)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + end + | None => + UnderLets.Base (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_rshi)%expr @ x @ x0 @ x1 @ x2)%expr_pat + end +| ident.Z_rshi_concrete s offset => + fun x x0 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + UnderLets.Base + ##(Definitions.Z.rshi s args args0 offset)%expr + | None => + UnderLets.Base + (#(ident.Z_rshi_concrete s offset)%expr @ x @ x0)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_rshi_concrete s offset)%expr @ x @ x0)%expr_pat + end + | None => + UnderLets.Base + (#(ident.Z_rshi_concrete s offset)%expr @ x @ x0)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_rshi_concrete s offset)%expr @ x @ x0)%expr_pat + end +| ident.Z_cc_m => + fun x x0 : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + match x0 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + UnderLets.Base ##(Definitions.Z.cc_m args args0)%expr + | None => + UnderLets.Base + (#(ident.Z_cc_m_concrete args)%expr @ x0)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.Z_cc_m_concrete args)%expr @ x0)%expr_pat + end + | None => UnderLets.Base (#(ident.Z_cc_m)%expr @ x @ x0)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_cc_m)%expr @ x @ x0)%expr_pat + end +| ident.Z_cc_m_concrete s => + fun x : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => UnderLets.Base ##(Definitions.Z.cc_m s args)%expr + | None => + UnderLets.Base (#(ident.Z_cc_m_concrete s)%expr @ x)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_cc_m_concrete s)%expr @ x)%expr_pat + end +| ident.Z_neg_snd => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + match x with + | ($_)%expr => + UnderLets.UnderLet x + (fun v0 : var (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | @expr.App _ _ _ s _ ($_)%expr _ => + UnderLets.UnderLet x + (fun v0 : var (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ #(idc)%expr_pat x1) x0 => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x0 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + (##(args0)%expr, ##((- args1)%Z)%expr)%expr_pat + | None => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) => + match a0 with + | Some x'0 => + UnderLets.Base + (x' v, (- x'0 v0)%expr)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ + x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x1) + end + | ($_)%expr => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v1 : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.Base + (x' v0, (- x'0 v1)%expr)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x1) + | @expr.LetIn _ _ _ _ _ _ _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.Base + (x' v, (- x'0 v0)%expr)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x1) + | _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.Base + (x' v, (- x'0 v0)%expr)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x1) + end + | None => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + UnderLets.Base + (x' v, (- x'0 v0)%expr)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x1) + end + | ($_)%expr => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v1 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) + t3 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr (type.base base.type.Z)) => + match a0 with + | Some x'0 => + UnderLets.Base + (x' v0, (- x'0 v1)%expr)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 + => UnderLets.Base (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x1) + | @expr.LetIn _ _ _ _ _ _ _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) + t3 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr (type.base base.type.Z)) => + match a0 with + | Some x'0 => + UnderLets.Base + (x' v, (- x'0 v0)%expr)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 + => UnderLets.Base (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x1) + | _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) + t3 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr (type.base base.type.Z)) => + match a0 with + | Some x'0 => + UnderLets.Base + (x' v, (- x'0 v0)%expr)%expr_pat + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end) + | (s2 -> d2)%ptype => + fun _ : Compile.value' false s2 -> Compile.value' true d2 + => UnderLets.Base (#(ident.Z_neg_snd)%expr @ x)%expr_pat + end (Compile.reflect x1) + end + | None => + UnderLets.UnderLet x + (fun v : var (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + end + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ ($_)%expr _) _ => + UnderLets.UnderLet x + (fun v0 : var (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base + (#(ident.fst)%expr @ ($v0)%expr, + (- (#(ident.snd)%expr @ $v0)%expr_pat)%expr)%expr_pat) + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _) + _ | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ (_ @ _)%expr_pat _) _ | + @expr.App _ _ _ s _ + (@expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _) _ => + UnderLets.UnderLet x + (fun v : var (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + | @expr.App _ _ _ s _ #(_)%expr_pat _ | @expr.App _ _ _ s _ + (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.UnderLet x + (fun v : var (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + | _ => + UnderLets.UnderLet x + (fun v : var (type.base (base.type.Z * base.type.Z)%etype) => + UnderLets.Base + (#(ident.fst)%expr @ ($v)%expr, + (- (#(ident.snd)%expr @ $v)%expr_pat)%expr)%expr_pat) + end +| ident.Z_cast range => + fun x : expr (type.base base.type.Z) => + match x with + | #(idc)%expr_pat => + match + match idc with + | @ident.Literal t0 v => + match t0 as t1 return (base.base_interp t1 -> option Z) with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args => + UnderLets.Base + ##(ident.cast ident.cast_outside_of_range range args)%expr + | None => UnderLets.Base (#(ident.Z_cast range)%expr @ x)%expr_pat + end + | _ => UnderLets.Base (#(ident.Z_cast range)%expr @ x)%expr_pat + end +| ident.Z_cast2 range => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + match x with + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ #(idc)%expr_pat x1) x0 => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x0 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + (let + '(a, b) := + (let (r1, r2) := range in + fun '(x2, x3) => + (ident.cast ident.cast_outside_of_range r1 + x2, + ident.cast ident.cast_outside_of_range r2 x3)) + (args0, args1) in + (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) + t2 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 + base.type.Z + (UnderLets.UnderLets base.type + ident var + (expr + (type.base + (base.type.Z * + base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base + base.type.Z)) => + match a0 with + | Some x'0 => + (fv <-- do_again + (base.type.Z * + base.type.Z) + (#(ident.Z_cast + (fst range))%expr @ + ($(x' v))%expr, + #(ident.Z_cast + (snd range))%expr @ + ($(x'0 v0))%expr)%expr_pat; + UnderLets.Base + (id (id fv)))%under_lets + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ + x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x1) + end + | ($_)%expr => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t3 : base.type => expr (type.base t3)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v1 : expr (type.base t3) => + base.try_make_transport_cps + (fun t4 : base.type => + expr (type.base t4)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + (fv <-- do_again + (base.type.Z * + base.type.Z) + (#(ident.Z_cast + (fst range))%expr @ + ($(x' v0))%expr, + #(ident.Z_cast + (snd range))%expr @ + ($(x'0 v1))%expr)%expr_pat; + UnderLets.Base (id (id fv)))%under_lets + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ + x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x1) + | @expr.LetIn _ _ _ _ _ _ _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + (fv <-- do_again + (base.type.Z * + base.type.Z) + (#(ident.Z_cast + (fst range))%expr @ + ($(x' v))%expr, + #(ident.Z_cast + (snd range))%expr @ + ($(x'0 v0))%expr)%expr_pat; + UnderLets.Base (id (id fv)))%under_lets + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ + x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x1) + | _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident + var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr + (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + (fv <-- do_again + (base.type.Z * + base.type.Z) + (#(ident.Z_cast + (fst range))%expr @ + ($(x' v))%expr, + #(ident.Z_cast + (snd range))%expr @ + ($(x'0 v0))%expr)%expr_pat; + UnderLets.Base (id (id fv)))%under_lets + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ + x)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x1) + end + | None => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => + expr (type.base t1)) t3 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr (type.base base.type.Z)) + => + match a0 with + | Some x'0 => + (fv <-- do_again + (base.type.Z * + base.type.Z) + (#(ident.Z_cast + (fst range))%expr @ + ($(x' v))%expr, + #(ident.Z_cast + (snd range))%expr @ + ($(x'0 v0))%expr)%expr_pat; + UnderLets.Base (id (id fv)))%under_lets + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x1) + end + | ($_)%expr => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v0 : expr (type.base t2) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v1 : expr (type.base t3) => + base.try_make_transport_cps + (fun t1 : base.type => expr (type.base t1)) + t3 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr (type.base base.type.Z)) => + match a0 with + | Some x'0 => + (fv <-- do_again + (base.type.Z * base.type.Z) + (#(ident.Z_cast (fst range))%expr @ + ($(x' v0))%expr, + #(ident.Z_cast (snd range))%expr @ + ($(x'0 v1))%expr)%expr_pat; + UnderLets.Base (id (id fv)))%under_lets + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 + => + UnderLets.Base (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x1) + | @expr.LetIn _ _ _ _ _ _ _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) + t3 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr (type.base base.type.Z)) => + match a0 with + | Some x'0 => + (fv <-- do_again + (base.type.Z * base.type.Z) + (#(ident.Z_cast (fst range))%expr @ + ($(x' v))%expr, + #(ident.Z_cast (snd range))%expr @ + ($(x'0 v0))%expr)%expr_pat; + UnderLets.Base (id (id fv)))%under_lets + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun + _ : Compile.value' false s1 -> + Compile.value' true d1 => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end) + | (s1 -> d1)%ptype => + fun _ : Compile.value' false s1 -> Compile.value' true d1 + => + UnderLets.Base (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x1) + | _ => + match + s0 as t2 + return + (Compile.value' false t2 -> + UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + with + | type.base t2 => + fun v : expr (type.base t2) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) t2 + base.type.Z + (UnderLets.UnderLets base.type ident var + (expr (type.base (base.type.Z * base.type.Z)%etype))) + (fun + a : option + (expr (type.base t2) -> + expr (type.base base.type.Z)) => + match a with + | Some x' => + match + s as t3 + return + (Compile.value' false t3 -> + UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + with + | type.base t3 => + fun v0 : expr (type.base t3) => + base.try_make_transport_cps + (fun t0 : base.type => expr (type.base t0)) + t3 base.type.Z + (UnderLets.UnderLets base.type ident var + (expr + (type.base + (base.type.Z * base.type.Z)%etype))) + (fun + a0 : option + (expr (type.base t3) -> + expr (type.base base.type.Z)) => + match a0 with + | Some x'0 => + (fv <-- do_again + (base.type.Z * base.type.Z) + (#(ident.Z_cast (fst range))%expr @ + ($(x' v))%expr, + #(ident.Z_cast (snd range))%expr @ + ($(x'0 v0))%expr)%expr_pat; + UnderLets.Base (id (id fv)))%under_lets + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end) + | (s2 -> d2)%ptype => + fun + _ : Compile.value' false s2 -> + Compile.value' true d2 => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x0) + | None => + UnderLets.Base + (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end) + | (s2 -> d2)%ptype => + fun _ : Compile.value' false s2 -> Compile.value' true d2 + => + UnderLets.Base (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end (Compile.reflect x1) + end + | None => UnderLets.Base (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end + | @expr.App _ _ _ s _ (@expr.App _ _ _ s0 _ ($_)%expr _) _ | @expr.App _ + _ _ s _ (@expr.App _ _ _ s0 _ (@expr.Abs _ _ _ _ _ _) _) _ | @expr.App + _ _ _ s _ (@expr.App _ _ _ s0 _ (_ @ _)%expr_pat _) _ | @expr.App _ _ _ + s _ (@expr.App _ _ _ s0 _ (@expr.LetIn _ _ _ _ _ _ _) _) _ => + UnderLets.Base (#(ident.Z_cast2 range)%expr @ x)%expr_pat + | @expr.App _ _ _ s _ #(_)%expr_pat _ | @expr.App _ _ _ s _ ($_)%expr _ | + @expr.App _ _ _ s _ (@expr.Abs _ _ _ _ _ _) _ | @expr.App _ _ _ s _ + (@expr.LetIn _ _ _ _ _ _ _) _ => + UnderLets.Base (#(ident.Z_cast2 range)%expr @ x)%expr_pat + | _ => UnderLets.Base (#(ident.Z_cast2 range)%expr @ x)%expr_pat + end +| ident.fancy_add log2wordmax imm => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + match x with + | (#(idc) @ x1 @ x0)%expr_pat => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x0 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + (let + '(a, b) := + ident.fancy.interp + (invert_Some + (ident.to_fancy + (ident.fancy_add log2wordmax imm))) + (args0, args1) in + (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.fancy_add log2wordmax imm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_add log2wordmax imm)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_add log2wordmax imm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_add log2wordmax imm)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_add log2wordmax imm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base (#(ident.fancy_add log2wordmax imm)%expr @ x)%expr_pat + end +| ident.fancy_addc log2wordmax imm => + fun x : expr (type.base (base.type.Z * base.type.Z * base.type.Z)%etype) + => + match x with + | (#(idc) @ x1 @ x0)%expr_pat => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x1 with + | (#(idc0) @ x3 @ x2)%expr_pat => + match + match idc0 with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x3 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + match x2 with + | #(idc2)%expr_pat => + match + match idc2 with + | @ident.Literal t3 v => + match + t3 as t4 + return + (base.base_interp t4 -> option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args2 => + match x0 with + | #(idc3)%expr_pat => + match + match idc3 with + | @ident.Literal t4 v => + match + t4 as t5 + return + (base.base_interp t5 -> + option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => + fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => + fun _ : nat => None + end v + | _ => None + end + with + | Some args3 => + UnderLets.Base + (let + '(a, b) := + ident.fancy.interp + (invert_Some + (ident.to_fancy + (ident.fancy_addc + log2wordmax imm))) + (args1, args2, args3) in + (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.fancy_addc log2wordmax + imm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_addc log2wordmax imm)%expr @ + x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_addc log2wordmax imm)%expr @ + x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_addc log2wordmax imm)%expr @ + x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_addc log2wordmax imm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_addc log2wordmax imm)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_addc log2wordmax imm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_addc log2wordmax imm)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_addc log2wordmax imm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_addc log2wordmax imm)%expr @ x)%expr_pat + end +| ident.fancy_sub log2wordmax imm => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + match x with + | (#(idc) @ x1 @ x0)%expr_pat => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x0 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + (let + '(a, b) := + ident.fancy.interp + (invert_Some + (ident.to_fancy + (ident.fancy_sub log2wordmax imm))) + (args0, args1) in + (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.fancy_sub log2wordmax imm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_sub log2wordmax imm)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_sub log2wordmax imm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_sub log2wordmax imm)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_sub log2wordmax imm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base (#(ident.fancy_sub log2wordmax imm)%expr @ x)%expr_pat + end +| ident.fancy_subb log2wordmax imm => + fun x : expr (type.base (base.type.Z * base.type.Z * base.type.Z)%etype) + => + match x with + | (#(idc) @ x1 @ x0)%expr_pat => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x1 with + | (#(idc0) @ x3 @ x2)%expr_pat => + match + match idc0 with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x3 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + match x2 with + | #(idc2)%expr_pat => + match + match idc2 with + | @ident.Literal t3 v => + match + t3 as t4 + return + (base.base_interp t4 -> option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args2 => + match x0 with + | #(idc3)%expr_pat => + match + match idc3 with + | @ident.Literal t4 v => + match + t4 as t5 + return + (base.base_interp t5 -> + option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => + fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => + fun _ : nat => None + end v + | _ => None + end + with + | Some args3 => + UnderLets.Base + (let + '(a, b) := + ident.fancy.interp + (invert_Some + (ident.to_fancy + (ident.fancy_subb + log2wordmax imm))) + (args1, args2, args3) in + (##(a)%expr, ##(b)%expr)%expr_pat) + | None => + UnderLets.Base + (#(ident.fancy_subb log2wordmax + imm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_subb log2wordmax imm)%expr @ + x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_subb log2wordmax imm)%expr @ + x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_subb log2wordmax imm)%expr @ + x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_subb log2wordmax imm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_subb log2wordmax imm)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_subb log2wordmax imm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_subb log2wordmax imm)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_subb log2wordmax imm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_subb log2wordmax imm)%expr @ x)%expr_pat + end +| ident.fancy_mulll log2wordmax => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + match x with + | (#(idc) @ x1 @ x0)%expr_pat => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x0 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + ##(ident.fancy.interp + (invert_Some + (ident.to_fancy + (ident.fancy_mulll log2wordmax))) + (args0, args1)%core)%expr + | None => + UnderLets.Base + (#(ident.fancy_mulll log2wordmax)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_mulll log2wordmax)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_mulll log2wordmax)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_mulll log2wordmax)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_mulll log2wordmax)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base (#(ident.fancy_mulll log2wordmax)%expr @ x)%expr_pat + end +| ident.fancy_mullh log2wordmax => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + match x with + | (#(idc) @ x1 @ x0)%expr_pat => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x0 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + ##(ident.fancy.interp + (invert_Some + (ident.to_fancy + (ident.fancy_mullh log2wordmax))) + (args0, args1)%core)%expr + | None => + UnderLets.Base + (#(ident.fancy_mullh log2wordmax)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_mullh log2wordmax)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_mullh log2wordmax)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_mullh log2wordmax)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_mullh log2wordmax)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base (#(ident.fancy_mullh log2wordmax)%expr @ x)%expr_pat + end +| ident.fancy_mulhl log2wordmax => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + match x with + | (#(idc) @ x1 @ x0)%expr_pat => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x0 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + ##(ident.fancy.interp + (invert_Some + (ident.to_fancy + (ident.fancy_mulhl log2wordmax))) + (args0, args1)%core)%expr + | None => + UnderLets.Base + (#(ident.fancy_mulhl log2wordmax)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_mulhl log2wordmax)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_mulhl log2wordmax)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_mulhl log2wordmax)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_mulhl log2wordmax)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base (#(ident.fancy_mulhl log2wordmax)%expr @ x)%expr_pat + end +| ident.fancy_mulhh log2wordmax => + fun x : expr (type.base (base.type.Z * base.type.Z)%etype) => + match x with + | (#(idc) @ x1 @ x0)%expr_pat => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x1 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x0 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + ##(ident.fancy.interp + (invert_Some + (ident.to_fancy + (ident.fancy_mulhh log2wordmax))) + (args0, args1)%core)%expr + | None => + UnderLets.Base + (#(ident.fancy_mulhh log2wordmax)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_mulhh log2wordmax)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_mulhh log2wordmax)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_mulhh log2wordmax)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_mulhh log2wordmax)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base (#(ident.fancy_mulhh log2wordmax)%expr @ x)%expr_pat + end +| ident.fancy_rshi log2wordmax x => + fun x0 : expr (type.base (base.type.Z * base.type.Z)%etype) => + match x0 with + | (#(idc) @ x2 @ x1)%expr_pat => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x2 with + | #(idc0)%expr_pat => + match + match idc0 with + | @ident.Literal t1 v => + match + t1 as t2 return (base.base_interp t2 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args0 => + match x1 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + UnderLets.Base + ##(ident.fancy.interp + (invert_Some + (ident.to_fancy + (ident.fancy_rshi log2wordmax x))) + (args0, args1)%core)%expr + | None => + UnderLets.Base + (#(ident.fancy_rshi log2wordmax x)%expr @ x0)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_rshi log2wordmax x)%expr @ x0)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_rshi log2wordmax x)%expr @ x0)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_rshi log2wordmax x)%expr @ x0)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_rshi log2wordmax x)%expr @ x0)%expr_pat + end + | _ => + UnderLets.Base (#(ident.fancy_rshi log2wordmax x)%expr @ x0)%expr_pat + end +| ident.fancy_selc => + fun x : expr (type.base (base.type.Z * base.type.Z * base.type.Z)%etype) + => + match x with + | (#(idc) @ x1 @ x0)%expr_pat => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x1 with + | (#(idc0) @ x3 @ x2)%expr_pat => + match + match idc0 with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x3 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + match x2 with + | #(idc2)%expr_pat => + match + match idc2 with + | @ident.Literal t3 v => + match + t3 as t4 + return + (base.base_interp t4 -> option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args2 => + match x0 with + | #(idc3)%expr_pat => + match + match idc3 with + | @ident.Literal t4 v => + match + t4 as t5 + return + (base.base_interp t5 -> + option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => + fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => + fun _ : nat => None + end v + | _ => None + end + with + | Some args3 => + UnderLets.Base + ##(ident.fancy.interp + (invert_Some + (ident.to_fancy + ident.fancy_selc)) + (args1, args2, args3)%core)%expr + | None => + UnderLets.Base + (#(ident.fancy_selc)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_selc)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_selc)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_selc)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_selc)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_selc)%expr @ x)%expr_pat + end + | None => + UnderLets.Base (#(ident.fancy_selc)%expr @ x)%expr_pat + end + | _ => UnderLets.Base (#(ident.fancy_selc)%expr @ x)%expr_pat + end + | None => UnderLets.Base (#(ident.fancy_selc)%expr @ x)%expr_pat + end + | _ => UnderLets.Base (#(ident.fancy_selc)%expr @ x)%expr_pat + end +| ident.fancy_selm log2wordmax => + fun x : expr (type.base (base.type.Z * base.type.Z * base.type.Z)%etype) + => + match x with + | (#(idc) @ x1 @ x0)%expr_pat => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x1 with + | (#(idc0) @ x3 @ x2)%expr_pat => + match + match idc0 with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x3 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + match x2 with + | #(idc2)%expr_pat => + match + match idc2 with + | @ident.Literal t3 v => + match + t3 as t4 + return + (base.base_interp t4 -> option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args2 => + match x0 with + | #(idc3)%expr_pat => + match + match idc3 with + | @ident.Literal t4 v => + match + t4 as t5 + return + (base.base_interp t5 -> + option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => + fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => + fun _ : nat => None + end v + | _ => None + end + with + | Some args3 => + UnderLets.Base + ##(ident.fancy.interp + (invert_Some + (ident.to_fancy + (ident.fancy_selm + log2wordmax))) + (args1, args2, args3)%core)%expr + | None => + UnderLets.Base + (#(ident.fancy_selm log2wordmax)%expr @ + x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_selm log2wordmax)%expr @ + x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_selm log2wordmax)%expr @ + x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_selm log2wordmax)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_selm log2wordmax)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_selm log2wordmax)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_selm log2wordmax)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_selm log2wordmax)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_selm log2wordmax)%expr @ x)%expr_pat + end + | _ => UnderLets.Base (#(ident.fancy_selm log2wordmax)%expr @ x)%expr_pat + end +| ident.fancy_sell => + fun x : expr (type.base (base.type.Z * base.type.Z * base.type.Z)%etype) + => + match x with + | (#(idc) @ x1 @ x0)%expr_pat => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x1 with + | (#(idc0) @ x3 @ x2)%expr_pat => + match + match idc0 with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x3 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + match x2 with + | #(idc2)%expr_pat => + match + match idc2 with + | @ident.Literal t3 v => + match + t3 as t4 + return + (base.base_interp t4 -> option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args2 => + match x0 with + | #(idc3)%expr_pat => + match + match idc3 with + | @ident.Literal t4 v => + match + t4 as t5 + return + (base.base_interp t5 -> + option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => + fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => + fun _ : nat => None + end v + | _ => None + end + with + | Some args3 => + UnderLets.Base + ##(ident.fancy.interp + (invert_Some + (ident.to_fancy + ident.fancy_sell)) + (args1, args2, args3)%core)%expr + | None => + UnderLets.Base + (#(ident.fancy_sell)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_sell)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_sell)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_sell)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_sell)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_sell)%expr @ x)%expr_pat + end + | None => + UnderLets.Base (#(ident.fancy_sell)%expr @ x)%expr_pat + end + | _ => UnderLets.Base (#(ident.fancy_sell)%expr @ x)%expr_pat + end + | None => UnderLets.Base (#(ident.fancy_sell)%expr @ x)%expr_pat + end + | _ => UnderLets.Base (#(ident.fancy_sell)%expr @ x)%expr_pat + end +| ident.fancy_addm => + fun x : expr (type.base (base.type.Z * base.type.Z * base.type.Z)%etype) + => + match x with + | (#(idc) @ x1 @ x0)%expr_pat => + match + match idc with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x1 with + | (#(idc0) @ x3 @ x2)%expr_pat => + match + match idc0 with + | @ident.pair A B => Some (A, B) + | _ => None + end + with + | Some _ => + match x3 with + | #(idc1)%expr_pat => + match + match idc1 with + | @ident.Literal t2 v => + match + t2 as t3 + return (base.base_interp t3 -> option Z) + with + | base.type.unit => fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args1 => + match x2 with + | #(idc2)%expr_pat => + match + match idc2 with + | @ident.Literal t3 v => + match + t3 as t4 + return + (base.base_interp t4 -> option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => fun _ : nat => None + end v + | _ => None + end + with + | Some args2 => + match x0 with + | #(idc3)%expr_pat => + match + match idc3 with + | @ident.Literal t4 v => + match + t4 as t5 + return + (base.base_interp t5 -> + option Z) + with + | base.type.unit => + fun _ : unit => None + | base.type.Z => + fun v0 : Z => Some v0 + | base.type.bool => + fun _ : bool => None + | base.type.nat => + fun _ : nat => None + end v + | _ => None + end + with + | Some args3 => + UnderLets.Base + ##(ident.fancy.interp + (invert_Some + (ident.to_fancy + ident.fancy_addm)) + (args1, args2, args3)%core)%expr + | None => + UnderLets.Base + (#(ident.fancy_addm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_addm)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_addm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_addm)%expr @ x)%expr_pat + end + | None => + UnderLets.Base + (#(ident.fancy_addm)%expr @ x)%expr_pat + end + | _ => + UnderLets.Base + (#(ident.fancy_addm)%expr @ x)%expr_pat + end + | None => + UnderLets.Base (#(ident.fancy_addm)%expr @ x)%expr_pat + end + | _ => UnderLets.Base (#(ident.fancy_addm)%expr @ x)%expr_pat + end + | None => UnderLets.Base (#(ident.fancy_addm)%expr @ x)%expr_pat + end + | _ => UnderLets.Base (#(ident.fancy_addm)%expr @ x)%expr_pat + end +end + : Compile.value' true t |